PNDSD ROOT SET -SOURCE- 2040 15 JAN 81 22-2362 OP  92425-18064 2001 S 0122 &TIMS TABL INTFC              H0101 0ASMB,Q,C NAM TIM5,7 92425-16064 REV.2001 791213 * * NAME: TIM * SOURCE: 92425-18064 * RELOC : 92425-1X064 * PRGM: DICK LAMPMAN ************************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************************* EXT EXEC,RTCLN,ISN,.ENTR EXT ERROR ENT TIM A EQU 0 B EQU 1 SKP * * * COMMENTS ************************************************** * * THIS IS THE TABLE INTERFACE MODULE FOR THE 9580 SYSTEM * RESPONSIBLE FOR RETRIEVING DATA FROM SYSTEM AVAILABLE * MEMORY (SAM) AND RETURNING THE DATA OF INTEREST TO * THE REQUESTING DEVICE SUBROUTINE. THE PARAMETERS * IN THE CALLING SEQUENCE DETERMINE WHAT DATA IS TO * BE RETURNED AND HOW MUCH. THE DEVICE SUBROUTINE * IS RESPONSIBLE FOR KNOWING WHAT DATA IS IN THE TABLE * AND WHAT FORMAT IT IS IN. * THE PARAMETERS IN THE CALLING SEQUENCE ARE DEFINED AS * AS FOLLOWS: * IDTN = DEVICE TYPE NUMBER, UNIQUE FOR EACH DEVICE * IUN = UNIT NUMBER * IRW = 1(READ),2(WRITE),3(# UNITS) * IBUF= DEVICE SUBROUTINE BUFFER IN WHICH DATA IS TO * BE RETURNED. * IBL = IBUF LENGTH * N = ERROR INDICATOR, * WHERE: * 1 = DEVICE TYPE NOT EXISTENT IN TABLE * 2 = LENGTH OF REQUEST BUFFER IBL DOES NOT * JIBE WITH THE LENGTH OF THE RECORD SET. * 3 = UNIT # DOES NOT EXIST IN THE TABLE. * 4 = NO CLASS # * 5 = ILLEGAL IRW REQUEST # * * ERRORS ARE RECOVERABLE BY CHANGING THE ASCII TABLE * OR BY CHANGING THE TEST PROGRAM. * * SUBROUTINE TIM IS INCLUDED WITH EACH BASIC OVERLAY * IN ORDER TO ENA BLE EACH DEVICE SUBROUTINE THAT * NEEDS VARIABLE DATA TO ACCESS TABLE DATA. * * PRIOR TO USING THIS PROGRAM IT IS ASSUMED THAT THE * ALLOC PROGRAM HAS BEEN RUN. ALLOC IS THE PROGRAM THAT TAKES * THE ASCII FILE CONTAINING THE CONFIGURATION INFORMATION * AND PLACES IT IN SAM (SYSTEM AVAILABLE MEMORY). OF COURSE * THE DATA IN SAM IS BINARY. THE FORMAT OF THE TABLE IN * IS AS SHOWN IN THE FOLLOWING FIGURE. EACH TABLE IN SAM * IS LINKED BY THE FIRST IN THE TABLE WHICH IS THE CLASS * NUMBER FOR THE SUCCEEDING TABLE. THE LAST TABLE IN SAM * HAS THE FIRST WORD POINTING TO THE FIRST TABLE OF THE GROUP, * SO THAT WE HAVE IN A SENSE A CIRCULARLY LINKED LIST. * THE SECOND WORD OF THE TABLE CONTAINS THE ACTUAL LENGTH * OF THE TABLE, WITH THE MAXIMUM SIZE ANY ONE TABLE CAN BE * IS 130 WORDS. * * ----------------------------------------- * WORD 1 * CLASS # FOR NEXT TABLE IF ANY * * * (MAY POINT TO ITSELF) * * ----------------------------------------- * WORD 2 * LENGTH (MAXIMUM 130 WORDS) * * *---------------------------------------- * WORD 3 * DEVICE TYPE NUMBER * * *---------------------------------------- * WORD 4 * # UNITS * * *---------------------------------------* * WORD 5 * # OF ENTRIES * * *---------------------------------------* * WORD 6 * DATA AND INFO SIMILAR TO WORDS 3-5 * * *---------------------------------------* * * NOTE: WORDS 3-5 ARE HEADER INFORMATION FOR EACH DEVICE * * * COMMENTS RELATED TO THE PROGRAM, KEYED TO THE NUMBERS. * ****#1 * * * SOME ERROR CHECKING IS DONE TO VERIFY IRW IS CORRECT. * THE STATION NUMBER IS RETRIEVED VIA ISN AND THE CLASS * NUMBER FOR THE FIRST BUFFER IN SAM IS ALSO RETRIEVED * VIA "RTCLN". * ****#2 * RETRIEVE THE BUFFER WITH A CLASS GET REQUEST, USING _ * SUBROUTINE "GTBUF". LDT IS THE POINTER INTO IBC AND * IT IS INITIALIZED TO 3 TO POINT TO THE THIRD WORD SINCE * WORDS 1 AND 2 CONTAIN RESPECTIVELY THE CLASS NUMBER * FOR THE NEXT BUFFER IF ANY AND THE LENGTH OF THE BUFFER. * ****#3 * * AT THIS POINT WE BEGIN SEARCHING THRU THE BUFFER IBC TO * FIND THE DEVICE TYPE NUMBER (IDTN). THE FOLLOWING ALGORITHM * IS USED TO INDEX TO EACH IDTN IN THE TABLE: * * LDT(N) = [IBC(LDT(N-1) + 2) + 1] *[IBC(LDT(N-1)] + [LDT(N-1)+3] * A B C * * WHERE: LDT IS THE INDEX THAT IS UPDATED EACH TIME THRU LOOP(TM3). * A = THE NUMBER OF ENTRIES PLUS ONE FOR EACH UNIT NUMBER WORD. * B = THE NUMBER OF UNITS * C = THREE WORDS OF OVERHEAD FOR EACH DEVICE TYPE. * * IF AFTER COMPUTING EACH LDT IT IS DISCOVERED THAT THE VALUE * EXCEEDS THE TABLE LENGTH THE NEXT TABLE IS RETRIEVED FROM * SAM. * ****#4 * * THIS PORTION SEARCHES FOR THE UNIT NUMBER "IUN". * THE POINTER LDT AT THIS TIME POINTS TO THE * FIRST UNIT NUMBER OF A PARTICULAR DEVICE TYPE (IDTN) * AND THE COUNTER "IUCNT" IS INITIALIZED WITH * THE NUMBER OF UNITS ASSIGNED TO THE DEVICE TYPE. * IF THE UNIT NUMBER (IUN) IS NOT FOUND * A RETURN IS MADE TO THE CALLING ROUTINE WITH THE * THE ERROR FLAG (N) = -2. * THE ALGORITHM USED TO COMPUTE THE INDEX (LDT) FOR EACH * UNIT NUMBER IS: * * LDT(N) = LDT(N-1) +IUPTR + 1 * A B C * * WHERE: A = THE PREVIOUS INDEX TO A UNIT NUMBER. * B = THE NUMBER OF ENTRIES PER UNIT. * C = ONE WORD FOR UNIT # * * ****#5 * * HERE THE READ/WRITE INDICATOR (IRW) IS EXAMINED TO * DETERMINE WHICH DIRECTION DATA IS TO FLOW, AND IF * A WRITE (IRW = 2) WE GO TO TM16. IF A * READ THE DATA OF INTEREST IS TRANSFERRED TO THE * DEVICE SUBROUTINE BUFFER (IBUF). IN CASE THE DATA * OVERFLOWS INTO ANOTHER BUFFER A CLASS GET REQUEST (GTBUF) * IS MADE TO RETR4IEVE THE OTHER BUFFER. * ****#6 * * THIS IS THE WRITE SECTION, WITH THE ONLY DIFFERNCE FROM * THE READ REQUEST BEING THAT "ICL" IN THE GET REQUEST * HAS BIT 14 =0 TO INDICATE TO THE SYSTEM THAT WE WANT * TO RELEASE THE BUFFER BU RETAIN THE CLASS NUMBER. * OVERFLOWS ARE HANDLED PRETTY MUCH THE SAME WAY AS IN THE * READ REQUEST. * * * SAME #6 EXCEPT THIS IS FOR A WRITE REQUEST. SKP SPC 3 IDTN NOP IUN NOP IRW NOP IBUF NOP IBL NOP N NOP TIM NOP JSB .ENTR RETRIEVE PARAMETER ADDRESSES DEF IDTN CLA STA N,I STA IFND STA J ************************** # 1 PARAMETER CHECK AND INITIALIZATION * OF STATION #(ISTN) AND CLASS # (ICLAS). * SEE IF IRW IS < 0 OR > 3 * LDA IRW,I SZA,RSS JMP ERR5 SSA JMP ERR5 CMA,INA ADA .2 SSA JMP ERR5 JSB ISN GET STATION # DEF *+2 DEF IDMY STA ISTN JSB RTCLN GET CLASS # FOR STATION DEF *+3 DEF ISTN DEF ICLAS STA IFCLS SAVE FIRST CLASS # SZA,RSS IS CLASS # = 0 JMP ERR4 YES ERROR TM1 LDA .3 INITIALIZE LDT(POINTER FOR SEARCHING) STA LDT LDA IDTN,I DEVICE TYPE NUMBER STA ISV SEARCH VARIABLE * ************************* # 2 GET TABLES AND SEARCH FOR IDTN. * TM2 LDB ICLAS LDA IC1 MASK (BITS 13 1AND 14 SET) JSB GTBUF GET CLASS BUFFER JSB FOUND SEE IF IBC(LDT) = ISV JMP TM5 EUREKA!! * **************************** # 3 * TM3 LDA LDT CHECK IF NUMBER OF CPA .130 INITS IS CURRENT BUFFER JMP *+2 IF NOT, READ NEXT BUFFER JMP TM3A * LDB IBC SET CLASS# OF NEXT BUFFER STB ICLAS * LDA IC1 GET NEXT BUFFER JSB GTBUF * LDA .2 SET CURRENT LOCATION OF STA LDT DEVICBE TYPE TO PSEUDO LOCATION. * LDA .2 SET TO (FIRST DATA LOC.) - 1 * * TM3A ADA IBCPT GET NUMBER OF UNITS INA LDB A,I STB TEMP * LDB LDT CHECK IF NUMBER OF INB CPB .130 ENTRIES IS IN CURRENT BUFFER JMP *+2 IF NOT, READ NEXT BUFFER JMP TM3B * LDB IBC SET CLASS # OF NEXT BUFFER STB ICLAS * LDA IC1 GET NEXT BUFFER JSB GTBUF * CLB,INB SET CURRENT LOCATION OF STB LDT DEVICE TYPE TO PSEUDO LOCATION * LDB .2 SET TO (FIRST DATA LOC.) - 1 * TM3B ADB IBCPT FETCH NUMBER OF ENTRIES INB LDA B,I * INA ADJUST NUMBER OF ENTRIES CLB MPY TEMP STA TEMP ADA LDT ADA .3 LDT = TEMP +(LDT+3) STA LDT CMA,INA SEE IF LDT > LENGTH OF TABLE(IBC(2)) ADA IBC2 SSA,RSS JMP TM4 LDA LDT LDT = LDT - 128 ADA M128 STA LDT LDA IBC CPA IFCLS HAVE WE EXAMINED ALL CLASS BUFFERS? JMP ERR1 YES THEN IDTN DOES NOT EXIST IN CONFIG TABLE LDB IBC STB ICLAS JMP TM2 TRY AGAIN (READ IN ANOTHER BUFFER) TM4 JSB FOUND JMP TM5 FOUND IT THIS TIME JMP TM3 GO LOOP DE LOOP * * SKP SPC 3 * ************************** # 4 * DEVICE TYPE NUMBER HAS BEEN FOUND SO THEREFORE WE MUST * NOW FIND THE UNIT # AND ENTRIES * TM5 LDA LDT MAKE SURE LDT+1 .NE. 130 INA CPA .130 JMP *+2 JMP TM6 LDA IB130 STA IUCNT NUMBER OF UNITS LDB IBC STB ICLAS KEEP ICLAS CURRENT LDA IC1 JSB GTBUF LDA .4 SET POINTER TO FIRST UNIT NUMBER STA LDT LDB IBCPT ADB .3 PICK UP # OF ENTRIES LDA B,I STA IUPTR CPA IBL,I SEE IF IBL(BUFFER LENGTH) = #ENTRIES(SUBRECORDS) K  JMP TM10 JMP ERR2 TM6 LDA LDT SEE IF LDT = 130(END OF BUFFER). CPA .130 JMP *+2 JMP TM7 LDB IBC SINCE LDT= 130, THE INFORMATION WE NEED IS IN STB ICLAS LDA IC1 THE NEXT CLASS BUFFER JSB GTBUF LDA .2 SET LDT TO POINT TO IBC LENGTH WORD (IBC(2)) STA LDT TM7 LDB IBCPT ADB LDT COMPUTE IBC(LDT+2) AND IBC(LDT+1), #ENTRIES AND INB # UNITS RESPECTIVELY LDA B,I STA IUCNT INB LDA B,I STA IUPTR CPA IBL,I SEE IF IBL = #ENTRIES JMP *+2 JMP ERR2 LDA LDT LDT = LDT + 3, POINT IT TO FIRST UNIT # ADA .3 STA LDT * * TM10 LDA IRW,I SEE IF THIS IS A UNIT COUNT REQUEST ONLY CPA .3 JMP TM20 * LDA IUN,I SET UP UNIT# TO BE TESTED FOR. STA ISV * LDA IUCNT PRESET COUNTER FOR #UNITS + 1. CMA STA IFND * TM11 ISZ IFND TEST IF #UNITS HAS BEEN EXCEEDED. JMP *+2 JMP ERR3 * TM12 LDA LDT CHECK IF UNIT # IS IN CURRENT BUFFER. CMA,INA ADA IBC2 SSA,RSS JMP TM13 YES. UNIT# IS IN CURRENT BUFFER. * LDA LDT ADJUST UNIT# POINTER FOR POSISTION IN ADA M128 NEXT BUFFER. STA LDT * LDA IC1 READ NEXT BUFFER. LDB IBC (NOTE. ENTRIES FOR A UNIT MAY SPAN MORE STB ICLAS THAN ONE BUFFER.) JSB GTBUF JMP TM12 * TM13 JSB FOUND CHECK IF UNIT# IS RIGHT ONE. JMP TM14 YES. * LDA LDT INDEX TO NEXT UNIT# POSITION. ADA IUPTR INA STA LDT * JMP TM11 * SKP SPC 3 ************************ # 5 * AT THIS POINT THE UNIT # AND DEVICE TYPE HAVE BEEN FOUND * AND WE ARE READY TO TRANSFER DATA TO OR FROM THE CLASS * TABLES IN SAM. * TM14 ISZ LDT POINT LDT TO FIRST SUBRECORD ENTRY IN TABLE LDA IBL,I  INITIALIZE COUNTER CMA,INA STA TRCNT LDA IRW,I READ OR WRITE REQUEST? CPA .2 JMP TM16 WRITE REQUEST * * READ REQUEST * LDA IBUF INITIALIZE ADDRESS POINTERS STA TO TM15 LDA IBCPT ADA LDT STA FROM JSB TRFER BEGIN TO TRANSFER JMP TIM,I ALL DONE LDB IBC GET THE REST LDA IC1 JSB GTBUF CLA STA J RE-INIT POINTERS LDA .3 STA LDT JMP TM15 SPC 3 ********************** #6 * WRITE REQUEST * TM16 LDB ICLAS LDA IC2 (BIT 13 ONLY SET) RELEASE BUFFER,KEEP CLASS # JSB GTBUF LDA IBUF STA FROM TM17 LDA IBCPT ADA LDT STA TO JSB TRFER JMP TM18 * * CLASS READ/WRITE * LDA IBC STA TEMP SAVE CURRENT CLASS # JSB WRTBF LDB TEMP GET THE NEXT BUFFER STB ICLAS LDA IC2 JSB GTBUF CLA RE-INIT POINTERS STA J LDA .3 STA LDT JMP TM17 TM18 JSB WRTBF JMP TIM,I GET HAT TM20 LDA IUCNT STA IBUF,I JMP TIM,I * SKP SPC 3 * * SPECIAL SUBROUTINES THAT MAKE THE JOB OF ALL THE PREVIOUS * BIT CRUNCHING IN THIS ROUTINE EASIER. * ************************************************************** * ******CLASS GET REQUEST UPON ENTRY A=MASK B=CLASS # * GTBUF NOP IOR B A /\ B STA ICL JSB EXEC DEF RTG DEF .21 DEF ICL DEF IBC DEF .130 RTG JMP GTBUF,I * .21 DEC 21 .130 DEC 130 ICL NOP * SPC 2 * *CLASS READ/WRITE REQUEST * WRTBF NOP JSB EXEC DEF RTW DEF .20 DEF .0 DEF IBC DEF IBC+1 LENGTH DEF IDMY DEF JDMY DEF ICLAS RTW JMP WRTBF,I * .20 DEC 20 .0 OCT 0 IDMY NOP JDMY NOP ICLAS NOP * SPC 2 * * 0.*MATCH CHECKING ROUTINE WHICH SEES WHETHER IBC(LDT) = ISV * WHERE ISV IS EITHER THE IDTN OR THE IUN. * * IF A MATCH RETURN IS P+1 * IF NO MATCH RETURN IS P+2 * FOUND NOP LDB IBCPT ADB LDT LDA B,I CPA ISV JMP FOUND,I ISZ FOUND JMP FOUND,I * SPC 2 * * DATA TRANSFER ROUTINE, TAKES DATA FROM ONE LOCATION(FROM) * AND TRANSFERS IT TO ANOTHER (TO). * P+1 RETURN INDICATES ALL DATA TRANSFERRED * P+2 RETURN " MORE TO GO * !!ATTENTION!! ZERO WORDS CANNOT MOVED.(IE TRCNT.NE.0) * TRFER NOP * TRLOP LDA J CHECK IF WORD ABOUT TO BE MOVED ADA LDT IS IN CURRENT BUFFER. CMA,INA ADA IBC2 SSA,RSS JMP *+3 * ISZ TRFER RETURN TO GET NEXT BUFFER. JMP TRFER,I * LDA FROM,I MOVE DATA WORD. STA TO,I * ISZ J SET POINTER TO NEXT WORD. ISZ FROM ISZ TO * ISZ TRCNT CHECK IF ALL WORDS HAVE BEEN MOVED. JMP TRLOP * JMP TRFER,I MAKE "FINISHED (P+1)" RETURN. * FROM NOP TO NOP J NOP TRCNT NOP SKP SPC 3 * * ERROR MESSAGES * ERR5 ISZ N,I ERR4 ISZ N,I ERR3 ISZ N,I ERR2 ISZ N,I ERR1 ISZ N,I JSB ERROR DEF *+3 DEF N,I DEF IERMS JMP TIM,I * IERMS DEC 5 ASC 3,TIM * SPC 3 * * STORAGE, CONSTANTS ETC * IBC BSS 130 IFND NOP .3 DEC 3 IBC2 EQU IBC+1 IBCPT DEF IBC-1 IB130 EQU IBC+129 .4 DEC 4 .2 DEC 2 IUCNT NOP IUPTR NOP IC1 OCT 60000 IC2 OCT 20000 ISV NOP TEMP NOP IFCLS NOP ISTN NOP M128 DEC -128 LDT NOP END fT0   92425-18065 2001 S 0122 &PUTID PRODIDSEG              H0101 lASMB,Q,C NAM PUTID,7 92425-1X065 REV.2001 791218 * NAME: PUTID * SOURCE: 92425-18065 * RELOCE: 92425-1X065 * RELOC: XXXXX-XXXXX * PRGM: DICK LAMPMAN ************************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************************* ENT PUTID EXT IDRPL,IDDUP,IDSGA,.DFER EXT .ENTR,FSTAT,LOPEN EXT LCLOS EXT .XLA A EQU 0 B EQU 1 XEQT EQU 1717B SECT3 EQU 1760B * * THIS SUBROUTINE WILL DO WHATEVER IS NECESSARY * TO MAKE A PROGRAM SCHEDULEABLE BY AN EXEC CALL. * THE PROGRAM WILL BE RENAMED WITH TERMINAL LU * AS THE LAST 2 CHARACTERS OF THE NAME IF THE * ID SESSION BIT OF THE CALLING PROGRAM IS SET * AND THE "IH" FLAG IS NOT SET UNLESS THE PROGRAM * TO BE SCHEDULED IS A NON-DUPLICATABLE PROGRAM. * (NOT SET UP AS TYPE 6 FILE OR IF ID-SEGMENT IS * IN CORE, ID SEGMENT WAS NOT SET UP BY ":RP") * * CALLING SEQUENCE: * CALL PUTID(IDCB,IERR,NAME,LU,IRPFLG) * * WHERE: * IDCB= 144 WORD FMGR DCB BUFFER FOR SUBROUTINE USE * IERR= FMGR ERROR RETURN VARIABLE * NAME= 6-ELEMENT ARRAY AS FOLLOWS: * * NAME(1-3)= PROGRAM NAME * NAME(4)= NOT USED FOR * "NAMR" COMPATABILITY. * NAME(5)= TYPE 6 FILE SECURITY * IF "IH", INHIBIT RENAMING. * NAME(6)= TYPE 6 FILE CRN * IF "0", SEARCH LU 2,3 * NAME(1-3) WILL BE CHANGED BY PUTID * TO THE APPROPRIATE S6ESSION NAME * IF SESSION CONDITIONS ARE MET. * LU= TERMINAL LU * IRPFLG= NON-ZERO IF CALLING PROGRAM * SHOULD RELEASE PROGRAM'S ID * SEGMENT (CALL IDRPD) AFTER PROGRAM * HAS COMPLETED. * HED FORTRAN EXAMPLE * FORTRAN EXAMPLE: * FTN4,L * PROGRAM RPTST(3,1000) * DIMENSION NAME(13),IBUF(10),IDCB(144) * C GET TERMINAL LU (ITMLU MUST BE CALLED FIRST!) * LU=ITMLU(IDMY) * WRITE (LU,10000) * 10000 FORMAT ("ENTER PROGRAM NAMR") * READ (LU,10100)NAME * 10100 FORMAT (13A2) * C * C PARSE USING NAMR * C * IST=1 * IEND=26 * CALL NAMR(IBUF,NAME,IEND,IST) * CALL PUTID(IDCB,IERR,IBUF,LU,IRP) * IF (IERR .NE. 0) GO TO 9000 * C * C SCHEDULE PROGRAM * C * CALL EXEC(100027B,IBUF,LU) * GO TO 8000 * 100 IF (IRP .NE. 0) CALL IDRPD(IBUF) * STOP * 8000 WRITE (LU,10200) * 10200 FORMAT ("SCHEDULE CALL FAILED.") * GO TO 100 * 9000 WRITE (LU,10300) IERR,(IBUF(I),I=1,3) * 10300 FORMAT (/"/FMGR: ERR#"I6" ON "3A2) * GO TO 100 * END * END$ HED SUBROUTINE TO MAKE PROGRAM SCHEDULEABLE ADDCB NOP * ADERR NOP * ADNAM NOP * ADLU NOP * ADRPF NOP * PUTID NOP * JSB .ENTR * DEF ADDCB * JSB .DFER * MOVE PROGRAM NAME DEF NWNAM * TO INTERNAL BUFFER. DEF ADNAM,I * LDB ADNAM * ADB =D4 * LDA B,I * GET FILE SECURITY. STA SEC * INB * LDA B,I * GET FILE CRN STA CRN * CLA * STA ADRPF,I * CLEAR RP FLAG STA RNFLG * CLEAR RENAME FLAG. ; STA ADERR,I * CLEAR ERROR VARIABLE LDA IH * CPA SEC * INHIBIT OPTION? JMP TRYOV * YES. LDA XEQT * ADA =D20 * CHECK IF SESSION BIT IS SET JSB .XLA * DEF A,I * LDA A,I AND SESBT * SZA,RSS * IN SESSION? JMP TRYOV * NO. CCA * YES. SET RENAMING FLAG. STA RNFLG * CLB * LDA ADLU,I * GET TERMINAL LU DIV =D10 * CHANGE TERMINAL LU TO ASCII ALF,ALF * IOR B * IOR "00" * STA TEMP * DLD NWNAM * GET FIRST 2 CHARACTERS OF AND =B377 * PROGRAM NAME CPA =B40 * IMBEDDED SPACE? LDA DOT * YES. REPLACE WITH DOT. IOR NWNAM * STA NWNAM * LSR 8 * CHECK THIRD CHARACTER. CPB =B40 * BLANK? LDB DOT * YES. MAKE DOT. LDA TEMP * RRL 8 * IOR =B40 * MAKE LAST CHARACTER BLANK. STB NWNAM+1 * STA NWNAM+2 * TRYOV JSB IDSGA * IS GENERIC ID-SEGMENT IN CORE? DEF *+2 * DEF ADNAM,I * USE GENERIC NAME. SZA,RSS * FIND IT? JMP RPIT * NO. LDB RNFLG * YES. SZB,RSS * NEED TO RENAME IT? JMP PUTID,I * NO. EXIT. ADA =D26 * INDX TO DISC ADDRESS WORD JSB .XLA * GET DISC ADDRESS DEF A,I * LDA A,I STA TEMP * SAVE TILL LATER JSB IDDUP * TRY IN-CORE DUPLICATE. DEF *+4 * DEF ADNAM,I * OLD NAME DEF NWNAM * NEW NAME DEF ADERR,I * ERROR VARIABLE SZA,RSS * ERROR? JMP RPFEX * NO. EXIT. CPA =D16 * (UNKNOWN BASKINS ERROR) JMP OKERR * EXIT. CPA =D17 * ID SEGMENT NOT SET-UP BR ":RP" ? JMP OKERR * YES. USE GENERIC NAME ID. CPA =D23 * DUPLICATE ID ? RSS w* YES. JMP PUTID,I * ERROR EXIT. JSB IDSGA * GET ID# OF DUPLICATE ID. DEF *+2 * DEF NWNAM * SZA,RSS * FIND ID? JMP TRYOV * NO. WHO OFF'D MY ID? ADA =D26 * YES. BUMP TO DISC TRACK ADDRESS. JSB .XLA * DEF A,I * LDA A,I CPA TEMP * DISC ADDRESS SAME AS GENERIC ID? JMP RPFEX * YES. USE IT, BUT SET ":RP,," FLAG. JMP BDERR * NO. ERROR EXIT. RPIT JSB IDSGA * DEF *+2 * SEE IF RENAMED ID IS IN CORE DEF NWNAM * SZA * FIND IT? JMP RPFEX * YES. EXIT. LDA CRN * NO. STA LUCRN * SZA * CRN SEARCH? JMP ONECR * NO. USE GIVEN CRN. LDA SECT3 * YES. GET# OF LU 3 SECTOR/TRACK SZA * LU 3 MISSING? JMP GTCRN * NO. LDA =D-2 * YES. SEARCH LU 2 ONLY. STA LUCRN * ONECR CCA * ONLY ONE CARTRIDGE TO SEARCH. STA #CRNS * JMP OPNIT * TRY TO OPEN. GTCRN JSB FSTAT * GET MOUNTED CARTRIDGE LIST DEF *+2 * DEF ADDCB,I *3-3 USE PASSED DCB BUFFER CLA * STA LUCRN * LDA ADDCB * STA CRADD * SET CURRENT ADDRESS TO START OF BUFFER GTLOP LDA CRADD,I * GET CARTRIDGE LU SZA,RSS * END OF LIST? JMP OPNIT * YES. AND =B77 * CPA =D2 * LU=2? JMP FOUND * YES. CPA =D3 * NO. IS THIS LU 3? JMP FOUND * YES. LDA CRADD * NO. ADA =D4 * BUMP ADDRESS STA CRADD * JMP GTLOP * DO SOME MORE. FOUND CMA,INA * STA LUCRN * SAVE STARTING LU. LDA =D-2 * SET # CRN'S TO SEARCH AS 2. STA #CRNS * OPNIT JSB LOPEN * OPEN TYPE 6 FILE DEF *+7 * FOR THIS PROGRAM DEF ADDCB,I * DEF ADERR,I * DEF ADNAM,I * USE GENERIC NAME DEF CD1 * DEF SEC * DEF LUCRN * USE APPROPRIATE CRN SSA,RSS * OPEN SUCCESSFUL? JMP RPLIT * YES. CPA =D-6 * NO. VALID ERROR (NOT FOUND) ? RSS * YES. JMP PUTID,I * NO. BAIL OUT. ISZ #CRNS * SEARCH ANOTHER CRN? RSS * YES. JMP PUTID,I * NO. BAIL OUT. LDA LUCRN * GET CURRENT CRN. CLB,INB * CPA =D-2 * WAS THIS LU 2? CCB * YES. ADA B * BUMP CRN UP OR DOWN APPROPRIATELY. STA LUCRN * JMP OPNIT * TRY OPEN AGAIN RPLIT JSB IDRPL * DEF *+4 * DO ":RP" ON PROGRAM DEF ADDCB,I * DEF ADERR,I * DEF NWNAM * PUT IN NEW NAME JSB LCLOS * DEF *+2 * CLOSE PROGRAM FILE DEF ADDCB,I * LDA ADERR,I * SZA,RSS * ANY ERROR? JMP RPFEX * NO. EXIT. CPA =D23 * YES. DUPLICATE ID? JMP RPFEX * USE THE ID ALREADY THERE. JMP PUTID,I * ERROR EXIT. RPFEX CCA * STA ADRPF,I * SET ":RP,," FLAG. CLA * STA ADERR,I * CLEAR ERROR VARIABLE. BDERR JSB .DFER * DEF ADNAM,I * RETURN NEW NAME (IF CHANGED) DEF NWNAM * JMP PUTID,I * EXIT OKERR CLA * STA ADERR,I * RESET ERROR PARAMETER JMP PUTID,I * DON'T SET ":RP,," SWITCH. DON'T RENAME. HED PUTID VARIABLES CRADD NOP * CRN NOP * #CRNS NOP * D1 DEC 1 * DOT OCT 56 * IH ASC 1,IH * LUCRN NOP * NWNAM BSS 3 * "00" ASC 1,00 * RNFLG NOP * SEC NOP * SESBT OCT 20000 * TEMP NOP * END $"$  92425-18066 2001 S 0122 &KGET GETSYMAPWD              H0101 N+ASMB,Q,C HED "KGET" SAME AS IGET BUT THRU SYSTEM MAP IF ONE 5-78 (DLB) NAM KGET,7 92425-1X066 REV.2001 791218 * NAME: KGET * SOURCE: 92425-18066 * RELOCE: 92425-1X066 * PRGM: DICK LAMPMAN ************************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************************* ENT KGET SPC 1 A EQU 0 B EQU 1 BPA3 EQU 1744B * PURPOSE: TO ALLOW FTN PROGRAM TO GET DATA FROM SYSTEM AND * BASE PAGE. * CALLED: * IVALU = KGET(IADDRS) * WHERE: * IADDRS = DESIRED ADDRESS OF WORD TO GET THUR SYSTEM MAP. * IVALU = VALUE OF DESIRED WORD. SPC 1 KGET NOP ENTRY LDA BPA3 CHECK IF MAPPING SYSTEM? CPA O2 CHECK IF MAPPED SYSTEM? JMP KGET1 YES, CONTINUE LDA LDAAI NO, MUST BE RTE-II OR DOS STA IOPTN LDA JMPBI GET THE JMP B,I INSTRUCTION STA IOPTN+1 KGET1 LDB KGET,I GET RETURN ADDRESS ISZ KGET BUMP TO PASSED PARAMETER ADDRESS LDA KGET,I GET PARAMETER ADDRESS LDAAI LDA A,I GET PARAMETER VALUE (=ADDRESS) IOPTN XLA A,I OR LDA A,I JMPBI JMP B,I AND EXIT WITH A-REG = ANSWER O2 OCT 2 END w  92425-18067 2001 S 0122 &,XLA CROS LOD A              H0101 ASMB,Q,C NAM .XLA,6 92425-1X067 REV.2001 791218 * NAME: .XLA * SOURCE: 92425-18067 * RELOC : 92425-1X067 * PRGM: DICK LAMPMAN ************************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************************* ENT .XLA EXT .ZPRV SPC 1 BPA3 EQU 1744B FWA OF DISC RESIDENT BASE PAGE FOR DMS SYSTEMS XLA OCT 101724 SPC 1 * PURPOSE: * THIS CODE WILL ALLOW PROGRAMS THAT GENERALLY WILL GO AFTER * DATA THAT IS IN A SYSTEM MAP FOR RTE-IV SYSTEMS, BUT ALLOW * THE SAME PROGRAMS TO WORD IN AN RTE-III & RTE-II SYSTEM. SPC 1 .TMP1 NOP .TMP2 NOP SPC 1 .XLA NOP ENTRY TO EXECUTE THE XLA INSTRUCTION JSB .ZPRV MAKE CALLABLE FROM TYPE 6 CODE DEF LIBX STA .TMP1 SAVE A-REG CONTENTS LDA O2 CHECK IF A MAPPING SYSTEM? CPA BPA3 (RTE-2?) JMP .XLA1 NO, MUST BE A MAPPING SYSTEM LDA .XLA,I GET OPERAND ADDRESS STA .TMP2 SAVE IT LDA .TMP1 RESTORE A-REG LDA .TMP2,I AND GET THE CONTENTS ISZ .XLA BUMP TO P+2 RETURN LIBX JMP .XLA,I AND EXIT DEF .XLA SPC 1 .XLA1 LDA .XLA GET P+1 ADDRESS CMA,INA DECREMENT WITHOUT DISTURBING CMA THE E-REG STA .XLA AND PUT BACK P+0 ADDRESS LDA XLA GET THE REAL INSTRUCTION STA .XLA,I AND CHANGE THE JSB TO XLA LDA .TMP1 RESTORE A-REG JMP LIBX AND GO EXECUTE THE INSTRUCTION SPC 1 O2 OCT 2 END     92425-18068 2001 S 0122 &,XLB CROS LOD B              H0101 ASMB,Q,C NAM .XLB,6 92425-1X068 REV.2001 791231 * NAME: .XLB * SOURCE: 92415-18068 * RELOC : 92415-1X068 * PRGM: DICK LAMPMAN ************************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************************* ENT .XLB EXT .ZPRV SPC 1 BPA3 EQU 1744B FWA OF DISC RESIDENT BASE PAGE FOR DMS SYSTEMS XLB OCT 105724 SPC 1 * PURPOSE: * THIS CODE WILL ALLOW PROGRAMS THAT GENERALLY WILL GO AFTER * DATA THAT IS IN A SYSTEM MAP FOR RTE-IV SYSTEMS, BUT ALLOW * THE SAME PROGRAMS TO WORD IN AN RTE-III & RTE-II SYSTEM. SPC 1 .TMP1 NOP .TMP2 NOP SPC 1 .XLB NOP ENTRY TO EXECUTE THE XLB INSTRUCTION JSB .ZPRV MAKE CALLABLE FROM TYPE 6 CODE DEF LIBX STA .TMP1 SAVE A-REG CONTENTS LDA O2 CHECK IF A MAPPING SYSTEM? CPA BPA3 (RTE-2?) JMP .XLB1 NO, MUST BE A MAPPING SYSTEM LDA .XLB,I GET OPERAND ADDRESS STA .TMP2 SAVE IT LDA .TMP1 RESTORE A-REG LDB .TMP2,I AND GET THE CONTENTS ISZ .XLB BUMP TO P+2 RETURN LIBX JMP .XLB,I AND EXIT DEF .XLB SPC 1 .XLB1 LDA .XLB GET P+1 ADDRESS CMA,INA DECREMENT WITHOUT DISTURBING CMA THE E-REG STA .XLB AND PUT BACK P+0 ADDRESS LDA XLB GET THE REAL INSTRUCTION STA .XLB,I AND CHANGE THE JSB TO XLB LDA .TMP1 RESTORE A-REG JMP LIBX AND GO EXECUTE THE INSTRUCTION SPC 1 O2 OCT 2 END     92425-18069 2001 S 0122 &TRTB5 TRAP TABL              H0101 !ASMB,Q,C NAM TRTB5,30 92425-1X069 REV.2001 791130<< 4 STN, 16 TRAPS >> * * NAME: TRTBL TRAP TABLE * SOURCE: 92425-18069 * RELOC: 92425-1X069 * PRGM: DICK LAMPMAN ************************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************************* ENT TABL$,STN$,TRTBL,TREND,SRQ.T SUP * *---------------------------------------------------------------- * * WRD FUNCTION * --- -------- * 1 STATION # FOR THIS TRAP BLOCK * 2 NOT USED CURRENTLY * 3 PRIORITY OF CURRENT INTERRUPT (1 TO 16, 1=HI) * 4 FLAG: #0 SEARCH TABLE BEFORE EVERY LINE * =0 DON'T SEARCH TABLE BEFORE EVERY LINE * * 5 TRAP CELLS: * TO BIT 15 1=TRAP SET/ 0=CLEAR * 20 BIT 14 1=TRAP IN PROCESS/ 0=CLEAR * BIT 13-0 SEQUENCE NUMBER, 0=> NOT ENABLED * *--------------------------------------------------------------- * TABL$ DEC 16 16 ENTRIES/STATION STN$ DEC 20 TOTAL SIZE OF A STATION'S TABLE SRQ.T EQU * DUMMY ENTRY POINT FOR HPIB SUBROUTINE. DON'T USE! TRTBL DEF *+1 REP 80 NOP TREND DEF * END F  92425-18070 2001 S 0122 &TRPNS TRAPSETB              H0101 VASMB,C,Q HED << 09580 TRAP SET ROUTINE >> NAM TRPN5,30 92425-1X070 REV.2001 791129 * *--------------------------------------------------------------- * * NAME: TRPNT * SOURCE: 92425-18070 * RELOC: 92415-1X070 * PRGM: DICK LAMPMAN ************************************************************************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************************* * * ENTRY POINTS: * ENT TRPNT * * * * EXTERNAL REFERENCES: * EXT $LIBR,$LIBX EXT TABL$,STN$,TRTBL,TREND EXT LUTRU * * * ***** * ** TRPNT ** SET A BIT IN THE TRAP TABLE * * LDA TRAP NUMBER * LDB STATION NUMBER (SESSION LU OF CRT) * JSB TRPNT * RETURN1 TRAP TABLE FULL & THIS ENTRY NOT THERE ALREADY * RETURN2 SUCCESS * * NOTE: IF NO ENTRY WITH THAT TRAP NBR EXISTS, THIS * ROUTINE WILL MAKE ONE WITH PRIORITY 99 AND * WITH THE ENABLE BIT AND THE SEQ NBR CLEARED. * ****** * TRPNT NOP * JSB $LIBR TURN OFF THE INTERRUPT SYSTEM. NOP * STA TRNUM SAVE TRAP # STB LUSES SAVE SESSION LU. * JSB LUTRU GET SYSTEM LU. DEF *+3 DEF LUSES DEF LUSYS * LDB TRTBL FINDT LDA TREND FIND TRAP TABLE FOR STN # CMA,INA ADA .B. SSA,RSS END OF TABLE? JMP ERTN YES, ERROR RETURN LDA .B.,I NO, GET STATION # CPA LUSYS SAME AS REQUEST? JMP SETTR YES, SET TRAP ADB STN$ NO, TRY AGAIN JMP FINDT SPC 5 SETTR LDA TRNUM TEST FOR LEGAL TRAP # SZA,RSS ZERO? JMP ERTN YES tc  SSA NEGATIVE? JMP ERTN YES CMA,INA COMPLEMENT TRAP NUMBER ADA TABL$ SSA TRAP # > TABLE SIZE JMP ERTN YES ADB D3 FORM 'SEARCH TBL' FLAG LDA BIT15 STA .B.,I ADDRESS & SET #0 ADB TRNUM FORM ADDRS OF TRAP CELL LDA .B.,I GET CONTENTS OF TRAP CELL IOR BIT15 SET TRAP BIT STA .B.,I PUT INTO TABLE ISZ TRPNT RETURN (P+1) ERTN JSB $LIBX RETURN (P) DEF TRPNT SKP * CONSTANTS AND VARIBLES * SPC 2 .A. EQU 0 A REGISTER .B. EQU 1 B REGISTER TRNUM NOP TRAP NUMBER LUSYS NOP SYSTEM LU OF STATION SPC 5 LUSES OCT 0 TEMP STORAGE FOR SESSION LU. D3 DEC 3 BIT15 OCT 100000 END 4   92425-18071 2001 S C0122 /DIR TEST DIRFIL             H0101 91:* 92425-18071 REV.2001 791231 * THIS DIRECTORY IS USED BY MTIS SOFTWARE * TO RELATE A TEST SEQUENCE FILE AND PARAMETERS * TO A UUT IDENTIFICATION NAME. UUT NAME IS AN * 80 CHARACTER STRING FOLLOWED BY ANOTHER * ENTRY WHICH SPECIFIES TEST SEQUENCE FILE NAME, * FOLLOWED BY THE VALUES TO BE SET INTO 1G,2G,& ETC. 10  92425-18999 2001 S 0122 C92425 SW# CAT              H0101  SOFTWARE NUMBERING CATALOG FOR 92425C 92425-18999 REV.2001 791231 file part number rev type name description ------ ----------- ---- --- ----- --------------------------- %ALLO5 92425-16059 2001 prg ALLOC load config table. %CNFG5 92425-16063 2001 prg CNFGD list config tables %DALO5 92425-16060 2001 prg DALOC release config. tables %DRTX5 92425-16062 2001 tbl DRTXX device ref table extension %DTSX5 92425-16045 2001 prg DTSXX directory driven test selector %ERROR 09580-16021 A sub ERROR replaces basic sub. %GTCX5 92425-16049 2001 prg GTCXX get cluster %IBCF5 92425-16056 2001 prg IBCFE config hp-ib error bit %IBLU5 92425-16050 2001 sub IBLU0 get ses lu of subchnl 0 %ISN5 92425-16043 2001 sub ISN return terminal session LU %LU2S5 92425-16052 2001 sub LU2ST dv lu to station sys lu %LUDV5 92425-16051 2001 sub LUDV get lu of device. %STAR5 92425-16047 2001 prg START initialize and load DRTXX %TIM5 09580-16064 2001 sub TIM accesses config. tables $TRPL5 92425-12001 2001 sub TRPLB basic multi stn trap lib &DRTX5 92425-18062 2001 tbl DRTXX device ref table extension &DVIN5 92425-18061 2001 PRG DVINT sets traps for interrupts &TRTB5 92425-18069 2001 tbl TRTBL BASIC multi station trap table *BUIL5 92425-18053 2001 fil *BUIL5 commands to build system /DIR 92425-18071 2001 Fil /DIR directory for DTSXX /SLC ----------- ---- fil /SLC reserved namr for 92425C C92425 92425-18999 2001 fil software numbering catalog 92425-13311 2001 car MTISC CART 1 92425-13312 2001 car MTISC CART 2 92425-13313 2001 car MTISC CART 3 92425-93007 JA80 mnl MTIS reference manual Q   92427-18001 2001 S C0122 &F2A2F HEADER MODULE MATURE ST             H0101 ASMB,Q,C NAM F2A2F,7 92427-12001 REV.2001 791022 * SOURCE: 92427-18001 * RELOC: 92427-YY001 PHANTOM * RELOC: PART OF 92427-12001 ******************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THES PRORAM MAY BE PHOTOCOPIED, * * REPRODUCEED OF TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ******************************************************************** * THIS MODULE IS A HEADER FOR A LIBRARY WITH THE * MODULES LISTED BELOW. THIS LIBRARY IS TO MAINTAINE THOSE * DEVICE SUBROUTINES WHICH USE THE LISTED FUNTIONS IN THE EVENT * THAT THOSE FUNCTIONS SHOULD CEASE TO BE PROVIDED BY * MTIS 92425 * * F2A 92425-18024 * A2F 92425-18019 * DATE 92425-18023 * ASCII 92425-18020 * TIMEC 92425-18031 * TIMEX 92425-18033 * TIMES 92425-18032 * PAK 92425-18037 * UNPK 92425-18039 * PUT 92425-18038 * * THE FUNCTION TODAY FROM DTS-70 91075B SOFTWARE IS NEEDED FOR THE * ABOVE MODULES. THE CODE FOR THAT FUNCTION IS PROVIDED AS PART * OF THIS HEADER MODULE. SKP HED "TODAY" RTE UTIL TO FORM STRING OF TODAY'S DATE AND TIME (DLB) * *-------------------------------------------------------- * * * D. BASKINS 13 OCT 76 REV. A * *--------------------------------------------------------- ENT TODAY EXT EXEC SPC 1 A EQU 0 B EQU 1 SUP SPC 1 * PURPOSE: * TO BUILD CALLERS 14 WORD BUFFER INTO A DATE/TIME MESSAGE IN * THE FOLLOWING FORM: * * "FRI 26 MAR 1976 18:24:30.09" * ---- ------ * WHERE: * TODAYS DATE IS FRIDAY, MARCH 26, 1976 AND THE TIME IS * 6:24 PM & 30.09 SECONDS. * * NOTES: * THE 1ST 2 WORDS MAY BE STRIPED OFF THE BUFFER AND THE LAST * THREE 8WORDS MAY BE STRIPPED OFF TO LOOK LIKE THIS: * * "26 MAR 1976 18:24" * * CALLING & EXAMPLE PROGRAM: * * FTN,L * PROGRAM DATE * DIMENSION IB(14),IP(5) * CALL RMPAR(IP) * 1 CALL TODAY(IB) * CALL EXEC (2,IP,IB,14) * CALL EXEC (2,IP,IB(3),9) * IB(13) = IB(13) - 14 * CALL EXEC (2,IP,IB,13) * END * * WHERE: IBUF IS A 14 WORD BUFFER AND IS STORED INTO BY * THE TODAY SUBROUTINE. SPC 1 YEAR NOP TMSEC NOP SEC NOP MIN NOP HOUR NOP DAY NOP TODAY NOP ENTRY POINT LDB TODAY,I ISZ TODAY GET PARAMETER ADDRESS LDA TODAY STB TODAY SAVE RETURN ADDRESS LDA A,I TRACK DOWN DIRECT PARAMETER RAL,CLE,SLA,ERA JMP *-2 CLE,ELA CALCULATE STARTING CHARACTOR STA CHRAD OF THE CALLERS BUFFER JSB EXEC NOW GET TIME FROM SYSTEM DEF *+4 DEF D11 CALL EXEC (11,IBUF,IYEAR) DEF TMSEC DEF YEAR LDA YEAR GET THE DAY OF WEEK ADA OM1 ARS,ARS WATCH OUT FOR LEAP YEAR ADA YEAR ADA DAY CLB DIV O7 RBL CALCULATE BUFFER ADDRESS ADB DAYWK POINT TO BUFFER JSB PUT2A PUT 4 CHARS FROM B-REG TO CALLERS BUF JSB PUT2A PUT THE NEXT TWO LDB DAY ADB DM60 SUBTRACT 2 MONTHS LDA YEAR GET YEAR AND O3 CHECK IF LEAP YEAR SZA LEAP YEAR? SSB OR BEFORE THE 29 FEB ADB OM1 NO, LEAP YEAR OR BEFORE FEB 29 SSB ADB D366 MAR 1 OR LATER ANY YEAR ADB D31 LDA B MPY BY 5 MPY O5 DIV D153 LIKE MAGIC, HUH! RAL MPY BY 2 ADA DEFMO GET MONTH ADDRESS STA PUT2A AND SAVE FOR LATER USE LDA B GET REMAINDER CLB AND DIVIDE BY 5 DIV O5 tTO GET DAY OF MONTH INA MINUS ONE JSB PUT2# PUT 2 DIGIT NUMBER IN BUFFER LDB PUT2A GET MONTH ADDRES JSB PUT2A AND MOVE 4 CHARS JSB PUT2A AND THE NEXT TWO LDA O40 PUT IN SPACE JSB PUTCR IN BETWEEN MONTH & YEAR LDA YEAR CLB DIV D100 STB PUT2A SAVE FRACTION CENTURY FOR LATER JSB PUT2# PUT TWO DIGIT 19 IN BUFFER LDA PUT2A RETRIVE THE 76 JSB PUT2# AND PUT FRACTION OF CENTURY IN BUFFER ISZ CHRAD CHEAT BY BUMPING PAST SPACE IN BUFFER LDA O40 PUT SPACE IN BUFFER JSB PUTCR FOR TWO SPACES LDA HOUR JSB PUT2# SET IN HOUR LDA COLON JSB PUTCR PUT IN COLON LDA MIN JSB PUT2# SET IN MINUTES LDA COLON PUT IN COLON JSB PUTCR LDA SEC JSB PUT2# SET IN SECONDS LDA PEROD GET DECEMAL POINT JSB PUTCR LDA TMSEC JSB PUT2# SET IN TENS OF MILLISECONDS JMP TODAY,I RETURN DONE SPC 1 CHRAD NOP HOLDS CURRENT CHARACTOR ADDRESS PUTC1 NOP PUTCR NOP ENTRY A=CHARACTOR TO PUT AND O377 MASK OFF HIGH CHARACTOR STB PUTC1 SAVE THE B-REG LDB CHRAD GET CHARACTOR ADDRESS TO PUT CLE,ERB CONVERT TO WORD ADDRESS ISZ CHRAD SEZ,RSS ALF,SLA,ALF POSITION IF NECESSARY XOR B,I MERGE IN OLD XOR O40 PUT IN/TAKE OUT SPACE STA B,I AND PUT IN BUFFER LDB PUTC1 RESTORE B-REG JMP PUTCR,I RETURN DONE SPC 1 PUT2A NOP MOVE 4 CHARACTORS FROM ADDRESS LDA B,I GET 1ST CHAR ALF,ALF POSITION JSB PUTCR AND PUT LDA B,I GET 2ND CHAR JSB PUTCR INB BUMP TO NEXT WORD JMP PUT2A,I RETURN SPC 1 PUT2# NOP CONVERT AND PUT 2 DIGIT # IN A-REG CLB FIRST R@CONVERT DIV D10 NUMBER TO BASE TEN ADB O60 CONVERT TO ASCII ADA O60 CONVERT TO ASCII JSB PUTCR PUT HIGH DIGIT LDA B JSB PUTCR PUT LOW DIGIT JMP PUT2#,I RETURN SPC 1 OM1 OCT -1 DM60 DEC -60 O3 OCT 3 O5 OCT 5 O7 OCT 7 D10 DEC 10 D11 DEC 11 D31 DEC 31 O40 OCT 40 PEROD OCT 56 COLON OCT 72 O60 OCT 60 D100 DEC 100 D153 DEC 153 O377 OCT 377 D366 DEC 366 DAYWK DEF *+1 ASC 14,FRI SAT SUN MON TUE WED THU DEFMO DEF *-1 ASC 12, MAR APR MAY JUN JUL AUG ASC 12, SEP OCT NOV DEC JAN FEB ORR END END$ M   92427-18999 2026 S C0122 A92427 SOFTWARE NUM. CAT.             H0101 Ձ92427A REV 2026 MODULE DESCRIPTION DATE CODE PART NUMBER %AC1 WTK 154 1840 09580-16043 %ACP ELGAR DDP-3-AF2-242 2001 09580-16011 %ACPS1 ELGAR DAP 2001 09580-16430 %ACSEN EVENT SENSE 2001 09580-16429 %ACVSD 3320 DVR37 1840 09580-16030 %ADCSU GERTSH ADC-1R-HP CC1 2026 09580-16009 %ANAGN SCHLUMBERGER 1172 2026 09580-16465 %ANAME SCHLUMBERGER 1172 2026 09580-16467 %ANARD SCHLUMBERGER 1172 2026 09580-16468 %ANASU SCHLUMBERGER 1172 2026 09580-16464 %ANASW SCHLUMBERGER 1172 2026 09580-16466 %ARMF 8100 1840 09580-16017 %C45HM 5345 2026 09580-16460 %C45IM 5345 2001 09580-16413 %C45MF 5345 2026 09580-16463 %C45OF 5345 2026 09580-16462 %C45RD 5345 DVR37 2026 09580-16290 %C45SU 5345 DVR37 2026 09580-16289 %CDTU FRONT END 1840 09580-16139 %CHANC 5353 DVR37 1840 09580-16291 %CHNAB 8100 1840 09580-16016 %CTREP 5328 DVR37 1840 09580-16128 %CTRIM 5328 DVR37 2013 09580-16129 %CTRLF 8100 1840 09580-16013 %CTRMU 5340 DVR37 1840 09580-16282 %CTRRE 5328 DVR37 1840 09580-16130 %CTRST 5328 DVR37 2013 09580-16131 %CTRSU 5340 DVR37 1840 09580-16281 %DCAV HP-682X AMP. 2001 09580-16441 %DCCDA 69370 DVM72 1840 09580-16286 %DCOPL 61XX 2001 09580-16134 %DCPSV 6002 DVR37 1840 09580-16163 %DCV 61XX 2001 09580-16040 %DCVDA 69321 DVM72 1840 09580-16285 %DCVOT HP-682X P.S. 2001 09580-16440 y%DCVSH 61XX 2001 09580-16038 %DCVSL 61XX 2001 09580-16039 %DGNLD HP-8018A 2001 09580-16450 %DGTST DTU DVR73 1830* 09570-16482 %DIGIN 69431A 1926 09580-16427 %DIGOT 69331 DVM72 1840 09580-16287 %DSERR DTU DVR73 1830* 09570-16484 %DSVMU 3437 DVR37 2001 09580-16137 %DSVSU 3437 DVR37 2001 09580-16136 %DTUTO FRONT END 1840 09580-16150 %DVMEP 3455 DVR37 1840 09580-16297 %DVMMU 3455 DVR37 1840 09580-16041 %DVMRE 5328 DVR37 1840 09580-16132 %DVMST 5328 DVR37 1926 09580-16133 %DVMSU 3455 DVR37 1840 09580-16042 %DVSTS STATUS STORE 2013 09580-16442 %ERRNM DTU DVR73 1830* 09570-16487 %FPREF FRONT END 1840 09580-16145 %FPSUP FRONT END 1840 09580-16152 %FPSWL FRONT END 1840 09580-16146 %GENTM 59308A 1926 09580-16320 %GFMRD 3575 2001 09580-16012 %GPRIO 12566-60024 2013 09580-16316 %GRTST GERTSH PSS-2613R 2001 09580-16010 %GTRNG 1900 1840 09580-16036 %HFGMY 3335A 1926 09580-16370 %HFGSU 3335A 1926 09580-16369 %IBGSC HP-59500A 2001 09580-16453 %INIT FRONT END 1840 09580-16141 %ISWRP SW REG PNL 1840 09580-16014 %LETED 1900 1840 09580-16037 %MATSW SWITCHING DVR37 1840 09580-16052 %MODES 8100 1840 09580-16015 %MODSW SWITCHING DVR37 1840 09580-16046 %MOUTP 8100 2013 09580-16019 %MPGSC 6940 DVM72 1840 09580-16288 %MUXSW SWITCHING DVR37  1840 09580-16053 %NASU 3570 DVR37 1926 09580-16270 %PGNSA 1900 1840 09580-16032 %PGNSD 1900 1840 09580-16033 %PGNSR 1900 1840 09580-16034 %PGNSS 1900 1840 09580-16035 %PINIT FRONT END 1840 09580-16153 %PMFLG SWITCHING DVR37 1840 09580-16059 %PPGIM 8160A 1926 09580-16305 %PPGMY 8160A 1926 09580-16304 %PPGOM 8160A 1926 09580-16306 %PPGSS 8160A 1926 09580-16307 %PSCTL DTU P.S. PROG 1926 09580-16412 %PSPRG 59501A 1926 09580-16319 %PSP 62XX 1840 09580-16031 %PULSE FRONT END 1840 09580-16148 %PWMMU 436A DVR37 1840 09580-16235 %PWMSU 436A DVR37 1840 09580-16234 %RASW 59306A 2001 09580-16368 %RCONF FRONT END 1840 09580-16149 %RFMOD 8672 DVR37 1840 09580-16278 %RFOSM 8660 DVR37 1840 09580-16280 %RFOSO 8660 DVR37 2001 09580-16279 %RFSU 8672 DVR37 1926 09580-16277 %RLCDM 4262 DVR37 1840 09580-16276 %RLCMU 4262 DVR37 1840 09580-16268 %RLCSU 4262 DVR37 1840 09580-16267 %RLCTM 4262 DVR37 1840 09580-16275 %RMSSU 3403 DVR37 2026 09580-16294 %RSTAT FRONT END 1840 09580-16142 %RTX1 PRT 3130 DVM72 1840 09580-16164 %S3330 3330 DVR37 1840 09580-16269 %SCANC SWITCHING DVR37 1840 09580-16055 %SCAND SWITCHING DVR37 1840 09580-16054 %SCNSU HP-3495A 2001 09580-16359 %SDLY FRONT END 1840 09580-16140 %SETHI FRONT END 1840 09580-1615ݙ1 %SETLU DTU DVR73 1830* 09570-16528 %SFAMP 3325A 2001 09580-16311 %SFFUN 3325A 1926 09580-16314 %SFGEN 3325A 1926 09580-16310 %SFGMD 3325A 1926 09580-16312 %SFGMY 3325A 1926 09580-16309 %SFMWC HP-5342 2001 09580-16449 %SGNBU 8165A DVR37 1840 09580-16302 %SGNLS 8165A DVR37 1926 09580-16299 %SGNMD 8165A DVR37 1926 09580-16300 %SGNMY 8165A DVR37 1840 09580-16301 %SGNSU 8165A DVR37 2001 09580-16298 %SGNSW 8165A DVR37 1840 09580-16303 %STREF FRONT END 1840 09580-16143 %STGET STATUS GET 2013 09580-16443 %SWAID SWITCHING DVR37 1840 09580-16050 %SWCID SWITCHING DVR37 1840 09580-16048 %SWCON SWITCHING DVR37 1840 09580-16056 %SWFRQ 8620C 1926 09580-16426 %SWMAP SWITCHING DVR37 1840 09580-16049 %SWSET FRONT END 1840 09580-16144 %SWTST SWITCHING DVR37 1840 09580-16051 %TIMRD 59309A 1926 09580-16322 %TIMRS 59309A 1926 09580-16321 %TIPRB 5363 DVR37 1840 09580-16292 %TRIGF 8100 1840 09580-16018 %TSASU 3571A 2013 09580-16323 %TSYCL HP-5359A 2001 09580-16458 %TSYFM HP-5359A 2026 09580-16453 %TSYOM HP-5359A 2026 09580-16456 %TSYSD HP-5359A 2001 09580-16457 %TSYSM HP-5359A 2001 09580-16454 %TSYTL HP-5359A 2001 09580-16459 %TSYTM HP-5359A 2001 09580-16455 %VARPG WTK-152 1926 09580-16306 %VHFSW SWITCHING DVR37 1840 09580-16047 %VVM 8405 DVM72 d 1840 09580-16272 %WAVSA AUTEK-505 2001 09580-16318 %WAVSU AUTEK-505 2013 09580-16317 %WFANA AMC 1010 DVM72 1840 09580-16293 %WTEK WTK 172 DVR37 1840 09580-16232 %WTKLS WTK 172 DVR72 1840 09580-16233 %XCONF DTU DVR73 1830* 09570-16547 %XDLY DTU DVR73 1830* 09570-16548 %XDTU DTU DVR73 1830* 09570-16549 %XNIT DTU DVR73 1830* 09570-16551 %XPREF DTU DVR73 1830* 09570-16555 %XPSUP DTU DVR73 1830* 09570-16556 %XPSWL DTU DVR73 1830* 09570-16557 %XSCTL DTU DVR73 1830* 09570-16559 %XSERN DTU DVR73 1925* 09570-16560 %XSTAT DTU DVR73 1830* 09570-16562 %XTREF DTU DVR73 1830* 09570-16563 %XTUTO DTU DVR73 1830* 09570-16568 %XULSE DTU DVR73 1830* 09570-16569 %XWSET DTU DVR73 1830* 09570-16572 &AC1 WTK 154 1840 09580-18043 &ACPS1 ELGAR DAP 2001 09580-18430 &ACSEN EVENT SENSE 2001 09580-18429 &ACVSD 3320 DVR37 1840 09580-18030 &ADCSU GERTSH ADC-1R-HP CC1 2026 09580-18009 &ANAGN SCHLUMBERGER 1172 2026 09580-18465 &ANAME SCHLUMBERGER 1172 2026 09580-18467 &ANARD SCHLUMBERGER 1172 2026 09580-18468 &ANASU SCHLUMBERGER 1172 2026 09580-18464 &ANASW SCHLUMBERGER 1172 2026 09580-18466 &ARMF 8100 1840 09580-18017 &C54HF 5345A 2026 09580-18460 &C45IM 5345A 2001 09580-18413 &C45MF 5345A 2001 09580-18463 &C45OF 5345A 2001 09580-18462 &C45RD 5345 DVR37 2026 09580-18290 &C45SU 5345 DVR37 2026 09R580-18289 &CDTU FRONT END 1840 09580-18139 &CHANC 5353 DVR37 1840 09580-18291 &CHNAB 8100 1840 09580-18016 &CTREP 5328 DVR37 1840 09580-18128 &CTRIM 5328 DVR37 2013 09580-18129 &CTRLF 8100 1840 09580-18013 &CTRMU 5340 DVR37 1840 09580-18282 &CTRRE 5328 DVR37 1840 09580-18130 &CTRST 5328 DVR37 2013 09580-18131 &CTRSU 5340 DVR37 1840 09580-18281 &DCAV HP-682X AMP. 2001 09580-18441 &DCCDA 69370 DVM72 1840 09580-18286 &DCOPL 61XX 2001 09580-18134 &DCPSV 6002 DVR37 1840 09580-18163 &DCV 61XX 2001 09580-18040 &DCVDA 69321 DVM72 1840 09580-18285 &DCVOT HP-682X P.S. 2001 09580-18440 &DCVSH 61XX 2001 09580-18038 &DCVSL 61XX 2001 09580-18039 &DGNLD HP-8018A 2001 09580-18450 &DGTST DTU DVR73 B* 09570-18482 &DIGIN 69431A 1926 09580-18427 &DIGOT 69331 DVM72 1840 09580-18287 &DSERR DTU DVR73 * 09570-18484 &DSVMU 3437 DVR37 2001 09580-18137 &DSVSU 3437 DVR37 2001 09580-18136 &DTUTO FRONT END 1840 09580-18150 &DVMEP 3455 DVR37 1840 09580-18297 &DVMMU 3455 DVR37 1926 09580-18041 &DVMRE 5328 DVR37 1840 09580-18132 &DVMST 5328 DVR37 1926 09580-18133 &DVMSU 3455 DVR37 1840 09580-18042 &DVSTS STATUS STORE 2013 09580-18442 &ERRNM DTU DVR73 A* 09570-18487 &FPREF FRONT END 1840 09580-18145 &FPSUP FRONT END 1840 09580-18152 &FPSWL FRONT +END 1840 09580-18146 &F2A2F STRING FUNCTIONS HEADER 2001 92427-18001 &GENTM 59308A 1926 09580-18320 &GFMRD 3575 2001 09580-18012 &GPRIO 12566-60024 2013 09580-18316 &GRTST GERTSH PSS-2613R 2001 09580-18010 >RNG 1900 1840 09580-18036 &HFGMY 3335A 1926 09580-18370 &HFGSU 3335A 1926 09580-18369 &IBGSC HP-59500A 2001 09580-18452 &INIT FRONT END 1840 09580-18141 &ISWRP SW REG PNL 1840 09580-18014 &LETED 1900 1840 09580-18037 &MATSW SWITCHING DVR37 1840 09580-18052 &MODES 8100 1840 09580-18015 &MODSW SWITCHING DVR37 1840 09580-18046 &MOUTP 8100 2013 09580-18019 &MPGSC 6940 DVM72 1840 09580-18288 &MUXSW SWITCHING DVR37 1840 09580-18053 &NASU 3570 DVR37 1926 09580-18270 &PGNSA 1900 1840 09580-18032 &PGNSD 1900 1840 09580-18033 &PGNSR 1900 1840 09580-18034 &PGNSS 1900 1840 09580-18035 &PINIT FRONT END 1840 09580-18153 &PMFLG SWITCHING DVR37 1840 09580-18059 &PPGIM 8160A 1926 09580-18305 &PPGMY 8160A 1926 09580-18304 &PPGOM 8160A 1926 09580-18306 &PPGSS 8160A 1926 09580-18307 &PSCTL DTU P.S. PROG 1926 09580-18412 &PSPRG 59501A 1926 09580-18319 &PSP 62XX 1840 09580-18031 &PULSE FRONT END 1840 09580-18148 &PWMMU 436A DVR37 1840 09580-18235 &PWMSU 436A DVR37 1840 09580-18234 &RASW 59306A 2001 i 09580-18368 &RCONF FRONT END 1840 09580-18149 &RFMOD 8672 DVR37 1840 09580-18278 &RFOSM 8660 DVR37 1840 09580-18280 &RFOSO 8660 DVR37 2001 09580-18279 &RFSU 8672 DVR37 1926 09580-18277 &RLCDM 4262 DVR37 1840 09580-18276 &RLCMU 4262 DVR37 1840 09580-18268 &RLCSU 4262 DVR37 1840 09580-18267 &RLCTM 4262 DVR37 1840 09580-18275 &RMSSU 3403 DVR37 2026 09580-18294 &RSTAT FRONT END 1840 09580-18142 &RTX1 PRT 3130 DVM72 1840 09580-18164 &S3330 3330 DVR37 1840 09580-18269 &SCANC SWITCHING DVR37 1840 09580-18055 &SCAND SWITCHING DVR37 1840 09580-18054 &SCNSU HP-3495A 2001 09580-18359 &SDLY FRONT END 1840 09580-18140 &SETHI FRONT END 1840 09580-18151 &SETLU DTU DVR73 * 09570-18528 &SFAMP 3325A 2001 09580-18311 &SFFUN 3325A 1926 09580-18314 &SFGEN 3325A 1926 09580-18310 &SFGMD 3325A 1926 09580-18312 &SFGMY 3325A 1926 09580-18309 &SFMWC HP-5342A 2001 09580-18449 &SGNBU 8165A DVR37 1840 09580-18302 &SGNLS 8165A DVR37 1926 09580-18299 &SGNMD 8165A DVR37 1926 09580-18300 &SGNMY 8165A DVR37 1840 09580-18301 &SGNSU 8165A DVR37 2001 09580-18298 &SGNSW 8165A DVR37 1840 09580-18303 &STREF FRONT END 1840 09580-18143 &STGET STATUS GET 2013 09580-18443 &SWAID SWITCHING DVR37 1840 09580-18050 &SWCID SWITCHING DVR37 1840 09580-18048 &SWCON SWITCHING DVR37 1840 09580-18056 &SWFRQ 86A20C 1926 09580-18426 &SWMAP SWITCHING DVR37 1840 09580-18049 &SWSET FRONT END 1840 09580-18144 &SWTST SWITCHING DVR37 1840 09580-18051 &TIMRD 59309A 1926 09580-18322 &TIMRS 59309A 1926 09580-18321 &TIPRB 5363 DVR37 1840 09580-18292 &TRIGF 8100 1840 09580-18018 &TSASU 3571A 2013 09580-18323 &TSYCL HP-5359A 2001 09580-18458 &TSYFM HP-5359A 2026 09580-18453 &TSYOM HP-5359A 2026 09580-18456 &TSYSD HP-5359A 2001 09580-18457 &TSYSM HP-5359A 2001 09580-18454 &TSYTL HP-5359A 2001 09580-18459 &TSYTM HP-5359A 2001 09580-18455 &VARPG WTK-152 1926 09580-18308 &VHFSW SWITCHING DVR37 1840 09580-18047 &VVM 8405 DVM72 1840 09580-18272 &WAVSA AUTEK-505 2001 09580-18318 &WAVSU AUTEK-505 2013 09580-18317 &WFANA AMC 1010 DVM72 1840 09580-18293 &WTEK WTK 172 DVR37 1840 09580-18232 &WTKLS WTK 172 DVR72 1840 09580-18233 &XCONF DTU DVR73 A* 09570-18547 &XDLY DTU DVR73 B* 09570-18548 &XDTU DTU DVR73 B* 09570-18549 &XNIT DTU DVR73 A* 09570-18551 &XPREF DTU DVR73 A* 09570-18555 &XPSUP DTU DVR73 A* 09570-18556 &XPSWL DTU DVR73 A* 09570-18557 &XSCTL DTU DVR73 A* 09570-18559 &XSERN DTU DVR73 D* 09570-18560 &XSTAT DTU DVR73 A* 09570-18562 &XTREF DTU DVR73 1826* 09570-18563 &XTUTO DTU DVR73 A* 09570-18568 &XULSE DTU DVR73 <:6 B* 09570-18569 &XWSET DTU DVR73 A* 09570-18572 $F2A2F MATURE STRING FUNCTIONS 2001 92427-12001 A92427 SOFTWARE NUMBER CATALOG 2026 92427-18999 * DATE CODES OF SOURCE AND RELOCATABLE DO NOT AGREE. :<   92832-18500 2015 S C0122 *UNLOA              H0101 :PU,$ULB ::2G :PU,$PLIB ::2G :PU,$SHSLB::2G :PU,%DC2 ::2G :PU,%ERR ::2G :PU,%EV1 ::2G :PU,%EV2 ::2G :PU,%EV3 ::2G :PU,%EV4 ::2G :PU,%EV5 ::2G :PU,%EXP ::2G :PU,%FLU ::2G :PU,%IN1 ::2G :PU,%IN2 ::2G :PU,%OPT ::2G :PU,%PRG ::2G :PU,%STD ::2G :PU,%STM ::2G :PU,%UNT ::2G :PU,%UTL ::2G :PU,%XXID ::2G :PU,%XF1 ::2G :PU,%XF2 ::2G :PU,%EMPTY::2G :PU,%DC1 ::2G :PU,%PASCL::2G :PU,%FMAIN::2G :PU,%MMAIN::2G :PU,%PRERS::2G :PU,%..GER::2G :PU,%TRACA::2G :PU,%TRACB::2G :PU,%TRACC::2G :PU,%SG01P::2G :PU,%SG02P::2G :PU,%SG03P::2G :PU,%SG04P::2G :PU,%SG05P::2G :PU,%SG06P::2G :PU,%SG07P::2G :PU,%SG08P::2G :PU,%SG09P::2G :PU,%SG10P::2G :PU,%SG11P::2G :PU,%SG12P::2G :PU,%SG13P::2G :PU,%SG14P::2G :PU,%SG15P::2G :PU,%SG16P::2G :PU,%SG17P::2G :PU,%SG18P::2G :PU,%HSSZ ::2G :PU,%@SAMS::2G :PU,%XREF1::2G :PU,%XREF2::2G :PU,*LOAD ::2G :PU,*LDPAS::2G :PU,#PASCL::2G :PU,*PCLF ::2G :PU,#PCLF ::2G :PU,*PCLM ::2G :PU,#PCLM ::2G :PU,*SPPCL::2G :PU,*PUPCL::2G :PU,*OFPCL::2G :PU,"PERRS::2G :PU,*LDXF1::2G :PU,#XREF1::2G :PU,*LDXF2::2G :PU,#XREF2::2G :PU,*SPXRF::2G :PU,*PUXRF::2G :PU,*OFXRF::2G :PU,A92832::2G :PK,2G :ST,1G,$ULB ::2G,BR :ST,1G,$PLIB ::2G,BR :ST,1G,$SHSLB::2G,BR :ST,1G,%DC2 ::2G,BR :ST,1G,%ERR ::2G,BR :ST,1G,%EV1 ::2G,BR :ST,1G,%EV2 ::2G,BR :ST,1G,%EV3 ::2G,BR :ST,1G,%EV4 ::2G,BR :ST,1G,%EV5 ::2G,BR :ST,1G,%EXP ::2G,BR :ST,1G,%FLU ::2G,BR :ST,1G,%IN1 ::2G,BR :ST,1G,%IN2 ::2G,BR :ST,1G,%OPT ::2G,BR :ST,1G,%PRG ::2G,BR :ST,1G,%STD ::2G,BR :ST,1G,%STM ::2G,BR :ST,1G,%UNT ::2G,BR :ST,1G,%UTL ::2G,BR :ST,1G,%XXID ::2G,BR :ST,1G,%XF1 ::2G,BR :ST,1G,%XF2 ::2G,BR :ST,1G,%EMPTY::2G,BR :ST,1G,%DC1 ::2G,BR :ST,1G,%PASCL::2G,BR :ST,1G,%FMAIN::2G,BR :ST,1G,%MMAIN::2G,BR :ST,1G,%PRERS::2G,BR :ST,1G,%..GER::2G,BR :ST,1G,%TRACA::2G,BR :ST,1G,%TRACB::2G,BRz   :ST,1G,%TRACC::2G,BR :ST,1G,%SG01P::2G,BR :ST,1G,%SG02P::2G,BR :ST,1G,%SG03P::2G,BR :ST,1G,%SG04P::2G,BR :ST,1G,%SG05P::2G,BR :ST,1G,%SG06P::2G,BR :ST,1G,%SG07P::2G,BR :ST,1G,%SG08P::2G,BR :ST,1G,%SG09P::2G,BR :ST,1G,%SG10P::2G,BR :ST,1G,%SG11P::2G,BR :ST,1G,%SG12P::2G,BR :ST,1G,%SG13P::2G,BR :ST,1G,%SG14P::2G,BR :ST,1G,%SG15P::2G,BR :ST,1G,%SG16P::2G,BR :ST,1G,%SG17P::2G,BR :ST,1G,%SG18P::2G,BR :ST,1G,%HSSZ ::2G,BR :ST,1G,%@SAMS::2G,BR :ST,1G,%XREF1::2G,BR :ST,1G,%XREF2::2G,BR :ST,1G,*LOAD ::2G,AS :ST,1G,*LDPAS::2G,AS :ST,1G,#PASCL::2G,AS :ST,1G,*PCLF ::2G,AS :ST,1G,#PCLF ::2G,AS :ST,1G,*PCLM ::2G,AS :ST,1G,#PCLM ::2G,AS :ST,1G,*SPPCL::2G,AS :ST,1G,*PUPCL::2G,AS :ST,1G,*OFPCL::2G,AS :ST,1G,"PERRS::2G,AS :ST,1G,*LDXF1::2G,AS :ST,1G,#XREF1::2G,AS :ST,1G,*LDXF2::2G,AS :ST,1G,#XREF2::2G,AS :ST,1G,*SPXRF::2G,AS :ST,1G,*PUXRF::2G,AS :ST,1G,*OFXRF::2G,AS :ST,1G,A92832::2G,AS h    92832-18501 2015 S C0122 *LOAD              H0101 N:*********************************************************** :* :* *LOAD :* :* :***This file contains the commands to load the :*** three programs comprising Pascal/1000: :* :* :* PASCL Pascal/1000 Monitor :* PCL Pascal/1000 Compiler :* PXREF Pascal/1000 Cross Referencer :* :* :* :********** Load PASCL, the Pascal/1000 Monitor :* ::*LDPAS :* :********** To 'SP' PASCL -------> :SP,PASCL:: :* :* :* :* :********** Load PCL, the Pascal/1000 Compiler on M or E Series :********** Change to *PCLF to load on an F in 27KW :* ::*PCLM :* :********** To 'SP' PCL, ---------> ::*SPPCL, :* :* :* :* :********** Load PXREF, the Pascal/1000 Cross Referencer, non-EMA ver. :********** Change to *LDXF2 to load the EMA version :* ::*LDXF1 :* :********** To 'SP' PXREF, -------> ::*SPXRF, :* :* :* :********** The following commands will store user-available files :* to cartridge 50 :* :* :ST,$PLIB ::RL,$PLIB ::50 :ST,"PERRS::RL,"PERRS::50 :ST,$SHSLB::RL,$SHSLB::50 :ST,%TRACA::RL,%TRACA::50 :ST,%TRACB::RL,%TRACB::50 :ST,%TRACC::RL,%TRACC::50 :ST,%PRERS::RL,%PRERS::50 :ST,%..GER::RL,%..GER::50 :* :* :* :**** Loading completed ...... happy Pascaling!    92832-18502 2015 S C0122 *LDPAS              H0101 u:OF,PASCL :RU,LOADR,#PASCL _  92832-18503 2015 S C0122 #PASCL              H0101 nLL,'PASCL OP,LB RE,%PASCL SE,$PLIB EN 4X  92832-18504 2015 S C0122 *PCLF              H0101 {]::*OFPCL :RU,LOADR,#PCLF %2  92832-18505 2015 S C0122 #PCLF              H0101 u]LL,'PCLF ::RL OP,LB LI,$ULB ::RL LI,$SHSLB ::RL LI,$PLIB ::RL RE,%FMAIN ::RL RE,%@SAMS ::RL SL SE LO,42000B RE,%EMPTY ::RL RE,%HSSZ ::RL RE,%SG01P ::RL RE,%IN1 ::RL RE,%SG02P ::RL RE,%IN2 ::RL RE,%SG03P ::RL RE,%DC1 ::RL RE,%SG04P ::RL RE,%DC2 ::RL RE,%SG05P ::RL RE,%UNT ::RL RE,%SG06P ::RL RE,%PRG ::RL RE,%SG07P ::RL RE,%STM ::RL RE,%SG08P ::RL RE,%EXP ::RL RE,%SG09P ::RL RE,%STD ::RL RE,%SG10P ::RL RE,%XF1 ::RL RE,%SG11P ::RL RE,%XF2 ::RL RE,%SG12P ::RL RE,%EV1 ::RL RE,%XXID ::RL RE,%SG13P ::RL RE,%EV2 ::RL RE,%SG14P ::RL RE,%EV3 ::RL RE,%XXID ::RL RE,%SG15P ::RL RE,%EV4 ::RL RE,%XXID ::RL RE,%SG16P ::RL RE,%EV5 ::RL RE,%XXID ::RL RE,%SG17P ::RL RE,%OPT ::RL RE,%UTL ::RL RE,%SG18P ::RL RE,%FLU ::RL RE,%ERR ::RL SL SEARCH DI END h  92832-18506 2015 S C0122 *PCLM              H0101 ]::*OFPCL :RU,LOADR,#PCLM ,2  92832-18507 2015 S C0122 #PCLM              H0101 ~]LL,'PCLM ::RL OP,LB LI,$ULB ::RL LI,$SHSLB ::RL LI,$PLIB ::RL RE,%MMAIN ::RL RE,%@SAMS ::RL SL SE LO,42000B RE,%EMPTY ::RL RE,%HSSZ ::RL RE,%SG01P ::RL RE,%IN1 ::RL RE,%SG02P ::RL RE,%IN2 ::RL RE,%SG03P ::RL RE,%DC1 ::RL RE,%SG04P ::RL RE,%DC2 ::RL RE,%SG05P ::RL RE,%UNT ::RL RE,%SG06P ::RL RE,%PRG ::RL RE,%SG07P ::RL RE,%STM ::RL RE,%SG08P ::RL RE,%EXP ::RL RE,%SG09P ::RL RE,%STD ::RL RE,%SG10P ::RL RE,%XF1 ::RL RE,%SG11P ::RL RE,%XF2 ::RL RE,%SG12P ::RL RE,%EV1 ::RL RE,%XXID ::RL RE,%SG13P ::RL RE,%EV2 ::RL RE,%SG14P ::RL RE,%EV3 ::RL RE,%XXID ::RL RE,%SG15P ::RL RE,%EV4 ::RL RE,%XXID ::RL RE,%SG16P ::RL RE,%EV5 ::RL RE,%XXID ::RL RE,%SG17P ::RL RE,%OPT ::RL RE,%UTL ::RL RE,%SG18P ::RL RE,%FLU ::RL RE,%ERR ::RL SL SEARCH DI END o  92832-18508 2015 S C0122 *SPPCL              H0101 :SP,PCL::1G :SP,HSSZ::1G :SP,SG01P::1G :SP,SG02P::1G :SP,SG03P::1G :SP,SG04P::1G :SP,SG05P::1G :SP,SG06P::1G :SP,SG07P::1G :SP,SG08P::1G :SP,SG09P::1G :SP,SG10P::1G :SP,SG11P::1G :SP,SG12P::1G :SP,SG13P::1G :SP,SG14P::1G :SP,SG15P::1G :SP,SG16P::1G :SP,SG17P::1G :SP,SG18P::1G :SP,SGERS::1G   92832-18509 2015 S C0122 *PUPCL              H0101 :PU,PCL::1G :PU,HSSZ::1G :PU,SG01P::1G :PU,SG02P::1G :PU,SG03P::1G :PU,SG04P::1G :PU,SG05P::1G :PU,SG06P::1G :PU,SG07P::1G :PU,SG08P::1G :PU,SG09P::1G :PU,SG10P::1G :PU,SG11P::1G :PU,SG12P::1G :PU,SG13P::1G :PU,SG14P::1G :PU,SG15P::1G :PU,SG16P::1G :PU,SG17P::1G :PU,SG18P::1G :PU,SGERS::1G n  92832-18510 2015 S C0122 *OFPCL              H0101 w:OF,PCL,1 :OF,HSSZ,1 :OF,SG01P,1 :OF,SG02P,1 :OF,SG03P,1 :OF,SG04P,1 :OF,SG05P,1 :OF,SG06P,1 :OF,SG07P,1 :OF,SG08P,1 :OF,SG09P,1 :OF,SG10P,1 :OF,SG11P,1 :OF,SG12P,1 :OF,SG13P,1 :OF,SG14P,1 :OF,SG15P,1 :OF,SG16P,1 :OF,SG17P,1 :OF,SG18P,1 :OF,SGERS,1 b  92832-18511 2015 S C0122 "PERRS              H0101 ~ Pascal/1000 Syntax Errors 5/20/80 1: error in simple type 2: identifier expected 3: 'PROGRAM' expected 4: ')' expected 5: ':' expected 6: illegal symbol 7: error in parameter list 8: 'of' expected 9: '(' expected 10: error in type 11: '[' expected 12: ']' expected 13: 'end' expected 14: ';' expected 15: integer expected 16: '=' expected 17: 'begin' expected 18: error in declaration part 19: error in field list 20: ',' expected 21: '.' expected 23: string expected 24: '..' expected 25: illegal character in this context 26: ',' or ';' expected 49: expression must be a constant 50: error in constant 51: ':=' expected 52: 'THEN' expected 53: 'UNTIL' expected 54: 'DO' expected 55: 'TO' or 'DOWNTO' expected 60: error in expression 70: external routine must be declared at outermost level 71: aliased routine must be declared at outermost level 72: recursive routine may not be direct 73: actual routine may not have errorexit 80: negative field width not allowed 81: index type has more than maxint values 100: duplicate or invalid external name 101: identifier redeclared 102: low bound exceeds high bound 103: identifier is not of appropriate class 104: identifier not declared 105: sign not allowed 106: scope violation 107: incompatible subrange types 108: file not allowed here 109: type must not be real 110: tagfield type must be scalar or subrange 111: incompatible with tagfield type 112: index type must not be real 113: index type must be scalar or subrange 114: base type must not be real or longreal 115: base type must be scalar or subrange 116: error in type of standard procedure parameter 117: unsatisfied forward reference 118: undeclared forward procedure or x function 119: forward declared; repeated parameter list not allowed 120: function may not return this type 121: file value parameter not allowed 122: forward declared; repeated result type not allowed 123: missing result type in function declaration 124: decimal position for real only 125: error in type of standard function parameter 126: number of parameters does not agree with declaration 127: missing parameter to standard routine 128: result type of parameter function conflicts with declaration 129: type conflict of operands 130: expression is not of set type 131: only tests of equality are allowed 132: strict inclusion not allowed 133: file comparison not allowed 134: illegal type of operand(s) 135: type of operand must be Boolean 136: set element type must be scalar or subrange 137: set element types not compatible 138: type of variable is not array 139: index type is not compatible with declaration 140: type of variable is not record 141: type of variable must be file or pointer 142: illegal parameter substitution 143: illegal type of loop control variable 144: illegal type of expression 145: type conflict 146: assignment of files not allowed 147: label type incompatible with selecting expression 148: subrange bounds must be scalar 149: not assignment compatible 150: assignment to standard function is not allowed 151: assignment to formal function is not allowed 152: no such field in this record 153: type error in read 154: actual parameter must be a variable 155: loop control variable must be simple/local variable 156: multidefined case label 157: loop control variable may not be assigned to 158: missing corresponding variant declaration 159: real or string tagfields not allowed 160: previous declaration was not forward 161: again forward declared 162: type error in write 163: missing variant in decnlaration 164: substitution of standard proc/func not allowed 165: multidefined label 166: multideclared label 167: undeclared label 168: undefined label 169: error in base set 170: value parameter expected 171: actual parameter cannot be component of packed type 172: dynamic variables cannot be/contain a file 173: too many enumerated values 174: file cannot be textfile 175: missing file "input" in program heading 176: missing file "output" in program heading 177: only variables may be assigned to 178: invalid expression 179: function identifier not assignable here 180: type of expression must be Boolean 181: no function result defined in the body of the function 182: program or module cannot be declared forward 183: program or module cannot be declared external 184: warning: division by zero 185: undeclared external file 186: file must be a textfile 187: option conflict 188: option cannot be specified here 189: heap option must be set to use this routine 190: recursive option must be set to do recursion 191: option cannot be respecified 192: option not recognized 193: include level too deep 194: include file cannot be read 195: option has invalid parameter 196: 'ON' or 'OFF' expected 200: numeric constant too long 205: real constant exceeds range 206: missing fractional part of real 207: missing scale factor of real or longreal 209: overflow or underflow 210: integer constant exceeds range 215: string constant too long 216: string constant exceeds source line 217: null string is invalid 218: non printing character invalid in string 219: invalid non printing character 220: character constant exceeds range 225: label exceeds range 230: structured type identifier expected 231: too few constants 232: too many constants 233: field(s) not specified 234: field respecified 235: tag not set or set to another variant 236: set type id expected 237: constant of wrong type 250: too many nested scopes of identifiers 251: too many nested blocks of code 252: location counter overflow 253: unexpected end of source file 254: source line too long 255: too many errors on this source line 260: compiler label overflow: break into separate compilations 261: compiler literal pool overflow: expression too complicated 302: index expression out of bounds 303: value to be assigned is out of bounds 304: element expression out of range 305: actual parameter out of bounds 307: expression out of bounds 398: implementation restriction 399: "non standard" construct 400 or greater: Compiler error, contact your HP representative. k  92832-18512 2015 S C0122 *LDXF1              H0101 zw:RU,LOADR,#XREF1 :SYPR,PXREF,90 M  92832-18513 2015 S C0122 #XREF1              H0101 pECHO LL,'XREF1 OP,LB SZ,26 LI,%PRERS LI,$SHSLB LI,$PLIB RE,%XREF1 END i]  92832-18514 2015 S C0122 *LDXF2              H0101 |x:RU,LOADR,#XREF2 :SYPR,PXREF,90 M  92832-18515 2015 S C0122 #XREF2              H0101 qECHO LL,'XREF2 OP,LB LI,%PRERS LI,$SHSLB LI,$PLIB RE,%XREF2 END  ! 92832-18516 2015 S C0122 *SPXRF              H0101 :SP,PXREF::1G :SP,PXMA1::1G :SP,PXSE1::1G  " 92832-18517 2015 S C0122 *PUXRF              H0101 :PU,PXREF::1G :PU,PXMA1::1G :PU,PXSE1::1G  # 92832-18518 2015 S C0122 *OFXRF              H0101 :OF,PXREF :OF,PXMA1 :OF,PXSE1 5 $ 92832-18999 2015 S C0122 A92832 SNC FILE             H0101  A92832 Pascal/1000 Software Numbering Catalog 92832-18999 DATE MODULE DESCRIPTION CODE PART NUMBER CARTRIDGE # ------ ----------- ---- ----------- ----------- *LDPAS Load PASCL 2015 92832-18502 92832-13301 *LDXF1 Load PXREF 2015 92832-18512 92832-13301 *LDXF2 Load EMA PXREF 2015 92832-18514 92832-13301 *LOAD Load everything 2015 92832-18501 92832-13301 *OFPCL OF PCL 2015 92832-18510 92832-13301 *OFXRF OF PXREF 2015 92832-18518 92832-13301 *PCLF Load PCL(F series Cmptr) 2015 92832-18504 92832-13301 *PCLM Load PCL(M,E) 2015 92832-18506 92832-13301 *PUPCL PU PCL 2015 92832-18509 92832-13301 *PUXRF PU PXREF 2015 92832-18517 92832-13301 *SPPCL SP PCL 2015 92832-18508 92832-13301 *SPXRF SP PXREF 2015 92832-18516 92832-13301 *UNLOA Tape Unloader 2015 92832-18500 92832-13301 #PASCL PASCL load commands 2015 92832-18503 92832-13301 #PCLF PCL load commands (F) 2015 92832-18505 92832-13301 #PCLM PCL load commands (M,E) 2015 92832-18507 92832-13301 #XREF1 PXREF Load commands 2015 92832-18513 92832-13301 #XREF2 XREF2 Load commands 2015 92832-18515 92832-13301 "PERRS Syntax Errors 2015 92832-18511 92832-13301 $PLIB Run-Time Lib 2015 92832-12002 92832-13309 $SHSLB Short H/S Lib 2015 92832-12003 92832-13301 $ULB Module Library 2015 92832-12001 92832-13308 %DC1 Label, Const 2015 92832-16052 92832-13303 %DC2 Type, Var 2015 92832-16004 92832-13304 %EMPTY Empty Module 2015 92832-16051 92832-13301 %ERR Error Segment 2015 92832-16008 92832-13307 %EV1 Assign, Ar+ithmetics 2015 92832-16010 92832-13306 %EV2 Procedure/Function Calls 2015 92832-16011 92832-13306 %EV3 FOR, CASE, WITH 2015 92832-16012 92832-13306 %EV4 Boolean Expressions 2015 92832-16013 92832-13306 %EV5 Structure Constants 2015 92832-16014 92832-13306 %EXP Expression Parser 2015 92832-16015 92832-13304 %FLU Constant Flush 2015 92832-16017 92832-13306 %FMAIN F Series Main 2015 92832-16071 92832-13301 %HSSZ Option Segment 2015 92832-16419 92832-13307 %IN1 Initialize Scalars 2015 92832-16021 92832-13303 %IN2 Initialize Tables 2015 92832-16022 92832-13304 %MMAIN M,E Series Main 2015 92832-16072 92832-13302 %OPT Options 2015 92832-16028 92832-13306 %PASCL Pascal Monitor 2015 92832-16070 92832-13301 %PRERS Short Errors 2015 92832-16301 92832-13307 %PRG Prog Units 2015 92832-16030 92832-13305 %SG01P Segment 1 2015 92832-16401 92832-13307 %SG02P Segment 2 2015 92832-16402 92832-13307 %SG03P Segment 3 2015 92832-16403 92832-13307 %SG04P Segment 4 2015 92832-16404 92832-13307 %SG05P Segment 5 2015 92832-16405 92832-13307 %SG06P Segment 6 2015 92832-16406 92832-13307 %SG07P Segment 7 2015 92832-16407 92832-13307 %SG08P Segment 8 2015 92832-16408 92832-13307 %SG09P Segment 9 2015 92832-16409 92832-13307 %SG10P Segment 10 2015 92832-16410 92832-13307 %SG11P Segment 11 2015 92832-16411 92832-13307 %SG12P Segment 12 2015 92832-16412 92832-13307 %SG13P Segment 13 2015 92832-16413 92832-13307 %SG14P Segment 14 2015 92832-16414 92832-13307 %SG15P Segment 15 R 2015 92832-16415 92832-13307 %SG16P Segment 16 2015 92832-16416 92832-13307 %SG17P Segment 17 2015 92832-16417 92832-13307 %SG18P Segment 18 2015 92832-16418 92832-13307 %STD Std Procedures/Functions 2015 92832-16037 92832-13305 %STM Statament Parsers 2015 92832-16039 92832-13302 %TRACA Trace A 2015 92832-16305 92832-13307 %TRACB Trace B 2015 92832-16310 92832-13307 %TRACC Trace C 2015 92832-16315 92832-13307 %UNT Unit Parser 2015 92832-16044 92832-13304 %UTL Debug Utilities 2015 92832-16045 92832-13305 %XF1 Tree Transforms 2015 92832-16048 92832-13305 %XF2 Tree Transforms 2015 92832-16049 92832-13305 %XREF1 Small XREF 2015 92832-16800 92832-13302 %XREF2 Large XREF 2015 92832-16810 92832-13303 %XXID Dummy Extr ID 2015 92832-16047 92832-13307 %@SAMS Pascal segmenter 2015 92832-16450 92832-13301 %..GER Duplicate segmenter 2015 92832-16302 92832-13307 LIST OF SOFTWARE MANUALS * The following is a list of the 92832A manuals. * The print date shown is the most current version of the manual for * your product. This date is the edition or the latest update print * date. If you have a reprinted manual, it will have the same print * date as the latest update with all current updates incorporated in * your manual. UPDATE PRINTED MANUAL TITLE PART NUMBER EDITION NO. (EDT/UP) Pascal/1000 Reference Manual 92832-90001 1 5/80 Programming in Pascal 92832-90002 1 5/80 Pascal/1000 Configuration Guide 92832-90003 1 5/80 92832A Software Numbering Cat 92832-90004 N/A  5/80  ( 92834-17001 2030 S C0122 "FTN4X CONFIGURATION GUIDE             H0101  CONFIGURATION GUIDE / INSTALLATION MANUAL FOR FTN4X. 1 CONFIGURATION GUIDE / INSTALLATION MANUAL FOR FTN4X. REV.2030 800820 1 Table of Contents 1 REQUIREMENTS . . . . . . . . . . . . . . . . . . . . . . . . . . . 1 1.1 HARDWARE . . . . . . . . . . . . . . . . . . . . . . . . . . 1 1.2 SYSTEM . . . . . . . . . . . . . . . . . . . . . . . . . . . 1 1.3 SOFTWARE . . . . . . . . . . . . . . . . . . . . . . . . . . 1 2 LOADING THE COMPILER . . . . . . . . . . . . . . . . . . . . . . . 2 2.1 RTE-IVB SYSTEM . . . . . . . . . . . . . . . . . . . . . . . 2 2.2 RTE-L SYSTEM . . . . . . . . . . . . . . . . . . . . . . . . 2 3 GENERATING FTN4X INTO A SYSTEM . . . . . . . . . . . . . . . . . . 3 3.1 THE COMPILER PROPER . . . . . . . . . . . . . . . . . . . . 3 3.1.1 RTE-IVB . . . . . . . . . . . . . . . . . . . . . . . 3 3.1.2 RTE-L . . . . . . . . . . . . . . . . . . . . . . . . 3 3.2 RUN-TIME LIBRARIES . . . . . . . . . . . . . . . . . . . . . 4 4 USING FTN4X . . . . . . . . . . . . . . . . . . . . . . . . . . . 5 4.1 COMPILING PROGRAMS . . . . . . . . . . . . . . . . . . . . . 5 4.2 LOADING PROGRAMS . . . . . . . . . . . . . . . . . . . . . . 5 4.3 USING FTN4X RELOCATABLES IN A GENERATION . . . . . . . . . . 5 1 +---------------------------------------------------+------------------+ | | | | REQUIREMENTS | CHAPTER 1 | | | | +---------------------------------------------------+------------------+ 1.1 HARDWARE FTN4X REQUIRES AN HP1000 M, E, F, OR L-SERIES COMPUTER TO RUN THE COMPILER AND/OR THE GENERATED CODE. 1.2 SYSTEM FTN4X REQUIRES AN RTE-IVB OR RTE-L OPERATING SYSTEM, OR SUPPORT OF THE APPROPRIATE CLIB ENTRY POINTS AND THE ROUTINES .MVW AND IFBRK. THE RELOCATABLE FILES GENERATED CONFORM TO THE RTE FORMAT FOR RELOCATABLE FILES, AS SPECIFIED FOR RTE-IVB AND RTE-L. FTN4X REQUIRES A MINIMUM OF 13-14 PAGES. THE RECOMMENDED SIZE IS 18-20 PAGES TO ALLOW FOR SUFFICIENT SYMBOL TABLE SPACE. IF NO PARTITION THIS LARGE EXISTS (E.G. ON AN RTE-L SYSTEM) THE SIZE PROGRAM WHICH MAY BE COMPILED MAY BE SEVERELY LIMITED. ON AN RTE-IVB SYSTEM, FTN4X SHOULD BE LOADED AS LARGE BACKGROUND, SO THAT IT MAY BE SIZED LARGER IF NECESSARY. 1.3 SOFTWARE THE 92834 PRODUCT INCLUDES THE FOLLOWING FILES: +------------------------------------------------------------+ | NAME PART NUMBER DESCRIPTION | +------------------------------------------------------------+ | "FTN4X 92834-17001 THIS FILE. | | A92834 92834-17999 SOFTWARE NUMBERING CATALOG FILE. | | $F4XCS 92834-12001 COMMON COMPILER MODULES (LIBRARY). | | %F4X1 92834-16002 COMPILER MODULES, PART 1. | | %F4X2 92834-16003 COMPILER MODULES, PART 2. | | $F4XLB 92834-12002 RUN-TIME LIBRARY. | | $F4XDS 92834-12003 DS LIBRARY. | | $F4XND 92834-12004 NON-DS LIBRARY. | +------------------------------------------------------------+ THE DS FILE I/O CAPABILITY REQUIRES DS/1000-IV, PRODUCT 91750. 1 1 +---------------------------------------------------+------------------+ | | | | LOADING THE COMPILER | CHAPTER 2 | | | | +---------------------------------------------------+------------------+ 2.1 RTE-IVB SYSTEM 1)'OF' MAIN & SEGMENTS: FTN4X, F4X.0, F4X.1, F4X.2, F4X.3, F4X.4, F4X.5, & F4X.6 . 2)'OF' T5IDM TO RELEASE ITS SEGMENT TABLES. 3)LOAD AS FOLLOWS: :RU,LOADR /LOADR: OP,LB /LOADR: SZ,18 (OR AS DESIRED) /LOADR: LI,$F4XCS /LOADR: RE,%F4X1 /LOADR: RE,%F4X2 /LOADR: EN 4)'SP' MAIN & SEGMENTS AS DESIRED. 5)'OF' MAIN & SEGMENTS. 2.2 RTE-L SYSTEM 1)PURGE FILE FTN4X. 2)LOAD AS FOLLOWS: :RU,LOADR /LOADR: SG,7 /LOADR: LI,$F4XCS /LOADR: LI,$CLIBL (INCLUDED WITH RTE-L SYSTEM) /LOADR: RE,%F4X1 /LOADR: RE,%F4X2 /LOADR: EN 2 1 +---------------------------------------------------+------------------+ | | | | GENERATING FTN4X INTO A SYSTEM | CHAPTER 3 | | | | +---------------------------------------------------+------------------+ 3.1 THE COMPILER PROPER 3.1.1 RTE-IVB THE COMPILER MAY BE GENERATED INTO A SYSTEM SIMPLY BY SPECIFYING THE FILES: $F4XCS %F4X1 %F4X2 IN THE APPROPRIATE SECTION OF THE ANSWER FILE. FTN4X MAY COEXIST WITH FTN4 IF NECESSARY. THE FOLLOWING ADDITIONS SHOULD BE MADE TO THE "CHANGE ENTS?" SECTION OF THE ANSWER FILE: Z$INT,RP,1 DEFAULT INTEGER*2 Z$LPP,RP,73 DEFAULT 59 LINES PER PAGE. TO DEFAULT ALL INTEGERS TO INTEGER*4 (J OPTION), SET Z$INT TO 2. THE VALUE OF Z$LPP IS THE MAXIMUM NUMBER OF LINES WHICH MAY BE PRINTED ON A PHYSICAL PAGE, IGNORING THE FORMAT OF THE DATA. THE ACTUAL NUMBER OF SOURCE LINES PRINTED ON A PAGE OF A LISTING WILL BE SMALLER, DUE TO THE TITLE. THE ENTRY POINT Z$DBL SHOULD ALREADY BE RP'D TO 3 OR 4; FTN4X USES THIS AS FTN4 DOES TO DETERMINE THE DEFAULT PRECISION OF "DOUBLE PRECISION". 3.1.2 RTE-L THE FTN4X COMPILER MAY NOT BE GENERATED INTO AN RTE-L SYSTEM. ON-LINE LOAD IT. 3 1 3.2 RUN-TIME LIBRARIES FOR SYSTEMS OF REVISION CODE 2101 OR LATER, NO SPECIAL ACTION IS REQUIRED FOR RUN-TIME LIBRARIES. THE FILES $F4XLB, $F4XDS AND $F4XND SHOULD BE DISCARDED. FOR EARLIER SYSTEMS, THE RUN-TIME LIBRARIES SUPPLIED WITH THE COMPILER MUST BE USED. IN ORDER TO GENERATE THEM INTO A SYSTEM, THE FILE $F4XLB SHOULD REPLACE $MLIB1 IN THE GENERATION, AND EITHER $F4XDS OR $F4XND, BUT NOT BOTH, SHOULD BE ADDED. $F4XDS IS FOR DS SYSTEMS AND REFERENCES "DEXEC", AND THE DS VERSION OF THE FMP ROUTINES (RFA), WHICH WILL NOT BE FOUND IN A NON-DS GENERATION. $F4XND IS FOR NON-DS SYSTEMS AND SATISFIES CERTAIN REFERENCES IN $F4XLB WHICH OTHERWISE WOULD BE FOUND IN $F4XDS. IN SHORT: ---- (DS) -----> $F4XLB / $F4XDS $MLIB1 \ --- (NON-DS) --> $F4XLB $F4XND WHERE 'DS' REFERS TO DS/1000-IV, PRODUCT 91750. EARLIER VERSIONS MAY BE USED, BUT REMOTE CONNECTIONS WILL BE LIMITED TO LU'S (NO FILES). THE FOLLOWING ENTRY POINTS WILL BE MISSING: DXCRE DXCLO DXLOC DXPOS DXREA DXWRI THE ENTRY POINT ".DMOD" MAY SHOW UP AS A DUPLICATE IN $F4XLB AND $PLIB . IF SO, JUST IGNORE IT: THE MODULES ARE IDENTICAL. THIS ROUTINE WILL BE REMOVED FROM $PLIB AT 2101, WHEN IT IS ADDED TO $MLIB1 . 4 1 +---------------------------------------------------+------------------+ | | | | USING FTN4X | CHAPTER 4 | | | | +---------------------------------------------------+------------------+ 4.1 COMPILING PROGRAMS TO COMPILE PROGRAMS, USE EXACTLY AS FTN4. SEE THE FTN4X MANUAL FOR DETAILS AND COMPILE OPTIONS. 4.2 LOADING PROGRAMS IF THE SYSTEM IS OF REVISION CODE 2101 OR LATER, ALL REQUIRED LIBRARY ROUTINES ARE ALREADY IN THE SYSTEM, AND NO SPECIAL LIBRARY SEARCHES ARE REQUIRED. IF $F4XLB AND ($F4XDS OR $F4XND) ARE GENERATED INTO THE SYSTEM, NO SPECIAL LIBRARY SEARCHES ARE REQUIRED. OTHERWISE, AN FTN4X RUN-TIME LIBRARY SHOULD BE CONSTRUCTED. MERGE $F4XLB AND ($F4XDS OR $F4XND), THE LIBRARIES SPECIFIED IN THE GENERATION CHAPTER, CREATING A NEW LIBRARY, E.G. $F . THIS LIBRARY MUST BE SEARCHED WHEN FTN4X RELOCATABLES ARE LOADED. THIS MAY BE DONE USING THE "LI" COMMAND TO THE LOADR. FOR LOADS OF SINGLE RELOCATABLES, IT IS CONVENIENT TO HAVE A LOADR COMMAND FILE WITH JUST THE COMMAND "LI,$F"; IF THIS FILE IS CALLED *F, THEN A SINGLE RELOCATABLE FILE "%ABC" MAY BE LOADED WITH THE COMMAND: :RU,LOADR,*F,%ABC WHEN THE SYSTEM IS UPDATED TO REVISION CODE 2101, THESE LIBRARI $"ES SHOULD BE DISCARDED. SEE THE SECTION ON "GENERATION" FOR RESTRICTIONS ON DS. 4.3 USING FTN4X RELOCATABLES IN A GENERATION ALL FTN4X MAIN PROGRAMS CONTAIN ENTRY POINTS WHICH ARE ALSO FOUND IN THE RUN-TIME LIBRARIES. THEREFORE, FTN4X MAIN PROGRAMS MAY NOT BE GENERATED INTO A SYSTEM. 5 1 FTN4X SUBPROGRAMS MAY BE GENERATED INTO A SYSTEM AS LIBRARY ROUTINES, BUT THEY SHOULD NOT BE USED BY ANY PROGRAM LOADED BY THE GENERATOR. 6 4d$  + 92834-17999 2030 S C0122 A92834 SOFTWARE NUMBERING FILE             H0101 D A92834 SOFTWARE NUMBERING GUIDE, REV.2030 . PRODUCT: REV PART NUMBER CODE DESCRIPTION ----------- ---- ----------- 92834A 2030 FORTRAN 4X COMPILER (FTN4X). ************************************************* MANUAL: REV PART NUMBER CODE DESCRIPTION ----------- ---- ----------- 92834-90001 2030 FTN4X REFERENCE MANUAL. ************************************************* MEDIA: REV PART NUMBER CODE DESCRIPTION ----------- ---- ----------- 92834-13301 2030 MINI-CARTRIDGE # 1. 92834-13302 2030 MINI-CARTRIDGE # 2. 92834-13303 2030 MINI-CARTRIDGE # 3. 92834-13401 2030 FLEXIBLE DISC. 92834-13501 2030 800 BPI MAG TAPE. 92834-13502 2030 1600 BPI MAG TAPE. ************************************************* ASCII INFORMATION FILES: FILE REV NAME PART NUMBER CODE DESCRIPTION ---- ----------- ---- ----------- "FTN4X 92834-17001 2030 INSTALLATION GUIDE. A92834 92834-17999 2030 SOFTWARE NUMBERING GUIDE. ************************************************* RELOCATABLE FILES: FILE REV NAME PART NUMBER CODE DESCRIPTION ---- ----------- ---- ----------- $F4XCS 92834-12001 2030 COMMON COMPILER MODULES. $F4XLB 92834-12002 2030 RUN-TIME LIBRARY. $F4XDS 92834-12003 2030 RUN-TIME LIBRARY, DS ONLY. $F4XND 92834-12004 2030 RUN-TIME LIBRARY, NON-DS. %F4X1 92834-16002 2030 COMPILER MODULES, PART 1. %F4X2 92834-16003 2030 COMPILER MODULES, PART 2. iq   !( 92834-18001 2030 S C0122 &F4XCS COMMON ROUTINES             H0101 ASMB,Q,C HED HEADER FOR FILES &F4XCS AND $F4XCS . NAM F4XCS,8 92834-12001 REV.2030 800715 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18001 * * RELOC: PART OF 92834-12001 * * PGMR: B.G. * *************************************** * END ASMB,L HED "Z$INT" - SYSTEM PARAMETERS. NAM Z$INT,8 92834-12001 REV.2030 800304 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18001 * * RELOC: PART OF 92834-12001 * * PGMR: B.G. * *************************************** * ENT Z$INT,Z$LPP * Z$INT RPL 1 1-WORD INTEGERS. Z$LPP RPL 59 59 LINES/PAGE. * END ASMB,Q,C HED STATEMENT DISPATCHER FOR FTN4X. NAM DSP.F,8 92834-12001 REV.2030 800805 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18001 * * RELOC: PART OF 92834-12001 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.AT ADDRESS TYPE OF CURRENT ITEM. ENT F.BGN STARTING POINT AFTER SEGMENT 0 LOADED. EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTION WORD. ENT F.CRT TEST FOR C/R & GO ON TO NEXT STMT. EXT F.D DO TABLE POINTER. EXT F.DCF DIM, COM FLAG EXT F.DNI ADDR OF (NID) BUFFER. EXT F.DO LWA MEM & LWA+1 DO TABLE. EXT F.EMA F.A OF EMA MASTER. EXT F.END END FLAG EXT F.FNS FIRST NON-SPECIFICATION CHECK. EXT F.IDI CONSTANT BUFFER. EXT F.IM CURRENT ITEM MODE. EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.L # WORDS ON STACK 2 EXT F.LFF LOCICAL IF FLAG EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LSN F.A OF LAST STATEMEXT NUMBER EXT F.LSP LAST OP FLAG: 0 IF CAN'T FALL THRU. EXT F.MSG MSEG SIZE. EXT F.NCR NO CROSS REF FLAG. EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.NXN NO INPUT FLAG ENT F.P1E PASS 1 ERROR EXIT POINT. EXT F.RPL PROGRAM LOCATION COUNTER. EXT F.SEG LOAD A NEW SEGMENT EXT F.SID STATEMEXT ID PHASE FLAG EXT F.SLF STATEMEXT LEVEL FLAG EXT F.STA FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ EXT F.STB STRING BACK FLAG (LOGICAL IF) ENT F.STS ENTRY TO STATEMENT SCAN (LOGICAL IF). EXT F.SVL SAVE # WDS ON OPER STACK (F.L) EXT F.T # WORDS ON STACK 1 EXT F.TC NEXT CHARACTER EXT F.TL LENGTH OF TITLE. ENT F.TRM TERMINATE COMPILE. (SOURCE END) EXT F.TTL TITLE. EXT F.#B # BUFFER BLOCKS. EXT F.#M # NON-DISC CONNECTIONS. EXT F.#N # DISC CONNECTIONS. EXT F.#S BUFFER MULTIPLE. EXT F.$CC SAVED F.CC AT $ STATEMENT BREAK. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT CSN.F CHECK STATEMENT # TYPE. ENT CTL.F COPY TITLE TO PASS FILE. EXT DAF.F DEFINE F.AF EXT DAT.F DEFINE F.AT EXT DEM.F DEFINE F.EM=1 EXT DL.F DEFINE LOCATION: F.AF_F.RPL. EXT EJP.F EJECT PAGE. EXT ER.F ERROR PRINT SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER EXT FA.F FETCH ASSIGNS. EXT IC.F GET NEXT CHARACTER. EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) EXT INM.F INPUT NAME. EXT ISN.F INPUT STATEMEXT NUMBER EXT ISY.F INPUT SYMBOL EXT ITS.F TEST CURRENT ITEM INTEGER. ENT KWP.F KEYWORD SEARCH (JOINED IN PROGRESS). ENT KWS.F KEYWORD SEARCH. EXT MCC.F RESET TO FIRST COLUMN OF STATEMEXT EXT PAK.F PACK & OUTPUT ASCII DATA. EXT PSI.F PRINT SOURCE IMAGE. EXT RP.F REQUIRE RIGHT PAREN & INPUT NEXT. EXT SCP.F SAVE CURRENT STMT POS (NEW STMT, SAME LINE). EXT SNC.F START NEXT CARD SUBROUTINE EXT TCT.F TEST (A)=F.TC ELSE ERROR 28. EXT TS.F TAG ITEM AS SUBROUTINE. EXT UC.F UNINPUT COLUMN EXT WAR.F WARNING MESSAGE PRINTER. EXT WS1.F WRITE A WORD TO SCRATCH FILE 1. * * FORMAT PROCESSOR. * ENT F.FMT * * SYSTEM LIBRARY. * EXT .MVW SPC 1 SUP A EQU 0 A-REGISTER B EQU 1 B-REGISTER SKP * ********************************** * * SOURCE END. VERIFY PROGRAM END * * ********************************** SPC 1 F.TRM LDA K98 LDB F.END LAST STATEMENT WAS 'END' ? SZB,RSS JMP F.ABT NO. ERROR 67. LDB K4 YES. LOAD SEGMENT 4. STB F.STA BUT DON'T LOOK FOR 'FTN,...' JMP F.SEG * K4 DEC 4 K98 DEC 98 SPC 2 * *********** * * SAVE CC * * *********** SPC 1 SCC.F NOP LDA F.CC SAVE COLUMN COUNTER STA F.SCC JMP SCC.F,I * F.SCC OCT 0 SAVE F.CC K29 DEC 29 SKP * ******************* * * STATEMENT INPUT * * ******************* SPC 1 F.BGN JSB SCC.F SAVE THE CHARACTER POSITION CLA STA F.A SET ASSIGNMENT TABLE PTR TO 0 STA F.LSN SET NO STMT #. LDA K46 WRITE START-OF-STATEMENT OPERATOR. JSB WS1.F JSB IC.F DIRECTIVE ? CPA "$" JMP DRCTV * CPA B40 STRIP BLANKS. JSB ICH.F JSB UC.F AND POSITION TO LAST BLANK. LDA F.TC CPA B15 IF BLANK CARD JMP F.CRT TREAT AS A CONTINUE CARD * LDA F.CC BEYOND COL. 6? ADA KM6 SZA,RSS IF EXACTLY 6 THEN MUST BE ISZ F.CC A '0' SO PUSH ON SSA,RSS WELL?? JMP F.STS YES, NO NUMBER. * CLA INPUT ANY KIND OF STATEMENT #. JSB ISN.F LDA F.A % STA F.LSN LAST STATEMENT NUMBER FLAG LDA F.TC LOAD THE LAST CHARACTER READ. CPA B15 CARRIAGE-RETURN? RSS YES. STMT # ON BLANK CARD. JMP F.STS NO, IDENTIFY THE CARD TYPE. * LDA K29 BITCH: STATEMENT NO. ON BLANK CARD JSB ER.F SPC 2 KM6 DEC -6 K46 DEC 46 B15 OCT 15 C/R B50 OCT 50 '(' "$" OCT 44 $ "EN" ASC 1,EN "D$" ASC 1,D$ "D/" BYT 104,15 SKP * ********************** * * DIRECTIVE HANDLING * * ********************** SPC 1 DRCTV CLA,INA SET DIRECTIVE FLAG. STA F.DF STA F.NXN SET 'NO INPUT': ONLY ONE LINE. JSB KWS.F SEARCH FOR THE KEYWORD. DEF DRTBL SZA,RSS IF NOT FOUND, JMP DRC01 THEN ALSO ERROR. * ADA DRJMP ELSE GET PROCESSOR, LDA A,I JMP A,I AND DO IT. * DRC01 JSB PSI.F ERROR. PRINT THE LINE. JMP STID2 THEN COMPLAIN. * DRTBL ASC 11,EMA PAGE FILES TITLE , DRJMP DEF * KEEP IN ORDER: * DEF EMA * DEF PAGE * DEF FILES * DEF TITLE * * F.DF NOP DIRECTIVE FLAG: 1=THIS STMT IS DIRECTIVE. SKP * ******************* * * TITLE DIRECTIVE * * ******************* SPC 1 * NOTE: SINCE '$TITLE' TAKES UP 6 CHARACTERS, AND THE NO-INPUT * FLAG IS SET, THE MAXIMUM POSSIBLE TITLE IS 66 CHARACTERS. * TITLE LDA DFTTL SET UP TITLE POINTER. RAL,CLE,SLA,ERA REMOVE AT MOST ONE INDIRECT. LDA A,I STA T1TTL STA T2TTL SAVE FOR COMPUTING # WDS WRITTEN. JSB EXN.F STRIP BLANKS OFF. TTL01 JSB IC.F GET TWO TITLE CHARACTERS. CPA B15 IF FIRST IS C/R, JMP TTL02 THEN DONE. * ALF,ALF POSITION & SAVE. STA T3TTL JSB IC.F SECOND. CPA B15 = IF SECOND IS C/R, LDA B40 CHANGE TO BLANK FOR NOW. IOR T3TTL MERGE IN FIRST. STA T1TTL,I STORE IN TITLE BUFFER. ISZ T1TTL BUMP POINTER. JMP TTL01 GET MORE. (MAY RE-READ C/R) * TTL02 LDB T1TTL BACK UP POINTER PAST BLANKS. LDA BLNKS (A) = TWO BLANKS. TTL03 CPB T2TTL AT START ? JMP TTL04 YES. WE'RE JUST CLEARING THE TITLE. * ADB KM1 ELSE BACK UP ONE, CPA B,I BLANKS ? JMP TTL03 YES. KEEP BACKING UP. * INB (B) = (LWA+1) OF TITLE. TTL04 STB T1TTL SAVE THE LWA+1. LDA T2TTL # WORDS WRITTEN = CMA,INA -(FWA) ADA B +(LWA+1) STA F.TL SET THAT AS THE TITLE LENGTH. JSB CTL.F COPY TO PASS 2. JMP PAGE GO PAGE EJECT & BUMP LINE #. * BLNKS ASC 1, T1TTL NOP CURRENT POINTER INTO TITLE BUFFER. T2TTL NOP FWA TITLE BUFFER (DIRECT). T3TTL NOP TEMP FOR MERGING TWO CHARACTERS. DFTTL DEF F.TTL FWA TITLE BUFFER. MAY BE INDIRECT ! SKP * ************** * * COPY TITLE * * ************** SPC 1 CTL.F NOP LDA F.TL TITLE LENGTH. ALF,ALF SET UP OPCODE. IOR K58 JSB WS1.F LDA F.TL AGAIN. CMA,INA,SZA,RSS NEGATE. ZERO ? JMP CTL.F,I YES. DONE. * STA T1CTL NO. SET UP COUNTER. LDA DFTTL SET UP POINTER. RAL,CLE,SLA,ERA LDA A,I STA T2CTL CTL01 LDA T2CTL,I SEND ANOTHER. JSB WS1.F ISZ T2CTL BUMP POINTER. ISZ T1CTL COUNT. JMP CTL01 MORE. JMP CTL.F,I DONE. * T1CTL NOP COUNTER. T2CTL NOP POINTER. KM1 DEC -1 K57 DEC 57 K58 DEC 58 B4002 OCT 4002 K34 DEC 34 K31 DEC 31 BCOMI OCT 7000 SKP * ****************** * * PAGE DIRECTIVE * * ****************** SPC 1 PAGE JSB ICH.F PREAD CHAR AFTER DIRECTIVE: CPA B15 REQUIRE C/R. RSS O.K. JMP DRC01 NO. PRINT LINE & ISSUE ERROR. * LDA F.CCW 'L' OPTION ? SLA,RSS JMP PAG02 NO. DONE. * AND B4002 'Q' OR 'M' ? SZA JMP PAG01 YES. * JSB EJP.F NO. DO IT NOW. JMP PAG02 THEN DONE. * PAG01 LDA K57 SEND OPCODE TO FORCE PAGE EJECT JSB WS1.F IN PASS 2. * PAG02 LDA K29 SINCE THE DIRECTIVE WASN'T PRINTED, JSB WS1.F MUST TELL PASS 2 TO BUMP LINE NUMBER. JMP F.CRT DONE. SKP * ***************** * * EMA DIRECTIVE * * ***************** SPC 1 EMA JSB PSI.F ALWAYS PRINT THIS ONE. LDB F.LSF BEFORE FIRST STATEMENT ? LDA K34 (ERROR: OUT OF ORDER) SZB,RSS WELL ? JSB ER.F NO. ERROR. * LDB F.EMA FIRST EMA STATEMENT ? SZB JSB ER.F NO. ERROR. * JSB ICH.F YES. READ THE '('. LDA B50 REQUIRE IT. JSB TCT.F JSB INM.F READ THE COMMON BLOCK NAME. LDA BCOMI AND JSB DAT.F SET UP AS COMMON JSB TS.F MASTER - TYPE SUB. LDA F.A SET F.EMA = ADDR OF MASTER. STA F.EMA JSB DAF.F SET TO POINT AT SELF (0 LENGTH LINKED LIST) JSB DEM.F SET TO BE TYPE EMA. LDA F.TC IS DELIMETER: CPA B54 A COMMA ? RSS YES. JMP EMA02 NO. MUST BE ')'. * * SET UP MSEG SIZE, CHECK ')'. * JSB GDC.F GET VALUE. LDB A A=B=VALUE. AND K31 LIMIT TO 31. CPA B (MUST NOT EXCEED 5 BITS) RSS JMP GDC02 TOO BIG. ERROR. * STA F.MSG SAVE THE VALUE. EMA02 JSB RP.F REQUIRE ')' NOW, & READ C/R JMP F.CRT TEST C/R, THEN DONE. SKP * ******************* * * FILES DIRECTIVE * * w ******************* SPC 1 FILES JSB PSI.F ALWAYS PRINT. LDB F.LSF BEFORE FIRST STATEMENT ? LDA K34 SZB,RSS JSB ER.F NO. ERROR 34. * LDB F.#S FIRST FILES ? SZB JSB ER.F NO. ERROR. * JSB EXN.F YES. SKIP OPTIONAL '(' CPA B50 JSB ICH.F * * GET M & N . * JSB GDC.F GET DIRECTIVE CONSTANT (M). STA F.#M SAVE. CMA,SSA,INA,RSS NEGATE. WAS IT NEGATIVE ? JMP FIL04 YES. ERROR. * ADA K64 NO. > 64 ? SSA JMP FIL04 YES. ERROR. * LDA B54 NO. REQUIRE COMMA. JSB TCT.F JSB GDC.F GET (N). STA F.#N CMA,SSA,INA,RSS NEGATE. WAS IT NEGATIVE ? JMP FIL04 YES. ERROR. * ADA K16 NO. > 16 ? SSA JMP FIL04 YES. ERROR. * LDA F.#M M = M + N. ADA F.#N STA F.#M * * GET S OR "DS". * LDB F.TC NO. IS S/DS PRESENT ? CPB B54 JMP FIL07 (YES) * CLA,INA NO. S=1. STA F.#S JMP FIL08 AND DEFAULT F.#B TOO. SKP FIL07 JSB EXN.F YES. IS NEXT PARAM NUMBER ? SZB,RSS JMP FIL01 YES. GO GET IT. * JSB KWS.F NON-DIGIT. REQUIRE "DS". DEF FILDS 1-ITEM KEYWORD SEARCH. SZA FOUND IT ? (I.E., IS IT "DS" ?) JMP FIL02 YES. LEAVE S=0. JMP FIL05 NO. ERROR. * FIL01 JSB GDC.F GET S. STA F.#S CMA,SSA,INA,SZA NEGATE. .LE. 0 ?. RSS (NO) JMP FIL04 YES. ERROR. * ADA K64 NO. > 64 ?. SSA JMP FIL04 YES. ERROR. * * GET B OR "FREESPACE". * LDA F.TC IS IT THERE ? CPA B54 RSS (YES) JMP FIL08 NO. DEFAULT IT. * JSB EXN.F DIGIT ? SZB,RSS JMP FIL09 YEzpS. GET VALUE. * JSB KWS.F NO. MUST BE "FREESPACE". DEF FILFR SZA,RSS WELL ? JMP FIL05 NO. ERROR. * CCA YES. SET F.#B = -1 AS FLAG. STA F.#B JMP FIL02 GO EXIT. * FIL09 JSB GDC.F YES. GET IT. STA F.#B & SET IT UP. (CLEARED IF ERROR) AND B377 RESTRICT TO [0,255] CPA F.#B CMA,RSS (O.K.; -B-1) JMP FIL04 REJECT: OUT OF RANGE. * ADA F.#N N-B-1 SSA,RSS IF B LDA F.LSN IF STATEMENT NUMBER, STA F.A SET IT FOR PAK.F CCA INITIALIZE PAK.F JSB PAK.F (B=OFFSET=0) LDA F.LSN STATEMENT # ? SZA,RSS JMP FMT02 NO. * JSB FA.F YES. FETCH ASSIGNS, LDA F.AT AND SEE IF ALREADY DEFINED. CPA REL WELL ? RSS YES. ERROR. JMP FMT10 NO. GO DEFINE IT. * LDA K27 DOUBLE DEFINED, WARNING 27. JSB WAR.F CLA ZAP STMT # SO NO CODE OUTPUT. STA F.A JMP FMT02 FIRST DEF HOLDS. * FMT10 JSB DL.F NOTE! PASS 1 USE OF F.RPL ! * * SCAN FORMAT. FIRST: GET NUMBER, IF ANY. * FMT02 CLA SET IT TO ZERO. STA T0FMT FMT03 JSB ICH.F NEXT DIGIT. JSB PAC.F SEND IT TO PASS FILE. LDA F.TC (A) = CHAR. ADA BM72 > '9' ? SSA,RSS JMP FMT04 YES. END OF DIGITS. ADA K10 < '0' ? (A=VALUE) SSA JMP FMT04 YES. END OF DIGITS. LDB T0FMT NO. ADD THIS DIGIT IN. RBL,RBL ADB T0FMT 5 * OLD #. RBL 10. ADB A ADD DIGIT. STB T0FMT ASL 4 > 2047 ? SOS JMP FMT03 NO. TRY FOR ANOTHER. * LDA K14 YES. COMPLAIN. JSB ER.F SKP * LOOK AT NON-DIGIT. PROCESS: ( ) H " ' * FMT04 LDB F.TC GET NEXT CHARACTER CPB "H" 'H' JMP FMT05 YES CPB B42 '"'? JMP FMT07 CPB B47 "'" ? JMP FMT07 * LDA K9 (ERROR #) CPB B15 C/R JSB ER.F YES. ERROR. * CPB B50 THIS A '('? ISZ T2FMT YES. CPB B51 A ')'? CCA,RSS YES. GO DECREMENT COUNT. JMP FMT02 NO. GO ON. ADA T2FMT STA T2FMT SZA OUTER RIGHT PAREN ? JMP FMT02 NO. GO ON. JSB ICH.n8F YES. SHOULD TRANSFER THE C/R JMP FMT09 GO WRAP UP. (F.CRT CATCHES IF NOT C/R.) * * HOLLERITH FORMAT. TRANSFER ALL CHARACTERS. * FMT05 LDB T0FMT SET UP THE COUNT. LDA K20 (ERROR #) CMB,INB,SZB,RSS ZERO ? JSB ER.F YES. ERROR. STB T0FMT NO. SAVE -(# CHARS) FMT06 JSB IC.F NEXT ! CPA B15 C/R ? JSB ER.F YES. ERROR 13. JSB PAC.F NO. SEND IT. ISZ T0FMT COUNT 'EM UP. JMP FMT06 MORE. JMP FMT02 DONE. * * QUOTE FORMATS. * FMT07 STB T0FMT SAVE TYPE OF QUOTE. FMT08 JSB IC.F SEND ALL. CPA B15 C/R ? JSB ER.F YES. ERROR. (A=13) JSB PAC.F SEND IT. LDA F.TC WAS IT MATCHING QUOTE ? CPA T0FMT JMP FMT02 YES, DONE. JMP FMT08 NO, GET MORE. SKP * END OF FORMAT. CLEAN UP & EXIT. * FMT09 LDA KM2 FLUSH PAK.F BUFFER. JSB PAK.F (MAYBE NOTHING WRITTEN - O.K.) ADB F.RPL UPDATE F.PRL STB F.RPL JMP F.CRT EXIT, CHECK FOR C/R. * * SUB TO CALL PAK.F IF FORMAT HAS STMT #. * PAC.F NOP LDB F.LSN FORMAT HAS STMT # ? SZB JSB PAK.F YES. DO IT. JMP PAC.F,I EXIT. SPC 2 T0FMT NOP T2FMT NOP BM72 OCT -72 "H" OCT 110 H KM2 DEC -2 K14 DEC 14 K20 DEC 20 K9 DEC 9 K50 DEC 50 K27 DEC 27 REL OCT 1000 F.AT = REL. * END ASMB,Q,C HED INPUT GROUP FOR FTN4 COMPILER NAM IC.F,8 92834-12001 REV.2030 800707 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ****************************J*********************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18001 * * RELOC: PART OF 92834-12001 * * PGMR: B.G. * *************************************** * * THIS MODULE CONTAINS THE CARD,CHARACTER,AND ITEM INPUT ROUTINES * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTION WORD EXT F.DNI ADDRESS OF NID EXT F.END END FLAG EXT F.FLN FIRST LINE NUMBER IN MODULE. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LNA ADDRESS OF CURRENT LINE EXT F.LNL LENGTH OF CURRENT LINE EXT F.LNN LINE # OF CURRENT LINE EXT F.NCR NO CROSS REF FLAG EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.NTF NAME TAG FLAG EXT F.NXN NO INPUT FLAG EXT F.SID STATEMEXT ID PHASE FLAG EXT F.TC NEXT CHARACTER EXT F.TRM TERMINATE COMPILE EXT F.$CC SAVED F.CC AT $ STATEMENT BREAK. SKP * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT BNI.F CLEAR NID TO BLANKS EXT Ck3RP.F OUTPUT CROSS-REFERENCE PAIR. EXT CSN.F CHECK STATEMENT NUMBER TYPE. EXT ER.F ERROR PRINT ROUTINE ENT EXN.F EXAMINE NEXT CHARACTER ENT IC.F GET NEXT CHARACTER ENT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) ENT II.F INPUT ITEM ENT IIV.F INPUT INTEGER VARABLE ENT INM.F INPUT NAME ENT IOP.F INPUT OPERATOR ENT ISN.F INPUT STATEMEXT NUMBER ENT ISY.F INPUT SYMBOL EXT ITS.F INTEGER TEST ENT IVN.F INPUT VARIABLE/ARRAY NAME. ENT MCC.F RESET TO FIRST COLUMN OF STATEMEXT EXT NCT.F TEST FOR NOT A CONSTANT ENT PSI.F PRINT SOURCE IMAGE. EXT PSL.F PRINT SOURCE LINE. ENT SCP.F SAVE CURREXT STATPMEXT POSITION. ENT SNC.F START NEXT CARD SUBROUTINE EXT TV.F TAG VARIABLE ENT UC.F UNINPUT COLUMN EXT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) EXT WS1.F WRITE WORD TO PASS FILE #1. * * COMPILER LIBRARY ROUTINES USED * EXT C.SAU SOURCE FCB EXT RED.C READ ROUTINE EXT WRT.C WRITE FILE ROUTINE EXT C.SC0 SCRATCH FILE FCB EXT RWN.C REWIND ROUTINE * * LIBRARY ROUTINES * EXT .MVW EXT IFBRK * SUP * A EQU 0 B EQU 1 SKP * GLOBALS, REFERENCED BY OFFSET FROM F.$IC * EXT F.$IC $ EQU F.$IC * EOSF EQU 0 END-OF-STATEMENT FLAG. FIRST EQU 1 FIRST-CARD FLAG. 0: CONTINUATION ILLEGAL. LINOL EQU 2 ADDR OF (ASCII) LINE # IN CURRENT BUFFER. CBA EQU 3 ADDR OF CARD TEXT IN CURRENT BUFFER. CRD#1 EQU 4 ADDR BUFFER # 1. CD#1 EQU 5 CARD NUMBER (WITHIN STMT) FOR BFR #1. CRD#2 EQU 6 ADDR BUFFER # 2. CD#2 EQU 7 CARD NUMBER (WITHIN STMT) FOR BFR #2. CD# EQU 8 CURRENT CARD NUMBER. DCD# EQU 9 F PTR TO CURRENT CARD BUFFER CARD NUMBER. CD#F EQU 10 # CARDS IN CARD FILE. CD#P EQU 11 CURRENT POSITION IN CARD FILE. CICNT EQU 12 ADDR WORD COUNT IN CURRENT BUFFER. MLIN EQU 13 ADDR CLIB LINE NUMBER IN CURRENT BUFFER. LIFCC EQU 14 COL # OF START OF 1ST CARD CURRENT STMT. FTNF EQU 15 FLAG THAT FTN DIRECTIVE IN PROCESS. * T0IC NOP K73 DEC 73 DCD#1 DEF $+CRD#1 DEF TO CARD BUFFER ADDRESSES B15 OCT 15 CARRAGE RETURN (USED AS END OF LINE) B377 OCT 377 B40 OCT 40 SKP * **************** * * INPUT COLUMN * * **************** SPC 1 IC.F NOP LDB $+CD# IF CURRENT CARD IS ZERO SZB,RSS THEN THERE IS NONE SO JMP IC02 GO FIND ONE * LDB F.CC COLUMN COUNTER. SZB IF F.CC=0, OR CPB K73 END OF CURRENT CARD, JMP IC01 THEN NOT EASY. (FASTEST TEST!) * IC18 ADB KM1 (B) WAS F.CC HERE. CLE,ERB (B)=(F.CC-1)/2 , E=ODD EVEN ADB $+CBA (B)=LOC. OF WORD CONTAINING CHAR. LDA B,I (A)=WORD CONTAINING CHAR. SEZ,RSS F.CC ODD ? ALF,ALF YES, GET LEFT CHAR. AND B377 ISZ F.CC F.CC=F.CC+1 * IC06 STA F.TC C/R, /, OR CHAR. FROM CARD BUFFER JMP IC.F,I EXIT * IC01 SZB F.CC=0 OR 73. WHICH ? JMP IC10 73. GET ANOTHER CARD. * IC00 LDA B15 0. RETURN C/R. JMP IC06 * IC10 LDB F.NXN NO INPUT FLAG SET? LDA B15 SZB JMP IC06 YES - SEND C/R * IC02 ISZ $+CD# BUMP THE CARD NUMBER LDA $+CD# GET THE REQUIRED CARD NUMBER LDB K7 SET THE COLUMN COUNTER CPA K1 BASED ON THE CARD NUMBER LDB $+LIFCC FIRST CARD OF STMT. MAY START ELSE WHERE STB F.CC SET IT LDB DCD#1 PICK A DEF TO BUFFER # 1 CPA $+CD#1 REQUIRED CARD IN BUFFER 1? JMP INC YES GO SET IT UP *  ADB K2 INDEX TO THE NEXT BUFFER CPA $+CD#2 REQUIRED CARD IN BUFFER # 2? JMP INC YES GO SET IT UP * LDA $+CD#1 CARD IS NOT IN MEMORY SO CMA,INA FIGURE WHICH BUFFER WE WILL USE ADA $+CD#2 USE ONE WITH LOWEST NUMBERED CARD IN IT SSA,RSS B CURRENTLY POINTS AT BUFFER 2 SO ADB KM2 ADJUST IF IT IS TO BE 1. JSB SETCA SET UP THE BUFFER ADDRESSES ECT. * LDA $+CD#P GET THE CURRENT FILE COUNT INA DOES THE BUFFER CONTAIN CPA $+DCD#,I THE NEXT CARD TO BE PUT IN THE CARD FILE? CLA,INA,RSS YES MUST WRITE IF .... JMP IC07 NO CARD NEED NOT BE WRITTEN * CPA $+CD# ... FIRST CARD OR ... JMP IC03 (IT IS FIRST CARD) * LDA F.SID ... STILL SCANNING. SZA,RSS WELL...?? JMP IC07 NO CARD NEED NOT BE WRITTEN * IC03 JSB WRT.C WRITE THE CARD IN THE DEF C.SC0 CARD FILE DEF $+CBA,I SO WE CAN GET IT BACK DEF K43 JMP PASER IF ERROR ABORT * ISZ $+CD#F STEP THE COUNT OF CARDS IN THE FILE ISZ $+CD#P AND THE CURRENT POSITION * IC07 LDA $+CD# NOW WE KNOW WHERE TO PUT IT SO FIGURE OUT CMA,INA WHERE TO GET IT ADA $+CD#F GET FROM SCRATCH FILE IF IT CONTAINS THE SSA,RSS THE REQUIRED NUMBER WELL? JMP INF YES GO READ IT IN * JSB RD.F READ A NEW CARD JMP IC08 GO CHECK FOR EOS ECT. * * INC JSB SETCA SET UP THE CURRENT BUFFER JMP IC08 AND GO CHECK FOR EOS ECT. * * SETCA NOP SET UP BUFFER POINTER ROUTINE STB $+DCD# SET LOCAL POINTER TO CARD #. ISZ $+DCD# LDB B,I GET POINTED TO ADDRESS. STB $+LINOL SAVE THE LINE NUMBER LOCATION IN BUFF. ADB K3 SKIP OVER LINE NUMBER. STB $+CBA SET CURRENT BUFFER ADDRESS. ADB K41 INDEX TO CARD LENGTH AREA.  STB $+CICNT SET POINT TO IT. INB AND TO THE LINE COUNT. STB $+MLIN JMP SETCA,I RETURN * KM1 DEC -1 KM2 DEC -2 K1 DEC 1 K3 DEC 3 SKP * ********************** * * CARD IMAGE INPUT * * ********************** SPC 1 RD.F NOP READ ROUTINE RD00 JSB IFBRK CHECK IF HE HAS HAD ENOUGH DEF *+1 SSA WELL JMP BREAK YES GO QUIT * JSB RED.C READ SOURCE FILE DEF C.SAU DEF $+CBA,I DEF K40 80 CHARACTERS JMP F.TRM ERROR ON READ ERROR 98 SSB EOF ? JMP F.TRM YES, GO WRAP IT UP. * STA $+MLIN,I SAVE THE LINE COUNT FROM READ ADB K3 ADD SPACE FOR LINE # TO LENGTH AND STB $+CICNT,I SAVE WORD COUNT IN WD 41 OF CI * LDA B COMPUTE # WDS LEFT IN CARD BUFFER. CMB -(LENGTH+3)-1 ADB K43 (40-LENGTH)-1 = (AMT LEFT)-1 SSB IF NONE JMP IC134 SKIP FILL * STB T0IC SAVE COUNT (ZERO IF ONE WD TO FILL) ADA $+LINOL ADDRESS OF FIRST UNUSED WORD LDB LINO FILL WITH STB A,I BLANKS STA B SET TO MOVE REST INTO PLACE INB A= FROM B= TO JSB .MVW MOVE WORDS DEF T0IC NOP * IC134 LDA KM40 CHECK FOR BLANK CARD: STA T0IC COUNT 40 WORDS, LDB $+CBA STARTING HERE. IC136 LDA B,I CURRENT WORD. CPA LINO BLANK ? INB,RSS YES. ADVANCE TO NEXT & SKIP. JMP IC138 NO. NON-BLANK CARD. * ISZ T0IC COUNT. 40 YET ? JMP IC136 NO. GO ON. * LDA F.END YES. BLANK. BETWEEN MODULES ? SZA,RSS JMP RD06 NO. TREAT AS COMMENT. JMP RD03 YES. IGNORE THE CARD. * IC138 LDA $+MLIN,I GET THE LINE # PASSED IN SSA IF NEGATIVE, JMP RD06 TREAT CARD AS A COMMENT * LDA $+&CD# STUFF THE CURRENT CARD NUMBER STA $+DCD#,I IN THE BUFFER FLAG * LDB $+FTNF FTN FLAG SET? (IT IS 1 IF SO) SZB JMP IC141 YES. CONTROL CARD * LDA $+CBA,I CPA KK10 IF CARD STARTS WITH '$ ' JMP F.TRM GO WIND IT UP * AND KK07. (A)HI=1ST CHAR. OF CARD BUFFER CPA "C" IS IT A 'C' ? RSS CPA "C"L OR LOWER CASE ? JMP RD06 YES, A COMMENT CARD CPA KK06 '*' ALSO COMMENT. JMP RD06 * CPA "D" OPTIONAL CARD? RSS CPA "D"L JMP RD05 YES GO CHECK IF OPTION ENABLED * CPA KK09 DOES IT START WITH '$' ? JMP RD02 YES. NOT A CONTINUATION. * RD04 LDA $+CBA COMPUTE ADDRESS ADA K2 OF THE SIXTH COLUMN LDA A,I AND GET IT AND B377 (A)LO=CI(6) LDB K7 7 CPA B60 RSS "0". CPA B40 RD02 CLB,INB,RSS CLA,RSS SET EOSF (END OF STATEMENT FLAG) LDA $+CD# TO ZERO (NOT END) OR CARD # IF END STA $+EOSF STB F.CC SET THE COLUMN POINTER ISZ $+FIRST ALLOW CONTINUATIONS AFTER THIS STMT. SZA CONTINUATION ? JMP RD.F,I NO. DON'T PRINT IT. * JSB PSI.F YES. PRINT. CLB,INB IF CONTINUATION NOT ALLOWED, CPB $+FIRST CLA,RSS (ERROR) JMP RD.F,I ALLOWED. EXIT. * STA F.END THEN ERROR. CLEAR END FLAG, LDA K90 AND SET ERROR NUMBER. JSB ER.F * IC141 STB F.CC F.CC=1. CLA STA $+FTNF CLEAR THE FTN FLAG STA $+EOSF KEEP READING (WELL, START) JMP RD.F,I DONE. DON'T PRINT IT. * RD05 LDA F.CCW CHECK THE D BIT AND B100 SZA SKIP IF TO BE TREATED AS COMMENT JMP RD04 D IS SET TREAT AS STD. STMT. * RD06 JSB PSI.F PRINT COMMENT CARD. RD03 JSB ULN.F UPDATE LINE # FOR PASS 2. JMP RD00 AND READ ANOTHER CARD * "D" BYT 104,0 "D"L BYT 144,0 KM40 DEC -40 SPC 1 * INF LDA $+CD# CHECK IF A REWIND IS NEEDED CMA,INA IT IS IF REQUESTED CARD IS ADA $+CD#P LESS THAN OR EQUAL TO CURRENT POSITION SSA,RSS WELL? JSB RWCDF YES REWIND THE CARD FILE JSB RED.C READ CARD FROM THE SAVE FILE DEF C.SC0 DEF $+CBA,I DEF K43 JMP PASER ABORT IF ERROR * ISZ $+CD#P STEP THE CURRENT POSITION ON THE SAVE FILE LDA $+CD#P CHECK IF THIS IS THE REQUIRED CARD CPA $+CD# WELL? CLB,RSS YES SKIP OUT JMP INF NO READ AGAIN * STA $+DCD#,I SET BUFFER FLAG TO SHOW CARD IS HERE * IC08 LDA $+EOSF CHECK IF THIS IS THE END OF STATEMENT CARD CPA $+CD# WELL? CLA,RSS YES SET UP TO SEND A C/R JMP IC09 NO. GO UPDATE XREF LINE & GET CHAR. * STA F.CC END OF STATEMENT SET F.CC TO ZERO AND JMP IC00 GO PICK A C/R. (F.CC STAYS ZERO) * IC09 LDA $+MLIN,I LINE NUMBER. STA F.LNN LDB F.CC SET UP FOR IC18. JMP IC18 NOW GO GET CHAR. SPC 1 BREAK LDA K96 SEND THE BREAK ERROR MESSAGE JMP F.ABT AND EXIT PASER LDA K99 ERROR ON CARD FILE. JMP F.ABT * K96 DEC 96 K99 DEC 99 SPC 1 K7 OCT 7 KM7 DEC -7 K2 DEC 2 K40 DEC 40 K41 DEC 41 K90 DEC 90 KK06 BYT 52,0 '*' IN HIGH BYTE. KK07. OCT 177400 "C" BYT 103,0 'C' IN HIGH BYTE. "C"L BYT 143,0 SAME BUT LOWER CASE. KK09 BYT 44,0 '$' IN HIGH BYTE. KK10 ASC 1,$ '$ ' B100 OCT 100 SPC 1 LINO ASC 1, BLANKS FOR FILL ROUTINE SKP * ********************** * * PRINT SOURCE IMAGE * * ********************** SPC 1 * SET UP LINE ADDR, LENGTH, NUMBER. * PSI.F NOP LDA $+CBA SET LINE ADDRESS, LENGTH IN PSL.F STA F.LNA LDA $+CICNT,I ADA KM3 (DON'T PASS ASCII LINE #) SZA,RSS IF ZERO-LENGTH, INA CHANGE TO ONE WORD. STA F.LNL JSB ULN.F UPDATE LINE #. * * IF Q.OR.(M&L).OR.(M&.NOT.COMMENT),PUT IN PASS FILE. * LDA F.CCW AND B4002 'M' OR 'Q' OPTIONS ? SZA,RSS JMP PSI03 NO. DON'T WRITE. * LDA F.CCW -Q,+M,-L ? AND B4003 CPA K2 RSS YES, CHECK FOR COMMENT. JMP PSI01 NO, PASS COMMENTS THRU TOO. * LDA $+CBA,I GET THE FIRST CHARACTER AND KK07. IF 'C' BUT NO 'Q' OPTION CPA "C" THEN RSS CPA "C"L JMP PSI03 DON'T KEEP IT * PSI01 LDA F.LNL COMBINE COUNT & OPERATOR. ALF,ALF IOR K28 JSB WS1.F & WRITE. LDA F.LNL # WDS. CMA,INA STA T1PSI LDA $+CBA ADDR. STA T2PSI PSI02 LDA T2PSI,I OUTPUT IT. JSB WS1.F ISZ T2PSI ISZ T1PSI JMP PSI02 JMP PSI04 DONE. SKP PSI03 LDA K29 JUST LINE BREAK. JSB WS1.F * * IF 'L', BUT NOT 'Q' OR 'M', PRINT IT. * PSI04 LDA F.CCW CHECK IF WE ARE TO LIST IT AND B4003 Q,M,L OPTIONS. CPA K1 IS IT -Q,-M,+L ? CLE,RSS YES. (E=0 FOR ASC.F) JMP PSI05 NO. GO CHECK 'D'. * LDA T0PSI LINE NUMBER. JSB ASC.F CONVERT TO ASCII CHARS SWP SWITCH SO WE CAN USE THE DST STB T1PSI SAVE 3RD & 4TH CHARS. RRR 8 CHANGE TO '4123', AND B377 THE REPLACE THE '4' WITH BLANK. IOR B20K DST $+LINOL,I SET '-123' IN THE CURRENT BUFFER LDA T1PSI NOW GET THE 4TH DIGIT, AND B377 IOR B20K AND APPEND A BLANK, ALF,ALF AFTER IT. LDB $+LINOL NOW PUT IT AFTER THE FIRST THREE. ADB K2 STA B,I  TO FORM: -1234- , THREE WORDS. LDA $+CICNT,I # OF WORDS IN IMAGE LDB $+LINOL LOC OF LINE # JSB PSL.F LIST THE CARD * * IF 'D' IN COLUMN 1, CHANGE GO BLANK. * PSI05 LDA $+CBA,I COLUMNS 1 & 2. AND KK07. UPPER CHAR. CPA "D" WAS IT "D" ? RSS CPA "D"L RSS JMP PSI.F,I NO. EXIT. * XOR $+CBA,I YES. CHANGE TO BLANK. (A)=LOWER. IOR B20K LOWER CHAR .OR. UPPER BLANK. STA $+CBA,I JMP PSI.F,I RETURN SPC 2 KM3 DEC -3 K28 DEC 28 K29 DEC 29 K43 DEC 43 B4002 OCT 4002 B4003 OCT 4003 B20K OCT 20000 BLANK IN UPPER BYTE. T0PSI NOP LINE #. T1PSI NOP COUNTER FOR OUTPUT. T2PSI NOP POINTER FOR OUTPUT. SKP * **************************** * * SET UP TO RESCAN THE STMT * * **************************** SPC 1 MCC.F NOP CLA SET THE CURRENT CARD TO ZERO STA $+CD# TO FOURCE RESCAN STA F.SID CLEAR THE SCAN SWITCH LDB $+LIFCC GET START OF CARD COLUMN CPB K1 IF IT IS 1 THEN LDB K7 CHANGE TO 7 (STMT. # PICKED ON FIRST SCAN) STB $+LIFCC SET THE INITIAL COLUMN JMP MCC.F,I RETURN SPC 2 * ********************************************* * * SET CURRENT POSITION AS START OF STATEMENT* * ********************************************* SPC 1 SCP.F NOP LDA $+CD# GET THE NUMBER OF THE NEW FIRST CARD LDB F.CC ALSO SAVE THE COLUMN POSITION JSB CCB.F CLEAR THE CARD BUFFER JMP SCP.F,I RETURN SPC 2 * **************************** * * SET UP FOR NEW STATEMENT * * **************************** SPC 1 SNC.F NOP SCN1 LDA $+EOSF IF LAST CARD OF PRIOR STMT. SZA NOT READ JMP SCN2 ISZ $+CD# STEP THE CARD NUMBER AND JSB RD.F READ # JMP SCN1 UNTIL IT IS READ * SCN2 CLB,INB SET THE RESET LOCATION JSB CCB.F CLEAR THE CARD BUFFER CLA STA $+EOSF CLEAR THE END OF STMT. FLAG JSB IC.F MAKE SURE LINE IS SET UP. JSB UC.F LDA F.TC IF LINE STARTS WITH $, CPA "$" JMP SNC3 THEN DIRECTIVE. JSB PSI.F ELSE PRINT IT NOW. JMP SNC.F,I RETURN * SNC3 CLA DIRECTIVE. DON'T PRINT, STA $+FIRST AND DON'T ALLOW CONTINUATIONS. JSB ULN.F UPDATE LINE NUMBER, THOUGH. JMP SNC.F,I * "$" OCT 44 $ SKP * ************************ * * REWIND THE CARD FILE * * ************************ SPC 1 RWCDF NOP ROUTINE TO REWIND THE CARD FILE JSB RWN.C REWIND THE CARD FILE DEF C.SC0 AND CLEAR ITS COUNTS JMP PASER ABORT IF ERROR CLA STA $+CD#P RESET THE CURRENT POSITION POINTER JMP RWCDF,I RETURN SPC 2 * **************************** * * CLEAR CARD FILE & BUFFER * * **************************** SPC 1 CCB.F NOP ROUTINE TO CLEAR THE CARD FILE AND BUFFERS STB $+LIFCC SET THE RESET COLUMN CLB,CLE SET THE NO CARD PRESENT FLAG IN B STB $+CD# SET INITIAL CARD NUMBER CPA $+CD#1 IS THIS CARD IN BUFFER 1 OR 2? CCE IT IS IN 1 CLA,SEZ,INA,RSS ARRANGE AN INITIAL CARD # FLAG SWP SWAP IF NEEDED STA $+CD#1 THE FLAGS STB $+CD#2 AS REQUIRED JSB RWCDF REWIND THE CARD BUFFER STA $+CD#F CLEAR ITS COUNT JMP CCB.F,I RETURN SPC 2 * ********************** * * UPDATE LINE NUMBER * * ********************** SPC 1 ULN.F NOP LDA $+MLIN,I CARD COUNT SSA IF NEGATIVE CMA,INA SET POSITIVE STA T0PSI SAVE FOR LIST. LDB F.FLN FIRST LINE # ? SZB,RSS STA F.FLN YES. REMEMBER IT FOR PASS 2. JMP ULN.F,I EXIT. SKP * *********************************** * * INPUT CHARACTER, DETERMINE TYPE * * *********************************** * * ON RETURN A=F.TC=CHARACTER * B=CHAR IF NON-DIGIT, ELSE 0 * E=1 IF DELIMITER, ELSE 0 FOR ALF,NUM. * O=1 IF NON-LETTER, ELSE 0 FOR ALPHA. SPC 1 ICH.F NOP ICH01 JSB IC.F INPUT COLUMN CPA B40 IS CHARACTER A BLANK? JMP ICH01 YES. GET ANOTHER CHARACTER * STO ASSUME NON-LETTER, O=1. CPA "!" COMMENT ESCAPE ? RSS (YES) JMP ICH05 NO. * LDA K73 YES. FORCE END-OF-LINE. STA F.CC JMP ICH01 AND GO FETCH THE C/R. * ICH05 CPA "$" STATEMENT BREAK ? CLA,RSS (YES) JMP ICH02 NO. * LDB F.CC YES. SAVE F.CC, STB F.$CC STA F.CC AND SET IT TO ZERO (END OF STATEMENT). JMP ICH01 GO GET C/R TO RETURN. * ICH02 LDB A SET B=CHAR. ADA BM60 CHAR-60B CCE,SSA E=1. JMP ICH04 F.TC .LT. "0" [0,57B] * ADA BM12 CHAR-72B SSA CLB,CLE,RSS F.TC IS A DIGIT [60B,71B] (E=0) * ADA KM7 CHAR-101B SSA (IF DIGIT, SKIPS TO HERE, A<0, E=0) JMP ICH04 NON-ALPHANUM. [72B,100B] * ADA BM32 CHAR-133B SSA JMP ICH03 UPPER CASE. [101B,132B] * ADA KM6 CHAR-141B SSA JMP ICH04 NON-ALPHANUM. [133B,140B] * ADA BM32 CHAR-173B SSA,RSS JMP ICH04 NON-ALPHANUM. [173B,177B] * ADA B133 LOWER CASE. [141B,172B] STA F.TC FOLD TO UPPER: CHAR-40B LDB A SET NEW (B)=CHAR. ICH03 CLE LETTER. (E) = 0. CLO AND (O) = 0. ICH04 LDA F.TC CHAR . JUST INPUT JMP ICH.F,I EXIT. * BM60 OCT -60 BM32 OCT -32 BM12 OCT -12 B133 OCT 133 "!" BYT 0,41 SKP * ****************** * * UNINPUT COLUMN * * ****************** SPC 1 UC.F NOP LDA F.CC F.CC=F.CC-1 SZA,RSS UNLESS F.CC=0, JMP UC.F,I INWHICHCASE LEAVE IT ALONE. * CMA,INA DO IT THIS WAY SO THAT CMA THE 'E' BIT IS PRESERVED. STA F.CC (SO EXN.F RETURNS PROPER FLAGS.) JMP UC.F,I SPC 2 * ************************** * * EXAMINE NEXT CHARACTER * * ************************** SPC 1 EXN.F NOP JSB ICH.F INPUT CHARACTER JSB UC.F UNINPUT COLUMN LDA F.TC RETURN NEXT CHAR JMP EXN.F,I RETURN NFL IN B SKP * ************** * * INPUT ITEM * * ************** SPC 1 II.F NOP JSB EXN.F STRIP OFF BLANKS PRECEDING ITEM JSB IDN.F INPUT DNA SZA F.IM=0, POSSIBLE ERROR CPA TWPE ALSO IF PSUDO JMP II.F,I * JSB AI.F ASSIGN ITEM STA T2II SAVE F.IM LDA F.NT IOR F.NCR SZA,RSS IS NAME TAG = 0? JSB CRP.F YES, BUILD CROSS REFERENCE PAIR LDA T2II RETURN F.IM JMP II.F,I * T2II NOP K24 DEC 24 TWPE OCT 40000 ARR OCT 600 F.IU=ARR. SPC 2 * ***************************** * * INPUT VARIABLE/ARRAY NAME * * ***************************** SPC 1 IVN.F NOP JSB INM.F FIRST, MUST BE A NAME. LDA F.IU THEN: IF NOT ALREADY ARRAY, CPA ARR RSS JSB TV.F FORCE IT TO BE A VARIABLE. JMP IVN.F,I DONE. SKP * ************** * * INPUT NAME * * ************** SPC 1 INM.F NOP JSB IOP.F INPUT OPERAND LDA K24 LDB F.NT IS OPERANDd A NAME? SZB JSB ER.F NO. GRIPE LDA F.IM YES, (A)=F.IM OF THE OPERAND JMP INM.F,I SPC 2 * **************** * * INPUT SYMBOL * * **************** SPC 1 ISY.F NOP CLA,INA STA F.NTF SET NO-TAG FLAG JSB INM.F INPUT NAME JMP ISY.F,I SPC 2 * ************************** * * INPUT INTEGER VARIABLE * * ************************** SPC 1 IIV.F NOP JSB IOP.F INPUT OPERAND JSB TV.F TAG VARIABLE JSB ITS.F INTEGER TEST JSB NCT.F NON-CONSTANT TEST JMP IIV.F,I SPC 2 * ***************** * * INPUT OPERAND * * ***************** SPC 1 IOP.F NOP JSB II.F INPUT ITEM SZA JMP IOP.F,I (A)=F.IM OF THE OPERAND LDA K17 JSB ER.F DELIMITER FOUND WHEN OPERAND EXPECTED * K17 DEC 17 SKP * ************************** * * INPUT STATEMENT NUMBER * * ************************** * * ENTER WITH A = TYPE: -1 = FORMAT. * 0 = DON'T CARE. * +1 = NON-FORMAT. SPC 1 ISN.F NOP STA T3ISN SAVE TYPE. JSB BNI.F CLEAR NID TO BLANKS LDA K64 '@' LDB F.DNI SET UP POINTER TO LAST CHAR STORED. STB T2ISN STA B,I SET FIRST WORD TO '@' LDA KM6 STA T1ISN T1=-6 LDA F.CC ARE WE READING THE DEFINITION, ADA KM7 OR A REFERENCE ? SSA,RSS JMP ISN04 REFERENCE. (F.CC > 6) * * DEFINITION IN COL 1-5. * ISN01 JSB IC.F READ ANOTHER CHAR. LDA F.CC IF IT WAS IN COL 6, CPA K7 JMP ISN06 THEN DONE. * LDA F.TC IF BLANK, CPA B40 JMP ISN01 THEN SKIP IT. * ADA BM60 DIGIT ? SSA FIRST, < "0" ? JMP ISN09 YES. ERROR. * ADA BM12 THEN > "9" ? SSA,RSS JMP ISN09 YES. ERROR. * LDA F.TC DIGIT. RESTORE F.TC CPA B60 IF A ZERO, RSS JMP ISN02 (NO) * LDB T2ISN IS IT A LEADING ZERO ? CPB F.DNI JMP ISN01 YES. SKIP IT. * ISN02 ISZ T2ISN NORMAL DIGIT, SAVE IT. STA T2ISN,I JMP ISN01 GO FOR MORE. * * ERROR IN STATEMENT #. * ISN09 LDA B40 ERROR # 32. JSB ER.F SKP * REFERENCE AFTER COL 6. * ISN04 JSB ICH.F INPUT CHAR. SZB DIGIT ? JMP ISN07 NO. DONE. * CPA B60 ZERO ? RSS JMP ISN05 (NO) * LDB T2ISN YES. LEADING ? CPB F.DNI JMP ISN04 YES. SKIP IT. * ISN05 ISZ T1ISN NORMAL DIGIT. SIXTH ONE ? RSS NO. JMP ISN09 YES. ILLEGAL STMT #. * ISZ T2ISN STORE DIGIT INTO NID BUFFER STA T2ISN,I JMP ISN04 AND GO FOR MORE. * * GOT THE WHOLE NUMBER. ENTER IN SYMBOL TABLE. * ISN06 JSB EXN.F FOR DEFINITION, PEEK AT NEXT CHAR. ISN07 LDB T2ISN ALL ZEROES ? CPB F.DNI JMP ISN09 YES. ERROR. * CLA STA F.IU F.IU=0 STA F.NT F.NT=0 STA F.IM F.IM=0 CLA,INA SET THE NO-TAG FLAG. STA F.NTF JSB AI.F ASSIGN ITEM JSB CRP.F BUILD CROSS REFERENCE PAIR LDA T3ISN TYPE. LDB F.A SZA DO WE CARE ? JSB CSN.F YES. CHECK IT OUT. LDA F.IM RETURN F.IM IN (A) JMP ISN.F,I * T1ISN BSS 1 COUNT FOR NO. OF DIGITS T2ISN BSS 1 NID BUFFER POINTER T3ISN BSS 1 TYPE. B60 OCT 60 K64 DEC 64 "@" KM6 DEC -6 * END ASMB,Q,C HED SCANNER FOR FTN4X. NAM IDN.F,8 92834-12001 REV.2030 800820 * ********************************************h******************* * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18001 * * RELOC: PART OF 92834-12001 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMENT TABLE ADDR OF CURRENT ENTRY. EXT F.CCW FTN OPTION WORD EXT F.CSL CHARACTER STRING LENGTH, CURRENT F.A EXT F.DID ADDRESS OF F.IDI EXT F.DNI ADDRESS OF NID ENT F.DPK DEF TO F.PAK BUFFER. EXT F.DTY IMPLICIT TYPE TABLE ENT F.EIM EXPECTED ITEM MODE. EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S2T TOP OF STACK 2 EXT F.SID STATEMEXT ID PHASE FLAG ENT F.SIM SAVED ITEM MODE (NEGATIVE CONSTANTS) EXT F.SLF STATEMENT LEVEL FLAG. ENT F.STC SAVED F.TC (NEGATIVE CON/STANTS) EXT F.SXF COMPLEX CONSTANT FLAG EXT F.TC NEXT CHARACTER * * ENT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT BNI.F CLEAR NID TO BLANKS EXT CDI.F CLEAR IDI ROUTINE EXT DL.F DEFINE LOCATION SUBROUTINE EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER. EXT IC.F GET NEXT CHARACTER EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT ENT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) ENT ISC.F INPUT STRING CONSTANT. EXT KWS.F KEYWORD SEARCH. EXT MVW.F INTERNAL MOVE WORDS. ENT PAK.F PACK & OUTPUT ASCII DATA. ENT RP.F INPUT ')' EXT TCT.F TEST (A) = F.TC ELSE ER 28 EXT UC.F UNINPUT COLUMN. EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) EXT WS1.F WRITE ONE WORD TO PASS FILE 1. * * EXT .MVW LIBRARY MOVE WORDS ROUTINE * * * A EQU 0 B EQU 1 SUP SKP * *********************** * * INPUT DO NOT ASSIGN * * *********************** SPC 1 * START BY CLEARING STATE. ASSUME IT'S A NUMBER. * IDN.F NOP CLA STA F.IU F.IU=0 STA F.NT F.NT=0 STA HFLAG NOT HOLLERITH. STA F.SIM NOT NEGATIVE CONSTANT. JSB EXN.F PEEK AT NEXT CHARACTER. ADA BM101 LETTER ? SSA JMP IDN04 NO. GO TRY NUMBER. * * NAME. READ IT. * JSB ICH.F READ 1ST CHARACTER. LDB F.TC GET THE CHARACTER AND ADB BM101 USE IT TO INDEX CLE,ERB INTO THE ADB F.DTY IMPLICIT TYPE TABLE LDA B,I GET TYPE FORM THE TABLE SEZ ROTATE IT ALF,ALF IF REQUIRED AND B170K ISOLATE THE TYPE STA F.IM SET THE IMPLICIT TYPE JSB BNI.F CLEAR NID BUFFER TO BLANKS LDA KM6 STA T4IDN SET CHAR. COUNT TO -6 LDB F.DNI LOC. OF 1ST WORD OF NID BUFFER STB T5IDN LDA F.TC STORE CHAR. INTO NID BUFFER IDN02 STA T5IDN,I JSB ICH.F INPUT A CHAR. SEZ IS IT ALPHANUMERIC?? JMP IDN11 NO * ISZ T5IDN INCREMENT NID BUFFER POINTER ISZ T4IDN 6 CHARS INPUT? JMP IDN02 NO. GET ANOTHER * JMP IDN11 YES QUIT EVEN IF NOT DONE WITH SYMBOL SKP T4IDN NOP T5IDN NOP T7IDN BSS 4 SAVED FIRST PART OF COMPLEX CONSTANT. HFLAG NOP ZPX OCT 140000 F.IM=12 DOUBLE COMPLEX CPX OCT 50000 DO NOT REARRANGE THESE ***** DBL OCT 60000 CONSTANTS ***** REA OCT 20000 F.IM=2 REAL ***** INT OCT 10000 F.IM=1 INTEGER ***** TPADD DEF INT+1 USED TO INDEX INTO ABOVE FOR HOLL. CONST. B170K OCT 170000 BM101 OCT -101 B60K EQU DBL * * CONSTANT OR OPERATOR. LET INC.F DECIDE. * IDN04 JSB INC.F GET A CONSTANT. SZA,RSS F.IM=0 ? JMP IDN11 YES, NO SUCH LUCK. * LDB F.SXF COMPLEX FLAG SET ? SZB,RSS JMP IDN10 NO. LDB F.TC YES. F.TC = ',' ? CPB B54 RSS YES. JMP IDN10 NO. LDB F.SID SCAN MODE ? SZB JMP IDN11 YES, DONE. * * COMPLEX CONSTANT. * CPA RE8 MUST BE COMPLEX. SINGLE OR DOUBLE ? (B=0) INB,RSS DOUBLE. B=1. CPA REA NO. SINGLE ? BLS,SLB SINGLE: B=0. DOUBLE: B=2 JMP IDN15 NO. ERROR. * ADB K2 B = 2/4 AS SINGLE/DOUBLE COMPLEX. STB T6IDN T6IDN = # WORDS IN EACH PART. ADB F.DID T4IDN = ADDR OF SECOND PART. STB T4IDN STA T5IDN T5IDN = TYPE OF FIRST PART. JSB MVW.F SAVE FIRST PART. DEF T7IDN IN T7IDN (UP TO 4 WORDS) DEF F.IDI DEC 4 JSB INC.F GET SECOND PART. CPA T5IDN MUST BE SAME TYPE AS FIRST PART. RSS JMP IDN15 * LDB CPX SET UP NEW F.IM: SINGLE, CPA RE8 LDB ZPX OR DOUBLE COMPLEX. STB F.IM JSB RP.F & FOLLOWED BY ')' JSB MVW.F FORM COMPLEX CONSTANT. DEF T4IDN,I MOVE SECOND PART UP. DEF F.IDI DEC 4 JSB MVW.F MOVE SAVED FIRST PART IN. DEF F.IDI DEF T7IDN T6IDN ABS *-* 2/4 AS TYPE. SKP * ALL DONE. IF CONSTANT, ESTABLISH IT. * SOAK UP ANY DOT OPERATOR FOLLOWING. * IDN10 LDA F.IM SET UP CONSTANT. JSB ESC.F IDN11 JSB IDO.F THIS MAY BE REDUNDANT. JMP IDN10 IF .TRUE. OR .FALSE., SET UP CONSTANT. CLA CLEAR COMPLEX FLAG. STA F.SXF LDB F.SIM SPECIAL NEGATIVE CONSTANT ? SZB,RSS JMP IDN13 NO. * LDB F.TC YES. NEG HOLLERITH OR EXPONENTIATION. STB F.STC REMEMBER THE CONSTANT. LDB F.IM STB F.SIM STA F.IM AND SEND '-' BACK FOR NOW. LDA B55 STA F.TC * IDN13 LDA F.IM RETURN (A) = F.IM. LDB HFLAG (B) = HOLLERITH FLAG. JMP IDN.F,I EXIT. * IDN15 LDA K8 COMPLEX CONSTANT ERROR. JSB ER.F * F.SIM NOP SAVED ITEM MODE & NEG CONST FLAG. F.STC NOP SAVED F.TC WHEN F.SIM#0. KM2 DEC -2 K4 DEC 4 B40 OCT 40 TWPE OCT 40000 SUBCL BYT 32,1 K20 DEC 20 B15 OCT 15 K8 DEC 8 B54 OCT 54 SKP * **************************** * * INPUT HOLLERITH CONSTANT * * **************************** SPC 1 * VERIFY COUNT > 0. IF SCANNING, JUST SKIP CHARACTERS. * IDN72 DLD F.IDI+2 (A,B) = COUNT, < 2**31. SZA,RSS IF >= 2**15 = 32768, SSB JMP IHC06 ERROR. * LDA K20 CM{B,INB,SZB,RSS SET HOLL. COUNT NEGATIVE JSB ER.F ERROR: EMPTY HOLLERITH STRING * STB T4IDN KEEP THE NEGATIVE COUNT STB HFLAG SET HOLLERITH FLAG. LDA F.SID NOT CODE GEN.? SZA,RSS SCANING? JMP IHC01 NO. NORMAL CODE GEN. * IHC00 JSB IC.F SCANNING. SKIP (N) CHARACTERS. ISZ T4IDN COUNT. ALL DONE ? JMP IHC00 NO, GO ON. * JSB IC.F READ DELIMITER. JMP IDN11 EXIT. * * SEE WHETHER NORMAL CONSTANT OR HOLLERITH PARAMETER. * IHC01 LDA SIGN IF NEG COUNT, SET FLAG (FOR SHORT). SSA ISZ F.SIM ADB K8 NORMAL CONSTANT AT MOST 8 CHARS. SSB,RSS JMP IHC02 LESS THAN 9-CHAR. OK * LDB F.S2T,I GET THE CURRENT TOP OF STACK RBL,CLE,ERB CLEAR POSSIBLE SIGN BIT CPB SUBCL IF SUBROUTINE PRAM. SSA AND POS. COUNT, O.K. JMP IHC06 ELSE ILLEGAL LONG HOLL. * LDA TWPE SET UP A TWPE ENTRY JSB ESC.F TO REMEMBER THE ADDRESS. JSB AI.F JSB DL.F START IT RIGHT HERE. JMP IHC03 SKIP OTHER TYPE. SKP * NORMAL CONSTANT. SET UP TYPE. * IHC02 LDB T4IDN GET THE NEGATIVE COUNT BRS DIVIDE BY TWO ADB TPADD ADD THE BASE ADDRESS LDB B,I GET THE TYPE LDA F.CCW 'J' OPTION. AND B10K CPB REA IF 3-4 CHARS SZA,RSS & 'J' OPTION, RSS (NO) LDB DBI THEN MAKE IT (DBI), NOT (REA). STB F.IM SET THE ITEM MODE * * INPUT THE PROPER NUMBER OF CHARACTERS. * IF NORMAL, WON'T FORCE FLUSH OF PAK.F BUFFER. * IHC03 CCA INITIALIZE PAK.F CLB OFFSET = 0. JSB PAK.F IHC04 JSB IC.F READ NEXT CHARACTER. CPA B15 C/R ? LDA B40 YES, USE BLANK. JSB PAK.F PACK IT. ISZ T4IDN MORE)l ? JMP IHC04 YES. * * FOR NORMAL CONSTANTS, COPY DATA TO F.IDI * LDA F.IM WHICH ? CPA TWPE SUB PARAM = TWPE. JMP IHC05 SUBROUTINE PARAMETER. * LDA F.DPK NORMAL. COPY FROM F.PAK BUFFER. LDB F.DID JSB .MVW DEF K4 NOP JSB ICH.F INPUT NEXT CHAR. JMP IDN10 GO FINISH UP. * * FOR SUBROUTINE PARAMETERS, FLUSH PAK.F BUFFER * AND MAKE SURE DELIMETER IS ',' OR ')' . * IHC05 LDA KM2 FLUSH BUFFER. JSB PAK.F ADB F.RPL UPDATE F.RPL STB F.RPL JSB ICH.F (A) = NEXT NON-BLANK. CPA B54 MUST BE ',' RSS CPA B51 OR ')' JMP IDN11 YES, FINISH UP. * IHC06 LDA K20 NO, ERROR. JSB ER.F SKP * ********************************** * * FINISH INPUT OF OCTAL CONSTANT * * ********************************** SPC 1 INB01 JSB ICH.F SKIP PAST THE "B". LDA F.SID SCAN MODE ? SZA JMP INC.F,I YES, DONE. * JSB CEX.F CHECK FOR '**' * LDB BILGD 8 OR 9 ? LDA K16 SZB JSB WAR.F YES, WARNING. LDB BOVFL OVERFLOW ? LDA K16 SZB JMP INB02 YES, WARNING & DOUBLE. * LDB F.SLF DATA STATEMENT ? CPB K2 RSS (YES) JMP INB05 NO. * LDA F.EIM YES. EXPECTED TYPE ? CPA DBI JMP INB03 DOUBLE. * LDB B.IDI SINGLE. OVERFLOW ? LDA K16 SZB JSB WAR.F YES. WARNING. LDB B.IDI+1 THEN FORCE SINGLE ANYWAY. JMP INB06 * INB05 LDA F.CCW NO. 'J' OPTION ? AND B10K SZA JMP INB03 YES, DOUBLE. * DLD B.IDI SINGLE OR DOUBLE ? SZA (SINGLE IF UPPER WORD = 0) JMP INB03 DOUBLE. * INB06 LDA SIGN SINGLE. NEGATE ? SSA Pz CMB,INB YES. DO IT. * STB F.IDI SINGLE. SET UP F.IDI & F.IM LDA INT JMP INC16 * INB02 LDA K16 OVERFLOW WARNING. JSB WAR.F * INB03 LDA SIGN DOUBLE. NEGATE IF SIGN#0. ELA COPY SIGN TO (E). DLD B.IDI VALUE. SEZ,RSS NEGATE ? JMP INB04 NO. CMA YES. DO IT. CMB,INB,SZB,RSS INA INB04 DST F.IDI LDA DBI JMP INC16 * K16 DEC 16 SPC 2 * ********************** * * INPUT DOT OPERATOR * * ********************** SPC 1 * ENTRY: F.TC=FIRST CHAR OF CANDIDATE. IF F.TC#'.', EXIT, ELSE * CHECK IT FOR BEING A DOT OPERATOR. IF NOT, ERROR 28. * IF .FALSE. OR .TRUE. : * IF F.IM#0, ERROR, ELSE SET UP THE CONSTANT. * EXIT: F.TC= FIRST TWO CHARACTERS OF OPERATOR NAME, E.G. 'EQ'. * RETURNS TO P+1 IF .FALSE. OR .TRUE. * P+2 IF OTHER OR SCAN MODE. SPC 1 * SEARCH FOR MATCHING KEYWORD & VERIFY TRAILING '.' * IDO.F NOP LDA F.TC STARTS WITH DOT ? CPA "." CCA,RSS YES. (A=-1) JMP IDO03 NO. LEAVE IT AS IS. * JSB KWS.F YES. SEARCH FOR KEYWORD. DEF DOTOP SZA,RSS FOUND ONE ? JMP IDO02 NO. ERROR. * * IF NOT TRUE/FALSE, SET F.TC = 1ST TWO CHARS & EXIT. * ADA TRORD TRUE=0, FALSE=1, OTHER < 0. SSA,RSS WELL ? JMP IDO01 TRUE/FALSE * ADA DLGOP OP. GET FIRST TWO CHARS. LDA A,I STA F.TC F.TC = FIRST TWO CHARS. JMP IDO03 NORMAL EXIT. SKP * TRUE/FALSE: 1) MAKE SURE NO PREVIOUS OPERAND. * 2) SET VALUE. * 3) PICK SINGLE OR DOUBLE LOGICAL. * IDO01 LDB F.IM CAN'T HAVE AFTER AN OPERAND. SZB DOES IT ? JMP IDO02 *YES. ERROR. * ADA KM1 TRUE: -1 FALSE: 0 AND B100K TRUE: 100000B FALSE: 0 STA F.IDI SET VALUE (FIRST WORD IF DOUBLE) STB F.IDI+1 SECOND WORD = 0 IN CASE DOUBLE. LDA F.SID SCAN MODE ? SZA JMP IDO03 YES, QUIT NOW. * LDA F.CCW 'J' OPTION ? AND B10K LDB LOG SINGLE LOGICAL IF NOT. SZA LDB LO4 DOUBLE LOGICAL IF SO. STB F.IM SET F.IM JSB ICH.F READ NEXT CHAR. JMP IDO.F,I RETURN P+1 (TO DO ESC.F) * * ERROR. IGNORE IF SCAN MODE. * IDO02 LDB F.SID ERROR. SCAN MODE ? LDA K28 (ERROR 28) SZB,RSS JSB ER.F 28: UNEXPECTED CHARACTER. IDO03 ISZ IDO.F BUMP RETURN POINT & EXIT.TER. JMP IDO.F,I SPC 2 K2 DEC 2 K28 DEC 28 LOG OCT 30000 LO4 OCT 110000 * DOTOP ASC 19,LT. LE. EQ. NE. GE. GT. OR. AND. NOT. , ASC 18,EQV. XOR. EOR. NEQV. TRUE. FALSE. , * TRORD DEC -14 -(ORDINAL OF .TRUE., FROM 1) * LOGOP ASC 13,LTLEEQNEGEGTORANNOEVXOXOXO DLGOP DEF * (LAST ABOVE)+1 "EQ" EQU LOGOP+2 "EV" EQU LOGOP+9 SKP * **************************** * * PACK & OUTPUT ASCII DATA * * **************************** SPC 1 * ENTRY: A>=0: PACK THE CHARACTER IN (A). * A=-1: INITIALIZE. F.A = A.T. ADDR OF ITEM. * IF ZERO, IS PROGM-RELATIVE. * (B) = OFFSET WITHIN ITEM. * A=-2: FLUSH THE BUFFER. RTNS (B)=LWA+1. (OFFSET) SPC 1 * FIRST, FLUSH BUFFER IF NEED BE. * PAK.F NOP STA T2PAK SAVE VALUE FOR LATER. INA,SZA INITIALIZE CALL ? JMP PAK03 NO. * STB T3PAK YES. SAVE OFFSET FOR OUTPUT. LDA F.A AND THE F.A VALUE. STA T4PAK JMP PAK05 GO INITIALIZE. * PAK03 LDB T0PAK BUFFER FULL, INA,SZA C OR FLUSH CALL ? CPB K20 RSS (YES) JMP PAK06 NO. JUST OUTPUT CHAR. * LDA T0PAK YES, FLUSH. (A) = # CHARS OUTPUT. INA ROUND UP TO WHOLE WORD. ARS (A) = # WORDS. STA T0PAK SZA,RSS ANY ? JMP PAK05 NO. GO RE-INIT & EXIT. * ADA K3 FORM & OUTPUT OPCODE. (3 HEADER WDS) ALF,ALF IOR K51 DATA STATEMENT OPERATOR. JSB WS1.F LDA T4PAK ITEM F.A JSB WS1.F LDA T3PAK OFFSET. JSB WS1.F LDA K1PS 1+SIGN BIT: REPEAT, ASCII. JSB WS1.F LDA T3PAK UPDATE OFFSET. ADA T0PAK STA T3PAK LDA T0PAK SET UP LOOP COUNTER. CMA,INA STA T0PAK LDA F.DPK SET UP LOOP TO OUTPUT. STA T1PAK PAK04 LDA T1PAK,I ONE WORD. JSB WS1.F ISZ T1PAK NEXT! ISZ T0PAK DONE ? JMP PAK04 NO. * PAK05 LDA F.DPK RESET BUFFER POINTER. STA T1PAK CLA T0PAK = 0, # CHARS IN BUFFER. STA T0PAK * * IF IT'S A DATA CALL, PACK THE CHARACTER. * PAK06 LDA T2PAK WELL ? LDB T3PAK (IN CASE NOT, (B)=LWA+1) SSA JMP PAK.F,I NO, INIT OR FLUSH. DONE. * ISZ T0PAK CHARACTER. COUNT IT. LDB T0PAK FIRST OR SECOND IN WORD ? SLB JMP PAK07 FIRST. GO STORE. * XOR B40 SECOND. PACK & OUTPUT. XOR T1PAK,I (REPLACES BLANK WITH CHARACTER) STA T1PAK,I ISZ T1PAK ADVANCE TO NEXT WORD. JMP PAK.F,I EXIT. * PAK07 ALF,ALF FIRST. PAD WITH A BLANK. IOR B40 STA T1PAK,I & STORE. JMP PAK.F,I EXIT. SPC 2 T0PAK NOP CURRENT # CHARS IN BUFFER (< 21) T1PAK NOP ADDR OF WORD WITH LAST CHAR PACKED. T2PAK NOP SAVED INPUT VALUE. T3PAK NOP OFFSET TO WRITE NEXT BUFFER TO. T4PAK NOP SAVED ITEM\ F.A F.DPK DEF FBUF ADDR OF BUFFER. FBUF BSS 10 10-WORD ASCII BUFFER. K51 BYT 0,63 DATA STATEMENT OPERATOR. K1PS OCT 100001 1 + SIGN BIT. K3 DEC 3 SKP * ************************* * * INPUT STRING CONSTANT * * ************************* SPC 1 * ENTRY: F.TC = LEADING SINGLE QUOTE. * EXIT: F.TC = CHARACTER AFTER TRAILING SINGLE QUOTE. * F.A = A.T. ADDR OF STRING CONSTANT. * ISC.F NOP CLA SET CHAR COUNT = 0. STA F.CSL STA F.A SET F.A=0 FOR PAK.F (PROGM REL) CCA INITIALIZE PAK.F LDB F.RPL JSB PAK.F ISC01 JSB IC.F NEXT CHAR. CPA B15 IF C/R, JMP ISC99 THEN ERROR - TERMINATED WITHOUT QUOTE. * CPA B47 SINGLE QUOTE ? RSS (YES) JMP ISC03 NO. * JSB IC.F YES. GET CHARACTER AFTER IT, CPA B47 TO SEE IF PAIR OF QUOTES. RSS YES; TREAT PAIR AS SINGLE ONE. JMP ISC04 NO. AT END. * ISC03 JSB PAK.F ELSE PACK THE CHARACTER. ISZ F.CSL AND COUNT IT. JMP ISC01 AND GO ON. * ISC04 CPA B40 HAVE CHAR AFTER END; IF BLANK, JSB ICH.F SKIP BLANKS & READ NEXT NON-BLANK. LDB F.CSL IF ODD # CHARS, LDA B40 SLB JSB PAK.F PACK ANOTHER BUT DON'T COUNT IT. * * CREATE SYMBOL TABLE ENTRY FOR IT. * LDA CHAR SET UP FIELDS FOR CONSTANT. JSB ESC.F LDA F.DPK MOVE 10 WORDS INTO F.IDI, LDB F.DID EVEN IF THEY'RE JUNK. JSB .MVW DEF K10 NOP JSB AI.F FIND OR CREATE A.T. ENTRY. LDA F.CSL LONG OR SHORT STRING ? ADA KM21 SSA JMP ISC.F,I SHORT. ALL DONE. SKP * LONG STRING. FLUSH BUFFER & SAVE ADDR. * LDA KM2 LONG. FLUSH PAK.F BUFFER. JSB PAK.F (NOW (B) HAS UPDATED F.RPL) ) LDA F.RPL (A) = OLD F.RPL = FWA CONSTANT. STB F.RPL UPDATE F.RPL = LWA+1 CONSTANT. LDB F.A GET EXTENSION ADDR. INB LDB B,I ADB K2 = POSITON OF BYTE ADDR FIELD. CLE,RAL BYTE ADDR. STA B,I STUFF IT. JMP ISC.F,I DONE. * ISC99 LDA K13 C/R BEFORE ENDING QUOTE. JSB ER.F DOWN THE TUBES. * K10 DEC 10 K13 DEC 13 B47 OCT 47 SINGLE QUOTE. CHAR OCT 130000 F.IM=CHAR. KM21 DEC -21 SKP * ******************** * * )-INPUT OPERATOR * * ******************** SPC 1 RP.F NOP LDA B51 F.TC MUST BE ')' JSB TCT.F F.TC-TEST JSB ICH.F INPUT CHARACTER JMP RP.F,I * B51 OCT 51 SPC 2 * GLOBALS. * EXP NOP EXPONENT D NOP -D-1 EXPON NOP EXPONENT PART OF NUMBER POST NOP INPUT CONTROL INDICATOR SIGN NOP SIGN OF NUMBER. MANTL NOP LWA DITTO * * ADDRESS CONSTANTS & SHIFT INSTRUCTIONS. * MULTZ DEF MULT DIVDZ DEF DIVD MANTE DEF F.IDI+5 LWA+1 MANTISSA * * NUMERIC AND CHARACTER CONSTANTS. * KM4 DEC -4 KM1 DEC -1 B53 OCT 53 B55 OCT 55 "." OCT 56 "D" OCT 104 "E" OCT 105 SKP * PTEN - SCALE NUMBER BY A POWER OF TEN. * * PTEN MULTIPLIES THE VALUE IN (MANT...MANT2) AND (EXP) * BY 10**(A). NO CHECK IS MADE FOR OVERFLOW/UNDERFLOW. * * CALLING SEQUENCE: * LDA POWER * JSB PTEN SPC 2 PTEN NOP SZA,RSS IF N=0, LEAVE ALONE. JMP PTEN,I SSA,RSS N>0 ? JMP PTEN1 YES. CMA,INA NO, TAKE IABS(N) STA T1PTN JSB RSN RIGHT SHIFT MANTISSA TWO BITS. JSB RSN LDB DIVDZ SET "DIVIDE" JMP PTEN2 PTEN1 LDB MULTZ SET "MULTIPLY" STA T1PTN T1PTN = IABS(N) PTEN2 STB T2PTN T2PTN = ADDR MULT OR DIVD PTEN3 LDA T1PTN A=N ADA KM6 N-6 CLE,SSA N<6 ? (E=0 FOR MULT) JMP PTEN4 YES, GO DO LAST ONE. STA T1PTN NO, MULT/DIV BY 10**6 LDA PWR1A+10 LDB PWR1A+11 JSB T2PTN,I JMP PTEN3 TRY AGAIN. PTEN4 ADA K5 A = N-1 RAL,CLE,SLA N=0 ? JMP PTEN5 YES, GO NORMALIZE. ADA PWR10 GET POWER OF TEN. (E=0 FOR MULT.) DLD A,I JSB T2PTN,I GO MPY DIV USING IT. PTEN5 JSB NORML NORMALIZE. JMP PTEN,I * T1PTN NOP T2PTN NOP SKP * INDIG TAKES A DIGIT AND COMBINES IT WITH THE RUNNING MANTISSA. * THE RUNNING MANTISSA IS NOT IN A USABLE FORM UNTIL A TERMINATION * CALL IS MADE. IT IS THEN USABLE BUT MAYBE NOT NORMALIZED. * * CALLING SEQUENCE: LDA (NEG FOR TERMINATION) * JSB INDIG * * ANY TRAILING ZEROES OR DIGITS AFTER THE LIMIT (20) * AFFECT ONLY THE TRAILING ZERO COUNT IN "T4INP". SPC 1 * CHECK FOR ZERO, EXTRA DIGIT OR TERMINATION. * INDIG NOP STA T1IND SAVE DIGIT. SSA TERMINATION CALL ? JMP INDI7 YES. * * ACCUMULATE OCTAL. * STA T2IND SAVE DIGIT. CPA K8 IF 8 OR 9, RSS CPA K9 ISZ BILGD ILLEGAL DIGIT. DLD B.IDI GET TOP 3 BITS. AND B160K SZA ANY SET ? ISZ BOVFL YES, OVERFLOW. XOR B.IDI GET TOP WORD WITHOUT BITS. RRR 13 SWAP & LEFT SHIFT 3. IOR T2IND INSERT DIGIT. STA B.IDI+1 STB B.IDI LDA T2IND (A) = DIGIT. * * CHECK FOR ZERO OR LIMIT. * INDI1 LDB MANTE NO. AT LIMIT ? RBL,CLE,SLB,ERB (REMOVE POSSIBLE INDIRECT) LDB B,I SZA OR ZERO DIGIT ? CPB MANTL JMP INDI6 YES, JUST COUNT IT. * * GOOD DIGIT. ADD' IT OR A SKIPPED ZERO. * LDA T1INP NO. GOOD DIGIT. MULTIPLY OTHERS BY 10. ALS,ALS ADA T1INP ALS LDB T4INP ANY UNUSED ZEROES ? SZB,RSS IF SO, ADD THEM FIRST. ADA T1IND IF NOT, ADD THIS DIGIT. STA T1INP ISZ T2INP COUNT DIGITS. FULL GROUP OF 4 ? JMP INDI5 NO. LDA K5000 YES, ADD THEM. INDI2 LDB KM16 MAKE ROOM. CMB,CCE,INB B=16, E=1. JSB MULT LDB MANTL ADD DIGIT(S) ISZ MANTL LDA B,I CLE ADA T1INP STA B,I CCA,SEZ,RSS CARRY ? JMP INDI4 NO. INDI3 ADB A PROPOGATE IT. ISZ B,I RSS JMP INDI3 * INDI4 LDA KM4 RESET COUNT. STA T2INP CLA RESET DIGITS. STA T1INP LDB T4INP RELOAD TRAILING ZERO COUNT. SKP * IF JUST PROCESSED A SKIPPED ZERO, DO ANOTHER DIGIT. * INDI5 LDA T1IND WAS IT A TERMINATION CALL ? SSA,RSS SZB,RSS OR NO TRAILING ZEROES ? JMP INDIG,I YES, DONE WITH THIS DIGIT. ADB KM1 IT WAS A SKIPPED ZERO. DECREMENT COUNT. STB T4INP JMP INDI1 TRY AGAIN. * * ZERO, EXTRA DIGIT & TERMINATION PROCESSING. * INDI6 LDA T1INP ZERO OR EXTRA DIGIT. LEADING ZERO ? ADA EXP (IF SO, EXP=-1 AND T1INP=0) SSA,RSS ISZ T4INP NO, TRAILING DIGIT, COUNT IT. JMP INDIG,I DONE WITH THIS ONE. INDI7 LDA T2INP ANY UNUSED DIGITS ? CPA KM4 JMP INDIG,I NO, DONE. ADA PWR10 YES. ADD THEM. LDA A,I JMP INDI2 * T1IND NOP T2IND NOP KM16 DEC -16 K9 DEC 9 B160K OCT 160000 B.IDI DEC 0,0 BILGD NOP OCTAL ILLEGAL DIGIT FLAG. BOVFL NOP OCTAL OVERFLOW FLAG. SPC 3 * POWER OF TEN TABLE. FIRST PART IS (10**I)/2, I=1,2,3. SECOND * PART IS IDENTICAL TO 2-WORD FLOATING EXCEPT THE SECOND WORD HAS f * BEEN RIGHT SHIFTED ONE BIT. VALUES ARE 1O**I FOR I=1,6. SPC 1 K5000 DEC 5000 PWR10 DEF PWR1A BASE ADDRESS. K5 DEC 5 DEC 50 DEC 500 PWR1A DEC 20480 10**1 DEC 4 DEC 25600 10**2 DEC 7 DEC 32000,10 10**3 DEC 20000,14 10**4 DEC 25000,17 10**5 DEC 31250,20 10**6 SKP * NORML - MANTISSA NORMALIZATION. * THE MANTISSA AND EXPONENT ARE ADJUSTED SO THAT THEY CONTAIN * A NORMALIZED VALUE. THE MANTISSA MUST NOT BE ZERO. * NORML NOP NORM1 LDB F.IDI SEE IF NORMALIZED. ASL 1 SOC WELL ? JMP NORML,I YES. JSB LSONE NO. LEFT SHIFT & ADJUST EXP. JMP NORM1 TRY AGAIN. SPC 2 * RSN - LOGICAL RIGHT SHIFT MANTISSA ONE BIT. * RSN NOP ISZ EXP ADJUST EXPONENT. NOP DLD F.IDI JUST SHIFT.... CLE,ERA ERB DST F.IDI DLD F.IDI+2 ERA ERB DST F.IDI+2 JMP RSN,I EXIT SPC 2 * LSONE - LOGICAL LEFT SHIFT MANTISSA ONE BIT. (5 WORDS) * LSONE NOP CCA ADJUST EXP ADA EXP STA EXP LDA F.IDI+4 CLE,ELA STA F.IDI+4 DLD F.IDI+2 ELB ELA DST F.IDI+2 DLD F.IDI ELB ELA DST F.IDI JMP LSONE,I * B17 OCT 17 LSR16 LSR 16 T1RSN NOP SKP * RSNN - LOGICAL RIGHT SHIFT (A) BITS, IN [0,63], AND UPPER * TWO WORDS ONLY VALID FOR INTEGER OVERFLOW TEST. * RSNN NOP STA T1RSN SAVE SHIFT COUNT. ARS,ARS DIVIDE BY 16 TO GET WORD COUNT. ARS,ARS ADA RSNN1 SELECT CODE FOR 0-3 WORDS OF SHIFT JMP A,I * RSNN1 DEF *+1 JUMP TABLE FOR WORD SHIFTS JMP RSNN7 JMP RSNN2 JMP RSNN3 JMP RSNN4 * RSNN2 DLD F.IDI+1 RIGHT SHIFT ONE WORD. DST F.IDI+2 LDA F.IDI F.IDI+1=F.IDI JMP RSNN6  * RSNN3 DLD F.IDI RIGHT SHIFT TWO WORDS. STB F.IDI+3 JMP RSNN5 * RSNN4 LDA F.IDI RIGHT SHIFT THREE WORDS. STA F.IDI+3 CLA RSNN5 STA F.IDI+2 CLA RSNN6 STA F.IDI+1 CLA STA F.IDI * * NOW RIGHT SHIFT BY PARTIAL WORD * RSNN7 LDA T1RSN GET SHIFT COUNT. AND B17 SZA,RSS JMP RSNN,I IF ZERO COUNT, DONE SHIFTING * IOR LSR16 FORM "LSR N" STA RSNN8 PLUG CODE STA RSNN9 LDB F.IDI+2 DO LOW SHIFT. LDA F.IDI+3 RSNN8 ABS *-* STA F.IDI+3 LDB F.IDI+1 THEN HIGH SHIFT. LDA F.IDI+2 RSNN9 ABS *-* STB F.IDI+1 (UPPER BITS LEFT IN F.IDI+0) STA F.IDI+2 JMP RSNN,I DONE. SKP * .XCOM - NEGATE MANTISSA / ROUND RESULT. * * IF 'SIGN' IS +, ADD 200B TO LAST WORD & PROPOGATE CARRY. * IF -, COMPLEMENT EACH WORD & ADD 201B TO LAST & PROP. * THE RESULT MUST NOT BE ZERO. SPC 2 .XCOM NOP LDA B200 (A) = ROUND CONSTANT FOR +. LDB SIGN + OR - ? SSB INA (A) = ROUND CONSTANT FOR -. STA T1DIV LDA MANTL (A) = POINTER. * XCOM1 LDB SIGN COPY COMPLEMENT STATUS TO (E) ELB LDB A,I (B) = WORD OF MANTISSA. SEZ COMPLEMENT ? (E=0) CMB,CLE YES. DO IT. (E=0) ADB T1DIV ADD CARRY. STB A,I (STORE MANTISSA) CLB,SEZ COPY NEW CARRY BIT TO (A). INB STB T1DIV SAVE CARRY FOR NEXT TIME. CPA F.DID AT FIRST WORD ? JMP XCOM2 YES. * ADA KM1 NO. BACK UP POINTER AND JMP XCOM1 KEEP GOING. * XCOM2 LDA F.IDI (A) = FIRST WORD. LDB A (ALSO B) XOR SIGN SIGN RIGHT ? SSA JMP XCOM4 NO. OFL. * ASL 1 YES. IS IT NEG UNNORM ? SOC JMP .XCOM,I NO, DONE. * CCA YES. (A)=-1 TO DECR EXPONENT, JMP XCOM5 AND (B)=100000, SHIFTED MANTISSA. * XCOM4 CLA,INA OFL. (A)=+1 TO INCR EXPONENT, RBR AND (B)=40000, SHIFTED MANTISSA. XCOM5 STB F.IDI SET UP MANTISSA, ADA EXP AND CORRECT EXPONENT. STA EXP JMP .XCOM,I DONE. SKP * MULT MULTIPLIES THE MANTISSA BY A 15-BIT SCALAR AND ADJUSTS THE * EXPONENT. THE RESULT IS AS IF AN INTEGER MULTIPLY OF THE MANTISSA * AND SCALAR WERE DONE FOLLOWED BY A RIGHT SHIFT 15. THE RESULT * WILL NOT OVERFLOW BUT IT MAY BECOME UNNORMALIZED. * * CALLING SEQUENCE: CLE/CCE LAST WORD FLAG. * LDA SCALAR MULTIPLIER. * LDB N EXPONENT ADJUSTMENT. * JSB MULT * * WHERE E=1 INDICATES THAT THE LAST WORD OF THE CURRENT MANTISSA IS * ZERO. (INPUT) FOR THIS CASE, EXP ADJUSTMENT MUST NOT CARRY OUT. SPC 1 MULT NOP STA T1DIV SAVE MULTIPLIER. RAL AND 2*MULTIPLIER. STA T4DIV CME E=0 IFF INPUT ADB EXP ADJUST EXPONENT STB EXP LDB MANTL CURRENT WORD ADDR SEZ,RSS INPUT ? JMP MULT3 YES, SKIP FIRST MPY STB T2DIV RAR RESTORE MULTIPLIER. MPY B,I ASL 1 JMP MULT2 MULT1 LDA T1DIV MULTIPLIER. MPY B,I * CURRENT WORD. CLE,ELA ALIGN. ELB,CLE ADA T3DIV,I ADD LOWER TO CURRENT + 1 STA T3DIV,I SEZ PROPOGATE CARRY. INB MULT2 LDA T2DIV,I CORRECT FOR BIT 15. SSA ADB T4DIV STB T2DIV,I LDB T2DIV SEE IF DONE. MULT3 CPB F.DID I.E., IS CURRENT WORD THE START ? JMP MULT,I YES, DONE. STB T3DIV NO, UPDATE POINTERS. ADB KM1 STB T2DIV JMP MULT1 AND LOOP. SKP * DIVD DIVIDES THE MANTISSA BY A SCALAR AND ADJUSTS THE EXPONENT * ACCORDINGLY. THE EFFECT IS AS IF THE TWO WERE INTEGERS AND THE * DIVIDE WERE DONE, KEEPING 15 FRACTION BITS, FOLLOWED BY A L.S. 15. * OVERFLOW CAN OCCUR ONLY IF THE MANTISSA IS NORMALIZED OR THE * DIVISOR IS LESS THAN 2**14. * * CALLING SEQUENCE: LDA SCALAR 15-BIT DIVISOR. * LDB N EXPONENT ADJUSTMENT. * JSB DIVD SPC 1 DIVD NOP STA T1DIV SAVE DIVISOR. ARS SAVE DIVISOR/2. STA T4DIV CMB,INB CORRECT EXPONENT. ADB EXP STB EXP LDA F.DID SET UP POINTERS. STA T2DIV STA T3DIV LDB A,I B = FIRST WORD. CMA,INA -F.DID ADA MANTL MANTL-F.DID = # WDS - 1 CMA - # WDS STA T5DIV CLA BITS 15,14 FIRST WORD = 0 JMP DIVD2 DIVD1 ISZ T2DIV CLA SAVE BIT 15 (IN E). ELA,ELA CMB FORM REM - DIVISOR/2 ADB T4DIV CMB,CLE,SSB POS ? ADB T4DIV NO, RESTORE REM & SET E. CME SAVE BIT 14 (IN E). ERA,RAR DIVD2 STA T6DIV SAVE BITS 15,14. ISZ T3DIV LDA T3DIV,I A = NEXT WORD (LOW) DIV T1DIV DIVIDE. CLE,ERA SHIFT RIGHT, SAVE BIT 0 AS BIT 15. IOR T6DIV ADD PREV BITS 15,14. STA T2DIV,I ISZ T5DIV DONE ? JMP DIVD1 NO, LOOP. JMP DIVD,I YES, EXIT. * T1DIV NOP T2DIV NOP T3DIV NOP T4DIV NOP T5DIV NOP T6DIV NOP SKP * INITIALIZE FOR CONVERTING A NUMBER. * INC.F NOP LDA F.DID SET UP (MANTL) FOR INDIG. STA MANTL LDA KM4 FOR INDIG. STA T2INP # DIGITS THIS GROUP - 4. CCA STA EXP JSB CDI.F CLEAR F.IDI, SET A=0. STA B.IDI CLEAR B.IDI STA B.IDI+1 STA T1INP ACCUMULATED DIGITS THIS GROUP. (UP TO 4) STA EXPS SIGN OF EXPONENT. STA T4INP # TRAILING ZEROES. STA SIGN SIGN OF MANTISSA. STA BOVFL OCTAL OVERFLOW FLAG. STA BILGD OCTAL ILLEGAL DIGIT FLAG. STA EXPON DECIMAL EXPONENT. STA POST STATE OF CONVERSION. STA D # DIGITS AFTER POINT. LDA REA DEFAULT F.IM = REA. STA F.IM JMP INC02 GO START. * * MAIN LOOP. READ A CHAR AND DECIDE WHAT TO DO. * INC00 ISZ POST BUMP POST TWICE. INC01 ISZ POST BUMP POST ONCE. * INC02 JSB ICH.F GET NEXT (NON-BLANK) CHAR. SZB,RSS DIGIT ? JMP INC04 YES. * CPA B53 '+' JMP INC07 CPA B55 '-' JMP INC07 CPA "." '.' JMP INC09 CPA "E" 'E' JMP INC13 CPA "D" 'D' JMP INC13 JMP INC14 NONE OF ABOVE. STOP THE CONVERSION. SKP * DIGIT. POST= 0 => 2 ADD MANTISSA DIGIT. * 1 => 2 .. * 2 => 2 .. * 3 => 3 .. & COUNT FRACTION DIGIT. * 4 => 6 ADD EXPONENT DIGIT. * 5 => 6 .. * 6 => 6 .. * INC04 ADA BM60 (A) = VALUE OF DIGIT. JSB JTB.F JUMP ON B=POST. DEC 6 ALL VALUES LEGAL. * ISZ POST 0 => 1 ISZ POST 1 => 2 JMP INC06 2, ADD DIGIT. JMP INC05 3, ADD & COUNT DIGIT. ISZ POST 4 => 5 ISZ POST 5 => 6 * LDB EXPON 6, MULTIPLY EXPON BY 10 BLS,BLS ADB EXPON BLS ADB A ADD DIGIT. ASL 4 GUARANTEE LARGE EXPONENTS STAY LARGE. SOC IF TOO BIG, LDB B60K SET LARGER THAN MAX ALLOWED. ASR 4 (HERE 60000B => 3000B) STB EXPON JMP INC02 TRY FOR MORE. * INC05 ISZ D 3, COUNT DIGIT. INC06 JSB INDIG 0-2, ADD MANTISA DIGIT. JMP INC02 NEXT! SPC 2 BM60, OCT -60 BM54 OCT -54 "Q" OCT 121 "V" OCT 26 T1INP NOP T2INP NOP EXPS NOP T4INP NOP SKP * SIGN. POST= 0 => 1 SET MANTISSA SIGN. * 1 => ERROR. * 2 => FINISH INTEGER. * 3 => FINISH REAL. * 4 => 5 SET EXPONENT SIGN. * 5 => ERROR * 6 => FINISH REAL/DOUBLE * INC07 ADA BM54 '+': -1 '-': +1 CMA,INA +-1 AS SIGN. JSB JTB.F JUMP ON (POST) DEC 4 5,6 SAME AS END. * JMP INC08 0, GO SAVE MANTISSA SIGN. JMP INC26 1, ERROR: TWO SIGNS. JMP INC20 2, FINISH INTEGER. JMP INC32 3, FINISH REAL. * STA EXPS 4, SAVE EXPONENT SIGN. JMP INC01 4 => 5. * INC08 STA SIGN 0, SAVE MANTISSA SIGN. JMP INC01 0 => 1. * INC26 LDA K17 ERROR 17, MISSING OPERAND. JSB ER.F K17 DEC 17 SPC 4 * E OR D. POST= 0 => NAME. * 1 => OPERATOR, + OR -. * 2 => 4 * 3 => 4 * 4 => ERROR * 5 => ERROR * 6 => FINISH REAL/DOUBLE. * INC13 JSB JTB.F JUMP ON (POST) DEC 3 4,5,6 SAME AS (END). * JMP INC15 0, NAME. JMP INC27 1, + OR -. ISZ POST 2 => 4 * STA E/D 3, REMEMBER WHICH KIND. JMP INC01 3 => 4. SKP * POINT. POST= 0 => 3 IF FOLLOWED BY DIGIT, ELSE OPERATOR. * 1 => 3 IF FOLLOWED BY DIGIT, ELSE ERROR. * 2 => 3 IF NOT FOLLOWED BY LETTER. * 4 IF FOLLOWED BY 'E' BUT NOT 'EQ'. * 'EQ', FINISH DOT OPERATOR THEN INTEGER. * 3 => FINISH REAL. * 4 => ERROR. * 5 => ERROR. * 6 => FINISH REAL/DOUBLE. * INC09 JSB JTB.F JUMP ON (POST) DEC 2 3,4,5,6 SAME AS (ENDh). JMP INC10 0 JMP INC12 1 * JSB EXN.F 2. WHAT'S NEXT ? SEZ,RSS DELIMETER OR SZB,RSS DIGIT ? JMP INC01 YES, 2 => 3. CPA "D" 'D' ? JMP INC01 YES, FIGURE IT OUT LATER. CPA "E" 'E' ? RSS JMP INC11 NO. MUST BE RELATIONAL OP. * JSB ICH.F READ THE 'E'. STA E/D AND SAVE FOR LATER. JSB EXN.F & LOOK AT ONE AFTER. CPA "Q" IS IT '.EQ' ? RSS YES. JMP INC00 NO. 2 => 4. * JSB ICH.F READ THE 'Q'. JSB ICH.F READ NEXT, SHOULD BE '.' OR 'V'. LDB "EQ" (INCASE .EQ.) CPA "V" IS IT .EQV. ? RSS MUST BE. JMP INC03 NO. GO VERIFY THAT IT'S .EQ. * JSB ICH.F .EQV., READ THE DOT. LDB "EV" SET UP RESULT. INC03 STB F.TC SET RESULT. CPA "." ENDS RIGHT ? JMP INC20 YES. JMP INC18 NO. ERROR. * INC10 JSB EXN.F 0. PEEK AHEAD. SZB DIGIT ? JMP INC11 NO. NOT A NUMBER. RESTORE '.' ISZ POST YES. DIGIT AFTER POINT. JMP INC00 ADVANCE POST TO 3. * INC11 LDA "." RESTORE F.TC = "." FOR DOT OPERATOR. STA F.TC JMP INC14 INTERPRET IT AS A DELIMETER. * INC12 JSB EXN.F 1, REQUIRE NEXT = DIGIT. SZB,RSS DIGIT ? JMP INC00 YES. 1 => 3. INC18 LDA K17 NO, ERROR. JSB ER.F * SPC 3 * UNKNOWN. POST= 0 => NAME. * 1 => + OR -. * 2 => FINISH INTEGER. * 3 => FINISH REAL. * 4 => ERROR. * 5 => ERROR. * 6 => END REAL/DOUBLE. * * JTB.F ALLOWS ACCESS TO AN IMMEDIATELY FOLLOWING JUMP TABLE USING * (POST) AS THE INDEX INTO THE TABLE. THE FIRST RETURN POINT * CORRESPONDS TO POST=0. IF POST>LIMIT, THE TERMINATION TABLE IS * USED (FOLLOW~3S JTB.F). * * ENTRY: JSB JTB.F (POST=INDEX) * DEC LIMIT * * * ..ETC.. * * EXIT: (B,E,O) DESTROYED, (A) INTACT. * JTB.F NOP LDB POST (B) = POST. CMB,CLE,INB -POST. E=0 UNLESS POST=0. ADB JTB.F,I LIMIT-POST. E=0 IFF POST>LIMIT AND POST#0. LDB JTB.F RETURN POINT FOR (-1). ADB POST RETURN POINT FOR (POST-1). SEZ,INB POST>LIMIT ? (RTN POINT FIXED) JMP B,I NO. RETURN. * * HERE'S THE ACTUAL JUMP TABLE FOR UNKNOWN CHARACTERS. * INC14 JSB JTB.F (MAY RE-ENTER) DEC 6 ALL. * JMP INC15 0, NAME OR OPERATOR. JMP INC27 1, + OR -. JMP INC20 2, FINISH INTEGER. JMP INC32 3, FINISH REAL. JMP INC19 4, ERROR. JMP INC19 5, ERROR. JMP INC30 6, END OF REAL/DOUBLE. * * EXIT CODE FOR INC.F * INC27 JSB UC.F SIGN ONLY. BACK UP. LDA SIGN AND RESTORE F.TC CMA,INA ADA B54 STA F.TC INC15 CLA SET F.IM=0 INC16 STA F.IM SET F.IM INC17 LDA F.IM LOAD F.IM JMP INC.F,I EXIT. * * ERROR - ILLEGAL EXPONENT. * INC19 LDA K14 LDB F.SID SCAN MODE ? SZB,RSS JSB ER.F NO. ERROR. JMP INC17 YES. RETURN F.IM * KM6 DEC -6 B1000 OCT 1000 B200 OCT 200 BM400 OCT -400 BMAX OCT 77777 RE8 OCT 120000 K14 DEC 14 E/D NOP KM63 DEC -63 B10K OCT 10000 B100K OCT 100000 DBI EQU B100K B52 OCT 52 SPC 2 * SUBR TO CHECK FOR '**' AFTER NEGATIVE CONST. * CEX.F NOP LDA F.SID SCAN MODE LDB SIGN OR + CONSTANT ? SZA,RSS SSB,RSS JMP CEX.F,I YES. DOESN'T MATTER. * LDA F.TC DELIMETER = '*' ? CPA B52 RSS YES. JMP CEX.F,I NO. ISN'T ** THEN T * JSB EXN.F CHECK NEXT ONE. CPA B52 WELL ? JMP CEX01 YES. SPECIAL NEGATIVE CONST. * LDA B52 NO. RESTORE F.TC STA F.TC JMP CEX.F,I & EXIT. * CEX01 CLA SET SIGN POSITIVE AGAIN. STA SIGN ISZ F.SIM SET FLAG TO DELAY CONSTANT. JMP CEX.F,I (WILL RETURN A '-' INSTEAD) SKP * FINISH UP AN INTEGER CONSTANT. * INC20 JSB CEX.F CHECK FOR '**' LDA F.TC OCTAL CONSTANT ? CPA "B" JMP INB01 YES. * LDA DBI SET F.IM=DBI IN CASE OVERFLOW. STA F.IM CCA ADD ANY REMAINING DIGITS. JSB INDIG LDA F.IDI RESULT = 0 ? IOR F.IDI+1 SZA IF SO, SKIP NORMALIZE. JSB NORML NORMALIZE SO 'PTEN' WORKS. LDA T4INP ADD ANY TRAILING ZEROES. JSB PTEN * LDA EXP ALLOW 4 WORDS (MAX NEG MUST FIT) ADA KM63 (A) = - (R.S. COUNT FOR 4 WORD INTEGER) CLE,SSA,RSS FITS ? (E=0) JMP INC35 NO. * CMA,INA YES. (A) = POSITIVE SHIFT COUNT. JSB RSNN RIGHT SHIFT (A) BITS. LDA F.IDI >= 2**32 ? IOR F.IDI+1 CLE,SZA (E=0) JMP INC35 YES, OFL. * DLD F.IDI+2 (A,B) = UNSIGNED VALUE. CLE,SSA >= 2**31 ? (E=0) JMP INC23 YES. -2**31 IS STILL O.K. * LDA F.SLF IF DATA STATEMENT, CPA K2 JMP INC25 LET THE DATA PROCESSOR DO HOLLERITH. * LDA F.TC OTHERWISE, CHECK FOR 'H' CPA "H" JMP IDN72 YES, HOLLERITH CONSTANT. * INC25 LDA F.IDI+2 ISZ SIGN NEGATIVE ? JMP INC22 NO. (A,B) = NUMBER. * CMA YES. NEGATE. CMB,INB,SZB,RSS INA SKP * (A,B) = INTEGER VALUE. * DECIDE IF SINGLE OR DOUBLE, SET VALUE & F.IM, EXIT. * INC22 DST F.IDI RESULT. SWP DECIDE IF SINGLE OR DOUBLE. ASL 16 OFL=1 IFF MUST BE DOUBLE. LDB F.TC IF 'J' SUFFIX, CPB "J" JMP INC28 THEN ALWAYS TWO-WORD. * CPB "I" 'I' SUFFIX ? JMP INC29 THEN ALWAYS ONE-WORD. * LDA F.CCW ELSE CHECK 'J' OPTION. AND B10K SZA,RSS FOR SINGLE INTEGER: 'J' OPTION OFF SOC AND FITS IN 16 BITS. JMP INC24 NO. DOUBLE. * INC29 LDA K14 'I' SUFFIX & TOO BIG ? SOC JSB WAR.F YES. GIVE WARNING. * LDB F.TC NO. IF 'I' SUFFIX, CPB "I" JSB ICH.F SKIP OVER IT. LDA F.IDI+1 SET UP SINGLE INTEGER CONSTANT. STA F.IDI LDA INT F.IM=INT. JMP INC16 SET F.IM & EXIT. * INC28 JSB ICH.F 'J' SUFFIX, SKIP OVER IT. INC24 LDA DBI F.IM=DBI, DOUBLE INTEGER. JMP INC16 * INC23 ISZ SIGN NEGATIVE ? JMP INC35 NO. CAN'T BE O.K. * CPA B100K (A) = 100000 CLE,SZB (B) = 0 ? (E=0) JMP INC35 NO. OVERFLOW. JMP INC22 YES. GO BACK TO STORE IT. * "B" OCT 102 "H" OCT 110 "I" OCT 111 "J" OCT 112 F.EIM NOP EXPECTED ITEM MODE (SET BY DATA STMT) SKP * FINISH UP REAL/DOUBLE WITH EXPONENT. * INC30 LDA E/D WHICH ? CPA "E" E ? JMP INC32 YES, LEAVE SINGLE. * JSB CEX.F CHECK FOR '**'. CCA ADD ANY LEFT-OVER DIGITS. JSB INDIG LDA F.SLF DATA STATEMENT ? CPA K2 RSS (YES) JMP INC31 NO. GO CHECK 'Y' OPTION. * LDA B1000 YES. ASSUME REAL*8; LDB F.EIM WHAT IS EXPECTED MODE ? CPB DBL IF REAL*6, CLA THEN SET UP FOR THAT. RSS (A)=1000 FOR RE8, 0 FOR DBL. INC31 LDA F.CCW "D", DECIDE PRECISION OF CONSTANT. AND B1000 'Y' BIT. LDB DBL ASSUME DBL = REAL*6 SZA WELL ? LDB RE8 WRONG, RE8 = REAL*8. STB F.IM SET UP TYPE. LDB K2 ALSO SET UP ADDR OF LAST WORD. SZA INB DBL=2, RE8=3 WORDS AFTER FIRST. JMP INC33 * * FINISH REAL/DOUBLE. * INC32 JSB CEX.F CHECK FOR '**'. CCA ADD ANY LEFT-OVER DIGITS. JSB INDIG CLB,INB COMPUTE ADDR LAST WORD. INC33 ADB F.DID STB MANTL LDA F.SID SCAN MODE ? SZA JMP INC17 YES. CAN STOP NOW. * LDA F.IDI TEST FOR ZERO. IOR F.IDI+1 SZA,RSS JMP INC17 RESULT = 0. * JSB NORML ELSE NORMALIZE. LDB EXPON FINAL COMPUTATION OF NUMBER ISZ EXPS COMPUTE EXTERNAL CMB,INB EXPONENT AS NEGATIVE ADB D ADJUST FOR DECIMAL POINT OR EXCESS DIGITS. CMB,INB ADB T4INP ACCOUNT FOR TRAILING ZEROES, EXTRA DIGITS. ASL 9 OFL IF OUTSIDE [-64,+64) SOC SHOULD NEVER BE OUTSIDE [-60,+39] JMP INC34 (MANTISSA IN [1,10**20], ASR 9 RESULT IN [10**-39,10**39] ) LDA B JSB PTEN MULTIPLY BY POWER OF TEN. * * ROUND FLOATING. CHECK FOR OFL UFL, PACK EXPONENT. * JSB .XCOM (NEGATE) & ROUND. LDB EXP CHECK EXP CLA FOR USE IN FORMATTING EXP ASL 8 MUST FIT IN 8 BITS WITH SIGN. SOC JMP INC34 NO, OFL/UFL. CLE,ELB E=EXP SIGN, B<15:9>=EXP MANT. BLF,BLF B<7:1>=EXP MANT. RBR,ELB B<7:0>=FORMATTED EXPONENT. LDA MANTL,I LAST WORD MANTISSA. AND BM400 MAKE ROOM FOR EXP. IOR B PUT TOGETHER. STA MANTL,I JMP INC17 ALL DONE! * * OVERFLOW & UNDERFLOW HANDLING. * INC34 CCE,SSB OFL OR UFL ? (IF OFL, E=1) CLA,CLE,RSS UFL. (E=0) INC35 LDA BMAX OFL. E=1 IF FLOATING. STA F.IDI RAL,ARS UFL:0 OFL:-1 STA F.IDI+1 STA F.IDI+2 STA F.IDI+3 SEZ,RSS INTEGER OR UFL ? JMP INC36 YES, DONE. LDA MANTL,I FLOATING & OFL, CLEAR LAST BIT. ALS STA MANTL,I * INC36 LDB F.SID SCAN MODE ? LDA K14 SZB,RSS JSB WAR.F NO, USE UFL/OFL WARNING. JMP INC17 EXIT. END ASMB,Q,C HED INPUT DUMMY LIST / LINK MANIPULATION. NAM IDL.F,8 92834-12001 REV.2030 800226 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18001 * * RELOC: PART OF 92834-12001 * * PGMR: B.G. * *************************************** * EXT F.A ASSIGNMENT TABLE ADDRESS (CURRENT ENTRY) EXT F.AT ADDRESS TYPE OF CURRENT F.A EXT F.NAR NUMBER OF ALTERNATE RETURNS. EXT F.NT NAME TAG: 0=VAR, 1=CONST. EXT F.SBF 0=MAIN, ELSE F.A OF SUBROUTINE. EXT F.SFF SUBROUTINE/FUNCTION FLAG (0=SUB). EXT F.SLF STATEMENT LEVEL. EXT F.TC NEXT CHARACTER. * EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (F.AT) EXT DIU.F DEFINE (F.IU) EXT EXN.F EXAMINE THE NEXT NONBLANK CHARACTER. EXT ICH.F GET & TYPE NEXT NONBLANK CHARACTER. EXT ISY.F INPUT SYMBOL. EXT RP.F INPUT ')' EXT TCT.F TEST (A)=F.TC ELSE ERROR 28. EXT WAR.F ISSUE WARNING. * ENT EL.F EXCHANGE LINKS OF (F.A) AND (B). ENT FL.F FETCH LINK OF (B). ENT IDL.F INPUT DUMMY LIST. +aSPC 1 A EQU 0 B EQU 1 SUP SKP * ***************************** * * INPUT DUMMY ARGUMENT LIST * * ***************************** SPC 1 * ENTRY: F.A = A.T. ADDR OF SUB/FCT NAME. * EXIT: (A)=ADDR FIRST FORMAL, LINKED THRU F.AF FIELDS. * IDL.F NOP LDA B50 CHECK FOR JSB TCT.F '(' JSB EXN.F O.K., CHECK FOR EMPTY LIST. CPB B51 WELL ? JMP IDL03 YES. THAT'S O.K. * CLA NO. SET LINK OF DUMMY HEAD TO ZERO. STA PLST+1 LDA DPLST START WITH F.A = DUMMY HEAD. STA F.A IDL00 LDA F.A SAVE F.A OF PREV ITEM FOR LINKING. STA T1IDL * * IF SUBROUTINE'S PARAMS, LOOK FOR ALTERNATE RETURNS. * LDA F.SLF IF IN SUBPROGRAM PARAM LIST, IOR F.SFF AND IT'S A SUBROUTINE, SZA JMP IDL02 NO. * JSB EXN.F THEN LOOK FOR ALTERNATE RETURNS. CPA B52 '*' ? RSS CPA B46 '&' ? RSS JMP IDL02 NEITHER. NOT AN ALT RTN. * ISZ F.NAR YES. COUNT IT. JSB ICH.F AND READ IT. JSB ICH.F AND POSITION AT THE DELIMETER. JMP IDL01 DONE WITH IT. * * ELSE GET THE PARAMETER AND DO SOME CHECKING. * IDL02 JSB ISY.F INPUT THE DUMMY NAME CLA CLEAR WAR.F AS A FLAG STA WAR.F TO BE TESTED FOR WARNINGS LATER LDB F.NT IF NOT A NAME LDA K74 SZB SEND JSB WAR.F WARNING LDB F.A IF SAME AS NAME CPB F.SBF JSB WAR.F SEND ALSO LDA K76 IF ALREADY DUM LDB F.AT THEN CPB DUM DOUBLY DEFINED DUMMY JSB WAR.F SEND MESSAGE CLA CLEAR JSB DIU.F THE F.IU LDA DUM SET F.AT JSB DAT.F TO DUM LDA WAR.F IF NO WARNINGS SENT SZA THEN SKIP TO THE LINK JMP IDL01 ELSE SKIP LINKING IT IN * LDB T1IDL LINK PREVIOUS TO CURRENT. JSB EL.F (F.AF OF CURRENT = SELF) CLA SET CURRENT LINK TO ZERO. JSB DAF.F (SAFER THIS WAY: AI.F SET STMT FCT F.AF) * * CHECK DELIMETER & LOOP. * IDL01 LDA F.TC ANY MORE?? CPA B54 ',' JMP IDL00 YES GO GET IT * JSB RP.F ')' TEST FOR FINAL ')', PASS IT. LDA PLST+1 RETURN ADDR FIRST DUMMY. JMP IDL.F,I EXIT. * IDL03 JSB ICH.F EMPTY LIST. READ THE ')'. JSB ICH.F AND THE ONE AFTER IT. CLA RETURN A=0, NULL LIST. JMP IDL.F,I * T1IDL NOP DPLST DEF PLST ADDR DUMMY HEAD. PLST DEC 0,0 DUMMY LIST HEAD. B46 OCT 46 & B50 OCT 50 ( B51 OCT 51 ) B52 OCT 52 * B54 OCT 54 , K74 DEC 74 K76 DEC 76 SKP * ************** * * FETCH LINK * * ************** SPC 1 * ENTRY: (B) = F.A OF ITEM TO FETCH LINK OF. * EXIT: (B) = ADDRESS OF LINK. * (A) = VALUE OF LINK. * SPC 1 FL.F NOP STB F.A LDA B,I AND B600 CPA ARR INB,RSS IU(F.A)=ARR RSS LDB B,I (B)=GF(F.A) XOR F.A,I GET THE AND B7000 AT FIELD CPA BCOM IF A BLOCK COMMON INB,RSS ELEMENT RSS INDEX ONE LDB B,I MORE LEVEL INB LDA B,I JMP FL.F,I SPC 2 * ****************** * * EXCHANGE LINKS * * ****************** SPC 1 * EXCHANGE AF(F.A) & AF(B) SPC 1 EL.F NOP LDA F.A STA T1EL JSB FL.F FETCH LINK (B) STB T2EL T2EL=LINK ADDR (B) LDB T1EL (B)=ORIGINAL F.A STA T1EL T1EL=LINK VALUE (B) JSB FL.F FETCH LINK STA T2EL,I SET CURRENT IN OLD LDA T1EL AND OLD IN STA B,I CURRENT JMP EL.F,I SPC 1 B600 OCT 600 EXTRACT F.IU FIELD ARR EQU B600 F.IU=ARR B7000 OCT 7000 EXTRACT F.AT FIELD. BCOM OCT 3000 F.AT=BCOM DUM OCT 5000 F.AT=DUM T1EL BSS 1 T2EL BSS 1 * END ASMB,Q,C HED FTN4X COMPILER CODE OUTPUT TO PASS 2 NAM OA.F,8 92834-12001 REV.2030 800623 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18001 * * RELOC: PART OF 92834-12001 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A ENT F.C GENERAL OFFSET FOR CODE GENERATION. EXT F.D.T ADDRESS OF '.' FUN. TABLE EXT F.D0 ARRAY ELEMEXT SIZE EXT F.DID ADDRESS OF F.IDI EXT F.GRD ACCESS TO GRD.F EXT F;.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) ENT F.NIT NO-INLINE-TEMP FLAG. EXT F.NT NAME TAG 0 = VAR, 1 = CONSTANT. EXT F.RES F.A OF CURRENT RESULT. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.XID EXTERNAL ID COUNTER. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT DAF.F DEFINE (F.AF) EXT DL.F DEFINE LOCATION SUBROUTINE EXT FA.F FETCH ASSIGNS ENT IN2.F INIT FOR OA.F MODULE ENT OA.F OUTPUT ASSIGNMEXT TABLE OPERAND ENT OAD.F OUTPUT ABS. DATA ENT OAI.F OUTPUT ABS. INSTRUCTION ENT OC.F OUTPUT CONSTANT ENT ODD.F OUTPUT DEF TO DOT FUNCTION. ENT ODF.F OUTPUT DOT FUNCTION ENT OID.F OUTPUT INSTRUCTION, DOT-OPERAND. ENT OLR.F OUTPUT LOAD ADDRESS ENT OMR.F OUTPUT MEMORY REF. INSTRUCTION ENT ORI.F OUTPUT ABS. REGISTER INSTRUCTION. ENT OS.F FLUSH THE BUFFER. ENT OW.F OUTPUT WORD ENT OZ.F OUTPUT ZREL (OP *+N) ENT PDF.F PRODUCE DEF SUBROUTINE ENT SOA.F STORE AND OUTPUT (OA.F) * * EXTERNALS IN RTM.F . * * * * COMPILER LIBRARY ROUTINES * EXT WRT.C WRITE RECORD EXT C.SC0 FCB FOR 2ND PASS FILE. * A EQU 0 B EQU 1 * ADDR OCT 70000 F.IM=7 ADDRESS SPC 1 * SKP * ******************************************* * * OUTPUT ASSIGNMENT TABLE POINTER OPERAND * * ******************************************* SPC 1 * PROCESS ABSOLUTE INSTRUCTIONS, CHANGE INDIRECTNESS * OF FORMAL PARAMS, OUTPUT 'DEF' ENTRIES IMMEDIATELY. * OA.F NOP STA T0OA TEMP CELL TO HOLD OPCODE WORD LDB F.A IF F.A IS SZB ZERO THEN PRODUCE AN CPB K1 (ONE ALSO) JMP OA03A ABSOLUTE INSTRUC TION * JSB CDO.F NO, CHECK FOR DATA WITH OFFSET. STB F.A JSB FA.F LDA T0OA GET THE OP CODE LDB F.IM IF THIS IS ADB F.NT A DEF ENTRY CPB K1 THEN SKIP THE REST OF THE CHECKS JMP OA015 AND PUT OUT THE CODE * LDB F.AT CPB DUM IS OPERAND TAGGED DUMMY? RSS JMP OA01 NO. * XOR KK01 YES, CHANGE THE INDIRECT OPTION. STA T0OA SAVE THE NEW INSTRUCTION JMP OA015 GO SEND A.T. BASED INSTRUCTION. * OA03A AND C2000 CLEAR THE CURRENT PAGE BIT STA T0OA SAVE WHILE GETTING REG INFO. JSB F.GRD,I GET REGISTER INFO. DEF F.A LDA T0OA RESTORE INSTRUCTION, IOR F.A ADD REGISTER NUMBER, SSB,RSS IF THE REGISTER IS DEFINED, SOS AND IT'S AN ADDRESS, RSS (NO) IOR SIGN SET THE INDIRECT BIT. JSB OAI.F SEND ABS INSTRUCTION OA04 CLA CLEAR THE NO-INLINE-TEMP FLAG. STA F.NIT JMP OA.F,I RETURN SKP * CHECK FOR SPECIAL PROCESSING. * OA01 LDA F.IU CPA SUB IS OPERAND AN EXTERNAL NAME JMP OA03 YES, GEN. EXT. REF. INSTRUCTION * LDB F.AT IS OPERAND CPB BCOM LABELED COMMON? JMP OA10 YES GO DO SPECIAL * CPB DIM DIMENSION ENTRY ? RSS CPB BCOMI OR BCOM OFFSET ? JMP OA015 YES. MUST BE NORMAL DEF. * LDA T0OA LOAD FIRST WORD OF INSTRUCTION CPB COM. IN COMMON? ADA K2 YES, SET BIT 2 OF FIRST WORD ON. STA T0OA UPDATE INSTRUCTION. LDB F.IM DOES OPERAND HOLD CPB ADDR ARRAY ELEMENT ADDRESS? JMP OA05 YES GO CHECK IF DEF * * OUTPUT THE CODE. * OA07 LDB F.AF (IN CASE ARRAY NAME) LDA F.IU IS OPERAND CPA ARR AN ARRAY NAME? JMP OA02 YES, OUTPUT eINSTR. WITH RPL * OA015 LDB F.A NO, OUTPUT THE ADB KK01 INSTRUCTION WITH (B) _ F.A,I OA02 LDA T0OA JSB OMR.F JMP OA.F,I * * ADDRESS TEMP. TRY TO DEFINE IN-LINE. * OA05 XOR KK01 ADD THE SIGN BIT. STA T0OA & SET NEW INSTRUCTION. LDB F.NIT (TO CHECK FOR INHIBITION OF INLINE) CPA KK01 IS IT 'DEF TEMP,I' ? SZB AND INHIBIT FLAG CLEAR ? JMP OA07 NO. LEAVE IT ALONE. * JSB DL.F SET F.AT TO REL LDA F.LLO GET THE CURRENT LOAD ADDRESS SSA,RSS IF DIRECT ADA ADON GET THE ACTUAL ADDRESS JSB DAF.F DEFINE ADDRESS OF ADCON LDA F.LLO GET THE BASE ADDRESS AGAIN LDB ADON IF A SYMBOL TABLE POINTER SSA,RSS THEN WE MUST CLB (NO USE ZERO) LDA F.A INCLUE THE OFFSET ADA K2 SET THE NAME STB A,I IN THE A.T. JMP OA015 GO SEND IT SKP * EXTERNAL REF. * OA03 LDB F.A F.IU IS SUBPROG; GEN. EXT. REF. INB (B) POINTS TO AF FOR JSB GETEX GET EXT NO FOR IT JMP OA015 GO SEND * * LABELLED COMMON REF. * OA10 LDB F.AF LABELED COMMON REF. INB GET INFO. ENTRY ADDRESS LDA B,I GET OFFSET ADA F.C ADD THE THE CURRENT OFFSET STA F.C AND SAVE IT INB GET ADDRESS OF LDB B,I THE EXT NO INB AND JSB GETEX GO SET IT UP ADB N1PS SUBTRACT ONE AND ADD THE SIGN LDA T0OA AND THE INSTRUCTION JSB OW.F PUT OUT A R111 OCT 160000 R=111 3- WORD EXT WITH OFFSET JMP OA.F,I RETURN * T0OA NOP F.NIT NOP NO-INLINE-TEMPS FLAG. COM. OCT 4000 F.AT=COM C2000 OCT 175777 COMPLEMENT OF 2000 (THE CURRENT PAGE BIT) K1 DEC 1 DUM OCT 5000 AT = 5 DIM OCT 6000 (AT = 6 SUB OCT 200 IU = 1 ARR OCT 600 IU = 3 K2 DEC 2 KM1 DEC -1 B10 OCT 10 BCOM OCT 3000 F.AT=BCOM SIGN DEF 0,I NT=1,IM=0 => A DEF ENTRY SKP * ****************************** * * CHECK FOR DATA WITH OFFSET * * ****************************** SPC 1 * INPUT: (B)=CANDIDATE F.A * OUTPUT: (B)=UPDATED F.A; IF DATA WITH OFFSET, F.C UPDATED. SPC 1 CDO.F NOP LDA B,I FIRST WORD. AND NT&IU F.NT & F.IU CPA DPO DATA PLUS OFFSET ? RSS JMP CDO.F,I NO, EXIT. ADB K2 YES. ADD OFFSET TO F.C LDA B,I ADA F.C STA F.C ADB KM1 SET (B) TO F.A OF MASTER. LDB B,I JMP CDO.F,I SPC 2 * *********************** * * GET EXT ID FROM TBL * * *********************** * * GETEX NOP GET00 LDA B,I GET THE CURRENT VALUE CMA,INA,SZA IF NON-ZERO THATS ALL THERE IS TO IT JMP GETEX,I JUST RETURN IT * ISZ F.XID ALLOCATE A NEW EXT LDA F.XID AND CMA,INA SET ITS NEGATIVE STA B,I IN THE TABLE JMP GET00 GO SET IT AND EXIT SKP * *********************** * * STORE AND OUTPUT OA * * *********************** SPC 1 SOA.F NOP STB F.A SAVE IT JSB OA.F JMP SOA.F,I SPC 2 * ************************ * * OUTPUT ABSOLUTE DATA * * ************************ SPC 1 OAD.F NOP JSB OW.F OUTPUT THE INSTRUCTION OCT 0 R=0 FOR ABSOLUTE DATA (OCT WORD) JMP OAD.F,I RETURN A=0, E=1 SPC 2 * ******************************* * * OUTPUT ABSOLUTE INSTRUCTION * * ******************************* SPC 1 OAI.F NOP JSB OW.F OCT 060000 R011 FOR MNEMONIC OPCODE JMP OAI.F,I RETURN AR=0, E=1 SPC 2 * **************************************** * * OUTPUT ABSOLUTE REGISTER INSTRUCTION * * **************************************** SPC 1 ORI.F NOP ALF,RAL MOVE BIT 11 TO BIT 0. IOR F.RES INSERT A/B BIT. ALF,ALF RESTORE. ALF,RAR JSB OAI.F NOW OUTPUT. JMP ORI.F,I DONE. SKP * *************************************** * * OUTPUT MEMORY REFERENCE INSTRUCTION * * *************************************** SPC 1 OMR.F NOP JSB OW.F OUTPUT INSTRUCTION R101 OCT 120000 R=5 FOR MEMORY REFERENCE LDB T1OW GET THE ADDRESS ADB K8 ALLOW A NEGATIVE OFFSET OF 8 SSB,RSS IF NOT AN A.T. REF JMP OMR.F,I JUST RETURN * ADB KK03 RESTORE THE ADDRESS TO B LDA B,I SET THE USED BIT IOR B10 IN THE A.T. STA B,I AND THEN CLA JMP OMR.F,I RETURN SPC 2 * *************************************** * * OUTPUT INSTRUCTION WITH DOT-OPERAND * * *************************************** SPC 1 OID.F NOP STA T1OID SAVE THE INSTRUCTION. ADB F.D.T GET ADDRESS TO B JSB GETEX GET THE EXT ID IOR T1OID ADD THE INSTRUCTION. JSB OW.F SEND IT KK01 OCT 100000 JMP OID.F,I AND RETURN * T1OID NOP SAVED INSTRUCTION CODE. SPC 2 * *********************** * * OUTPUT DOT FUNCTION * * *********************** SPC 1 ODF.F NOP LDA JSBI JUST JSB TO IT. JSB OID.F SEND IT JMP ODF.F,I AND RETURN SPC 2 * ****************************** * * OUTPUT DEF TO DOT FUNCTION * * ****************************** SPC 1 ODD.F NOP CLA A=0 FOR DEF. JSB OID.F SEND IT. JMP ODD.F,I EXIT. SKP * HE ******************************************** * * PRODUCE THE DEF DESCRIBED BY CURRENT F.A * * ******************************************** * * PDF.F NOP LDA F.RPL DEFINE ITS ADDRESS JSB DAF.F AS THE CURRENT ADDRESS LDB F.AT WHERE IS IT CPB BCOMI LABELED COM? JMP PDF03 YES DO SPECIAL * CLA NO SET FOR DEF CPB COM IN COMMON? LDA K2 YES SET MR LDB F.A INDEX ADB K2 INTO THE ENTRY LDB B,I AND GET THE ADDRESS JSB OMR.F OUTPUT THE WORD PDF02 LDA F.A,I SET THE R FLAG IOR B20 TO SHOW STA F.A,I IT WAS DONE JMP PDF.F,I AND RETURN * PDF03 LDB F.A LABELED COMMON REFERENCE ADB K2 GET THE LDA B,I OFFSET AND STA F.C SET UP INB GET THE LDB B,I ADDRESS OF THE MASTER JSB CDO.F IF DATA WITH OFFSET, FIX THAT. INB INDEX TO THE EXT WORD. JSB GETEX GET THE EXT NO ADB N1PS ADD THE SIGN BIT AND SUBTRACT ONE CLA SET INSTRUCTION TO DEF JSB OW.F SEND IT OCT 160000 MAKE SURE IT IS WITH OFFSET JMP PDF02 GO SEND IT * * K8 DEC 8 F.C NOP B20 OCT 20 COM OCT 4000 F.AT=COM BCOMI OCT 7000 F.AT=BCOMI N1PS OCT 77777 -1+100000B KK03 OCT 77770 -8-100000B JSBI OCT 16000 SKP * *************************** * * OUTPUT LOAD ADDRESS=RPL * * *************************** SPC 1 OLR.F NOP CLB LDA F.RPL JSB OW.F R001 OCT 20000 R=1 JMP OLR.F,I RETURN A=0, E=1 SPC 2 * *************** * * OUTPUT ZREL * * *************** SPC 1 OZ.F NOP OUTPUT COMMAND OF FORM 'OP *+N' ADB ADON ADD CURRENT DISPLACEMENT ADB F.C NOT CURRENTLY ONEEDED BUT FEEL FREE STB F.C SET THE TOTAL DISPLACEMENT LDB F.LLO GET THE BASE ADDRESS JSB OMR.F OUTPUT INSTR. (A) HAS OP IN IT JMP OZ.F,I SPC 2 * ******************* * * OUTPUT CONSTANT * * ******************* SPC 1 OC.F NOP OUTPUT INT,REA,LOG,CPX, OR DBL LDA F.D0+1 CONSTANT. CMA,INA STA T0OC -LENGTH OF CONST LDA F.DID 1ST LOC OF F.IDI STA T1OC OC01 LDA T1OC,I JSB OAD.F OUTPUT WORD ISZ T1OC ISZ T0OC JMP OC01 NOT DONE; OUTPUT MORE WORDS. JMP OC.F,I RETURN A=0, E=1 * T0OC NOP T1OC NOP SKP * *************** * * OUTPUT WORD * * *************** SPC 1 * INPUT: (A)=WORD TO BE OUTPUT * (B)=2ND WORD IF MR * (F.C)=OFFSET IF R=111 OR IF R=101 AND F.C#0 * THEN: JSB OW.F * VFD 3/R,13/0 * WHERE R = RELOCATION INDICATOR IN HIGH ORDER (-1 IF SRC) * * THE VALUES OF 'R' AND THEIR MEANINGS ARE: * * R=000 OCTAL DATA. * R=001 ORG TO (B). * R=010 ASCII DATA. * R=011 ABSOLUTE INSTRUCTION. * R=100 EXTERNAL, EXT ID IN LOW BITS. * R=101 MEM REF INSTRUCTION TO (B). * R=110 BYTE DEF; A<15>=LSB, (B)=WORD ADDR. * R=111 EXTERNAL (B) WITH OFFSET (F.C). * * SET UP WORD TO OUTPUT AND RELOCATION INDICATOR. * IF R=1,5,7 THEN SET UP ADDRESS. * OW.F NOP STA T0OW SAVE (A) STB T1OW SAVE (B), JUST IN CASE. LDA OW.F,I (A)=RELOCATION INDICATOR. ISZ OW.F STA R SAVE 'R'; SEE IF ADDRESS IN (B). CPA R001 R=1,5,7 ? RSS CPA R101 RSS CPA R111 RSS JMP OW01 NO. IGNORE (B). (OR BYTE ADDR) * STB T1OW YES, SET AS TENTATIVE ADDR. ADB K8 A.T. REF ? SSB,RSS JMP OW01 NO. * ADB KK03 YES. RESTORE & REMOVE BIT 15. JSB CDO.F HANDLE DATA WITH OFFSET. ADB SIGN PUT BIT 15 BACK, STB T1OW AND SET AS ADDRESS. SKP * IF R=5 & F.C#0, CHANGE R TO 7. * OW01 LDB R (B)=R. LDA F.C (A)=OFFSET. CPB R101 IF R=5, NORMAL MEM REF, SZA,RSS AND OFFSET#0, RSS (NO. LEAVE IT) LDB R111 THEN SET TO OFFSET TYPE. STB R (IN CASE CHANGED) * * IF NEW RECORD (E.G. INIT) THEN START IT UP. * CPB R001 IS THIS A NEW LOAD LOC? JMP OWS41 YES * CLB,INB IF A NEW RECORD CPB F.BUF THEN JMP OW07 GO SET IT UP * * SEE IF ENOUGH ROOM IN CURRENT RECORD. * LDA KM63 DETERMINE ROOM IN PRESENT SECTOR ADA F.BUF ADD CURRENT USAGE LDB R ADD TO PRIOR DATA RECORD. CPB R111 IF OFSET INA,RSS ADD TWO CPB R101 MEM REF? RSS CPB R110 OR BYTE ADDR ? INA YES. NEEDS EXTRA WORD. LDB RNO ADB KM5. SSB,RSS NEW BYTE WORD NEEDED? INA YES. ALLOW FOR IT SSA,RSS ROOM FOR THESE WORDS? JMP OW06 NO. USE NEW RECORD. * * IT FITS. BUT MAY STILL NEED NEW R-WORD. * SSB,RSS BYTE WORD FULL? JMP OW16 YES. START NEW BYTE WORD JMP OW17 USE PRESENT ONE * * START A NEW RECORD. * OW06 JSB OS.F FULL. OUTPUT RECORD OW07 LDA F.LLO LOAD LOCATION JSB WR SEND IT LDA ADON ADD-ON JSB WR SEND IT SKP * START A NEW RELOCATION INDICATOR WORD. * OW16 LDA PBPT START NEW BYTE WORD. STA RPTR SAVE ITS LOCATION CLA STA RNO JSB WR SEND A ZERO * * #INSERT RELOCATION INDICATOR. * OW17 LDB RNO REL BYTE NO. BLS ADB RNO 3*RNO LDA R RECORD TYPE BYTE CMB,RSS RAR POSITION R-BYTE INB,SZB SHIFT COMPLETE? JMP *-2 NO IOR RPTR,I STA RPTR,I COMBINE PRIOR BYTE WORD ISZ RNO BUMP THE COUNT. * * BUMP LOCATION COUNTER & CHECK FOR OFL. * ISZ ADON ADON=ADON+1 ISZ F.RPL RPL=RPL+1 LDB F.RPL LDA K84 OVERFLOW CODE SSB OVERFLOW?? JMP F.ABT RPL OVERFLOW * * OUTPUT THE CODE. * LDA T0OW JSB WR SEND THE WORD LDB R LDA T1OW GET WORD TWO CPB R101 MEMORY REFERENCE? RSS CPB R110 OR BYTE ADDR ? RSS CPB R111 OR OFFSET TYPE? JSB WR SEND IT IN THIS CASE ALSO LDA F.C GET OFFSET CPB R111 OFFSET TYPE JSB WR YES SEND THE OFFSET CLA,CCE CLEAR A AND STA F.C F.C JMP OW.F,I RETURN A=0, E=1 SKP * ORG. * OWS41 LDA T0OW ELSE SET UP STA F.LLO THE NEW ADDRESS LDA T1OW AND STA ADON OFFSET JSB OS.F FLUSH THE CURRENT RECORD JMP OW.F,I AND RETURN (A=0, E=1) * WR NOP WRITE WORD AND PUSH POINTERS STA PBPT,I ISZ PBPT ISZ F.BUF JMP WR,I RETURN * F.LLO NOP LOAD LOCATION ADON NOP ADD-ON TO LOAD LOCATION PBPT NOP PBUF WORD POINTER RPTR NOP RECORD R1R2R3R4R5 LOCATION RNO NOP R NUMBER KM5. DEC -5 T0OW NOP SAVE ENTRY (A) T1OW NOP SAVE ENTRY (B) R NOP INTERMEDIATE CODE RECORD TYPE KM63 DEC -63 R110 OCT 140000 K84 DEC 84 NT&IU OCT 000601 MASK F.NT & F.IU DPO EQU NT&IU F.NT=1 & F.IU=ARR SKP * ****(************* * * OUTPUT SECTOR * * ***************** SPC 1 OS.F NOP CLB,INB IF EMPTY RECORD CPB F.BUF JUST JMP OS.F,I RETURN * LDB OWK1 STB PBPT RESET PBUF POINTER JSB WRT.C OUTPUT BUFFER TO DISC DEF C.SC0 OWK1 DEF F.BUF DEF F.BUF FIRST WORD IS THE TRUE LENGTH JMP PASER IF NO ERROR RETURN * CLA,CCE SET BUFFER TO POINT TO NEXT WD JSB WR AND COUNT TO ONE JMP OS.F,I RETURN A=0, E=1 * PASER LDA K99 SEND PASS WRITE BOOM JMP F.ABT NO RETURN SPC 1 K99 DEC 99 * IN2.F NOP INIT CODE FOR THIS MODULE LDA OWK1 REMOVE THE INDIRECT RAL,CLE,SLA,ERA IF SET LDA A,I GET THE REAL ADDRESS STA OWK1 ON THE BUFFER ADDRESS STA PBPT CLA SET COUNT TO 1 AND PUSH THE POINTER. JSB WR JMP IN2.F,I RETURN * F.BUF BSS 65 BUFFER FOR WRITING TO PASS FILE. * END \ "Mp 92834-18002 2030 S C0122 &F4X1 PART 1             H0101 ASMB,Q,C HED HEADER FOR FILES &F4X1 AND %F4X1 . NAM F4X1,8 92834-16002 REV.2030 800714 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * END ASMB,Q,C HED FTN4X COMPILER (FTN4X:MAIN) NAM FTN4X,3,90 92834-16002 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ADDRESS OF CURRENT A.T. ENTRY. EXT F.ABT ABORT COMPILER POINT. EXT F.AT ADDRESS TYPE OF CURRENT ITEM. ENT F.AT. SUBSCRIPT INFO FLAG EXT F.CC CHARACTER COUNT ENT F.CCW FTN OPTION WORD ENT F.CSN CURRENT SEGMENT NUMBER. ENT F.CSZ COMMON SIZE ENT F.D DO TABLE POINTER EXT F.D0 ARRAY (ELEMENT) SIZE. ENT F.D.T ADDRESS OF '.' FUN. TABLE ENT F.DID ADDR OF F.IDI ENT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DNI DEF TO NAME BUFFER (NID). ENT F.DO LWAM - END OF DO TABLE ENT F.DPJ DEF TO CURRENT PROC. JUMP TABLE. ENT F.DTY DEFAULT TYPE TABLE. ENT F.E EQUIVALENCE TABLE ADDR. ENT F.EMA F.A OF EMA MASTER. ENT F.EMS EMA SIZE DOUBLE WORD, (INTERNAL FORMAT) ENT F.END END FLAG ENT F.ER0 'RX' OF ERRX LIB ERROR ROUTINE ENT F.FES TWPE FOR FIRST EXECUTABLE STMT. ENT F.FNS FIRST NON-SPECIFICATION CHECK. ENT F.FRF FUNCTION RESULT F.A (NON-STMT FCT). ENT F.IDI GENERAL DATA BUFFER. EXT F.IM CURRENT ITEM MODE. EXT F.IU CURRENT ITEM USAGE. ENT F.IMF IMPLICIT FLAG. ENT F.L # WORDS ON STACK 2 ENT F.LCF LABELLED COMMON FLAG. ENT F.LFF LOCICAL IF FLAG ENT F.LO END OF ASSIGNMEXT TABLE+1 ENT F.LSF EXPECT FIRST STATEMEXT FLAG ENT F.LSN F.A OF LAST STATEMEXT NUMBER ENT F.LSP LAST OPERATION FLAG ENT F.MSG MSEG SIZE ON $EMA(...) ENT F.NAR NUMBER OF ALTERNATE RETURNS. EXT F.NT CURRENT NAME TAG. EXT F.NXN NO INPUT FLAG ENT F.PCT F.A OF TEMP FOR PCOUNT(). ENT F.PTF PERMENENT TEMP FLAG. ENT F.PTY PROGRAM TYPE. ENT F.REL F.RPL OF ENTRY POINT. ENT F.RES F.A OF CURRENT RESULT. ENT F.RPL PROGRAM LOCATION COUNTER ENT F.S1B BOTTOM OF STACK 1 ENT F.S1T TOP OF STACK 1 ENT F.S2T TOP OF STACK 2 ENT F.SBF 0= MAIN, ELSE SUBROUTINE ENT F.SEE RETURN POINT FROM SEGMENT 1. ENT F.SEG LOAD A NEW SEGMENT ENT F.SEQ CODE-GENERATING STATEMENT COUNTER. ENT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 ENT F.SID STATEMEXT ID PHASE FLAG ENT F.SLF STATEMEXT LEVEL FLAG ENT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL ENT F.SPS ADDRESS OF CURRENT STATEMENT PROCESSOR. ENT F.STA FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ ENT F.STB STRING BACK FLAG (LOGICAL IF) ENT F.SVL SAVE # WDS ON OPER STACK (F.L) ENT F.SXF COMPLEX CONSTANT FLAG ENT F.T # WORDS ON STACK 1 ENT F.TYP TYPE STMT FLAG ENT F.XID EXTERNAL ID COUNTER. ENT F.UFM ADDR OF UNIT-FILE MAP. ENT F.#M # NON-DISC I/O CONNECTIONS. ENT F.#N # DISC I/O CONNECTIONS. ENT F.#S BUFFER SIZE MULTIPLE. ENT F.#B # OF BUFFER BLOCKS. ENT F.$CC SAVED F.CC AT $ STATEMENT BREAK. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * ENT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM. ENT APT.F ALLOCATE 'PERMANENT' TEMP CELL. EXT BNI.F CLEAR NAME BUFFER TO BLANKS. ENT CAT.F COMMON CODE FOR ALLOCATING TEMPS. EXT DAT.F DEFINE F.AT . EXT DL.F DEFINE LOCATION OF CURRENT A.T. ENTRY. EXT ER.F ERROR PRINT SUBROUTINE. EXT FA.F FETCH ASSIGNS. ENT MVW.F MOVE WORDS, FTN-STYLE. ENT NEW.F SUB TO CLEAR TEMPS FOR A NEW MODULE EXT WAR.F WARNING PRINT SUBROUTINE. EXT WS1.F WRITE TO FIRST PASS FILE. * * EXTERNAL IN THE SEGMENTS. * EXT F.GRX TO SECOND LEVEL OF GRD.F EXT F.RCO ACCESS TO RCO.F: RELATE COMMON. EXT FER.F DO PROGRAM ENTRANCE STUFF. * * ENTRIES TO KEEP THE GENERATOR HAPPY. * ENT F.GRD GET REGISTER DATA. * * THIS FORTRAN IV COMPILER RUNS UNDER VARIOUS OP * SYSTEMS THROUGH SUITABLE INTERFACE ROUTINES. * * OPSYSTEM INTERFACE: * * EXT .MVW MOVE WORDS INSTRUCTION. EXT SEG.F SEGMENT TRANSLATOR EXT WRT.C EXT C.TTY EXT C.BIN BINARY FCB (MUST BE IN MAIN) EXT C.SAU SOURCE FCB (MUST BE IN MAIN) EXT C.SC0 CARD FILE FCB (MUST BE IN MAIN). EXT C.TRN COMPILER LIB. DATA STORE EXT OLY.C SEGMENT LOAD SPC 1 SUP A EQU 0 A-REGISTER B EQU 1 B-REGISTER SKP * ****************************** * * MAIN ENTRY TO THE COMPILER * * ****************************** SPC 1 FTN4 BSS 0 DST F.IDI SAVE THE RUN REGS. LDB K4 GO TO SEGMENT 4 JMP F.SEG SPC 2 * ************************* * * COMPILE A NEW PROGRAM * * ************************* SPC 1 NEW.F NOP CLA STA F.NXN RESET NO INPUT FLAG STA F.SID CLEAR THE SCAN SWITCH LDA K73 STA F.LSP SET PATH TO THIS STATMENT TRUE STA F.CC SET F.CC=73 JMP NEW.F,I RETURN SPC 2 F.STA NOP FTN READ YET FLAG F.CCW DEC 1 COMPILE OPTION CONTROL WORD (PRINT CON REC.) F.DNB DEF NBUF K4 DEC 4 F.ER0 ASC 1,R0 F.DO NOP LWAM; END OF F.DO TABLE F.D.T DEF ..TBL * F.LO NOP END OF ASSIGNMENT TABLE + 1. F.S1B NOP BEGIN OPERAND STACK F.S1T NOP END OPERAND STACK F.S2T NOP END OPERATOR STACK K73 DEC 73 F.D NOP DO-TABLE POINTER F.LSF NOP F.LSN NOP LAST STATEMENT NUMBER FLAG F.STB NOP ADDRESS OF STRING-BACK ENTRY. * NBUF EQU * START OF NAM RECORD DEF C.TRN DUMMY REF. TO FOURCE LOAD WITH MAIN DEF C.BIN ALSO A DUMMY DEF C.SAU DITTO. DEF C.SC0 DITTO. F.PTY EQU NBUF+9  PROGRAM TYPE. BSS 60-*+NBUF RESERVE ROOM OF NAM RECORD SKP * ****************** * * SEGMENT LOADER * * ****************** SPC 1 * ENTRY (B) = SEGMENT NUMBER. * F.SEG STB F.CSN SET THE SEGMENT NUMBER JSB SEG.F GET SEGMENT ID DEF F.CSN FOR SEGMENT STB SEG SET FOR CALL JSB OLY.C LOAD SEGMENT (NO RETURN) SEG NOP * JSB WRT.C SEGMENT LOAD FAILED DEF C.TTY TELL HIM DEF NOSEG DEF L.NOS NOP (IN CASE ERROR) HLT 0 FOURCE MP (OR HLT IF SUCH A SYSTEM) * NOSEG ASC 12,/FTN4X: SEGMENT MISSING!, L.NOS DEC 12 F.CSN NOP CURRENT SEGMENT NUMBER. F.SEQ NOP SEQUENCE COUNTER FOR CODE-GEN STMTS. F.SLF NOP STATEMENT LEVEL FLAG F.SID NOP STID FLAG F.END NOP SPC 2 * ********************** * * MOVE WORDS ROUTINE * * ********************** SPC 1 * CALL: JSB MVW.F * DEF * DEF * DEC <# WDS> * MVW.F NOP LDB MVW.F (B) = ADDR ADDR DEST. ISZ MVW.F LDA MVW.F (A) = ADDR ADDR SOURCE. ISZ MVW.F LDA A,I RESOLVE ADDRESSES. RAL,CLE,SLA,ERA JMP *-2 LDB B,I RBL,CLE,SLB,ERB JMP *-2 JSB .MVW MOVE THE BLOCK. DEF MVW.F,I NOP ISZ MVW.F BUMP PAST WORD COUNT, JMP MVW.F,I AND EXIT. SKP * ********************************* * * FIRST NON-SPECIFICATION CHECK * * ********************************* SPC 1 * INPUT: (A)=STATEMENT TYPE HIERARCHY. * (B)=STATEMENT KEYWORD ORDINAL. SPC 1 F.FNS STB T2FNS SAVE ORDINAL. CLB STB F.END RESET '$'-END FLAG STA F.SLF LEVEL OF THIS STMT LDB F.SEQ SAVE SEQUENCE DATA. STB T1FNS CPA K8 FORMAT ? JMP $FNS16 YES. SKIP ALL THIS JUNK. CPA K4 IS IT EXECUTABLE ? ISZ F.SEQ YES. BUMP COUNTER. CPA K5 IF END STMT. JMP FNS07 CHECK FOR RELAT COMMON YET ADA KM3 SSA JMP F.SEE * LDA F.SPF EXECUTABLE. SZA IF NOT ZERO OR CPA K1 ONE JMP F.SEE THEN * FNS02 CLB,INB IT IS AN EXECUTABLE CPB F.CSN EVALUATOR IN MEMORY? JMP F.SEE YES. GO TO ITS RETURN POINT. JMP F.SEG NO. LOAD IT. RETURN TO F.SEE (B=1) * K1 DEC 1 K5 DEC 5 K8 DEC 8 KM3 DEC -3 KM2 DEC -2 T1FNS NOP * FNS07 LDB F.SPF COMMON RELATED YET?? ADB KM2 ZERO OR ONE IF NOT SSB,RSS WELL? JMP FNS02 YES. NOW (CONDITIONALLY) LOAD F4.1 * JSB F.RCO,I NO. GO DO IT. FNS06 LDA K2 AND SET PGM LEVEL TO 2. STA F.SPF JMP FNS02 NOW GO TO F4.1 SKP * WHEN LOADED, F4.1 DOES NOTHING EXCEPT RETURN HERE. * F.SEE LDB F.SLF CPB F.SPF SPECIFICATION FLAG JMP FNS12 F.SLF EQUALS CURRENT STMNT LEVEL * CMB,INB ADB F.SPF F.SPF-F.SLF LDA K34 SSB,RSS JMP FNS17 F.SPF .GT. F.SLF, STMNT OUT OF ORDER * CLA,INA TEST IF JUST A SPEC STMT. CPA F.SLF WELL? JMP FNS05 YES SKIP TEST FOR RELATE COM * CMA A=-2 ADA F.SPF IF CURRENT LEVEL IS LESS THAN TWO SSA,RSS THEN JMP FNS05 (NO) * JSB F.RCO,I RELATE COMMON ITEMS LDA F.SLF PROCESSING FIRST DATA STATEMENT ? CPA K2 JMP FNS05 YES. LEAVE SEGMENT 0 IN MEMORY. JMP FNS06 NO. GO ADVANCE PGM LVL & LOAD SEGMNT 1. * FNS05 LDA F.SLF LDB F.SPF GET CURRENT STMT. LEVEL CPB K4 IF AT 4 ALREADY THEN JMP FNS08 WE HAVE ALREADY DONE THE ENTRY * CPA K5 IF END RSS DO NOT ADVANCE STA F.SPF ADVANCE PROGRAM STMT LEVEL ADA KM3 AT 1ST STMT FCT OR 1ST EXECUTABLE, SSA,RSS INCL END ? (I.E., NEW LEVEL = 3,4,5 ?) JSB FER.F YES, PRODUCE ENTRANCE CODE. FNS08 LDA F.LSN LAST STATEMENT NUMBER STA F.A SZA,RSS JMP FNS20 NONE; GO TO PROCESSOR. * LDA F.SLF FORMAT STATEMENT LDB F.LFF OR TRUE BRANCH OF LOGICAL IF ? SZB,RSS CPA K8 JMP FNS20 YES. DON'T DEFINE STATEMENT #. * LDA K77 LDB F.SPF STATEMENT LEVEL FLAG ADB KM3 SSB EXECUTABLE? JMP FNS15 NO. GRIPE ABOUT STMT NO. * JSB FA.F YES. ALREADY DEFINED ? (FOR FORMAT)? LDB F.AT I.E., IS F.AT=REL ? LDA K27 (ERROR #) CPB REL JMP FNS15 YES. GO ISSUE WARNING 27. * LDA REL NO. SET F.AT=REL SO KNOW HAS BEEN SEEN. JSB DAT.F LDA KK37 OUTPUT OPCODE TO DEFINE IT. JSB WS1.F LDA F.A AND THE F.A JSB WS1.F LDA F.A SAVE THE SEQUENCE # SO WE CAN OPTIMIZE INA OUT 'GOTO NEXTLINE' LDB T1FNS CMB DON'T CONFUSE WITH DEFAULT VALUE. STB A,I JMP FNS20 EXIT. SPC 1 FNS12 LDA F.LSP LAST OPERATION FLAG ADA F.LSN LAST STATEMENT NUMBER FLAG CLB,INB STB F.LSP FNS14 SZA JMP FNS08 LDA K35 FNS15 JSB WAR.F NO PATH TO THIS STATEMENT CLA IN CASE IT'S DECLARATION WITH STA F.LSN STMT #, ZAP IT. JMP FNS20 SPC 1 FNS16 LDA F.LSN LAST STATEMENT # FLAG JMP FNS14 * FNS17 LDB F.SLF GET THE LEVEL FLAG CPB K2 DATA STATEMENT? CLB,RSS YES IT CAN BE OUT OF ORDER JSB ER.F NO BAIL OUT * CPB F.CSN IF SPEC. SEGMENT IN MEMORY JMP FNS08 GO FINISH UP * LDA K77 (IN CASE ERROR) CPB F.LSN STATEMENT NUMBER?? RSS <5NO. JSB WAR.F YES. ERROR. * CLB NOW LOAD SEGMENT 0. JMP F.SEG * K2 DEC 2 K27 DEC 27 K34 DEC 34 K35 DEC 35 K77 DEC 77 KK37 BYT 1,45 DEFINE STMT # OPERATOR. REL OCT 1000 F.AT = REL. SKP * GO TO PROCESSOR. THE LOOK-UP OF THE PROCESSOR * ADDRESS MUST BE DELAYED SO THAT IF A SEGMENT * IS LOADED, IT CAN UPDATE 'F.DPJ'. * FNS20 LDB T2FNS KEYWORD ORDINAL. ADB F.DPJ GET ADDR PROCESSOR. LDB B,I STB F.SPS SET IT FOR USE BY THE PROCESSOR, JMP B,I AND GO THERE. * T2FNS NOP KEYWORD ORDINAL. SKP * ****************** * * ASSIGN ADDRESS * * ****************** SPC 1 * TO ASSIGN STORAGE TO A SINGLE VARIABLE OR ARRAY * INPUT: F.A=POINTS AT THE CANDIDATE FOR STORAGE ASSIGNMENT * OUTPUT: STORAGE IS ASSIGNED FOR THE ELEMENT(IF NOT YET * ASSIGNED) POINTED AT BY F.A * EACH ELEMENT HAS ITS AT SET TO REL AND ITS AF SET * TO THE ELEMENTS RELATIVE LOCATION WITHIN THE OBJECT * OUTPUT & RPL BUMPED BY SIZE OF THE ELEMENT OR ARRAY. SPC 1 AA.F NOP LDA F.NT A NAME? SZA JMP AA.F,I NO. RETURN. LDA F.AT CPA B2000 STRAB RSS NOT YET ASSIGNED JMP AA.F,I ALREADY ASSIGNED LDA F.IU CPA VAR JMP AA02 F.IU=VAR CPA ARR RSS F.IU=ARR JMP AA.F,I NEITHER VAR NOR ARRAY AA02 JSB DL.F DEFINE LOCATION DLD F.D0 CHECK THAT SIZE < 32768. SZA,RSS I.E., UPPER WORD = 0, SSB AND LOWER WORD >= 0. JMP AA03 NO. MEM OFL. ADB F.RPL O.K., ADD TO LOC. STB F.RPL RPL=RPL+F.D0 SSB,RSS JMP AA.F,I * AA03 LDA K84 RPL OVER FLOW JMP F.ABT ABORT * VAR OCT 400 F.IU=VAR. ARR OCT 600 6I F.IU=ARR. K84 DEC 84 B2000 OCT 2000 SKP * ***************************** * * ALLOCATE 'PERMANENT' TEMP * * ***************************** SPC 1 APT.F NOP STA F.IM SAVE THE TYPE. ALF INDEX INTO THE TEMP TABLE. LDB DFINT ADA B ISZ A,I BUMP TO THE NEXT ONE. LDA A,I AND GET IT. ADA B2000 USE 2ND HALF OF RANGE ALLOCATED. JSB CAT.F COMMON CODE TO DO IT. JMP APT.F,I DONE. SPC 2 * COMMON CODE FOR ATC.F & APT.F * CAT.F NOP ENTER WITH (A)=TEMP #, F.IM=TYPE. RAL PUT THE TYPE IN BITS 14:11, IOR F.IM BY SHIFTING TWICE. INA SET BIT 15 WHILE WE'RE AT IT. RAR DONE. <15>=1, <14:11>=TYPE, <10:0>=NUMBER. STA T0CAT SAVE TEMP CELL NAME CLA STA F.NT NAME TAG = 0 (VARIABLE) STA F.PTF (ALSO CLEAR PERMANENT TEMP FLAG) LDA VAR STA F.IU ITEM USAGE = VARIABLE JSB BNI.F CLEAR NAME TO BLANKS LDA T0CAT SET UP THE FIRST TWO CHARACTERS AND B377 AS THE IDENT HIGH AND LOW BYTES. LDB A (B) = LOW BYTE. XOR T0CAT (A) = HIGH BYTE. ALF,ALF (RIGHT-JUSTIFY) DST F.DNI,I THERE THEY GO. JSB AI.F ASSIGN NAME TO A.T. LDA F.A RETURN ASSIGN TAB PTR TO TEMP CELL LDB F.A JMP CAT.F,I SPC 1 T0CAT BSS 1 DFINT DEF F.INT-1 B377 OCT 377 * ****************************************** * * GLOBAL VARIABLES,BUFFERS,AND CONSTANTS * * ****************************************** SPC 1 F.LSP NOP LAST OPERATION FLAG. F.SPS NOP ADDR OF CURRENT STMT PROCESSOR. F.LFF NOP LOGICAL IFF FLAG. F.GRD DEF F.GRX,I POINTER TO GRD.F F.DID DEF F.IDI ADDR OF F.IDI F.DTY DEF TYPET ADDR OF DEFAULT TYPE TABLE. F.DPJ NOP  ADDR OF CURRENT PROC. JUMP TABLE. F.RES NOP F.A OF CURRENT RESULT. SPC 2 * ********************** * * DEFAULT TYPE TABLE * * ********************** * * THIS TABLE CONTAINS THE DEFAULT OR IMPLICIT TYPE FOR EACH OF THE * LETTERS (WHICH MAY START AN IDENTIFIER). IT IS INITIALIZED BY THE * INITIALIZATION SEGMENT BEFORE EACH MODULE, AND IS MODIFIED BY ANY * 'IMPLICIT' STATEMENT ENCOUNTERED. EACH BYTE IS THE LEFT BYTE OF * THE CORRESPONDING F.IM, E.G. F.IM=REA=020000, LEFT BYTE = 40. * TYPET BYT 40,40,40,40,40,40,40,40 A-H, REAL. BYT 20,20,20,20,20,20 I-N, INTEGER. BYT 40,40,40,40,40,40,40,40,40,40,40,40 O-Z, REAL. SKP * ******************* * * INITIALIZE TO 0 * * ******************* SPC 1 ABS COMEN-F.AT.-1 LENGTH OF AREA TO ZAP F.AT. OCT 0 SUBSCRIPT INFORMATION FLAG F.REL BSS 1 ENTRY POINT. F.RPL BSS 1 RELATIVE PROGRAM LOCATION F.SFF BSS 1 SUBROUTINE/FUNCTION FLAG (SET IF * A FUNCTION) F.SPF OCT 0 SPECIFICATION FLAG (SET TO * CURRENT STATEMENT LEVEL) F.SBF NOP SUBPR FLAG(0=MAIN,ELSE SUBPROG.) F.L NOP NUMBER OF WORDS ON STACK 2 F.SVL NOP SAVED COPY OF F.L F.SXF NOP COMPLEX CONSTANT FLAG F.T NOP NO. WORDS ON STACK 1 F.TYP NOP TYPE STATEMENT FLAG F.CSZ NOP COMMON SIZE F.MSG NOP MSEG SIZE. F.EMS OCT 0,0 DOUBLE WORD EMA SIZE F.EMA NOP F.A OF EMA MASTER. F.INT BSS 13 TEMP CELL NUMBERS. F.IDI BSS 14 GENERAL DATA BUFFER. F.E NOP EQUIVALENCE TABLE POINTER. F.XID NOP EXTERNAL ID COUNTER. F.IMF NOP IMPLICIT FLAG. F.NAR NOP NUMBER OF ALTERNATE RETURNS. F.LCF NOP LABELLED COMMON FLAG. F.#M NOP # NON-DISC. F.#N NOP # DISC'. F.#S NOP BUFFER SIZE. F.#B NOP NUMBER OF BUFFER BLOCKS. F.UFM NOP ADDR OF UNIT-FILE MAP. F.PTF NOP PERMANENT TEMP FLAG. F.FES NOP TWPE OF 1ST EXECUTABLE. F.$CC NOP SAVED F.CC AT $ STATEMENT BREAK. F.PCT NOP F.A OF TEMP USED BY PCOUNT(). F.FRF NOP FUNCTION RESULT F.A (NON-STMT FCT). SPC 1 * ******************** * * .EXTERNAL TABLE * * ******************** SPC 1 * THIS TABLE OF EXTERNAL ORDINALS FOR DOT-FUNCTION * SUBROUTINES IS CLEARED TO ZERO AT THE BEGINNING OF * COMPILATION. * ..TBL BSS 348 SPC 1 COMEN EQU * LOCATION OF END OF COMMON AREA ORG * END FTN4 ASMB,Q,C HED ASSIGNMEXT TABLE ROUTINES NAM FA.F,8 92834-16002 REV.2030 800707 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE OF THE HP FTN4X COMPILER CONTAINS THE * ASSIGNMEXT TABLE ROUTINES. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) ENT F..E DIMENSIONS CONSTANT BIT FROM ASSIGNS TABLE ENT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY ENT F.AF ADDRESS FIELD CURREXT F.A ENT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.AT. SUBSCRIPT INFO FLAG ENT F.CSL CHARACTER STRING LENGTH. ENT F.D0 ARRAY ELEMEXT SIZE ENT F.DCF DIM, COM FLAG EXT F.DID ADDRESS OF F.IDI ENT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. ENT F.DNI ADDRESS OF NID ENT F.DP BASE OF USER SYMBOL TABLE EXT F.E EQUIVALENCE TABLE POINTER ENT F.EM EMA FLAG BIT IN A.T. ENT F.EXF EXTERNAL STATEMEXT FLAG EXT F.IDI INPUT ARRAY NON-NUMERIC ENT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) ENT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LCF LABELLED COMMON FLAG. EXT F.LO END OF ASSIGNMEXT TABLE+1 ENT F.LUB ADDRESS OF LOWER/UPPER BOUNDS TABLE. ENT F.NC NAME CHANGE FLAG. ENT F.ND NUMBER OF DIMENSIONS ENT F.NT NAME TAG 0= VAR, 1=CONSTANT. ENT F.NTF NAME TAG FLAG EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. ENT F.R MISC A.T. FLAG EXT F.RPL PROGRAM LOCATION COUNTER ENT F.S SUBROUTINE FLAG. EXT F.S1T TOP OF STACK 1 ENT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 ENT F.SFA F.A OF STMT FCT IF CURRENTLY IN ONE. EXT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL EXT F.TC NEXT CHARACTER ENT F.VDM VARIABLE DIMENSIONS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * ENT AI.F ASSIGN ITEM ENT AST.F ALLOCATE SPACE IN SYMBOL TABLE. ENT BNI.F CLEAR NID TOQ= BLANKS ENT CFC.F CHECK FOR CONSTANT. ENT CDI.F CLEAR IDI ROUTINE ENT CSN.F CHECK STATEMENT NUMBER TYPE ENT DAD.F DOUBLE INTEGER ADD. ENT DAF.F DEFINE (F.AF) ENT DAT.F DEFINE (AT) ENT DEM.F DEFINE (F.EM)=1 ENT DIM.F DEFINE (F.IM) ENT DIU.F DEFINE (F.IU) ENT DL.F DEFINE LOCATION SUBROUTINE ENT DMP.F DOUBLE INTEGER MULTIPLY. ENT DS.F DEFINE (F.S)=1 ENT DSB.F DOUBLE INTEGER SUBTRACT. ENT EDO.F ESTABLISH DATA WITH OFFSET. ENT EIC.F ESTABLISH INTEGER CONSTANT. ENT EJC.F ESTABLISH DOUBLE INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE ENT ESC.F ESTABLISH CONSTANT SUBROUTINE ENT ESD.F ESTABLISH DEF SUBROUTINE ENT FA.F FETCH ASSIGNS ENT FC.F FETCH VALUE OF CONSTANT. ENT FID.F FETCH (ID) TO NID (UNPACK) ENT GCD.F GET CONSTANT DIMENSION AS DOUBLE INT. ENT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. ENT GFC.F GET FIRST (CONSTANT) SYMBOL TABLE ENTRY. ENT GFD.F GET FIRST (DEF) SYMBOL TABLE ENTRY. ENT GNA.F GET NEXT SYMBOL TABLE EXTRY ENT IN4.F INIT FOR FA.F MODULE ENT ITS.F INTEGER TEST ENT NAM.F COPY SYMBOL NAME. ENT NCT.F TEST FOR NOT A CONSTANT ENT NET.F TEST FOR NOT EMA. ENT NST.F TEST FOR NOT A SUBROUTINE NAME ENT NTI.F MOVE NID TO F.IDI (PACKS) ENT NWE.F RETURN (B) = # WORDS IN ITEM TYPE F.IM ENT NWI.F SET F.D0 TO # WORDS IN ARRAY ENT TCT.F TEST (A) = F.TC ELSE ER 28 ENT TS.F TAG SUBPROGRAM SUB. ENT TV.F TAG VARIABLE EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) * * GENERAL LIB EXT * EXT .MVW MOVE WORDS * A EQU 0 B EQU 1 SUP * * IN4.F NOP INITILIZE CODE CLA ZERO OUT THE e STA DSTH+1 SYMBOL TABLE STA DSTH+2 LIST HEADS. STA DSTH+3 STA DSTH+4 JMP IN4.F,I RETURN * K1 OCT 1 SKP * THE ASSIGNMENT TABLE * * WORD -1 IS ALWAYS PRESENT AND GIVES THE ADDRESS OF THE NEXT ENTRY. * WORD 0 IDENTIFIES THE ENTRY AND IS SPLIT UP INTO FIELDS: * * !---------------!-----------!-------!-------!---!---!---!---!---! * ! IM ! AT ! IU ! NC ! R ! E ! S !EM !NT ! * !---------------!-----------!-------!-------!---!---!---!---!---! * !15 14 13 12 ! 11 10 9 ! 8 7 ! 6 5 ! 4 ! 3 ! 2 ! 1 ! 0 ! * !---------------!-----------!-------!-------!---!---!---!---!---! * (170000) (7000) (600) (140) 20 10 (4) (2) (1) * * * IM = ITEM MODE: * * 0: --- STMT NUMBER 6: DBL: DOUBLE PRECISION*6 * 1: INT: INTEGER*2 7: ADDR: TEMPORARY ADDRESS * 2: REA: REAL*4 8: DBI: INTEGER*4 * 3: LOG: LOGICAL*2 9: LO4: LOGICAL*4 * 4: TWPE: OBJECT CODE 10: RE8: DOUBLE PRECISION*8 * 5: CPX: COMPLEX*8 11: STR: CHARACTER * 12: ZPX: COMPLEX*16 * * * AT = ADDRESS TYPE. MEANING OF WORD 1 (F.AF) * * 0: --- ABSOLUTE (NOT USED) * 1: REL: RELATIVE RELATIVE ADDRESS * 2: STR-ABS: UNDEFINED OR NOT DEF * * REFERENCED YET * HOLLERITH CONST - # WORDS. * 3: BCOM: LABELLED COMMON PTR TO BCOMI OR DIM ENTRY * 4: COM: BLANK COMMON OFFSET INTO COMMON * 5: DUM: DUMMY PARAMETER RELATIVE ADDR OF DEF TO IT * 6: DIM: DIMENSION ENTRY RELATIVE ADDRESS OF ARRAY * (OR POINTER TO BCOM ENTRY) * 7: BCOMI: LBL COMMON OFFSET OFFSET FROM START OF BLOCK * LBL COMMON MASTER 0 OR - EXT ID # * * * IU = ITEM USAGE: HOW USED * * 0: --- NOT YET USED * 1: SUB: SUBROUTINE * 2: VAR/CON: VARIABLE OR CONSTANT * 3: ARR: ARRAY * * * NC = MISC FLAGS * * STATEMENT #'S: TYPE (FORMAT/EXECUTABLE). * SUBROUTINES: EXTERNAL/INTRINSIC/GENERIC FLAGS. * DIMENSION: F.VDM = VARIABLE DIMENSION FLAG. * F.DIS = DOUBLE INTEGER SUBSCRIPT FLAG. SKP * R = MISC FLAG * * BCOMI ENTRY: WHETHER EMA OFFSET REFORMATTED YET. * DEF ENTRY: FLAGS WHETHER GENERATED YET. * SUBPRG ENTRY: INDICATES HAS BEEN USED AS FUNCTION. * * * S = SUBROUTINE FLAG. * * SUBPRG ENTRY: INDICATED HAS BEEN USED AS SUBROUTINE. * * * E = MISC FLAG. * * PASS 1: EXPLICIT TYPING FLAG. * PASS 2,3: REFERENCE FLAG. * * * EM = EMA FLAG. NT = NAME TAG * * 0: IN LOCAL MEMORY 0: NAMED ITEM * 1: IN EMA 1: UNNAMED ITEM SPC 4 * SPECIAL NOTE ON ADDRESS TEMPS: * * NOTE: FOR ADDRESS TEMPS (F.IM=ADDR), IF A 'DEF' IS DONE TO THE * TEMP, THE TEMP REPLACES THE DEF: ITS F.AF IS SET TO THE ADDR * OF THE DEF. IF WE ARE IN AN IMPLIED DO, THO, F.RPL IS RELATIVE * TO A TWPE ENTRY; IN THIS CASE, AN OFFSET MECHANISM IS USED: * F.AF IS SET TO THE F.A OF THE TWPE ENTRY + 100000B, AND WORD 2 IS * SET TO THE OFFSET. WE MAY DESTROY WORD 2 AT WILL SINCE ADDRESS * TEMPS ARE RENAMED IN END.F ANYWAY. NO ONE WILL FIND AT THE ENTRY * UNTIL END.F NOW, SINCE IT LOOKS LIKE A VARIABLE, AND ALL SEARCHING * FOR THEM IS COMPLETED IN PASS ONE. * ************************************************************************ * * OBJECT CODE OR LOAD ADDRESS ENTRIES * * 0) IM: TWPE * AT: STR-ABS / REL * IU: 0 * NT: 0 * * 1) AF: REL ADDR IN PROGRAM (0 IF UNDEF) * * USED AS INTERNAL ADDRESS CONSTANTS OR HOLLERITH ADDRESSES. * THE SPECIAL CAS#9E OF HOLLERITH VS. END-OF-LOOP ADDRESS, WITHIN * A PARAM LIST, CAN BE DISTINGUISHED BY F.AT, WHICH IS REL FOR * HOLLERITH (ALREADY DEFINED) OR STR-ABS FOR ADDRESSES. SKP ************************************************************************ * * VARIABLE NAMES: * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: ABS,REL,STR-ABS,COM,BCOM,DUM * IU: VAR/CON,ARR (ZERO IF NAME OF CURRENT PROGRAM) * E: 1 IFF EXPLICITLY TYPED. * EM: 0/1 FOR LOCAL/EMA * NT: 0 * * 1) AF: ADDRESS (AT=REL OR DUM),COMMON OFFSET (AT=COM) * POINTER TO DIM ENTRY (IU=ARR) (THIS BEFORE BCOM) * POINTER TO BCOMI ENTRY (AT=BCOM,IU#ARR) * * 2) WORDS 2-N: SYMBOL, 2 CHARS/WORD, PADDED WITH A BLANK IF REQ'D. * THE LAST CHARACTER (POSSIBLY BLANK) HAS BIT 7 = 1. * ************************************************************************ * * MASTER OR LABEL ENTRY FOR LABELED COMMON * OR SUBPROGRAM NAME ENTRY * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: BCOMI(COM), STR-ABS(EXT SUB), REL(STMT FCT), DUM(DUMMY SUB) * IU: SUB * EM: 0/1 AS LOCAL/EMA. * NT: 0 * * 1) AF: 0 OR - EXT ID NUMBER (BCOM MASTER OR EXT SUB). * ADDRESS OF A TWO-WORD BLOCK CONTAINING THE ADDRESS OF THE * FUNCTION AND THE F.A OF THE FIRST FORMAL PARAM (IF ANY). * REL ADDRESS OF DEF FOR DUMMY SUB. * * 2) WORDS 2-N HAVE SYMBOL (SEE VARIABLES). * ************************************************************************ * * TEMPORARY VARABLES * * 0) IM: INT,LOG,REA,DBL,CPX,ADDR,DBI,LO4,RE8,STR,ZPX * AT: REL * IU: VAR/CON * NT: 0 * * 1) AF: REL ADDR OF TEMP * ( IF IM=ADDR, IS IM OF REFERENCED ITEM) * * 2) TEMP I.D.: <1> , WHERE SEQ# IS IN [1,2047] * * NOTE: SEE ABOVE FOR SPECIAL CONSIDERATIONS FOR ADDRESS TEMPS. SKP ************************************************************************ * * STATEMENT NUMBERS * * 0) IM: 0 * AT: REL,STR-ABS * IU: 0 * NC: TYPE: 0/2/3 = UNKNOWN/NON-FORMAT/FORMAT * NT: 0 * * 1) AF: PROGRAM ADDRESS OF STATEMENT (AT=REL) * POINTER TO THIS ENTRY IF UNDEFINED (AT=STR-ABS) * * 2-N) ASCII STATEMENT #, PREFIXED BY '@', AS A SYMBOL. * ************************************************************************ * * DIMENSION ENTRY * * 0) IM: # OF DIMENSIONS, 1-7. * AT: DIM * IU: 0 * NC: F.VDM: 1 IFF VARIABLE DIMENSION(S). * F.DIS: 1 IFF DOUBLE INTEGER DIMENSION(S). (EMA ONLY) * NT: 1 * * 1) AF: ARRAYS ADDRESS (AT=REL,DUM) OR COMMON OFFSET (AT=COM) * OR POINTER TO BCOMI ENTRY (AT=BCOM) * (NOTE THESE AT'S ARE OF THE VARIABLE ENTRY, THIS AT IS DIM) * * 2) WORD 2: F.A OF: NON-FORMAL: CONSTANT OFFSET TO ELEMENT (0...0) * FORMAL: DEF TO ELEMENT (0...0) * * 3) WORDS 3 to 2*N+2: LB1,UB1,...,LB7,UB7, LOWER & UPPER BOUNDS. * WHEN ENTRY CODE GENERATED, UPPER BOUNDS * REPLACED BY DIMENSION SIZES. * ************************************************************************ * * BLOCK COMMON INFO. ENTRY * * 0) IM: 0 * AT: BCOMI * IU: 0 * EM: 0/1 FOR LOCAL/EMA * NT: 1 * * 1) OFFSET FROM START OF BLOCK. * EMA: LOWER BITS. * EMA FORMAL: F.A OF TEMP FOR BASE ADDR. (REVERSED) * * 2) F.A OF BLOCK NAME. * * 3) EMA: UPPER BITS. * EMA FORMAL: F.A OF TEMP FOR ADDR OF (0,..,0). (DBL INT SUB ONLY) SKP ************************************************************************ * * CONSTANTS * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: REL,STR-ABS * IU: VAR/CON * NT: 1 * ************************************************************************ * * DATA WITH OFFSET * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: REL,COM,BCOM * IU: ARR * NT: 1 * * 1) AF: F.A OF ITEM OFFSET IS FROM * * 2) THE OFFSET * ************************************************************************ * * DEF POINTERS * * 0) IM: 0 * AT: REL,COM,STR-ABS * IU: VAR * R: 1 IFF DEFINED * NT: 1 * * 1) AF: REL ADDR OF DEF (* IF UNDEF) * * 2) + REL ADDR, CONTENTS OF DEF * 100000B + F.A OF ITEM DEF POINTS TO * ************************************************************************ * * DEF POINTERS (EXTERNAL WITH OFFSET) * * 0) IM: 0 * AT: BCOMI * IU: VAR * R: 1 IFF DEFINED * NT: 1 * * 1) AF: REL ADDR OF DEF (* IF UNDEF) * * 2) OFFSET * * 3) F.A OF ITEM WITH EXT I.D. SKP ************************************************************************ * * CHARACTER ITEM EXTENSION. * * 0) # CHARACTERS; 0 = DESCRIPTOR ONLY. * * 1) REL ADDR OF DESCRIPTOR. * * 2) BYTE ADDR OF DATA, IF KNOWN. SKP * ***************** * * FETCH ASSIGNS * * ***************** SPC 1 FA.F NOP LDB F.A LDA B,I AND B170K 170000B STA F.IM F.IM=IM(F.A) LDA B,I AND B7000 STA F.AT F.AT=AT(F.A) LDA B,I AND B600 STA F.IU F.IU=IU(F.A) LDA B,I AND B140 STA F.NC F.NC=NC(F.A) LDA B,I AND B20 STA F.R F.R=R(F.A) LDA B,I AND B10 STA F..E F..E=E(F.A) LDA B,I AND K4 STA F.S F.S=S(F.A) LDA B,I AND K2 STA F.EM F.EM=EM(F.A) LDA B,I AND K1 STA F.NT F.NT=NT(F.A) INB LDA B,I (A)=GF(F.A) STA X5 STA F.AF JSB NWE.F # WDS PER ELEMENT. STB F.D0+1 F.D0=NO. OF WDS FOR THIS ITEM MODE CLA CLEAR THE UPPER STA 1F.D0 HALF OF THE DOUBLE WORD LDA F.IU CPA ARR ARRAY OR DATA WITH OFFSET ? RSS JMP FA02 NO. LDA F.NT YES. WHICH ? SZA JMP FA03 DATA WITH OFFSET. SKP * ARRAY. SET UP DIM ENTRY FIELDS. * LDB X5 (B)=ADDR OF SUBSCRIPT INFO ENTRY LDA B,I AND B20 STA F.R F.R=R(X5) LDA B,I AND B100 STA F.VDM F.VDM=NC(X5), UPPER BIT. LDA B,I AND B40 STA F.DIS F.DIS=NC(X5), LOWER BIT. LDA B,I AND B170K ALF STA F.ND F.ND=IM(X5), (# OF DIMENSIONS) ADB K3 STB F.LUB F.LUB=ADDR BOUNDS LIST. * * SET UP F.AF = 2ND WD OF 1ST LINKED ENTRY, EXIT. * FA03 LDB X5 INB LDA B,I (A)=GF(X5) STA F.AF FA02 LDA F.A,I IF STATEMENT FUNCTION, AND KK10 I.E. F.AT=REL AND F.IU=SUB, LDB A (WANT F.AF IN A-REG) LDA F.AF (A)=F.AF FOR RETURN. CPB KK11 WELL ? LDA A,I THEN SET F.AF TO THE REAL VALUE. STA F.AF (NOP/CHANGE) LDB F.IM CHARACTER STRING ? CPB CHAR RSS (YES) JMP FA.F,I NO. EXIT. * DLD A,I YES. GET TRUE F.AF & LENGTH. STA F.AF SET ADDR DESCRIPTOR, STB F.CSL AND THE CHAR LENGTH. JMP FA.F,I EXIT. * F..E BSS 1 F.EM BSS 1 THE EMA FLAG. F.S BSS 1 SUBROUTINE FLAG. F.VDM BSS 1 VARIABLE DIMENSIONS FLAG. F.DIS BSS 1 DOUBLE INTEGER SUBSCRIPT FLAG. F.LUB BSS 1 ADDRESS OF LUWER/UPPER BOUNDS TABLE. F.CSL BSS 1 CHARACTER STRING LENGTH. DUM OCT 5000 AT=5 TWPE OCT 40000 CHAR OCT 130000 F.IM=CHAR. B100 OCT 100 B200 OCT 200 SUB EQU B200 IU=1 REL OCT 1000 AT=1 X5 BSS 1 ASSIGN TABLE POINTER FOR ARRAY . B7000 OCT 7000 TO ENTRACT AT FIELD BCOMI EQU B7000 B20 OCT 20 B140 OCT 140 K8 DEC 8 B10 EQU K8 KM2 DEC -2 KK10 OCT 007600 MASK OVER F.AT & F.IU KK11 OCT 001200 F.AT=REL & F.IU=SUB, STMT FCT. F.IM NOP ITEM MODE: REAL, CPX, INT, ETC. F.IU NOP ITEM USAGE: DUMMY, RELATIVE, ETC. F.NC NOP NAME CHANGE FLAG F.ND NOP # OF DIMENSIONS F.NT NOP NAME TAG: 0 IF VAR, 1 IF CONST F.AT NOP ADDRESS TYPE F.AF NOP ADDRESS FIELD F.R NOP MISC FLAG. F.D0 NOP WORDS/ARRAY ELEMENT NOP F.D0 IS A DOUBLE WORD SPC 4 * ***************************** * * DETERMINE S.T. ENTRY TYPE * * ***************************** * * ENTRY: F.IM, F.AT, F.IU, F.NT SET UP. * EXIT: (A)=F.STY = TYPE, IN RANGE [-2,3]. (B DESTROYED) * * THE TYPES ARE: * * -2 DIMENSION OR BCOM OFFSET * -1 TWPE * 0 ANY NAMED ITEM. * 1 DATA WITH OFFSET. * 2 CONSTANT. * 3 DEF. * STY.F NOP LDA KM2 (A=-2) LDB F.AT. SZB JMP STY01 F.AT. # 0: -2 CCA (A=-1) LDB F.IM CPB TWPE JMP STY01 F.IM=TWPE: -1 LDA F.NT SZA,RSS JMP STY01 F.NT=0: 0 LDB F.IU (A=1) CPB ARR JMP STY01 F.NT=1, F.IU=ARR: 1 INA (A=2) LDB F.IM SZB,RSS F.NT=1, F.IU#ARR, F.IM#0: 2 INA F.NT=1, F.IU#ARR, F.IM=0: 3 STY01 STA F.STY JMP STY.F,I * F.STY NOP SKP * ********************* * * MOVE NID TO F.IDI * * ********************* SPC 1 * ALSO SETS F.NWN = # WORDS IN SYMBOL. SPC 1 NTI.F NOP LDA NID+4 PACK 3RD WORD ALF,ALF IOR NID+5 STA F.IDI+2 LDB K3 ASSUME 3 WORDS. CPA TWOBS BLANKS ? LDB K2 YES, ONLY 2. STB F.NWN TENTATIVE WORD COUNT. LDA NID+2 PAJCK 2ND WORD ALF,ALF IOR NID+3 STA F.IDI+1 CLB,INB B=1 CPA TWOBS BLANKS ? STB F.NWN YES, ONLY ONE WORD. LDA NID PACK 1ST WORD ALF,ALF IOR NID+1 STA F.IDI JMP NTI.F,I SPC 2 NID BSS 6 F.DNI DEF NID F.NWN NOP # WORDS IN PACKED NAME. TWOBS ASC 1, SKP * ********************* * * SET F.IDI TO ZERO * * ********************* SPC 1 CDI.F NOP SET F.IDI TO ZERO. CLA STA F.IDI STA F.IDI+1 STA F.IDI+3 STA F.IDI+2 STA F.IDI+4 JMP CDI.F,I SPC 2 * *********************** * * CLEAR NID TO BLANKS * * *********************** SPC 1 BNI.F NOP LDA B40 STA NID STA NID+1 STA NID+2 STA NID+3 STA NID+4 STA NID+5 JMP BNI.F,I SKP * *************** * * ASSIGN ITEM * * *************** * * SPECIAL ALGORITHM: IN ORDER TO IMPLEMENT LOCAL SCOPE OF STATEMENT * FUNCTION FORMAL PARAMETERS, THEY ARE ATTACHED ONLY TO THE FUNCTION * ENTRY, THRU ITS F.AF . WE ARE IN A STATEMENT FUNCTION WHEN F.SLF * IS 2; IN THIS CASE, F.SFA IS THE F.A OF THE FUNCTION, WITH THE * SIGN BIT SET IF WE ARE DEFINING FORMAL PARAMETERS. IF F.SLF#2, * FA.F SETS F.SFA=0 TO SIMPLIFY TESTING. * NOW IF SEARCHING FOR A NAMED ITEM (TYPE 0), AND F.SFA#0: * * FIRST, SET T3AI=-1. * * F.SFA<0: SEARCH NORMAL LIST, THEN: * * NO MATCH: T3AI=-1: T3AI_0; GO SEARCH (F.SFA+2) * =0 : O.K. * MATCH: T3AI=-1: T3AI_0; GO SEARCH (F.SFA+2) * (USE F.IM OF MATCHED ITEM) * =0 : O.K. (ERROR, CAUGHT LATER.) * * * F.SFA>0: SET LIST HEAD TO F.SFA+2, THEN: * * NO MATCH: T3AI=-1: T3AI_0; GO SEARCH NORMAL LIST.)? * =0 : O.K. * MATCH: T3AI=-1: O.K. * =0 : O.K. * * STATEMENT FUNCTION FORMAL PARAMETERS ARE NEVER MOVED, * ALWAYS INSERTED AT END OF LIST (INSTEAD OF AT START). * * FOR NAMED ITEMS, IF F.IM=0, F.AT MUST BE BCOMI. (COMMON LABELS) SPC 2 * TEST FOR CASES WE DON'T SEARCH FOR. * AI.F NOP CLA IF NOT STATEMENT FUNCTION, LDB F.SPF CPB K3 (3=STMT FCT) RSS (YES, LEAVE IT) STA F.SFA THEN CLEAR OUT THE FLAG. STA F.SFD CLEAR THE STMT FCT DUMMY FLAG. LDA F.NT IS ITEM A NAME? IOR F.AT. (DIM/BCOMI DON'T SET F.NT) SZA I.E., F.NT=F.AT.=0 ? JMP AI03 NO. * JSB NTI.F YES, F.IDI=NID CCB FIND LAST WORD OF NAME. ADB F.NWN ADB F.DID LDA B,I AND MARK IT. SSA,RSS (UNLESS IT'S A CONSTANT ORDINAL) IOR B200 BY SETTING BIT 7. STA B,I AI03 JSB STY.F DETERMINE TYPE. SSA IS IT A SEARCHABLE TYPE ? JMP AI50 NO. JUST GO ADD IT. * LDA F.STY YES. SET UP COMPARE ROUTINE ADDRESS. ADA DSTC LDA A,I STA STC JSB NWE.F COMPUTE # WORDS (IN CASE CONSTANT). STB F.D0+1 & SAVE. (GARBAGE IS O.K.) * * SET UP & PERFORM SEARCH. * AT FIRST CUT, JUST COMPARE WORD 2 OF EACH. * CCA SET T3AI=-1 IN CASE STMT FCT. STA T3AI LDA F.STY TYPE. LDB F.SFA STATEMENT FUNCTION INFO. CMB,SSB,INB,SZB IF F.SFA>0, SZA AND TYPE=0 (NAMED), JMP AI04 (NO - NORMAL) * AI4A LDA F.SFA YES, STATEMENT FUNCTION EXPRESSION PART, RAL,CLE,ERA (CLEAR POSSIBLE SIGN BIT) INA THE F.AF OF THE STMT FCT POINTS TO 2-WORD LDA A,I BLOCK, WITH 1ST WD = REL ADDR, ADA K2 2ND=LLINK. (A)=ADDR+1 OF LINK. RSS AI04 ADA DSTH (A) = (ADDRESS OF PTR TO FIRST ENTRY)+1 STA F.A USED TO EASILY INSERT FIRST ELEMENT. STA T4AI (REMEMBER FOR LATER) AI02 LDB F.IDI (B) = FIRST WORD OF I.D. PART LDA F.A (A) = F.A+2 ADA K2 * AI022 ADA KM3 REMEMBER WHERE LINK OF LAST ONE WAS. STA T0AI (MUCHO TIME SPENT IN THIS LOOP!) LDA A,I LINK TO NEXT ENTRY. SZA,RSS END OF TABLE? JMP AI120 YES, GO SET UP NEW SYMBOL. * ADA K2 NO, EASY CHECK, FIRST ID WORD. CPB A,I & IF IT MATCHES THEN RSS WORRY ABOUT MORE. JMP AI022 ELSE IT WAS QUICK! * ADA KM2 SET UP CORRECT F.A STA F.A JMP STC,I GO TO TAILORED COMPARE ROUTINE. * * NEW ENTRY!!! * AI120 LDA F.STY GO TO UNIQUE INSERT CODE. ADA DSTI LDA A,I JMP A,I SKP F.DP NOP ADDRESS OF USER A.T. KM3 DEC -3 KK01 DEF 0,I K2 DEC 2 F.S2B NOP END OF A.T. F.A NOP A.T. CURRENT ADDRESS F.SFA NOP F.A OF STMT FCT, IF CURRENTLY IN ONE. STC NOP T0AI NOP T2AI NOP T3AI NOP T4AI NOP * * LINKED LIST HEADS, COMPARE/INSERT ROUTINE ADDRESSES. * DSTH DEF *+2 LINKED LIST HEADS. NOP NAMED ITEMS. NOP DATA WITH OFFSET. NOP CONSTANTS. NOP DEFS. * DSTC DEF *+1 COMPARE ROUTINES. DEF AI000 NAMED. DEF AI100 DATA WITH OFFSET. DEF AI200 CONSTANTS. DEF AI300 DEFS. * DSTI DEF *+1 INSERT ROUTINES. DEF AI050 NAMED. DEF AI150 DATA WITH OFFSET. DEF AI250 CONSTANTS. DEF AI350 DEFS. SPC 4 * NAMED ITEM COMPARE. * AI000 LDA F.DID GET THE ADDRESS OF WHAT WE WANT STA T1AI SET FOR LOOP LDB F.A INDEX TOLt THE ADB K2 FIRST I.D. WORD. * AI05 LDA B,I CPA T1AI,I MATCH?? (ALWAYS, FIRST TIME) INB,RSS YEP, STEP B TO NEXT WORD OF TABLE JMP AI02 ID FIELD NOT MATCHED REJECT THE ENTRY ISZ T1AI AND B15.7 IS THIS THE LAST WORD ? SZA,RSS JMP AI05 NO, TRY THE NEXT WORD. * LDA F.A,I MATCH. IS IT A COMMON LABEL ? AND B7000 I.E., IS F.AT=BCOMI ? LDB F.LCF AND LOOKING FOR ONE ? CPA BCOMI IF LOOKING & GOT IT, SZB,RSS RSS (NO) JMP AI06 THEN ACCEPT. * SZB,RSS IF NOT LOOKING, CPA BCOMI AND DIDN'T GET IT, JMP AI02 (NO. REJECT) * LDA F.SFA MATCH. IN STMT FCT FORMALS DEF ? SSA JMP AI5A YES. * SZA,RSS NO. STMT FCT EXPRESSION PART ? JMP AI06 NO. * LDA T4AI YES. DID WE MATCH A STMT FCT FORMAL ? CPA DSTH RSS NO. ISZ F.SFD YES. SET FLAG. JMP AI06 DONE. * AI5A LDA F.A,I STMT FCT FORMALS DEF; AND B170K EXTRACT F.IM OF MATCHED ITEM. STA F.IM LDA T4AI WHICH LIST WERE WE SEARCHING ? CPA DSTH WAS IT THE NAMED ITEM LIST ? JMP AI4A YES. GO SEARCH THE FORMALS LIST NOW. * LDA K76 DOUBLE DEFINED FORMAL... JSB ER.F DOWN THE TUBES... * K76 DEC 76 SKP * NAMED ITEM MATCH. TAG AS VARIABLE OR SUBROUTINE. * AI06 JSB FA.F FETCH ASSIGN LDA F.NTF NO TAG FLAG SET? SZA JMP AI08 YES, DO NOT TAG ITEM LDA F.IU F.IU FLAGGED? SZA JMP AI09 YES. CHECK FOR DUMMY ITEM LDA F.SPF CURRENT STATEMENT LEVEL CPA K4 RSS EXECUTABLE STATEMENT JMP AI01 NO * LDA F.AT YES CPA DUM JMP AI07 F.AT=DUM * AI01 LDA F.SPF SPEC STATEMENT? SZA (YES IF LEVEL 0 OR 1) CPA K1 SPECIFICATION STATEMENT? JMP AI08 YES * AI07 LDA F.TC F.TC=( ? CPA B50 JMP AI13 YES, SUBPROGRAM JSB TV.F NO, TAG VARIABLE JMP AI08 GO CLEAN UP & EXIT. AI09 CPA ARR JMP AI08 DO NOT RE-TYPE DUMMY ARRAY CPA SUB JMP AI08 DO NOT RE-TYPE DUMMY SUBPROG LDA F.AT CPA REL F.AT=REL? JMP AI08 YES LDA F.IDI SSA JMP AI08 TEMP CELL JMP AI01 TAG ITEM AS 'SUB' IF F.TC=( SPC 1 AI13 LDA F.DCF DIM,COM,EQV FLAG SET? SZA,RSS JSB TS.F NO. TAG SUBPROGRAM JMP AI08 SKP * DATA WITH OFFSET COMPARE. * AI100 DLD F.A,I (B) = F.AF LDA F.A,I AND B170K (A) = F.IM CPB F.AF BOTH MUST MATCH. RSS JMP AI02 NO. CPA F.IM JMP AI10 YES. THAT'S IT. GO FA.F & EXIT. JMP AI02 NO. * * CONSTANTS COMPARE. * AI200 LDA F.A,I F.IM MUST MATCH. AND B170K CPA F.IM RSS JMP AI02 NO. * LDB F.D0+1 (# WDS, IN CASE NOT CHAR) CPA CHAR CHARACTER ? RSS (YES) JMP AI202 NO. NORMAL. * DLD F.A,I (B) = EXTENSION ADDR. DLD B,I (B) = LENGTH. CPB F.CSL SAME AS WE'RE LOOKING FOR ? RSS (YES) JMP AI02 NO. MISMATCH. * INB YES. ROUND UP TO WORD COUNT. CLE,ERB (B) = # WORDS TO MATCH. AI202 CMB,INB NEGATE LENGTH. STB T1AI LOOP COUNTER. LDA F.A T2AI = S.T. ADDRESS. ADA K2 STA T2AI LDB F.DID (B) = F.IDI ADDRESS. * AI201 LDA T2AI,I S.T. WORD. CPA B,I MATCH ? (ALWAYS, FIRST TIME) INB,RSS YES. BUMP F.IDI PTR. JMP AI02 NO. ISZ T2AI BUMP S.T. PTR ISZ T1AI COUNT. DONE ? h JMP AI201 NO. JMP AI10 YES. GO FA.F & EXIT. * * 'DEF' COMPARE. * AI300 LDB F.AT NORMAL OR EXT+OFFSET ? CPB BCOMI JMP AI310 E+O, GO DO THAT. * LDA F.A,I NORMAL. F.AT MUST MATCH. AND B7000 CPA F.AT JMP AI10 YES, GO FA.F & EXIT. JMP AI02 NO. * AI310 LDA F.A E+O, OFFSET MUST MATCH. GET OFFSET BASE. ADA K3 LDA A,I CPA F.IDI+1 MATCH ? JMP AI10 YES, GO FA.F & EXIT. JMP AI02 NO. SKP * BUILD A BCOMI OR DIM ENTRY, UNLINKED. * AI50 INA,SZA,RSS OR MAYBE TWPE ? JMP AI52 YES. * CLA DIM/BCOMI. F.IU = 0. STA F.IU CLA,INA F.NT=1 STA F.NT LDB F.AT. WHICH IS IT ? CPB BCOMI JMP AI51 BCOMI. * LDA F.ND DIM. SET F.IM = # DIM. RAR,RAR RAR,RAR IOR F.VDM ALSO F.VDM, WHILE WE'RE AT IT. IOR F.DIS AND F.DIS STA F.IM LDB F.ND NOW SET UP TOTAL # BOUNDS, BLS TWO PER DIMENSION. STB T1AI T1AI = NUMBER OF WORDS TO COPY. ADB K3 ALLOW 3 MORE. JSB AST.F ALLOCATE THE SPACE. STB F.A F.A = TABLE ADDR. STB F.AF SET F.AF = F.A ADB K3 (B) = FWA DIMENSIONS. LDA F.DID (A) = SOURCE. JSB .MVW DEF T1AI NOP JMP AI53 GO SET F.AT=DIM, PACK & EXIT. * AI51 LDA F.EM BCOMI. F.IM=0, BUT SET F.EM STA F.IM LDB K3 NORMALLY USE 3 WORDS, SZA BUT IF EMA, INB USE 4. JSB AST.F STB F.A F.A = A.T. ADDR, STB F.AF SET F.AF = F.A, AI53 LDA F.AT. SET F.AT TO DIM/BCOMI, JMP AI14 PACK FIELDS & EXIT. * * BUILD A TWPE ENTRY, UNLINKED. * AI52 LDB K2 ALLOCATE TWO WORDS. JSB AST.F STB F.A SET F.A = TABLE ADDR. STB F.AF SET F.AF=F.A JMP AI15 GO FINISH UP. * * NAMED SYMBOL INSERT. * AI050 LDA F.SFA NOT IN A STATEMENT FUNCTION SZA OR, ISZ T3AI ON SECOND PART OF STMT FCT SEARCH ? JMP AI052 YES. INSERT NORMALLY. * SSA DEFINING THE FORMALS ? JMP AI4A YES. GO LOOK IN FORMALS LIST NOW. * CLA NO. WASN'T FORMAL, MUST BE NORMAL VAR, JMP AI04 SO GO SEARCH THEM. * AI052 LDB F.NWN COMPUTE SYMBOL LENGTH IN WORDS + 3 ADB K3 JMP AI12 GO ALLOCATE, LINK, COPY SYMBOL & PACK FIELDS. * * INSERT CONSTANT. * AI250 LDB F.D0+1 # WDS IN CONSTANT. LDA F.IM CHARACTER ? CPA CHAR RSS (YES) JMP AI252 NO. (B) = LENGTH. * LDB F.CSL YES. COMPUTE WORD LENGTH. INB CLE,ERB LDA B IS IT MORE THAT 10 WORDS ? ADA KM11 SSA,RSS CLB YES. NOT KEPT WITH TABLE ENTRY. AI252 ADB K3 + 3 MORE. JMP AI12 STANDARD STUFF. * * INSERT DEF OR DATA WITH OFFSET. * AI150 EQU * AI350 LDB K4 JUST STANDARD WITH 4 WORDS. LDA F.AT EXCEPT: DEF TO EXTERNAL WITH OFFSET. CPA BCOMI INB WHICH IS 5 WORDS. SKP * ALLOCATE SPACE AND INSERT AT END OF LIST. * (MOVED TO BEGINNING LATER.) * AI12 STB T1AI T1AI = # WORDS ALLOCATED. JSB AST.F ALLOCATE (B) WORDS. STB F.A SET LINK OF LAST ENTRY TO POINT HERE. INB (HASN'T BEEN BUMPED YET) STB T0AI,I SET PREVIOUS LINK. CLB SET NEW LINK TO ZERO. STB F.A,I ISZ F.A (MOVE PAST LINK) * * SET UP F.AF & COPY F.IDI INTO NEW ENTRY. * LDA F.IU IF F.IU = SUB, LDB F.A CPA SUB CLB SET F.AF=0 ST{B F.AF ELSE SET F.AF = F.A * LDA T1AI LENGTH IS T1AI-3 ADA KM3 STA T1AI LDB K2 TO WORD 2 OF A.T. ENTRY. ADB F.A LDA F.DID FROM F.IDI JSB .MVW DO IT. DEF T1AI NOP * * IF CHARACTER STRING, BUILD EXTENSION. * LDA F.IM WELL ? CPA CHAR RSS (YES) JMP AI15 NO. * LDB K3 YES. 3-WORD EXTENSION. JSB AST.F STB F.AF LINKED THRU F.AF CLA 1ST WD = 0 (ADDR DESCRIPTOR). STA B,I INB LDA F.CSL 2ND WD = F.CSL, LENGTH. STA B,I INB CLA 3RD WD = 0 (BYTE ADDR OF DATA). STA B,I * * SET UP F.AT, PACK FIELDS, AND EXIT. * AI15 LDA STRAB (NORMAL F.AT=STRAB) * AI14 STA F.AT ADDRESS TYPE IOR F.IM ITEM MODE IOR F.IU ITEM USAGE IOR F.NT NAME TAG LDB F.AF (A,B) = WORDS 0,1 DST F.A,I PUT 'EM AWAY. * LDA F.NT NAMED ? SZA,RSS JMP AI06 YES, MUST DETERMINE USAGE. JMP AI08 NO. ALL DONE. SKP * DONE WITH SYMBOL. IF IT'S A SEARCHABLE TYPE AND * NOT A STATEMENT FUNCTION FORMAL, MOVE TO START. * AI10 JSB FA.F FETCH ASSIGNS IF NOT ALREADY. AI08 LDA F.STY TYPE. (B<0 IF NOT SEARCHABLE) LDB T4AI HEAD OF LAST LIST SEARCHED. SZA,RSS IF SYMBOL WAS NAMED, CPB DSTH BUT NOT SEARCHING NAMED LIST, SSA OR NOT A SEARCHABLE TYPE, JMP AI11 THEN DON'T MOVE TO START. * CCB NOW GET CURRENT ITEM'S LINK. ADB F.A STB T1AI (SAVE IT'S ADDR) LDB B,I SET PREV LINK TO CURRENT, STB T0AI,I WHICH DELETES CURRENT ITEM. CCB COMPUTE ADDR OF LIST HEAD. ADB T4AI IN B. LDA B,I GET HEAD OF THIS LIST. STA T1AI(,I SET INTO CURRENT LINK. LDA F.A SET HEAD TO POINT TO THIS ITEM. STA B,I * AI11 CLB ZAP: STB F.NTF NO TAG FLAG. STB F.AT. SPECIAL DIM/BCOMI FLAG. STB F.LCF LABELLED COMMON FLAG. LDA F.IM (A) = F.IM JMP AI.F,I EXIT. * F.NTF NOP NON ZERO IF NOT TO BE TAGGED AS NAME K4 DEC 4 B50 OCT 50 K3 DEC 3 B40 OCT 40 K32 EQU B40 KM11 DEC -11 T1AI BSS 1 TEMP CELL F.EXF NOP ENT FLAG F.DCF NOP DIM,COM FLAG B15.7 OCT 100200 BITS 15 & 7 SKP * ALLOCATE SYMBOL TABLE SPACE. * ALLOCATE (B) WORDS, RETURN (B)=START. * AST.F NOP STB T1AST SAVE SIZE. CMB ALSO -1-SIZE. STB T2AST LDA F.LO SET UP ADDR OF BLOCK. STA T0AST ADA T1AST MOVE END OF A.T. OUT. STA F.LO NEW END OF A.T. = STA F.S2B NEW FWA OF STACK 2. LDA F.S2T OLD LWA OF STACK 2 ADA T1AST + SIZE OF BLOCK = STA F.S2T NEW LWA OF STACK 2. * * CHECK FOR MEM OFL. * LDA F.S1T LWA FREE SPACE = FWA OF STACK 1, LDB F.SPF UNLESS: SPECIFICATION LEVEL ? SZB I.E., F.SPF=0 CPB K1 OR 1 ? LDA F.E YES, LWA FREE SPACE = FWA EQUIV TBL. CMA,INA ADA F.S2T (LWA STACK 2) - (LWA FREE SPACE) SSA,RSS COLLISION ? JMP F.OFE YES, DATA POOL OVERFLOW. * * MOVE STACK 2 UP IN MEMORY. * LDA F.S2T START WITH NEW LWA+1 OF STACK 2. INA (AS IF JUST STORED THERE) AST01 ADA T2AST -1-SIZE BACKS UP TO NEXT ITEM. LDB A,I GET DATA FROM OLD ADDR. ADA T1AST + SIZE = NEW ADDR IN STACK 2. STB A,I PUT IT THERE. CPA F.S2B DID WE JUST MOVE 1ST WD OF STACK 2 ? RSS YES. THEN WE'RE DONE. JMP AST01 NO. GO MOVE ANOT"UHER. * LDB T0AST (B)=FWA OF ALLOCATED SPACE. JMP AST.F,I EXIT. * T0AST NOP FWA OF ALLOCATED BLOCK. T1AST NOP SIZE OF BLOCK. T2AST NOP -SIZE-1 OF BLOCK. SKP * ******************************** * * (B)=NO. OF WORDS PER ELEMENT * * ******************************** SPC 1 NWE.F NOP LDB F.IM ITEM MODE. BLF ALIGN. ADB DNWPE GET FROM TABLE. LDB B,I JMP NWE.F,I * DNWPE DEF *+1 WORDS/ELEMENT TABLE, BY ITEM MODE. DEC 0 NONE: 0 DEC 1 INTEGER: 1 DEC 2 REAL: 2 DEC 1 LOGICAL: 1 DEC 1 TWPE: 1 DEC 4 COMPLEX: 4 DEC 3 EXTENDED: 3 DEC 1 ADDRESS: 1 DEC 2 DOUBLE INTEGER: 2 DEC 2 DOUBLE LOGICAL: 2 DEC 4 DOUBLE PRECISION: 4 DEC -1 CHARACTER: SPECIAL DEC 8 DOUBLE COMPLEX: 8 SKP * **************************************** * * GET FIRST ASSIGNMENT POINTER (NAMES) * * **************************************** SPC 1 * EXIT: AFTER THE NEXT GNA.F CALL, (F.A) WILL POINT TO THE * FIRST A.T. NAME ENTRY (OR ZERO IF NONE). SPC 1 GFA.F NOP LDA DSTH JUST SET F.A = DUMMY HEAD OF LIST. STA F.A JMP GFA.F,I EXIT SPC 3 * ******************************************** * * GET FIRST ASSIGNMENT POINTER (CONSTANTS) * * ******************************************** SPC 1 GFC.F NOP LDA DSTH JUST SET F.A = DUMMY HEAD OF LIST. ADA K2 STA F.A JMP GFC.F,I EXIT SPC 3 * **************************************** * * GET FIRST ASSIGNMENT POINTER (DEF'S) * * **************************************** SPC 1 GFD.F NOP LDA DSTH JUST SET F.A = Dp/UMMY HEAD OF LIST. ADA K3 STA F.A JMP GFD.F,I EXIT SPC 3 * ******************************* * * GET NEXT ASSIGNMEXT POINTER * * ******************************* SPC 1 * ENTRY: F.A=CURRENT POINTER TO ASSIGNMENT TABLE ENTRY * EXIT : (A)=F.A=POINTER TO NEXT ENTRY IN THE ASSIGNMENT TABLE * (A)=0 MEANS END REACHED. SPC 1 GNA.F NOP CCA BACK UP TO POINTER. ADA F.A LDA A,I STA F.A AND SET IT'S ADDRESS JMP GNA.F,I SKP * ******************* * * DEFINE LOCATION * * ******************* SPC 1 * DEFINE: AF(F.A)=RPL (PRESENT LOCATION COUNTER) * F.AT(F.A)=REL SPC 1 DL.F NOP LDA REL JSB DAT.F DEFINE AT LDA F.RPL JSB DAF.F DEFINE F.AF JMP DL.F,I SPC 1 * ************** * * FETCH F.ID * * ************** SPC 1 * COPY NAME FROM TABLE ENTRY TO NID IN A1 FORMAT. * FID.F NOP JSB BNI.F CLEAR NID TO BLANKS LDA F.A,I NAMED ? SLA JMP FID.F,I NO. NO ID FIELD. LDA F.DNI LOC. OF 1ST WD OF NID BUFFER STA T1FID LDB F.A ADB K2 FID02 LDA B,I ALF,ALF AND B177 STA T1FID,I STORE 1ST CHAR INTO NID BUFFER ISZ T1FID BUMP NID BUFFER LOC BY 1 LDA B,I AND B177 STA T1FID,I STORE 2ND CHAR INTO NID BUFFER ISZ T1FID BUMP NID BUFFER LOC LDA B,I END BIT SET ? INB BUMP ID FIELD LOC AND B15.7 (IF ZERO, QUIT) SZA,RSS WELL ? JMP FID02 MORE TO DO. JMP FID.F,I DONE. * T1FID BSS 1 NID BUFFER POINTER SPC 1 B177 OCT 177 VAR OCT 400 IU=2 SKP * ******************** * * COPY SYMBOL NAME * * ******************** SPC 1 * ENTRY: JSB NAM.F (FS.A SET UP) * DEF * EXIT: 3 WORDS COPIED. SPC 1 NAM.F NOP JSB FID.F COPY FROM A.T. ENTRY TO NID BUFFER. JSB NTI.F PACK IT. LDB NAM.F GET & RESOLVE ADDRESS. ISZ NAM.F LDB B,I RBL,CLE,SLB,ERB JMP *-2 LDA F.DID SOURCE ADDR. JSB .MVW MOVE 3 WORDS. DEF K3 NOP JMP NAM.F,I EXIT. SKP * ****************** * * TAG SUBPROGRAM * * ****************** SPC 1 TS.F NOP LDA F.IU ALREADY TAGGED 'VAR' ? CPA VAR RSS (YES) JMP TS01 NO. * LDB F.AT YES. IS IT A FORMAL PARAM ? CPB DUM JMP TS03 YES. LEAVE ALONE. (ELSE ERROR) * TS01 CPA SUB OTHERWISE, MUST BE UNUSED OR SUB. RSS JSB NUTST NO USAGE TEST * TS03 LDA SUB JSB DIU.F DEFINE F.IU AS SUBPROG LDA F.AT CPA DUM JMP TS02 IT IS DUMMY * JSB FA.F FETCH ASSIGN LDA F.AT CPA REL JMP TS.F,I EXIT, SUB ALREADY DEFINED * CLA ELSE CLEAR THE F.AF FIELD SO THAT LDB F.A CAN TELL IT'S EXTERNAL SUB, NOT REF'D. INB STA B,I AF(F.A)=0 JMP TS.F,I * TS02 LDA K22 FORMAL PARAM USED AS SUB: LDB F.SFD IS IT A STMT FCT FORMAL ? SZB JSB WAR.F YES, DUMMY ARG SUBSCRIPTED IN ASF JMP TS.F,I * TSE22 LDA K22 JSB ER.F VARIABLE RENAMED AS SUBROUTINE SPC 2 K22 DEC 22 K47 DEC 47 B600 OCT 600 ARR EQU B600 B170K OCT 170000 (FOR F.IM) F.SFD NOP #0 IFF CURRENT ITEM IS STMT FCT FORMAL. SKP SPC 2 * *********** * * F.TC TEST * * *********** SPC 1 * ENTRY: (A)=CORRECT TERMINATING CHAR. SPC 1 TCT.F NOP CPA F.TC JMP TCT.F,I F.TC=(A),EXIT LDA K28 JSB ER.F IMPROPER TERMINATING CHARACTER SPC 2 * ********************* * * NON-CONSTANT TEST * * ********************* SPC 1 NCT.F NOP LDA F.NT SZA,RSS JMP NCT.F,I EXIT, ITEM NOT A CONSTANT LDA K24 JSB ER.F CONSTANT MUST NOT BE PRESENT SPC 2 * ********************** * * CHECK FOR CONSTANT * * ********************** SPC 1 * INPUT: (B)=F.A TO BE CHECKED. * OUTPUT: SKIP IF CONSTANT, AND: (B)=ADDR CONSTANT * (A)=FIRST WORD SPC 1 CFC.F NOP SZB IN REGISTER ? CPB K1 JMP CFC.F,I YES, NOT CONSTANT. LDA B,I F.NT & F.IM SLA,RSS NAMED ? JMP CFC.F,I YES, NOT CONSTANT. AND B170K F.IM SZA,RSS TYPED ? JMP CFC.F,I NO, NOT CONSTANT. LDA B,I GET F.IU AND B600 CPA ARR ARRAY ? JMP CFC.F,I YES, NOT CONSTANT. (DATA WITH OFFSET) ISZ CFC.F ELSE CONSTANT. ADB K2 IF CONST, ITS ADDR. LDA B,I IF CONST, ITS FIRST WORD. JMP CFC.F,I SKP * *********************** * * NON-SUBROUTINE TEST * * *********************** SPC 1 NST.F NOP LDA K25 LDB F.IU CPB SUB JSB ER.F SUBPROGRAM NAME NOT ALLOWED JMP NST.F,I EXIT SPC 2 * **************** * * NON-EMA TEST * * **************** SPC 1 NET.F NOP LDB F.EM LDA K47 SZB WELL ? JSB ER.F EMA: ERROR 47. JMP NET.F,I ELSE DONE. SPC 2 * **************** * * INTEGER TEST * * **************** SPC 1 ITS.F NOP LDA F.IM F.IM=INTEGER? CPA INT RSS YES, O.K. CPA DBI OR DOUBLE INTEGER ? JMP ITS.F,I YES, ALSO O.K. EXIT. * LDA K26 NO JSB ER.F { ITEM NOT AN INTEGER * DBI OCT 100000 SPC 2 * ***************** * * NO USAGE TEST * * ***************** SPC 1 NUTST NOP LDA F.IU IS ITEM NAME ALREADY USED? SZA,RSS JMP NUTST,I NO, EXIT LDA K22 YES, NAME ALREADY BEING USED JSB ER.F SPC 2 INT OCT 10000 IM=1 INTEGER K24 DEC 24 K25 DEC 25 K26 DEC 26 K28 DEC 28 SPC 2 * **************** * * TAG VARIABLE * * **************** SPC 1 TV.F NOP LDA F.IU CPA VAR RSS JSB NUTST NO USAGE TEST LDA VAR JSB DIU.F DEFINE F.IU JMP TV.F,I SPC 2 * ************* * * DEFINE F.IM * * ************* SPC 1 * ENTRY: (A)=NEW ITEM MODE SPC 1 DIM.F NOP STA F.IM F.IM=(A) LDA F.A,I AND KK15 =B007777 IOR F.IM STA F.A,I IM(F.A)=F.IM JMP DIM.F,I SPC 2 * ********************** * * ESTABLISH CONSTANT * * ********************** SPC 1 * INPUT: (A)=MODE OF ITEM SPC 1 ESC.F NOP STA F.IM CLA,INA STA F.NT F.NT=1 FOR CONSTANT LDA VAR STA F.IU SET F.IU=VAR JMP ESC.F,I EXIT SPC 2 * ****************************** * * ESTABLISH INTEGER CONSTANT * * ****************************** SPC 1 * INPUT: (A)=CONSTANT. * OUTPUT: (A)=F.A OF CONSTANT. SPC 1 EIC.F NOP STA F.IDI VALUE. LDA INT ESTABLISH IT. JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A RETURN (A)=F.A JMP EIC.F,I SPC 2 * ************************************* * * ESTABLISH DOUBLE INTEGER CONSTANT * * ************************************* SPC 1 * INPUT: (A,B)=CONSTANT. * OUTPUT: (A)=F.A OF CONSTANT. SPC ;1 EJC.F NOP DST F.IDI VALUE. LDA DBI ESTABLISH IT. JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A RETURN (A)=F.A JMP EJC.F,I SKP * **************** * ESTABLISH DEF * * **************** * * THIS ROUTINE ESTABLISHES A 3 OR 4 WORD ASSIGNMENT TABEL ENTRY * WHICH IF REFERENCED WILL CAUSE A DEF TO BE GENERATED -- * EITHER ALONG THE WAY OR AT THE END OF THE CODE GENERATION. * * CALLING SEQUENCE: * * LDA OFFSET (ONLY ZERO ALLOWED IF ENTRY IS UNDEFINED) * LDB F.A POINTER TO ASSIGNMENT TABEL ENTRY TO BE DEFED * JSB ESD.F * RETURN A=0 * ESD.F NOP STA T1ESD SAVE THE OFFSET STB F.A AND THE A.T. ADDR. JSB FA.F FETCH THE ASSIGNS. LDA F.AT GET LOCATION INFO LDB F.AF ADDRESS TO B CPA BCOM LABELED COMMON REFERENCE? JMP ESD02 YES DO SPECIAL * ADB T1ESD ADD THE OFFSET CPB F.AF IF OFFSET IS ZERO JMP ESD03 THEN USE A POINTER INSTEAD. * ADB K8 SEE IF TOO NEGATIVE FOR SIMPLE. SSB,RSS JMP ESD04 NO. USE SIMPLE DEF. * LDA T1ESD YES. DATA WITH OFFSET: (A)=OFFSET, LDB F.A (B)=BASE F.A JSB EDO.F WHICH CAN TAKE A FULL-WORD OFFSET. ESD03 LDB F.A AT THIS POINT, OFFSET = 0. ADB KK01 SO GENERATE A S.T. REF. RSS ESD04 ADB KM8 DIRECT REF, RESTORE ADDRESS. LDA F.AT CHECK ADDR TYPE: CPA COM IF IN COMMON RSS LDA STRAB USE COM ELSE USE STR-ABS FOR AT STB F.IDI SET VALUE NEEDED * ESD01 STA F.AT SET UP F.AT FOR SEARCH, STA T1ESD AND SAVE FOR LATER (AI.F CHANGES IT) CLA ESTABLISH CONSTANT JSB ESC.F NT=0 IM=0 IU=VAR JSB AI.F ASSIGN ITEM LDA T1ESD RESTORE F.AT JSB DAT.F CLA CLEAR A AND JMP ESD.F,I RETURN * ESD02 LDB F.A IN LABELLED COMMON, LDA T1ESD CAN TRY TO REMOVE DATA WITH OFFSET. JSB CDO.F STA T1ESD OLD OR REVISED OFFSET. LDB F.AF F.A OF BCOMI ENTRY. INB DLD B,I GET THE OFFSET AND F.A OF ADA T1ESD THE MASTER ADD THE OFFSET DST F.IDI STOR FOR THE NEW ID LDA BCOMI SET REQUIRED F.AT JMP ESD01 GO FINISH * T1ESD NOP COM OCT 4000 F.AT=COM BCOM OCT 3000 STRAB OCT 2000 KM8 DEC -8 SKP * ****************************** * * ESTABLISH DATA WITH OFFSET * * ****************************** SPC 1 * ENTRY: AS ESD.F, AND F.IM = TYPE OF NEW ITEM. * EDO.F NOP STA T1EDO SAVE OFFSET, WHILE LDA F.IM SAVE TYPE OF RESULT. STA T2EDO LDA T1EDO RESTORE OFFSET, JSB CDO.F AND RESOLVE DATA WITH OFFSET. STB T1EDO T1EDO=F.A=F.A OF MASTER. * LDB T2EDO F.IM OF NEW. IF TYPES MATCH, CPB F.IM SZA AND THE OFFSET IS ZERO, RSS (NO) JMP EDO.F,I THEN USE THE MASTER ITSELF. * STA F.IDI ELSE CREATE NEW. F.IDI=OFFSET, STB F.IM F.IM=TYPE, CLA,INA F.NT=1 STA F.NT LDA ARR F.IU=ARR STA F.IU CLA SET F.AT=0 (JUST IN CASE) STA F.AT LDA T1EDO F.AF = F.A OF MASTER. (FOR COMPARE) STA F.AF JSB AI.F ENTER. LDA T1EDO,I EXTRACT F.AT OF MASTER. AND B7000 JSB DAT.F AND SET THAT FOR NEW ENTRY. LDB F.A SET F.AF TO F.A OF MASTER. INB LDA T1EDO STA B,I JMP EDO.F,I EXIT. SPC 1 T1EDO NOP T2EDO NOP SKP * **************************** * * RESOLVE DATA WITH OFFSET * * **************************** SPC 1 * ENTRY: (A) = ADDITIONAL OFFSET. * (B) = F.A, PODSSIBLY DATA WITH OFFSET. * * EXIT: (A) = TOTAL OFFSET. * (B) = F.A = NON-OFFSET F.A * AND ASSIGNS OF (B) FETCHED. * CDO.F NOP STB F.A SET UP F.A, STA T1CDO AND REMEMBER OFFSET. JSB FA.F FETCH ASSIGNS. JSB STY.F IS THE MASTER A DATA WITH OFFSET ? CPA K1 RSS JMP CDO01 NO. * ISZ F.A YES. FETCH: DLD F.A,I THE F.A OF THE MASTER & THE OFFSET. STA F.A REPLACE ITEM WITH THE MASTER. ADB T1CDO ADD OFFSET TO INPUT OFFSET. STB T1CDO JSB FA.F FETCH ITS ASSIGNS FOR BELOW. CDO01 LDA T1CDO RETURN (A) = TOTAL OFFSET, LDB F.A (B) = F.A JMP CDO.F,I EXIT. * T1CDO NOP OFFSET. SKP * ************* * * DEFINE F.IU * * ************* SPC 1 * ENTRY: (A)=NEW F.IU (SUBR, VAR, OR 0) SPC 1 DIU.F NOP STA F.IU F.IU=(A) LDA F.A,I AND KK16 =B177177 IOR F.IU STA F.A,I IU(F.A)=F.IU JMP DIU.F,I * KK15 OCT 007777 KK16 OCT 177177 KK17 OCT 170777 SPC 2 * ************* * * DEFINE F.AT * * ************* SPC 1 * ENTRY: (A)=NEW AT(F.A) SPC 1 DAT.F NOP STA F.AT F.AT=(A) LDA F.A,I AND KK17 =B170777 IOR F.AT STA F.A,I JMP DAT.F,I SPC 2 * ***************** * * DEFINE F.EM=1 * * ***************** SPC 1 DEM.F NOP LDA K2 JUST SET IT. STA F.EM IOR F.A,I STA F.A,I JMP DEM.F,I EXIT. SPC 2 * **************** * * DEFINE F.S=1 * * **************** SPC 1 DS.F NOP LDA K4 JUST SET IT. STA F.S IOR F.A,I STA F.A,I JMP DS.F,I EXIT. SKP * ************* * * DEFINE AF * * ************* g/ SPC 1 * ENTRY: (A)=NEW F.AF SPC 1 DAF.F NOP STA F.AF F.AF=(A) LDB F.A LDA B,I AND B600 GET F.IU FIELD CPA ARR JSB DAF.G IU(F.A)=ARR LDA F.A,I TEST IF LABELED COMMON AND B7000 CPA BCOM WELL? JSB DAF.G YES INDEX TO THE INFO ENTRY LDA F.IM IF CHARACTER, CPA CHAR JSB DAF.G ALSO GO TO NEXT ENTRY, CPA CHAR RSS BUT USE FIRST WORD. INB POINT TO 2ND WD OF THIS ENTRY. LDA F.AF GET THE VALUE STA B,I STORE IT JMP DAF.F,I RETURN SPC 1 DAF.G NOP INB LDB B,I (B)=GF(F.A) JMP DAF.G,I SPC 2 * ************************** * * CHECK STATEMENT NUMBER * * ************************** SPC 1 CSN.F NOP AND B40 BIT 5 = TYPE BIT. XOR B,I SET TYPE BIT OR CHECK IT. ALF,ALF CHECK DEFINED FLAG. CCE (SET DEFINE BIT) RAL,ELA E = DEFINE BIT. ALF,RAL RESTORE POSITION. RAL SEZ,RSS WAS IT DEFINED ? STA B,I NO. SET TYPE & DEFINE BIT. AND B40 GET TYPE DIFFERENCE (IF WAS DEF) SEZ IF NEW DEFINITION SZA,RSS OR OLD BUT SAME TYPE JMP CSN.F,I THEN O.K., SO EXIT. LDA K32 ELSE ERROR 32. JSB ER.F SKP * ****************** * * FETCH CONSTANT * * ****************** SPC 1 FC.F NOP JSB CDI.F CLEAR F.IDI BUFFER TO 0 JSB NWE.F (B) = # WDS IN CONSTANT. STB T1FC LDA F.A FROM A.T. ENTRY WORD 2 ADA K2 LDB F.DID TO F.IDI JSB .MVW DEF T1FC NOP JMP FC.F,I EXIT. * T1FC NOP # WORDS TO MOVE. SKP * ************************************ * * F.D0 := NUMBER OF WORDS FOR ITEM * * ************************s************ SPC 1 * AT THIS POINT, RCO.F MUST HAVE BEEN CALLED. IT HAS CHANGED * THE UPPER BOUNDS INTO THE DIMENSION SIZES (FOR NON-FORMAL ARRAYS). * NWI.F NOP LDA F.IU CPA ARR RSS JMP NWI.F,I * LDA F.ND SET UP COUNTER. CMA,INA STA T1NWI LDA F.LUB SET UP POINTER INTO BOUNDS TABLE. STA T2NWI * * LOOP THRU BOUNDS TABLE; FOR EACH DIMENSION, * MULTIPLY F.D0 BY THE SIZE (2-WORD COMPUTATION). * NWI01 ISZ T2NWI SKIP LOWER BOUND. LDB T2NWI,I GET UPPER BOUND. ISZ T2NWI (SKIP IT) JSB GCD.F JMP RPLOV SOMEONE GOOFED! * SSA DID SOMETHING GO WRONG ? JMP RPLOV YES. * JSB DMP.F MULTIPLY & REPLACE RUNNING PRODUCT. DEF F.D0 JMP RPLOV OFL. * DST F.D0 ISZ T1NWI INCR LOOP COUNTER. MORE ? JMP NWI01 YES. DO IT. JMP NWI.F,I NO. ALL DONE. (A,B) = PRODUCT. SKP RPLOV LDA K84 OFL IN SIZE CALC. CATASTROPHE! JMP F.ABT * T1NWI NOP LOOP COUNTER. T2NWI NOP BOUNDS TABLE POINTER. K84 DEC 84 SKP * ************************** * * GET CONSTANT DIMENSION * * ************************** SPC 1 * ENTRY: (B) = F.A OF CONSTANT. (MUST BE INT*2 OR INT*4) * EXIT: (A,B) = DOUBLE INTEGER VALUE OF CONSTANT. * RETURNS TO (P+1) IF NOT CONSTANT. (A,B) GARBAGE. * (P+2) IF CONSTANT. * GCD.F NOP STB T1GCD SAVE F.A IN QUESTION. JSB CFC.F CONSTANT ? JMP GCD.F,I NO. FORGET IT. * ISZ GCD.F YES. BUMP RETURN. LDB T1GCD RESTORE F.A LDA B,I (A) = 1ST WD A.T. ENTRY: ELA E=1 IFF INT*4 . ADB K2 GET CONSTANT. DLD B,I IF INT*4, THAT'S ALL. SEZ WELL ? JMP GCD.F,I YES. DONE. * LDB A !. INT*2. CONVERT IT. ASR 16 SWP JMP GCD.F,I DONE. * T1GCD NOP SKP * ********************************* * * DOUBLE INTEGER ADD (INTERNAL) * * ********************************* SPC 1 * CALLING SEQUENCE: DLD * JSB DAD.F * DEF * --> OVERFLOW OCCURED. (A,B)=LEAST 32 BITS. * --> NO OVERFLOW. (A,B)=SUM. * DAD.F NOP DST T1DAD SAVE ARG1. LDA DAD.F,I GET ARG2. ISZ DAD.F DLD A,I CLE ADD LOWERS. ADB T1DAD+1 CLO PROPOGATE CARRY. DON'T WORRY ABOUT SEZ THE CASE: ARG2U=32767, CARRY, AND INA ARG1U<0, EVEN THOUGH IT'S A SPURIOUS ADA T1DAD (ADD UPPERS) OVERFLOW. SOS OVERFLOW ? ISZ DAD.F NO. NORMAL RETURN. JMP DAD.F,I EXIT. * T0DAD BSS 1 T1DAD BSS 2 ARG1. T2DAD BSS 2 ARG2. SPC 2 * ************************************** * * DOUBLE INTEGER SUBTRACT (INTERNAL) * * ************************************** SPC 1 DSB.F NOP STA T1DAD SAVE (A) WHILE... LDA DSB.F,I GET ARG2 ADDR. ISZ DSB.F STA DSB01 & PUT IN DAD.F CALL. LDA T1DAD RESTORE (A), CMA COMPLEMENT (A,B), CMB JSB DAD.F SUBTRACT ARG2, DSB01 DEF *-* JMP DSB.F,I (IF OFL) * CMA AND COMPLEMENT AGAIN. CMB ISZ DSB.F TAKE GOOD RETURN. JMP DSB.F,I SKP * ************************************** * * DOUBLE INTEGER MULTIPLY (INTERNAL) * * ************************************** SPC 1 * CALLING SEQUENCE: DLD * JSB DMP.F * DEF * --> OVERFLOW. (A,B)=LEAST 32 BITS. *  --> NO OVERFLOW. (A,B)=RESULT. * * NOTE: IF EITHER ARGUMENT IS NEGATIVE, OVERFLOW WILL BE * SET, BUT THE RESULT WILL BE THE CORRECT LEAST 32 BITS. * * ALGORITHMIC NOTE: SINCE OVERFLOW IS EXPLICITLY SET WHEN EITHER * OF THE ARGUMENTS IS NEGATIVE, THE CROSS-PRODUCTS CAN BE TAKEN * WITHOUT SIGN CORRECTION: IN XU*YL: * XU<0: OFL ALREADY SET. * XU=0: RESULT ZERO ANYWAY. * XU>0, YL<0: SIGNIFICANT BITS OCCUR IN THE UPPER WORD OF THE * CROSS-PRODUCT, BUT WILL BE CAUGHT BY THE FACT * THAT THE CROSS-PRODUCT IS NEGATIVE. * OF COURSE, THE UPPER WORD OF THE CROSS-PRODUCT IS ONLY NEEDED * TO DETECT OVERFLOW ANYWAY, AND SIGN CORRECTION AFFECT ONLY THE * UPPER WORD. * DMP.F NOP DST T1DAD SAVE ARG1. CLB INITIALIZE OVERFLOW FLAG: RRL 1 (B) = 1 IF ARG1<0, ELSE 0. STB T0DAD LDA DMP.F,I GET ARG2. ISZ DMP.F DLD A,I STB T2DAD+1 (DON'T NEED ARG2U AGAIN) SSA IF ARG2<0, ISZ T0DAD SET THE OVERFLOW FLAG. LDB T1DAD ARE BOTH UPPER WORDS NONZERO ? SZA SZB,RSS RSS NO. THEIR PRODUCT IS ZERO. ISZ T0DAD YES. RESULT UNCHANGED, BUT OFL. * MPY T1DAD+1 YU*XL SZB,RSS TOO BIG ? SSA ISZ T0DAD YES. SET OFL. STA T2DAD SAVE LSB (FIRST CROSS-PRODUCT) * LDA T2DAD+1 DO YL*XU MPY T1DAD SZB,RSS TOO BIG ? SSA ISZ T0DAD YES, SET OFL. ADA T2DAD ADD FIRST CROSS-PRODUCT. SSA IF TOO BIG, ISZ T0DAD SET OFL. STA T2DAD SAVE SUM OF CROSS-PRODUCTS. * LDA T2DAD+1 DO YL*XL. MPY T1DAD+1 STA T1DAD SAVE LOWER PART. LDA T2DAD+1 CORRECT FOR XL<15>. SSA ADB T1DAD+1 LDA T1DAD+1 CORRECT FOR YL<15>. SSA ADB T2DAD+1 SSpcB TOO BIG ? ISZ T0DAD IF SO, SET OFL. * ADB T2DAD ADD CROSS-PRODUCTS. SSB IF TOO BIG, ISZ T0DAD SET OFL. LDA T0DAD IF OFL NEVER OCCURED, SZA,RSS ISZ DMP.F SKIP ERROR RETURN. LDA B (A) = UPPER RESULT. LDB T1DAD (B) = LOWER RESULT. JMP DMP.F,I EXIT. END ASMB,Q,C HED GLOBALS & INITIALIZATION FOR IC.F NAM IN6.F,8 92834-16002 REV.2030 800226 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE CONTAINS THOSE DATA ITEMS REFERENCED IN IC.F WHICH * MUST BE PRESERVED THROUGHOUT PASS ONE, EVEN THOUGH SEGMENT LOADS * OCCUR. THEY ARE REFERENCED BY OFFSET FROM THE SYMBOL: F.$IC * * SINCE THEY MUST BE INITIALIZED ONLY ONCE PER MODULE, THE * INITIALIZATION ROUTINE IS ALSO LOCATED HERE: IN6.F * ENT F.$IC BASE OF GLOBALS. ENT F.NXN NO INPUT FLAG. ENT F.TC LAST CHARACTER READ. ENT F.NCR NO-CROSS-REFERENCE FLAG. * ENT IN6.F IC.F INITIALIZATION. * * * A EQU 0 B EQU 1 SUP SPC 2 * THE FORMAT OF A CARD BUFFER IS: * * WORDS 0-2: ROOM FOR LINE # FOR LISTING. * 3-43: UP TO 82 CHARACTERS (ROOM TO ADD BLANK AFTER 72) * 44: LENGTH, IN WORDS. * 45: CLIB LINE #. * 46-48: LEFT OVER, NOT CURRENTLY USED. * -------- * j TOTAL: 49 WORDS. SKP * INITIALIZE IC.F * IN6.F NOP STB CRD#1 SET CARD BUFFER POINTER ADB K49 FOR BOTH BUFFERS STB CRD#2 SSA IF CALL JUST TO MOVE THE CARD BUFFERS JMP IN6.1 SKIP UNRELATED GARBAGE * CLB,SEZ,INB,RSS IF A NEW COMPILE JMP NOTNW NO * STB FTNF SET THE FTN FLAG CLA ALSO ITS STA CD#F LENGTH, STA CD#P AND SIZE. STA CD#1 AND CLEAR THE LOCAL CARD BUFFERS STA CD#2 ALSO SET NOTNW CLA CLEAR THE NO. CARDS IN STA FIRST SET FIRST FLAG IN6.1 CLA ENTRY FOR BUFFER MOVE ONLY STA CD# TO ZERO LDB DCD#1 SET UP BUFFER JSB SETCA NO. ONE INCASE SNC.F CALLED FIRST CLA,INA STA LIFCC INITIAL COLUMN COUNTER JMP IN6.F,I RETURN * DCD#1 DEF CRD#1 DEF TO CARD BUFFER ADDRESSES K49 DEC 49 SKP * GLOBALS. * F.$IC EQU * BASE ADDR. GLOBALS REF'D BY OFFSET. * EOSF NOP END-OF-STATEMENT FLAG. FIRST NOP FIRST-CARD FLAG. LINOL NOP ADDR OF (ASCII) LINE # IN CURRENT BUFFER. CBA NOP ADDR OF CARD TEXT IN CURRENT BUFFER. CRD#1 DEF *-* ADDR BUFFER # 1. CD#1 NOP CARD NUMBER (WITHIN STMT) FOR BFR #1. CRD#2 DEF *-* ADDR BUFFER # 2. CD#2 NOP CARD NUMBER (WITHIN STMT) FOR BFR #2. CD# NOP CURRENT CARD NUMBER. DCD# NOP PTR TO CURRENT CARD BUFFER CARD NUMBER. CD#F NOP # CARDS IN CARD FILE. CD#P NOP CURRENT POSITION IN CARD FILE. CICNT NOP ADDR WORD COUNT IN CURRENT BUFFER. MLIN NOP ADDR CLIB LINE NUMBER IN CURRENT BUFFER. LIFCC NOP COL # OF START OF 1ST CARD CURRENT STMT. FTNF NOP FLAG INDICATING FTN DIRECTIVE IN PROCESS. * * GLOBALS REF'D DIRECTLY. * F.NXN NOP NO INPUT FLAG. F.TC NOP  LAST CHARACTER READ. F.NCR NOP NO-CROSS-REFERENCE FLAG. SPC 2 * CARD BUFFER SETUP ROUTINE. * SETCA NOP SET UP BUFFER POINTER ROUTINE STB DCD# SET LOCAL POINTER TO CARD #. ISZ DCD# LDB B,I GET POINTED TO ADDRESS. STB LINOL SAVE THE LINE NUMBER LOCATION IN BUFF. ADB K3 SKIP OVER LINE NUMBER. STB CBA SET CURRENT BUFFER ADDRESS. ADB K41 INDEX TO CARD LENGTH AREA. STB CICNT SET POINT TO IT. INB AND TO THE LINE COUNT. STB MLIN JMP SETCA,I RETURN * K3 DEC 3 K41 DEC 41 * END ASMB,Q,C HED FTN4X - SCRATCH FILE 1 ACCESS. NAM WS1.F,8 92834-16002 REV.2030 800613 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * * ENTRIES IN THIS MODULE. * ENT CRP.F WRITE A CROSS-REFERENCE PAIR. ENT ES1.F WRITE EOF ON SCRATCH FILE 1. ENT IN3.F INITIALIZE MODULE WS1.F ENT RS1.F READ WORD FROM SCRATCH FILE 1. ENT WS1.F WRITE WORD TO SCRATCH FILE 1. * * EXTERNALS IN OTHER MODULES. * EXT F.A A.T. PTR EXT F.ABT FTN4 ABORT JUMP TARGET. EXT F.CCW FTN OPTION WORD. EXT F.DP FWA ASSIGNMENT TABLE. EXT F.LNN CURRENT LINE NUMBER. EXT F.LO LWA+1 A.T. * EXT EJP.F NEW PAGE ON LISTING. EXT PSL.F WRITE LISING LsINE. EXT SKL.F SKIP LINE(S) ON LISING. * * OP SYSTEM INTERFACE. * EXT C.SC1 FCB FOR 1ST PASS FILE. * EXT RED.C CLIB READ PROCESSOR. IFZ EXT RWN.C CLIB REWIND PROCESSOR. (ON IFZ) XIF EXT WRT.C CLIB WRITE PROCESSOR. SPC 2 A EQU 0 B EQU 1 SUP SPC 2 IN3.F NOP INITIALIZATION: CLA JUST SET BUFFER EMPTY, STA COUNT JMP IN3.F,I SKP * **************** * * WRITE A WORD * * **************** SPC 1 WS1.F NOP LDB DBUFR COMPUTE ADDR FOR THIS WORD: ADB COUNT (FWA) + (# WDS BEFORE) STA B,I PUT IT THERE. ISZ COUNT BUMP COUNT. CPB DBUFE FULL ? RSS YES. JMP WS1.F,I NO. DONE. * JSB WRT.C YES. WRITE IT OUT. DEF C.SC1 DEF BUFFR DEF COUNT JMP ERROR (IF ERROR) * CLA NOW SET IT EMPTY. STA COUNT JMP WS1.F,I ALL DONE. SPC 2 * *************** * * READ A WORD * * *************** SPC 1 RS1.F NOP RS1.0 CCB DECREMENT COUNT. ADB COUNT STB COUNT SSB,RSS WAS IT EMPTY ? JMP RS1.1 NO. * JSB RED.C YES. READ ANOTHER RECORD. DEF C.SC1 DEF BUFFR DEF BFSIZ JMP ERROR IF ERROR. * SSB EOF ? (-1) JMP RS1.2 YES. RETURN A=B=-1. * STB COUNT NO. SET UP COUNT, LDA DBUFR AND POINTER. STA T1RS1 JMP RS1.0 GO SEE IF ANY DATA IN RECORD. * RS1.1 LDB T1RS1,I (A)=(B)=DATA. ISZ T1RS1 (BUMP POINTER TO NEXT WORD.) RS1.2 LDA B JMP RS1.F,I DONE. SKP * *************** * * WRITE E-O-F * * *************** SPC 1 * WRITE E-O-F, REWIND, CHECK FOR 'E' OPTION. * ES1.F NOP JSB WS81.F WRITE EXTRA JUNK WORD: 2 LOOK-AHEADS. LDA COUNT ANYTHING IN BUFFER ? SZA,RSS JMP ES1.0 NO. * JSB WRT.C YES. WRITE THE RECORD. DEF C.SC1 DEF BUFFR DEF COUNT (NOTE: F4.2 REWINDS THE FILE) JMP ERROR * * SET BUFFER EMPTY. CHECK FOR 'E' OPTION. * ES1.0 CLA SET BUFFER EMPTY. STA COUNT LDA F.CCW 'E' OPTION ? ALF,ALF SLA,RSS JMP ES1.F,I NO. EXIT. JMP ES1.5 YES. GO DUMP PASS FILE, SYMBOL TABLE. SPC 2 T1RS1 NOP POINTER FOR READING. COUNT NOP # WDS IN BUFFER. DBUFR DEF BUFFR FWA BUFFER. BUFFR BSS 60 BUFFER. DBUFE DEF *-1 LWA BUFFER (MUST FOLLOW 'BUFFR') BFSIZ ABS DBUFE-BUFFR+1 BUFFER SIZE, IN WORDS. SKP * 'E' OPTION. DUMP THE PASS FILE CONTENTS. * ES1.5 EQU * CODE DEPENDS ON AN 'IFZ' . IFZ JSB RWN.C YES. REWIND PASS FILE NOW. DEF C.SC1 JMP ERROR * JSB EJP.F DO THE TITLE. LDA K12 LDB DTTL1 JSB PSL.F CLA LEAVE BLANK LINE. JSB SKL.F * ES1.1 JSB RS1.F START A RECORD. CPA KM1 IF END, JMP ES1.3 SKIP OUT. * LDB A COMPUTE ADDITIONAL LENGTH. BRS,BRS WAS IN UPPER 8 BITS. BRS,BRS BRS,BRS BRS,BRS CMB,SSB,RSS (B) = -(TOTAL LENGTH), UNLESS CCB IT WAS OPERAND. THEN TOT LEN = 1. STB T2ES1 SAVE AS COUNTER. RSS SKIP READ FIRST TIME: (A)=DATA. ES1.2 JSB RS1.F READ ANOTHER WORD. STA T1ES1 SAVE IT. LDB KM6 6 DIGITS. JSB COD.F CONVERT. DEF LINE1+5 LDA T1ES1 ASCII TOO. JSB ALM.F STA LINE1+9 LDA K11 WRITE LINE. LDB DLIN1 JSB PSL.F ISZ T2ES1 MORE IN THIS RECORD ? JMP ES1.2 YES. DO THEM. JMP ES1.1 yR NO. GO FOR ANOTHER RECORD. * ES1.3 JSB RWN.C REWIND PASS FILE. DEF C.SC1 JMP ERROR * CLA SET BUFFER EMPTY. STA COUNT SKP * DUMP THE SYMBOL TABLE. * JSB EJP.F TITLE FOR SYMBOL TABLE. LDA K11 LDB DTTL2 JSB PSL.F CLA JSB SKL.F LDA F.DP SET UP LOOP. STA T1ES1 * ES1.4 LDA T1ES1 CONVERT ADDRESS. LDB KM5 5 DIGITS. JSB COD.F CONVERT. DEF LINE2+5 LDA T1ES1,I CONVERT CONTENTS. LDB KM6 6 DIGITS. JSB COD.F CONVERT. DEF LINE2+9 LDA T1ES1,I OUTPUT ASCII: AND KK02 REMOVE SYMBOL END BIT. JSB ALM.F IF NOT PRINTABLE, CHANGE TO BLANK. STA LINE2+13 LDA K15 OUTPUT THE LINE. LDB DLIN2 JSB PSL.F ISZ T1ES1 ADVANCE IN MEMORY. LDA T1ES1 DONE ? CPA F.LO JMP ES1.F,I YES. EXIT. JMP ES1.4 NO. LOOP. * T1ES1 NOP T2ES1 NOP KM1 DEC -1 KM5 DEC -5 KM6 DEC -6 K11 DEC 11 K12 DEC 12 K15 DEC 15 KK02 OCT 177577 MASK TO REMOVE SYMBOL END MARK. DTTL1 DEF TTL1 TITLE # 1. TTL1 ASC 12, FIRST PASS FILE. DTTL2 DEF TTL2 TITLE # 2. TTL2 ASC 11, SYMBOL TABLE. DLIN1 DEF LINE1 LINE1 ASC 11, 777777 'ZZ' DLIN2 DEF LINE2 LINE2 ASC 15, 77777: 777777 'ZZ' SKP * ************************************ * * MAP NON-PRINTING CHARS TO BLANKS * * ************************************ * * ALM.F : (A) => (A), TWO CHARACTERS. (B LOST) * ALM.F NOP CLB DO FIRST CHAR. RRR 8 (A)=1ST CHAR, (B)=2ND CHAR, IN UPPER. JSB AM.F SWP SAVE & DO 2ND CHAR. ALF,ALF (A) = 2ND CHAR. BLF,BLF (B) = 1ST CHAR, IN UPPER. JSB AM.F IOR B MERGE JMP ALM.F,I EXIT * * AM.F : (A) => (A), ONE CHARAU)CTER. (B PRESERVED) * AM.F NOP ADA BM177 (A)=CHAR-177 SSA,RSS RUBOUT OR 8-BIT ? CLA,RSS YES. CHANGE TO BLANK. ADA B137 (A)=CHAR-40 SSA CONTROL CHAR ? CLA YES. CHANGE TO BLANK. ADA B40 (A)=CHAR. JMP AM.F,I EXIT. * B40 OCT 40 B137 OCT 137 BM177 OCT -177 SKP * ************************** * * CONVERT OCTAL TO ASCII * * ************************** * * CALL: LDA * LDB <- # DIGITS> * JSB COD.F * DEF WORD ADDRESS, MUST BE DIRECT. * COD.F NOP SUBR TO CONVERT TO OCTAL DIGITS. STB T2COD T2COD = - # DIGITS TO DO. CMB (B) = (# DIGITS) - 1 ADB COD.F,I FORM BYTE ADDRESS OF ADB COD.F,I THE LAST BYTE. ISZ COD.F CLE,ERB (B) = ADDR, (E) = ODD/ EVEN BIT. * COD01 STA T1COD SAVE DATA. AND K7 (A) = NEXT DIGIT. IOR "0" MAKE ASCII. SEZ,RSS WHICH BYTE ? ALF,ALF FIRST, POSITION IT. STA T0COD SAVE NEW BYTE. LDA B,I DATA WORD. AND B377 CLEAR UPPER BYTE. SEZ WAS THAT RIGHT ? XOR B,I NO RESTORE & CLEAR OTHER. IOR T0COD INSERT NEW CHAR. STA B,I CMB (NEEDED TO SUBTRACT 1 & PRESERVE E) SEZ,CME,RSS BACK UP. WAS FIRST BYTE ? INB YES. PREVIOUS WORD. CMB LDA T1COD CLEAR & SHIFT PAST DIGIT. AND KM8 RAR,RAR RAR ISZ T2COD COUNT. DONE ? JMP COD01 NO. LOOP. JMP COD.F,I YES. EXIT. * T0COD NOP T1COD NOP T2COD NOP KM8 DEC -8 K7 DEC 7 B377 OCT 377 "0" OCT 60 XIF JMP ES1.F,I (IF CODE NOT ASSEMBLED: EXIT) SKP * ************************ * * WRITE CROSS-REF PAIR * * ************************ SPC 1 * | WRITE TO THE PASS FILE THE CROSS-REF OPERATOR AND * A CROSS-REF PAIR OF THE FORM: * * WORD 1: SYMBOL TABLE ADDR OF IDENTIFIER. (F.A) * WORD 2: SOURCE LINE NUMBER OF OCCURANCE. (F.LNN) SPC 1 CRP.F NOP LDA F.CCW 'C' OPTION ? AND K16 SZA,RSS JMP CRP.F,I NO. IGNORE IT. LDA KK30 COUNT & OPERATOR. JSB WS1.F LDA F.A JSB WS1.F LDA F.LNN JSB WS1.F JMP CRP.F,I DONE. * K16 DEC 16 KK30 BYT 2,36 K99 DEC 99 SPC 2 ERROR LDA K99 ERROR. ABORT, DISASTR 99. JMP F.ABT * END ASMB,Q,C HED LISTING ROUTINES. NAM PSL.F,8 92834-16002 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE CONTAINS ROUTINES TO PRINT LINES ON THE LISTING. * THIS INCLUDES: SOURCE LINES. * ERROR MESSAGES. * MISCELANEOUS COMMENTS. * MIXED LISTING. * CROSS-REF. * SYMBOL TABLE. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE OROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) ENT F.ABT ABORT COMPILE ENTRY ENT F.CC CURRENT COL EXT F.CCW FTN OPTION WORD EXT F.CSN CURRENT SEGMENT NUMBER. EXT F.D LOW ADDR OF DO STACK. ENT F.DEB DEF TO ERROR BIT TABLE. EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DO HIGH ADDR + 1 DO STACK. EXT F.END END SWITCH (0: EOF NOT ALLOWED) ENT F.EQE EQUIVALENCE ERROR FLAG ENT F.ERF ERROR FLAG (# OF ER.F CALLS) ENT F.ERX ERROR EXIT ADDRESS ENT F.ERN ERROR ARRAY ENT F.FLN FIRST LINE NUMBER OF MODULE. ENT F.LNA ADDRESS OF CURRENT LINE ENT F.LNL LENGTH OF CURRENT LINE ENT F.LNN LINE # OF CURRENT LINE ENT F.LOP NO. LINES LEFT ON THIS PAGE. EXT F.LSP LAST OPERATION FLAG ENT F.OFE DATA POOL OVERFLOW ERROR ENTRY. ENT F.OPT ADDR OF OPTIONS IN TITLE. ENT F.PAS PASS NUMBER. EXT F.SEG LOAD A NEW SEGMENT EXT F.STA FLAG THAT IS 0 UNTIL FTN STMT ENT F.TIM TIME ARRAY ADDRESS IN HEAD ENT F.TL LENGTH OF TITLE, INCL 2 WDS BLANKS. ENT F.TTL START OF TITLE (AFTER 4 BLANKS) * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * ENT ASC.F CONVERT TO 4 ASCII DIGITS ENT CER.F COMPILER ERROR. ENT EJP.F PAGE EJECT SUBROUTINE ENT ER.F ERROR PRINT SUBROUTINE ENT IN1.F INITIALIZATION FOR PSL.F ENT MPN.F MOVE PROGRAM NAME (TO NAM REC, ETC) ENT PCC.F PRINT COMPILER COMMENT. ENT PSL.F PRINT LINE ON PRINTER ENT SKL.F SKIP LINES ON LIST ENT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) EXT WS1.F -WRITE WORD TO PASS FILE 1. * * COMPILER LIBRARY ROUTINES USED * EXT C.LST LIST FCB EXT SPC.C SPACE ROUTINE EXT WRT.C WRITE FILE ROUTINE * * LIBRARY ROUTINES * EXT .MVW * SUP * A EQU 0 B EQU 1 SPC 2 * ************************* * * MODULE INITIALIZATION * * ************************* SPC 1 IN1.F NOP SZA IF NEW # LINES PER PAGE, STA LINEP SET IT. CLB,SEZ,RSS NEW COMPILE ? JMP IN1.F,I NO, DONE. STB PGNUM SET PAGE # BACK TO ZERO. CCB FORCE A PAGE EJECT. STB F.LOP JMP IN1.F,I EXIT. SKP * ********************* * * PRINT SOURCE LINE * * ********************* SPC 1 * ENTRY: (B)=BUFFER LOCATION * (A)=NO. OF WORDS TO BE PRINTED * PRINTS LINE, PRECEDED BY PAGE HEADER AND TWO BLANK LINES IF AT * TOP OF PAGE. * PSL.F NOP STA PBFL SAVE NO. OF WORDS TO BE PRINTED STB PBFP SAVE TEXT ADDR LDA F.LOP INA,SZA,RSS AT BOTTOM OF PAGE? JSB EJP.F YES. FORMFEED LDA F.LOP SZA,RSS AT TOP OF FORM? JSB PHEDR YES. PRINT HEADER ISZ F.LOP JSB WRT.C WRITE THE LINE DEF C.LST THE FCB PBFP DEF PBFP THE BUFFER DEF PBFL IT'S LENGTH JMP EXIT NOTHING TO DO BUT EXIT IF ERROR ON LIST JMP PSL.F,I OK RETURN * * ROUTINE TO CAUSE PAGE EJECT IN LISTING. * EJP.F NOP CLB CPB F.LOP AT TOP OF PAGE? JMP EJP.F,I YES. IGNORE LDA F.LOP GET NUMBER LEFT ON THE PAGE STB F.LOP SET NUMBER LEFT TO ZERO ADA KM6 SET TO SKIP 6 EXTRA ON TTY'S LDB F.CCW GET THE OPTION WORD BLF,BLF TEST IF TTY FORMAT DESIRED SSB,RSS IF NOT LDA KM2 REPLACE FORM FEED WITH SPC TWO LINES FOR CRT'S{. JSB SKPCL CALL COMP. LIB. SKIP ROUTINE JMP EJP.F,I RETURN SKP * ROUTINE TO SKIP (A)+1 LINES IN LISTING. * SKL.F NOP LDB F.LOP SZB,RSS AT TOP OF PAGE? JMP SKL.F,I YES. IGNORE. (SHOULDN'T GET HERE) * INA ADB A SSB TEST IF NEAR BOTTOM JMP SKPBN NOT NEAR BOTTOM. JSB EJP.F AT BOTTOM; DO FORMFEED INSTEAD JMP SKL.F,I SKPBN STB F.LOP JSB SKPCL SKIP ROUTINE JMP SKL.F,I * * INTERNAL ROUTINE TO SKIP (A) LINES. * SKPCL NOP SSA COUNT NEGATIVE ? JMP SKP02 YES. GO CALL SPC.C * CMA,INA,SZA,RSS NEGATE COUNT. ZERO ? JMP SKPCL,I YES. DO NOTHING. * STA T1PSL COUNTER. SKP01 JSB WRT.C WRITE A BLANK LINE. DEF C.LST DEF BLNKS DEF K1 JMP EXIT ERROR. EXIT. * ISZ T1PSL COUNT. DONE ? JMP SKP01 NO. MORE. JMP SKPCL,I YES. EXIT. * SKP02 STA T1PSL NEGATIVE COUNT. CALL SPC.C JSB SPC.C FOR A PAGE EJECT ? DEF C.LST DEF T1PSL NOP IGNORE SKIPPING ERRORS, FOR SOME REASON. JMP SKPCL,I EXIT. SKP * ROUTINE TO PRINT HEADER AT TOP OF PAGE. * PHEDR NOP AT TOP OF PAGE; PRINT HEADER ISZ PGNUM LDA PGNUM CLE SUPPRESS LEADING ZEROES. JSB ASC.F SWP (A,B) = 1234 AND B377 CHANGE FIRST DIGIT TO BLANK. IOR B20K RRL 8 (A,B) = 234- DST PAGE SET PAGE. ASSUME < 1000. JSB WRT.C WRITE HEADER. DEF C.LST LIST FCB DEF HEADR ADDRESS OF HEAD DEF F.HDL LENGTH OF HEAD JMP EXIT EXIT IF LIST ERROR LDA F.TL SET UP TRUE TITLE LENGTH, ADA K2 WITH 4 BLANKS ACCOUNTED FOR. STA TTLEN JSB WRT.C THEN TITLE, IF ANY. DEF C.LST DEF TITLE DEF TTLEN LENGTH. JMP EXIT IF LIST ERROR. CLA,INA THEN ONE BLANK LINE. JSB SKPCL LDA LINEP SET # LINES LEFT. CMA,INA AS NEGATIVE IN F.LOP STA F.LOP JMP PHEDR,I SPC 2 PBFL NOP # WDS TO BE PRINTED. LINEP DEC 55 (IN CASE DISASTER) F.LOP NOP PGNUM NOP T1PSL NOP BLNKS ASC 1, K1 DEC 1 KM6 DEC -6 KM2 DEC -2 K2 DEC 2 B20K BYT 40,0 BLANK IN UPPER BYTE. * F.HDL DEC 35 LENGTH OF HEADER. HEADR ASC 03, PAGE , PAGE ASC 03,001 , PAGE #. HEADN ASC 03,FTN. , PROGRAM NAME. ASC 05, OPTS: , F.OPT ASC 06, , OPTIONS. F.TIM ASC 15,HH:MM AM DAY., XX MON., 19XX, CLIB TIME MSG. * F.TL DEC 1 TITLE LENGTH, WITHOUT EXTRA BLANKS. TTLEN NOP COMPUTED TRUE LENGTH. TITLE ASC 2, , 2 BLANKS COLUMNS BEFORE TITLE. F.TTL BSS 33 TITLE. MAX 66 CHARS. SKP * ************************** * * PRINT COMPILER COMMENT * * ************************** SPC 1 * PCC.F PRINTS A LINE JUST LIKE PSL.F, BUT IF THE LISTING HAS BEEN * DELAYED UNTIL PASS TWO, AND WE ARE CURRENTLY IN PASS ONE, THE * LINE IS NOT PRINTED IMMEDIATELY, BUT IS WRITTEN TO THE PASS FILE. * * CALLING SEQUENCE: SEE PSL.F * * ENTRY. SEE WHAT PASS WE'RE ON. * PCC.F NOP STA T1PCC SAVE THE LINE LENGTH. CLA,INA PASS 1 ? CPA F.PAS JMP PCC02 YES. * PCC01 LDA T1PCC RESTORE (A), JSB PSL.F PRINT LINE IMMEDIATELY, JMP PCC.F,I AND EXIT. * PCC02 LDA F.CCW PASS ONE. 'M' OR 'Q' OPTIONS ? AND B4002 SZA,RSS JMP PCC01 NO. PRINT IMMEDIATELY. * * DELAYED LIST. SEND TO PASS FILE. * STB T2PCC SAVE BUFFER ADDR. LDA T1PCC COMBINE LINE LENGTH ALF,ALF IOR K56 AND OPCODE. \G JSB WS1.F WRITE THAT. LDA T1PCC SET UP COUNT. CMA,INA,SZA,RSS NEGATE. ZERO ? JMP PCC.F,I YES. DONE. * STA T1PCC NO. T1PCC = COUNTER. PCC03 LDA T2PCC,I WRITE A WORD AT A TIME. JSB WS1.F ISZ T2PCC BUMP BUFFER POINTER. ISZ T1PCC BUMP COUNTER. DONE ? JMP PCC03 NO. LOOP. JMP PCC.F,I YES. EXIT. * T1PCC NOP LINE LENGTH / COUNTER. T2PCC NOP BUFFER POINTER. K56 DEC 56 DELAYED PRINT OPCODE. B4002 OCT 4002 Q & M OPTIONS. SKP * ***************** * * ERROR COMMENT * * ***************** SPC 1 * TO PRINT ERROR COMMENT. INPUT: (A) = ERROR NUMBER. * ERROR CLASS DETERMINED BY ER.F & F.ERN * CURRENT LINE DESCRIBED BY F.LNA F.LNL F.LNN F.CC SPC 1 WAR.F NOP STA ERTYP SAVE ERROR NUMBER. CLE (SUPPRESS LEADING ZERO) JSB PD.F CONVERT TYPE TO ASCII. STA ERBFX STA F.LSP SET LAST OPERATION FLAG. * * SET THE BIT IN THE ERROR BIT VECTOR. * LDA ERTYP GET WORD OFFSET. ARS,ARS ARS,ARS ADA F.DEB WORD IN VECTOR. STA T1WAR LDA ERTYP GET BIT OFFSET. AND B17 CMA -(BIT #)-1, LEFT TO RIGHT. CLB,INB WAR06 RBR SHIFT UNTIL BIT IS POSITIONED. INA,SZA JMP WAR06 * LDA T1WAR,I SET THE BIT. IOR B STA T1WAR,I * * SEE IF LISTING DELAYED TILL PASS 2. * CLA,INA IF [Q OR (M&L)] AND PASS 1, DELAY IT. LDB F.ERN UNLESS DISASTER. CPA F.PAS PASS 1 ? SZB AND NOT DISASTER ? JMP WAR01 NO. * LDA F.END END SWITCH SET ? SZA JMP WAR01 YES. DON'T DELAY. * LDA F.CCW OPTIONS. AND B4003 Q,M,L. CPA K3 -Q,+M,+L ? JMP WAR04 YES. DELAY. ALIF +Q ? SSA JMP WAR04 YES. DELAY. SKP * SKIP A LINE, CONVERT LINE #. * WAR01 ISZ WARNF (COUNT THE ERROR) CLA SKIP A LINE. JSB SKL.F LDA F.LNN CONVERT LINE #. CLE SUPPRESS LEADING ZEROES. JSB ASC.F SWP DST ERBFY * * LIMIT COL TO LINE LENGTH. IF < 2, IGNORE. * LDA F.CC (A) = COL #. ADA KM2 COL - 2 SSA,INA WELL ? (COL - 1) JMP WAR03 YUP. JUST MESSAGE. LDB F.LNL GET CURRENT CARD LENGTH BLS IN CHARACTERS STB T1WAR SAVE IT CMB,INB IF ERROR IS OFF ADB A THE CARD CLE,SSB,RSS THEN (E=0: ZERO SUPPR IN PD.F) LDA T1WAR USE LAST CHAR. ON THE CARD STA T1WAR SAVE THE COLUMN NUMBER JSB PD.F MAKE TWO ASCII DIGITS STA ERBFZ ERROR COLUMN * * INSERT '?', WRITE LINE, RESTORE. * LDB F.LNA GET THE BUFFER ADDRESS CLE,ELB CONVERT TO CHAR ADDRESS ADB T1WAR ADD THE COLUMN NUMBER CLE,ERB ADDRESS TO B, UPPER, LOWER TO E STB T0WAR SAVE THE ADDRESS LDA B,I AND ITS CONTENTS STA T2WAR FOR TO RESTORE IT LDA "?B" ASSUME EVEN COLUMN. SEZ,RSS TRUE ? JMP WAR02 YES. LDA B,I NO. GET WORD. XOR "?" CNANGE LOWER CHAR TO "?" AND B377 ISOLATE THE UPPER CHARACTER XOR B,I WAR02 STA B,I IN THE BUFFER AFTER THE BAD GUY LDB F.LNA GET THE ADDRESS LDA T1WAR AND THE CHARACTER COUNT ADA K2 ADJUST FOR BLANKS AND ODD ARS CONVERT TO WORDS JSB PSL.F PRINT IT LDA T2WAR RESTORE THE BUFFER STA T0WAR,I JUST IN CASE SKP * SET UP AND PRINT THE ERROR MESSAGE. * WAR03 LDA DWARN ASSUME "WARNING" LDB ER.F s CALLED FROM ER.F ? SZB LDA DERRO YES. " ERROR " LDB F.ERN CALLED FROM BOM.F ? SZB LDA DDISA YES. "DISASTR" LDB DERBW JSB .MVW DEF K4 NOP LDA K27 (LENGTH IF COL COUNTER) LDB F.CC IF COL < 01 ADB KM2 SSB THEN LDA K22 SKIP THE 'COLUMN ZZ'. LDB F.LNN IF NO LINE #, SZB,RSS THEN LDA K16 SKIP THE 'AT LINE XXXX'. LDB ERCK1 "ERR N DETECTED ..." JSB PSL.F PRINT ERROR MESSAGE CLA SKIP A LINE. JSB SKL.F JMP WAR05 CLEAR ER.F & EXIT. * * DELAY TILL PASS 2. JUST 'PASS' IT ALONG.... * WAR04 LDA K25 SEND ERROR OPERATOR. JSB WS1.F LDA ER.F ERROR CLASS. JSB WS1.F LDA F.LNN LINE # (DIFFERENT FOR EQUIV) JSB WS1.F LDA F.CC COLUMN #. JSB WS1.F LDA ERTYP ERROR CLASS. JSB WS1.F WAR05 CLA CLEAR ER.F FLAG. STA ER.F JMP WAR.F,I EXIT. SKP * GLOBALS DESCRIBING THE CURRENT LINE. * F.PAS NOP PASS NUMBER. F.LNA NOP ADDRESS F.LNL NOP LENGTH (WORDS) F.LNN NOP LINE # F.FLN NOP FIRST LINE # OF MODULE. F.CC NOP CURRENT COLUMN * * THE ERROR LINE. * ERCK1 DEF *+1 ADDRESS OF ERROR MESSAGE. ASC 02, ** ERBFV ASC 04,FTN. ** ERBFW ASC 04,WWWWWWW ERBFX ASC 10,XX DETECTED AT LINE ERBFY ASC 06,0000 COLUMN ERBFZ ASC 01,ZZ K27 DEC 27 FULL LENGTH OF ERROR MESAGE. K22 DEC 22 LENGTH WITHOUT COLUMN #. K16 DEC 16 LENGTH WITHOUT LINE # OR COLUMN #. K25 BYT 4,31 OPERATOR FOR ERROR. * DERBW DEF ERBFW ADDRESS OF ERROR/WARNING/DISASTR DERRO DEF *+1 ASC 4, ERROR DWARN DEF *+1 ASC 4,WARNING DDISA DEF *+1 ASC 4,DISASTR SPC 1 * F.ERN NOP ERROR ARRAY NOP CUMULATIVE ERROR COUNT NOP CUMULATIVE WARNING COUNT F.ERF NOP NO OF ERRORS WARNF NOP NO. OF WARNINGS. * F.DEB DEF *+1 DEF TO ERROR BIT VECTOR. OCT 0,0,0,0,0,0,0 ERROR BITS 0-111. * T0WAR NOP T1WAR NOP T2WAR NOP "?" OCT 77 "?B" ASC 1,? B377 OCT 377 B4003 OCT 4003 K4 DEC 4 B17 OCT 17 SKP * *************** * * FATAL ERROR * * *************** SPC 1 * TO PRINT AN ERROR MESSAGE & ABORT CURRENT STATEMENT. * INPUT (A) = ERROR TYPE. * F.EQE = SPECIAL PROCESSING FLAG: * =0 NORMAL. EXIT THRU F.EQX . * >0 RECOVERY. EXIT THRU F.EQE . * <0 EQUIVALENCE. JSB THRU F.EQE BEFORE WAR.F . SPC 1 ER.F NOP CPA K84 DATA / CODE OVERFLOW ? JMP F.ABT YES. PUNT. ISZ F.ERF STEP ERROR COUNT. STA ERTYP SAVE ERROR NUMBER. LDA F.EQE EQUIVALENCE ? CMA,SSA,RSS JSB A,I YES, SPECIAL PROCESSING. LDA ERTYP ISSUE MESSAGE. JSB WAR.F LDA F.DO CUT DO STACK. STA F.D LDA F.EQE RECOVERY ? SZA SSA JMP F.ERX,I NO. EXIT THRU NORMAL (F.ERX) EXIT. JMP F.EQE,I YES. EXIT THRU (F.EQE). SPC 1 F.ERX DEF 0 ERROR EXIT ADDRESS. F.EQE DEF 0 SPECIAL PROCESSING FLAG. ERTYP NOP ERROR NUMBER. K84 DEC 84 SPC 2 * ***************** * * ABORT COMPILE * * ***************** SPC 1 F.OFE LDA K3 DATA POOL OVERFLOW. F.ABT ISZ F.ERN BUMP DISASTER COUNT. CLB SET F.CC=0 STB F.CC TO SUPPRESS ECHO & COLUMN #. JSB WAR.F ISSUE MESSAGE. LDA F.CCW TURN OFF C,T OPTIONS. AND BM31 STA F.CCW LDB K3 GO TO SEGMENT 3 JMP EXIT2 TO WRITE THE ERROR DIRECTORY. * EXIT LDB K4 LOAD SEGMENT 4 TO QUIT. EXIT2 STB F.STA JMP F.SEG * BM31 OCT -31 SKP * ****************** * * COMPILER ERROR * * ****************** SPC 1 CER.F NOP ISZ F.ERN BUMP DISASTER COUNT. LDA F.CSN GET CURRENT SEGMENT NUMBER. ALF,ALF IN HIGH BYTE. ADA CECSN PUT IN MSG. STA CECSN CCB GET ADDRESS OF JSB. ADB CER.F JSB COD.F CONVERT FOR PRINTING. DEF CENUM JSB WRT.C WRITE MESSAGE. DEF C.LST DEF CEMSG DEF CELEN JMP EXIT IF ERROR ON WRITE. JMP EXIT ALSO IF NO ERROR ON WRITE. * CEMSG ASC 12, *** COMPILER ERROR AT: CECSN ASC 1,0/ CENUM ASC 3,177777 ASC 15,B *** PLEASE REPORT TO HP *** CELEN ABS *-CEMSG KM3 DEC -3 B3407 OCT 3407 DIGIT MASK. SPC 2 * *************************** * * CONVERT TO OCTAL DIGITS * * *************************** SPC 1 * CALL: LDB * JSB COD.F * DEF <3-WORD ASCII BUFFER> * COD.F NOP LDA COD.F GET THE RESULT ADDR. ISZ COD.F LDA A,I RESOLVE INDIRECTS. RAL,CLE,SLA,ERA JMP *-2 STA T2COD * LDA KM3 CONVERT 6 DIGITS, 2 AT A TIME. STA T1COD LSR 2 SET UP SO ONLY GET 1 BIT FIRST TIME. CER01 RRL 3 MOVE LEFT DIGIT THIS PAIR TO (A). ALF,RAL LEAVE 5 BITS. RRL 3 MOVE RIGHT DIGIT IN. AND B3407 ISOLATE THE DIGITS. ADA "00" FORM ASCII, STA T2COD,I PUT IN BUFFER. ISZ T2COD BUMP BUFFER POINTER. ISZ T1COD BUMP COUNTER. JMP CER01 IF MORE. JMP COD.F,I ELSE DONE. * T1COD NOP COUNTER FOR 3 LOOPS. T2COD NOP RESULT POINTER. SKP * ******************************** * * CONVERT TO FOUR ASCII DIGITS * * ******************************** SPC -1 * ENTRY: (A) = VALUE TO CONVERT. * (E) = 1 TO PRODUCE LEADING ZEROES, 0 TO SUPPRESS. * EXIT: (B,A) = 4 ASCII CHARACTERS. * * NOTE: IF VALUE IS NOT IN RANGE (0,9999) THEN THE RESULT * WILL BE " ??" . * ASC.F NOP ERB (SAVE E-REG) CMA,SSA,RSS < 0 ? (A = -N-1) JMP ASC01 YES. * ADA K10K > 9999 ? (A = -N+9999) CMA,SSA,RSS (A = N-10000) JMP ASC01 YES. * ADA K10K NO. RESTORE ORIGINAL VALUE. ELB RESTORE E-REG. CLB CLEAR FOR DIV. DIV K100 SEPERATE HIGH AND LOW DIGITS STB T1FC SAVE THE LOW ONES JSB PD.F CONVERT THE HIGH DIGITS CPA BLNKS IF DIGITS PRODUCED IN FIRST PART, CLE,RSS (NO - CONTINUE TO SUPPRESS) CCE THEN FORCE LEADING ZERO IN SECOND. STA T2FC SAVE FIRST TWO. LDA T1FC GET THE LOW JSB PD.F CONVERT LDB T2FC RESTORE THE HIGH TO B JMP ASC.F,I RETURN * ASC01 LDB BLNKS OUT OF RANGE. RETURN " ??" LDA "??" JMP ASC.F,I * T1FC NOP T2FC NOP "00" ASC 1,00 "??" ASC 1,?? K10 DEC 10 K100 DEC 100 K10K DEC 10000 SKP * *************** * * PACK DIGITS * * *************** SPC 1 * ENTRY: (A)=TWO DIGIT DECIMAL NUMBER BINARIZED * (E)=0 TO SUPPRESS LEADING OR BOTH ZEROES. * EXIT: (A)=ASCII EQUIVALENT OF ENTRY (A) SPC 1 PD.F NOP CLB DIV K10 ALF,ALF SEZ,SZA,RSS IS ZERO & SUPPRESSED ? ADB B170K YES. MAKE IT BLANK: ' ' - '0' CPB B170K BOTH ZERO & SUPPRESSED ? ADB BM20 YES. MAKE FINAL BLANK: ' ' - '00' ADA B ADA "00" ADD THE ASCII BITS JMP PD.F,I * B170K BYT -20,0 ' ' - '0' BM20 OCT -20 IN LOWER. SPC 2 * **************************************** * * ڮMOVE PROGRAM NAME TO PBUF,ERBF,HEADN * * **************************************** SPC 1 MPN.F NOP STA T1MPN SAVE MOVE FROM LOC. LDB HDLP7 JSB .MVW MOVE NAME TO F.HDL+7,8,9 DEF K3 NOP LDA T1MPN LDB F.DNB ADB K3 JSB .MVW MOVE NAME TO NBUF+3,4,5 DEF K3 NOP LDA T1MPN LDB DERBV JSB .MVW MOVE NAME TO ERBF+1,2,3 DEF K3 NOP JMP MPN.F,I SPC 1 T1MPN NOP MOVE FROM LOC. K3 DEC 3 SPC 1 DERBV DEF ERBFV ADDRESS LOCATION IN ERROR BUFFER. HDLP7 DEF HEADN SPC 1 END ASMB,L HED FTN4X - SEGMENT NAME ADDRESS FETCH NAM SEG.F,8 92834-16002 REV.2030 800226 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * ENT SEG.F * A EQU 0 B EQU 1 * * THIS ROUTINE FORMS A SEGMENT NAME, F4X.N, WHERE N IS THE * SEGMENT NUMBER PASSED AS AN INPUT PARAMETER. UPON RETURN, * THE B-REGISTER CONTAINS THE ADDRESS OF THE SEGMENT NAME. * * CALLING SEQUENCE: JSB SEG.F * DEF SEG# SEGMENT NUMBER * * RETURNS: B = ADDRESS OF THE SEGMENT'S NAME * (5 CHARACTERS) * * SEG.F NOP ENTRY LDB SEG.F,I GET ADDRESS OF SEGMENT # LDB B,I GET THE SEGMENT NUMBER BLF,BLF PUT IN UPPER BYTE. ADB "0" ADD TO FORM "N " STB NAM SAVE IN NAME ARRAY LDB NAMA GET ADDRESS ISZ SEG.F STEP RETURN JMP SEG.F,I RETURN * "0" ASC 1,0 NAMA DEF *+1 ASC 2,F4X. NAME = F4X.N NAM NOP * END ASMB,Q,C HED FTN4X COMPILER (SEG: F4X.0) SPECIFICATION STATEMENTS ** NAM F4X.0,5 92834-16002 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * ***************************************** * FORTRAN-4 COMPILER OVERLAY 0 ***************************************** * * THIS OVERLAY PROCESSES COMMON, DIMENSION, AND * EQUIVALENCE STATEMENTS, PROGRAM AND DATA STATEMENTS, * AND TYPE DECLARATIONS. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F..E EXPLICIT TYPING FLAG. EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE ENTRY. EXT F.AF f  ADDRES FIELD OF CURRENT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.AT. SUBSCRIPT INFO FLAG EXT F.BGN RETURN FROM F4.0 EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTION WORD. EXT F.CRT TEST FOR C/R & GO ON TO NEXT STMT. EXT F.D DO TABLE POINTER EXT F.D0 ARRAY ELEMEXT SIZE EXT F.DCF DIM, COM FLAG EXT F.DID ADDRESS OF F.IDI EXT F.DIS DOUBLE INTEGER SUBSCRIPTING FLAG. EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DO LWAM - END OF DO TABLE EXT F.DPJ DEF TO CURRENT PROC. JUMP TABLE. EXT F.DPK DEF TO F.PAK BUFFER. EXT F.DTY IMPLICIT TYPE TABLE EXT F.E EQUIVALENCE TABLE POINTER EXT F.EIM EXPECTED ITEM MODE. EXT F.EM EMA FLAG BIT IN A.T. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.EXF EXTERNAL STATEMEXT FLAG EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IMF IMPLICIT FLAG. EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LCF LABELLED COMMON FLAG. EXT F.LNN CURRENT LINE NUMBER. EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LUB ADDR OF LOWER/UPPER BOUNDS TABLE. EXT F.ND NUMBER OF DIMENSIONS EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.P1E PASS 1 ERROR RECOVERY POINT. EXT F.PTY PROGRAM TYPE IN NAM RECORD. EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.SLF STATEMEXT LEVEL FLAG EXT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL EXT F.SPS STATEMEXT PROCESSOR SWITCH EXT F.SXF COMPLEX CONSTANT FLAG EXT F.TC NEXT CHARACTER EXT F.TYP TYPE STATEMEXT FLAG EXT  F.VDM VARIABLE DIMENSIONS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR & FETCH CONSTANT. EXT CRP.F CROSS REF PAIR SUB. EXT DAD.F DOUBLE INTEGER ADD. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (AT) EXT DEM.F DEFINE (F.EM) TRUE. EXT DIM.F DEFINE (F.IM) EXT DEM.F SET THE F.EM BIT. EXT DIU.F DEFINE (F.IU) EXT DMP.F DOUBLE INTEGER MULTIPLY. EXT DSB.F DOUBLE INTEGER SUBTRACT. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT EL.F EXCHANGE LINKS OF (F.A) & (B). EXT ER.F ERROR PRINT SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER EXT FA.F FETCH ASSIGNS EXT FL.F FETCH LINK OF (B). EXT GCD.F GET CONSTANT DIMENSION (AS DBL INT) EXT GFA.F GET FIRST NAMED S.T. ENTRY. EXT GNA.F GET NEXT S.T. ENTRY. EXT IC.F GET NEXT CHARACTER EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDL.F INPUT DUMMY LIST. EXT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) EXT IN6.F INIT FOR IC.F MODULE EXT INM.F INPUT NAME EXT IOP.F INPUT OPERATOR EXT ISY.F INPUT SYMBOL EXT ITS.F INTEGER TEST EXT KWS.F KEYWORD SEARCH. EXT MPN.F MOVE PROGRAM NAME (TO NAM RECORD ECT.) EXT MVW.F FTN MOVE WORDS. EXT NCT.F TEST FOR NOT A CONSTANT EXT NST.F TEST FOR NOT A SUBROUTINE NAME EXT NTI.F MOVE NID TO F.IDI (PACKS) EXT NWI.F SET F.D0 TO # WORDS IN ARRAY EXT PAK.F PACK & OUTPUT ASCII DATA. EXT RP.F INPUT ')' EXT TCT.F TEST (A) = F.TC ELSE ER 28 EXT TS.F TAG SUBPROGRAM SUB. EXT TV.F TAG VARIABLE EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) EXT WS1.F WRITE WORD TO PASS FILE # 1. * * OTHER ENTRY POINTS THIS SEGMENT. * ENT F.BCM BLANK COMMON HEADER. ENT F.CIO ITEM OFFSET (2-WORD INTEGER) * ENT CIO.F COMPUTE ITEM OFFSET. ENT NDS.F NON-DUMMY/SUBROUTINE TEST. * * SPECIAL ACCESS FOR 'RCO.F' * ENT F.RCO JUST POINTS TO RCO.F EXT RCO.F MAIN CAN'T ACCESS IT DIRECTLY. * * FORMAT PROCESSOR IN 'DSP.F'. * EXT F.FMT STMT PROC FOR FORMAT. * * OTHER LIB ROUTINES * EXT .MVW * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 1 DEC 0 OVERLAY # SKP * *-----------------------* * * START HERE. * * *-----------------------* * F4.0 LDA DFP1E SET THE ERROR RECOVERY ADDRESS. STA F.ERX LDA DFPJT AND THE PROC. JUMP TABLE ADDR. STA F.DPJ LDA F.SLF IF BACK IN TO DO CPA K2 A DATA STATEMENT JMP F.DAT JUST GO DO IT * JSB MVW.F MOVE THE CARD BUFFER, DEF F.IDI+1,I TO HERE, DEF F.IDI,I FROM HERE. DEC 98 98 WORDS. LDB F.IDI+1 NOW PASS THE ADDRESS OF CARD BUFFER CCA,CLE TO JSB IN6.F THE ONE WHO MUST KNOW * JMP F.BGN BACK TO READ THE FIRST CARD SPC 1 DFP1E DEF F.P1E PASS 1 ERROR RECOVERY ADDRESS. DFPJT DEF F.PJT DEF TO PROC. JUMP TABLE FOR SEG 0. F.RCO DEF RCO.F SPECIAL ACCESS TO RCO.F K9 DEC 9 SKP * ************************ * * PROCESSOR JUMP TABLE * * ************************ SPC 1 * THIS TABLE IS INDEXED BY THE KEYWORD ORDINAL DETERMINED BY * THE DISPATCHER. THE PROCESSORS ARE LOCATED IN BOTH SEGMENTS * 0 AND 1; THIS TABLE IS DUPLICATED IN EACH SEGMENT, SO THAT THE * MAIN HAS NO REFERENCES TO TYPE 7 ROUTINES IN THE SEGMENTS. * THE SEGMENTS MUST SET UP 'F.DPJ' ON ENTRY TO POINT TO F.PJT . * THE ORDINALS FOR THE FIR1ST 3 ENTRIES ARE SPECIAL-CASED IN THE * DISPATCHER, AND ARE NOT TRUE ORDINALS. * DEF 0 DO (-2) DEF 0 ASSIGNMENT STMT (-1) F.PJT DEF 0 STMT FCT. (0) DEF 0 IF (1) DEF F.EMP EMA DEF 0 END DEF 0 CALL DEF 0 GO TO DEF 0 READ DEF 0 STOP DEF F.REA REAL DEF F.DAT DATA DEF 0 THEN DEF 0 ELSE DEF 0 OPEN DEF 0 WRITE DEF 0 PRINT DEF 0 PAUSE DEF 0 ENDIF DEF 0 CLOSE DEF 0 RETURN DEF F.FMT FORMAT DEF 0 REWIND DEF F.COM COMMON DEF 0 ASSIGN DEF 0 ENCODE DEF 0 DECODE DEF 0 END FILE DEF F.INP INTEGER DEF F.CPX COMPLEX DEF F.LOG LOGICAL DEF F.PRO PROGRAM DEF 0 INQUIRE DEF F.FUN FUNCTION DEF 0 CONTINUE DEF F.EXT EXTERNAL DEF F.IMP IMPLICIT DEF F.DIM DIMENSION DEF 0 BACKSPACE DEF F.BLK BLOCK DATA DEF F.SUB SUBROUTINE DEF F.EQU EQUIVALENCE DEF F.DBL DOUBLE PRECISION SKP * ************ * * EXTERNAL * * ************ SPC 1 F.EXT CLA,INA STA F.EXF SET EXT FLAG JSB INM.F INPUT NAME JSB TS.F TAG SUBPROGRAM SPC 1 * ***************** * * , OR C/R TEST * * ***************** SPC 1 CCRT CLB STB F.LSF CLEAR THE EXPECT FIRST STMT. FLAG LDA F.TC CPA B54 ',' ? JMP F.SPS,I YES. MORE TO PROCESS * STB F.EXF NO. CLEAR EXTERNAL FLAG JMP F.CRT C/R TEST * TYPES ASC 13,NONE REAL INTEGER COMPLEX , ASC 13,LOGICAL DOUBLEPRECISION , DIMPCT DEF IMPT-1 ORDINAL TO TYPE TRANSLATION. IMPT OCT 20000,10000,50000,30000,60000 REA EQU IMPT B10K EQU IMPT+1 INT EQU IMPT+1 CPX EQU IMPT+2 LOG EQU IMPT+3 DBL EQU IMPT+4 T1IMP NOP T2IMP NOP T3IMP NOP BM101 OCT -101 K5 DEC 5 B51 OCT 51 B54 OCT 54 B55 OCT 55 B377 OCT 377 B170K OCT 170000 SKP * ************ * * IMPLICIT * * ************ SPC 1 * GET TYPE, HANDLE 'IMPLICIT NONE'. * F.IMP LDB F.IMF HAVE WE SEEN AN 'IMPLICIT NONE' ? LDA K5 IF SO, SSB JSB ER.F ERROR 5. * JSB KWS.F NO. LOOK FOR TYPE. DEF TYPES LDB A (B) = ORDINAL. LDA K28 (ERROR NUMBER) CMB,INB,SZB,RSS GOT ONE ? (B=-ORD) JSB ER.F NO. ERROR. * CMB,SZB 'NONE' ? (B=ORD-1) JMP IMP01 NO. NORMAL TYPE. * LDB F.IMF YES. IS IT THE FIRST IMPLICIT ? LDA K5 SZB JSB ER.F NO. ERROR 5. * CCA YES. SET THE FLAG: -1 = NONE. STA F.IMF JSB ICH.F READ THE C/R. JMP F.CRT THAT'S ALL. * IMP01 CLA,INA NORMAL IMPLICIT. SET FLAG = 1. STA F.IMF ADB DIMPT GET TYPE. LDA B,I JSB MTY.F MODIFY IT IF APPROPRIATE. JSB ICH.F REQUIRE '(' HERE. CPA B50 JMP IMP03 O.K. LDA K9 NO. UNEXPECTED CHAR. JSB ER.F SKP * GET THE RANGE, IN FORM X OR X-Y. * IMP03 JSB ICH.F GET FIRST CHAR OF SET STA T1IMP SET IT SZB IF IT IS NOT SEZ ALF JMP TYP11 GO REPORT THE ERROR * CCA IN CASE SINGLE LETTER, STA T2IMP SET COUNT TO 1. JSB ICH.F GET THE NEXT CHAR CPA B55 '-' IF '-' THEN PART OF RANGE RSS YES. JMP IMP04 NO. ALREADY SET UP. * JSB ICH.F GET THE FINAL CHAR OF A RANGE SZB TEST FOR SEZ ALF JMP TYP11 NOPE BITCH * CMA COMPUTE NEG. NO TO DO ADA T1IMP AND STA T2IMP SET FOR THE LOOP SSA,RSS IF LETTERS BACKWARD JMP TYP11 REPORT ERROR * JSB ICH.F GET NEXT CHAR. * * SET DEFAULTS FOR ALL IN RANGE TO SPECIFIED TYPE. * IMP04 LDB T1IMP GET THE CHARACTER ADB BM101 SUBTRACT 'A' CLE,ERB COMPUITE TYPE ADDRESS IN THE TABLE ADB F.DTY AND GET CURRENT LDA B,I TYPE SEZ ROTATE ALF,ALF IF NEEDED STA T3IMP SAVE RESULT FOR DUP IMPLICIT TEST XOR F.MFL GET THE NEW TYPE AND B377 KEEP THE OLD LOW ORDER BYTE XOR F.MFL RULES OF WOO CHAR REPLACE IOR B400 SET LEAST BIT IN BYTE AS FLAG. SEZ IS CHAR IS TO BE IN LOW WORD ALF,ALF PUT IT THERE STA B,I RESTORE WORD TO THE TABLE LDA K5 WARNING 5 LDB T3IMP IF SECOND REF TO SAME BLF,BLF CHAR SLB JSB WAR.F * ISZ T1IMP STEP TO THE NEXT CHAR ISZ T2IMP STEP THE COUNT (DONE?) JMP IMP04 N0 - DO NEXT CHAR SKP * APPLY IMPLICIT TYPING TO ALL SYMBOLS SO FAR. * JSB GFA.F SET UP TO SCAN NAMED SYMBOLS. IMP05 JSB GNA.F NEXT. SZA,RSS SEE IF DONE. JMP IMP06 YES. * JSB FA.F NO. SET ADDR & FETCH ASSIGNS. LDA F..E EXPLICITLY TYPED ? SZA IF SET JMP IMP05 YES. IGNORE IT. * LDA F.A GET THE FIRST ADA K2 CHAR OF THE NAME LDA A,I TO A ALF,ALF ROTATE AND AND B377 ISOLATE ADA BM101 SUBTRACT 'A' CLE,ERA CONVERT TO CHAR ADDRESS ADA F.DTY ADD THE ADDRESS OF THE TYPE TABLE LDA A,I GET THE TYPE FROM THE TABLE SEZ USE RIGHT END  ALF,ALF AND B170K ISOLATE THE MODE JSB DIM.F DEFINE NEW IM JMP IMP05 GO GET NEXT SYMBOL. * * CHECK DELIMITER AFTER RANGE. * IMP06 LDA F.TC YES - GET DELIMITER CPA B54 ',' IF COMMA JMP IMP03 GO DO NEXT CHAR * CPA B51 ')' IF CLOSE THEN RSS OK ELSE JMP TYP11 UNEXPECTED CHAR * JSB ICH.F GET THE NEXT CHAR JMP CCRT GO TEST FOR COMMA SKP * ******* * * EMA * * ******* SPC 1 F.EMP CLA,INA SET DIMENSION FLAG. STA F.DCF JSB INM.F INPUT NAME. LDA F.IU ALREADY DECLARED AS AN ARRAY ? CPA ARR RSS YES. LEAVE IT ALONE. JSB TV.F NO. TAG VARIABLE. LDA F.AT VERIFY A DUMMY CPA DUM RSS JMP EMP2 NO, ERROR JSB DEM.F MAKE IT TYPE EMA. JSB IDC.F PROCESS ANY DIMENSION INFO. JMP CCRT CHECK FOR "," OR "C/R" * EMP2 LDA K94 ERROR 94: NOT DUMMY OR MENTIONED TWICE. JSB ER.F * K94 DEC 94 SPC 3 * *********************************** * * NON-DUMMY & NON-SUBPROGRAM TEST * * *********************************** SPC 1 NDS.F NOP JSB NST.F NON-SUBPROGRAM TEST LDB F.A MUST NOT CPB F.SBF SUBPROGRAM NAME JSB ER.F A SET BY NST.F TO 25 LDA K37 LDB F.AT CPB DUM DUMMY? JSB ER.F ILLEGAL USE OF DUMMY VARIABLE JMP NDS.F,I SPC 1 K37 DEC 37 SKP * ********************* * * TYPE MODIFICATION * * ********************* SPC 1 * ENTRY: (A) = TENTATIVE TYPE. * F.TC = LAST CHAR OF TYPE. * EXIT: F.MFL = TYPE MODIFIED BY 'J', 'Y' AND *N. SPC 1 MTY.F NOP LDB A (B) = TENTATIVE TYPE. LDA F.CCW CHECK FOR 'Y' OPTION AND B100,0 SZA,RSS JMP MTY01 NO. CPB DBL YES. TYPE = DOUBLE ? LDB RE8 YES, CHANGE TO REAL*8. MTY01 LDA F.CCW GET 'J' OPTION. AND B10K SZA,RSS JMP MTY02 NO. CPB INT TYPE = INTEGER ? LDB DBI YES, CHANGE TO INTEGER*4. CPB LOG TYPE = LOGICAL ? LDB LO4 YES, CHANGE TO LOGICAL*4. * MTY02 STB F.MFL SAVE TYPE (SO FAR) JSB EXN.F FOLLOWED BY '*N' ? CPA B52 RSS JMP MTY.F,I NO. * JSB ICH.F YES. SWALLOW IT. JSB ICH.F NEXT. DIGIT ? SZB JMP TYP11 NO. ERROR. * ADA BM60 YES. (A) = ITS VALUE. STA F.IDI SAVE. JSB EXN.F LOOK AT NEXT ONE. SZB DIGIT ? JMP MTY05 NO. THAT'S O.K. * JSB ICH.F YES, READ IT OFFICIALLY. ADA BM60 YES. (A) = ITS VALUE. LDB F.IDI (B) = FIRST DIGIT. BLS,BLS 4*FIRST ADB F.IDI 5*FIRST BLS 10*FIRST ADB A WHOLE #. STB F.IDI SAVE IT. MTY05 LDB F.IDI BLF B<11:4> = LENGTH. ADB F.MFL B<15:12> = DEFAULT TYPE. LDA DFTLT SET UP TO SCAN TYPE-LENGTH TABLE. STA T1MTY SKP * SCAN TYPE-LENGTH TABLE FOR MATCH. * MTY03 LDA T1MTY,I NEXT ENTRY. AND BM20 TYPE & LENGTH PART. CPB A MATCH ? JMP MTY04 YES. GOT IT. ISZ T1MTY BUMP TO NEXT ENTRY. SZA MORE ? JMP MTY03 YES. JMP TYP11 NO. ILLEGAL STATEMENT. * MTY04 XOR T1MTY,I MATCH. FETCH NEW TYPE. RAR,RAR ALIGN. RAR,RAR STA F.MFL SAVE FINAL TYPE. JMP MTY.F,I EXIT. * T1MTY NOP F.MFL NOP CURRENT F.IM OF TYPE SPECIFICATION. BM60 OCT -60 SPC 2 * TYPE-LENGTH TABLE. FORMAT IS: * BITS 15:12 - UNMODIFIED TYPE. *  11:4 - LENGTH. * 3:0 - MODIFIED TYPE. * DFTLT DEF *+1 TYPE-LENGTH TABLE. ABS 10040B+1 INTEGER*2 = INT ABS 10100B+8 INTEGER*4 = DBI ABS 20100B+2 REAL*4 = REA ABS 20140B+6 REAL*6 = DBL ABS 20200B+10 REAL*8 = RE8 ABS 30040B+3 LOGICAL*2 = LOG ABS 30100B+9 LOGICAL*4 = LO4 ABS 50200B+5 COMPLEX*8 = CPX ABS 50400B+12 COMPLEX*16 = ZPX ABS 60140B+6 DOUBLE*6 = DBL ABS 60200B+10 DOUBLE*8 = RE8 OCT 100041 INTEGER*2(J) = INT OCT 100110 INTEGER*4(J) = DBI OCT 110043 LOGICAL*2(J) = LOG OCT 110111 LOGICAL*4(J) = LO4 OCT 120146 DOUBLE*6(Y) = DBL OCT 120212 DOUBLE*8(Y) = RE8 ABS 0 (END-OF-TABLE) SKP * *********** * * INTEGER * * *********** SPC 1 F.INP LDA INT JMP TYP02 SPC 1 * ******** * * REAL * * ******** SPC 1 F.REA LDA REA JMP TYP02 SPC 1 * ******************** * * DOUBLE PRECISION * * ******************** SPC 1 F.DBL LDA DBL JMP TYP02 SPC 1 * *********** * * COMPLEX * * *********** SPC 1 F.CPX LDA CPX JMP TYP02 SPC 1 * *********** * * LOGICAL * * *********** SPC 1 F.LOG LDA LOG TYP02 JSB MTY.F MODIFY TYPE BY 'Y', 'J' & *N. SKP * PROCESS ITEMS IN TYPE DECLARATIONS. * LDA DTP17 SUBSEQUENT ITEMS SKIP PREV JUNK. STA F.SPS TYP17 LDA F.LSF LAST STATEMENT FLAG SZA JMP TYP06 1ST STATEMENT OF PROGRAM CLA,INA STA F.TYP SET TYPE FLAG JSB INM.F INPUT NAME TYP03 LDA F.A,I GET OLD EXPLICIT TYPE FLAG AND K8 (CAN'T USE F..E INCASE IT IS DUM,ARR ALREADY) SZA,RSS IF NOT SET THEN JMP TYP05 PROCEED ALL OK * LDA F.IM GET OLD MODE CPA F.MFL SAME AS NEW ONE?? JMP TYP05 RETYPE IM THE SAME * LDA K83 JSB WAR.F RETYPE DIFFERENTLY JMP TYP08 SPC 1 TYP05 LDA F.MFL IOR K8 SET EXPLICID TYPE FLAG JSB DIM.F DEFINE F.IM JSB FA.F FETCH ASSIGN LDB F.IU LDA VAR SZB JMP TYP08 LDB F.AT CPB STRAB JMP TYP08 JSB DIU.F SET F.IU=VAR/CON TYP08 CLA STA F.TYP RESET TYPE FLAG TO INPUT DIMENSION. JSB IDC.F INPUT DIMENSION IF THERE. JMP CCRT SKP * FIRST LINE OF PROG. MAY BE FUNCTION STATEMENT. * TYP06 JSB EXN.F STRIP OFF PRECEDING BLANKS AND JSB IDN.F INPUT DNA: EAT SIX CHARS. LDA F.TC CPA B117 IS NEXT CHAR "O"? JMP TYP0F YES. "O" IN "FUNCTION". CLA,INA STA F.TYP SET TYPE FLAG LDA F.IM SZA JSB AI.F ASSIGN ITEM SZA JMP TYP01 LDA K17 NO MODE: JSB ER.F ILLEGAL OPERAND SPC 1 TYP0F JSB NTI.F PACK NAME TO F.IDI LDB F.DID GET DEF TO IT LDA B,I TEST FOR 'FUNCTION' CPA "FU" INB,RSS SO FAR SO GOOD JMP TYP11 BAD NEWS * LDA B,I NOW CPA "NC" "NC" INB,RSS OK JMP TYP11 BAD * LDA B,I LAST ONE HERE CPA "TI" OK? JSB ICH.F GET THE "N" CPA "N" IF NOT "N" JMP FUN01 * TYP11 LDA K28 ILLEGAL STATEMENT JSB ER.F TERMINATE STATEMENT (NO RETURN) SPC 1 TYP01 LDA F.A STA TYP.A SAVE F.A LDA K24 LDB F.NT SZB,RSS JMP TYP10 JSB WAR.F OPERAND NOT A NAME. RSS TYP10 JSB CRP.F OUTPUT CROSS REF. PAIR. LDA TYP.A STA F.A RESTORE F.A  JMP TYP03 SPC 1 DTP17 DEF TYP17 B400 OCT 400 VAR EQU B400 F.IU=2, VARIABLE OR CONSTANT STRAB OCT 2000 F.AT=2, STR-ABS - UNDEFINED TYP.A NOP SAVE F.A B1000 OCT 1000 B100K OCT 100000 DBI EQU B100K LO4 OCT 110000 RE8 OCT 120000 K83 DEC 83 BM20 OCT 177760 K17 DEC 17 K24 DEC 24 B117 OCT 117 'O' "N" OCT 116 "FU" ASC 1,FU "NC" ASC 1,NC "TI" ASC 1,TI K28 DEC 28 SPC 2 * SHORTEN DOUBLE INTEGER * SDI.F NOP LDA F.IM IS IT DOUBLE ? CPA DBI JMP SDI01 YES. * CPA LO4 DOUBLE LOGICAL ? LDA LOG YES, JUST CHANGE F.IM JMP SDI02 * * SDI01 DLD F.IDI TRY TO SHORTEN. SWP ASL 16 SOC FITS ? JMP SDI.F,I NO. LEAVE IT. * STB F.IDI YES. CHANGE TO SINGLE. LDA INT SDI02 STA F.IM JMP SDI.F,I EXIT. SKP * *********************************** * * INPUT DIMENSION (CONDITIONALLY) * * *********************************** SPC 1 IDC.F NOP LDA F.TC NEXT CHAR '(' ? CPA B50 JSB IND.F YES, INPUT DIMENSION. JMP IDC.F,I EXIT. SPC 1 ARR OCT 600 F.IU=3, ARRAY SPC 1 * ************* * * DIMENSION * * ************* SPC 1 F.DIM CLA,INA STA F.DCF SET DIM FLAG JSB INM.F INPUT NAME JSB IND.F INPUT DIMENSION. JMP CCRT CHECK FOR ',' OR 'C/R' . * IND.F NOP LDA F.AT DUMMY CHECK CCB CPA DUM CLB STB T0DIM T0=0 IF DUMMY, ELSE =-1 LDA F.A STA T2DIM T2=F, SAVE F JSB NST.F NON-SUBPROGRAM TEST LDB F.A CHECK IF NAME OF CURRENT MODULE CPB F.SBF IF SO SEND JSB ER.F ERROR 25 (A SET BY NST.F) * LDA K54 LDB F.IU CPB ARR JSB ER.F ARRAY NAME DEFINED TWICE LDWcA B52 LDB F.TC CPB B50 '(' RSS JSB ER.F ERR 42: ARRAY WITHOUT DECLARATOR LDA T0DIM JSB ISP.F INPUT SUBSCRIPT JSB MVW.F COPY BOUNDS INFO TO F.IDI: DEF F.IDI DEF DSTBL,I DEC 14 14 WORDS: UP TO 7 DIM, UPPER/LOWER. LDA NS NO. OF SUBSCRIPTS STA F.ND FOR AI.F (ALSO NEEDS F.VDM) LDA DIM SET F.AT. = DIM AS SPECIAL FLAG STA F.AT. JSB AI.F TO AI.F, TO BUILD A DIM ENTRY. LDB F.A SET LOWER BOUND CORRECTION TO ZERO. ADB K2 (FLAG TO AEA.F THAT IT IS DOING CLA PROLOGUE CODE, IF PROCESSING FORMAL.) STA B,I ISZ T2DIM EXCHANGE LINKS LDA F.A (USE LOCAL BECAUSE LDB T2DIM,I FETCH LINK IS FOLLED BY STA T2DIM,I POSSIBLE BCOM INA FLAG STB A,I CCB RECOVER ORGIONAL ADB T2DIM F.A STB F.A F.A=ORIGONAL F.A LDA ARR JSB DIU.F DEFINE F.IU=ARR JMP IND.F,I SPC 1 K3 DEC 3 K14 DEC 14 T0DIM BSS 1 SET T0 0(DUMMY) OR -1 T2DIM BSS 1 SAVE F K54 DEC 54 B50 OCT 50 NS BSS 1 NUMBER OF SUBSCRIPTS DIM OCT 6000 F.AT = DIM SKP * ********************** * * INPUT LIST ELEMENT * * ********************** SPC 1 * TO INPUT AN ITEM THAT CAN BE CONTAINED WITHIN A LIST AND INSURE * THAT THE ITEM HAS NOT BEEN TYPED AS DUMMY OR SUBPROGRAM, AND * COMPUTE THE WORD OFFSET INTO THE ITEM (USING SUBSCRIPTS). * CALLED ONLY BY THE DATA STATEMENT PROCESSOR. * * EXIT: F.A = A.T. ADDR OF ITEM. * (A) = WORD OFFSET FROM START OF ITEM. SPC 1 ILE.F NOP JSB NDS.F NON-DUMMY & NON-SUBPROGRAM TEST LDA F.IU CPA ARR JMP ILE01 F.IU=ARR * JSB TV.F TAG VARIABLE CLA SIMPLE VARIABLE, OFFSET = 0. JMP ILE.F,I DO}NE. * ILE01 JSB ISP.F INPUT SUBS. A>0: CONST, NO LOWER BOUNDS. JSB FA.F FETCH ASSIGNS (F.ND) LDB NS NO. OF SUBSCRIPTS CMB,INB ADB F.ND (# DIM) - (# SUBS) LDA K38 (ERROR #) SSB MORE SUBS THAN DIMS ? JSB ER.F YES. ERROR. * LDA F.D0+1 SAVE # WORDS/ELEMENT ACROSS CIO.F CALL. STA T1ILE LDA NS (A) = # SUBS. CCB COMPUTE ADDR LAST SUBSCRIPT. ADB A (# SUBS) - 1 BLS *2 ADB DSTBL (B) = ADDR LAST SUBSCR. JSB CIO.F COMPUTE ITEM OFFSET. LDA T1ILE RESTORE F.DO (2ND WD ONLY) STA F.D0+1 LDA F.CIO+1 (A) = OFFSET, ALWAYS ONE WORD (NON-EMA). JMP ILE.F,I EXIT. * * THE SUBSCRIPT TABLE. * DSTBL DEF *+1 BSS 14 MUST FOLLOW DSTBL. * T1ILE NOP TO SAVE F.D0 ACROSS CIO.F CALL. K38 DEC 38 SKP * *********************** * * COMPUTE ITEM OFFSET * * *********************** SPC 1 * CIO.F COMPUTES THE OFFSET, IN WORDS, OF AN ARRAY ELEMENT FROM THE * BASE OF THE ARRAY. THE NAME & SUBSCRIPTS MAY BE READ WITH ILE.F . * * ENTRY: F.A = A.T. ADDR OF ITEM. * (A) = # SUBSCRIPTS (MAY BE ZERO). * (B) = ADDR OF LAST SUBSCRIPT (FOLLOWED BY NEXT-TO-LAST) * IF ZERO, ALL SUBSCRIPTS ASSUMED TO BE ZERO. * EXIT: F.CIO = TWO-WORD OFFSET IN INTERNAL FORM. SPC 1 CIO.F NOP STB T1CIO SAVE ADDR LAST SUBSCR. CLB INITIALIZE F.CIO = 0 STB F.CIO STB F.CIO+1 STB T0CIO CLEAR OVERFLOW FLAG. CMA,INA,SZA,RSS NEGATE # SUBS. JMP CIO03 IF NONE, DONE. (CLEAR OFL & EXIT) * STA T2CIO ELSE SAVE AS LOOP COUNTER. JSB FA.F SET UP: F.D0 = # WDS PER ELEMENT. DLD F.D0 SAVE THAT. DST T5CIO LDA T2CIO -(#SUBS) CMA (#SUBS)-1 φ ALS *2 ADA F.LUB ADDR LOWER BOUND LAST SUBSCR. STA T4CIO * * LOOP THRU SUBS & DIMS COMPUTING OFFSET. * CIO01 LDB T4CIO,I F.A OF (NEGATED) LOWER BOUND. JSB GCD.F (A,B) = LOWER BOUND. ISZ T0CIO NOT CONSTANT: SOMEONE GOOFED! DST T6CIO SAVE. CLA (A,B)=0 IN CASE FORCED ZERO SUBSCRIPTS. CLB DLD T1CIO,I SUBSCRIPT. JSB DAD.F SUBTRACT LOWER BOUND. DEF T6CIO ISZ T0CIO IF TOO BIG. SSA ALSO BAD IF NEGATIVE. ISZ T0CIO SKP JSB DAD.F ADD RUNNING SUM. DEF F.CIO ISZ T0CIO IF TOO BIG. ISZ T2CIO WAS THAT FIRST SUBSCR ? RSS NO. JMP CIO02 YES. DONE. * DST F.CIO SAVE CURRENT VALUE. LDA T4CIO BACK UP TO PREVIOUS DIMENSION. ADA KM2 STA T4CIO DLD A,I (B) = F.A OF ITS SIZE. JSB GCD.F GET VALUE. ISZ T0CIO IF NOT CONSTANT. JSB DMP.F MULTIPLY PREV DIM SIZE BY DEF F.CIO CURRENT VALUE. ISZ T0CIO IF TOO BIG. DST F.CIO SAVE. LDA T1CIO BACK UP TO PREVIOUS SUBSCR. SZA IF FORCED ZERO SUBSCR, DON'T CHANGE. ADA KM2 STA T1CIO JMP CIO01 ARROUND WE GO * CIO02 JSB DMP.F * # WORDS PER ELEMENT. DEF T5CIO ISZ T0CIO IF TOO BIG. DST F.CIO SAVE OFFSET. JSB NWI.F COMPUTE F.D0 = TOTAL SIZE. DLD F.CIO COMPUTE OFFSET - SIZE. JSB DSB.F DEF F.D0 ISZ T0CIO IF OFL. SSA,RSS IF OFFSET >= SIZE, ISZ T0CIO ALSO SET OVERFLOW. LDA T0CIO OVERFLOW INDICATOR. CIO03 CLO SZA IF OVERFLOW OCCURED, STO RETURN OVERFLOW=1. JMP CIO.F,I DONE. F.CIO = OFFSET. * F.CIO OCT 0,0 COMPUTED ITEM OFFSET VALUE. T0CIO NOP OVERFLOW FLAG. T1CIO NOP ADTDR CURRENT SUBSCRIPT. T2CIO NOP LOOP COUNTER. T4CIO NOP ADDR F.A ENTRY CURRENT LOWER BOUND. T5CIO BSS 2 # WORDS PER ELEMENT. T6CIO BSS 2 TEMP. * KM2 DEC -2 K39 DEC 39 DUM OCT 5000 F.AT=5, RELATIVE WITHIN DUMMY LOC K8 DEC 8 K19 DEC 19 K11 DEC 11 B72 OCT 72 B100 OCT 100 SKP * ******************* * * INPUT SUBSCRIPT * * ******************* SPC 1 * TO INPUT THE SUBSCRIPT LIST. * ENTRY: (A)=0 DIMENSIONS OF FORMAL PARAMETER. * >0 SUBSCRIPTS, MUST BE CONSTANT. * <0 DIMENSIONS OF NON-FORMAL, MUST BE CONSTANT. * * EXIT: NS=NO. OF SUBSCRIPTS * S-TABLE: DIMENSIONS: F.A'S OF LOWER & UPPER BOUNDS, * AS IN A.T. * SUBSCRIPTS: 2-WORD VALUES OF SUBSCRIPTS. * F.VDM: 100B IF ANY VARIABLE DIMENSIONS. * F.DIS: 40B IF ANY DOUBLE INTEGER BOUNDS. * ISP.F NOP STA T0ISP T0ISP = INDICATOR OF ALLOWABLE SUBSCRIPTS. CLB STB F.VDM CLEAR VARIABLE DIMENSIONS FLAG. STB F.DIS AND DOUBLE INTEGER SUBSCRIPTING FLAG. STB NS NO. OF SUBSCRIPTS =0 LDB DSTBL T4ISP = S-TABLE POINTER. STB T4ISP LDA B50 MUST BE FOLLOWED BY '('. JSB TCT.F * * START OF SUBSCRIPT INPUT LOOP. * ISP01 CCA SET T3ISP TO -1 TO INDICATE THAT STA T3ISP LOWER BOUND MAY BE ALLOWED HERE. ISP02 LDA T0ISP RESTORE (A) SZA JMP ISP06 DIMENSIONS NOT DUMMY. * JSB EXN.F EXAMINE NEXT CHARACTER SOC LETTER ? JMP ISP06 NO. CHARACTER IS A DIGIT OR DELIMITER. SKP * INPUT VARIABLE DIMENSION. * JSB IOP.F INPUT THE JSB TV.F DIMENSION JSB NCT.F MUST NOT BE A CONSTANT LDA F.VDM SET THE VARIABLE DIMENSIONS FLAG. IOR B100 STA F.VDM LDA F.AT MUST BE FORMAL PARAMETER, CPA DUM RSS CPA COM OR IN COMMON, RSS CPA BCOM OR IN LABELLED COMMON. JMP ISP10 * LDA K39 NON-DUMMY DIMENSION VARIABLE JSB ER.F NAME USED WITH DUMMY ARRAY NAME * * INPUT A CONSTANT DIMENSION OR SUBSCRIPT. * ISP06 JSB IDN.F INPUT DNA JSB SDI.F SHORTEN IF DOUBLE. JSB ITS.F INTEGER TEST LDA K19 LDB F.NT IS IT A CONSTANT? SZB,RSS JSB ER.F NO. LOSE. LDA T0ISP ARE WE DOING SUBSCRIPT OR DIMENSION ? CMA,SSA,INA,SZA SUBSCRIPT OR DIMENSION ? (SKIP IF <=0) RSS SUBSCRIPT. SKIP. JMP ISP09 DIMENSION. GO CHECK OUT LOWER BOUNDS. * * SUBSCRIPT. PUT CONSTANT VALUE IN S-TABLE. * LDA F.IM CONSTANTS ONLY. 1/2 WORD INT ? ELA E=1 IFF INT*4 DLD F.IDI (A,B) = CONST IF INT*4 (ELSE IS (A) ONLY) SEZ WHICH ? JMP ISP08 INT*4, GOT IT. * LDB A INT*2, EXTEND IT. ASR 16 SWP ISP08 DST T4ISP,I PUT IN S-TABLE. ISZ T4ISP ISZ T4ISP JMP ISP20 GO LOOK FOR ',' OR ')'. SKP * DIMENSION, LOWER BOUNDS ALLOWED. * ISP09 JSB AI.F ENTER CONSTANT IN A.T. LDB F.A GET ITS VALUE. JSB CFC.F NOP (CAN'T HAPPEN) LDB F.IM AND ITS TYPE. CPA B100K IF (UPPER) BITS = 100000, LDB DBI THEN ALWAYS TREAT AS DBI, LDA F.CCW UNLESS 'S' OPTION. RAL SSA LDB F.IM LDA B40 F.DIS BIT (CAN'T BE EMAP L.B.) CPB DBI CONSTANT DOUBLE INT BOUND OR -32768 ? STA F.DIS YES. SET THE F.DIS BIT. ISP10 LDA F.A (A) = F.A OF BOUND. ISZ T3ISP DO WE ALREADY HAVE A LOWER BOUND ? JMP ISP12 YES. CAN'T HAVE ANOTHER. * LDB F.TC NO. IS THIS A LOWER BOUND ? CPB B72 I.E., FOLLOWED BY ':' ? RSS JMP ISP11 NO. GO SET LOWER BOUND = 1. * STA T4ISP,I YES. SET LOWER BOUND IN PLACE, ISZ T4ISP ADVANCE TO UPPER BOUND, JMP ISP02 AND GO GET THAT. * ISP11 STA T5ISP NO LOWER BOUND. SAVE F.A OF UPPER WHILE.. CLA,INA WE INVENT A LOWER BOUND = 1, JSB EIC.F STA T4ISP,I PUT IN S-TABLE, ISZ T4ISP AND BUMP TO PLACE FOR UPPER BOUND. LDA T5ISP NOW (A) = F.A OF UPPER BOUND. ISP12 STA T4ISP,I PUT UPPER BOUND IN S-TABLE. ISZ T4ISP * * VERIFY THAT UPPER BOUND >= LOWER BOUND. * LDB T4ISP FETCH LOWER BOUND IF CONSTANT. ADB KM2 LDB B,I (B)=F.A OF LOWER BOUND. JSB GCD.F WELL ? JMP ISP20 NOT CONST. * DST T6ISP CONSTANT. SAVE IT. CCB FETCH UPPER BOUND IF CONSTANT. ADB T4ISP LDB B,I (B)=F.A OF UPPER BOUND. JSB GCD.F WELL ? JMP ISP20 NOT CONST. * JSB DSB.F CONST. TAKE: (UPPER)-(LOWER) DEF T6ISP JMP ISP99 OVERFLOW. TOO BIG. * SSA LOWER > UPPER ? JMP ISP90 YES. CAN'T HAVE THAT EITHER. * SZA SIZE > 65536 ? JMP ISP15 YES. ALWAYS DOUBLE INTEGER. * LDA F.CCW NO. IS 'S' OPTION SET ? RAL SSA,RSS IF SO, <= 65536 IS SINGLE. SSB,RSS ELSE <= 32768 IS SINGLE. JMP ISP20 SINGLE. * ISP15 LDA B40 DOUBLE INTEGER DIM, SET THE BIT. STA F.DIS SET F.DIS * * BUMP # SUBSCRIPTS, CHECK FOR END. * ISP20 ISZ NS LDA NS AT LIMIT CPA K7 OF 7 DIMENSION ? JMP ISP22 YES. * LDA F.TC NO. MORE ? CPA B54 I.E., DELIMETER IS ',' ? JMP ISP01 YES. GET ANOTHER. * ISP22 JSB RP.F NO. MUST END WITH ')' . JMP ISP.F,I DONE. * ISP90 LDA K11 0LOWER BOUND > UPPER BOUND. JSB ER.F * ISP99 LDA K84 DIMENSION OVERFLOW. JMP F.ABT SPC 2 K84 DEC 84 T0ISP NOP SAVE ENTRY (A) VALUE T3ISP NOP LOWER BOUND FLAG. T4ISP NOP S-TABLE POINTER. T5ISP NOP TEMP FOR F.A OF UPPER. T6ISP BSS 2 TEMP FOR VALUE OF UPPER. SKP * ******************** * * COMMON PROCESSOR * * ******************** SPC 1 * IF UNLABELLED, GO FIND LAST ELEMENT. * F.COM CLA,INA STA F.DCF SET COMMON FLAG CLA CLEAR THE EMA FLAG. STA T1COM JSB EXN.F EXAMINE NEXT CHAR. CPA B57 '/' ? RSS YES, PROBABLY LABELLED. JMP COM07 NO, BLANK. * COM03 JSB ICH.F READ THE '/'. COM04 JSB EXN.F LOOK FOR ANOTHER. CPA B57 IS IT '//' ? JMP COM06 YES, BLANK. * * LABELLED. PROCESS LABEL. * JSB IDN.F INPUT COMMON LABEL. LDB F.NT MAKE SURE IT'S A NAME. SZB,RSS I.E., F.NT=0 SZA,RSS AND F.IM#0. JMP COM09 IF NOT. STB F.IM YES. SET F.IM=0, ISZ F.LCF AND SET FLAG FOR AI.F . JSB AI.F ENTER IN ASSIGNMENT TABLE. LDA F.AT GET ITS TYPE CPA BCOMI IF ALREADY BCOMI THEN JMP COM08 ADDING TO EXISTING LABEL * LDA BCOMI DEFINE F.AT JSB DAT.F TO BCOM JSB TS.F FLAG AS A SUBROUTINE (IT IS EXTERNAL) LDA F.A NOW REDEFINE F.AF JSB DAF.F (TS.F SETS IT TO ZERO) COM08 LDA F.EM SAVE EMA FLAG. STA T1COM LDB F.A SET FOR TRACK DOWN LDA F.TC DO WE HAVE THE PROPER DELIMITER? CPA B57 WELL '/' JMP COM10 GOOD GO TRACK DOWN THE END OF TH LIST * COM09 LDA K4 ERROR WRONG DELIMITER, CONSTANT JSB ER.F OR MORE THAN 6 CHAR. ABANDON THE STMT. SKP * CHzAIN THRU COMMON LIST TO FIND END. * COM06 JSB ICH.F READ THE SECOND / IN // COM07 LDB F.BCM SET UP BLANK COMMON HEADER. COM10 STB CT01 SET HEAD COM11 STB CT02 SET CURRENT ADDRESS JSB FL.F FETCH LINK CPA CT01 POINT AT HEAD? JMP COM12 YES THIS IS IT STA B NO AROUND JMP COM11 WE GO. * * GET AND CHECK OUT VARIABLE NAME. * COM12 JSB INM.F GET THE VARABLE NAME JSB NDS.F NON-DUMMY & NON-SUBPROGRAM TEST. LDA F.A UP DATE STA LCOM LAST COMMON LDA K36 SEE IF ALREADY IN COMMON. LDB F.AT CPB COM JSB ER.F ILLEGAL USE OF COMMON NAME CPB BCOM IF ALREAD IN COMMON JSB ER.F ILLEGAL TO RE-ENTER IT. LDA F.IU IF NOT YET TAGED SZA,RSS TAG JSB TV.F TAG AS VARIABLE LDA T1COM IF EMA COMMON, SZA JSB DEM.F SET EMA. * * IF LABELLED, BUILD & LINK-IN A BCOMI ENTRY. * LDB CT01 LABELLED ? LDA COM (A=F.AT FOR BLANK) CPB F.BCM JMP COM13 BLANK. SKIP THIS. * LDA BCOMI SET F.AT. = BCOMI FOR AI.F STA F.AT. JSB AI.F BUILD BCOMI ENTRY. (USES F.EM) LDA CT01 TO DESCRIBE IT LDB F.A SET POINTER ADB K2 TO STA B,I THE MASTER ENTRY LDB LCOM EXCHANGE LINKS JSB EL.F OF (F.A)=BCOMI, (B)=ITEM. LDA BCOMI SET F.AT TO JSB DAT.F BCOMI LDA LCOM RESTORE STA F.A F.A OF THE VARABLE LDA BCOM (A) = F.AT FOR BCOM. SKP * DEF F.AT, INPUT ANY DIM'S, LINK INTO LIST & GO ON. * COM13 JSB DAT.F DEFINE F.AT=COM OR BCOM JSB FA.F RESTORE ASSIGNS FOR DIM PROCESSOR JSB IDC.F INPUT DIMENSION (IF THERE) LDB CT02 EXCHANGE LINKS. JSB EL.F OF (F.A)=ITEM, (B)=PREV. ITEM. l LDA F.TC DELIMITER: CPA B57 IF "/", JMP COM04 THEN START OF NEW BLOCK. * CPA B54 ELSE MUST BE COMMA, RSS (YES) JMP F.CRT OR END OF STATEMENT. * JSB EXN.F COMMA. FOLLOWED BY "/" ? CPA B57 JMP COM03 YES. START OF NEW BLOCK. * LDA LCOM NO. SET UP CT02 FOR NEXT ITEM. STA CT02 JMP COM12 AND GO GET IT. SPC 1 LCOM BSS 1 LAST COMMON ASSIGNMENT POINTER K36 DEC 36 COM OCT 4000 F.AT=4 (COMMON) BCOM OCT 3000 F.AT=BCOM BCOMI OCT 7000 F.AT=BCOMI CT01 NOP CT02 NOP T1COM NOP F.EM OF MASTER. K2 DEC 2 K4 DEC 4 B15 OCT 15 B57 OCT 57 NOP 1ST COMMON ASSIGN PTR. DEF *-1 DUMMY LINK TO SELF F.BCM DEF *-2 LINK TO DUMMY B40 OCT 40 SKP * ************************* * * EQUIVALENCE PROCESSOR * * ************************* SPC 1 * ADDS EQUIVALENCE GROUPS TO THE EQUIVALENCE TABLE IN THE FORM: * (-1) (LINE#) (ITEM#1),,,,,(ITEM#N) * WHERE THE ITEMS HAVE THE FORM: * (F.A) (#SUBS) (LAST SUB),,,,(FIRST SUB) * (WHICH, SINCE THE EQUIVALENCE TABLE GROWS DOWNWARDS, PUTS * THE SUBSCRIPTS IN FOREWARDS ORDER FOR CIO.F PROCESSING.) * AND ITEMS WITHOUT SUBSCRIPTS ARE PADDED WITH ONE EXTRA * WORD (LEAVING ROOM FOR 2-WORD OFFSET LATER). SPC 1 F.EQU LDA F.E COPY F.E STA T2GRE (WILL UPDATE AFTER A GOOD GROUP) EQU01 JSB ICH.F REQUIRE '(' CPA B50 CCA,RSS (A=-1) JMP EQU90 NO. ERROR. * JSB GREW2 WRITE (-1). LDA F.LNN WRITE (LINE #) JSB GREW2 * EQU02 JSB ISY.F GET SYMBOL. LDA F.A WRITE (F.A) JSB GREW2 JSB NDS.F MUST NOT BE DUMMY OR SUBROUTINE. CLA DEFAULT IS ZERO-DIM. STA NS LDB F.TC ANY SUBSCRIPTS ? CLA,INA (MUST BE CONgSTANT) CPB B50 WELL ? JSB ISP.F YES. GET THEM. LDA NS (A) = # OF SUBSCR. JSB GREW2 WRITE (# SUBS) SZA,RSS ANY SUBSCRIPTS ? JMP EQU04 IF NONE. * ALS 2*(# SUBS) ADA DSTBL LWA+1 SUBSCRIPT LIST. EQU03 ADA KM2 GO BACK TO PREV. SUBSCR. STA T1EQU INA WRITE 2ND WORD FIRST. LDA A,I JSB GREW2 2ND WORD. LDA T1EQU,I FIRST WORD. JSB GREW2 LDA T1EQU WAS THAT THE FIRST ONE ? CPA DSTBL JMP EQU05 YES. DONE. JMP EQU03 NO. KEEP GOING. * EQU04 JSB GREW2 NO SUBSCR. LEAVE EXTRA WORD. * EQU05 LDA F.TC MORE IN THIS GROUP ? CPA B54 (IE COMMA) JMP EQU02 YES. DO THEM. * JSB RP.F REQUIRE ')' LDB T2GRE MAKE THE GROUP PERMANENT. STB F.E CPA B54 ANOTHER GROUP ? JMP EQU01 YES. DO IT. * CPA B15 END ? JMP F.CRT YES. ALL DONE. * EQU90 LDA K28 SYNTAX ERROR IN EQUIVALENCE. JSB ER.F DOWN THE TUBES. * T1EQU NOP * * SUBROUTINES TO READ & WRITE 'DO' STACK. * GRER2 NOP READ EQUIV TABLE INTO (A) USING (T2GRE) CCB BACK UP T2GRE. ADB T2GRE STB T2GRE LDA B,I (A) = DATA. JMP GRER2,I EXIT. * GREW2 NOP WRITE (A) INTO EQUIV TABLE USING (T2GRE) LDB F.LO TOP OF A.T. + 1 CMB -F.LO-1 (F.LO: MIN ALLOWABLE F.E) ADB T2GRE (T2GRE-1)-F.LO SSB NEW T2GRE < F.LO ? JMP F.OFE YES, MEM OVERFLOW. * ADB F.LO NEW T2GRE = T2GRE-1 STB T2GRE STA B,I STORE DATA. JMP GREW2,I EXIT. * T2GRE NOP POINTER INTO DO STACK. SKP * ********************** * * FUNCTION PROCESSOR * * ********************** SPC 1 F.FUN CLA CLEAR EXPLICIT TYPINUG FLAG. STA F.MFL FUN01 CLA,INA SET FUNCTION FLAG. STA F.SFF JMP SUBP0 START IT UP. SPC 1 * ************************ * * SUBROUTINE PROCESSOR * * ************************ SPC 1 F.SUB CLA CLEAR EXPLICIT TYPING FLAG. STA F.MFL SUBP0 LDB F.LSF 1ST STATEMENT? SZB JMP SUBP1 YES * NFSTM LDA K34 JSB ER.F PROG/SUBR/FUNCTION NOT 1ST STATM SPC 1 K7 DEC 7 K34 DEC 34 SPC 1 SUBP1 CLA SET STMT. LEVEL BACK TO ZERO STA F.SPF INCASE IT IS A TYPED FUNCTION LDA K7 SUBR/FUNC = TYPE 7 STA F.PTY ISZ F.DCF SET DIM,COM FLAG TO FOOL AI.F IN CASE OF '(' JSB INM.F INPUT NAME JSB SPN.F SET THE PROGRAM NAME. LDB F.A STB F.SBF SET SUBPROGRAM FLAG CLA SET F.AF=0 JSB DAF.F TO TERMINATE FORMALS LINKED LIST. LDA F.MFL MODE FLAG SET? LDB A IOR K8 SET EXPLICIT TYPE FLAG SZB TYPE BEING SET? JSB DIM.F YES. DEFINE F.IM LDA F.TC CPA B54 STRING AFTER? JMP SUBP6 YES GO HANDLE * CPA B15 JMP SUBP6 F.TC=C/R: NO ARGUMENTS. * JSB IDL.F INPUT DUMMY LIST. LDB F.SBF RESTORE F.A OF SUBR/FUCT, STB F.A JSB DAF.F SO CAN SET F.AF = F.A OF 1ST FORMAL. SUBP4 LDA F.DO INITIALIZE ????????????????????? STA F.D F.D=F.DO JMP PROG9 C/R TEST SPC 1 SUBP6 LDB F.SFF FUNCTION? LDA B52 SZB JSB WAR.F YES. WARNING 42: NO ARGUMENT LIST JMP SUBP4 SKP * ********************************** * * BLOCK DATA STATEMENT PROCESSOR * * ********************************** * F.BLK LDA K2 SET PROGRAM TYPE SWITCH STA F.SFF TO 2 LDA F.LSF TEST IF FIRST STATEMENT SZA,rRSS WELL? JMP NFSTM NO GO BITCH * LDA K7 SET UP TO INPUT STA F.PTY PROGRAM NAME JSB IDN.F INPUT POSSIBLE BLOCK DATA NAME LDA F.NT GET ONE? SZA JMP PROG1 NO BITCH * JMP PROG9 GO TEST FOR PRAM STRING. SPC 3 * ******************** * * SET PROGRAM NAME * * ******************** SPC 1 SPN.F NOP JSB NTI.F MOVE NID TO F.IDI LDA F.DID JSB MPN.F MOVE PROG NAME TO PBUF,ERBF,HEAD JMP SPN.F,I EXIT. SPC 1 T1PRO BSS 1 TO SAVE PBUF POINTER. T2PRO BSS 1 T3PRO BSS 1 K35 DEC 35 K93 DEC 93 BL2B ASC 1, SKP * ******************************* * * PROGRAM STATEMENT PROCESSOR * * ******************************* * * READ "PROGRAM PNAME,(TYPE,PRIOR,RES,EMULT,HR,MIN,SEC,MS)" * TEXT FOLLOWING ")" TO EXTEND NAM RECORD SPC 1 F.PRO LDA F.LSF 1ST STATEMENT? SZA,RSS JMP NFSTM NO, ERROR LDA K4 STA F.PTY DEFAULT LG BKGND DISK RESIDENT JSB EXN.F EXAMINE NEXT CHAR. SZB,RSS DIGIT? JMP PROG1 YES. LOSE. CPA B15 'C/R' CLA,INA,RSS JMP PROG4 STA F.CC F.CC=1 JMP PROG6 SPC 1 PROG1 LDA K24 JSB ER.F ILLEGAL CONSTANT. SPC 1 PROG4 JSB IDN.F INPUT PROGRAM NAME SZA IF NO NAME F.IM=0 JSB SPN.F NAMED. SET THE PROGRAM NAME. LDA F.TC CPA B50 '(' JMP PROG7 CPA B54 ',' JMP PROG7 PROG6 JMP F.CRT C/R TEST SPC 1 PROG7 LDA F.DNB ADDR OF PBUF+9 ADA K9 STA T1PRO PARAM POINTER ADA K8 SET UP THE NAM BUFFER STOP STA T2PRO POINTER PROG8 JSB EXN.F EXAMINE NEXT CHARACTER SZB,RSS DIGIT? JMP PROG2 YES. JSB ICH.F NO. READ IT FOR REAL. CPA B54 F.TC = ','v  ? RSS JMP PROG3 ISZ T1PRO NO. NULL PARAM. PROGA LDB T2PRO LOC OF PBUF+17 CPB T1PRO ALL PARAMS READ? JMP PROG3 YES. JMP PROG8 SPC 1 PROG2 JSB IDN.F INPUT DO NOT ASSIGN JSB SDI.F SHORTEN IF DOUBLE INTEGER. LDB F.IM MUST BE SINGLE INTEGER NOW. LDA K14 ELSE ERROR 14. CPB INT RSS O.K. JSB ER.F * LDA F.IDI DIGIT STRING JUST INPUT STA T1PRO,I STORE INTO PBUF ISZ T1PRO BUMP PBUF POINTER LDA F.TC CPA B54 ',' JMP PROGA PROG3 CPA B51 ")" ? JSB ICH.F GET THE NEXT CHARACTER PROG9 LDA F.TC DELIMETER ? CPA B54 IF COMMA THEN RSS SET UP NAM RECORD COMMENT JMP PRO12 NOT COMMA MUST BE CARRAGE RETURN * LDA F.DNB SET UP TO ACCESS THE NAM BUFFER ADA K17 STA T2PRO ADDRESS OF WORD 17 LDA K35 STA T3PRO CHARACTER COUNT PRO10 JSB IC.F CPA B15 JMP PRO12 END OF STMT. * LDB T3PRO CPB K121 IF NO MORE ROOM, JMP PRO11 TEST FOR ALL BLANKS. * SLB,INB ALF,SLA,ALF XOR T2PRO,I XOR B40 INSERT/REMOVE BLANK STA T2PRO,I STUFF CHAR IN NAM REC STB T3PRO SLB,BRS ISZ T2PRO BUMP POINTER CPA BL2B IF TRAILING BLANKS, JMP PRO10 DON'T UPDATE WORD COUNT. * STB F.DNB,I ELSE UPDATE WORD COUNT, JMP PRO10 AND GO FOR MORE. * PRO11 CPA B40 87TH CHAR: IF BLANK, JSB ICH.F LOCATE NEXT NON-BLANK (ERROR IF ANY) PRO12 LDB F.PTY NOW CHECK PROG TYPE. LDA K61 CPB K5 IF TYPE = 5, JSB WS1.F ISSUE A SEGMENT START OPCODE. JMP F.CRT MUST NOW BE END OF STMT. * K26 DEC 26 K121 DEC 121 K61 DEC 61 K72 DEC 72 SKP * ****************** * * DATA PROCESSOR * * ****************** SPC 1 * CAUTION: F.SPS IS NOT ALWAYS SET. * INITIALIZE DO TABLE FOR LIST ITEMS. * F.DAT LDA F.DO SET TO WRITE INTO DO TABLE. STA T2GRE * * NEXT LIST ITEM: GET SYMBOL & DO ERROR CHECKING. * DATA0 JSB ISY.F INPUT SYMBOL JSB NDS.F CAN'T BE DUMMY OR SUBROUTINE. LDA F.IU IF NOT ARRAY, CPA ARR RSS JSB TV.F MUST BE VARIABLE. (REQ'D FOR AA.F) LDA K93 LDB F.EM EMA ? CLE,SZB (E=0) JSB ER.F YES. CAN'T DO EMA. LDB F.SFF BLOCK DATA ? CPB K2 CME YES. MUST BE LABELLED COMMON. LDA K72 (ERROR NUMBER FOR COMMON) LDB F.AT HOW 'BOUT BLANK COMMON ? CPB COM JSB ER.F YUP. IT NEITHER. CPB BCOM LABELLED COMMON ? CME YES. MUST BE BLOCK DATA. SEZ EITHER OF ABOVE VIOLATED ? JSB ER.F YES. ERROR 72. CPB BCOM IF NOT BLOCK COMMON, RSS JSB AA.F ASSIGN VARIABLES NOW. * * IF ARRAY NAME ONLY, USE WHOLE ARRAY, * OTHERWISE USE SIMPLE ITEM OR ARRAY ELEMENT. * LDA F.IU ITEM USAGE. LDB F.TC NEXT CHAR. CPA ARR IF NOT ARRAY, CPB B50 OR ARRAY AND FOLLOWED BY '(', JMP DATA1 THEN JUST DO SIMPLE ITEM. * JSB NWI.F ELSE WHOLE ARRAY. SET F.D0 = # WORDS. CLA,RSS (A) = OFFSET = 0. DATA1 JSB ILE.F INPUT LIST ELEMENT: (A) = OFFSET. SKP * SAVE THE OFFSET, F.A & # WORDS IN DO TABLE. * JSB GREW2 OFFSET. LDA F.A F.A JSB GREW2 LDA F.D0+1 NUMBER OF WORDS PER ITEM JSB GREW2 * * IF ',' THEN READ MORE ITEMS, ELSE READ '/' & DATA. * LDA F.TC CPA B54 , ? JMP DATA0 YES. GET MORE VARIABLES. * LDA B57 ELSE MUST wBE '/' JSB TCT.F F.TC-TEST LDA T2GRE REMEMBER END OF DO TABLE. STA T3DAT CLA START READING VALUES: STA KBAR REPEAT COUNT = 0 (NONE) STA T2DAT # WDS LEFT CURRENT ITEM = 0. LDA F.DO SET UP TO READ LIST BACK. STA T2GRE * * READ ANOTHER LIST ITEM. * DATA6 LDA T2DAT ANY LEFT IN CURRENT ITEM ? SZA JMP DATA4 YES, DO THAT FIRST. * JSB GRER2 T4DAT = OFFSET. STA T4DAT JSB GRER2 F.A = ITEM. STA F.A JSB GRER2 T2DAT = # WORDS IN ITEM. STA T2DAT JSB FA.F FETCH ITEM ASSIGNS. LDA F.IM T0DAT = LIST ITEM MODE. STA F.EIM (SET UP FOR IDN.F: DBL VS RE8) STA T0DAT LDA KBAR UNFINISHED REPEAT COUNT ? SZA JMP DAT13 YES. USE THAT CONSTANT. SKP * READ ANOTHER DATA VALUE. * DATA4 JSB EXN.F IS IT A QUOTED STRING ? CPA B47 JMP DAT30 YES. DONE ELSEWHERE... * JSB IDN.F INPUT DO NOT ASSIGN SZA JMP DATA5 F.IM .NE. 0, GOT ONE. * LDA B50 '(' OTHERWISE, MUST BE COMPLEX CONSTANT. JSB TCT.F F.TC-TEST ISZ F.SXF SET COMPLEX FLAG. JSB IDN.F TRY AGAIN. CPA CPX COMPLEX ? RSS CPA ZPX OR DOUBLE COMPLEX ? RSS YES. (IF NAME, CAUGHT LATER) JMP ERDAT NO. GENERAL TYPE MISMATCH ERROR. * * MAKE SURE IT'S A CONSTANT. IF FOLLOWED BY '*', * PROCESS THE REPEAT COUNT. * DATA5 LDA B54 LDB F.NT SZB,RSS JSB ER.F ERR 44: NAME IN CONSTANT LIST. JSB SDI.F ALWAYS USE SHORT INTEGERS IF POSSIBLE. LDB F.TC B=NEXT CHAR LDA KBAR ALREADY HAVE REPEAT ? SZA JMP DAT04 YES. DON'T CHECK FOR ANOTHER. * ISZ KBAR NO. SET KBAR=1 IN CASE NO REPEAT. CPB B52 YG WELL ? RSS YES. PROCESS IT. JMP DAT04 NO. USE REPEAT = 1. * LDB F.IM REPEAT MUST BE SINGLE INTEGER. LDA K26 ELSE ERROR 26. CPB INT RSS JSB ER.F NO, ERROR. * LDB F.IDI SET KBAR = REPEAT COUNT. STB KBAR SSB,RSS MAKE SURE REPEAT > 0. SZB,RSS WELL ? JMP ERD71 NEGATIVE OR ZERO, ERROR. JMP DATA4 YES. GO GET REPEATED DATA. * B47 OCT 47 SINGLE QUOTE. ZPX OCT 140000 F.IM = ZPX SKP * CHECK FOR HOLLERITH DATA. IF SO, SET T5DAT = -COUNT. * DAT04 LDA F.IM SAVE F.IM OF CONSTANT. STA T1DAT CLA SET T5DAT=0, STA T5DAT THE HOLLERITH DATA LENGTH. CPB B110 F.TC = 'H' ? RSS YES. JMP DAT13 NO. NOT HOLLERITH. * LDB F.IM YES. MUST BE SINGLE INTEGER. CPB INT RSS YES, O.K. JMP ERDAT ELSE ERROR. * LDB F.IDI AND > 0. LDA K20 CMB,SSB,INB,SZB (NEGATE, SKIP IF WAS <= 0) RSS O.K. (E=1) JSB ER.F BAD HOLLERITH COUNT. (ERR 20) * STB T7DAT SAVE FOR LOOP COUNTER. BRS - # WORDS HOLLERITH. STB T5DAT SAVE AS FLAG. ADB F.D0+1 MORE THAN ONE ELEMENT ? SSB JMP DAT15 YES. LONG HOLLERITH. * * COPY SHORT HOLLERITH DATA TO F.IDI * LDA F.DID NO. JUST COPY TO F.IDI RAL (BYTE ADDR) STA T6DAT LDA BL2B SET F.IDI TO BLANKS. STA F.IDI STA F.IDI+1 STA F.IDI+2 STA F.IDI+3 DAT14 JSB IC.F COPY THE CHARACTERS. XOR B40 (CHANGES BLANK TO THE CHAR) LDB T6DAT (B) = CHAR ADDR TO PUT IT. CLE,SLB,ERB (B) = WORD ADDR. HIGH OR LOW BYTE ? RSS LOW. LEAVE CHAR LOW. ALF,ALF HIGH. MOVE IT UP. XOR B,I CHANGE BLANK TO THE CHAR.  STA B,I ISZ T6DAT BUMP ADDRESS. ISZ T7DAT BUMP COUNTER. JMP DAT14 LOOP. * JSB ICH.F READ THE DELIMETER. SKP * CHECK ITEM SIZE, MODE VS. DATA. * DAT13 LDA F.D0+1 ITEM SIZE. ADA T5DAT - HOLLERITH SIZE. SSA IF HOLLERITH BIGGER, JMP ERDAT SEND ERROR * LDA T5DAT IF HOLLERITH, SZA JMP DATA9 THEN O.K. * LDA T1DAT ELSE MUST CHANGE STA F.IM DOUBLE INTEGER JSB SDI.F BACK TO SINGLE IF POSSIBLE, LDA F.IM SO THAT STA T1DAT AFTER REPEAT, DON'T FAIL. CPA T0DAT DOES TYPE MATCH ? JMP DATA9 YES. O.K. * ALF IS MIXED SINGLE/DOUBLE INT ? IOR T0DAT (A) = 4/ITEM TYPE, 8/0, 4/CONST TYPE. CPA KK02 DBLINT / INT ? RSS YES. JMP DAT11 NO. GO CHECK LOGICAL. * LDB F.IDI CHANGE CONST TO DOUBLE INT. ASR 16 SWP DST F.IDI LDA DBI REMEMBER WE DID IT. STA T1DAT JMP DATA9 VOILA ! * DAT11 CPA KK05 LOG / DBLLOG ? RSS YES. O.K. AS IS. JMP ERDAT ALL ELSE IS BAD. SKP * START OUTPUT OF REGULAR DATA ITEM WITH REPEAT. * DATA9 LDA F.D0+1 SEND OPERATOR. ADA K3 HAS F.A, OFFSET, REPEAT. ALF,ALF IOR K51 JSB WS1.F LDA F.A F.A JSB WS1.F LDA T4DAT OFFSET. JSB WS1.F CLB COMPUTE # ITEMS LEFT IN ARRAY. LDA T2DAT DIV F.D0+1 (A) = # ITEMS LEFT. LDB KBAR B = REPEAT LEFT CMB,INB ADB A (#ITEMS) - (#CONST) SSB,RSS TAKE THE SMALLER OF THE TWO. LDA KBAR STA T6DAT CAN SEND REPEAT OF THAT MANY. LDB T5DAT IF HOLLERITH, SZB IOR B100K SET SIGN TO FLAG THAT. JSB WS1.F * * SEND THE DhATA TO THE PASS FILE. * LDA F.D0+1 THIS MANY WORDS. CMA,INA STA T7DAT LDA F.DID FROM HERE. STA T8DAT DAT17 LDA T8DAT,I COPY THEM. JSB WS1.F ISZ T8DAT ISZ T7DAT JMP DAT17 JMP DAT08 DONE. GO UPDATE STATE. SKP * LONG HOLLERITH. MUST FILL PART OF AN ARRAY. * DAT15 CLB SEE IF EXACT # OF ITEMS. LDA F.IDI DIV F.D0+1 SZB I.E., REMAINDER = 0 ? (OR QUOTIENT ODD) JMP ERD71 NO. ILLEGAL PARTIAL ITEM. * LDB KBAR REPEAT > 1 ? CPB K1 CLE,SLA,ERA (REST OF EXACT-MULTIPLE CHECK) JMP ERD71 YES. ERROR. * LDA T2DAT EXCEEDS SPACE LEFT IN ARRAY ? ADA T5DAT SSA JMP ERD71 YES, ERROR. * * INITIALIZE, SEND DATA TO PAK.F * CCA INITIALIZE PAK.F : LDB T4DAT OFFSET. JSB PAK.F * DAT16 JSB IC.F COPY THE DATA TO THE BUFFER. JSB PAK.F ISZ T7DAT COUNT. DONE ? JMP DAT16 NO. LOOP. * * FINISH UP & UPDATE OFFSET, AMT REMAINING. * LDA KM2 FLUSH THE BUFFER. JSB PAK.F (B) SET TO (F.AF + T4DAT + #WDS OUTPUT) CMB,INB COMPUTE # WDS OUTPUT. ADB T4DAT (B) = -(# WDS OUTPUT) LDA B UPDATE OFFSET. CMA,INA + # WDS. ADA T4DAT T4DAT _ T4DAT + # WDS. STA T4DAT ADB T2DAT T2DAT = T2DAT - # WDS. STB T2DAT * JSB ICH.F GET DELIM. CLB SET REPEAT = 0 & CHECK STATE. JMP DAT09 * K1 DEC 1 K20 DEC 20 SKP * QUOTED HOLLERITH CONSTANT. * DAT30 JSB IC.F READ THE QUOTE. CLA IF REPEAT = 0, CPA KBAR (SKIPPED REGULAR CHECK) ISZ KBAR SET IT TO ONE. LDA KBAR SET MAMIMUM SIZE: IF KBAR > 1, LDB F.D0+1 MAX SIZE IS SIMPLE ITEM SIZE, CPA ZFK1 ELSE LDB T2DAT MAX SIZE IS SPACE REMAINING IN ITEM. BLS CHANGE TO # CHARS, CMB AND SET UP AS COUNTER. STB T7DAT T7DAT = -(MAX # CHARS)-1 CCA SET UP PAK.F LDB T4DAT OFFSET. JSB PAK.F * * COPY STRING. * DAT32 JSB IC.F NEXT CHAR, INCL BLANKS. CPA B47 QUOTE ? RSS (YES) JMP DAT34 NO. * JSB IC.F YES. TWO IN A ROW ? CPA B47 RSS YES: TREAT AS ONE. JMP DAT36 NO. DONE. * DAT34 ISZ T7DAT IS THAT ONE TOO MANY ? RSS JMP ERD71 * JSB PAK.F NO. SEND IT. JMP DAT32 AND GO FOR MORE. * * END. BLANK FILL SINGLE ITEM (ALL IF AT /). * DAT36 CPA B40 HAVE CHAR AFTER END; IF BLANK, JSB ICH.F SKIP IT & READ NEXT NON-BLANK. LDA F.D0+1 COMPUTE # CHARS LEFT IN ITEM: CLE,ELA STA T5DAT T5DAT = TOTAL # IN AN ITEM. LDB T7DAT (B) = -(# LEFT)-1 INB -(# LEFT TOTAL) LDA F.TC AT END OF CURRENT DATA LIST (/) ? CPA B57 JMP DAT40 YES. FILL WHOLE ITEM. * ASR 16 DIV T5DAT (B) = REM = # TILL BOUNDARY. DAT40 SZB,RSS IF NONE, JMP DAT38 DON'T BOTHER. * STB T5DAT ELSE BLANK FILL. DAT37 LDA B40 JSB PAK.F ISZ T7DAT THIS SHOULD NEVER SKIP (MAX = -1) ISZ T5DAT JMP DAT37 * * FINISH UP REPEATED (SHORT) ITEM. * DAT38 CLA,INA IS IT REPEATED ? CPA KBAR JMP DAT39 NO. GO DO LONG VERSION. * LDA F.DPK SHORT. JUST COPY TO F.IDI LDB F.DID JSB .MVW DEF F.D0+1 NOP LDA F.D0+1 SET UP T5DAT AS HOLLERITH FLAG. STA T5DAT JMP DATA9 GO SEND IT WITH REPEAT COUNT. * * FINISH UP NON-REPEATED (POSSIBLY LONG) ITEM. * DAT39 LDA KM2 NO. TERMINv0ATE PAK.F JSB PAK.F CMB,INB COMPUTE # WDS SENT. ADB T4DAT (B) = -(# WDS SENT) LDA B UPDATE OFFSET & # WDS LEFT. CMA,INA ADA T4DAT T4DAT _ T4DAT + # WDS. STA T4DAT ADB T2DAT T2DAT _ T2DAT - # WDS. STB T2DAT CLB REPEAT = 0 NOW. JMP DAT09 DONE. SKP * UPDATE OFFSET, # WDS LEFT, REPEAT COUNT. * DAT08 LDA T6DAT THIS MAY ITEMS. MPY F.D0+1 OF THIS SIZE. LDB T4DAT ADD TO OFFSET. ADB A STB T4DAT CMA,INA SUBTRACT FROM # WDS LEFT IN ITEM. ADA T2DAT STA T2DAT LDB T6DAT UPDATE REPEAT COUNT. CMB,INB ADB KBAR DAT09 STB KBAR LDA F.TC MORE DATA ITEMS ? CPA B54 I.E., COMMA NEXT OR INB REPEAT WASN'T ZERO. SZB,RSS WELL ? JMP DAT20 OUT OF DATA. MUST BE OUT OF LIST. * LDA T2DAT MORE DATA. MUST BE MORE LIST. LDB T2GRE CPB T3DAT IS LIST EXHAUSTED ? SZA JMP DATA6 NO. GO GET NEW LIST ITEM. JMP ERD71 YES. MORE DATA THAN VARIABLES. * DAT20 LDA T2DAT OUT OF DATA. HOW 'BOUT LIST ? LDB T2GRE CPB T3DAT ANY LEFT IN TABLE ? SZA OR IN ARRAY ? RSS YES. MORE VARIABLES THAN DATA. JMP DAT21 NO. O.K. * LDA K71 YES. WARNING, BUT NOT ERROR. JSB WAR.F * DAT21 LDA B57 MUST END WITH '/' JSB TCT.F TEST F.TC JSB EXN.F AT END OF STATEMENT ? CPA B15 JMP DAT22 YES. * CPA B54 NO. IF OPTIONAL COMMA, JSB ICH.F SKIP IT. JMP F.DAT AND PROCESS NEXT LIST. * DAT22 JSB ICH.F READ C/R. JMP F.CRT AND FINISH STATEMENT. SPC 2 KK02 OCT 100001 DBLINT / INT KK05 OCT 110003 DBLLOG / LOG K51 DEC 51 DATA OPERATOR. B110 OCT 110 "H" T0DAT NOP  SAVE F.IM OF LIST ELEMENT T1DAT NOP SAVE F.IM OF DATA ELEMENT T2DAT NOP SAVED END OF DO TABLE. T3DAT NOP SAVE # WORDS IN ARRAY T4DAT NOP OFFSET INTO ARRAY. T5DAT NOP HOLLERITH COUNT. T6DAT NOP SCRATCH. T7DAT NOP SCRATCH. T8DAT NOP SCRATCH. KBAR NOP REPEAT INDICATOR IN DATA PROCESSOR * * ERROR IN DATA STATEMENT. * ERD71 LDA K71 COUNT MISMATCH / BAD REPEAT COUNT. JSB ER.F ERDAT LDA K73 ERROR 73. JSB ER.F * K71 DEC 71 B52 OCT 52 K73 DEC 73 * * END F4.0 ASMB,Q,C HED RELATE COMMON, EQUIVALENCE, AND ASSIGN ARRAY PHASE. NAM RCO.F,8 92834-16002 REV.2030 800727 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE: * * 1) (RCO.F) COMPUTES OFFSETS OF ITEMS EXPLICITLY DECLARED TO * TO BE IN COMMON. * 2) (GREQU) RESOLVES THE EQUIVALENCE CLASSES AND ASSIGNS * ADDRESSES TO THEIR MEMBERS. * 3) (APSEC) FOR NON-FORMAL ARRAYS, ASSIGNS ADDRESSES (IF NOT IN * COMMON OR EQUIV GROUP) & COMPUTES OFFSET TO (0,0,0). * * IT IS CALLED WHEN THE FIRST 'DATA' OR EXECUTABLE STATEMENT IS * ENCOUNTERED. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * j 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE. EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.AT. FLAG TO AI.F TO BUILD BCOMI OR DIM ENTRY. EXT F.CC CHARACTER COUNT EXT F.CSZ COMMON SIZE EXT F.D0 ARRAY ELEMEXT SIZE EXT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. EXT F.DO LWAM - END OF DO TABLE EXT F.E EQUIVALENCE TABLE POINTER EXT F.EM EMA FLAG BIT IN A.T. EXT F.EMS EMA SIZE DOUBLE WORD. EXT F.EQE EQUVALENCE ERROR FLAG EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LNN LINE # OF CURRENT LINE. EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LUB ADDR OF LOWER/UPPER BOUNDS TABLE. EXT F.ND NUMBER OF DIMENSIONS EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.SBF F.A OF PROG NAME IF SUBPROG. EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR CONSTANT VALUE. EXT DAD.F DOUBLE INTEGER ADD. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (AT) EXT DEM.F DEFINE (F.EM) = 1. EXT DMP.F DOUBLE INTEGER MULTIPLY. EXT DSB.F DOUBLE INTEGER SUBTRACT. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT EJC.F ESTABLISH DOUBLE INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FL.F FETCH LINK OF (B). EXT GCD.F CHECK FOR & GET INT CONST, 2 WORDS. EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT NAM.F COPY SYMBOL NAME. EXT PCC.F PRINT COMPILER COMMENT. EXT PSL.F PRINT SOURCE LINE (IMMEDIATELY). EXT TV.F TAG VARIABLE. EXT WAR.F ISSUE WARNING. * * EXTERNALS IN THE SEGMENT. * EXT F.BCM BLANK COMMON HEADER. EXT F.CIO ITEM OFFSET (DOUBLE INTEGER) * EXT CIO.F COMPUTE ITEM OFFSET. * * ENTRY IN THIS MODULE. * ENT RCO.F SPC 2 A EQU 0 B EQU 1 SUP SKP * ***************** * * RELATE COMMON * * ***************** RCO03 LDB F.BCM END OF LABELED COMMON CLA CLEAR THE FLAG STA F.LCM JMP RCO02 GO DO BLANK COMMON * RCO04 LDA T1RCO GET CURRENT MASTER ENTRY ADDRESS STA F.A RESTORE IT FOR GNA.F CLA SET UP TO ZAP THE F.AF OF THE MASTER LDB F.SFF AND IF BLOCK DATA SUBPROGRAM CPB K2 LDA T0RCO+1 SET F.AF OF MASTER TO SIZE JSB DAF.F SET MASTER ENTRY F.A JSB CCS.F CHECK SIZE. LDA F.EM GET EMA FLAG SZA,RSS THIS THE EMA ENTRY? JMP RCO01 NO, LOOK FOR NEXT BLOCK * DLD T0RCO YES, SAVE SIZE. DST F.EMS JMP RCO01 LOOK FOR NEXT BLOCK * RCO.F NOP ISZ F.LCM DO LABELED COMMON FIRST JSB GFA.F SEARCH A.T. FOR COMMON LABELS. RCO01 JSB GNA.F SZA,RSS END OF TABLE?? JMP RCO03 YES GO DO BLANK COMMON * LDA F.A,I CHECK IF LAB9ELED COMMON MASTER AND B7601 ISOLATE NT,AT,IU FIELDS CPA B7200 IF NT=0 & AT=BCOMI & IU=SUB RSS THIS IS A MASTER ENTRY JMP RCO01 NOT SO TRY NEXT ENTRY * LDB F.A SAVE THE ADDRESS OF MASTER RCO02 STB T1RCO ENTRY JSB FL.F FETCH LINK STA T2RCO T2RCO = LINK. CLB SET COMMON SIZE STB T0RCO TO ZERO STB T0RCO+1 RCO05 LDA T2RCO GO TO NEXT ONE. STA F.A F.A=NEXT LINK CPA T1RCO END OF LIST? CLB,INB,RSS YES SKIP OUT JMP RCOM2 NO DO NEXT ENTRY * CPB F.LCM DOING LABELED COMMON?? JMP RCO04 YES SET FOR NEXT ENTRY * LDB T0RCO+1 SET COMMON SIZE. STB F.CSZ JSB CCS.F CHECK IT FOR OFL. JMP GREQU DO EQUIV. GROUPS * RCOM2 JSB FA.F FETCH ASSIGN JSB NW2.F F.D0: # WDS FOR ITEM LDB F.A JSB FL.F FETCH LINK STA T2RCO T2RCO = LINK. LDA T0RCO+1 JSB DAF.F DEFINE F.AF=T0 LDA F.EM IS IT IN EMA ? SZA,RSS THEN JMP RCO06 NOT IN EMA SKIP IT * LDA T0RCO GET THE HIGH ORDER BITS ADB K2 INDEX TO PLACE FOR THEM. STA B,I SET IN THE SYMBOL TABLE RCO06 DLD T0RCO GET COMMON SIZE. JSB DAD.F ADD ELEMENT SIZE. DEF F.D0 CCA (IF OFL, MAKE SURE IS CAUGHT) DST T0RCO JSB CCS.F CHECK FOR OFL. JMP RCO05 DO NEXT ONE IN THE LIST * T0RCO DEC 0,0 SIZE. T1RCO NOP F.A OF MASTER. T2RCO NOP LINK TO NEXT ITEM. F.LCM NOP LABELLED COMMON FLAG. K84 DEC 84 K2 DEC 2 B7200 OCT 7200 NT=0, AT=BCOMI, IU=SUB. B7601 OCT 7601 F.NT & F.AT & F.IU * * SUBROUTINE TO CHECK T0RCO FOR OVERFLOW. * CCS.F NOP DLD T0RCO SZA,RSS MUST HAVE UPPER BITS=0, SSB AND LOWER POSITIVE. RSS NO. ERROA_R. JMP CCS.F,I YES. EXIT. * LDB F.EM WELL, MAYBE. IS IT EMA ? SZB SSA YES. IS BIT 31 CLEAR ? RSS NO. TRUE OVERFLOW. JMP CCS.F,I YES ON BOTH. IT FITS. * LDA K84 OVERFLOW. JMP F.ABT SKP * ********************* * * GROUP EQUIVALENCE * * ********************* SPC 1 * THIS SECTION RESOLVES THE EQUIVALENCE DECLARATIONS SAVED IN THE * EQUIVALENCE TABLE, (F.DO-1) TO (F.E). THE INITIAL FORM OF THE * TABLE IS DESCRIBED IN F.EQU . AT THIS POINT ALL OTHER * DECLARATIONS HAVE BEEN PROCESSESED SO THE SUBSCRIPTS GIVEN IN * THE EQUIVALENCE ITEMS CAN NOW BE RESOLVED INTO WORD OFFSETS FROM * THE START OF THE ITEM. THIS IS THE INITIAL "PACK" PHASE. AT THE * END OF THE PACK PHASE, EACH ITEM IN THE EQUIVALENCE TABLE IS * A 3-WORD FRAME CONTAINING THE F.A OF THE ITEM AND THE 2-WORD * OFFSET FROM ITS START TO THE SUBSCRIPTED ADDRESS. * * EQUIVALENCE PROCESSING IS DONE BY EXTRACTING EQUIVALENCE CLASSES. * (ONE OR MORE EQUIVALENCE GROUPS EACH CONTAINING AT LEAST ONE * ITEM IN ANOTHER GROUP IN THE CLASS, SUCH THAT NO ITEM IS IN * A GROUP OUTSIDE THE CLASS. THE CLASS DESCRIBES A SET OF ITEMS * IN LOCK-STEP WITH EACH OTHER.) THE FOLLOWING ALGORITHM IS USED * TO EXTRACT A CLASS FROM THE REMAINING EQUIVALENCE DATA: * 1) THE FIRST GROUP IS IN THE CLASS. AS EACH GROUP IS PUT IN * THE CLASS, IT IS MARKED 'KNOWN'. * 2) FOR EACH KNOWN ITEM, SEARCH FOR A MATCHING ONE: * IF NONE FOUND, GO ON TO NEXT KNOWN ITEM. * IF FOUND & KNOWN, OFFSETS MUST MATCH. GO ON. * IF FOUND & UNKNOWN, ADD GROUP CONTAINING ITEM * TO THE CLASS & RESTART STEP (2). * IF NO NEW GROUPS ADDED TO CLASS, THE CLASS IS COMPLETE. * THE ADDRESS OF A (HYPOTHETICAL) SIMPLE ITEM IN THE FIRST GROUP * OF THE CLASS IS CONSIDERED TO BE THE REFERENcCE ADDRESS. THE * REFERENCE OFFSET IS THE OFFSET FROM THIS ADDRESS TO THE ADDRESS * OF A SIMPLE ITEM IN THE CURRENT GROUP. (FOR THE FIRST GROUP, * ZERO.) THE LOCATIONS 'ULIM' AND 'LLIM' ARE THE OFFSETS TO THE * LWA+1 OF THE ITEM AT THE HIGH END OF THE CLASS AND THE LWA OF THE * ITEM AT THE LOW END, BASED ON THE REFERENCE ADDRESS. THE SIZE * OF A CLASS IS (ULIM-LLIM). * * AS EACH CLASS IS COMPLETED, IT IS ALLOCATED TO LOCAL SPACE, COMMON * OR LABELLED COMMON (INCLUDING EMA) AND THE ADDRESSES OF THE ITEMS * IN THE CLASS ARE DEFINED. THE CLASS IS THEN REMOVED FROM THE * EQUIVALENCE TABLE AND A SCAN FOR THE NEXT CLASS IS STARTED. SPC 3 * START. PACK EQUIVALENCE TABLE. * GREQU LDA F.DO ANY ITEMS IN TABLE ? CPA F.E JMP ASPEC NO. SKIP EQUIVALENCE PROCESSING. * STA T1GRE YES. T1GRE = ADDRESS OF LAST WORD READ. STA T2GRE T2GRE = ADDRESS OF LAST WORD WRITTEN. JMP GRE01 GO START. SKP GRE00 STA T4GRE T4GRE = LINE # FOR ERRORS. JSB GREW2 LEAVE IN TABLE. GRE01 JSB GRER1 COPY F.A OR GROUP START MARK. STA F.A JSB GREW2 JSB GRER1 READ # SUBS OR LINE #. LDB F.A (B) = F.A OR -1 SSB WHICH ? JMP GRE00 NEW GROUP. SAVE LINE #. * STA T3GRE T3GRE = # SUBS. JSB FA.F FETCH ASSIGNS (F.IU, F.ND, F.D0) LDB F.A MUST NOT BE DUMMY OR SUBROUTINE. LDA K22 (ELSE ERROR 22.) CPB F.SBF CHECK FOR PROGRAM NAME, JMP GRE99 * LDB F.AT FORMAL PARAM, CPB DUM JMP GRE99 * LDB F.IU OR SUBROUTINE. CPB SUB JMP GRE99 * CPB ARR ARRAY ? RSS YES. JSB TV.F NO. MAKE IT VAR. LDA F.ND (A) = DECLARED # DIM (GARBAGE IF VAR) LDB F.IU SIMPLE VARIABLE ? CPB VAR CLA YES, # DIM = 0. e LDB T3GRE # SUBSCRIPTS. CMB,INB -(#SUBS) ADB A (#DIM)-(#SUBS) SSB MORE SUBS THAN DIMS ? JMP GRE02 YES, ERROR. * LDA T3GRE (A) = # SUBS. LDB T1GRE SET (B) TO ADDR OF LAST SUBSCR ADB KM2 WHICH IS NEXT THING FROM # SUBS. JSB CI2.F COMPUTE ITEM OFFSET. SOC OUT OF BOUNDS ? JMP GRE17 YES, CALL IT IMPOSSIBLE. * LDA F.CIO+1 WRITE IT OUT. JSB GREW2 LDA F.CIO JSB GREW2 LDA T3GRE ADVANCE PAST SUBSCRIPTS IN TABLE. ALS TWO WORDS EACH. SZA,RSS (IF NONE, SKIP A WORD ANYWAY) INA CMA,INA JUST SET SUBTRACT FROM T1GRE. ADA T1GRE STA T1GRE CPA F.E END ? RSS YES. DONE. JMP GRE01 NO. GET NEXT ITEM. * LDA T2GRE SHORTEN TABLE TO CURRENT SIZE. STA F.E JMP GRE04 GO START THE CLASS DETERMINATION. * GRE02 LDA K38 MORE SUBSCRIPTS THAN DIMENSIONS. JMP GRE99 REPORT IT, DELETE TABLE & EXIT. SKP * START NEW EQUIVALENCE CLASS. * GRE04 LDA F.DO ANYTHING LEFT ? CPA F.E JMP ASPEC NO. DONE WITH EQUIV. * STA T1GRE T1GRE = PTR TO START OF 1ST GROUP. CLA T0GRE = REFERENCE OFFSET (INITIALLY ZERO). STA T0GRE STA T0GRE+1 STA LLIM LLIM = OFFSET OF FWA CLASS. STA LLIM+1 STA ULIM ULIM = OFFSET OF LWA+1 CLASS. STA ULIM+1 STA T6GRE T6GRE = ADDRESS LEVEL. STA T7GRE T7GRE = COMMON BLOCK NAME. LDA STRAB T5GRE = ADDRESS TYPE. STA T5GRE JSB GRER1 SKIP (-1) GROUP START. * * START NEW GROUP. T1GRE = ADDR OF GROUP. * T0GRE = REFERENCE OFFSET. * GRE06 JSB GRER1 SAVE LINE #. STA T4GRE GRE08 LDA T1GRE IF THIS WAS LAST GROUP, CPA F.E D THEN NO GROUP MARK. JMP GRE10 YES. DONE WITH GROUP. * JSB GRER1 READ F.A OR GROUP MARK. CPA KM1 WHICH ? JMP GRE10 GROUP MARK. * STA F.A ITEM. SAVE F.A IOR B100K SET SIGN ON ITEM F.A TO MARK IT. STA T1GRE,I JSB FA.F FETCH ASSIGNS. * * CHECK OUT ADDRESS TYPES, SAVE BLOCKNAME. * LDB F.AT DEFINED ? CPB STRAB JMP GRE9B NO. ALL'S FAIR. * LDA T5GRE COMMON. FIRST ONE ? CPA STRAB RSS YES. JMP GRE9A NO. GO CHECK FOR CONSISTENT BLOCK. * STB T5GRE YES. SET TYPE OF COMMON. LDA F.AF SET BLOCKNAME. ADA K2 INDEX TO THE F.A LDA A,I (A) = F.A OF MASTER. STA T7GRE LDA T1GRE SAVE ADDR OF FRAME STA TAGRE FOR BCOM OFFSET RESOLUTION LATER. GRE9A LDA F.AT COMMON. MUST BE SAME TYPE. CPA T5GRE RSS YES. O.K. JMP GRE17 NO. ERROR. * CPA COM BLANK OR LABELLED ? JMP GRE9B BLANK. O.K. * LDA F.AF LABELLED. BLOCKNAME MUST MATCH. ADA K2 GET F.A OF MASTER. LDA A,I CPA T7GRE RSS SAME. O.K. JMP GRE17 NO. ERROR. * GRE9B LDA T6GRE SET ADDRES LEVEL TO MAX. IOR F.EM STA T6GRE * JSB NW2.F COMPUTE # WORDS. JSB GRER1 ADVANCE T1GRE TO OFFSET (LOWER) JSB GRER1 (UPPER). DLD T0GRE REFERENCE OFFSET. JSB DSB.F - OFFSET. DEF T1GRE,I = CLASS OFFSET. JMP GRE98 IF OFL. * DST T1GRE,I REPLACE ARRAY OFFSET WITH CLASS OFFSET. JSB DSB.F (CLASS OFFSET) - LLIM DEF LLIM JMP GRE98 IF OFL. * SSA,RSS NEW OFFSET SMALLER ? (OR MORE NEGATIVE) JMP GRE9D NO. * DLD T1GRE,I YES. UPDATE LLIM. DST LLIM GRE9D DLD F.D0 SIZE JSB DAD.F + CLASS OFFSET. L DEF T1GRE,I JMP GRE98 IF OFL * DST T8GRE SAVE IT. JSB DSB.F (OFFSET+SIZE) - ULIM DEF ULIM JMP GRE98 IF OFL. * SSA WHICH IS BIGGER ? JMP GRE08 ULIM. LEAVE IT. * DLD T8GRE OFFSET+SIZE. NEW ULIM. DST ULIM JMP GRE08 GO FOR NEXT ITEM IN GROUP. SKP * GROUP HAS BEEN ADDED TO CLASS. * SEARCH FOR CONFLICTS AND OTHER GROUPS IN CLASS. * GRE10 LDA F.DO SET UP SCANS. STA T1GRE T1GRE = OUTER LOOP POINTER. * GRE11 STA T4GRE T4GRE = LINE # (GARBAGE 1ST TIME) GRE12 LDA T1GRE END OF OUTER LOOP ? CPA F.E JMP GRE24 YES. NO NEW GROUPS, CLASS COMPLETE. JSB GRER1 GET F.A OR GROUP START. STA F.A * JSB GRER1 ADVANCE T1GRE TO OFFSET OR LINE #. LDB F.A RECALL F.A CPB KM1 GROUP START ? JMP GRE11 YES. SAVE LINE # & GO ON. * JSB GRER1 ADVANCE TO 2ND WD OF OFFSET. LDA F.A (A) = F.A SSA,RSS UNKNOWN ITEM ? JMP GRE12 YES. INGORE IN OUTER LOOP. * * INNER LOOP. * LDA F.DO SET UP INNER LOOP. STA T2GRE T2GRE = POINTER. * GRE13 LDA T2GRE T8GRE = LOCATION OF CURRENT GROUP. INA (A = ADDR OF GROUP MARK) STA T8GRE (GARBAGE FIRST TIME) GRE14 LDA T2GRE END ? CPA F.E JMP GRE12 YES, ADVANCE OUTER LOOP. * JSB GRER2 NO. GET F.A OR GROUP START (INNER LOOP) STA T3GRE SAVE. JSB GRER2 ADVANCE T2GRE TO OFFSET (OR LINE #) LDA T3GRE IS IT GROUP START ? CPA KM1 JMP GRE13 YES, SAVE LOCATION. * JSB GRER2 ADVANCE TO 2ND WORD OF OFFSET. LDA T3GRE CPA F.A DUPLICATE MARKED ITEMS ? JMP GRE16 YES. OFFSETS MUST MATCH. * IOR B100K SAME NAME IN NEW GROUP ? CPA F.A JMP GRE18 YES.uD JMP GRE14 NO. GO ON TO NEXT ONE. SKP GRE16 DLD T1GRE,I T0GRE = ORIGINAL OFFSET. DST T0GRE DLD T2GRE,I (A,B) = DUPLCATE ITEM'S OFFSET. CPA T0GRE MATCH ? RSS JMP GRE17 NO. ERROR. CPB T0GRE+1 UPPERS TOO. JMP GRE14 YES. JUST REDUNDANT EQUIVALENCE. * GRE17 LDA K40 NO. IMPOSSIBLE EQUIVALENCE GROUP. JMP GRE99 GO TELL LINE # & NAME. * * ADD NEW GROUP TO CLASS. * GRE18 DLD T1GRE,I T0GRE = BASE OF ITEM IN BOTH GROUPS. JSB DAD.F + OFFSET IN NEW GROUP. DEF T2GRE,I JMP GRE98 IF OFL. * DST T0GRE = NEW REFERENCE OFFSET. LDA T8GRE T1GRE = ADDRESS OF NEW GROUP. STA T1GRE JMP GRE06 GO ADD THE GROUP TO THE CLASS. * LLIM OCT 0,0 LOWER LIMIT OF CLASS. ULIM OCT 0,0 UPPER LIMIT OF CLASS + 1 T0GRE OCT 0,0 REFERENCE ADDRESS. T1GRE NOP POINTER INTO EQUIV TABLE. T2GRE NOP POINTER INTO EQUIV TABLE. T3GRE NOP TEMP T4GRE NOP LINE # OF CURRENT GROUP. T5GRE NOP F.AT OF CLASS. T6GRE NOP F.EM OF CLASS. T7GRE NOP F.A OF BCOM MASTER FOR CLASS. T8GRE OCT 0,0 ADDR START OF CURRENT GROUP (INNER LOOP) TAGRE NOP ADDR OF FRAME OF A BCOM ITEM THIS CLASS. ARR OCT 600 F.IU=ARR VAR OCT 400 F.IU=VAR STRAB OCT 2000 F.AT=STRAB COM OCT 4000 F.AT=COM BCOM OCT 3000 F.AT=BCOM BCOMI OCT 7000 F.AT=BCOMI KM1 DEC -1 KM2 DEC -2 K10 DEC 10 K22 DEC 22 K38 DEC 38 B100K OCT 100000 K40 DEC 40 SKP * MISCELLANEOUS SUBROUTINES FOR EQUIVALENCE. * GRER1 NOP READ EQUIV TABLE INTO (A) USING (T1GRE) CCB BACK UP T1GRE. ADB T1GRE STB T1GRE LDA B,I (A) = DATA. JMP GRER1,I EXIT. * GRER2 NOP READ EQUIV TABLE INTO (A) USING (T2GRE) CCB BACK UP T2GRE. ADB T2GRE STB T2GRE LDA B,I (A) = DATA. JMP GRER2,I EXIT. * GREW2 NOP WRITE (A) INTO EQUIV TABLE USING (T2GRE) LDB F.LO TOP OF A.T. + 1 CMB -F.LO-1 (F.LO: MIN ALLOWABLE F.E) ADB T2GRE (T2GRE-1)-F.LO SSB NEW T2GRE < F.LO ? JMP F.OFE YES, MEM OVERFLOW. * ADB F.LO NEW T2GRE = T2GRE-1 STB T2GRE STA B,I STORE DATA. JMP GREW2,I EXIT. SKP * COMPLETE EQUIV CLASS. ASSIGN ADDRESSES OR OFFSETS. * GRE24 DLD ULIM COMPUTE SIZE = (ULIM-LLIM) JSB DSB.F DEF LLIM JMP GRE98 IF OFL. * SZA,RSS > 32767 ? SSB RSS YES. JMP GRE25 NO. ALWAYS O.K. * LDA T6GRE > 32767. EMA ? SZA,RSS JMP GRE98 NO. TOO BIG. * GRE25 LDA T5GRE WHAT KIND ? CPA STRAB RSS NORMAL. JMP GRE27 COMMON OR BCOM. * CLA SET T0GRE = F.RPL - LLIM LDB F.RPL (THIS IS THE VALUE WHICH, WHEN ADDED JSB DSB.F TO THE ITEM OFFSET, GIVES THE PROPER DEF LLIM RELOCATABLE ADDRESS FOR THE ITEM.) JMP GRE98 IF OFL. * DST T0GRE JSB DAD.F + BIGGEST OFFSET GIVES NEW F.RPL DEF ULIM JMP GRE98 * STB F.RPL SZA,RSS ROOM ? SSB JMP F.OFE NO. YOU LOOSE... * LDA REL YES. WILL MARK F.AT = REL. STA T5GRE JMP GRE50 GO ON. * GRE27 LDA TAGRE COMMON. GET ADDR OF ITEM OFFSET ADA KM2 OF THE ITEM KNOWN TO BE IN COMMON. STA GRE28 SET UP FOR LATER. LDA TAGRE,I (A) = KNOWN ITEM F.A + SIGN. RAL,CLE,ERA CLEAR SIGN. STA F.A SAVE & FETCH ASSIGNS. JSB FA.F LDB T5GRE WHICH COMMON ? CPB BCOM JMP GRE40 LABELLED. * LDB A (F.AF) CLA (A,B) = COMMON OFFSET.Q JSB DSB.F - ITEM'S EQUIV OFFSET GRE28 DEF *-* JMP GRE98 IF OFL. * DST T0GRE GIVES THE DISPLACEMENT. JSB DAD.F + MAX OFFSET = SIZE. DEF ULIM (IGNORE UPPER WORD) JMP GRE98 IF OFL. * LDA DCSZ (A) = ADDR OF SIZE. (POSSIBLY INDIRECT) JMP GRE42 GO UPDATE SIZE IF BIGGER. SKP GRE40 LDB T6GRE EMA ? SZB JMP GRE44 YES. * DLD A,I (B) = ITEM'S OFFSET. CLA (A,B) JSB DSB.F - ITEM EQUIV OFFSET. DEF GRE28,I JMP GRE98 IF OFL. * DST T0GRE GIVES DISPLACEMENT. JSB DAD.F + MAX OFFSET = SIZE. DEF ULIM (IGNORE UPPER WORD) JMP GRE98 IF OFL. * LDA F.SFF BLOCK DATA ? CPA K2 CLA,INA,RSS YES. (A=1) JMP GRE43 NO. DONE HERE. * ADA T7GRE (A) = ADDR OF SIZE. GRE42 STA T3GRE SAVE ADDR SIZE. LDA B (A) = NEW SIZE. CMA,INA ADA T3GRE,I OLD - NEW SSA NEW BIGGER ? STB T3GRE,I YES. UPDATE. GRE43 SSB TOO BIG ? JMP F.OFE YES. PUNT. JMP GRE50 NO. START THE SCAN. * GRE44 INA GET EMA OFFSET. LDB A,I LOWER IS AT F.A+1 ADA K2 LDA A,I UPPER IS AT F.A+3 JSB DSB.F (EMA OFFSET) - (ITEM OFFSET) DEF GRE28,I JMP GRE98 IF OFL. * DST T0GRE GIVES DISPLACEMENT. JSB DAD.F + MAX OFFSET GIVES SIZE. DEF ULIM JMP GRE98 IF OFL. * DST T8GRE SAVE SIZE. DLD F.EMS OLD SIZE JSB DSB.F (OLD SIZE) - (NEW SIZE) DEF T8GRE JMP GRE98 IF OFL. * SSA,RSS WHICH IS BIGGER ? JMP GRE50 OLD. * DLD T8GRE NEW. SET IT AS SIZE. DST F.EMS SKP * LOOP THRU ITEMS IN CLASS, DEFINING THEIR ADDRESSES. * GRE50 LDA F.DO SET T1GRE AS READ POINTER.a STA T1GRE STA T2GRE AND T2GRE AS WRITE POINTER. JSB GRER1 SKIP INITIAL GROUP HEAD. * * JUST COPY GROUPS NOT IN CLASS. * GRE52 JSB GRER1 SEE IF IN CLASS. COPY LINE #. STA T4GRE T4GRE = LINE #. JSB GRER1 GET F.A FIRST ITEM. SSA MARKED ? JMP GRE55 YES. PROCESS IT. * STA F.A NO. SAVE F.A, THEN CCA 'COPY' THE DISCARDED GROUP HEAD, JSB GREW2 LDA T4GRE AND THE LINE #, JSB GREW2 LDA F.A AND GO FINISH COPYING 1ST ITEM. JMP GRE51 * GRE53 LDA T1GRE AT END ? CPA F.E JMP GRE65 YES. * JSB GRER1 COPY UNTIL NEW GROUP. CPA KM1 WELL ? JMP GRE52 YES. GO CHECK IT. * GRE51 JSB GREW2 NO. COPY F.A JSB GRER1 OFFSET LOWER. JSB GREW2 JSB GRER1 OFFSET UPPER. JSB GREW2 JMP GRE53 UNTIL GROUP HEAD. * * GROUP IS IN CLASS. PROCESS EACH ITEM. * GRE54 LDA T1GRE AT END ? CPA F.E JMP GRE65 YES. * JSB GRER1 NEXT F.A OR GROUP HEAD. CPA KM1 WHICH ? JMP GRE52 NEW GROUP. GO SEE IF IN CLASS. * GRE55 RAL,CLE,ERA CLEAR SIGN. STA F.A SET F.A (SIGN HAS BEEN CLEARED) STA TAGRE (ALSO FOR EMA LATER) JSB FA.F FETCH ASSIGNS. JSB GRER1 ADVANCE TO 1ST WD OFFSET. JSB GRER1 DLD T1GRE,I (A,B) = ITEM OFFSET. JSB DAD.F (A,B) = ITEM ADDRESS OR COMMON OFFSET. DEF T0GRE JMP GRE98 IF OFL. * DST T1GRE,I SAVE IT. SSA IF NEGATIVE, JMP GRE97 MUST BE NEG EXTENSION OF COMMON. SKP * IF NOT BLOCK COMMON, JUST DEFINE F.AT & F.AT . * BLOCK COMMON: IF DEFINED, MUST ALREADY MATCH. * IF NOT, MUST DEFINE IT. * LDB T5GRE LABELLED COMMON ? CPB BC<`OM RSS YES. JMP GRE62 NO, GO DEFINE F.AT & F.AF * CPB F.AT DEFINED ? JMP GRE63 YES. ADDRESSES MUST MATCH. * LDA T6GRE SET F.EM FOR AI.F STA F.EM LDA BCOMI SET F.AT. = BCOMI FOR AI.F STA F.AT. JSB AI.F CREATE THE TABLE ENTRY. LDB T7GRE (B) = ADDR OF MASTER. LDA F.A (A) = ADDR NEW BCOMI ENTRY. ADA K2 INDEX TO PLACE FOR MASTER ADDR. STB A,I & PUT IT THERE. INA ADDR OF UPPER WORD EMA ADDR. STA T3GRE SAVE. LDA T6GRE EMA FLAG. LDB T1GRE,I (B) = UPPER WORD. SZA EMA ? STB T3GRE,I YES. SET UPPER WORD. LDA BCOMI DEFINE THE F.AT JSB DAT.F LDA F.A (A) = ADDR BCOMI ENTRY. LDB TAGRE (B) = ADDR ORIGINAL ENTRY. STB F.A RESTORE F.A TO THERE. JSB DAF.F LINK IN THE BCOMI ENTRY. LDA T6GRE IF EMA, SZA JSB DEM.F SET THE EMA BIT. JSB FA.F & FETCH ASSIGNS AGAIN. JMP GRE64 NOW GO DEFINE F.AT & F.AF SKP * VERIFY ALREADY IN LABELLED COMMON, VERIFY ADDR. * GRE63 DLD T1GRE,I (B) = CORRECT (LOWER) OFFSET. LDA F.AF ADDR OF BCOMI ENTRY. INA ADDR OF DEFINED OFFSET. CPB A,I SAME ? RSS JMP GRE17 NO. IMPOSSIBLE. * LDB T6GRE YES. EMA ? SZB,RSS JMP GRE54 NO. DONE. * LDB T1GRE,I CORRECT UPPER OFFSET. ADA K2 ADDR OF DEFINED VALUE. CPB A,I SAME ? JMP GRE54 YES. JMP GRE17 NO. IMPOSSIBLE. * * REL/COM: IF COM & ALREADY DEF, SEE IF SAME. * GRE62 LDA F.AT WELL ? CPA COM RSS JMP GRE64 NO. * DLD T1GRE,I YES. (B) = CORRECT OFFSET. CPB F.AF SAME ? JMP GRE54 YES. JMP GRE17 NO. IMPOSSIBLE. * * : DEFINE (LOWER) ADDRESS/OFFET. * GRE64 LDA T5GRE SET F.AT OF NEW ITEM. JSB DAT.F DLD T1GRE,I SET (LOWER) WORD OFFSET. LDA B JSB DAF.F JMP GRE54 ALL DONE! * * DONE WITH THIS CLASS. CUT THE TABLE BACK TO * REFLECT THE NEW (GREW2) LENGTH & TRY FOR ANOTHER. * GRE65 LDA T2GRE NEW LWA STA F.E JMP GRE04 MAY BE EMPTY NOW. SKP DEQMS DEF EQMSG EQMSG ASC 7, INVOLVING: EQNAM ASC 3,XXXXXX DCSZ DEF F.CSZ DEF TO BLANK COMMON SIZE IN MAIN. REL OCT 1000 K41 DEC 41 DGR95 DEF GRE95 ERROR RETURN POINT. SPC 2 * IMPOSSIBLE EQUIVALENCE CLASS. * OUTPUT ERROR MSG WITH GROUP LINE # AND ITEM NAME. * GRE97 LDA K41 NEGATIVE EXTENSION OF COMMON. JMP GRE99 GRE98 LDA K84 ADDRESS SPACE OVERFLOW. GRE99 LDB F.LNN DUMMY UP LINE #. STB T5GRE LDB T4GRE STB F.LNN LDB F.CC ALSO COLOUMN. STB T6GRE CLB STB F.CC LDB DGR95 SET ERROR RETURN POINT. STB F.EQE JSB ER.F ISSUE MSG & RETURN. GRE95 CLA RESET ERROR RETURN POINT. STA F.EQE LDA T5GRE RESTORE LINE #. STA F.LNN LDA T6GRE & F.CC STA F.CC LDA F.A CLEAR SIGN OF F.A RAL,CLE,ERA STA F.A JSB NAM.F COPY NAME TO MESSAGE. DEF EQNAM LDA K10 TEN WORDS. LDB DEQMS FROM HERE. JSB PCC.F TO OUTPUT. SKP * ************************ * * ASSIGN SPECIFICATION * * ************************ SPC 1 * TO ASSIGN STORAGE TO ARRAYS NOT ALREADY ASSIGNED (BY EQUIV). * * TOP OF LOOP. GET ANOTHER ARRAY. * ASPEC JSB GFA.F SET UP TO SCAN A.T. LDA F.A KEEP THE F.A IN T1ASP. STA T1ASP ASP01 LDA T1ASP RESTORE F.A STA F.A JSB GNA.F GET NEXT F.A  STA T1ASP KEEP IT IN T1ASP. SZA,RSS JMP CAI00 END OF ASSIGNMENT TABLE * JSB FA.F FETCH ASSIGNS LDA F.IU IF NOT AN ARRAY, CPA ARR RSS JMP ASP01 THEN SKIP IT (ASSIGN AT 'END'). * * ASSIGN SPACE IF NOT DONE ALREADY AND NOT FORMAL. * LDA F.AT IF A DUMMY, CPA DUM JMP ASP01 DON'T ASSIGN SPACE. * JSB NW2.F F.D0=# OF WDS FOR ITEM JSB AA.F ASSIGN ADDRESS JMP ASP01 * * B40 OCT 40 INT OCT 010000 F.IU=INT DBI OCT 100000 F.IU=DBI DUM OCT 5000 F.AT=DUM SUB OCT 200 F.IU=SUB T1ASP NOP F.A OF CURRENT ARRAY. SKP * ********************** * * COMPUTE ARRAY INFO * * ********************** SPC 1 * IN THIS SECTION, FOR EACH ARRAY: * 1) IF IN EMA, CHECKED FOR DOUBLE INTEGER SUBSCRIPTS. * 2) IF NON-FORMAL: * A) OFFSET TO ELEMENT (0,0,0) COMPUTED. * B) EACH LOWER BOUND NEGATED. * C) EACH UPPER BOUND REPLACED BY DIMENSION SIZE. * * THIS SECTION MUST BE EXECUTED BEFORE THE ROUTINES * 'NWI.F' AND 'CIO.F' ARE CALLED, AS THEY USE THE MODIFIED * ARRAY INFORMATION. * CAI00 JSB GFA.F SET UP SCAN OF NAMED ITEMS. LDA F.A KEEP F.A IN T1ASP STA T1CAI CAI01 LDA T1CAI RESTORE F.A STA F.A JSB GNA.F GET NEXT ITEM. STA T1CAI SZA,RSS DONE ? JMP RCO.F,I YES. ALL DONE WITH SPECS. * JSB FA.F NO. FETCH ASSIGNS. LDA F.IU ARRAY ? CPA ARR RSS (YES) JMP CAI01 NO. SKIP IT. SKP * CHECK WHETHER ANY DIMENSIONS ARE DOUBLE INTEGER. * IF CONSTANT DBL INT DIM FOR NON-EMA, PUNT. * LDA F.EM EMA ? SZA JMP CAI02 YES. * LDB F.DIS NO. CONSTANT DOUBLE INT SUBSCR ? SZB JMP CAI10 YE[S. ERROR. JMP CAI05 NO. ALL'S O.K. * CAI02 LDA F.LUB SET UP BOUNDS POINTER. STA T2CAI LDA F.ND SET UP LOOP COUNTER. ALS *2 FOR LOWER & UPPER BOTH. CMA,INA STA T3CAI CAI03 LDA T2CAI,I NEXT BOUND. ISZ T2CAI STA F.A GET ITS F.IM JSB FA.F LDA F.IM CPA DBI IS IT INTEGER*4 ? JMP CAI04 YES. DOUBLE INT SUBSCR. * ISZ T3CAI COUNT 'EM UP. JMP CAI03 MORE. JMP CAI05 DONE. SINGLE INT SUBSCR. * CAI04 DLD T1CAI,I FOUND ONE. SET THE F.DIS BIT, LDA B,I IN FIRST WORD OF DIM ENTRY. IOR B40 MEANING 'DOUBLE INTEGER SUBSCRIPT' STA B,I SKP * IF NOT FORMAL PARAM, LOOP THRU THE BOUNDS * AND: 1) NEGATE THE LOWER BOUNDS. * 2) REPLACE UPPER BOUNDS BY DIMENSION SIZE. * * CAI05 LDA T1CAI RESTORE F.A & ASSIGNS. STA F.A JSB FA.F LDA F.AT F.AT = DUM ? CPA DUM JMP CAI01 YES. FORMAL, SKIP IT. * LDA F.LUB SET UP BOUNDS LOOP. STA T2CAI T2CAI = BOUNDS POINTER. LDA F.ND # DIMENSIONS. CMA,INA STA T3CAI T3CAI = LOOP COUNTER. LDA F.DIS SINGLE OR DOUBLE ? SZA JMP CAI07 DOUBLE. * CAI06 LDB T2CAI,I SINGLE. GET LOWER BOUND VALUE. JSB CFC.F NOP CMA,INA NEGATE. STA T4CAI & SAVE FOR COMPUTING SIZE. CPA B100K -32768 ? JMP CAI6A YES. USE DOUBLE INTEGER. * JSB EIC.F NO. SET UP AS SINGLE INTEGER. JMP CAI6B * CAI6A LSL 16 (A,B) = 000000 100000 JSB EJC.F SET UP DOUBLE INTEGER LOWER BOUND. CAI6B STA T2CAI,I & REPLACE LOWER BOUND. ISZ T2CAI LDB T2CAI,I GET UPPER BOUND VALUE. JSB CFC.F NOP ADA T4CAI UPPER - LOWER. INA,SZA DIMENSION SIZE = UPPER-LOWER+1 SSA # > 32767 ? (0 = 65536) JMP CAI6C YES. USE DOUBLE INTEGER. * JSB EIC.F NO. USE SINGLE INTEGER. JMP CAI6D * CAI6C LDB A USE DOUBLE. CLA SZB,RSS (IF ZERO, REALLY 65536) CLA,INA JSB EJC.F * CAI6D STA T2CAI,I REPLACE UPPER BOUND WITH DIM SIZE. ISZ T2CAI ADVANCE TO NEXT DIMENSION. ISZ T3CAI COUNT. DONE ? JMP CAI06 NO. LOOP. JMP CAI08 YES. GO COMPUTE OFFSET. SKP * ADJUST BOUNDS FOR DOUBLE INTEGER DIMENSIONS. * CAI07 LDB T2CAI,I DOUBLE SUBSCR. LOOP. JSB GCD.F GET VALUE OF LOWER. NOP STA T4CAI & SAVE. STB T5CAI CMA NEGATE. CMB,INB,SZB,RSS INA DST F.IDI SET UP NEW CONSTANT. LDA DBI JSB ESC.F JSB AI.F LDA F.A REPLACE LOWER BOUND. STA T2CAI,I ISZ T2CAI LDB T2CAI,I GET VALUE OF UPPER. JSB GCD.F NOP JSB DSB.F UPPER - LOWER. DEF T4CAI NOP INB,SZB,RSS ADD ONE. INA DST F.IDI BUILD THE NEW CONSTANT. LDA DBI JSB ESC.F JSB AI.F LDA F.A STA T2CAI,I REPLACE UPPER WITH SIZE. ISZ T2CAI BUMP BOUNDS POINTER. ISZ T3CAI COUNT. DONE ? JMP CAI07 NO. LOOP. SKP * COMPUTE THE OFFSET FROM THE * START OF THE ARRAY TO ELEMENT (0,0,0). * CAI08 LDA T1CAI RESTORE F.A STA F.A JSB FA.F & ASSIGNS. LDA F.ND COMPUTE OFFSET. CLB B=0 FORCES ALL SUBSCRIPTS = 0. JSB CIO.F LDA F.CIO+1 (A)=OFFSET IF NON-EMA. STA F.IDI SET THAT UP, LDA INT AND THE TYPE. LDB F.EM WHICH IS IT ? SZB,RSS IF NON-EMA, JMP CAI09 WE'RE READY. * DLD F.CIO ELSE SET TWO-WORD VALUE. DST F.IDI (DIDN'T NEGATE LOWER B1OUNDS HERE) LDA DBI CAI09 JSB ESC.F SET IT UP. JSB AI.F DLD T1CAI,I (B) = F.A OF DIM ENTRY THIS ARRAY. ADB K2 = PLACE TO PUT OFFSET F.A LDA F.A PUT IT THERE. STA B,I JMP CAI01 GO GET NEXT SYMBOL. * * DOUBLE INTEGER BOUNDS ON NON-EMA, PUNT. * CAI10 LDA T1CAI RESTORE F.A & GET NAME. STA F.A JSB NAM.F DEF CAIMS+1 LDB DCAIM ISSUE MESSAGE FIRST. LDA K15 JSB PSL.F PRINT IMMEDIATELY. LDA K84 THEN DISASTER. JMP F.ABT * T1CAI NOP SAVED F.A T2CAI NOP BOUNDS TABLE POINTER. T3CAI NOP BOUNDS LOOP COUNTER. T4CAI NOP TEMP FOR CALCULATION. T5CAI NOP DITTO. DCAIM DEF CAIMS CAIMS ASC 15, ( ) HAS ILLEGAL BOUNDS. K15 DEC 15 SKP * ************************************ * * F.D0 := NUMBER OF WORDS FOR ITEM * * ************************************ SPC 1 * AT THIS POINT, RCO.F MUST NOT HAVE BEEN CALLED. THE LOWER AND * UPPER BOUNDS MUST BE INTACT. * NW2.F NOP LDA F.IU CPA ARR RSS JMP NW2.F,I * LDA F.ND SET UP COUNTER. CMA,INA STA T1NWI LDA F.LUB SET UP POINTER INTO BOUNDS TABLE. STA T2NWI * * LOOP THRU BOUNDS TABLE; FOR EACH DIMENSION, * MULTIPLY F.D0 BY THE SIZE (2-WORD COMPUTATION). * NWI01 LDB T2NWI,I GET LOWER BOUND. ISZ T2NWI (& GO PAST) JSB GCD.F JMP RPLOV NOT CONSTANT! * DST T3NWI SAVE, WHILE WE... LDB T2NWI,I GET UPPER BOUND. ISZ T2NWI (SKIP IT) JSB GCD.F JMP RPLOV SOMEONE GOOFED! * JSB DSB.F UPPER - LOWER. DEF T3NWI JMP RPLOV IF OFL. * INB,SZB,RSS + 1. INA SSA DID SOMETHING GO WRONG ? JMP RPLOV YES. * JSB DMP.F MULTIPLY &Ȧ REPLACE RUNNING PRODUCT. DEF F.D0 JMP RPLOV OFL. * DST F.D0 ISZ T1NWI INCR LOOP COUNTER. MORE ? JMP NWI01 YES. DO IT. JMP NW2.F,I NO. ALL DONE. (A,B) = PRODUCT. SKP RPLOV LDA K84 OFL IN SIZE CALC. CATASTROPHE! JMP F.ABT * T1NWI NOP LOOP COUNTER. T2NWI NOP BOUNDS TABLE POINTER. T3NWI DEC 0,0 TEMP FOR DIM SIZE CALC. SKP * *********************** * * COMPUTE ITEM OFFSET * * *********************** SPC 1 * CI2.F COMPUTES THE OFFSET, IN WORDS, OF AN ARRAY ELEMENT FROM THE * BASE OF THE ARRAY. THE NAME & SUBSCRIPTS MAY BE READ WITH ILE.F . * * NOTE: THE BOUNDS REFORMATTING MUST NOT HAVE BEEN DONE YET. IF IT * HAS, THEN CIO.F SHOULD BE USED. * * ENTRY: F.A = A.T. ADDR OF ITEM. * (A) = # SUBSCRIPTS (MAY BE ZERO). * (B) = ADDR OF LAST SUBSCRIPT (FOLLOWED BY NEXT-TO-LAST) * IF ZERO, ALL SUBSCRIPTS ASSUMED TO BE ZERO. * EXIT: F.CIO = TWO-WORD OFFSET IN INTERNAL FORM. SPC 1 CI2.F NOP STB T1CIO SAVE ADDR LAST SUBSCR. CLB INITIALIZE F.CIO = 0 STB F.CIO STB F.CIO+1 STB T0CIO CLEAR OVERFLOW FLAG. CMA,INA,SZA,RSS NEGATE # SUBS. JMP CIO03 IF NONE, DONE. (CLEAR OFL & EXIT) * STA T2CIO ELSE SAVE AS LOOP COUNTER. JSB FA.F SET UP: F.D0 = # WDS PER ELEMENT. DLD F.D0 SAVE THAT. DST T5CIO LDA T2CIO -(#SUBS) CMA (#SUBS)-1 ALS *2 ADA F.LUB ADDR LOWER BOUND LAST SUBSCR. STA T4CIO * * LOOP THRU SUBS & DIMS COMPUTING OFFSET. * CIO01 LDB T4CIO,I F.A OF LOWER BOUND. JSB GCD.F (A,B) = LOWER BOUND. ISZ T0CIO NOT CONSTANT: SOMEONE GOOFED! DST T6CIO SAVE. CLA (A,B)=0 IN CASE FORCED ZERO SUBSCRIPTS. CLB DLD T1CIO,I SUBSCRIPT. JSB DSB.F SUBTRACT LOWER BOUND. DEF T6CIO ISZ T0CIO IF TOO BIG. SSA ALSO BAD IF NEGATIVE. ISZ T0CIO JSB DAD.F ADD RUNNING SUM. DEF F.CIO ISZ T0CIO IF TOO BIG. ISZ T2CIO WAS THAT FIRST SUBSCR ? RSS NO. JMP CIO02 YES. DONE. * DST F.CIO SAVE CURRENT VALUE. LDA T4CIO BACK UP TO PREVIOUS DIMENSION. ADA KM2 STA T4CIO LDB A,I GET LOWER BOUND OF PREVIOUS. JSB GCD.F ISZ T0CIO IF NOT CONSTANT. DST T6CIO SAVE, WHILE WE DLD T4CIO,I GET THE UPPER BOUND. JSB GCD.F ISZ T0CIO (IF NOT CONSTANT) JSB DSB.F UPPER - LOWER. DEF T6CIO ISZ T0CIO (IF OFL) INB,SZB,RSS + 1 = PREV DIM SIZE. INA JSB DMP.F MULTIPLY PREV DIM SIZE BY DEF F.CIO CURRENT VALUE. ISZ T0CIO IF TOO BIG. DST F.CIO SAVE. LDA T1CIO BACK UP TO PREVIOUS SUBSCR. SZA IF FORCED ZERO SUBSCR, DON'T CHANGE. ADA KM2 STA T1CIO JMP CIO01 ARROUND WE GO * CIO02 JSB DMP.F * # WORDS PER ELEMENT. DEF T5CIO ISZ T0CIO IF TOO BIG. DST F.CIO SAVE OFFSET. JSB NW2.F COMPUTE F.D0 = TOTAL SIZE. DLD F.CIO COMPUTE OFFSET - SIZE. JSB DSB.F DEF F.D0 ISZ T0CIO IF OFL. SSA,RSS IF OFFSET >= SIZE, ISZ T0CIO ALSO SET OVERFLOW. LDA T0CIO OVERFLOW INDICATOR. CIO03 CLO SZA IF OVERFLOW OCCURED, STO RETURN OVERFLOW=1. JMP CI2.F,I DONE. F.CIO = OFFSET. * T0CIO NOP OVERFLOW FLAG. T1CIO NOP ADDR CURRENT SUBSCRIPT. T2CIO NOP LOOP COUNTER. T4CIO NOP ADDR F.A ENTRY CURRENT LOWER BOUND. T5CIO BSS 2 # WORDS PER ELEMENT. T6CIO BSS 2 TEMP. * END ASMB,Q,C HED FTN4X COMPILER (F4X.1:EXPRESSION --> POSTFIX) ** NAM F4X.1,5 92834-16002 REV.2030 800613 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 1 *************************************** * * THIS OVERLAY IS THE EXPRESSION EVALUATOR. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F..E DIMENSIONS CONSTANT BIT FROM ASSIGNS TABLE EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.DPJ DEF TO CURRENT PROCESSOR JUMP TABLE. EXT F.EM EMA FLAG BIT IN A.T. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.FES TWPE ENTRY FOR 1ST EXECUTABLE. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.L # WORDS ON SEyTACK 2 EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.P1E PASS 1 ERROR RECOVERY POINT. EXT F.S1T TOP OF STACK 1 *** OBSOLETE ? *** EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SEE RETURN FROM F4.1 EXT F.SFA F.A OF CURRENT STATEMENT FUNCTION. EXT F.SIM SAVED ITEM MODE (NEG CONSTS) EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.SLF LEVEL OF CURRENT STATEMENT. EXT F.STC SAVE F.TC (NEG CONSTS) EXT F.SVL SAVE # WORDS ON OPER STACK (F.L) EXT F.SXF COMPLEX CONSTANT FLAG EXT F.TC NEXT CHARACTER * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM TO A.T. EXT DAT.F DEFINE (AT) EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT. EXT EXN.F EXAMINE NEXT CHARACTER EXT FA.F FETCH ASSIGNS EXT ICH.F INPUT A CHARACTER. EXT II.F INPUT ITEM EXT WS1.F OUTPUT WORD TO SCRATCH FILE # 1. * * ENTRY POINTS FOR ROUTINES IN THIS SEGMENT * ENT EE.F EXPRESSION ANALIZER (THE WHOLE REASON FOR EXISTANCE) ENT PU2.F PUSH ONTO OPERATOR STACK ENT FER.F FORM PROGRAM ENTRANCE * * STATEMENT PROCESSORS IN THIS SEGMENT. * EXT F.ASS ASSIGNMEXT STATEMENT PROCESSOR EXT F.ASP ASSIGN STMT. PROCESSOR EXT F.BSP BACKSPACE STMT. PROCESSOR EXT F.CAL CALL STATEMENT PROCESSOR EXT F.CLP CLOSE STATEMENT PROCESSOR. EXT F.CON CONTINUE STMT. PROCESSOR EXT F.DCP DECODE PROCESSOR. EXT F.DOP DO STATEMENT PROCESSOR EXT F.ECP ENCODE PROCESSOR. EXT F.EDP END IF STATEMENT PROCESSOR. EXT F.EFP ENDFILE STMT. PROCESSOR EXT F.ELP ELSE STATEMENT PROCESSOR. % EXT F.ENP END STATEMENT PROCESSOR. EXT F.GOP GO TO STATEMENT PROCESSOR EXT F.IFP IF STATEMENT PROCESSOR EXT F.IQP INQUIRE STATEMENT PROCESSOR. EXT F.OPP OPEN STATEMENT PROCESSOR. EXT F.PAP PAUSE STMT. PROCESSOR EXT F.PNT PRINT STMT. PROCESSOR. EXT F.RDP READ STATEMENT PROCESSOR EXT F.RTN RETURN STMT. PROCESSOR EXT F.RWP REWIND STMT. PROCESSOR EXT F.SFP STATEMEXT FUNCTION PROCESSOR EXT F.STP STOP STMT. PROCESSOR EXT F.THP THEN STATEMENT PROCESSOR. EXT F.WRP WRITE STATEMEXT PROCESSOR * * THE FORMAT PROCESSOR IN 'DSP.F' * THE MODIFIED STMT # FETCHER. * EXT F.FMT FORMATS. EXT ISD.F INPUT STMT #, MODIFY IF 'DO' TERM. SPC 2 A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 1 DEC 1 OVERLAY NUMBER SKP * ************************ * * PROCESSOR JUMP TABLE * * ************************ SPC 1 * THIS TABLE IS INDEXED BY THE KEYWORD ORDINAL DETERMINED BY * THE DISPATCHER. THE PROCESSORS ARE LOCATED IN BOTH SEGMENTS * 0 AND 1; THIS TABLE IS DUPLICATED IN EACH SEGMENT, SO THAT THE * MAIN HAS NO REFERENCES TO TYPE 7 ROUTINES IN THE SEGMENTS. * THE SEGMENTS MUST SET UP 'F.DPJ' ON ENTRY TO POINT TO F.PJT . * THE ORDINALS FOR THE FIRST 3 ENTRIES ARE SPECIAL-CASED IN THE * DISPATCHER, AND ARE NOT TRUE ORDINALS. * DEF F.DOP DO (-2) DEF F.ASS ASSIGNMENT STMT (-1) F.PJT DEF F.SFP STMT FCT. (0) DEF F.IFP IF (1) DEF 0 EMA DEF F.ENP END DEF F.CAL CALL DEF F.GOP GO TO DEF F.RDP READ DEF F.STP STOP DEF 0 REAL DEF 0 DATA DEF F.THP THEN DEF F.ELP ELSE DEF F.OPP OPEN DEF F.WRP WRITE DEF F.PNT PRINT DEF F.PAP PAUSE DEF F.EDP ENDIF DEF F.CLP CLOSE DEF F.RTN RETURN DEF F.FMT FORMAT DEF F.RWP REWIND DEF 0 COMMON DEF F.ASP ASSIGN DEF F.ECP ENCODE DEF F.DCP DECODE DEF F.EFP END FILE DEF 0 INTEGER DEF 0 COMPLEX DEF 0 LOGICAL DEF 0 PROGRAM DEF F.IQP INQUIRE DEF 0 FUNCTION DEF F.CON CONTINUE DEF 0 EXTERNAL DEF 0 IMPLICIT DEF 0 DIMENSION DEF F.BSP BACKSPACE DEF 0 BLOCK DATA DEF 0 SUBROUTINE DEF 0 EQUIVALENCE DEF 0 DOUBLE PRECISION SKP * *************************** * * HANDLE PROGRAM ENTRANCE * * *************************** * * CALLED AT FIRST STATEMENT FUNCTION AND AT FIRST EXECUTABLE. * FER.F NOP LDA F.FES ALREADY GENERATED ENTRY SEQUENCE ? SZA,RSS JMP FER02 NO. GO DO IT. * SSA YES. WAS IT DUE TO STATEMENT FUNCTION ? JMP FER.F,I NO. JUST EXIT. * LDA KK37 YES. DEFINE THE TWPE ENTRY. JSB WR2.F LDA F.FES JSB WR2.F JMP FER.F,I THAT'S ALL. * * IF BLOCK DATA OR MAIN, NO PARAMS. * FER02 LDA F.SFF IF BLOCK DATA LDB F.SBF OR MAIN PROG SZB CPA K2 JMP FER03 THERE IS NO ENTRY * * SET F.AT=DUM FOR ALL FORMALS. * STB F.A JSB FA.F SET UP F.AF FOR LOOPING. * FER00 LDA F.AF GET THE LINK TO THE NEXT DUMMY STA F.A SET AS CURRENT. SZA,RSS IF END OF LIST JMP FER03 GO OUTPUT THE OPERATOR. * JSB FA.F SET UP ASSIGNS (INCL F.AF) LDA DUM TYPE IT "DUM" JSB DAT.F JMP FER00 GO FOR MORE. SKP * WRITE PROGRAM ENTRY OPERATOR TO PASS FILE & EXIT. * FER03 LDA KK31 OPCODE=31, ONE ARGUMENT. JSB WR2.F LDA F.SBF ALSO F.A OF SUB/FCT. JSB WR2.F LDA F.SLF IF DUE TO STATEMENT FUNCTION, CCB (B=-1 TO FLAG NOT STMT FCT) CPA K3 RSS (YES) JMP FER04 NO. SET FLAG TO -1. * LDA TWPE YES. SET UP THE JUMP AROUND. JSB ESC.F JSB AI.F LDB F.A F.FES = F.A OF A TWPE ENTRY. FER04 STB F.FES JMP FER.F,I * DUM OCT 5000 TWPE OCT 40000 F.IM=TWPE. CPX OCT 50000 ZPX OCT 140000 K2 DEC 2 KK31 BYT 1,37 KK37 BYT 1,45 B377 OCT 377 SKP * *------------------* * * START HERE * * *------------------* * F4.1 LDA DFP1E JUST SET UP ERROR RECOVERY; STA F.ERX LDA DFPJT AND ADDRESS OF PROC. JUMP TABLE. STA F.DPJ JMP F.SEE NOTHING ELSE TO DO HERE. * DFP1E DEF F.P1E PASS 1 ERROR RECOVERY ADDRESS. DFPJT DEF F.PJT DEF TO PROCESSOR JUMP TABLE. EQFLG NOP EQUALS FLAG SKP * *********************** * * EXPRESSION ANALYZER * * *********************** SPC 1 * CALLING SEQUENCE: * * (POSSIBLY SET F.IM &/OR F.SIM) * (POSSIBLE SET (A)=#SOFT LEFT PARENS) * JSB EE.F * BYT FLAGS,TYPE * -->(A) = # SOFT LEFT PARENS UNUSED. * * WHERE THE FLAGS ARE: * * BIT 15: SOFT PAREN & F.SIM BIT. IF SET, * (A) MUST CONTAIN # OF SOFT PARENS, * AND F.SIM MUST BE SET BY AN IDN.F * CALL. * BIT 8: TEMP FLAG FOR PASS 2. * * THE TYPES ARE: * * 0, STATEMENT FUNCTION. * 1, SUBROUTINE CALL STATEMENT. * * 2, DO INITIAL PARAMETER. * 3ń, ARRAY ELEMENT IN I/O LIST. * 4, DO STATEMENT TERMINAL OR STEP-SIZE PARAMETER. * 5, COMPUTED GO TO INDEX EXPRESSION. * * 6, ASSIGNMENT STATEMENT. * 7, IF EXPRESSION. * * 8, INPUT LIST-STYLE EXPRESSION. * * 9, OUTPUT LIST-STYLE EXPRESSION. * * AND THE STARRED (*) TYPES REQUIRE THAT F.IM AND F.TC BE * SET UP AS IF AN II.F CALL HAD BEEN MADE, AND THE OTHER * TYPES REQUIRE THAT THE NEXT ICH.F CALL GETS THE FIRST * CHARACTER OF THE EXPRESSION. * * INITIALIZE F.SIM & SOFT PAREN COUNT. * EE.F NOP LDB EE.F,I SET UP SOFT LEFT PAREN COUNT. SSB,RSS IF FLAG NOT SET, CLA THEN COUNT IS ZERO. STA T1EE CLA ALSO ZERO OUT F.SIM SSB,RSS IF THE FLAG ISN'T SET. STA F.SIM SKP * SEND START OP TO PASS FILE & INIT LOCALS. * LDA KK32 SEND COUNT & OPERATOR TO PASS FILE. JSB WS1.F LDA EE.F,I (A) = TYPE & FLAGS. JSB WS1.F SEND THRU PASS FILE. LDA EE.F,I GET IT BACK, ISZ EE.F AND B377 EXTRACT TYPE IN LOW 4 BITS, STA TYPEX AND SAVE IT. LDA F.L SAVE NO.OF WORDS ON OPERATOR STA F.SVL STACK ON ENTRY (USUALLY 0) CLA STA EQFLG EQFEG =0 (NO '=' OP. ALLOWED) STA EMAFL CLEAR EMA ASSIGNMENT FLAG. STA INAFL CLEAR INVERSE ASSIGN FLAG. CCA STA OPCOD INITIALIZE OPCOD TO -1. STA PRIOR INITIALIZE PRIORITY TO -1. STA LASTC SET PREVIOUS F.TC TO -1 AS A FLAG. * * TYPE-DEPENDENT INITIALIZATION. * LDA F.IM (IN CASE ALREADY UNDER WAY.) LDB EEJT1 SELECT NEXT OP BY JUMP TABLE. ADB TYPEX LDB B,I JMP B,I EEJT1 DEF *+1 DEF EE030 STMT FCT. DEF EE003 SUBR CALL. DEF EE007 DO INITIAL; ITEM ALREADY SCANNED. DEF EE030 UNIT # ? DEF EE03j0 DO TERMINAL / STEP-SIZE. DEF EE030 COMPUTED GOTO. DEF EE009 ASSIGNMENT: ITEM ALREADY SCANNED. DEF EE11 IF: STACK '('. DEF EE035 INPUT ITEM: ITEM ALREADY SCANNED. DEF EE005 OUTPUT ITEM: DITTO, BUT CHECK UNARY OP. SKP * SUBR CALL: IF SIMPLE, DO IT NOW. * EE003 LDB F.TC CPB B50 IS F.TC A LEFT PARENTHESIS? JMP EE035 YES; PROCESS ARG LIST. * LDA F.A SUBROUTINE CALL (NO ARGS) JSB WR1.F OPND = SUB NAME, LDA K33 THEN OPERATOR. JSB WR2.F JMP EXIT * * FOR OUTPUT LIST, IF NO ITEM, ALLOW FOR UNARY OP. * EE005 LDB F.TC FOR +/- CHECK. CPB B53 IF +, RSS CPB B55 OR -, SZA AND NO ITEM YET, JMP EE035 (NO. REGULAR START) JMP EE038 THEN JOIN UNARY +/- IN PROGRESS. * * DO INITIAL. EXPECT '='. * EE007 CCA JUST SET EQFLG = -1. STA EQFLG JMP EE035 AND START WITH ITEM ALREADY SCANNED. * * ASSIGNMENT. EXPECT '=', SET EMA FLAG. * EE009 CCA STA EQFLG JMP EE036 SPC 2 T1EE NOP SOFT LEFT PAREN COUNT. KM1 DEC -1 KK32 BYT 1,40 COUNT & OPERATOR. K33 DEC 33 SKP * ********************************** * * EXPRESSION EVALUATOR MAIN BODY * * ********************************** SPC 1 * IF + OR -, DECIDE IF UNARY OR BINARY. * EE03 LDB F.TC SAVE CURRENT F.TC AS EE01 STB LASTC PREVIOUS F.TC. EE030 JSB EXN.F EXAMINE NEXT CHARACTER. CPA B53 IF '+' JMP EE031 CPA B55 OR '-', RSS SEE IF IT IS UNARY JMP EE034 NEITHER; INPUT ITEM AND CONT. EE031 LDA LASTC A '+' OR '-' IS THE NEXT CHAR. CPA B75 IF LAST F.TC WAS AN '=' JMP EE032 CPA B50 OR '(', JMP EE032 CPA ̸B54 OR COMMA, JMP EE032 THEN '+' OR '-' IS UNARY. SSA IF NEGATIVE, BEGINNING OF EXPR., JMP EE032 THEN '+' OR '-' IS UNARY. LDA KM11 STA TKM9 COUNTER FOR 11 LOG. & REL. OPS. LDB RELOP EE131 LDA B,I (A)=RELATIONAL OPERATOR CPA LASTC IF LASTC IS REL OP JMP EE032 THEN '+' OR '-' IS UNARY ADB K2 ISZ TKM9 LOOKED AT ALL OF THEM? JMP EE131 NO. JSB ICH.F NONE OF ABOVE; IT IS A BINARY CLA '+' OR '-'. INCREMENT F.CC PAST IT STA F.IM F.IM=0 FOR BINARY + OR - JMP EE035 SET F.IM IN A TO 0 AND PROCESS IT. SPC 1 EE032 JSB II.F INPUT OPERATOR OR SIGNED CONSTANT SZA IF F.IM#0, THEN IT IS A SIGNED JMP EE035 CONSTANT. GO PROCESS IT. EE038 LDB F.TC MUST BE + OR - A VARIABLE. CPB B53 IF A '+', IGNORE IT JMP EE01 SAVE IT AS LAST F.TC EE033 LDA B40 CHANGE F.TC = UNARY - TO BLANK. JMP EE14A PROCESS UNARY '-' DIRECTLY. SPC 1 B40 OCT 40 LASTC NOP KM11 DEC -11 TKM9 NOP COUNTER RELOP DEF OR. SKP * ***************** * * GET NEXT ITEM * * ***************** * * OPERATORS & DELIMS DONE ELSEWHERE. * EE034 LDA F.SIM DELAYED CONSTANT ? SZA,RSS JMP EE037 NO. * STA F.IM YES. SET IT UP. LDB F.STC STB F.TC CLB STB F.SIM CLEAR THE FLAG. JSB AI.F ENTER INTO A.T. JMP EE035 ALREADY WAS INPUT! * EE037 JSB II.F ELSE INPUT AN ITEM. EE035 LDB F.TC CCE,SZA,RSS IS F.IM=0? JMP EE08 YES, NO OPERAND TO STACK * * CHECK FOR MISSING OPERATOR. * CHECK ITEM USAGE. * OUTPUT OPERAND TO PASS FILE. * CLB,RSS CLEAR THE EMA ASSIGNMENT FLAG, EE036 LDB F.EM (SET IT PROPERLY FOR FIRST ITEM) + STB EMAFL SINCE ONLY APPLIES TO FIRST ITEM. LDB LASTC IF CHARACTER PRECEDING CPB B51 NAME OR CONSTANT IS ')', JMP EE16 ERROR 53 - MISSING OPERATOR LDA F.TC IF CURRENT F.TC IS .NOT., CPA NO JMP EE16 MISSING OPERATOR. LDB F.IU ITEM USAGE ZERO ? SZB,RSS JMP EE045 YES, ILG USE OF NAME. LDA F.A WRITE F.A TO PASS FILE. JSB WR1.F LDB F.TC IS F.TC A '(' ? CPB B50 JMP EE04 YES, MAKE SURE F.IU=SUB OR ARR JMP EE09 FIND OUT WHAT OP OR DELIM IS. SKP * ITEM FOLLOWED BY '('. MUST BE SUB OR ARRAY. * EE04 LDB F.A IS IT THE CURRENT FUNCTION/SUB ? LDA K75 CPB F.SBF JSB ER.F YES. RECURSION ILLEGAL. LDB F.IU ELSE WHAT IS IT ? CPB ARR F.IU = ARRAY? JMP EE05 YES, '(' IS VALID. STACK. * CPB SUB F.IU=SUBPROGRAM? RSS YES, '(' IS VALID. JMP EE045 NO. ILLEGAL USE. * LDA TYPEX IF SUBROUTINE CALL, (TYPE=1), CMA,INA (-1 IFF SUB CALL) AND LASTC AND PROCESSING THE SUBROUTINE NAME, INA,SZA,RSS WELL ? JMP EE043 YES. GO STACK IT. * LDA F.A,I NO. FUNCTION REF, FLAG IT. IOR B20 STA F.A,I EE043 LDA KK26 ('[' IS CODE=26, PRIOR=1.) JSB PU2.F STACK OPERATOR. LDA OPCOD SEND TO PASS FILE TOO. JSB WR2.F JMP EE48 GO CHECK FOR ALT RTNS. * EE045 LDA K22 ILLEGAL USAGE OF NAME JSB ER.F * * ARRAY REFERENCE. * EE05 LDA KK27 STACK '<' AS CODE=27, PRIOR=1. LDB EMAFL IF THIS IS A TARGET EMA VARIABLE CCE,SZB,RSS THEN (E=1) JMP EE06 (NO) * RAL,ERA SET THE SIGN BIT TO REMEMBER THAT. STB INAFL ALSO SET INVERSE ASSIGN FLAG. EE06 JSB PU2.F STACK OPERATOR LDA OPCOD ALSO SEND TO PASS FILE. JSB WR2.F JMP EE03 INPUT NEXT ELEMENT SPC 1 B20 OCT 20 B50 OCT 50 B53 OCT 53 B54 OCT 54 B55 OCT 55 K22 DEC 22 K75 DEC 75 KK26 BYT 32,1 CODE=26, PRIORITY=1 (LEFT BRAKT) KK27 BYT 33,1 CODE=27, PRIORITY=1 (LEFT BRACE) SUB OCT 200 ARR OCT 600 F.IU=3 (ARRAY) NO ASC 1,NO INAFL NOP INV ASS FLAG: CHANGES = TO INVERSE =. EMAFL NOP EMA FLAG: CURRENT ITEM IS FIRST & EMA. SKP * ************************* * * OPERATOR OR DELIMITER * * ************************* SPC 1 * CHECK FOR '('. * CHECK FOR ADJACENT OPERATORS. * EE08 CPB B50 IS F.TC = '('? JMP EE11 YES, IT MUST START A SUB EXPRES. EE09 LDA F.IM F.IM OF PRESENT ITEM IS 0? SZA JMP EE095 NO - PROCESS OPERAND-TC COMBINATION. LDA LASTC YES - PREVIOUS CHARACTER IN THIS CPB NO IF PRESENT OPERATOR IS .NOT. JMP EE096 CPA B51 2 ADJACENT SPECIAL CHARACTER JMP EE095 COMBINATION MUST BE A ')' OR * CPB B51 MAYBE AN EMPTY PARAM LIST ? RSS MUST END WITH RIGHT PAREN. JMP EE16 (NO. ERROR 53) * LDA OPCOD YUP. HOW ABOUT BEFORE IT... CPA SOP[ WAS LAST A FUNCT/SUB LEFT PAREN ? JMP EE095 YES. EMPTY PARAM LIST. JMP EE16 ERROR 53 - MISSING OPERAND. * EE096 CPA NO IF PREVIOUS OPERATOR IS .NOT., JMP EE16 ERROR 53 - ADJACENT OPERATORS JMP EE14 PROCESS DIRECTLY * * CHECK FOR ')' ',' 'C/R' * EE095 CLA (A=0) CPB B51 F.TC = ) ? JMP EE12 YES CPB B54 NO, IS F.TC = ',' JMP EE12 YES CPB B15 NO, IS F.TC = 'C/R' ? RSS CPB B47 OR SINGLE QUOTE, RSS CPB B72 OR COLON ? JMP EE115 YES. (A)=0. JMP EE14 GO SEARCH FOR THE OPi ERATOR. * EE12 LDB OPCOD ')' OR ','; CHECK FOR: CPB SOP[ TOS IS START OF SUBR CALL, THEN IT LDA K59 MIGHT BE EMA CALL-BY-REF; GET OP. CPB SOPPR TOS IS LEFT PAREN, THEN IT MIGHT LDA K60 BE EMA CALL-BY-VALUE; GET OP. CPB SOP< TOS IS START OF ARRAY REF, THEN FORCE LDA K60 SUBSCRIPT MAPPING BEFORE ARRAY MAPPING. STA VREFF SAVE THAT AS THE VALUE/REFERENCE FLAG. * LDA K3 SET CURRENT PRIORITY OF DELIMITER EE115 STA CPRIO TO 3 AND CURRENT OPCOD=0, THEN CLA GENERATE CODE USING F.TC LATER STA CCODE TO 'REMEMBER' WHAT DELIMITER JMP EE40 WAS SCANNED. SPC 1 B52 OCT 52 B75 OCT 75 KK25 BYT 31,1 CODE=25, PRIORITY=1 (LEFT PAREN) K59 DEC 59 OPCODE FOR CALL-BY-REF SIGNAL. K60 DEC 60 OPCODE FOR CALL-BY-VALUE SIGNAL. SPC 1 * LEFT PAREN. TAKE CARE WITH COMPLEX CONSTANTS. * EE11 STB F.SXF SET TO NON-ZERO AS A FLAG LDA KK25 STACK '(' AS CODE=25,PRIOR=1. JSB PU2.F STACK THE '(' JSB II.F INPUT NEXT ITEM LDB F.NT (B)= ITS NAME TAG CPA CPX IF ITS ITEM MODE IS COMPLEX AND RSS CPA ZPX SZB,RSS IT IS A CONSTANT, JMP EE110 NOT A COMPLEX CONSTANT STACK WAS RIGHT JSB PO2.F SHOULD NOT HAVE STACKED THE '(' SO FIX IT JMP EE035 A COMPLEX CONSTANT WAS INPUT. * EE110 LDA LASTC IF PREVIOUS F.TC IS A ')' CPA B51 JMP EE16 ERROR 53 - MISSING OPERATOR. LDA B50 STA LASTC SET PREVIOUS F.TC TO '('. LDA F.IM GET F.IM OF ITEM JUST INPUT. SZA JMP EE035 LDB F.TC IF CHAR INPUT IS CPB B53 UNARY +, THEN JMP EE01 IGNORE IT AND INPUT NEXT ITEM. CPB B55 UNARY -, THEN JMP EE033 PROCESS AS UNARY MINUS JMP EE035 OTHERWISE PROCESS CURRENT ITEM SKP * |W ***************************** * * SEARCH TABLE FOR OPERATOR * * ***************************** SPC 1 * THE SEARCH PROPER. * EE02 JSB ICH.F SHOVE F.CC PAST SECOND '*' LDA DSTAR CHANGE F.TC TO '**' EE14A STA F.TC EE14 CLA (A) WILL BE CODE FOR OPERATOR LDB OPTBL INB EE15 STB T0EE SEARCH OP. TABLE FOR INA MATCH WITH F.TC. LDB B,I (B) = THIS OP IN TABLE. CPB F.TC IS THIS IT ? JMP EE17 YUP ! LDB T0EE NO. ADVANCE IN TABLE. ADB K2 CPB EOPTB END OF TABLE ? JMP EE16 YES. ERROR. JMP EE15 NO. GO ON. * * GOT IT. CHECK FOR '**'. * EE17 STA CCODE FIRST, SAVE CODE. CPB B52 IS IT '*' SO FAR ? RSS YES. JMP EE19 NO. JSB EXN.F YES. LOOK AT NEXT CHAR. LDB B52 CPB F.TC IS IT '*' ? JMP EE02 YES. SET UP '**'. STB F.TC NO. RESTORE F.TC . * * DON'T ALLOW A SECOND '='. * EE19 CPB B75 IS OPERATOR AN '='? RSS YES, MAKE SURE IT IS LEGAL. JMP EE18 NO, PROCESS OPR * LDA INAFL YES. IS INVERSE ASSIGN SET ? LDB K19 SZA IF SO, STB CCODE CHANGE OPCODE. (PRIORITY IS SAME) ISZ EQFLG IS '=' ALLOWED AND NONE SEEN YET? JMP EE16 NO,'=' IS ILLEGAL IN PRESENT EXP SKP * SET UP CODE & PRIORITY. * IF PRIOR > TOP-OF-STACK, STACK IT, ELSE USE IT. * EE18 ISZ T0EE YES, OPERATOR IS LEGAL, PROCESS. LDB T0EE,I CPRIO _ PRIORITY OF OPERATOR STB CPRIO LDA CCODE (A) _ CODE (ORDINAL) OF OPERATOR. ALF,ALF IOR B (A) _ CODE, PRIORITY CMB,INB CHECK OP PRIORITY AGAINST TOP OP ADB PRIOR CPA KK07 IF OPERATOR IS **, ADB KM1 EVALUATE RIGHT-TO-LEFT. SSB,RSS IS PRIORITY > TOP OP. PRIORITY? JMP EE20 NO, GENERATE CODE JSB PU2.F YES, STACK OP, INPUT NEXT ITEM JMP EE03 SPC 1 K3 DEC 3 B15 OCT 15 EOPTB DEF EOPT B47 OCT 47 ' B72 OCT 72 : B51 OCT 51 DSTAR ASC 1,** KK07 BYT 7,13 CODE=7, PRIORITY=11 (**). CCODE NOP CURRENT OPERATOR CODE CPRIO NOP CURRENT OPERATOR PRIORITY OPTBL DEF TABLE-1 OPERATOR TABLE T0EE NOP SPC 5 * *********************** * * HANDLE THE OPERATOR * * *********************** SPC 1 * CHECK FOR END & MISMATCHED PARENS. * EE42 SSA IF OPCOD < 0, JMP EXIT END OF INPUT EXPRESSION. EE20 LDA OPCOD NEXT OPERATOR CODE CPA SOP< IF '<' '(' OF ARRAY JMP EE44 ERROR - MISMATCHED PARENS. CPA SOPPR IF '(' JMP EE44 ERROR - MISMATCHED PARENS. CPA SOP[ IF '[' JMP EE44 ERROR - MISMATCHED PARENS. * * WRITE OPERATOR TO PASS FILE. * JSB WR2.F JSB PO2.F POP OPERATOR OFF STACK 2. SKP * CONTINUE POPPING OPERATORS OF SAME OR GREATER PRIOR. * EE40 LDA CPRIO CMA,INA ADA PRIOR COMPARE OPERATOR PRIORITIES SSA,RSS IF PRIOR=0, CONTINUE GEN. CODE * * NOW HANDLE THIS OPERATOR. * LDA CCODE SZA,RSS IF CCODE = 0 JMP EE41 THEN CURRENT OP IS ')',',' OR C/R ALF,ALF NO, STACK OPERATOR IOR CPRIO (A) = CCODE,CPRIO JSB PU2.F STACK OPERATOR JMP EE03 * SOPPR OCT 31 SOP[ OCT 32 SOP< OCT 33 K34 DEC 34 TYPEX NOP TYPE OF EXPRESSION. OPCOD NOP TOP OPERATOR CODE. PRIOR NOP TOP OPERATOR PRIORITY. VREFF NOP EMA CALL-BY-(VALUE/REFERENCE) FLAG. SKP * *********|***************** * * HANDLE ')' ',' 'C/R' * * ************************** SPC 1 * C/R: END OF EXPR. * COMMA: IF TOP IS SUB OR ARR ([,<), KEEP GOING. * ELSE IF DO PARAMETER, EMPTY OP STACK. * ELSE ERROR. * EE41 LDA F.TC CPA B15 IF DELIMITER IS CARRIAGE RETURN, RSS CPA B47 OR SINGLE QUOTE, RSS CPA B72 OR COLON, JMP EXIT GO TO END OF EXPRESSION EVAL. * LDA VREFF ')' OR ','; SEE WHETHER SZA CALL-BY-VALUE/REF SET. JSB WS1.F YES, OUTPUT THAT INFO. LDA F.TC (RESTORE CHAR) CPA B51 IF DELIMITER IS ')', JMP EE43 GO HANDLE IT. * * COMMA. * LDA OPCOD NO, MUST BE ',' CPA SOP[ IF TOP OPERATOR IS '['. JMP EE48 GO CHECK FOR ALTERNATE RETURNS. * CPA SOP< IF TOP OPERATOR IS '<' JMP EE03 CONTINUE SCAN OF EXPRESSION. * LDB EEJT2 CHECK TYPE OF INPUT EXPR. ADB TYPEX LDB B,I JMP B,I EEJT2 DEF *+1 DEF EE16 STMT FCT - ERROR. DEF EE16 SUBR CALL - ERROR. DEF EE42 DO INITIAL - O.K. DEF EE42 UNIT # - O.K. DEF EE42 DO TERM / STEP-SIZE - O.K. DEF EE16 COMPUTED GOTO - ERROR. DEF EE16 ASSIGNMENT - ERROR. DEF EE16 IF - ERROR. DEF EE42 INPUT ITEM - O.K. DEF EE42 OUTPUT ITEM - O.K. * EE16 LDA K17 ERROR, ILLEGAL OP OR DELIMITER. JSB ER.F SKP * RIGHT PAREN. MATCH WITH TOP OF STACK. * EE43 LDA OPCOD CPA SOPPR IS TOP OPERATOR '('? JMP EE45 YES * CPA SOP< IS IT AND ARRAY? JMP EE46 YES. MAY BE EMA ASSIGNMENT. * CPA SOP[ HOW ABOUT END OF FUNCTION SUB ? JMP EE47 YES. * SSA,RSS WAS STACK 4EMPTY ? JMP EE49 NO. * ADA T1EE YES. DECREMENT # LEFT PARENS AVAIL. SSA WAS THERE ONE ? JMP EE49 NO. * STA T1EE YES. UPDATE # LEFT. JMP EE50 AND CONTINUE WITH MATCHED PARENS. * EE49 LDA TYPEX INPUT LIST ITEM ? CPA K8 RSS YES. CPA K9 OUTPUT LIST ITEM ? RSS YES. CPA K4 DO TERM OR STEP-SIZE ? RSS YES. CPA K3 UNIT # ? JMP EXIT YES. * * TRUE LEFT PAREN. MAKE SURE END OF 'IF' CAUGHT. * EE44 LDA K9 JSB ER.F ERROR - MISMATCHED PARENTHESIS. EE45 JSB PO2.F POP OFF '(' EE50 LDA OPCOD SSA,RSS IF (A) <0, OPERATOR STACK EMPTY JMP EE03 NO, CONTINUE EXPRESSION SCAN LDA TYPEX YES, CPA K7 IF INPUT EXPRESSION IS AN 'IF' JMP EXIT END OF IF STATEMENT EXPRESSION CPA K8 LIKEWISE FOR INPUT LIST ITEM. JMP EXIT JMP EE03 NO, CONTINUE STATEMENT SCAN. SKP * COMMA IN SUBROUTINE/FCT REF. CHECK FOR ALT RTNS. * EE48 JSB EXN.F WELL ? LDB B54 (RESTORE F.TC FOR LASTC) STB F.TC CPA B52 * ? RSS CPA B46 OR & ? RSS JMP EE03 NO. * JSB ICH.F YES. READ THE * OR &. CLA,INA (A=1: STMT # IS NON-FORMAT) JSB ISD.F AND THE STATEMENT #. LDA F.A SEND AS OPERAND. JSB WR1.F LDA F.TC MUST END WITH: CPA B54 ',' RSS CPA B51 OR ')' JMP EE41 YES. BACK WHERE WE STARTED. JMP EE16 NO. ERROR. SKP * ARRAY. CHECK FOR EMA ASSIGNMENT. * EE46 LDA F.S2T,I WELL ? (SIGN BIT ON STACK ENTRY) SSA,RSS JMP EE47 NO. * JSB PO2.F YES. POP THE '<', AND JMP EE03 GO GET NEXT OPERATOR. * * SUBROUTINEo OR NORMAL ARRAY. * EE47 LDA K34 WRITE OPERATOR TO PASS FILE. JSB WR2.F JSB PO2.F POP THE OPERATOR. LDA PRIOR IS TOP OPERATOR PRIORITY SSA,RSS -1? (THEN OPERATOR STK IS EMPTY) JMP EE03 NO. * CLA,INA YES CPA TYPEX CALL STATEMENT? RSS (YES) JMP EE03 NO. * JSB ICH.F YES. INPUT C/R. F.CAL CHECKS FOR IT. * K19 DEC 19 INVERSE ASSIGN OPCODE. SKP * ****************** * * EXPRESSION END * * ****************** SPC 1 EXIT LDB TYPEX IF STATEMENT FUNCTION, (0), SZB JMP EXIT1 (NO) * LDA F.SFA GET ITS TYPE. STA F.A JSB FA.F LDA F.IM IS IT... CPA DBL REAL*6, RSS CPA RE8 REAL*8, RSS CPA CPX OR COMPLEX ? RSS CPA ZPX OR DOUBLE COMPLEX ? CLA,INA,RSS (A=1) JMP EXIT1 NO. RESULT FITS IN REGISTER. * JSB WR2.F YES. ISSUE ASSIGNMENT. EXIT1 LDA K35 WRITE OPERATOR TO TERMINATE. JSB WR2.F LDA T1EE RETURN (A) = # SOFT PARENS LEFT. JMP EE.F,I SPC 1 DBL OCT 60000 RE8 OCT 120000 B46 OCT 46 & K9 DEC 9 K35 DEC 35 K17 DEC 17 K4 DEC 4 K7 DEC 7 K8 DEC 8 SKP * **************** * * PUSH STACK 2 * * **************** SPC 1 * STACK 2 IS THE OPERATOR STACK. IT IS IN LOWER CORE THAN * IS STACK 1, JUST ABOVE THE ASSIGNMENT TABLE, AND GROWS * TOWARD HIGH CORE. THIS ROUTINE IS ENTERED WITH (A) = * WORD TO BE STACKED. SPC 1 PU2.F NOP PUSH STACK 2 TO STACK OPERATORS ISZ F.L F.L=F.L+1 LDB F.S2B ADB F.L STB F.S2T CPB F.S1T IF TOP TWO POINTERS SAME, JMP F.OFE DATA POOL OVERFLOW. STA F.S2T,I STACK OPERATOR JSB SPC.F UPDATE OPCOD, PRIOR OF TOP OP. JMP PU2.F,I SPC 2 * *************** * * POP STACK 2 * * *************** SPC 1 PO2.F NOP UNSTACK AND DISCARD OPERATORS CCB STB PRIOR REINITIALIZE OPCODE AND PRIOR TO 0. STB OPCOD ADB F.L STB F.L F.L=F.L-1 ADB F.S2B STB F.S2T NEW PTR TO TOP OPERATOR LDB F.L CPB F.SVL IS OPERATOR STACK EMPTY? RSS YES, EXIT JSB SPC.F NO, UPDATE OPCOD, PRIOR OF TOP OP. JMP PO2.F,I SPC 2 * ****************************** * * SEPARATE CODE AND PRIORITY * * ****************************** SPC 1 SPC.F NOP LDA F.S2T,I (A) _ TOP WORD IN OPERATOR STACK AND B377 STA PRIOR PRIOR _ PRIORITY OF TOP OPERATOR XOR F.S2T,I RAL,CLE,ERA CLEAR POSSIBLE SIGN BIT ALF,ALF STA OPCOD OPCOD _ CODE OF TOP OPERATOR JMP SPC.F,I SKP * ********************** * * WRITE TO PASS FILE * * ********************** SPC 1 WR1.F NOP OPERAND. IOR KK01 SET SIGN BIT. JSB WS1.F WRITE TO PASS FILE. JMP WR1.F,I EXIT. SPC 2 WR2.F NOP RAL,CLE,ERA CLEAR SIGN BIT. JSB WS1.F WRITE IT TO PASS FILE. JMP WR2.F,I EXIT. SPC 1 KK01 OCT 100000 SKP * OPERATOR TABLE WORD 1: THE OPERATOR. * 2-WORD ENTRIES WORD 2: ITS PRIORITY. SPC 1 TABLE OCT 75 =, OCT 1 PRIORITY=1, CODE=1 SPC 1 OCT 53 +, DEC 8 PRIORITY=8, CODE=2 SPC 1 OCT 55 -, DEC 8 PRIORITY=8, CODE=3 SPC 1 OCT 40 UNARY - (BLANK) DEC 9 PRIORITY=9, CODE=4 SPC 1 OCT 52 *, DEC 10 PRIORITY=10, CODE=5 SPC 1 OCT 57 /, DEC 10 PRIORITY=10, CODE=6 SPC 1 ASC 1,** **, DEC 11 PRIORITY=11, CODE=7 SPC 1 OR. ASC 1,OR LOGICAL OR, OCT 4 PRIORITY=4, CODE=8 SPC 1 ASC 1,AN LOGICAL AND OCT 5 PRIORITY=5, CODE=9 SPC 1 ASC 1,NO LOGICAL NOT, OCT 6 PRIORITY=6, CODE=10 SPC 1 ASC 1,LT RELATIONAL LESS THAN, OCT 7 PRIORITY=7, CODE=11 SPC 1 ASC 1,LE RELATIONAL LESS OR EQUAL TO, OCT 7 PRIORITY=7, CODE=12 SPC 1 ASC 1,EQ RELATIONAL EQUAL, OCT 7 PRIORITY=7, CODE=13 SPC 1 ASC 1,NE RELATIONAL NOT EQUAL, OCT 7 PRIORITY=7, CODE=14 SPC 1 ASC 1,GE RELATIONAL GREATER OR EQUAL TO, OCT 7 PRIORITY=7, CODE=15 SPC 1 ASC 1,GT RELATIONAL GREATER THAN, OCT 7 PRIORITY=7, CODE=16 SPC 1 ASC 1,EV LOGICAL EQUIVALENCE, OCT 3 PRIORITY=3, CODE=17 SPC 1 ASC 1,XO EXCLUSIVE OR, (ALSO .NEQV. & .EOR.) OCT 3 PRIORITY=3, CODE=18 SPC 1 ASC 1,== INVERSE ASSIGN, OCT 0 PRIORITY=0, CODE=19 * EOPT EQU * * UNS END F4.1 ASMB,Q,C HED EXECUTABLE STATEMENT PARSING FOR FTN4X. NAM EX.F,8 92834-16002 REV.2030 800814 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * ****************************!*********** * * THIS MODULE PARSES ALL EXECUTABLE STATEMENTS. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.AT ADDRESS TYPE OF CURRENT F.A EXT F.CC CHARACTER COUNT EXT F.CRT TEST FOR C/R & GO ON TO NEXT STMT. EXT F.CSL CHARACTER STRING LENGTH. EXT F.D DO TABLE POINTER EXT F.D0 ITEM SIZE. EXT F.DID ADDRESS OF F.IDI EXT F.DO LWAM - END OF DO TABLE EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.L # WORDS ON STACK 2 EXT F.LFF LOCICAL IF FLAG EXT F.LNN CURRENT LINE #. EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LSN STMT # OF CURRENT STATEMENT. EXT F.LSP LAST OPERATION FLAG EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.NTF NO-TAG FLAG. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SEG SEGMENT LOADER. EXT F.SEQ SEQUENCE COUNTER, CODE-GENERATING STMTS. EXT F.SFA STATEMENT FUNCTION F.A EXT F.SFF SUBROUTINE/FUNCTION FLAG. (SUB=0) w EXT F.STB STRING BACK JUMP FLAG EXT F.STS TO STATEMEXT SCAN EXT F.TC NEXT CHARACTER EXT F.VDM CURRENT ITEM'S VARIABLE DIMENSION BIT. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CDI.F CLEAR IDI. EXT CRP.F ISSUE CROSS-REF PAIR. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (F.AT) EXT DS.F DEFINE (F.S)=1 EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ESC.F ESTABLISH CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDL.F INPUT DUMMY LIST. EXT IDN.F INPUT ITEM, DO NOT ASSIGN. EXT II.F INPUT ITEM EXT IIV.F INPUT INTEGER VARABLE EXT ISC.F INPUT STRING CONSTANT. EXT ISN.F INPUT STATEMEXT NUMBER EXT ISY.F INPUT SYMBOL EXT ITS.F INTEGER TEST EXT IVN.F INPUT VARIABLE/ARRAY NAME. EXT KWP.F KEYWORD SEARCH, IN PROGRESS. EXT KWS.F KEYWORD SEARCH ROUTINE. EXT MVW.F INTERNAL MOVE WORDS. EXT NCT.F TEST FOR NOT A CONSTANT EXT NET.F TEST FOR NOT EMA. EXT NST.F TEST FOR NOT A SUBROUTINE NAME EXT NWI.F COMPUTE # WORDS IN ITEM. EXT RP.F INPUT ')' EXT SCP.F SAVE CURREXT STATPMEXT POSITION. EXT TCT.F TEST (A) = F.TC ELSE ER 28 EXT TS.F TAG SUBPROGRAM SUB. EXT TV.F TAG VARIABLE EXT UC.F UNINPUT COLUMN EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) EXT WS1.F WRITE WORD ON SCRATCH FILE 1. * * EXTERNALS IN EX.F . * ENT F.ASP ASSIGN STATEMENT PROCESSOR. ENT F.ASS ASSIGNMENT STATEMENT PROCESSOR. ENT F.BSP BACKSPACE STATEMENT PROCESSOR. ENT F.CAL CALL STATEMENT PROCESSOR. y/ ENT F.CLP CLOSE STATEMENT PROCESSOR. ENT F.CON CONTINUE STATEMENT PROCESSOR. ENT F.DCP DECODE STATEMENT PROCESSOR. ENT F.DOP DO STATEMEXT PROCESSOR ENT F.ECP ENCODE STATEMENT PROCESSOR. ENT F.EDP END IF STATEMENT PROCESSOR. ENT F.EFP ENDFILE STATEMENT PROCESSOR. ENT F.ELP ELSE STATEMENT PROCESSOR. ENT F.ENP END STATEMENT PROCESSOR. ENT F.GOP GO TO STATEMENT PROCESSOR ENT F.IFP IF STATEMEXT PROCESSOR ENT F.IQP INQUIRE STATEMENT PROCESSOR. ENT F.OPP OPEN STATEMENT PROCESSOR. ENT F.PAP PAUSE STATEMENT PROCESSOR. ENT F.PNT PRINT STATEMENT PROCESSOR. ENT F.RDP READ STATEMEXT PROCESSOR ENT F.RTN RETURN STATEMENT PROCESSOR. ENT F.RWP REWIND STATEMENT PROCESSOR. ENT F.SFP STATEMEXT FUNCTION PROCESSOR ENT F.STP STOP STATEMENT PROCESSOR. ENT F.THP THEN STATEMENT PROCESSOR. ENT F.WRP WRITE STATEMEXT PROCESSOR * ENT ISD.F INPUT STMT #, MODIFY FOR DO TERM. * * * EXTERNALS IN THE SEGMENT * EXT APT.F ALLOCATE PERMANENT TEMP. EXT EE.F EXPRESSION EVALUATOR EXT PU2.F PUSH ONTO STACK 2 SUB * * SYSTEM ROUTINES. * EXT .MVW * A EQU 0 B EQU 1 SUP SKP * ******************* * * IF ( PROCESSOR * * ******************* SPC 1 * ANALYZE EXPRESSION. CHECK WHAT FOLLOWS. * F.IFP JSB ICH.F MAKE SURE IS 'IF(' LDA B50 JSB TCT.F TEST F.TC=(A) ? JSB EE.F EXPRESSION EVALUATOR BYT 0,7 LDA B51 ')' JSB TCT.F F.TC-TEST JSB EXN.F EXAMINE NEXT CHARACTER SZB DIGIT? JMP IFLP6 NO. STATEMENT TO FOLLOW * * 2-WAY OR 3-WAY. GET STMT #'S & OUTPUT. * STB T3IFL SET DEFAULT OF 2-WAY. CLA,INA INPUT FIRST STMT # (NON-FORMAT) JSB ISD.F LDA F.A T1IFL = 1ST STMT #. STA T1IFL LDA B54 , JSB TCT.F CLA,INA INPUT SECOND STMT # (NON-FORMAT). JSB ISD.F LDA F.A T2IFL = 2ND STMT #. STA T2IFL LDB F.TC LDA KK39A (A=OP FOR 2-WAY) CPB B54 ',' ? CLA,INA,RSS YES. THIRD STMT # FOLLOWS JMP IFLP2 NO. 2-WAY. A=OP. JSB ISD.F INPUT THIRD STATEMENT #. LDA F.A T3IFL = 3RD STMT #. STA T3IFL LDA KK39B SEND 3-WAY OPCODE. IFLP2 JSB WS1.F OPCODE. LDA F.SEQ SEQUENCE COUNTER. JSB WS1.F LDA T1IFL 1ST STMT # JSB WS1.F LDA T2IFL 2ND STMT # JSB WS1.F LDA T3IFL 3RD STMT # SZA (IF THERE) JSB WS1.F JMP RTNP1 SKP * CLEAN UP & EXIT. * RTNP1 LDA F.LFF IF LOGICAL IF FLAG SZA,RSS NOT SET STA F.LSP RESET LAST OPERATION FLAG CILDT LDA F.LFF ILLEGAL DO TERM SZA ONLY IF NOT IN LOGICAL IF. JMP F.CRT ELSE IT'S O.K. * ILTRM CLA,INA SET LAST STATEMENT STA F.LSF FLAG ILLEGAL TERMINATION JMP F.CRT GO TEST FOR END OF STATEMENT SPC 2 * LOGICAL IF FOLLOWED BY STATEMENT. * IFLP6 LDB F.LFF LOGICAL IF FLAG SET ? LDA K52 SZB JSB ER.F YES. LOGICAL IF WITHIN LOGICAL IF LDB F.TC LOAD THE NEXT CHARACTER. CPB B15 END OF CARD? JMP IFLP1 YES. BITCH. LDA KK40 SEND THE LOGICAL IF OPCODE. JSB WS1.F LDA F.SEQ AND THE SEQUENCE COUNTER. JSB WS1.F LDA TWPE FORM TWPE ENTRY. JSB ESC.F JSB AI.F LDA F.A SAVE THE F.A AS STRING-BACK ENTRY. STA F.STB STA F.LFF SET THE LOGICAL IF FLAG JSB WS1.F SEND F.A OF IT TO PASS 2. JSB EXJN.F EXAMINE NEXT CHARACTER JSB SCP.F SAVE CURRENT CARD POSITION FOR RESCAN JMP F.STS TO STATEMENT SCAN * IFLP1 ISZ F.CC SET "F.CC" TO 1. LDA K89. ERROR 89. JSB ER.F SPC 2 B15 OCT 15 C/R B51 OCT 51 ')' B54 OCT 54 ',' K52 DEC 52 K89. DEC 89 KK39A BYT 3,47 2-WAY OPCODE. KK39B BYT 4,47 3-WAY OPCODE. KK40 BYT 2,50 LOGICAL IF OPCODE. KK41 BYT 2,51 SIMPLE GOTO OPCODE. T1IFL NOP T2IFL NOP T3IFL NOP SKP * ****************** * * THEN PROCESSOR * * ****************** SPC 1 F.THP LDB F.LFF IN LOGICAL IF ? LDA K10 SZB,RSS JSB ER.F NO. ERROR 10. * LDA KM3 YES. ALLOCATE THREE WORDS ON DO STACK. JSB DPO.F LDA B100K TOS = 100000 (ENDIF TARGET) LDB F.STB TOS+1 = ELSE TARGET = FALSE BRANCH F.A ADB B100K (SET SIGN TO FLAG THAT IT'S BLOCK IF) DST F.D,I PUT ON STACK. THP01 JSB ICH.F ADVANCE TO THE C/R. JMP ILTRM ALWAYS ILLEGAL DO TERMINATOR. * K10 DEC 10 K50 DEC 50 KM2 DEC -2 KK55 BYT 2,67 ENDIF OPERATOR. SPC 2 * ******************* * * ENDIF PROCESSOR * * ******************* SPC 1 F.EDP JSB EET.F DO SOME ERROR CHECKING. LDA KK55 OUTPUT ENDIF OPCODE. JSB WS1.F LDA F.D,I AND ENDIF TARGET. ISZ F.D JSB WS1.F LDA F.D,I AND ELSE TARGET. ISZ F.D JSB WS1.F ISZ F.D (SKIP UNUSED THIRD WORD ON STACK) JMP THP01 DONE. SPC 2 * SUBR TO CHECK IF VALID ELSE, ELSEIF, ENDIF. * EET.F NOP LDA K50 IF TRUE BRANCH OF LOGICAL IF, LDB F.LFF SZB JSB ER.F THEN ERROR 50. LDB F.LSN STATEMENT NUMBER ?? LDA K77 IF SO, WARNING. SZB JSB WAR.F LDA K30 IF DO STACK EMPTY, LDB F.D CPB F.DO JSB ER.F THEN NO MATCHING 'THEN'. INB IF TOP ENTRY IN DO STACK LDB B,I IS FOR A DO LOOP, SSB,RSS JSB ER.F THEN NESTING ERROR. * JMP EET.F,I ELSE O.K. * K30 DEC 30 K77 DEC 77 SKP * ****************** * * ELSE PROCESSOR * * ****************** SPC 1 F.ELP JSB EXN.F CHECK NEXT CHARACTER AFTER 'ELSE'. CPA B15 END OF LINE ? JMP ELP00 YES. JUST AN ELSE. * JSB ICH.F ELSE MUST BE 'ELSE IF' LDA "I" JSB TCT.F JSB ICH.F LDA "F" JSB TCT.F CCA,RSS ELSEIF. FLAG=-1. ELP00 CLA ELSE. FLAG=0. STA T1ELP SAVE ELSE/ELSEIF FLAG. JSB EET.F DO SOME ERROR CHECKING. DLD F.D,I ARE WE CURRENTLY IN AN ELSE PART ? LDA K30 CPB B100K JSB ER.F YES. TWO ELSE'S IN A ROW. * LDB F.D,I ENDIF TARGET. CPB B100K DOES IT EXIST ? RSS JMP ELP01 YES. (DUE TO ELSEIF) * LDA TWPE NO. CREATE ONE. JSB ESC.F JSB AI.F LDA F.A AND PUT IT ON STACK. STA F.D,I ELP01 LDA KK54 OUTPUT OPERATOR FOR ELSE. JSB WS1.F LDA F.D,I WITH: ENDIF TARGET. JSB WS1.F DLD F.D,I LDA B AND ELSE TARGET. JSB WS1.F LDB F.D ZAP THE ELSE TARGET, LDA B100K TO SHOW THAT WE'RE IN THE INB ELSE PART NOW, AND ONLY STA B,I ENDIF IS LEGAL FROM NOW ON. ISZ T1ELP IS IT ELSE OR ELSEIF ? JMP THP01 ELSE. DONE. SKP * ELSEIF PROCESSING. * JSB ICH.F VERIFY '(' LDA B50 JSB TCT.F JSB EE.F GET LOGICAL EXPRESSION. BYT 0,7 LDA B51 VERIFY ')' JSB TCT.F JSB KWS.F VERITY 'THEN' DEF "THEN ADA K30 CPA K30 FOUND ?  JSB ER.F NO. * LDA KK40 LOGICAL IF OPCODE. JSB WS1.F LDA F.SEQ SEQUENCE COUNTER (NOT USED HERE) JSB WS1.F LDA TWPE FORM THE TWPE ENTRY. JSB ESC.F JSB AI.F LDA F.A AND SEND IT. JSB WS1.F LDA F.A ALSO USE IT AS THE ELSE TARGET. IOR B100K LDB F.D INB STA B,I JMP THP01 DONE. * KK54 BYT 2,66 ELSE OPERATOR. T1ELP NOP ELSE/ELSEIF FLAG. "I" BYT 0,111 "F" BYT 0,106 "THEN ASC 3,THEN SKP * ******************* * * GO TO PROCESSOR * * ******************* SPC 1 F.GOP JSB EXN.F EXAMINE NEXT CHARACTER SZB CHAR. A DIGIT? JMP GOTO2 NO * CLA,INA INPUT (NON-FORMAT) STMT #. JSB ISD.F LDA F.LFF ON TRUE SIDE OF LOGICAL IF ? SZA JMP GOTO1 YES. SPECIAL CASE. * STA F.LSP NO. RESET LAST OP FLAG. LDA KK41 OUTPUT SIMPLE 'GOTO'. JSB WS1.F LDA F.SEQ WITH SEQUENCE COUNTER. JSB WS1.F LDA F.A AND STMT #. JSB WS1.F JMP RTNP1 DONE. ILLEGAL DO TERMINATOR. * GOTO1 LDA F.A LOGICAL IF. SET F.AF OF THE CMA STRINGBACK ENTRY TO THE ISZ F.STB COMPLEMENT OF THE F.A OF STA F.STB,I THE TARGET STATEMENT #. CLA CLEAR THE STRINGBACK FLAG. STA F.STB JMP RTNP1 THAT'S ALL. SPC 2 * ***************** * * ASSIGNED GOTO * * ***************** SPC 1 GOTO2 SEZ CHAR A LETTER ? JMP GOTO4 NO. DELIMITER. * ISZ F.NTF ASSIGNED; INPUT INTEGER VARIABLE JSB IIV.F (NO-TAG FLAG IN CASE LEFT PAREN AFTER) LDA F.A SAVE ITS F.A FOR LATER. STA T1GOT CLA SET DEFAULT COUNT = 0. STA T1IBL LDA F.TC BRANCH LIST ? CPA B15 JMP GO8MTO3 NO. END OF STMT. * CPA B54 YES. OPTIONAL COMMA ? RSS YES. HAVE ALREADY READ IT. JSB UC.F NO. BACK UP SO CAN RE-READ LEFT PAREN. JSB IBL.F INPUT BRANCH LIST GOTO3 LDA KK42 OUTPUT ASSIGNED GOTO OPERATOR. JSB WS1.F LDA T1GOT AND VARIABLE. JSB WS1.F LDA T1IBL AND LENGTH OF BRANCH LIST. JSB WS1.F LDA F.LFF UNLESS IN TRUE PART OF LOGICAL IF, SZA,RSS STA F.LSP RESET LAST OP FLAG. JMP RTNP1 DONE. MAKE SURE NOT END OF 'DO'. SKP * ***************** * * COMPUTED GOTO * * ***************** SPC 1 GOTO4 JSB IBL.F COMPUTED; INPUT BRANCH LIST CPA B54 NEXT CHAR = , ? RSS (IT'S OPTIONAL) JSB UC.F NO. UNINPUT COLUMN JSB EE.F EVALUATE GOTO INDEX EXPR. BYT 0,5 LDA KK43 OUTPUT COMPUTED GOTO OPERATOR. JSB WS1.F LDA F.SEQ AND SEQUENCE COUNTER. JSB WS1.F LDA T1IBL AND LENGTH OF BRANCH LIST. JSB WS1.F LDA F.LFF UNLESS IN TRUE PART OF LOGICAL IF, SZA,RSS STA F.LSP RESET LAST OP FLAG. JMP RTNP1 DONE. MAKE SURE ISN'T 'DO' END. SPC 2 B50 OCT 50 '(' B100K OCT 100000 T1IBL NOP NO. OF STMT NUMBERS T1GOT NOP KK42 BYT 2,52 ASSIGNED GOTO OPERATOR. KK43 BYT 2,53 COMPUTED GOTO OPERATOR. SPC 2 * ********************* * * INPUT BRANCH LIST * * ********************* SPC 1 IBL.F NOP CLA STA T1IBL LENGTH = 0. JSB ICH.F MUST START WITH '('. LDA B50 '(' JSB TCT.F IBL02 CLA,INA INPUT (NON-FORMAT) STMT #. JSB ISD.F LDA F.A SEND OUT AS AN OPERAND. IOR B100K JSB WS1.F ISZ T1IBL INCREMENT NUMBER OF STMNT NOS. LDA F.TC CPA B54 ',' ? JMP IBL02 YES. GET- ANOTHER STMT NO. JSB RP.F )-INPUT OPERATOR JMP IBL.F,I DONE. SKP * **************** * * DO PROCESSOR * * **************** SPC 1 * INPUT STMT #. * F.DOP LDA K50 LDB F.LFF IN LOGICAL IF ? SZB JSB WAR.F DO IN LOG IF STATEMENT CLA,INA INPUT STMT # (NON-FORMAT) JSB ISN.F LDA F.TC IF COMMA, CPA B54 RSS LEAVE IT THERE, JSB UC.F ELSE BACK UP TO LAST DIGIT. LDA F.A T1DOP = F.A OF STMT #. STA T1DOP * * INPUT INDEX, PROCESS REST OF LINE. * JSB IIV.F INPUT INTEGER VARIABLE LDA B75 MUST BE FOLLOWED BY '='. JSB TCT.F F.TC TEST. LDA F.A T2DOP = ITS F.A STA T2DOP CLB MUST END WITH 'C/R'. JSB DCM.F COMMON 'DO' PROCESSING. LDA KK44 END OF DO STATEMENT. JSB WS1.F LDA T2DOP ALSO INDEX F.A JSB WS1.F * * PUT STMT #, CONTROL VAR, & TWPE ON STACK. * LDA KM3 ALLOCATE 3 WORDS. JSB DPO.F LDA T1DOP (D) = STMT #. LDB T2DOP (D+1) = CONTROL VARIABLE. DST F.D,I LDA TWPE FORM TWPE ENTRY. JSB ESC.F JSB AI.F LDA F.A LDB F.D (D+2) = F.A OF TWPE ENTRY. ADB K2 STA B,I JMP ILTRM EXIT. * T1DOP NOP F.A OF STMT # IN DO STMT. T2DOP NOP F.A OF INDEX IN DO STMT. B75 OCT 75 = KK44 BYT 1,54 OPCODE FOR 'DO', STEP=1. SKP * ************************ * * COMMON DO PROCESSING * * ************************ SPC 1 * INPUT: (A) = F.A OF LOOP INDEX. * (B) = END REQUIREMENT: 0=C/R, -1=). * * VERIFY THAT THE INDEX IS UNIQUE. * DCM.F NOP STB T1DCM (SAVE END FLAG) LDB F.D VERIFY UNI%QUE: SEARCH DO TABLE. DCM01 CPB F.DO END ? JMP DCM03 ALL CHECKED: OK. INB CPA B,I THIS ONE ? JMP ERR51 YES, ERROR. ADB K2 JMP DCM01 NEXT ! ERR51 LDA K51 ERROR 51 JSB ER.F NESTED DO WITH SAME CONTR VAR * * EVALUATE INITIAL,FINAL,STEP. * DCM03 JSB EE.F EVALUATE INITIAL INDEX BYT 0,2 LDA B54 , JSB TCT.F JSB EE.F EVALUATE FINAL VALUE. BYT 0,4 LDB F.TC CPB B54 F.TC = ',' ? RSS JMP DCM04 NO. NO STEP SIZE. JSB EE.F YES. EVALUATE STEP SIZE BYT 0,4 * * CHECK NEXT CHARACTER. * DCM04 LDB B15 NORMAL DO: WANT 'C/R'. LDA K9 (ELSE ERROR 9) ISZ T1DCM WHICH ? JMP DCM05 NORMAL. LDB B51 IMPLIED DO: WANT ')'. LDA K28 (ELSE ERROR 28) DCM05 CPB F.TC IS IT RIGHT ? JMP DCM.F,I YES, EXIT. JSB ER.F NO, ERROR. SPC 1 T1DCM NOP K28 DEC 28 K51 DEC 51 SKP * ****************************** * * INPUT STMT #'S IN DO LOOPS * * ****************************** SPC 1 * INPUTS A STATEMENT NUMBER, USING ISN.F, AND CHECKS * WHETHER THE STMT # ENDS A DO LOOP; IN THAT CASE, THE TWPE FOR * THE END OF THE INNERMOST LOOP (WITH THAT LABEL) WHICH CONTAINS * THE CURRENT STATEMENT IS RETURNED IN F.A INSTEAD OF THE ACTUAL * STMT # F.A . * * ENTRY: (A) = -1/0/+1 AS IN ISN.F * ISD.F NOP JSB ISN.F INPUT STATEMENT #. LDA F.A (A) = STMT # F.A LDB F.D TOP OF DO STACK. ISD01 CPB F.DO ALL CHECKED ? JMP ISD.F,I YES. NOT FOUND, EXIT WITH (F.A) INTACT. * CPA B,I NO. CHECK NEXT ENTRY. JMP ISD02 GOT ONE. * ADB K3 NOT THIS ONE. GO ON TO NEXT. JMP ISD01 * ISD02 ADB K2 GOT ONE. GET IT'S TWPE ENTRY. LDB B,I Su STB F.A AND RTN IN F.A LDA B,I SET THE F..E FLAG IN THE TWPE, IOR K8 TO INDICATE THAT IT WAS USED. STA B,I JMP ISD.F,I EXIT. SPC 2 * *************************** * * DATA POOL OVERFLOW TEST * * *************************** SPC 1 * INPUT: (A) = DELTA-D. RETURN NEW D IN B SPC 1 DPO.F NOP ADA F.D STA F.D F.D=(A) LDB A CMA,INA ADA F.LO ADA F.L (A)=LO+F.L-D SSA JMP DPO.F,I EXIT * JMP F.OFE DATA POOL OVERFLOW BAIL OUT!@*?##@@'** SKP * **************** * * READ & WRITE * * **************** SPC 1 * STANDARD-UNIT VERSIONS. * F.RDP JSB EXN.F NEXT IS '(' ? CPA B50 JMP RDP01 YES. KEYWORD FORM. * CLA,RSS READ: 0. F.PNT CLA,INA PRINT: 1. STA T0IOK LDA KK64 OPCODE 64, JSB WS1.F LDA T0IOK WITH STATEMENT TYPE. JSB WS1.F CLA SET F.IM=0 FOR RFM.F STA F.IM JSB RFM.F READ THE FORMAT; SEND THRU PASS FILE. LDA K66 OPCODE 66, TO FINISH IT. JSB WS1.F LDA F.TC CHECK DELIMETER: CPA B54 IF COMMA, JSB IOL.F GO PROCESS LIST. JMP IOK52 TERMINATE STATEMENT. (REQUIRE C/R) SPC 2 * KEYWORD VERSIONS. * F.WRP CLA,INA,RSS STATEMENT TYPE = 1. RDP01 CLA READ; TYPE = 0. JMP IOK01 GO PROCESS KEYWORDS. SKP * **************************************************** * * OPEN, CLOSE, INQUIRE, BACKSPACE, ENDFILE, REWIND * * **************************************************** SPC 1 F.OPP LDA K2 OPEN. TYPE = 2. (4) JMP IOK01 * F.CLP LDA K3 CLOSE. TYPE = 3. (10B) JMP IOK01 * F.IQP LDA K4 INQUIRE. TYPE = 4. (20B) JMP IOK01 * F.BSP CCA,RSS BACKSPACE. CODE = -1. F.EFP CLA ENDFILE. CODE = 0. RSS F.RWP CLA,INA REWIND. CODE = +1. STA T1IOK SAVE TYPE. LDA KK22 SEND SPECIAL OPCODE WITH CODE. JSB WS1.F LDA T1IOK JSB WS1.F JSB EXN.F IS IT A KEYWORD LIST ? LDB A (B) = FIRST CHAR. LDA K5 (A) = STATEMENT TYPE, IN CASE KEYWORDS. CPB B50 STARTING WITH '('. JMP IOK01 YES. GO PROCESS THAT. * JSB EE.F NO. GET UNIT # NOW. BYT 0,3 LDA KK64 DO SPECIAL SEQUENCE: JSB WS1.F OPCODE 64, LDA K5 WITH STATEMENT TYPE. JSB WS1.F LDA KK65 OPCODE 65, JSB WS1.F LDA K.UNT ONLY VALUE IS UNIT #. JSB WS1.F LDA K66 OPCODE 66 TO END IT. JSB WS1.F JMP F.CRT THAT'S ALL. * K3 DEC 3 K5 DEC 5 KK22 BYT 1,26 SKP * INITIALIZE KEYWORD FETCH LOOP. * IOK01 STA T0IOK SAVE TYPE. ADA DBTBL GET CORRESPONDING BIT. LDA A,I STA T1IOK AND SAVE THAT TOO. LDA KK64 SEND OPCODE TO START STATEMENT. JSB WS1.F LDA T0IOK WITH STATEMENT TYPE. JSB WS1.F JSB ICH.F READ & LDA B50 REQUIRE '(' JSB TCT.F IOK02 LDA NKWRD CLEAR OUT THE 'USED' BITS. CMA,INA STA T2IOK LDA KWIT FWA-1 OF TABLE. IOK03 INA CLEAR ANOTHER. LDB A,I RBL,CLE,ERB STB A,I ISZ T2IOK JMP IOK03 * CLA CLEAR OUT FLAGS. STA T2IOK UNIT FMT POSITIONAL FLAG. STA T4IOK FMT=* FLAG. STA T5IOK SEC/TER FLAG. * * GET ANOTHER KEYWORD. * IOK04 CLA FLAG F.IM: IDN.F NOT CALLED. STA F.IM JSB EXN.F BECAUSE: ONLY CALLED FOR NAMES (HERE). SEZ,RSS (E=0: LETTER/DIGIT) SZB,RSS (B#0: NON-DIGIT) JMP IOK05 NOT LETT@<ER; NOT KEYWORD. * JSB IDN.F LETTER. GET KEYWORD OR NAME. JSB UC.F REREAD THE DELIMETER. JSB ICH.F SEZ IF LONG NAME, CPA B75 OR ENDS WITH '=', JMP IOK07 THEN NORMAL KEYWORD. SKP * VALUE, NOT KEYWORD. CHECK THAT THAT'S O.K. * IOK05 LDB T2IOK MAKE SURE THAT VALUE ALLOWED HERE: ISZ T2IOK (UNIT->FMT, FMT->ILLEGAL) CLA CPB K1 FORMAT ? LDA K.FMT YES. SZB,RSS UNIT # ? LDA K.UNT YES. STA T3IOK SAVE (MISSING) KEYWORD ORDINAL. SZA EITHER OF THE ABOVE ? JMP IOK11 YES. JMP IOK99 NO. ERROR 15. * * TRUE KEYWORD. SEARCH FOR IT. * IOK07 LDA K2 BUT FIRST, DISALLOW ANY MORE POSITIONAL. STA T2IOK JSB UC.F AND BACK UP SO CAN REREAD THE '='. JSB KWP.F START MATCH IN PROGRESS. DEF IOKWL SZA,RSS FOUND ? JMP IOK99 NO. ERROR. * IOK09 STA T3IOK YES. SAVE ORDINAL. CLA SET F.IM TO INDICATE THAT STA F.IM NO ATTEMPT MADE TO READ VALUE. * * CHECK IF DUPLICATE OR ALLOWED; * SPECIAL-CASE 'FMT', 'ERR', AND 'END'. * IOK11 LDB KWIT GET TABLE ENTRY. ADB T3IOK LDA B,I SSA DUPLICATE KEYWORD ? JMP IOK99 YES. * IOR B100K NO. SET 'USED' BIT. STA B,I AND T1IOK ALLOWED ? SZA,RSS JMP IOK99 NO. SKP * CHECK FOR ILLEGAL COMBINATION. THIS IS DONE ON THE * FLY SO THAT THE CURSOR IS POSITIONED PROPERLY. * LDA T4IOK NOT ALLOWED WITH 'REC': 'FMT=*', IOR T5IOK SEC/TER, IOR T.END END, IOR T.ZBF ZBUF, IOR T.ZLN ZLEN. AND T.REC ONE OF ABOVE WITH 'REC' ? SSA JMP IOK98 YES. ILLEGAL. * LDA T.ZBF ZBUF .OR. ZLEN, S IOR T.ZLN AND T5IOK AND SEC/TER ? SSA JMP IOK98 YES. ILLEGAL. * LDA T.FIL FILE .AND. UNIT, AND T.UNT LDB T0IOK ON INQUIRE ? CPB K4 (INQUIRE=4) SSA,RSS RSS (NO) JMP IOK98 YES. ILLEGAL. * * IS ALLOWED & LEGAL. SPECIAL-CASE FMT,ERR,END,UNIT. * LDA T3IOK 'FMT' ? CPA K.FMT JMP IOK30 YES. * CPA K.ERR 'ERR' RSS OR CPA K.END 'END' ? JMP IOK40 YES. * LDB F.IM 'UNIT', CPA K.UNT AND NO VALUE YET ? SZB (YES) JMP IOK17 NO. * JSB EXN.F YES. IS IT 'UNIT=*' ? CPA B52 RSS (YES) JMP IOK15 NO. (UNIT ALWAYS R-VALUED) * JSB ICH.F YES. READ THE '*', STA T4IOK DISALLOW 'REC' IN THE FUTURE. LDA T.REC ALSO IN THE PAST. SSA JMP IOK98 * LDA T0IOK CHECK THAT READ OR WRITE. SZA CPA K1 RSS (YES) JMP IOK98 NO. ILLEGAL IN ANY OTHER. * JSB ICH.F AND THE DELIMITER. LDA KK65B WRITE TO THE PASS FILE: JSB WS1.F OP FOR ALTERNATE FORM, LDA K.UNT KEYWORD NUMBER, IOR B100K WITH WHOLE ITEM BIT, JSB WS1.F CLA THEN VALUE = 0. JSB WS1.F JMP IOK28 CHECK DELIMITER. * * DETERMINE WHETHER R-VALUED OR L-VALUED. * IOK17 CPA K.FIL IF FILE, JMP IOK15 THEN ALWAYS R-VALUED. * CPA K.IOS IF IOSTAT, JMP IOK13 THEN ALWAYS L-VALUED. * LDA T0IOK ELSE SEE IF INQUIRE: CPA K4 IF SO, THEN L-VALUED; IOK13 CCB,RSS L-VALUED: LIKE INPUT, NO EXPRESSIONS. IOK15 CLB R-VALUED: LIKE OUTPUT, EXPRESSIONS O.K. ADB KK09 SET UP EXPRESSION TYPE. STB IOK24 SKP * PARSE THE EXPRESSION. ^_ * LDA KWIT FIRST, SEE IF CHARACTER DATA. ADA T3IOK LDA A,I ALF,ALF SLA WELL ? (BIT 8) JMP IOK35 YES. GO DO THAT. * LDA F.IM NO. CALLED IDN.F YET ? SZA,RSS JMP IOK22 NO. GO CALL II.F * JSB AI.F YES. ENTER NAME IN A.T., JSB CRP.F AND CROSS-REF IT. RSS (SKIP II.F) IOK22 JSB II.F GET FIRST ITEM IN EXPRESSION. LDA IOK24 INPUT-TYPE OR OUTPUT-TYPE. CPA KK09 JMP IOK26 OUTPUT-TYPE. * JSB NCT.F INPUT-TYPE. NO CONSTANTS/DELIMETERS, JSB NST.F OR FUNCTIONS, JSB NET.F AND MUST NOT BE EMA. LDB F.TC AND REQUIRE NEXT CHAR TO BE: CPB B50 '(' RSS CPB B51 ')' RSS CPB B54 OR COMMA. RSS JMP IOL53 ELSE ERROR 17. * IOK26 LDA F.IU ARRAY ? CPA ARR RSS (YES) JMP IOK23 NO. GO DO IT, FINALLY. * LDA F.TC YES. ALL BY ITSELF ? CPA B54 I.E., FOLLOWED BY COMMA, RSS CPA B51 OR RIGHT PAREN ? JMP IOK42 YES. SEND WITH "WHOLE ITEM" BIT. * IOK23 JSB EE.F GET KEYWORD EXPRESSION. IOK24 ABS *-* LOOKS LIKE I/O LIST ITEM. IOK25 LDA KK65 SEND GENERAL KEYWORD OPCODE. JSB WS1.F LDA T3IOK AND KEYWORD ORDINAL. JSB WS1.F SKP * IF R/W UNIT, PROCESS OPTIONAL 'REC OR :SEC:TER . * LDA T0IOK READ OR WRITE ? SZA CPA K1 RSS (YES) JMP IOK28 NO. DON'T CHECK FURTHER. * LDA T3IOK UNIT ? RAL,CLE,ERA CPA K.UNT RSS (YES) JMP IOK28 NO. NO OTHERS HAVE SPECIAL SYNTAX. * LDB F.TC YES. RECORD NUMBER ? LDA K.REC (JUST IN CASE) CPB B47 I.E. LU'REC ? JMP IOK09 YES. TREAT QUOTE AS: ",REC=" . * CPB B72 NO. HOW 'BOUT COLON ? Go RSS (YES) JMP IOK28 NO. * LDA T.ZBF YES. DON'T ALLOW: ZBUF, IOR T.ZLN ZLEN, IOR T.REC REC. CMA,SSA,RSS WELL ? JMP IOK98 YES. ILLEGAL WITH SECONDARIES. * STA T5IOK NO. SET T5IOK<15> AS FLAG. JSB EE.F GET 'SEC' VALUE. BYT 1,3 LDA KK65 SEND KEYWORD OPCODE, JSB WS1.F LDA K.SEC WITH 'SEC' ORDINAL. JSB WS1.F LDA F.TC IS 'TER' PRESENT ? CPA B72 JMP IOK32 YES. GET IT. * CLA NO. CREATE ZERO, JSB EIC.F IOR B100K AND SEND THRU TO APPEAR ON STACK. JSB WS1.F JMP IOK33 * IOK32 JSB EE.F GET 'TER' VALUE. BYT 1,3 IOK33 LDA KK65 AND SEND THAT VALUE, TOO. JSB WS1.F LDA K.TER JSB WS1.F SKP * CHECK SYNTAX AFTER VALUE. * IF END, CHECK KEYWORD COMBINATIONS AGAIN. * IOK28 LDA F.TC HOW DOES IT END ? CPA B54 ',' ? JMP IOK04 YES. GET NEXT ONE. * LDA B51 REQUIRE ')'. JSB TCT.F LDA T.ZBF IF EITHER OF ZBUF/ZLEN, XOR T.ZLN THEN MUST BE BOTH. SSA JMP IOK98 NO. ERROR. * LDA T.UNT UNIT PRESENT ? SSA JMP IOK49 YES. THEN ALL'S O.K. * LDA T1IOK NO. ENCODE OR DECODE ? AND B300 SZA JMP IOK49 YES. THAT'S RIGHT. * LDA T0IOK INQUIRE & 'FILE' PRESENT ? LDB T.FIL CPA K4 INQUIRE=4, SSB,RSS INQUIRE. 'FILE' ? JMP IOK98 NOT INQUIRE OR NO FILE. ERROR. JMP IOK49 YES. INQUIRE BY FILE, O.K. * KK09 BYT 1,11 EE.F PARAM: OUTPUT ITEM, NO TEMP INIT. KM1 DEC -1 * * GET FORMAT SPECIFIER. * IOK30 JSB RFM.F COMMON WITH STD UNIT & DECODE/ENCODE. JMP IOK28 SKP * READ CHARACTER DATA ITEM. * IOK35 LDA IOK24 L-VALUE YOR R-VALUE ? CPA KK09 RSS R-VALUE. JMP IOK36 L-VALUE. CAN'T BE CONSTANT. * JSB EXN.F R-VALUE. CONSTANT STRING ? CPA B47 RSS YES. JMP IOK36 NO. THEN SAME AS L-VALUE. * JSB ICH.F YES. READ THE QUOTE. JSB ISC.F INPUT THE CONSTANT STRING. JMP IOK42 AND GO SEND IT. * IOK36 JSB IVN.F GET ITEM. (DIDN'T CALL IDN.F YET) JSB FSD.F FAKE A STRING DESCRIPTOR. JMP IOK42 GO SEND THE TEMP AS THE VALUE. * * READ STATEMENT NUMBER FOR END= AND ERR=. * IOK40 LDA F.IM MUST NOT BE NAMED. SZA JMP IOK99 NAMED. * CLA,INA GET NON-FORMAT STMT #. JSB ISN.F IOK42 LDA F.A PASS THRU FOR STACK. IOR B100K JSB WS1.F LDA T3IOK SET THE "WHOLE ITEM" BIT. IOR B100K STA T3IOK JMP IOK25 SKIP THE EXPRESSION STUFF. SKP * COMMON FORMAT READER. * SENDS FORMAT THRU PASS FILE WITH OPCODE 65. * FORMAT '*' HAS VALUE 0. 'WHOLE ITEM' BIT SET. * RFM.F NOP LDA F.IM ALREADY HAVE NAME ? SZA JMP RFM06 YES. GO ANALYZE. * JSB EXN.F NO. CHECK FIRST CHAR. SZB DIGIT ? JMP RFM02 NO. NOT STMT #. * CCA YES. GET (FORMAT) STATEMENT #. JSB ISN.F JMP RFM08 GO WRITE TO PASS FILE. * RFM02 CPA B52 '*' ? RSS (YES) JMP RFM03 NO. * LDA T.REC YES. LIST-DIRECTED; CMA,SSA,RSS ILLEGAL WITH 'REC'. JMP IOK98 'REC', ERROR. * STA T4IOK NO. SET T4IOK<15> AS FMT=* FLAG. JSB ICH.F READ THE '*', JSB ICH.F & DELIMETER. CLA AND SET F.A = 0. STA F.A JMP RFM08 GO WRITE TO PASS FILE. * RFM03 CPA B47 CONSTANT STRING ? (SINGLE QUOTE) RSS (YES) JMP RFM04 ! NO. * JSB ICH.F YES. READ THE QUOTE, JSB ISC.F AND GET THE STRING. JMP RFM08 AND GO WRITE. * RFM04 LDA K17 (ERROR #) SEZ LETTER ? (NOT DIGIT HERE) JSB ER.F NO. ERROR 17. * JSB IDN.F YES. GET NAME. RFM06 JSB AI.F VARIABLE/ARRAY NAME. JSB CRP.F LDA F.IU IF NOT ARRAY, CPA ARR RSS JSB TV.F THEN MUST BE VARIABLE, * RFM08 LDA KK65B WRITE TO PASS FILE, USING JSB WS1.F ALTERNATE FORM OF OPCODE 65: LDA K.FMT FIRST IS AS ALWAYS, IOR B100K WHOLE ITEM BIT. JSB WS1.F LDA F.A SECOND IS F.A JSB WS1.F JMP RFM.F,I DONE. SPC 2 * SET UP A FAKE STRING DESCRIPTOR. * FSD.F NOP LDB F.IM IF STATEMENT NUMBER, LDA MAX (SIZE IS MAX IF SO) SZB,RSS JMP FSD01 THEN SKIP CHECKS. * JSB ITS.F ELSE MUST BE INTEGER. JSB NET.F MUST NOT BE EMA. LDA F.IU IF ARRAY, LDB F.VDM AND VARIABLE DIMENSIONS, CPA ARR SZB,RSS THEN COMPUTE SIZE LATER, JSB NWI.F ELSE COMPUTE SIZE NOW. LDA F.D0+1 (A) = SIZE. FSD01 STA T7IOK SAVE ITS SIZE. LDA F.A AND ITS F.A . STA T6IOK LDA CHAR AND SET UP CHAR TEMP. CLB (F.CSL=0, DESCRIPTOR ONLY) STB F.CSL JSB APT.F DLD F.A,I (B)=EXTENSION ADDR. LDA T6IOK 1ST WD WOULD NORMALLY BE IOR B100K THE DESCRIPTOR ADDR, BUT STA B,I HERE IT'S F.A,I OF ITEM. INB LDA T7IOK 2ND WD = BYTE LENGTH. CLE,ELA STA B,I JMP FSD.F,I EXIT. F.A = THE DESCRIPTOR. * MAX DEC 32767 SKP * END OF I/O STATEMENT. * IOK49 JSB ICH.F READ CHAR AFTER ')'. IOK50 LDA K66 SEND END OPERATOR. JSB WS1.F LDA T0IOK IS IT READ OR WRITE ? SZA CPA K1 RSS IF SO, PROCESS LIST. JMP F.CRT ELSE TEST FOR C/R. * * FOR READ/WRITE/DECODE/ENCODE, GET LIST. * JSB UC.F UNINPUT COLUMN JSB IOL.F I/O LIST PROCESSOR. IOK52 LDA K47 TERMINATE I/O STATEMENT. JSB WS1.F JMP F.CRT WRAP IT UP. (C/R TEST) * IOK98 LDA K18 ERR 18, ILLEGAL COMBINATION OF KEYWORDS. JSB ER.F IOK99 LDA K15 ERR 15, UNRECOGNIZED OR ILLEGAL KEYWORD. JSB ER.F SKP T0IOK NOP STATEMENT TYPE; 0-5. T1IOK NOP 2**(T0IOK) T2IOK NOP UNIT, FMT AS POSITIONAL FLAG. T3IOK NOP ORDINAL OR CURRENT KEYWORD. T4IOK NOP FMT=* FLAG. T5IOK NOP SEC/TER FLAG. T6IOK NOP GENERAL TEMP. T7IOK NOP GENERAL TEMP. KK64 BYT 1,100 OPCODE 64, ONE ARG. KK65 BYT 1,101 OPCODE 65, ONE ARG. KK65B BYT 2,101 OPCODE 65, TWO VALUES. K66 DEC 66 K15 DEC 15 K18 DEC 18 K47 DEC 47 B47 OCT 47 SINGLE QUOTE. B72 OCT 72 COLON. B300 OCT 300 CHAR OCT 130000 F.IM=CHAR. SPC 2 * BIT TABLE. EACH WORD CONTAINS 2**(WORD ORDINAL). MAX = 5. * DBTBL DEF *+1 INDEXED THRU HERE. K1 OCT 1 0 K2 OCT 2 1 K4 OCT 4 2 K8 OCT 10 3 OCT 20 4 OCT 40 5 B100 OCT 100 (6,7: DECODE, ENCODE USE 0,1 & 100,200) SPC 2 * SOME KEYWORD ORDINALS. * K.END EQU K1 K.ERR EQU K2 K.FMT DEC 3 K.REC EQU K4 K.FIL DEC 6 K.RCL DEC 10 K.UNT DEC 11 K.IOS DEC 19 K.SEC DEC 31 K.TER DEC 32 K.SDS DEC 33 SKP * I/O STATEMENT KEYWORD LIST. * IOKWL ASC 21,END= ERR= FMT= REC= USE= FILE= FORM= NAME=, ASC 21, NODE= RECL= UNIT= ZBUF= ZLEN= BLANK= EXIS, ASC 21,T= NAMED= ACCESS= DIRECT= IOSTAT= NUMBER= , ASC 21,OPENED= STATUS= BUFSIZ= MAXREC= NEXTREC= F, ASC 18,ORMATTED= SEQUENTIAL= UNFORMATTED= , * * KEYWORD INFO TABLE. ONE-WORD ENTRIES; BITS 7:0 ARE THE LOGICAL * SUM OF THE BITS FOR EACH STATEMENT TYPE THIS KEYWORD ALLOWED FOR: * READ=1 WRITE=2 OPEN=4 CLOSE=10 INQUIRE=20 * BACKSPACE/ENDFILE/REWIND=40 DECODE=100 ENCODE=200 * BIT 8: CHARACTER ITEM. (ELSE INTEGER) * BIT 15: SET IFF ALREADY SEEN. * KWIT DEF * T.END BYT 0,001 01 END READ BYT 0,377 02 ERR ALL BYT 1,003 03 FMT READ/WRITE T.REC BYT 0,003 04 REC READ/WRITE BYT 1,024 05 USE OPEN/INQUIRE T.FIL BYT 1,024 06 FILE OPEN/INQUIRE BYT 1,024 07 FORM OPEN/INQUIRE BYT 1,020 08 NAME INQUIRE BYT 0,024 09 NODE OPEN/INQUIRE BYT 0,024 10 RECL OPEN/INQUIRE T.UNT BYT 0,077 11 UNIT ALL (SPECIAL DECODE/ENCODE) T.ZBF BYT 0,003 12 ZBUF READ/WRITE T.ZLN BYT 0,003 13 ZLEN READ/WRITE BYT 1,024 14 BLANK OPEN/INQUIRE BYT 0,020 15 EXIST INQUIRE BYT 0,020 16 NAMED INQUIRE BYT 1,024 17 ACCESS OPEN/INQUIRE BYT 1,020 18 DIRECT INQUIRE BYT 0,377 19 IOSTAT ALL BYT 0,020 20 NUMBER INQUIRE BYT 0,020 21 OPENED INQUIRE BYT 1,014 22 STATUS OPEN/CLOSE BYT 0,004 23 BUFSIZ OPEN BYT 0,024 24 MAXREC OPEN/INQUIRE BYT 0,020 25 NEXTREC INQUIRE BYT 1,020 26 FORMATTED INQUIRE BYT 1,020 27 SEQUENTIAL INQUIRE BYT 1,020 28 UNFORMATTED INQUIRE NKWRD ABS *-KWIT-1 # OF KEYWORDS. SKP * *************************** * * ENCODE-DECODE PROCESSOR * * *************************** SPC 1 * SET UP TYPE, KEYWORD MASK; REQUIRE '(', INITIALIZE. * F.DCP CLB,RSS DECODE. TYPE=0. F.ECP CLB,INB ENCODE. TYPE=1. STB T0IOK LDA K2 ALSO}, SET UP IOK FOR NO POSITIONAL. STA T2IOK LDA B100 KEYWORD CHECK MASK: SZB DECODE=100B, RAL ENCODE=200B. STA T1IOK JSB ICH.F READ THE '(' LDA B50 REQUIRE IT. JSB TCT.F LDA KK64 OPCODE 64, JSB WS1.F LDA T0IOK WITH STATEMENT TYPE. JSB WS1.F * * GET THE POSITIONAL PARAMETERS: RECL, FMT, SDES. * JSB EE.F GET THE CHARACTER COUNT: BYT 1,3 (IT LOOKS LIKE A UNIT NUMBER) LDA KK65 OPCODE 65, JSB WS1.F LDA K.RCL WITH 'RECL' KEYWORD #. JSB WS1.F LDA B54 REQUIRE COMMA. JSB TCT.F CLA SET F.IM=0 FOR RFM.F STA F.IM JSB RFM.F GET THE FORMAT; SEND THRU PASS FILE. LDA B54 REQUIRE COMMA. JSB TCT.F JSB IVN.F INPUT BUFFER NAME. JSB NET.F DON'T ALLOW EMA. JSB FSD.F FAKE A STRING DESCRIPTOR. LDA F.A FORCE BUFFER F.A THRU ON STACK. IOR B100K JSB WS1.F LDA KK65 OPCODE 65, JSB WS1.F LDA K.SDS WITH 'SDES' KEYWORD ORDINAL. JSB WS1.F * * JOIN KEYWORD PROCESSOR TO FINISH IT. * LDA F.TC KEYWORDS TO FOLLOW ? CPA B54 JMP IOK02 YES. GO PROCESS THEM. * JSB RP.F NO. REQUIRE & SKIP ')'. JMP IOK50 WRAP IT UP & GET LIST. SKP * ******************************** * * I/O STATEMENT LIST PROCESSOR * * ******************************** SPC 1 * INITIALIZE. * IOL.F NOP READ() OR WRITE() JSB EXN.F FIRST, SEE IF LIST EMPTY. CPA B15 WELL ? JMP IOL.F,I YES. NOTHING TO DO. * CLA NO. CLEAR SOME STATE. STA F.L NUMBER SYNTAX ENTRIES STACKED LDA F.S2B MAKE SURE STACK CUT BACK. STA F.S2T * * NEW LISTm ITEM. COUNT NUMBER OF LEADING LEFT PARENS. * IOL01 CLA STA T1IOL T1IOL = # OF '(' BEFORE START OF ITEM. STA T2IOL T2IOL = # OF ')' WITHIN ITEM. IOL03 JSB ICH.F PAREN ? CPA B50 RSS (YES) JMP IOL05 NO. GO GET ITEM. * JSB NR.F START NEW GROUP, ISZ T1IOL AND COUNT THE PAREN. JMP IOL03 TRY FOR MORE. * * IF INPUT, JUST GET THE ITEM. * IOL05 JSB UC.F (UNREAD THE CHAR AFTER THE PAREN) LDA T0IOK INPUT OR OUTPUT ? SZA JMP IOL11 OUTPUT. TRY FOR CONST OR EXPR. * JSB II.F INPUT. GET NAME. SZA,RSS DID WE GET NAME ? (OR CONST) JMP IOL53 NO. ERROR. * JSB NCT.F YES. DON'T ALLOW CONSTANTS, JSB NST.F OR FUNCTION CALLS. LDA F.TC CHECK FOR IMPLIED DO CONTROL: CPA B75 IS F.TC AN '=' ? JMP IOL24 YES. * CPA B50 '(' RSS CPA B51 OR ')' RSS CPA B54 OR ',' RSS CPA B15 OR 'C/R' RSS JMP IOL53 NOPE. ILLEGAL IN INPUT LIST. SKP * IF ARRAY NAME BY ITSELF, DO WHOLE ARRAY. * IOL07 LDB F.IU ARRAY ? CPB ARR RSS (YES) JMP IOL55 NO. THEN NOT WHOLE ARRAY. * LDA F.TC YES. SIMPLE LIST ITEM, I.E. CPA B54 FOLLOWED BY COMMA, RSS CPA B51 RIGHT PAREN, RSS CPA B15 OR C/R ? RSS (YES) JMP IOL55 NO. THEN NOT WHOLE ARRAY. * LDA F.A YES. WHOLE ARRAY. IOR B100K SEND ITEM THRU FOR STACK. JSB WS1.F LDA K62 THEN THE WHOLE ARRAY OPERATOR. JSB WS1.F JMP IOL91 AND DONE. * * GET POSSIBLE SUBSCRIPTS ON INPUT ITEM. * IOL55 JSB EE.F GET INPUT LIST ELEMENT. BYT 1,10 TEMPS ? TYPE = 8. LDA K63 AND TELL PASS 2 TO PROCESSQ IT. JSB WS1.F * * DELIMETER AFTER LIST ITEM OR SUBLIST. * IOL91 LDB F.TC WHAT IS IT ? CPB B51 ')' ? JMP IOL22 YES, NEW RECORD AND MATCH PARENS. * CPB B54 ',' ? JMP IOL01 YES,SCAN NEXT ITEM OR SUBLIST. * CPB B15 C/R ? JMP IOL27 YES, FIX UP LOAD ADDRESS POINTERS. * IOL53 LDA K17 ELSE CONSTRUCTION ERROR: JSB ER.F ILLEGAL DELIMITER. SPC 2 TWPE OCT 40000 F.IM=4 DUMMY TWO WORD ENTRY CPX OCT 50000 F.IM=5 COMPLEX. ZPX OCT 140000 F.IM=12 DOUBLE COMPLEX. RE8 OCT 120000 F.IM=10 DOUBLE PRECISION. ARR OCT 600 F.IU=ARR K22 DEC 22 B52 OCT 52 * K17 DEC 17 K62 DEC 62 K63 DEC 63 SKP * ANALYZE OUTPUT LIST ITEM. * IOL11 JSB II.F TRY FOR AN OPERAND. SZA,RSS DID WE GET ONE ? JMP IOL15 NO. TRY FOR EXPRESSION. * LDB F.TC YES. SEE WHAT'S AFTER IT. CPB B75 IF '=', JMP IOL24 THEN DO LOOP CONTROL. * CPB B15 IF C/R, JMP IOL07 SIMPLE ITEM. (CHECK FOR ARRAY) * CPB B54 IF COMMA, RSS (YES) JMP IOL15 NO. GO TRY FOR EXPRESSION. * * COMMA AFTER ITEM. PROBABLY SIMPLE ITEM, BUT * COULD BE START OF COMPLEX CONSTANT. CHECK IT. * LDB F.NT YES. CHECK FOR COMPLEX CONST: CPA REA MUST BE TYPE REAL, RSS CPA RE8 OR REAL*8, SZB,RSS AND CONSTANT. JMP IOL07 NO. SIMPLE LIST ITEM. (CHECK ARRAY) * STA T4IOL YES. SAVE TYPE FOR CHECK LATER. JSB EXN.F SEE IF FOLLOWED BY '('. LDB B54 (RESTORE COMMA) STB F.TC LDB T1IOL AND ALSO MUST HAVE A LEFT PAREN. SZB IF NO LEFT PAREN AT START, CPA B50 OR LEFT PAREN AFTER COMMA, JMP IOL07 THEN STILL SIMPLE LIST ITEM. * LDA F.A 3^ NO. SAVE F.A OF FIRST CONSTANT. STA T3IOL JSB II.F GET NEXT THING IN LIST. LDB F.NT IF CONSTANT, CPA T4IOL AND SAME TYPE AS FIRST CONSTANT, SZB,RSS JMP IOL13 NO. NOT COMPLEX CONSTANT. * LDB F.TC YES. ENDS WITH ')' ? CPB B51 JMP IOL14 YES. SKP * NOT COMPLEX CONSTANT. OUTPUT THE REAL CONSTANT * WHICH WAS SAVED, THEN PROCESS THE ITEM AFTER COMMA. * IOL13 LDA T3IOL NOT CPX CONST: MUST OUTPUT 1ST CONSTANT. IOR B100K JSB WS1.F LDA K63 JSB WS1.F CLA THEN ZAP PAREN COUNT. STA T1IOL JMP IOL15 AND PROCESS SECOND ITEM/EXPRESSION. * * COMPLEX CONSTANT. FORM IT, AND ASSUME START OF EXPR. * IOL14 LDA F.DID FORM CONSTANT: LDB F.DID FIRST, MOVE SECOND PART UP. ADB F.D0+1 BY 2 OR 4 WORDS. JSB .MVW DEF F.D0+1 NOP LDA T3IOL NOW COMPUTE ADDRESS OF FIRST PART, ADA K2 LDB F.DID AND MOVE IT TO THE START. JSB .MVW DEF F.D0+1 NOP LDB F.IM SET UP PROPER TYPE: LDA CPX IF REAL*4, IS COMPLEX*8. CPB RE8 LDA ZPX IF REAL*8, IS COMPLEX*16. JSB ESC.F JSB AI.F JSB ICH.F GET DELIMITER AFTER IT. ISZ T2IOL COUNT ONE PAREN USED. * * START OF EXPRESSION. CALL EE.F . * IOL15 LDA T2IOL PASS THE COUNT OF LEADING LEFT PARENS. CMA,INA ADA T1IOL JSB EE.F TO EXPRESSION ANALYZER. BYT 201,11 OUTPUT, TEMPS?, USE F.SIM & PARENS. * * ACCOUNT FOR RIGHT PARENS IN EXPRESSION WHICH * MATCHED LEFT PARENS ALREADY STACKED UP. * CMA,INA - (# LEFT PARENS STILL UNUSED) ADA T1IOL + TOTAL = # USED. CMA,INA,SZA,RSS ANY ? JMP IOL19 NO. GO OUTPUT LIST OPCODE. * STA T2IOL YES.Q ACCOUNT FOR THEM. IOL17 JSB MPL.F ONCE FOR EACH RIGHT PAREN USED. ISZ T2IOL JMP IOL17 * IOL19 LDA K63 OUTPUT OPCODE FOR LIST ITEM. JSB WS1.F JMP IOL91 DONE. SKP * PROCESS ')': START NEW RECORD & MAKE SURE MATCHED. * IOL22 JSB MPL.F START NEW RECORD FOR ')' AND MATCH IT JSB ICH.F READ DELIMETER. JMP IOL91 PROCESS DELIMETER AFTER SUBLIST. * * PROCESS IMPLIED DO CONTROL INFO. * IOL24 LDA T1IOL IF CONTROL VARIABLE FOLLOWS SZA ONE OR MORE LEFT PARENS, JMP IOL53 THEN EMPTY LIST - ERROR. * JSB ITS.F CONTR. VAR. MUST BE INTEGER JSB NCT.F CONTR. VAR. MUST NOT BE CONSTANT JSB TV.F MUST BE VARIABLE * * START NEW RECORD, PROCESS 'DO' STUFF. * LDA F.A (SAVE F.A OVER NR.F) STA CONTR IOR B100K (A) = F.A,I JSB NR.F START NEW RECORD FOR INITIAL. CODE LDA CONTR (RESTORE) STA F.A CCB REQUIRE THAT IT ENDS ON ')'. JSB DCM.F COMMON DO PROCESSOR. * * FIND MATCHING '(', ISSUE OPCODE TO PASS 2. * JSB MPL.F START NEW RECORD, FIND MATCHING '(' LDA A,I GET THE F.A OF THE JUMP TARGET RAL,ERA SET INDIRECT (THRU TWPE ENTRY). STA T1DOP SAVE IT. LDA KK48 ISSUE OP. JSB WS1.F LDA CONTR WITH F.A OF INDEX (CONTROL). JSB WS1.F LDA T1DOP AND F.A OF JUMP TARGET. JSB WS1.F JSB ICH.F READ THE DELIMITER. JMP IOL91 PROCESS DELIMITER AFTER SUBLIST. * * ROUTINE TO START ')' RECORD & FIND MATCHING ')'. * MPL.F NOP A ')' FOUND START NEW RECORD AND LDA B51 (A) = ')'. JSB NR.F THEN CCA FIND THE MATCHING '(' LDB KM2 LOOK DOWN THE STACK ADA F.S2T JSB MP.F MATCH IT JMP !MPL.F,I RETURN SKP * END. SCAN SKELETON OF LIST TO DETERMINE ORDER THAT THE ENTRIES * SHOULD ACTUALLY APPEAR. OUTPUT OPCODES TO PASS 2 TO DEFINE THE * LOAD ADDRESSES (TWPE'S) SO THAT THE ORDER WILL BE CORRECT. * * THE SKELETON WILL LOOK LIKE: * * (A (B &C )D (E &F )G &H )I * * WHERE THE INTERPRETATION IS: ( LIST PROPER. * & 'DO' INITIALIZE. * ) 'DO' LOOPING. * * AND THE DESIRED LOAD ORDER IS: H,A,C,B,D,F,E,G,I. * * THIS IS ACCOMPLISHED BY OUTPUTTING THE LOAD REQUESTS IN ORDER * EXCEPT THAT LOOP INITIALIZATION IS OUTPUT JUST BEFORE THE LOOP IT * CONTROLS, BY FINDING THE MATCHING RIGHT PAREN AND BACKING UP ONE. * * START & INCREMENT SCAN OF STACK 2. * IOL27 CCA ADA F.S2B INITIALIZE STACK POINTER STA T0IOL * IOL28 LDA T0IOL POINT TO ADA K2 NEXT SYNTAX ELEMENT STACKED. STA T0IOL LDB F.S2T CMB,INB ADB A (B) _ STACK POINTER - STACK TOP SSB,RSS PAST TOP? JMP IOL33 YES, DONE PROCESSING LIST * * ): OUTPUT. &: IGNORE. (: FIND MATCHING ')'. * LDB A,I B = TYPE INDICATION. CPB B50 '(' ? JMP IOL29 YES, FIND MATCHING ')'. CPB B51 NO. ')' ? JMP IOL31 YES, OUTPUT. JMP IOL28 NO, MUST BE & (INDEX VAR), SKIP IT. SKP * '('. FIND MATCHING ')', OUTPUT THE LOOP INDEX INIT. * IOL29 LDB K2 SEARCH UP THE STACK FOR MATCHING JSB MP.F RIGHT PARENTHESIS. ADA KM3 POINTS TO SYNTAX ELEM. BEFORE ). STA T1IOL LDB A,I IS PREVIOUS SYNTAX ELEMENT AN SSB,RSS IMPLIED DO CONTROL VARIABLE? JMP IOL31 NO, JUST PARENS, DO '(' NOW. JSB ILA.F YES. OUTPUT THE INIT NOW. * * LOOK FOR A DUPLICATE INDEX VAR. * LDA T1IOԝL,I (A) = F.A,I TO DO CONTROL VAR. LDB T1IOL (B) = STK2 WORD WHICH CONTAINS(A) IOL30 ADB KM2 NEXT SYNTAX BELOW(B) IN STK2 CPB T0IOL IS NEXT SYNTAX THE ( OF DO BODY? JMP IOL31 YES, INSERT LOAD ADDRESS FOR BODY CPA B,I NO, IS IT IDENTICAL TO CONT. VAR? JMP ERR51 YES, ERROR-REPEATED CONT. VAR. JMP IOL30 NO, LOOK AT NEXT SYNTAX IN STK2. * * OUTPUT CURRENT ITEM, WHATEVER. * IOL31 LDA T0IOL ADDRESS-1 OF WORD IN STACK2 CONTAINING JSB ILA.F PTR TO LOAD ADDR. INSERT IT. JMP IOL28 CONTINUE FIXING UP LOAD ADDRS. * * CLEAR STACK & EXIT. * IOL33 CLA SET NUMBER OF ELEMENTS STACKED STA F.L ON STACK 2 TO 0. LDB F.S2B STB F.S2T JMP IOL.F,I DONE PROCESSING I/O LIST. * T0IOL NOP 0=READ, 1=WRITE. T1IOL NOP # LEFT PARENS BEFORE EXPRESSION. T2IOL NOP # RIGHT PARENS WITHIN EXPRESSION. T3IOL NOP F.A OF FIRST PART SUSPECTED CPX CONST. T4IOL NOP F.IM OF FIRST PART. CONTR NOP PTR TO IMPLIED DO CONTR. VAR. KK48 BYT 1,60 'DO' OPERATOR. KM3 DEC -3 REA OCT 20000 F.IM = REA SKP * ************** * * NEW RECORD * * ************** SPC 1 * ENTRY: (A) = '(', ')', OR F.A,I * NR.F NOP COMPLETE INFO FOR PREVIOUS JSB PU2.F STACK SYNTAX OF I/O LIST ON STK2 LDA TWPE LOAD F.IM=4 FOR TWO WORD PSEUDO ENT JSB ESC.F ESTABLISH DUMMY A.T.ENTRY JSB AI.F AND ASSIGN IT TO TABLE LDA F.A STACK ON TOP OF I/O LIST JSB PU2.F SYNTAX,THE A.T. POINTER TO THIS LDA KK49 SEND 'NR.F' OPERATOR. JSB WS1.F LDA F.A JSB WS1.F JMP NR.F,I SPC 2 * *********************** * * INSERT LOAD ADDRESS * * *********************** SPC 1 ILA.F NOP INA GET 2ND vWORD OF STACK FRAME LDA A,I I.E., THE TWPE ENTRY. STA T1ILA SAVE IT. LDA KK50 OUTPUT 'ILA.F' OPERATOR. JSB WS1.F LDA T1ILA AND F.A OF TWPE TO DEFINE. JSB WS1.F JMP ILA.F,I SPC 2 T1ILA NOP KK49 BYT 1,61 'NR.F' OPERATOR. KK50 BYT 1,62 'ILA.F' OPERATOR. SKP * ********************* * * MATCH PARENTHESES * * ********************* SPC 1 MP.F NOP MATCH PAREN IN STACK 2 STA T0MP LOCATION OF PAREN TO BE MATCHED STB T1MP SEARCH UP STK IS +2, DOWN IS -2 CLB INITIALIZE PAREN COUNTER MP01 LDA T0MP,I WORD 1 OF 2 WORD STACK 2 ENTRY CPA B50 IS SYNTAX '('? INB YES, BUMP COUNT CPA B51 NO, IS SYNTAX ')'? ADB KM1 YES, DECREMENT COUNT LDA T0MP SZB,RSS IS COUNT = 0? JMP MP03 YES, FINISH UP ADA T1MP UPDATE POINTER IN STACK TO STA T0MP POINT TO NEXT SYNTAX ELEMENT CMA,INA ADA F.S2B (A) _ F.S2B - POINTER SSA,RSS PAST BOTTOM OF STACK? JMP MP02 YES. MISMATCH ERROR. LDA T0MP CMA,INA ADA F.S2T (A) _ F.S2T - POINTER SSA,RSS PAST TOP OF STACK? JMP MP01 NO, CONTINUE SEARCH MP02 LDA K9 YES, MISMATCH ERROR JSB ER.F NO RETURN SPC 1 MP03 CCE,INA RETURN POINTER TO STK WORD +1 JMP MP.F,I FOR LOAD ADDRESS STARTING RECORD * T0MP BSS 1 T1MP BSS 1 K9 DEC 9 SKP * ****************** * * CALL PROCESSOR * * ****************** SPC 1 F.CAL JSB ISY.F INPUT NAME. LDB F.A CHECK FOR RECURSION: LDA K75 (ERROR #) CPB F.SBF SAME AS THIS PROG UNIT ? JSB ER.F YES. ERROR. LDA F.IU NO. GET USAGE. CPA SUB RSS JSB TS.F TAG SUBPROGRAM JSB DS.F SET F.S=1 TO INDICATE USED AS SUBR. JSB EE.F EVALUATE SUBROUTINE CALL BYT 0,1 JMP F.CRT * SUB OCT 200 F.IU=1 SUBPROGRAM SPC 2 * ********************************** * * ASSIGNMENT STATEMENT PROCESSOR * * ********************************** SPC 1 F.ASS JSB II.F INPUT ITEM JSB NCT.F NON-CONSTANT TEST JSB NST.F NON-SUBPROGRAM TEST JSB EE.F EVALUATE ASSIGNMENT STMT. BYT 0,6 JMP F.CRT * STRAB OCT 2000 STR-ABS F.AT = UNDEFINED SKP * ******************************** * * STATEMENT FUNCTION PROCESSOR * * ******************************** SPC 1 F.SFP JSB ISY.F INPUT SYMBOL LDA K22 IF THIS IS THE SAME NAME AS THE CURRENT LDB F.SBF SUBROUTINE MODULE CPB F.A THEN JSB ER.F TOO BAD ! * LDA K22 IF ALREADY USED LDB F.AT AS CPB STRAB ANY THING OTHER THAN TYPE RSS NO GOOD SKIP THE ERROR JSB ER.F TOO BAD ALSO! JSB TS.F ELSE TAG AS SUBROUTINE. (F.AF=0) LDA REL AND SET F.AT=DUM. JSB DAT.F LDA F.A SAVE F.A OF FUNCTION. IOR B100K WITH SIGN SET FOR AI.F STA F.SFA LDA TWPE ALLOCATE TWO-WORD BLOCK. JSB ESC.F JSB AI.F CLA INITIALIZE IT TO ZERO. CLB DST F.A,I LDA F.A GET EXTENSION ADDR, LDB F.SFA RESTORE F.A TO STMT FCT, RBL,CLE,ERB (CLEAR SIGN) STB F.A JSB DAF.F AND SET F.AF TO POINT TO EXT. * JSB IDL.F INPUT THE DUMMY LIST. LDA B75 REQUIRE '='. JSB TCT.F LDA KK31 PROG ENTRY OPCODE = 31, JSB WS1.F ONE ARG. LDA F.SFA WHICH IS F.A OF FCT. RAL,CLE,ERA WITHOUT SIGN BIT, STA F.SFA LIKEWISE REMOVE SIGN FROM HERE. JSB WS1.F JSB EE.F INPUT THE zPEXPRESSION. BYT 0,0 TYPE = 'STATEMENT FUNCTION' JMP F.CRT ALL DONE ! * K75 DEC 75 KK31 BYT 1,37 PROG ENTRY OPERATOR. REL OCT 1000 AT=1, REL DUM OCT 5000 AT=5, DUM SKP * ************************ * * PAUSE-STOP PROCESSOR * * ************************ SPC 1 * SET UP OPCODE. * F.STP LDB KK23 STOP OPCODE = 23. RSS F.PAP LDB KK24 PAUSE OPCODE = 24. STB T2PAS T2PAS = OPCODE. * * GET OCTAL NUMBER. * LDA KM6 SET LIMIT OF 5 DIGITS. STA T3PAS JSB CDI.F SET TO ZERO. PAST1 JSB ICH.F INPUT CHAR. CPA B15 C/R ? JMP PAST4 YES, DONE. * ISZ T3PAS TOO MANY ? RSS JMP PAST2 YES. ERROR. * SZB DIGIT ? JMP PAST2 NO, ERROR. * ADA BM70 8 OR 9 ? SSA,RSS JMP PAST2 YES, ERROR. * ADA K8 (A) = VALUE. LDB F.IDI UPDATE RUNNING VALUE. BLF,RBR IOR B STA F.IDI F.IDI=F.IDI+F.TC (BINARIZED) JMP PAST1 NO, TRY FOR MORE. * * ERRORS. * PAST2 LDA K16 TOO MANY OR ILLEGAL DIGITS. JSB WAR.F ONLY A WARNING. PAST5 JSB ICH.F SKIP TO C/R. CPA B15 RSS JMP PAST5 * CLA,RSS PAST4 LDA F.IDI (A) = VALUE. JSB EIC.F SET UP AS CONSTANT. STA T3PAS SAVE FOR A MOMENT. LDA T2PAS ISSUE OPCODE. JSB WS1.F LDA T3PAS THEN F.A OF CONSTANT. JSB WS1.F LDA T2PAS WHICH WAS IT ? CPA KK23 JMP RTNP1 STOP. 'NO PATH'. JMP CILDT PAUSE. JUST CHECK DO TERMINATION. SKP T2PAS NOP T3PAS NOP # OF OCTAL DIGITS KK23 BYT 1,27 'STOP' OPCODE. KK24 BYT 1,30 'PAUSE' OPCODE. K16 DEC 16 BM70 OCT -70 KM6 DEC -6 K7 DEC 7 K20 DEC 20 K21 DEC 21 SKP * L********************** * * CONTINUE PROCESSOR * * ********************** SPC 1 F.CON LDA F.LSP LAST OPERATION FLAG ADA F.LSN LAST STATEMENT NUMBER FLAG STA F.LSP F.LSP=F.LSP+F.LSN CLA STA F.LSF JSB ICH.F INPUT THE NEXT CHARACTER. LDB F.LFF LDA K89 89 SZB TRUE BRANCH OF LOGICAL "IF"? JSB WAR.F YES, COMMENT ON EFFECTIVE "NOP". JMP F.CRT C/R TEST SPC 2 * ******************** * * ASSIGN PROCESSOR * * ******************** SPC 1 F.ASP CLA INPUT ANY KIND OF STMT #. JSB ISD.F LDA F.A SAVE ITS F.A . STA T0ASP LDA "T" 'T' JSB TCT.F F.TC-TEST JSB ICH.F INPUT CHARACTER LDA "O" 'O' JSB TCT.F F.TC-TEST JSB IIV.F INPUT INTEGER VARIABLE LDA K37 LDB F.AT CPB DUM JSB WAR.F ILLEGAL USAGE OF DUMMY VARIABLE LDA KK36 'ASSIGN' OPCODE. JSB WS1.F LDA T0ASP THE STMT # F.A JSB WS1.F LDA F.A THE VARIABLE F.A JSB WS1.F JMP F.CRT C/R TEST * K89 DEC 89 KK36 BYT 2,44 'ASSIGN' OPERATOR. K37 DEC 37 "T" OCT 124 K79 DEC 79 "O" EQU K79 T0ASP NOP SAVE ASSI PTR OF STMT FUNC NAME SKP * ******************** * * RETURN PROCESSOR * * ******************** SPC 1 F.RTN JSB ICH.F INPUT A CHAR. LDB F.SBF SUBPROGRAM FLAG SET ? SZB JMP RTN01 YES. O.K. * LDA K7 NO. WARNING: RETURN IN MAIN. JSB WAR.F LDA K20 A = END OPCODE. JMP RTN04 * RTN01 LDA F.SFF SUBROUTINE OR FUNCTION ? SZA JMP RTN03 FUNCTION. NO ALTERNATE RETURNS. * LDA F.TC SUB. IS THERE AN ALT RTN VALUE ? CPA B15 JMP RTN02 NO. GO USE ZERO. * JSB UC.F BACK UP FOR EEn.F'S BENEFIT. JSB EE.F YES. SAME AS A UNIT NUMBER. BYT 0,3 JMP RTN03 GO SEND OPCODE. * RTN02 CLA SET UP A CONSTANT ZERO. JSB EIC.F IOR B100K JSB WS1.F SO IT WILL BE ON STACK. RTN03 LDA K21 RETURN OPERATOR. RTN04 JSB WS1.F WRITE OP. JMP RTNP1 DONE. SKP * ***************** * * END STATEMENT * * ***************** SPC 1 F.ENP CLA SET LINE NUMBER TO ZERO STA F.LNN TO SUPPRESS IN ERROR MESSAGES. LDA K30 IF DO STACK IS NOT EMPTY, LDB F.D THEN THERE IS AN UNCOMPLETED CPB F.DO DO LOOP OR IF-THEN-ELSE. RSS (EMPTY, O.K.) JSB WAR.F COMPLAIN. * LDA K50 LIKEWISE IF TRUE BRANCH OF LOGICAL IF. LDB F.LFF SZB JSB WAR.F * CLA SET F.CC=0 TO SUPPRESS ERRORS. STA F.CC JSB EIC.F CREATE ZERO. IOR B100K WRITE TO PASS FILE AS OPERAND, JSB WS1.F JUST IN CASE 'RETURN'. LDA K20 'END' OPCODE. LDB F.SBF SUBPROGRAM FLAG SET ? SZB INA YES, CHANGE TO 'RETURN' LDB F.LSP PATH HERE ? ADB F.LSN SZB JSB WS1.F YES, WRITE THE OPCODE. LDB K2 SET SEGMENT 2. JMP F.SEG GO LOAD THE SEGMENT * END ASMB,Q,C HED FTN4X, SEGMENT F4X.2 - INTRINSIC FUNCTIONS PHASE. NAM F4X.2,5 92834-16002 REV.2030 800613 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC<: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * ************************************ * FORTRAN-4 COMPILER SEGMENT 2 * ************************************ * * THIS SEGMENT IS THE INTRINSIC/GENERIC FUNCTION PHASE. * (ALSO DOES 'IMPLICIT NONE' CHECKING.) * IT IS EXECUTED BETWEEN PASS 1 AND PASS 2. * * GENERAL EXTERNALS. * EXT F.A ASSIGNMENT TABLE ADDR (CURRENT ENTRY). EXT F.ABT ABORT COMPILE. EXT F.CCW OPTIONS WORD. EXT F..E EXPLICIT TYPING BIT. EXT F.EQE LOCAL ERROR RECOVERY ADDRESS. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.IM CURRENT ITEM MODE. EXT F.IMF IMPLICIT FLAG. EXT F.PCT F.A OF TEMP FOR PCOUNT(). EXT F.S SUBROUTINE FLAG. EXT F.SBF F.A OF CURRENT MODULE. EXT F.SEG SEGMENT LOADER. EXT F.SFF SUBROUTINE/FUNCTION/BLOCKDATA FLAG. * EXT APT.F ALLOCATE PERMANENT TEMP. EXT AST.F ALLOCATE SPACE IN SYMBOL TABLE. EXT DAF.F DEFINE (F.AF) EXT DIM.F DEFINE (F.IM) EXT ES1.F WRITE E-O-F ON PASS FILE 1. EXT FA.F FETCH ASSIGNS. EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE ENTRY. EXT NAM.F COPY SYMBOL NAME. EXT PCC.F PRINT COMPILER COMMENT. EXT WAR.F ISSUE WARNING MESSAGE. EXT WS1.F WRITE WORD ON PASS FILE 1. * * LIBRARY. * EXT .MVW MOVE WORDS. * EXT C.SC0 CARD FILE / 2ND PASS FILE. EXT C.SC1 1ST PASS FILE. * EXT EOF.C CLIB WRITE EOF. EXT RWN.C CLIB REWIND. SPC 2 A EQU 0 B EQU 1 SUP * DEC 2 SEGMENT NUMBER. SKP * ENTRIES IN THE INTRINSICS TABLE USED IN THIS SEGMENT * HAVE THE FOLLOWING FORMAT: * * * !-------------W------------------!-------------------------------! * ! CHAR 1 ! CHAR 2 ! * !-------------------------------!-------------------------------! * ! CHAR 3 ! CHAR 4 ! * !-------------------------------!-------------------------------! * ! CHAR 5 ! CHAR 6 ! * !---!---!-------!---------------!---------------!---------------! * ! 0 ! S !A=#PRMS! B=# EXT VER ! C=# GEN VER ! D=DEFLT TYPE ! * !---!---!---!---!-----------!---!---------------!---------------! * ! IJXY=OPT. ! E=TYPE ! DOT FCT ORDINAL IF DCL EXTERNAL ! * !-----------!---------------!-------------------!---------------! * // (repeat above 1-word entry B-1 times) // * !-------------------------------!---------------!---------------! * ! 0 ! G=ARG TYPE ! H=FCT TYPE ! * !---------------------------!---!---------------!---------------! * ! DOT FUNCTION DESCRIPTION ! DOT FUNCTION ORDINAL ! * !---------------------------!-----------------------------------! * // (repeat above 2-word entry C-1 times) ! * !---------------------------------------------------------------! * * THE TABLE IS JUST A LINEAR LIST OF THESE ENTRIES, TERMINATED * BY A ZERO WORD. * * * THIS SEGMENT SEARCHES FOR MATCHES BETWEEN THE SYMBOL TABLE AND * THE INTRINSICS TABLE. WHEN IT FINDS A MATCH, IT BUILDS A SYMBOL * TABLE ENTRY OF THE FOLLOWING FORM: * * * !---!-------!---------------!-----------------------------------! * ! S ! #PRMS ! # ENTRIES ! DOT FCT ORDINAL IF DCL EXTERNAL ! * !---!-------!---------------!---!---------------!---------------! * ! 0 ! ARG TYPE ! FCT TYPE ! * !---------------------------!---!---------------!---------\------! * ! DOT FUNCTION DESCRIPTION ! DOT FUNCTION ORDINAL ! * !---------------------------!-----------------------------------! * // (repeat above pair as specified in count above) // * !---------------------------------------------------------------! * * THE F.AF FIELD OF THE ORIGINAL A.T. ENTRY GETS THE ADDRESS OF THE * NEW SYMBOL TABLE ENTRY. SKP * THE ALGORITHM FOR CREATION OF THE NEW SYMBOL TABLE ENTRY, GIVEN THE * SYMBOL A.T. ENTRY AND THE INTRINSIC TABLE ENTRY IS: * * 1) Copy number of parameters verbatim. * * 2) If symbol is not explicitly typed, make its type the default type, * as modified by the 'J' and 'Y' options. * * 3) Search the first section of the intrinsics table for a type which * matches the function type. If the IJXY field is nonzero, the * appropriate option must be on. Copy that to the new entry. * If none were found, the function didnt't have a specific name, * or it was retyped to a type for which no specific form existed. * If explicitly typed, it is not considered intrinsic, else it is * one of those generics with no specific (e.g. LOG), which is O.K. * but it can't be used as an EXTERNAL then (set dot fct value = 0). * * 4) Scan the second section of the intrinsics table. Copy each entry * unless: * a) Type was explicitly declared and function type of the * entry is different. * b) Function type is different from argument type and * function type is not default for current 'J' or 'Y' * option. * * 5) Set the number of entries found into the count field. SPC 4 * FOR 'ALIAS' FUNCTIONS & SUBROUTINES, A SYMBOL TABLE ENTRY IS SET UP * WITH THE FTN NAME, WITH THE F.AF POINTING TO ANOTHER SYMBOL TABLE * ENTRY, WHICH HAS THE TRUE NAME AND HAS THE DOT FUNCTION INTO IN *  ITS F.AF WORD. ALIAS ENTRIES HAVE F.NC=2. SKP * EQUATED SYMBOLS TO AID IN BUILDING INTRINSICS TABLE. * * SYMBOLS HAVE THE FORM 'X.V' WHERE: X=FIELD INDICATOR, * V=VALUE INDICATOR. * * E.G., 'D.INT' INDICATES THE FIELD 'D' WITH VALUE 'INT'. * * A.0 EQU 00000B NONE # PARAMETERS. A.1 EQU 10000B 1 A.2 EQU 20000B 2 A.VAR EQU 30000B VARIABLE. * B.0 EQU 0000B 0 # OF 'EXTERNAL' VERSIONS. B.1 EQU 0400B 1 B.2 EQU 1000B 2 B.4 EQU 2000B 4 * C.1 EQU 020B 1 # OF 'SPECIFIC' VERSIONS. C.2 EQU 040B 2 C.3 EQU 060B 3 C.4 EQU 100B 4 C.5 EQU 120B 5 C.7 EQU 160B 7 C.12 EQU 300B 12 * D.NON EQU 0 (NONE) DEFAULT TYPE. D.INT EQU 1 INTEGER*2 D.REA EQU 2 REAL*4 D.CPX EQU 5 COMPLEX*8 D.DBL EQU 6 REAL*6 D.RE8 EQU 12B REAL*8 * I EQU 20000B (HALF-SIZE 'CAUSE CAN'T EQU TO NEG) J EQU 30000B BITS 15:14 SPECIFY WHICH OPTION TO CHECK: X EQU 40000B 0=NEITHER, 1=I/J, 2=X/Y, 3=UNUSED. Y EQU 50000B OPTION VALUE IN BIT 13: I=X=0, J=Y=1. * E.INT EQU 01000B INTEGER*2 EXTERNAL FCT TYPE. E.REA EQU 02000B REAL*4 E.CPX EQU 05000B COMPLEX*8 E.DBL EQU 06000B REAL*6 E.DBI EQU 10000B INTEGER*4 E.RE8 EQU 12000B REAL*8 E.ZPX EQU 14000B COMPLEX*16 * G.INT EQU 020B INTEGER*2 ARGUMENT TYPE. G.REA EQU 040B REAL*4 G.CPX EQU 120B COMPLEX*8 G.DBL EQU 140B REAL*6 G.DBI EQU 200B INTEGER*4 G.RE8 EQU 240B REAL*8 G.ZPX EQU 300B COMPLEX*16 G.SUB EQU 0 SUBROUTINE (NON-GENERIC) * H.INT EQU 1 INTEGER*2 FUNCTION TYPE. H.REA EQU 2 REAL*4 H.CPX EQU 5 COMPLEX*8 H.DBL EQU 6 REAL*6 H.DBI EQU 10B INTEGER*4 H.RE8 EQU 12B REAL*8 H.ZPX EQU 14B COMPLEX*16 * R.REG EQU 40000B REG. PRESERVED. DOT FCT OPTIONS. R.OPM EQU 20000B OPNDS IN MEM. R.RTN EQU 10000B RTN ADDR. R.ER0 EQU 04000B DO JSB ERR0. * S.1 EQU 40000B SUBROUTINE CALL ALLOWABLE. SKP * THE INTRINSICS TABLE. * DEF SQRT2 IFTBL ASC 3,SQRT SQRT. ABS A.1+B.1+C.5+D.REA ABS E.REA+%QRT ABS G.REA+H.REA ABS R.REG+R.ER0+SQRT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DSQRT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SQRT ABS G.CPX+H.CPX ABS R.OPM+R.RTN+CSQRT ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+.ZSQR * DEF SQRT3 SQRT2 ASC 3,DSQRT DSQRT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$SQRT ABS E.RE8+/SQRT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DSQRT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SQRT * DEF SIN1 SQRT3 ASC 3,CSQRT CSQRT. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+CSQRT ABS E.ZPX+.ZSQR ABS G.CPX+H.CPX ABS R.OPM+R.RTN+CSQRT ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+.ZSQR * * SIN. * DEF SIN2 SIN1 ASC 3,SIN SIN. ABS A.1+B.1+C.5+D.REA ABS E.REA+%IN ABS G.REA+H.REA ABS R.REG+R.ER0+SIN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SIN ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CSIN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZSIN * DEF SIN3 SIN2 ASC 3,DSIN DSIN. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DSIN ABS E.RE8+/SIN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SIN * DEF COS1 SIN3 ASC 3,CSIN CSIN. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#SIN ABS E.ZPX+%ZSIN ABS G.CPX+H.CPX  ABS R.OPM+R.RTN+R.ER0+CSIN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZSIN * DEF COS2 COS1 ASC 3,COS COS. ABS A.1+B.1+C.5+D.REA ABS E.REA+%OS ABS G.REA+H.REA ABS R.REG+R.ER0+COS ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DCOS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.COS ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CCOS ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZCOS * DEF COS3 COS2 ASC 3,DCOS DCOS. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DCOS ABS E.RE8+/COS ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DCOS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.COS * DEF TAN1 COS3 ASC 3,CCOS CCOS. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#COS ABS E.ZPX+%ZCOS ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CCOS ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZCOS * DEF TAN2 TAN1 ASC 3,TAN TAN. ABS A.1+B.1+C.5+D.REA ABS E.REA+%AN ABS G.REA+H.REA ABS R.REG+R.ER0+TAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DTAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.TAN ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+.CTAN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZTAN * DEF TAN3 TAN2 ASC 3,DTAN DTAN. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$TAN ABS E.RE8+/TAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DTAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.TAN * DEF TANH1 TAN3 ASC 3,CTAN CTAN. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+%CTAN ABS E.ZPX+%ZTAN ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+.CTAN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZTAN * DEF TANH2 TANH1 ASC 3,TANH o TANH. ABS A.1+B.1+C.3+D.REA ABS E.REA+%ANH ABS G.REA+H.REA ABS R.REG+TANH ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DTANH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.TANH * DEF ATN.1 TANH2 ASC 3,DTANH DTANH. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DTANH ABS E.RE8+.TANH ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DTANH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.TANH * DEF ATN.2 ATN.1 ASC 3,ATAN ATAN. ABS A.1+B.1+C.3+D.REA ABS E.RE8+%TAN ABS G.REA+H.REA ABS R.REG+ATAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ATAN * DEF AT2.1 ATN.2 ASC 3,DATAN DATAN. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DATAN ABS E.RE8+.ATAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ATAN * DEF AT2.2 AT2.1 ASC 3,ATAN2 ATAN2. ABS A.2+B.1+C.3+D.REA ABS E.REA+ATAN2 ABS G.REA+H.REA ABS R.OPM+R.RTN+ATAN2 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATN2 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.ATN2 * DEF AT2.3 AT2.2 ASC 3,DATAN2 DATAN2. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DATN2 ABS E.RE8+/ATN2 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATN2 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.ATN2 * DEF LOG1 AT2.3 ASC 3,DATN2 DATN2. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DATN2 ABS E.RE8+/ATN2 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATN2 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.ATN2 * DEF LOG2 LOG1 ASC 3,LOG LOG. ABS A.1+B.0+C.5+D.NON ABS G.REA+H.REA ABS R.REG+R.ER0+GXALOG ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOG ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOG ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CLOG ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZLOG * DEF LOG3 LOG2 ASC 3,ALOG ALOG. ABS A.1+B.1+C.1+D.REA ABS E.REA+%LOG ABS G.REA+H.REA ABS R.REG+R.ER0+ALOG * DEF LOG4 LOG3 ASC 3,DLOG DLOG. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$LOG ABS E.RE8+/LOG ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOG ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOG * DEF L10.1 LOG4 ASC 3,CLOG CLOG. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#LOG ABS E.ZPX+%ZLOG ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CLOG ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZLOG * DEF L10.2 L10.1 ASC 3,LOG10 LOG10. ABS A.1+B.0+C.3+D.NON ABS G.REA+H.REA ABS R.REG+R.ER0+ALOGT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOGT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOGT * DEF L10.3 L10.2 ASC 3,ALOG10 ALOG10. ABS A.1+B.1+C.1+D.REA ABS E.REA+%LOGT ABS G.REA+H.REA ABS R.REG+R.ER0+ALOGT * DEF ALGT1 L10.3 ASC 3,DLOG10 DLOG10. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$LOGT ABS E.RE8+/LOGT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOGT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOGT * DEF ALGT2 ALGT1 ASC 3,ALOGT ALOGT. ABS A.1+B.1+C.1+D.REA ABS E.REA+%LOGT ABS G.REA+H.REA ABS R.REG+R.ER0+ALOGT * DEF EXP1 ALGT2 ASC 3,DLOGT DLOGT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$LOGT ABS E.RE-8+/LOGT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOGT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOGT * DEF EXP2 EXP1 ASC 3,EXP EXP. ABS A.1+B.1+C.5+D.REA ABS E.REA+%XP ABS G.REA+H.REA ABS R.REG+R.ER0+EXP ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DEXP ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.EXP ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CEXP ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZEXP * DEF EXP3 EXP2 ASC 3,DEXP DEXP. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$EXP ABS E.RE8+/EXP ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DEXP ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.EXP * DEF SINH1 EXP3 ASC 3,CEXP CEXP. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#EXP ABS E.ZPX+%ZEXP ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CEXP ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZEXP * DEF SINH2 SINH1 ASC 3,SINH SINH. ABS A.1+B.1+C.2+D.REA ABS E.REA+%SINH ABS G.REA+H.REA ABS R.REG+R.ER0+.SINH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DSNH * DEF COSH1 SINH2 ASC 3,DSINH DSINH. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DSNH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DSNH * DEF COSH2 COSH1 ASC 3,COSH COSH. ABS A.1+B.1+C.2+D.REA ABS E.REA+%COSH ABS G.REA+H.REA ABS R.REG+R.ER0+.COSH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DCSH * DEF ASIN1 COSH2 ASC 3,DCOSH DCOSH. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DCSH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DCSH * DEF ASIN2 ASIN1 ASC 3,ASIN ASIN. : ABS A.1+B.1+C.2+D.REA ABS E.REA+%ASIN ABS G.REA+H.REA ABS R.REG+R.ER0+.ASIN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DASN * DEF ACOS1 ASIN2 ASC 3,DASIN DASIN. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DASN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DASN * DEF ACOS2 ACOS1 ASC 3,ACOS ACOS. ABS A.1+B.1+C.2+D.REA ABS E.REA+%ACOS ABS G.REA+H.REA ABS R.REG+R.ER0+.ACOS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACS * DEF ASNH1 ACOS2 ASC 3,DACOS DACOS. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DACS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACS * DEF ASNH2 ASNH1 ASC 3,ASINH ASINH ABS A.1+B.1+C.2+D.REA ABS E.REA+%ASNH ABS G.REA+H.REA ABS R.REG+.ASNH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DASH * DEF ACSH1 ASNH2 ASC 3,DASINH DASINH ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+.DASH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DASH * DEF ACSH2 ACSH1 ASC 3,ACOSH ACOSH ABS A.1+B.1+C.2+D.REA ABS E.REA+%ACSH ABS G.REA+H.REA ABS R.REG+R.ER0+.ACSH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACH * DEF ATNH1 ACSH2 ASC 3,DACOSH DACOSH ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DACH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACH * DEF ATNH2 ATNH1 ASC 3,ATANH ATANH ABS A.1+B.1+C.2+D.REA ABS E.REA+%ATNH ABS G.REA+H.REA ABS R.REG+R.ER0+.ATNH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DATH * DEF ABS1 ATNH2 ASC 3,DATANH DATANH ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DATH J ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DATH * DEF ABS2 ABS1 ASC 3,ABS ABS. ABS A.1+B.1+C.7+D.REA ABS E.REA+%BS ABS G.INT+H.INT OCT 100001 ABS G.DBI+H.DBI OCT 100002 ABS G.REA+H.REA OCT 100003 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DABS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ABS ABS G.CPX+H.REA ABS R.OPM+R.RTN+CABS ABS G.ZPX+H.RE8 ABS R.OPM+R.RTN+.ZABS * DEF ABS3 ABS2 ASC 3,IABS IABS. ABS A.1+B.2+C.2+D.INT ABS E.INT+%ABS ABS E.DBI+%JABS ABS G.INT+H.INT OCT 100001 ABS G.DBI+H.DBI OCT 100002 * DEF ABS4 ABS3 ASC 3,DABS DABS. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DABS ABS E.RE8+.ABS ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DABS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ABS * DEF MOD1 ABS4 ASC 3,CABS CABS. ABS A.1+B.2+C.2+D.REA ABS E.REA+CABS ABS E.RE8+.ZABS ABS G.CPX+H.REA ABS R.OPM+R.RTN+CABS ABS G.ZPX+H.RE8 ABS R.OPM+R.RTN+.ZABS * DEF MOD2 MOD1 ASC 3,MOD MOD. ABS A.2+B.2+C.5+D.INT ABS E.INT+MOD ABS E.DBI+%JMOD ABS G.INT+H.INT ABS R.OPM+R.RTN+MOD ABS G.DBI+H.DBI ABS R.REG+.DMOD ABS G.REA+H.REA ABS R.OPM+R.RTN+AMOD ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMOD ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MOD * DEF MOD3 MOD2 ASC 3,AMOD AMOD. ABS A.2+B.1+C.1+D.REA ABS E.REA+AMOD ABS G.REA+H.REA ABS R.OPM+R.RTN+AMOD * DEF SIGN1 MOD3 ASC 3,DMOD DMOD. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DMOD ABS E.RE8+.MOD ABS G.DBL+H.DBL AB}"S R.OPM+R.RTN+DMOD ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MOD * DEF SIGN2 SIGN1 ASC 3,SIGN SIGN. ABS A.2+B.1+C.5+D.REA ABS E.REA+%IGN ABS G.INT+H.INT ABS R.OPM+ISIGN ABS G.DBI+H.DBI ABS R.OPM+.JSGN ABS G.REA+H.REA ABS R.OPM+SIGN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIGN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.SIGN * DEF SIGN3 SIGN2 ASC 3,ISIGN ISIGN. ABS A.2+B.2+C.2+D.INT ABS E.INT+%IGN ABS E.DBI+%JSGN ABS G.INT+H.INT ABS R.OPM+ISIGN ABS G.DBI+H.DBI ABS R.OPM+.JSGN * DEF DIM1 SIGN3 ASC 3,DSIGN DSIGN. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DSIGN ABS E.RE8+.SIGN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIGN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.SIGN * DEF DIM2 DIM1 ASC 3,DIM DIM. ABS A.2+B.1+C.5+D.REA ABS E.REA+DIM ABS G.INT+H.INT ABS R.OPM+R.RTN+IDIM ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JDIM ABS G.REA+H.REA ABS R.OPM+R.RTN+DIM ABS G.DBL+H.DBL ABS R.OPM+R.RTN+.XDIM ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DDIM * DEF DIM3 DIM2 ASC 3,IDIM IDIM. ABS A.2+B.2+C.2+D.INT ABS E.INT+IDIM ABS E.DBI+.JDIM ABS G.INT+H.INT ABS R.OPM+R.RTN+IDIM ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JDIM * DEF MIN.1 DIM3 ASC 3,DDIM DDIM. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+.XDIM ABS E.RE8+.DDIM ABS G.DBL+H.DBL ABS R.OPM+R.RTN+.XDIM ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DDIM * DEF MIN.2 MIN.1 ASC 3,MIN MIN. ABS A.VAR+B.0+C.5+D.NON ABS G.INT+H.INT ABS R.OPM+R.RTN+MIxN0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMN0 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMIN1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMIN1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MIN1 * DEF MIN.3 MIN.2 ASC 3,MIN0 MIN0. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MIN0 ABS E.DBI+.JMN0 ABS G.INT+H.INT ABS R.OPM+R.RTN+MIN0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMN0 * DEF MIN.4 MIN.3 ASC 3,AMIN1 AMIN1. ABS A.VAR+B.1+C.1+D.REA ABS E.REA+AMIN1 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMIN1 * DEF AMN.0 MIN.4 ASC 3,DMIN1 DMIN1. ABS A.VAR+B.2+C.2+D.DBL ABS E.DBL+DMIN1 ABS E.RE8+.MIN1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMIN1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MIN1 * DEF MN1.1 AMN.0 ASC 3,AMIN0 AMIN0. ABS A.VAR+B.2+C.2+D.REA ABS I+I+E.REA+AMIN0 ABS J+J+E.REA+.AMNJ ABS G.INT+H.REA ABS R.OPM+R.RTN+AMIN0 ABS G.DBI+H.REA ABS R.OPM+R.RTN+.AMNJ * DEF MAX.1 MN1.1 ASC 3,MIN1 MIN1. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MIN1 ABS E.DBI+.JMN1 ABS G.REA+H.INT ABS R.OPM+R.RTN+MIN1 ABS G.REA+H.DBI ABS R.OPM+R.RTN+.JMN1 * DEF MAX.2 MAX.1 ASC 3,MAX MAX. ABS A.VAR+B.0+C.5+D.NON ABS G.INT+H.INT ABS R.OPM+R.RTN+MAX0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMX0 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMAX1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMAX1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MAX1 * DEF MAX.3 MAX.2 ASC 3,MAX0 MAX0. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MAX0 ABS E.DBI+.JMX0 ABS G.INT+H.INT |ABS R.OPM+R.RTN+MAX0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMX0 * DEF MAX.4 MAX.3 ASC 3,AMAX1 AMAX1. ABS A.VAR+B.1+C.1+D.REA ABS E.REA+AMAX1 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMAX1 * DEF AMX.0 MAX.4 ASC 3,DMAX1 DMAX1. ABS A.VAR+B.2+C.2+D.DBL ABS E.DBL+DMAX1 ABS E.RE8+.MAX1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMAX1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MAX1 * DEF MX.1 AMX.0 ASC 3,AMAX0 AMAX0. ABS A.VAR+B.2+C.2+D.REA ABS I+I+E.REA+AMAX0 ABS J+J+E.REA+.AMXJ ABS G.INT+H.REA ABS R.OPM+R.RTN+AMAX0 ABS G.DBI+H.REA ABS R.OPM+R.RTN+.AMXJ * DEF AIMG1 MX.1 ASC 3,MAX1 MAX1. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MAX1 ABS E.DBI+.JMX1 ABS G.REA+H.INT ABS R.OPM+R.RTN+MAX1 ABS G.REA+H.DBI ABS R.OPM+R.RTN+.JMX1 * DEF CNJG1 AIMG1 ASC 3,AIMAG AIMAG. ABS A.1+B.2+C.2+D.REA ABS E.REA+AIMAG ABS E.RE8+.ZAIM ABS G.CPX+H.REA ABS R.OPM+R.RTN+AIMAG ABS G.ZPX+H.RE8 ABS R.OPM+R.RTN+.ZAIM * DEF AINT1 CNJG1 ASC 3,CONJG CONJG. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+CONJG ABS E.ZPX+.ZCJG ABS G.CPX+H.CPX ABS R.OPM+R.RTN+CONJG ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+.ZCJG * DEF DINT AINT1 ASC 3,AINT AINT. ABS A.1+B.1+C.3+D.REA ABS E.REA+%INT ABS G.REA+H.REA ABS R.REG+AINT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DDINT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.YINT * DEF DDNT1 DINT ASC 3,DINT DINT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DDINT ABS E.RE8+.YINT dG ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DDINT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.YINT * DEF INT1 DDNT1 ASC 3,DDINT DDINT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DDINT ABS E.RE8+.YINT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DDINT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.YINT * DEF INT2 INT1 ASC 3,INT INT. ABS A.1+B.2+C.12+D.INT ABS E.INT+%FIX ABS E.DBI+%FIXD ABS G.INT+H.INT OCT 100000 ABS G.DBI+H.DBI OCT 100000 ABS G.REA+H.INT OCT 100000 ABS G.REA+H.DBI OCT 100000 ABS G.DBL+H.INT OCT 100000 ABS G.DBL+H.DBI OCT 100000 ABS G.RE8+H.INT OCT 100000 ABS G.RE8+H.DBI OCT 100000 ABS G.CPX+H.INT OCT 100000 ABS G.CPX+H.DBI OCT 100000 ABS G.ZPX+H.INT OCT 100000 ABS G.ZPX+H.DBI OCT 100000 * DEF INT3 INT2 ASC 3,IFIX IFIX ABS A.1+B.2+C.2+D.INT ABS E.INT+%FIX ABS E.DBI+%FIXD ABS G.REA+H.INT OCT 100000 ABS G.REA+H.DBI OCT 100000 * DEF ANNT1 INT3 ASC 3,IDINT IDINT. ABS A.1+B.4+C.4+D.INT ABS X+X+E.INT+IDINT ABS X+X+E.DBI+%XFXD ABS Y+Y+E.INT+%TFXS ABS Y+Y+E.DBI+%TFXD ABS G.DBL+H.INT OCT 100000 ABS G.DBL+H.DBI OCT 100000 ABS G.RE8+H.INT OCT 100000 ABS G.RE8+H.DBI OCT 100000 * DEF DNNT1 ANNT1 ASC 3,ANINT ANINT. ABS A.1+B.1+C.2+D.REA ABS E.REA+%ANNT ABS G.REA+H.REA ABS R.REG+.ANNT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.TNNT * DEF NINT1 DNNT1 ASC 3,DNINT DNINT ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%TNNT ABS G.RE8+H.RE8 = ABS R.OPM+R.RTN+.TNNT * DEF IDNT1 NINT1 ASC 3,NINT NINT. ABS A.1+B.2+C.4+D.INT ABS E.INT+%NINT ABS E.DBI+%NJNT ABS G.REA+H.INT ABS R.REG+.NINT ABS G.REA+H.DBI ABS R.REG+.NJNT ABS G.RE8+H.INT ABS R.OPM+.IDNT ABS G.RE8+H.DBI ABS R.OPM+.JDNT * DEF REAL1 IDNT1 ASC 3,IDNINT IDNINT. ABS A.1+B.2+C.2+D.INT ABS Y+Y+E.INT+%IDNT ABS Y+Y+E.DBI+%JDNT ABS G.RE8+H.INT ABS R.OPM+.IDNT ABS G.RE8+H.DBI ABS R.OPM+.JDNT * DEF FLT1 REAL1 ASC 3,REAL REAL. ABS A.1+B.2+C.7+D.REA ABS I+I+E.REA+%LOAT ABS J+J+E.REA+%FLTD ABS G.INT+H.REA OCT 100000 ABS G.DBI+H.REA OCT 100000 ABS G.REA+H.REA OCT 100000 ABS G.DBL+H.REA OCT 100000 ABS G.RE8+H.REA OCT 100000 ABS G.CPX+H.REA OCT 100000 ABS G.ZPX+H.RE8 OCT 100000 * DEF SNGL1 FLT1 ASC 3,FLOAT FLOAT. ABS A.1+B.2+C.2+D.REA ABS I+I+E.REA+%LOAT ABS J+J+E.REA+%FLTD ABS G.INT+H.REA OCT 100000 ABS G.DBI+H.REA OCT 100000 * DEF DBLE1 SNGL1 ASC 3,SNGL SNGL. ABS A.1+B.2+C.2+D.REA ABS X+X+E.REA+SNGL ABS Y+Y+E.REA+.NGL ABS G.DBL+H.REA OCT 100000 ABS G.RE8+H.REA OCT 100000 * DEF CMPL1 DBLE1 ASC 3,DBLE DBLE. ABS A.1+B.2+C.12+D.DBL ABS E.DBL+DBLE ABS E.RE8+.BLE ABS G.INT+H.DBL OCT 100000 ABS G.INT+H.RE8 OCT 100000 ABS G.DBI+H.DBL OCT 100000 ABS G.DBI+H.RE8 OCT 100000 ABS G.REA+H.DBL OCT 100000 ABS G.REA+H.RE8 OCT 100000 ABS G.DBL+H.DBL OCT 100000  ABS G.RE8+H.RE8 OCT 100000 ABS G.CPX+H.DBL OCT 100000 ABS G.CPX+H.RE8 OCT 100000 ABS G.ZPX+H.DBL OCT 100000 ABS G.ZPX+H.RE8 OCT 100000 * DEF IAND1 CMPL1 ASC 3,CMPLX CMPLX. ABS A.2+B.2+C.2+D.CPX ABS E.CPX+CMPLX ABS E.ZPX+.ZMPX ABS G.REA+H.CPX ABS R.OPM+R.RTN+CMPLX ABS G.RE8+H.ZPX ABS R.OPM+R.RTN+.ZMPX * DEF IOR1 IAND1 ASC 3,IAND IAND. ABS A.2+B.2+C.2+D.INT ABS E.INT+%AND ABS E.DBI+%DAND ABS G.INT+H.INT OCT 100005 ABS G.DBI+H.DBI ABS R.REG+.DAND * DEF IXOR1 IOR1 ASC 3,IOR IOR. ABS A.2+B.2+C.2+D.INT ABS E.INT+%OR ABS E.DBI+%DOR ABS G.INT+H.INT OCT 100006 ABS G.DBI+H.DBI ABS R.REG+.DOR * DEF IEOR1 IXOR1 ASC 3,IXOR IXOR. ABS A.2+B.2+C.2+D.INT ABS E.INT+IXOR ABS E.DBI+%DXOR ABS G.INT+H.INT OCT 100007 ABS G.DBI+H.DBI ABS R.REG+.DXOR * DEF NOT IEOR1 ASC 3,IEOR IEOR. ABS A.2+B.2+C.2+D.INT ABS E.INT+IXOR ABS E.DBI+%DXOR ABS G.INT+H.INT OCT 100007 ABS G.DBI+H.DBI ABS R.REG+.DXOR * DEF ISHFT NOT ASC 3,NOT NOT. ABS A.1+B.2+C.2+D.INT ABS E.INT+%OT ABS E.DBI+%DNOT ABS G.INT+H.INT OCT 100010 ABS G.DBI+H.DBI OCT 100011 * DEF ISSW1 ISHFT ASC 3,ISHFT ISHFT. ABS A.2+B.2+C.2+D.INT ABS E.INT+%ISH ABS E.DBI+%JSH ABS G.INT+H.INT OCT 100004 ABS G.DBI+H.DBI OCT 100004 * DEF PCNT1 ISSW1 ASC 3,ISSW ISSW. ABS A.1+B.1+C.1+D.INT ABS E.INT+%S/SW ABS G.INT+H.INT ABS R.REG+ISSW * DEF EXEC1 PCNT1 ASC 3,PCOUNT PCOUNT. .PCNT ABS A.0+B.0+C.2+D.INT ABS H.INT OCT 100012 ABS H.DBI OCT 100012 * DEF DEXC1 EXEC1 ASC 3,EXEC EXEC. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+EXEC ABS E.REA+EXEC ABS G.SUB+H.DBI ABS R.OPM+R.RTN+EXEC ABS G.SUB+H.REA ABS R.OPM+R.RTN+EXEC * DEF REIO1 DEXC1 ASC 3,DEXEC DEXEC. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+DEXEC ABS E.REA+DEXEC ABS G.SUB+H.DBI ABS R.OPM+R.RTN+DEXEC ABS G.SUB+H.REA ABS R.OPM+R.RTN+DEXEC * DEF XLUE1 REIO1 ASC 3,REIO REIO. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+REIO ABS E.REA+REIO ABS G.SUB+H.DBI ABS R.OPM+R.RTN+REIO ABS G.SUB+H.REA ABS R.OPM+R.RTN+REIO * DEF 0 XLUE1 ASC 3,XLUEX XLUEX. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+XLUEX ABS E.REA+XLUEX ABS G.SUB+H.DBI ABS R.OPM+R.RTN+XLUEX ABS G.SUB+H.REA ABS R.OPM+R.RTN+XLUEX * * * END OF INTRINSICS TABLE. SKP * ORDINALS IN DOT-FUNCTION TABLE. * EXEC EQU 72 REIO EQU 90 XLUEX EQU 91 * SQRT EQU 102 DSQRT EQU 103 .SQRT EQU 104 CSQRT EQU 105 %QRT EQU 106 $SQRT EQU 107 /SQRT EQU 108 * SIN EQU 109 DSIN EQU 110 .SIN EQU 111 CSIN EQU 112 %IN EQU 113 /SIN EQU 115 #SIN EQU 116 * COS EQU 117 DCOS EQU 118 .COS EQU 119 CCOS EQU 120 %OS EQU 121 /COS EQU 123 #COS EQU 124 * TAN EQU 125 DTAN EQU 126 .TAN EQU 127 %AN EQU 128 $TAN EQU 129 /TAN EQU 130 * TANH EQU 131 DTANH EQU 132 .TANH EQU 133 %ANH EQU 134 * ATAN EQU 135 DATAN EQU 136 .ATAN EQU 137 %TAN EQU 138 * ATAN2 EQU 139 DATN2 EQU 140 .ATN2 EQU 141 /ATN2 EQU 122 * ALOG EQU 142 DLOG EQU 143 .LOG EQU 144 CLOG EQU 145 %LOG EQU 146 $LOG EQU 147 /LOG EQU 148 #LOG EQU 149 * ALOGT EQU 150 DLOGT EQU 151 .LOGT EQU 152 %LOGT EQU 153 $LOGT EQU 154 /LOGT EQU 155 * EXP EQU 156 DEXP EQU 157 .EXP EQU 158 CEXP EQU 159 %XP EQU 160 $EXP EQU 161 /EXP EQU 162 #EXP EQU 163 * DABS EQU 164 .ABS EQU 165 CABS EQU 166 %ABS EQU 167 %JABS EQU 168 %BS EQU 169 * .DMOD EQU 170 AMOD EQU 171 DMOD EQU 172 .MOD EQU 173 MOD EQU 174 %JMOD EQU 175 * ISIGN EQU 176 .JSGN EQU 177 SIGN EQU 178 DSIGN EQU 179 .SIGN EQU 180 %IGN EQU 181 %JSGN EQU 182 * IDIM EQU 183 .JDIM EQU 184 DIM EQU 185 .XDIM EQU 186 .DDIM EQU 187 * MIN0 EQU 188 .JMN0 EQU 189 AMIN1 EQU 190 DMIN1 EQU 191 .MIN1 EQU 192 * AMIN0 EQU 193 .AMNJ EQU 194 * MIN1 EQU 195 .JMN1 EQU 196 * MAX0 EQU 197 .JMX0 EQU 198 AMAX1 EQU 199 DMAX1 EQU 200 .MAX1 EQU 201 * AMAX0 EQU 202 .AMXJ EQU 203 * MAX1 EQU 204 .JMX1 EQU 205 * AIMAG EQU 206 CONJG EQU 207 * AINT EQU 208 DDINT EQU 209 .YINT EQU 210 %INT EQU 211 * %FIX EQU 220 %FIXD EQU 221 IDINT EQU 222 %XFXD EQU 223 %TFXS EQU 224 %TFXD EQU 225 * FLOAT EQU 226 .FLTD EQU 227 SNGL EQU 228 .NGL EQU 229 %LOAT EQU 231 %FLTD EQU 232 * DBLE EQU 237 .BLE EQU 238 * CMPLX EQU 241 * %AND EQU 242 %DAND EQU 243 .DAND EQU 244 * %OR EQU 245 %DOR EQU 246 .DOR EQU 247 * IXOR EQU 248 %DXOR EQU 249 .DXOR EQU 250 * %OT EQU 251 %DNOT EQU 252 * %ISH EQU 256 %JSH EQU 257 * %SSW EQU 258 ISSW EQU 259 * .SINH EQU 270 %SINH EQU 271 .COSH EQU 272 %COSH EQU 273 .ASIN EQU 274 %ASIN EQU 275 .ACOS EQU 276 %ACOS EQU 277 .ASNH EQU 278 %ASNH EQU 279 .ACSH EQU 280 %ACSH EQU 281 .ATNH EQU 282 %ATNH EQU 283 .CTAN EQU 284 %CTAN EQU 285 .DSNH EQU 286 %DSNH EQU 287 .DCSH EQU 288 %DCSH EQU 289 .DASN EQU 290 %DASN EQU 291 .DACS EQU 292 %DACS EQU 293 .DASH EQU 294 .DACH EQU 296 %DACH EQU 297 .DATH EQU 298 %DATH EQU 299 * .ZMPX EQU 307 .ZSQR EQU 317 .ZSIN EQU 318 %ZSIN EQU 319 .ZCOS EQU 320 %ZCOS EQU 321 .ZTAN EQU 322 %ZTAN EQU 323 .ZLOG EQU 324 %ZLOG EQU 325 .ZEXP EQU 326 %ZEXP EQU 327 .ZABS EQU 328 .ZAIM EQU 329 .ZCJG EQU 330 * .NINT EQU 331 %NINT EQU 332 .NJNT EQU 333 %NJNT EQU 334 .IDNT EQU 335 %IDNT EQU 336 .JDNT EQU 337 %JDNT EQU 338 .ANNT EQU 339 %ANNT EQU 340 .TNNT EQU 341 %TNNT EQU 342 * DEXEC EQU 343 SKP * ***************** * * SEGMENT ENTRY * * ***************** SPC 1 * SET UP SOME INFO ABOUT THE 'Y' AND 'I' OPTIONS. * F4.2 LDA DEXIT SET UP ERROR RECOVERY ADDRESS. STA F.ERX LDB F.CCW OPTIONS WORD. LDA DBL MODIFIES DBL=REAL*6 BLF,BLF 'Y' OPTION IS IN BIT 9=>1 RBR,SLB =>0, IS IT SET ? LDA RE8 YES, DEFAULT IS RE8=REAL*8. STA MDBL MDBL=MODIFIED DBL. XOR DBL COMPUTE THE OTHER ONE. XOR RE8 STA ODBL ODBL=NON-DEFAULT OF THE TWO. * LDA INT 'J' CHANGES INT=INTEGER*2 LDB F.CCW WELL ? BLF,SLB BIT 12=>0, IS OPTION SET ? LDA DBI YES, DEFAULT TO DBI=INTEGER*4. STA MINT MINT=MODIFIED INT. XOR INT COMPUTE OTHER ONE. XOR DBI STA OINT OINT=NON-DEFAULT OF THE TWO. * LDA F.CCW CONSTRUCT IJXY FIELD FOR REQ'D I/J. RRR 12 AND K1 I=0, J=1. IOR K2 + SELECTION BITS. STA JOPT * LDA F.CCW DITTO, X/Y. RRR 9 AND K1 IOR K4 STA YOPT * * SCAN SYMBOL TABLE FOR EXTERNAL SUBROUTINES. * LDA DISP1 SET UP LOCAL ERROR RECOVERY. STA F.EQE JSB GFA.F SET UP F.A, FDUMMY LIST HEAD. ISP01 JSB GNA.F GET NEXT ITEM. SZA,RSS DONE ? JMP IMP01 YES. GO DO 'IMPLICIT NONE' CHECKING. * CPA F.SBF CURRENT MODULE ? JMP ISP01 YES. SKIP. * LDA F.A,I GET F.AT & F.IU . AND B7600 CPA B2200 IS F.AT=STRAB & F.IU=SUB ? JMP ISP04 YES. JMP ISP01 NO. NOT AN EXTERNAL SUBROUTINE. SKP * GOT ONE. SEARCH INTRINSICS TABLE FOR IT. * ISP04 JSB NAM.F YES. EXTRACT ITS NAME. DEF NAME LDA DIFTB SET UP LOOP. ISP05 STA T1ISP T1ISP = INTRINSICS TABLE POINTER. LDB A,I (B) = CHARS 1,2. CPB NAME 1&2 SAME ? RSS YES. JMP ISP06 NO. WRONG ONE. * INA DLD A,I CHARS 3,4,5,6. CPA NAME+1 3&4 SAME ? RSS YES. JMP ISP06 NO. WRONG ONE. * CPB NAME+2 5&6 SAME ? JMP ISP10 YES. MATCH. * ISP06 CCA NO. SKIP THIS ENTRY. ADA T1ISP GET ADDR OF NEXT. LDA A,I SZA,RSS MORE ? JMP ISP01 NO. NOT INTRINSIC. JMP ISP05 YES. GO CHECK IT OUT. * DEXIT DEF EXIT SEGMENT ERROR RECOVERY ADDR. DISP1 DEF ISP01 LOCAL ERROR RECOVERY ADDR. NAME BSS 3 NAME FROM SYMBOL TABLE. DIFTB DEF IFTBL ADDR OF FIRST ENTRY. T1ISP NOP ADDR OF CURRENT ENTRY. T2ISP NOP GENERAL COUNTER.ENTRY. T3ISP NOP GENERAL POINTER.ENTRY. T4ISP NOP POINTER SIZE BUILT TABLE. B7600 OCT 7600 B2200 OCT 2200 MDBL NOP MODIFIED 'DBL'. ODBL NOP OTHER ONE. MINT NOP MODIFIED 'INT'. OINT NOP OTHER ONE. JOPT NOP MATCHING REQ'D 'J' OPTION BITS. YOPT NOP MATCHING REQ'D 'Y' OPTION BITS. B10K OCT 010000 INT EQU B10K DBI OCT 100000 DBL OCT 060000 RE8 OCT 120000 K1 DEC 1 K2 DEC 2 K4 DEC 4 K7 DEC 7 SKP * GOT AN INTRINSIC. PROhCESS IT. * FIRST, SET UP ITS TYPE. * ISP10 ISZ T1ISP SKIP OVER THE NAME. ISZ T1ISP ISZ T1ISP JSB FA.F FETCH SYMBOL ASSIGNS. LDA F..E EXPLICITLY TYPED ? SZA JMP ISP11 YES. LEAVE IT. * LDA T1ISP,I NO. GET THE TYPE. AND B17 ALF,ALF POSITION IT. ALF CPA DBL IF DBL, LDA MDBL MAY CHANGE TO RE8. CPA INT IF INT, LDA MINT MAY CHANGE TO DBI. JSB DIM.F CHANGE F.IM TO DEFAULT TYPE. * * IF SUBROUTINE, USE FIRST EXTERNAL NAME. * ISP11 LDA F.S USED AS SUB ? SZA,RSS JMP ISP12 NO. * STA T4ISP YES. (TABLE = 1 WORD) DLD T1ISP,I IS THAT ALLOWED ? RAL SSA,RSS JMP ISP01 NO. THEN NOT AN INTRINSIC. * LSL 7 YES. GET THE DOT ORDINAL. LSR 7 (B) = DOT ORDINAL. JMP ISP27 GO INSERT IN TABLE & PROCEED. SKP * DETERMINE THE EXTERNAL NAME. IF CAN'T FIND TYPE, * AND EXPLICITLY RETYPED, THEN NOT INTRINSIC. * ISP12 LDA T1ISP,I GET THE NUMBER OF THEM. AND B7400 ALF,ALF STA T4ISP SAVE THAT. CMA,INA T2ISP = COUNTER. STA T2ISP LDA T1ISP T3ISP = POINTER. STA T3ISP ISP13 ISZ T3ISP NEXT CANDIDATE.. LDA T3ISP,I ALF,RAR GET ITS TYPE. AND B170K CPA F.IM MATCH ? RSS YES. JMP ISP14 NO. GO CHECK NEXT. * LDA T3ISP,I YES. CHECK OUT I/J & X/Y STUFF. ALF,RAR TO BITS 2:0 AND K7 THE FLAG BITS. SZA IF NO OPTION REQUIRED, CPA JOPT OR IF ITS 'J' & CORRECT ? RSS YES. CPA YOPT OR 'Y' AND CORRECT ? JMP ISP15 YES. MATCH COMPLETE. * ISP14 ISZ T2ISP NO. BUMP COUNTER. JMP ISP13 IF MORE. * LDA F..E NOT FO)UND. WAS IT EXPLICITLY TYPED ? SZA JMP ISP01 YES. THEN NOT AN INTRINSIC. JMP ISP17 NO. JUST A GENERIC WITH NO SPECIFICS. * ISP15 LDA T3ISP,I FOUND. SET INTO TABLE. AND B777 ISP17 STA TABLE BITS <8:0> OF FIRST WORD. SKP * COPY EACH SPECIFIC NAME INTO TABLE, UNLESS: * 1) EXPLICIT TYPING & DOESN'T MATCH, OR * 2) FCT TYPE # ARG TYPE AND FCT TYPE IS * NOT DEFAULT FOR 'Y' OR 'J' OPTIONS. * LDA T1ISP,I GET THE NUMBER OF SPECIFIC NAMES. AND B360 ALF,ALF ALF CMA,INA T2ISP = COUNTER. STA T2ISP LDA T1ISP COMPUTE ADDR OF FIRST ONE. ADA T4ISP SKIP TO LAST EXTERNAL ENTRY. STA T3ISP T3ISP = POINTER (BUMP ONE FIRST). LDA DTBL1 SET POINTER TO TABLE. STA T4ISP ISP20 ISZ T3ISP ON TO NEXT ENTRY... LDA T3ISP,I GET THE FUNCTION TYPE. AND B17 ALF,ALF ALIGN IT. ALF LDB F..E FUNCTION IS EXPLICITLY TYPED ? SZB,RSS JMP ISP22 NO. * CPA F.IM YES. IS IT RIGHT TYPE ? JMP ISP24 YES. COPY IT. JMP ISP26 NO. SKIP IT. * ISP22 LDB A NOT EXPL. TYPED. FCT TYPE = ARG TYPE ? LDA T3ISP,I GET ARG TYPE. ALF,ALF AND B170K CPA B WELL ? JMP ISP24 SAME. HAVE TO KEEP IT. * CPB ODBL DIFFERENT. IS IT A NON-DEFAULT TYPE ? RSS YES. CPB OINT JMP ISP26 YES. SKIP IT. * ISP24 DLD T3ISP,I COPY ENTRY TO TABLE. DST T4ISP,I ISZ T4ISP ISZ T4ISP ISP26 ISZ T3ISP ADVANCE TO NEXT ENTRY. (OTHER ISZ AT TOP) ISZ T2ISP DONE ? JMP ISP20 NO. LOOK FOR MORE. SKP * FINISH BUILDING TABLE. * LDB DTBL1 COMPUTE NUMBER OF SPECIFIC NAMES. CMB,INB ADB T4ISP (LWA+1) - FWA = COUNT*2 STB T4ISYP T4ISP = (TABLE SIZE)-1. BLF,BLF PUT IN BITS <12:9>, FIRST WORD. ADB TABLE ISP27 LDA T1ISP,I GET # PARAMS & S-BIT. AND B70K WERE IN BITS <14:12>, RAL PUT IN BITS <15:13>, FIRST WORD. IOR B STA TABLE ISZ T4ISP T4ISP = # WORDS IN TABLE. * * ALLOCATE SPACE IN A.T. AREA FOR THE TABLE, * AND COPY IT THERE. SET F.AF=TABLE ADDR, F.NC=1. * LDB T4ISP ALLOCATE SPACE. JSB AST.F STB T3ISP SAVE ITS ADDR. LDA DTABL COPY TABLE. JSB .MVW DEF T4ISP NOP LDA T3ISP SET F.AF OF SYMBOL TO TABLE ADDR. JSB DAF.F LDA F.A,I SET F.NC=1. IOR B40 STA F.A,I LDA T1ISP IS THIS 'PCOUNT' ? CPA DPCNT RSS (YES) JMP ISP01 NO. DONE WITH THIS SYMBOL. * LDA F.A YES. ALLOCATE TEMP FOR ENTRY. STA T1ISP BUT FIRST, SAVE F.A . LDA INT ALLOCATE THE TEMP. JSB APT.F STA F.PCT LDA T1ISP RESTORE F.A STA F.A JMP ISP01 NOW DONE. * B17 OCT 17 B40 OCT 40 B777 OCT 777 B360 OCT 360 B7400 OCT 7400 B70K OCT 70000 B170K OCT 170000 DPCNT DEF .PCNT USED TO CHECK FOR PCOUNT. DTABL DEF TABLE DTBL1 DEF TABLE+1 TABLE BSS 15 MAX 7 SPECIFIC AT A TIME. K6 DEC 6 B10 OCT 10 SKP * ***************** * * IMPLICIT NONE * * ***************** SPC 1 * THE CHECKING FOR 'IMPLICIT NONE' SCANS THE NAMED PART OF THE * SYMBOL TABLE, AND COMPLAINS ABOUT SYMBOLS WHICH: * * 1) ARE NORMAL NAMED VARIABLES, ARRAYS, OR SUBPROGRAMS. * 2) ARE NOT INTRINSIC. * 3) ARE NOT SUBROUTINES. * 4) ARE NOT EXPLICITLY TYPED. * * START SYMBOL TABLE SCAN. * IMP01 LDA F.IMF IMPLICIT NONE ? SSA,RSS JMP EXIT NO. DON'T BOTHER. * CCA YES.) CLEAR THE MESSAGE FLAG. STA T1IMP JSB GFA.F SET UP SCAN. IMP02 JSB GNA.F GET NEXT ITEM. SZA,RSS DONE ? JMP EXIT YES. GO EXIT. * LDA F.A,I EXPLICITLY TYPED ? AND B10 (IF NOT PROPER TYPE OF ENTRY, SZA THIS CHECK DOESN'T HURT.) JMP IMP02 YES. SKIP IT. * LDB F.A NO. SEE IF TEMP OR STMT #. ADB K2 LDA B,I FIRST WORD OF NAME. SSA TEMP ? JMP IMP02 YES. SKIP IT. * AND BM400 NO. GET FIRST CHAR. CPA B40K IS IT @ ? JMP IMP02 YES. STMT #, SKIP IT. * LDA F.A NO. NAME OF THIS MODULE ? LDB F.SFF AND IT'S A SUBROUTINE ? CPA F.SBF SZB RSS (NO. ERROR) JMP IMP02 YES. SKIP IT. * LDA F.A,I NO. GET USAGE. AND B600 CPA SUB IF SUBROUTINE, RSS MUST CHECK FURTHER. JMP IMP10 NO. UNTYPED VARIABLE/ARRAY! SKP * F.IU=SUB. CHECK COMMON BLOCK, SUBROUTINE, INTRINSIC. * LDA F.A,I GET F.AT AND B7000 CPA BCOMI COMMON LABEL ? (F.AT=BCOMI) JMP IMP02 YES. SKIP IT. * LDA F.A,I SUBROUTINE OR FUNCTION ? AND B20 SZA,RSS JMP IMP02 SUBROUTINE (OR EXTERNAL ONLY), SKIP. * LDA F.A,I GET F.NC AND B140 CPA B40 INTRINSIC ? JMP IMP02 YES. SKIP IT. * * UNTYPED NAME. COMPLAIN. * IMP10 LDA K87 WARNING 87. ISZ T1IMP HAVE WE PUT OUT THE MESSAGE YET ? RSS YES. NOT AGAIN. JSB WAR.F NO. PUT IT OUT. * JSB NAM.F COPY THE ITEM NAME. DEF IMMSG+1 TO HERE. LDA K4 PRINT MESSAGE: 4 WORDS, LDB DIMSG FROM HERE. JSB PCC.F DO IT. JMP IMP02 GO FOR MORE. * T1IMP NOP INDICATOR WHETHER MSG DONE YET. B20 OCT 20 B140 OCT 140 T=nlh SUB OCT 200 F.IU=SUB B600 OCT 600 F.IU MASK. B7000 OCT 7000 F.AT MASK. BCOMI EQU B7000 F.AT=BCOMI B40K BYT 100,0 '@',0 BM400 OCT 177400 K87 DEC 87 DIMSG DEF IMMSG ADDR OF MESSAGE. IMMSG ASC 4, MESSAGE BUFFER. SPC 2 * SEGMENT EXIT. * EXIT CLA CLEAR OUT THE LOCAL ERROR RECOVERY. STA F.EQE CCA WRITE (-1) TO END PASS FILE. JSB WS1.F JSB ES1.F FLUSH LAST PASS FILE RECORD. JSB EOF.C WRITE EOF ON 1ST PASS FILE. DEF C.SC1 JMP PASER * JSB RWN.C REWIND 1ST PASS FILE. DEF C.SC1 JMP PASER * JSB RWN.C REWIND CARD FILE: DEF C.SC0 IT BECOMES 2ND PASS FILE. JMP PASER * LDB K6 GO TO SEGMENT 6. JMP F.SEG * PASER LDA K99 ACCESS ERROR ON SCRATCH FILE. JMP F.ABT * K99 DEC 99 * END F4.2 n # 92834-18003 2030 S C0122 &F4X2 PART 2             H0101 ASMB,Q,C HED HEADER FOR FILES &F4X2 AND %F4X2 . NAM F4X2,8 92834-16003 REV.2030 800715 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * END ASMB,Q,C HED FTN4X COMPILER (F4X.3:SYMBOL TABLE & XREF) NAM F4X.3,5 92834-16003 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 3 *************************************** * * THIS OVERLAY GENERATES THE SYMBOL TABLE LIST AND CROSS REFERENCE * LISTING FROM THE CREF INFO IN THE INTER PASS FILE * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.CCW FTN OPTION WORD EXT F.DEB DEF TO ERROR BIT VECTOR. EXT F.DNI ADDRESS OF NID EXT F.DO LWAM - END OF DO TABLE EXT F.DP BASE OF A.T. EXT F.EM EMA FLAG BIT IN A.T. EXT F.EMA F.A OF EMA MASTER. EXT F.ERF ERROR ARRAY, CURRENT MODULE. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LOP NO. LINES LEFT ON THIS PAGE. EXT F.NC INTRINSICS FLAGS. EXT F.ND NUMBER OF DIMENSIONS EXT F.R MISC A.T. BIT. EXT F.SEG LOAD A NEW SEGMENT * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT CER.F COMPILER ERROR REPORT. EXT EJP.F PAGE EJECT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FID.F FETCH (ID) TO NID (UNPACK) EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT NAM.F COPY SYMBOL NAME. EXT PSL.F PRINT LINE ON PRINTER EXT SKL.F SKIP LINES ON LIST * * * * UTILITY LIBRARY ROUTINES * EXT .MVW EXT IFBRK BREAK CHECK ROUTINE * * COMPILER LIBRARY: * EXT RWN.C REWIND FILE ROUTINE EXT RED.C READ FILE ROUTINE EXT C.SC0 SCRATCH FCB EXT GMS.C GET )MAIN MEMORY BOUNDS SPC 1 SUP A EQU 0 B EQU 1 SPC 1 DEC 3 OVERLAY # SPC 4 * ************** * * START HERE * * ************** SPC 1 F4.3 BSS 0 BEGIN HERE! CLA SHOULDN'T NEED ERROR RECOVERY ADDR, STA F.ERX BUT ZAP IT ANYWAY. LDA F.ERF+1 TOTAL # ERRORS, WARNINGS THIS MODULE. SZA,RSS JMP TABLS IF NONE, GO DO T & C OPTIONS. * LDA F.LOP IF NOT AT TOP-OF-PAGE, SZA (E.G. DISASTER), JSB EJP.F THEN GO THERE. SKP * ***************************** * * PRINT THE ERROR DIRECTORY * * ***************************** SPC 1 * THIS SECTION SCANS THE ERROR BIT VECTOR IN THE MAIN AND PRINTS * THE ERROR MESSAGES CORRESPONDING TO THE ERRORS AND WARNINGS * WHICH OCCURED IN THIS MODULE. THE TABLE OF MESSAGES IS JUST * ASCII WITH THE LAST CHARACTER IN EACH MESSAGE BEING | IN THE * RIGHT BYTE; IT IS CONVERTED TO BLANK BEFORE PRINTING. * * CHECK FOR ERRORS WHICH DON'T REQUIRE EXPLANATIONS; * IF ONLY THOSE, THEN DON'T PRINT DIRECTORY. * CLA INITIALIZE FLAG TO "NO PRINT". STA T6ERD STA T0ERD (ALSO CLEAR ERROR NUMBER) LDB F.DEB SET POINTER TO BIT VECTOR. LDA DEMSK SET POINTER TO MASKS. STA T2ERD LDA KM7 SET COUNT OF WORDS. STA T3ERD ERD00 LDA B,I NEXT BIT VECTOR WORD. INB AND T2ERD,I APPLY MASK. ISZ T2ERD IOR T6ERD IF PRINTING ERROR, SET FLAG. STA T6ERD ISZ T3ERD DONE ? JMP ERD00 NO. * * INITIALIZE DIRECTORY PRINT. * LDA F.DEB SET ADDR CURRENT BIT TABLE WORD. STA T1ERD LDA DMSGS SET ADDR CURRENT MESSAGE. STA T2ERD LDA KM7 SET COUNTER OF WORDS IN BIT TABLE. STA T3ERD ERD01 LDA KM16B SET COUNTER OF BITS IN CURRENT WORD. STA T4ERD * * COPY CURRENT ERROR MESSAGE TO BUFFER. * ERD02 LDA DMBUF SET BUFFER ADDR. STA T5ERD ERD03 LDA T2ERD,I WORD IN MSG. ISZ T2ERD STA T5ERD,I PUT IN BUFFER. ISZ T5ERD AND B377 TERMINATOR ? CPA B174 (BROKEN BAR) RSS (YES) JMP ERD03 NO. KEEP COPYING. SKP * IF BIT SET, FINISH SETTING UP MESSAGE. * LDA T1ERD,I WORD WITH BIT. CLE,ELA (E)=BIT; CLEAR & SHIFT FOR NEXT TIME. STA T1ERD,I LDB T6ERD PRINT FLAG. SZB IS PRINT FLAG ON, CCB,SEZ,RSS AND BIT SET ? (B=-1) JMP ERD08 NO. DON'T PRINT. * ADB T5ERD YES. CHANGE FINAL | TO BLANK. LDA B,I ADA BM134 STA B,I CPB DMBUF WAS THAT ONLY WORD OF MESSAGE ? JSB CER.F YES. COMPILER ERROR. LDA T0ERD CONVERT ERROR NUMBER. CLE (E=0, SUPPRESS LEADING ZEROES.) JSB ASC.F STA ERNUM PUT IN MSG. * * HANDLE SUBHEADING. * LDA F.LOP AT BOTTOM OF PAGE ? INA,SZA,RSS JSB EJP.F YES. GO TO TOP. LDA F.LOP AT TOP OF PAGE ? SZA JMP ERD04 NO. * LDA K9 FIRST SUB-HEADING. LDB DERH1 JSB PSL.F CLA BLANK LINE. JSB SKL.F LDA K12 SECOND SUB-HEADING. LDB DERH2 JSB PSL.F CLA,INA TWO BLANK LINES. JSB SKL.F ERD04 LDA DEBUF COMPUTE # WORDS IN LINE. CMA,INA -(FWA) ADA T5ERD LWA-FWA+1 LDB DEBUF PRINT LINE. JSB PSL.F SKP * LOOP THRU ALL ERROR BITS. * ERD08 ISZ T0ERD BUMP ERROR NUMBER. ISZ T4ERD NEXT BIT. DONE THIS WORD ? JMP ERD02 NO. * ISZ T1ERD YES. ADVANCE IN TABLE. ISZ T3ERD COUNT WORDS. DONE WI/%TH TABLE ? JMP ERD01 NO. JMP TABLS YES. DO SYMBOL & XREF TABLES. * * CONSTANTS & TEMPS FOR ERROR DIRECTORY. * T0ERD NOP CURRENT ERROR NUMBER. T1ERD NOP POINTER TO BIT VECTOR. T2ERD NOP POINTER TO MESSAGE TEXT. T3ERD NOP COUNTER OF WORDS IN BIT VECTOR. T4ERD NOP COUNTER OF BITS IN THIS WORD. T5ERD NOP POINTER INTO ERROR BUFFER. T6ERD NOP FLAG THAT PRINTED ERROR FOUND. DERH1 DEF *+1 ASC 09, ERROR DIRECTORY DERH2 DEF *+1 ASC 12, NUMBER EXPLANATION DEBUF DEF EBUF DMBUF DEF MBUF EBUF ASC 2, START OF ERROR LIST BUFFER. ERNUM BSS 1 FOR ASCII ERROR NUMBER. ASC 3, MBUF BSS 36 FOR ERROR MESSAGE. K12 DEC 12 KM7 DEC -7 B30 OCT 30 C,T OPTION BITS. B174 OCT 174 | BM134 OCT -134 SPACE - | B377 OCT 377 DEMSK DEF *+1 ERROR MASK: BIT SET IF ALWAYS PRINTED. OCT 177777 0-15 OCT 177777 16-31 OCT 177777 32-47 OCT 177777 48-63 OCT 173777 64-79, EXCEPT 68. OCT 177777 80-95 OCT 177777 96-111 SKP * ERRORS 0-99. * DMSGS DEF *+1 * 0-9: ASC 0001, | ASC 0012,ERROR IN FTN DIRECTIVE.| ASC 0001, | ASC 0013,COMPILER SPACE OVERFLOW. | ASC 0011,INVALID COMMON LABEL.| ASC 0010,REDUNDANT IMPLICIT.| ASC 0001, | ASC 0012,RETURN IN MAIN PROGRAM.| ASC 0012,ILLEGAL COMPLEX NUMBER.| ASC 0012,MISMATCHED PARENTHESIS.| * 10-19: ASC 0012,UNRECOGNIZED STATEMENT.| ASC 0014,UPPER BOUND < LOWER BOUND. | ASC 0020,RETURN # TOO LARGE OR TOO MANY ALTERNATE ASC 05, RETURNS.| ASC 0020,CONSTANT IN FORMAT > 2047 OR ILLEGAL HOL ASC 04,LERITH.| ASC 0020,CONSTANT OR CONSTANT EXPRESSION OVERFLOW ASC 08, OR UNDERFLOW. | ASC 0020,KEYWORD UNRECOGNIZED, REPEATEdD, OR ILLEG ASC 02,AL.| ASC 0012,ILLEGAL OCTAL CONSTANT.| ASC 0015,MISSING CONSTANT OR OPERAND. | ASC 0017,ILLEGAL COMBINATION OF KEYWORDS. | ASC 0014,INTEGER CONSTANT EXPECTED. | * 20-29: ASC 0020,ILLEGAL CHARACTER COUNT IN HOLLERITH CON ASC 04,STANT. | ASC 0011,VALUE OUT OF RANGE. | ASC 0011,ILLEGAL USE OF NAME. | ASC 0008,STEP SIZE = 0. | ASC 0017,VARIABLE OR ARRAY NAME EXPECTED. | ASC 0018,VARIABLE NAME OR CONSTANT EXPECTED.| ASC 0017,INTEGER (LOGICAL) ITEM EXPECTED. | ASC 0014,DUPLICATE STATEMENT NUMBER.| ASC 0011,UNEXPECTED CHARACTER.| ASC 0017,BLANK LINE HAS STATEMENT NUMBER. | * 30-39: ASC 0020,INCORRECT NESTING. MAY BE DUE TO OTHER ASC 04,ERRORS.| ASC 0019,DO LOOP NESTING PROBLEM. SEE MANUAL.| ASC 0020,UNDEFINED, ILLEGAL OR INCORRECTLY USED S ASC 09,TATEMENT NUMBER. | ASC 0001, | ASC 0012,STATEMENT OUT OF ORDER.| ASC 0014,NO PATH TO THIS STATEMENT. | ASC 0017,VARIABLE APPEARS TWICE IN COMMON.| ASC 0020,FORMAL PARAMETER IN COMMON OR DATA STATE ASC 03,MENT.| ASC 0014,WRONG NUMBER OF SUBSCRIPTS.| ASC 0020,VARIABLE DIMENSION NOT A FORMAL PARAMETE ASC 08,R OR IN COMMON.| * 40-49: ASC 0016,INCONSISTENT EQUIVALENCE GROUP.| ASC 0020,NEGATIVE EXTENSION OF COMMON VIA EQUIVAL ASC 03,ENCE.| ASC 0014,LEFT PARENTHESIS EXPECTED. | ASC 0001, | ASC 0012,NAME IN CONSTANT LIST. | ASC 0018,ILLEGAL COMBINATION OF DATA TYPES. | ASC 0020,NAME OF A FUNCTION NOT USED OR NAME OF A ASC 11, SUBROUTINE IS USED. | ASC 0001, | ASC 0015,ILLEGAL USE OF EMA VARIABLE. | ASC 0001, | * 50-59: ASC 0020,ILLEGAL LAST STATEMENT OF DO, OR THEN WI ASC 05,THOUT IF.| ASC 0020,CONTROL VARIABLE OF DO STATEMENT ALREADY ASC 05, IN USE. | ASC 0015,LOGICAL IF WITHIN LOGICAL IF.| ASC 0001, | ASC 0015,ARRAY NAME DIMENSIONED TWICE.| ASC 0001, | ASC 0018,ILLEGAL COMBINATION OF DATA TYPES. | ASC 0018,ILLEGAL COMBINATION OF DATA TYPES. | ASC 0020,FUNCTION USED AS SUBROUTINE OR HAS ALTER ASC 07,NATE RETURNS.| ASC 0011,WRONG # OF ARGUMENTS.| * 60-69: ASC 0012,ILLEGAL ARGUMENT TYPE. | ASC 0018,STATEMENT NUMBER AFTER LOGICAL IF. | ASC 0020,NO STATEMENT NUMBERS AFTER ARITHMETIC IF ASC 01,.| ASC 0001, | ASC 0001, | ASC 0001, | ASC 0020,PROGRAM SHOULD (NOT) HAVE EXECUTABLE STA ASC 05,TEMENTS. | ASC 0001, | ASC 0020,EXTERNAL NAME SHORTENED TO 5 CHARACTERS. ASC 01, | ASC 0001, | * 70-79: ASC 0001, | ASC 0020,TOO MANY/FEW CONSTANTS, OR ILLEGAL REPEA ASC 05,T COUNT. | ASC 0015,ITEM MUST (NOT) BE IN COMMON.| ASC 0020,CONSTANT & VARIABLE HAVE DIFFERENT TYPES ASC 01,.| ASC 0001, | ASC 0011,PROGRAM CALLS ITSELF.| ASC 0014,DUPLICATE FORMAL PARAMETER.| ASC 0013,STATEMENT NUMBER IGNORED.| ASC 0001, | ASC 0001, | * 80-89: ASC 0001, | ASC 0001, | ASC 0001, | ASC 0013,ATTEMPT TO RETYPE A NAME.| ASC 0018,OBJECT CODE OR EMA SPACE OVERFLOW. | ASC 0020,PROGRAM NAME CONFLICTS WITH COMMON, EXTE ASC 12,RNAL OR INTRINSIC NAME.| ASC 0001, | ASC 0016,THE GIVEN NAMES WERE NOT TYPED.| ASC 0001, | ASC 0020,LOGICAL IF HAS CONTINUE OR NO STATEMENT. ASC 01, | * 90-99: ASC 0014,ILLEGAL CONTINUATION LINE. | ASC 0020,TWO EXTERNAL NAMES CONFLICT AFTER BEING ASC 06,SHORTENED. | ASC 0020,EXTERNAL NAME CONFLICTS WITH A LIBRARY R ASC 04,OUTINE.| ASC 0016,EMA VARIABLE IN DATAA STATEMENT.| ASC 0020,VARIABLE NOT A FORMAL PARAMETER OR GIVEN ASC 04, TWICE.| ASC 0001, | ASC 0008,BREAK DETECTED.| ASC 0020,CANNOT ACCESS RELOCATABLE OUTPUT FILE. | ASC 0020,CANNOT ACCESS SOURCE FILE, OR EOF BEFORE ASC 03, END.| ASC 0016,CANNOT ACCESS SCRATCH FILE(S). | * 100-111: ASC 12, | | | | | | | | | | | | SKP * ************************************** * * SORT THE NAMED ENTRIES IN THE A.T. * * ************************************** SPC 1 * START OF OUTER LOOP: REPEATEDLY SCAN THE NAMED SYMBOL LIST FOR * THE LARGEST SYMBOL LEFT IN THE LIST FOR THAT SCAN. THEN LINK IT * INTO THE START OF THE SORTED LIST AND REMOVE FROM THE UNSORTED. * REPEAT UNTIL NO SYMBOLS REMAIN IN THE UNSORTED LIST. * TABLS LDA F.CCW IS EITHER T OR C SELECTED ? AND B30 SZA,RSS JMP RETRN NO. DONE. * OLOOP CLA SAV.A IS 0 UNTIL 1ST PRINTABLE FOUND. STA SAV.A JSB GFA.F START SCAN. * * START OF INNER LOOP. GET NEXT SYMBOL IN UNSORTED LIST. * LOOPI LDA F.A SAVE OLD F.A STA OLDFA JSB GNA.F GET NEXT SYMBOL TABLE ENTRY. SZA,RSS IF TOP OF S.T. REACHED, JMP LOOPE END OF LOOP THRU ASSIGN. TABLE * JSB FID.F GET SYMBOL ID, TAGS. JSB FA.F LDA F.A TEMP CELL ? ADA K2 LDA A,I SSA,RSS JMP LOOP0 NO, COMPARE TO BEST SO FAR. * * * REJECTED. REMOVE FROM LIST. * CCA GET THIS ITEM'S LINK. ADA F.A LDA A,I LDB OLDFA NOW BACK UP TO PREVIOUS ITEM. STB F.A ADB KM1 & SET ITS LINK TO POINT PAST DELETED ITEM. STA B,I (OLDFA IS WRONG NOW BUT THAT'S O.K.) JMP LOOPI NOW GO ADVANCE. SPC 1 OLDFA NOP F.A OF PREVIOUS ENTRY. SAV.A NOP OLDFA OF LARGEST SO FAR.^ T.DNI NOP POINTER TO STEP THRU (DID) BSNID DEF SNID SNID BSS 6 KM1 DEC -1 B100 OCT 100 SKP * GOT ONE. SEE IF SMALLEST SO FAR. * LOOP0 LDA SAV.A FIRST PRINTABLE ? SZA,RSS JMP LOOPR YES, THEN SET UP AS AN INITIAL SYMBOL * LDB BSNID COMPARE AGAINST BEST SO FAR. LDA F.DNI STA T.DNI * LOOPF LDA B,I CHARACTER FROM SNID CMA,INA ADA T.DNI,I (NID) - (SNID) INB (ADVANCE) ISZ T.DNI SZA,RSS SAME ? JMP LOOPF YES, KEEP CHECKING. SSA NO. WHICH IS SMALLER ? JMP LOOPI ITEM BEING SCANNED. SKIP IT. * * NEW LARGEST SYMBOL. * LOOPR LDA F.DNI THIS IS ALPHABETICALLY THE LDB BSNID SMALLEST NAME SO FAR THIS SCAN. JSB .MVW .MVW TO SAVE AREA DEF K6 NOP LDA OLDFA REMEMBER OLDFA & SET SAV.A#0. STA SAV.A JMP LOOPI * * THIS SCAN COMPLETE. ADD SYMBOL TO SORTED LIST. * LOOPE CCB FORM ADDR OF LINK OF PREVIOUS ONE. ADB SAV.A SSB (IF NONE, SAV.A=0 SO B=-1 NOW) JMP LOOP7 DIDN'T FIND ANY. ALL DONE SORTING. * CCA FIRST, REMOVE THE ITEM FROM UNSORTED LIST. ADA B,I (A) = ADDR OF LINK OF ONE TO ADD. STA F.A (NEED IT LATER) LDA A,I (A) = VALUE OF LINK OF ONE TO ADD. STA B,I IT'S GONE! LDA F.SSL ADD TO THE START OF THE SORTED LIST. STA F.A,I 1) POINT IT TO THE LIST. LDA F.A 2) MAKE IT THE NEW FIRST ITEM. INA STA F.SSL JMP OLOOP GO SCAN AGAIN. SKP * DONE SORTING. IF 'T', PRINT THE TABLE ENTRIES. * LOOP7 LDA F.CCW 'T' OPTION ? AND K8 SZA,RSS JMP XREF NO. JUST XREF. JSB EJP.F NEW PAGE. * LDA F.SSL START SCAN. STA F.A JMP LOOP9 * LOOPA CLA Er RESET STMT FCT FLAG. STA T1LOP LOOP4 JSB GNA.F BUMP TO NEXT ITEM. LOOP9 SZA ALL DONE ? JMP LOOPB NO. LOOK AT THIS ONE. * LDA T1LOP MAYBE. IS IT JUST END OF STMT FCT ? STA F.A (JUST IN CASE) SZA WELL ? JMP LOOPA YES. RESUME AFTER IT. JMP XREF ELSE DONE. TEST TO SEE IF XREF REQUESTED * LOOPB JSB FA.F FETCH ASSIGNS. JSB FID.F COPY (UNPACKED) SYMBOL TO (DID) * LDA F.AT PROCESS ALL FORMAL PARAMETERS. CPA DUM JMP LOOP6 LDB F.DNI,I (B) = FIRST CHAR. CPB B100 STATEMENT # CPA B2000 AND DEFINED (F.AT#2000) RSS NO. (IF STMT #, F.IU=0) JMP LOOP6 YES. LDB F.IU SZB,RSS IF F.IU = 0, SKIP ITEM. JMP LOOP4 * CPA STRAB IF F.AT=STRAB, CPB SUB AND F.IU#SUB, RSS NO. JMP LOOP4 THEN UNUSED VARIABLE. * CPA BCOMI IF LABELLED COMMON MASTER, JMP LOOP6 ALWAYS PRINT. * LDA F.AF IF F.AF=0 AND F.IU=SUB, SZA JMP LOOP6 (F.AF#0) * CPB SUB JMP LOOP4 SKIP THE ITEM. SKP * GOT A LIVE ONE. SET UP TO PRINT IT. * LOOP6 LDA F.LOP PRINT A SYMBOL TABLE LINE. INA,SZA,RSS AT BOTTOM OF PAGE? JSB EJP.F YES. FORMFEED LDA F.LOP SZA AT TOP OF PAGE? JMP LOOP5 NO. LDA K7 YES; PRINT HEADER LDB LABLE AND TWO BLANK LINES JSB PSL.F THEN "SYMBOL TABLE" CLA JSB SKL.F THEN A BLANK LINE LDA K31 LDB HEADR JSB PSL.F THEN HEADER CLA,INA JSB SKL.F AND TWO MORE BLANK LINES. LOOP5 JSB CLR1 CLEAR OUT LIST BUFFER * * COPY NAME TO LINE. * LDA NAME NORMAL POSITION FOR NAME. LDB T1LOP IS IT A STMT FCT FORMAL ? SZB INA YES, MOVE FURTHER RIGHT. STA LOOPC JSB NAM.F LOOPC DEF *-* * * TRANSFER ADDRESS TO LINE. SPC 1 LDB F.AF GET ADDRESS LDA F.A,I SEE IF INTRINSIC. AND B7740 F.AT,F.IU,F.NC CPA B2240 F.AT=STRAB,F.IU=SUB,F.NC=1: JMP TYP01 INTRINSIC, NO ADDR OR LOCATION. * LDA F.EM EMA ? SZA JMP EMAAD YES. GO FORMAT THAT. * LDA F.AT GET ADDRESS TYPE. CPA BCOM IF LABELLED COMMON, RSS SKIP TO DO IT JMP ATL1 ELSE JMP * INB STEP TO AND LDB B,I GET THE OFFSET ATL1 SSB CMB,INB LDA ADDR2 ADDRESS FIELD OF LINE. STA ASSLC SET LOCATION JSB ASCI5 CONVERT TO ASCII AND STORE. JMP REL01 GO DO RELOCATION INDICATOR. SKP * PROCESSING FOR EMA ADDRESSES. * EMAAD LDA F.IU CHECK IF ARRAY CPA ARR IF SO RSS SKIP JMP EMAA1 NOT ARRAY * DLD F.A,I ARRAY. THE BCOMI POINTER IN THE DIM ENTRY ADB K2 MAY HAVE BEEN GARBAGED. GET THE COPY FROM LDB B,I WORD 2 OF THE DIM ENTRY, AND STB F.AF RESET F.AF TO RIGHT VALUE EMAA1 LDA F.AT DUMMY ? CPA DUM JMP EMAFP YES. DIFFERENT ? * CPA BCOMI EMA MASTER ENTRY ? JMP USAG1 YES. NO ADDR, LOCATION OR TYPE. * LDB F.AF GET EMA ADDRESS: ADB K2 DLD B,I IN (B,A). ASL 6 SET PAGE NUMBER IN B LDA ADDR SET THE ADDRESS STA ASSLC FOR THE ADDRESS JSB ASCI4 THEN TO THE LINE LDA "P" NOW SEND THE 'P' TO INDICATE PAGE JSB PUT.F TO THE LINE LDA B40 AND A BLANK JSB PUT.F LDA F.AF GET LOWER PART AGAIN. ADA K2 LDA A,I AND B1777 ISOLATE THE PAGE OFFSET. STA B AND JSB ASCI4 SEND IT TO THE LINE - JMP EMART GO SEND THE '+' * * EMA FORMAL PARAMETERS. * EMAFP CCA EMA DUMMY. SET EMA FLAG. STA EMFLG LDB F.AF GET F.RPL OF DUMMY. ADB K2 LDB B,I JMP ATL1 * B7740 OCT 7740 MASK FOR F.AT & F.IU & F.NC B2240 OCT 2240 F.AT,F.IU,F.NC FOR INTRINSICS. B2200 OCT 2200 F.AT,F.IU OF ANY EXTERNAL FUNCTION. B7200 OCT 7200 F.AT,F.IU OF COMMON MASTERS. B17K OCT 17000 B1000 OCT 1000 LABLE DEF SYTH HEADR DEF SYTH2 SKP * RELOCATION INDICATOR TO LINE * REL01 LDB "R" ASSUME PROGRAM RELOCATABLE. LDA F.AT CPA COM. IF COMMON, LDB "C" SET INDICATOR TO 'C'. CPA BCOM IF BCOM EMART LDB B53 USE "+" (RETURN FROM EMAAD) LDA F.A,I SEE IF EXTERNAL SUBR. AND B7600 F.AT & F.IU CPA B2200 F.AT=STRAB & F.IU=SUB ? RSS CPA B7200 OR F.AT=BCOMI & F.IU=SUB ? LDB "X" YES, EXTERNAL PROG OR COMMON MASTER. STB USE SAVE USE FOR LATER LDA B PUT THE CHAR IN THE LINE JSB PUT.F * * LOCATION. * LDA IU1 ITEM USAGE = STATEMENT NUMBER? LDB F.DNI,I CPB B100 JMP LOOP3 YES, SKIP TYPE AND LOCATION. * LDA LO4 ASSUME 'LOCAL' LDB USE CPB "X" IF EXTERNAL INDICATOR, LDA LO1 CHANGE TO 'EXTERNAL' LDB F.AT CPB COM. IF COMMON, LDA LO2 CHANGE TO 'COMMON' CPB DUM IF DUMMY, LDA LO3 CHANGE TO 'DUMMY'. CPB BCOM IF LABELED COMMON LDA LO5 CHANGE TO 'L COMMON' LDB LOCAT LOCATION FIELD OF LINE JSB .MVW DEF K4 NOP * * IF EMA DUMMY, ADD '(EMA)' TO LOCATION. * ISZ EMFLG EMA DUMMY ? JMP TYP02 NO. DLD LO6A YES, COPY "(EMA)" DST LBUF+30 LDA LO6A+2 STA LBUF+32 JMP TYP02 gGO DO TYPE. SKP * TYPE. INTRINSICS FIRST, THEN OTHERS. * TYP01 LDA F.R UNLESS ONLY USED AS SUBROUTINE. SZA,RSS JMP USAG1 THEN NO TYPE. * LDA B,I FIRST WORD INTRINSIC DATA. SSA SPECIAL: EXEC/REIO/XLUEX ? JMP TYP02 YES. NOT GENERIC. * AND B17K # SPECIFIC FUNCTIONS SELECTED. CPA B1000 EXACTLY ONE ? JMP TYP02 YES. TELL HIM THAT TYPE. * LDA DIMG ELSE 'GENERIC' JMP TYP03 * TYP02 LDA F.AT COMMON LABEL ? CPA BCOMI JMP USAG1 YES. NO TYPE. * LDA F.IM OTHER. INDEX TABLE BY TYPE. ALF ADA DDFIM LDA A,I (A) = ADDR OF NAME. TYP03 LDB TYPE TYPE FIELD OF LINE JSB .MVW DEF K4 NOP * * USAGE TO LINE * USAG1 LDB F.IU CPB SUB RSS JMP LOOP2 NOT SUBPROGRAM * LDA IU2 ASSUME STATEMENT FUNCTION LDB F.AT CPB DUM IF DUMMY, JMP USAG2 GO CHECK SUBROUTINE/FCT. CPB BCOMI IF BCOM INFO ENTRY LDA IU8 CHANGE TO BCOM LABEL CPB STRAB IF EXTERNAL SUBROUTINE, RSS JMP LOOP3 (NO. GOT IT ALREADY) * LDA IU6 ASSUME 'INTRINSIC'. LDB F.NC IF F.NC=1, CPB B40 JMP LOOP3 THAT'S RIGHT. * USAG2 LDA IU7 ASSUME 'FUNCTION'. LDB F.R IF FUNCTION FLAG SET, SZB JMP LOOP3 THAT'S RIGHT. LEAVE TYPE. * LDA DFIM0 ELSE ZAP TYPE. LDB TYPE JSB .MVW DEF K4 NOP LDA IU3 NOW 'SUBROUTINE'. JMP LOOP3 SKP * HANDLE ARRAYS AND UNUSED VARIABLES. * LOOP2 LDA IU4 CPB VAR IF VARIABLE. JMP LOOP3 * SZB,RSS IF NOT USED, JMP LOOP8 THEN LEAVE BLANK. * LDA IU5X ARRAY. WORD CONTAINING DIMENSION COUNT. AND BM10 CLEAR OUT LAST NUMBER USED,d. ADA F.ND INSERT NEW DIMENSION COUNT. STA IU5X LDA IU5 ADDR OF THAT MSG. LOOP3 LDB USAGE USAGE FIELD OF LINE JSB .MVW DEF K9 NOP * * SUPPLY BCOM LABEL IF IN LABELED COMMON * LOOP8 LDA F.AT CPA BCOM IN LABELED COMMON? RSS YES SKIP JMP OL1 NO JUST OUTPUT THE LINE * LDB F.A SAVE F.A FOR TRAVERSING LIST. STB OLDFA LDB F.AF COPY NAME OF COMMON BLOCK. ADB K2 SKIP TO SLOT FOR MASTER ADDR. LDB B,I (B) = ADDR COMMON MASTER. LDA F.EM UNLESS EMA, SZA LDB F.EMA INWHICHCASE IT'S THIS ONE. STB F.A JSB NAM.F DEF LBUF+33 LDB OLDFA RESTORE F.A STB F.A SKP * OUTPUT LINE. FIRST, TRIM BLANKS. * OL1 LDA LAST START AT END. LDB BLNKS (B) = TWO BLANKS. OL2 ADA KM1 BACK UP ONE. CPB A,I IF STILL BLANK, JMP OL2 KEEP GOING. * CMA -(ADDR LAST NONBLANK WORD)-1 ADA DLBU. (FIRST)-(LAST)-1 CMA,INA (LAST)-(FIRST)+1 = LENGTH. LDB DLBU. JSB PSL.F PRINT THE LINE. JSB IFBRK CHECK FOR BREAK. DEF *+1 SSA WELL ? JMP BREAK YES. GO ABORT. * LDA F.A,I WAS THIS A STATEMENT FUNCTION ? AND B7600 CPA B1200 I.E., F.AT=REL & F.IU=SUB ? RSS YES. JMP LOOP4 NO. GO ON TO NEXT SYMBOL. * DLD F.A,I YES. (B) = EXTENSION ADDR. INB LDA B,I (A) = ADDR FIRST FORMAL. LDB F.A SAVE CURRENT F.A STB T1LOP (ALSO FLAG FOR LISTING) STA F.A SET UP TO LIST FORMALS, JMP LOOP9 AND DO IT. * ASSLC NOP ASSBF PTR ARR OCT 600 "C" OCT 103 B7600 OCT 7600 MASK FOR F.AT & F.IU B1200 OCT 1200 F.AT=REL, F.IU=SUB : STMT FCT. B53 OCT 53 "+" B1777 OCT 1777 B20 OCT 20 "R" OCT 122 "P" OCT 120 KM4 DEC -4 "X" OCT 130 USE NOP T1LOP NOP F.A OF STMT FCT IF IN FORMALS. STRAB OCT 2000 BCOM OCT 3000 BCOMI OCT 7000 K31 DEC 31 EMFLG NOP SPC 1 K9 DEC 9 BM10 OCT -10 B40 OCT 40 B2000 OCT 2000 DUM OCT 5000 SPC 1 SUB OCT 200 VAR OCT 400 COM. OCT 4000 LO1 DEF LO1A LO2 DEF LO2A LO3 DEF LO3A LO4 DEF LO4A LO5 DEF LO5A DIMG DEF IMGEN FOR 'GENERIC' DDFIM DEF *+1 USED TO INDEX THIS TABLE. DFIM0 DEF IM0 0 NONE (BLANK) DEF IM1 1 INTEGER DEF IM2 2 REAL DEF IM3 3 LOGICAL DEF IM0 4 ERROR DEF IM5 5 COMPLEX DEF IM6 6 EXTENDED DEF IM0 7 ERROR DEF IM8 8 DOUBLE INTEGER DEF IM9 9 DOUBLE LOGICAL DEF IM10 10 DOUBLE DEF IM11 11 CHARACTER DEF IM12 12 DOUBLE COMPLEX * DLBU. DEF LBUF NAME DEF LBUF+1 ADDR DBL LBUF+5 ADDR2 DBR LBUF+7 USAGE DEF LBUF+12 TYPE DEF LBUF+22 LOCAT DEF LBUF+27 LAST DEF LBUF+40 * IU1 DEF IU1A IU2 DEF IU2A IU3 DEF IU3A IU4 DEF IU4A IU5 DEF IU5A IU6 DEF IU6A IU7 DEF IU7A IU8 DEF IU8A K7 OCT 7 * * * CLEAR LIST BUFFER * SPC 1 CLR1 NOP LDA BLNKS 2 BLANKS STA LBUF START WITH BLANKS, LDA DLBU. AND PROPOGATE. LDB A INB I.E., MOVE * TO *+1. JSB .MVW DEF K39 FIRST + 39 = 40 WORDS. NOP JMP CLR1,I DONE. * K39 DEC 39 SKP * ** DATA TO OCTAL ASCII CONVERSION ** SPC 1 * CALLING SEQUENCE: LDB (DATA WORD) * LDA (ADDRESS AT START OF STORAGE) * JSB ASCI6 SPC 1 ASCI6 NOP OUTPUT 6 DIGITS STA ASSLC SET THE ADDRESS LDA KM6 GET NO. OF DIGITS TO CONVERT RBL MOVE FIRST DIGIT TO LOW B JSB NUM.F CONVERT THE NUMBER JMP ASCI6,I RETURN SPC 2 ASCI5 NOP 5 DIGITS & BLANK LDA KM5 GET NO OF DIGITS TO CONVERT BLF POSITION FIRST DIGIT JSB NUM.F CONVERT THE NUMBER JMP ASCI5,I RETURN * ASCI4 NOP ROUTINE TO CONVERT 4 OCTAL DIGITS FROM B LDA KM4 TO THE OUT PUT LINE BLF,RBL POSITION FIRST DIGIT IN RBL,RBL LEAST 3 BITS OF B JSB NUM.F CONVERT IT TO THE LINE JMP ASCI4,I RETURN. * * *********************************** * * CONVERT DIGITS TO ASCII BASE 8 * * *********************************** * * NUM.F NOP STA T1NUM SAVE THE DIGIT COUNT CPA KM6 IF 6 THEN CLA,INA,RSS USE 1 AS A MASK FOR FIRST DIGIT NUM00 LDA K7 ELSE USE 7 AND B ISOLATE THE DIGIT ADA "0" ADD 60 TO MAKE ASCII JSB PUT.F PUT IN THE BUFFER BLF,RBR POSITION THE NEXT DIGIT ISZ T1NUM DONE? JMP NUM00 NO DO NEXT DIGIT * JMP NUM.F,I YES RETURN * T1NUM NOP KM6 DEC -6 KM5 DEC -5 "0" OCT 60 * SPC 2 * * ******************************** * * PUT CHARACTER IN LIST BUFFER * * ******************************** * PUT.F NOP STB T1PUT SAVE B LDB ASSLC GET CURRENT BUFFER ADDRESS AND B177 ISOLATE THE CHARACTER CLE,ERB WORD ADDRESS TO B E=UPPER,LOWER FLAG SEZ,RSS IF UPPER CHAR ALF,SLA,ALF POSITION AND SKIP XOR B,I INCLUSION OF HIGHER CHAR. XOR B40 ADD,TAKE AWAY LOWER BLANK STA B,I SET THE WORD DOWN ISZ ASSLC STEP THE CHAR ADDRESS LDB T1PUT RESTORE B JMP PUT.F,I RETURN * T1PUT NOP B177 OCT 177 SKP * *************************** * * VARIABLES AND CONSTANTS * * h*************************** SPC 1 SYTH ASC 7, SYMBOL TABLE * SYTH2 ASC 06, NAME ASC 06, ADDRESS ASC 10, USAGE ASC 05,TYPE ASC 04,LOCATION * IU1A ASC 9,STATEMENT NUMBER IU2A ASC 9,STATEMENT FUNCTION IU3A ASC 9,SUBROUTINE IU4A ASC 9,VARIABLE IU5A ASC 3,ARRAY, IU5X ASC 6, 0 DIMEN. IU6A ASC 9,INTRINSIC IU7A ASC 9,FUNCTION IU8A ASC 9,COMMON LABEL * IMGEN ASC 4,GENERIC IM0 ASC 4, (NONE) IM1 ASC 4,INTEGER IM2 ASC 4,REAL IM3 ASC 4,LOGICAL IM5 ASC 4,COMPLEX IM6 ASC 4,EXTNDED IM8 ASC 4,DBL INT IM9 ASC 4,DBL LOG IM10 ASC 4,DOUBLE IM11 ASC 4,CHAR IM12 ASC 4,DBL CPX * LO1A ASC 4,EXTERNAL LO5A ASC 1,L L FOR LABELED COMMON LO2A ASC 4,COMMON LO3A ASC 4,DUMMY LO4A ASC 4,LOCAL LO6A ASC 3,(EMA) LBUF ASC 1, BSS 39 LIST BUFFER K16 DEC 16 HED F4.3 XREF SECTION XREF JSB EJP.F FINISH OFF THE SYMBOL TABLE LDA F.CCW CHECK IF XREF AND K16 REQUIRED SZA,RSS WELL? JMP RETRN NO XREF REQUESTED GO DO NEXT MODULE * CLA XREF REQUESTED SET UP FOR IT JSB SKL.F SKIP LINE DEBUG ONLY JSB RWN.C REWIND XREF DISC FILE DEF C.SC0 JMP FERR ERROR REPORT AND EXIT SPC 1 * THE MEMORY AREA USED IN THIS SEGMENT IS IN THREE PARTS * PART 0 IS FROM THE BEGINING OIF THE SEGMENT DOWN TO 'PAS1' BELOW * PART 1 IS FROM THE END OF THIS SEGMENT (AS DEFINED BY GMS.C) * TO THE BEGINING OF THE ASSIGNMENT TABLE. PART TWO IS FROM * THE END OF THE ASSIGNMENT TABLE TO THE END OF AVAILABLE MEMORY * (THESE ARE DEFINED BY F.LO AND F.DO). * * THESE AREAS ARE FILLED WITH THE CROSS REFERENCE PAIRS GENERATED * IN PASS ONE IN CIRCULAR FASHION SO THAT WE ALWAYS HAVE THE LAST * N RECORDS IN MEMORY. THIS MEANS THAT FOR LARGE PROGRAMS WHERE * THERE IS NOT ENOUGH MEMORY TO CONTAIN ALL THE CROSS REFERENCE PAIRS * WE NEED lGONLY READ THE BEGINNING OF THE FILE TO GET THE RECORDS THAT * ARE NOT IN MEMORY. * * TO DO ALL THESE WONDERS WE USE THE FOLLOWING POINTERS: * * STM0 START OF MEMORY POOL (F4.3) * ENDM0 END OF POOL ZERO ~ 'PAS1' * STMEM START OF MEMORY * ENDM1 END OF FIRST MEMORY * F.LO START OF SECOND MEMORY * ENDM2 END OF SECOND MEMORY AREA * FREC NUMBER OF LOWEST NUMBERED X-REF RECORD IN MEMORY * FRLOC THE ABOVE RECORDS ADDRESS * SPC 1 * THE CODE BELOW USES FOUR ADDRESSES: * PLIST AND ULIST ARE DEFINED AT THE * END OF THIS SEGMENT; * F.LO = END OF ASSIGNMENT TABLE + 1 AND * F.DO = END OF MEMORY. SPC 1 * IF F.DO - F.LO > ULIST - PLIST, THEN * SET PLIST _ F.LO AND ULIST _ F.DO. SPC 1 LDA SIZ0 GET SIZE OF MEMORY POOL ZERO LSR 5 ROUND DOWN TO 32 BIT CHUNCKS LSL 5 AND ADA STM0 ADD THE BASE ADDRESS STA ENDM0 SET THE END ADDRESS JSB GMS.C FIND THE END OF THIS SEGMENT STA STMEM STMEM _ LOW MAIN CCB SET UP THE END OF THIS FREE AREA ADB F.DP AS THE START OF THE ASSIGNMENT TABLE CMA,INA ADA B KEEP EVEN 32 WORD PIECES ONLY LSR 5 LSL 5 ADA STMEM ADDRESS OF WORD AFTER LAST USABLE STA ENDM1 SAVE IT CCB NOW SET UP THE OTHER AREA ADB F.DO LDA F.LO CMA,INA ADA B LSR 5 LSL 5 ADA F.LO STA ENDM2 SET IT UP * * SCAN THE SORTED SYMBOLS & CLEAR WORD (1) = COUNT WORD. * LDA F.SSL SET TO SCAN A.T. TO CLR COUNT WDS (WD 2) STA F.A RSS CLOP JSB GNA.F GET AN ENTRY SZA,RSS IF END OF LIST JMP PAS1 GO READ IN THE XREF PAIRS * INA CLEAR THE COUNT WORD. CLB STvpB A,I COUNT WORD JMP CLOP AND GO GET THE NEXT ENTRY *********************************************************************** *** ALL DATA & CODE REFERENCES WITHIN THIS MODULE MUST NOW BE MADE *** *** TO ADDRESSES PHYSICALLY HIGHER THAN THIS ONE. THE LOWER PART *** *** OF THIS MODULE WILL BE USED FOR DATA !!! *** *********************************************************************** * COUNT THE NUMBER OF REFERENCES FOR EACH SYMBOL * BY LOGGING EACH ONE AS THE XREF DATA IS READ. * PAS1 JSB READ READ A PAIR BUFFER TO MEMORY LDB CREC GET THE CURRENT RECORD ADDRESS PAS11 LDA B,I GET THE A.T. ADDRESS SZA,RSS END OF LIST? JMP PAS2 YES START PASS 2 * INA NO STEP THE COUNT ON THIS ENTRY ISZ A,I ADB K2 STEP B ISZ PCOUN DONE WITH THIS RECORD? JMP PAS11 NO GET NEXT ENTRY * JSB NEXRC SET ADDRESS FOR NEXT RECORD JMP PAS1 READ THE NEXT ONE SKP * ************* * * PHASE TWO * * ************* SPC 1 * SCAN THRU SORTED SYMBOLS, PRINTING XREF. * PAS2 JSB NEXRC RESERVE A BUFFER FOR PASS TWO LDA CREC SAVE ITS STA SADD ADDRESS ISZ XFLAG SET PASS TWO FLAG FOR READ ROUTINE * LDA F.SSL START SCAN. STA F.A RSS PAS22 JSB GNA.F NEXT ! SZA,RSS DONE ? JMP RETRN YES. QUIT. JMP LBL14 NO. GO PROCESS IT. SPC 1 STMEM NOP ENDM1 NOP ENDM2 NOP FREC NOP SADD NOP F.SSL NOP SPC 3 * ************************* * * ABORT CROSS REFERENCE * * ************************* SPC 1 * ************************************** * * RETURN TO FTN4 * * ************************************** SPC 1 RETRN JSB EJP.F TO TOP OF PAGE qM LDB K4 RETURN TO JMP F.SEG THE INIT SEGMENT FOR NEXT PGM. SPC 2 DEC 23 * NEXTP NOP K6 DEC 6 K4 DEC 4 K2 DEC 2 SKP * PRINT REFERENCES FOR SYMBOL (F.A) * LBL14 JSB RWN.C REWIND XREF FILE DEF C.SC0 JMP FERR ERROR REPORT AND EXIT * DLD F.A,I (B) = REFERENCE COUNT. CMB,INB,SZB,RSS NEGATE. ZERO ? JMP PAS22 YES. SKIP IT. STB COUNT NEGATE FOR COUNTER CLB STB REC SET RECORD COUNT TO ZERO JSB NAM.F COPY SYMBOL ASCII NAME. DEF LINE+1 CLA SKIP A LINE. JSB SKL.F * * SCAN THRU XREF DATA, OUTPUT EACH (F.A) REF. * LBL15 JSB READ GET NEXT SECTOR OF XREF PAIRS. LDA CREC GET CURRENT RECORD ADDRESS STA NEXTP AND SET IN VARABLE LBL16 LDA NEXTP,I (A)=NEXT A.T. POINTER TO CHECK CPA F.A IF IT IS THE SAME AS THE CURRENT JMP LBL19 ELEMENT, ADD LINE NO. * ISZ NEXTP POINT TO LBL17 ISZ NEXTP NEXT PAIR IN PLIST. ISZ PCOUN BUMP PAIR COUNT. JMP LBL16 COMPARE AGAINST NEXT PAIR. * LDA NEXTP IF PCOUN=0, ADJUST NEXTP, JSB NEXRC GET NEXT RECORD OF PAIRS JMP LBL15 SPC 1 LBL19 LDA NREFS CPA K10 LINE FULL? JSB PLINE YES. PRINT IT. LDA NREFS REFS ON LINE ALS,CLE *3 (E=0 FOR ASC.F) ADA NREFS ADA XRLOC START OF REFERENCES IN LINE STA RFLOC LOCATION IN LINE OF NEXT REF ISZ NREFS ISZ NEXTP POINT TO LINE NO. IN XREF PAIR LDA NEXTP,I LINE NO. IN BINARY JSB ASC.F CONVERT IT TO ASCII (E=0 HERE) STB RFLOC,I FIRST 2 DIGITS ISZ RFLOC STA RFLOC,I 2ND TWO ISZ COUNT MORE REFS? JMP LBL17 YES. * JSB PLINE PRINT LAST LINE OF XREF LIST JMP PAS22 GO GET THE NEXT SYMBOL SKP * 5************** * * PRINT LINE * * ************** SPC 1 PLINE NOP LDA F.LOP INA,SZA,RSS AT BOTTOM OF PAGE? JSB EJP.F YES. FORMFEED LDA F.LOP SZA AT TOP OF PAGE? JMP PL01B NO. * LDA K11 PRINT HEADER AND TWO BLANK LINES LDB LABLX "CROSS REFERENCE LIST" JSB PSL.F OUTPUT LINE CLA JSB SKL.F SKIP A LINE LDA K11 LDB HEADX "SYMBOL REFERENCES" JSB PSL.F OUTPUT LINE CLA,INA JSB SKL.F SKIP 2 LINES PL01B LDA NREFS COMPUTE LENGTH OF PORTION OF ALS LINE BUFFER TO BE PRINTED (ONLY ADA NREFS OUT TO END OF CROSS-REF INFO.) ADA K5 LDB BLINE JSB PSL.F PRINT THE LINE CLA SET NUMBER OF REFS IN LINE STA NREFS TO 0. * LDA BLNKS BLANK OUT NAME EVERY TIME. STA LINE+1 BE PRINTED AGAIN. STA LINE+2 STA LINE+3 JMP PLINE,I SPC 1 K5 DEC 5 K10 DEC 10 BLINE DEF LINE ADDRESS OF LINE BUFFER XRLOC DEF LINE+6 RFLOC NOP COUNT NOP K32 DEC 32 K8 DEC 8 STM0 DEF F4.3 START OF MEMORY POOL 0 ENDM0 DEF PAS1 END OF POOL 0 (REFINED BY CODE) CREC DEF F4.3 INITIAL FIRST BUFFER FRLOC DEF F4.3 AND FIRST RECORD SIZ0 ABS PAS1-F4.3 MAX SIZE OF POOL 0 SKP UPADD NOP COMPUTE NEXT ADDRESS IN CIRCULAR BUFFER LDA CREC GET CURRENT ADDRESS ADA K32 ADD BLOCK SIZE CPA ENDM0 END OF BLOCK ZERO? LDA STMEM YES START BLOCK 1 CPA ENDM1 END OF FIRST POOL? LDA F.LO YES SWITH TO NEXT POOL CPA ENDM2 END OF SECOND POOL? LDA STM0 YES SET TO FIRST POOL JMP UPADD,I RETURN * * NEXRC NOP COMPUTE ADDRESS OF NEXT RECORD AND JSB UPADD KEEP TRACK OF OVERLAYS STA CREC SET NEW ADDRESS CPA STM0 OVER LAY ? ISZ OVER @ YES LDB OVER WERE THERE ANY OVER LAYS? SZB,RSS WELL? JMP NEXRC,I NO ALL IS WELL * LDB XFLAG PASS TWO? SZB WELL? JMP NEXRC,I YES ALL IS WELL ANY WAY * ISZ FREC STEP THE RECORD NUMBER OF THE FIRST RECORD IN JSB UPADD THE POOL AND GET ITS ADDRESS STA FRLOC SET ADDRESS IN ITS LOCATION. JMP NEXRC,I NOW ALL IS WELL SPC 2 * LINE SET-UP: SPC 1 * 2 BLANKS (LINE PRINTER ONLY) * 6 CHAR NAME (FIRST LINE FOR SYMBOL) OR 6 BLANKS (OTHER LINES) * 4 BLANKS AND 4 DIGIT REFERENCE (REPEATED UP TO 8 TIMES) SPC 1 * MAX # CHARS/LINE: 70(TTY), 72(LINE PRINTER) SPC 1 * LINE IS INITIALIZED TO 72 BLANKS SPC 1 LINE ASC 18, ASC 18, ASC 18, ASC 18, BLNKS EQU LINE NREFS NOP MUST BE 0 INITIALLY SPC 1 LABLX DEF *+1 ASC 11, CROSS-REFERENCE LIST HEADX DEF *+1 ASC 11, SYMBOL REFERENCES K11 DEC 11 SKP * **************************************** * * READ CROSS REFERENCE PAIRS FROM DISC * * **************************************** SPC 1 * ON ENTRY, THE FOLLOWING VARIABLES ARE SET UP: SPC 1 * NEXTP = NEXT PAIR LOCATION. THE 64 WORD SECTOR * IS READ INTO THIS AREA OF THE LIST OF * CROSS REFERENCE PAIRS. THE 64 WORDS * WILL TAKE UP THE AREA ADDRESSED BY * NEXTP+0 TO NEXTP+63. AT LEAST 128 WORDS MUST * REMAIN BETWEEN PLIST AND NEXTU, THE * LOCATION OF THE NEXT UNIQUE ASSIGNMENT * TABLE POINTER IN THE LIST OF THOSE POINTERS. * IF NOT, A MESSAGE IS PRINTED ELSEWHERE IN * THIS SEGMENT AND THE CROSS REF. IS ABORTED. SPC 1 * NOTE: SPC 1 * THIS ROUTINE IS USED IN BOTH PHASES OF THIS SEGMENT. * IN PHASE 1, WHEN THE LIST OF UNIQUE ASSIGNMENT * TABLE POINTERS IS BEING CONSTRUCTED (XFLAG=0d{), * THE SECTOR IS ALWAYS READ FROM THE DISC. IN PHASE 2, * WHEN THE CROSS REFERENCE LIST IS BEING PRINTED (XFLAG#0), * THE SECTOR IS READ ONLY IF IT IS NOT ALREADY IN CORE. * THE SECTOR IS NOT IN CORE WHEN NEXTP = OVLAY. OVLAY * IS THE ADDRESS WHERE THE SECTOR OVERLAY AREA BEGINS. SPC 1 * ON EXIT, THE FOLLOWING VARIABLES ARE SET UP: SPC 1 * PCOUN = PAIR COUNT. THIS IS THE NUMBER OF CROSS * REFERENCE PAIRS IN THE SECTOR. IT IS SET * NEGATIVE FOR LATER USE AS A COUNTER. PCOUN * ALWAYS HAS A VALUE OF -32. SPC 1 * WCOUN = WORD COUNT. THIS IS A COUNT OF THE NUMBER * OF WORDS THAT NEXTP MUST BE ADJUSTED BEFORE * THIS ROUTINE IS CALLED THE NEXT TIME. USUALLY * WCOUN IS SET TO 0. HOWEVER, WCOUN IS SET * NON-ZERO IF: SPC 1 * WCOUN = -64 IF THE SECTOR READ OVERLAYED A * PREVIOUS SECTOR. SPC 2 READ NOP JSB IFBRK CHECK FOR BREAK DEF *+1 SSA WELL? JMP BREAK * LDA XFLAG IF THIS FLAG IS 0, THE UNIQUE SZA,RSS A.T. POINTER IS BEING BUILT JMP READ1 IN PHASE 2. MUST READ SECTOR; * LDA FREC IN PASS TWO IF RECORD IS CMA,INA BELOW ONE IN ONE OF THE ADA REC BUFFERS SSA THEN JMP READ0 GO READ IT * SZA IT IS IN MEMORY JMP READ3 IF NOT FIRST ACCESS JUST GO SET IT UP * LDA FRLOC FIRST REC FROM MEM BUFFER STA CREC SET IT'S ADDRESS JMP READ3 GO DO IT * READ0 LDA SADD USE THE SAVED ADDRESS FOR PASS TWO STA CREC READS * READ1 CCB GET THE BUFFER ADDRESS ADB CREC LESS ONE STB BUFA AND SET AS THE READ ADDRESS LDA B,I GET THE WORD TO BE OVERLAYED AND STA SAV SAVE IT READ2 CLA SET TO SAVE THE AREA JSB RE"D.C READ A LINE DEF C.SC0 OF SCRATCH BUFA DEF * CONFIGURED ABOVE DEF K33 TOTAL SIZE IS 33 (32+FLAG) JMP FERR READ ERROR GO ABORT * SSB IF EOF JMP EOF GO SET UP * LDA BUFA,I GET THE FLAG WORD CPA KM2 IF NOT AN XREF RECORD RSS JMP READ2 GO READ ANOTHER RECORD * READ4 LDA SAV RESTOR THE SAVED WORD STA BUFA,I AND READ3 LDA KM16 A FULL SECTOR WAS READ. STA PCOUN PCOUN=-16 INDICATES 16 PAIRS ISZ REC STEP THE RECORD COUNT JMP READ,I SPC 1 EOF CLA SET EOF FLAG STA CREC,I AND GO JMP READ4 RETURN * FERR LDA K99 PASS FILE READ ERROR JMP F.ABT * BREAK LDA K96 GET BREAK ERROR JMP F.ABT AND GO ABORT * K96 DEC 96 XFLAG NOP MUST BE 0 INITIALLY. K99 DEC 99 OVER NOP MUST BE 0 INITIALLY. REC NOP PCOUN NOP KM2 DEC -2 K33 DEC 33 KM16 DEC -16 SAV BSS 1 * END F4.3 ASMB,Q,C HED FTN4X COMPILER (SEG: F4X.4) INITIALIZE THE COMPILER. NAM F4X.4,5 92834-16003 REV.2030 800613 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * ***************************************** * FORTRAN-4 COMPILER OVERLAY 4 ***************************************** * * THIS OVERLAY SETS UP THE SYMBOL TABLE AND ENTERS THE FIXED ENTRIES * IT ALSO INITFIALIZES THE COMPILER AND READS THE FTN STATEMENT IF * SETTING UP FOR THE FIRST MODULE IN THIS COMPILE. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.AT. SUBSCRIPT INFO FLAG EXT F.ABT ABORT COMPILE - FATAL ERROR. EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTION WORD EXT F.D DO TABLE POINTER EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DO LWAM - END OF DO TABLE EXT F.DP BASE OF USER SYMBOL TABLE EXT F.DTY IMPLICIT TYPE TABLE EXT F.E EQUIVALENCE TABLE POINTER EXT F.EQE EQUVALENCE ERROR FLAG EXT F.ER0 'RX' OF ERRX LIB ERROR ROUTINE EXT F.ERF ERROR FLAG (# OF ER.F CALLS) EXT F.ERN ERROR ARRAY EXT F.ERX ERROR EXIT ADDRESS. EXT F.FLN FIRST LINE # OF THIS MODULE. EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.LNA ADDRESS OF CURENT LINE EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LSP LAST OPERATION FLAG EXT F.NXN NO INPUT FLAG EXT F.OPT OPTIONS PART OF MAIN HEADER. EXT F.PAS PASS NUMBER. EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SEG LOAD A NEW SEGMENT EXT F.SID STATEMEXT ID PHASE FLAG  EXT F.STA FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ EXT F.TC NEXT CHARACTER EXT F.TIM TIME ARRAY ADDRESS IN HEAD EXT F.TL LENGTH OF TITLE. EXT F.TTL TITLE LINE. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT CDI.F CLEAR IDI ROUTINE EXT CTL.F COPY TITLE TO PASS FILE. EXT IC.F GET NEXT CHARACTER EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) EXT IN1.F INIT FOR PSL.F MODULE EXT IN3.F INIT FOR WS1.F MODULE. EXT IN4.F INIT FOR FA.F MODULE EXT IN6.F INIT FOR IC.F MODULE EXT MPN.F MOVE PROGRAM NAME (TO NAM RECORD ECT.) EXT NEW.F SUB TO CLEAR TEMPS FOR A NEW MODULE EXT NTI.F MOVE NID TO F.IDI (PACKS) EXT PSI.F PRINT SOURCE IMAGE. EXT SNC.F START NEXT CARD SUBROUTINE * * COMPILER LIBRARY ENTS * EXT SUP.C COMP LIB SUPER EXT C.BIN BINARY FCB EXT RWN.C REWIND ROUTINE EXT C.SAU INPUT FCB EXT OPN.C OPEN ROUTINE EXT EOF.C EOF WRITE ROUTINE EXT END.C END ROUTINE EXT C.LST LIST FCB EXT GMM.C GET MAIN MEMORY EXT PRM.C GET PRAMETER EXT C.SC0 SCR FILE FCB, CARD FILE & 2ND PASS FILE. EXT C.SC1 SCR FILE FCB, 1ST PASS FILE. EXT C.TTY TTY FCB EXT WRT.C WRITE TO FCB ROUTINE * * FTN UNIQUE SUB * EXT SEG.F GET SEGMENT ID SUB * * LIBRARY ROUTINES * * EXT .MVW MOVE WORDS MACRO EXT Z$INT 1/2 WORD INTEGER OPTION EXT Z$DBL 3/4 WORD DOUBLE PRECISION OPTION EXT Z$LPP DEFAULT # LINES PER PAGE * A EQU 0 B EQU 1 K4 DEC 4 SEGMENT NUMBER SUP SKP * ************************ * * START OF COMPILATION * * ************************ SPC 1 * CLEAR LINE DESCRIPTION. DECIDE TYPE OF CALL. * F4.4 CLA,INA SET PASS 1. STA F.PAS LDA DERR1 SET ERROR RECOVERY ADDR. STA F.ERX CLA MAKE SURE WAR.F DOESN'T STA F.LNA PRINT LIST LINE IF ERROR. STA F.CC LDB F.STA WHAT KIND OF CALL ? SSB JMP NEW NEW MODULE BUT NOT FIRST ONE. (B<0) SZB JMP TRM TERMINATION. (B>0) * * GET TIME, OPEN FILES. * DLD F.IDI RESTORE REGISTERS AND JSB SUP.C CALL. DEF F.TIM ADDRESS OF TIME ARRAY NOP CLA,INA SET TITLE TO BLANKS. STA F.TL LDA BLNKS STA F.TTL * LDA PRMPT OPEN INPUT FILE. (PROMPT=']') JSB OPN.C DEF C.SAU SOURCE FCB JMP INERR * JSB OPN.C OPEN THE LIST DEVICE DEF C.LST JMP TRML * CLB OPEN THE BINARY (B=0,RELOCATABLE) JSB OPN.C DEF C.BIN JMP BERR * BERX JSB OPN.C OPEN THE CARD FILE & 2ND PASS FILE. DEF C.SC0 JMP ERROR * JSB OPN.C OPEN THE 1ST PASS FILE. DEF C.SC1 JMP ERROR * SKP * REWIND THE PASS FILES. SET # LINES / PAGE. * NEW JSB RWN.C CARD FILE & 2ND PASS FILE. DEF C.SC0 JMP ERROR JSB RWN.C 1ST PASS FILE. DEF C.SC1 JMP ERROR JSB PRM.C 4TH PARAM IS LINES/PAGE. DEF K4 SZA,RSS IF NOT GIVEN, LDA Z.LPP USE DEFAULT. ADA KM3 - 4 EXTRAS, + 1 FOR WAY USED. STA NOLIN TENTATIVE. ADA KM7 WAS IT < 10 ? CLB SSA STB NOLIN YES, USE INFINITE SIZE PAGE. * * COMPUTE BASE ADDRESS OF SYMBOL TABLE = MAX(X+C,Y) WHERE: * WHERE X = END OF LARGEST SEGMENT WHICH USES THE CARD BUFFER, AND * Y = END OF LARGEST SEGMENT WHICH DOES NOT USE IT, AND * C = LENGTH OF THE CARD BUFFER. * THIS SEGMENT IS NOT INCLUDED IN THE ABOVE. * LDA DSEGS SEGMENT TABLE POINTER. STA DFSEG JSB GMM.C GET MAIN MEMORY BOUNDS DEF K2 TWO CARD-BUFFER SEGMENTS. DEF LSE.F NAME OF LOCAL SEG. NAME FINDER STB F.DO SET TOP OF SYMBOL TABLE (END MEM) STA F.CRB X = ADDRESS OF CARD BUFFER ADA K98 X+C STA F.DP * JSB GMM.C SAME FOR NON-CARD-BUFFER ONES. DEF K4 FOUR OF THEM DEF LSE.F * LDB F.DP (B)=X+C, (A)=Y CMB,INB -(X+C). ADB A (B) = Y-(X+C) SSB,RSS IF Y IS BIGGER, STA F.DP USE IT. F.DP = BASE OF SYMBOL TABLE. * * COMPUTE ADDRESS USER PART. CHECK IT. * CMA MAKE SURE THERE IS ROOM ADA F.DO IF NEGATIVE RESULT THEN NO ROOM FOR SSA TABLE SO QUIT ON SYMBOL TABLE OVERFLOW JMP ERR3 NO ROOM. SKP * SET UP FOR CARD BUFFER. * JSB GMM.C GET SIZE THIS SEGMENT AND DEF K1 DEF LSE.F ADA K98 FOR CARD BUFFER CMA ADA F.DO SSA IF NO ROOM JMP ERR3 ABORT * LDA F.DO SET UP ADDRESS OF CARD BUFFER. ADA KM98 STA F.CRB LOCATION CLB NOW CLEAR THE CARD BUFFER STB A,I PLANT A ZERO INB AND ADB A JSB .MVW WATCH IT GROW DEF K98 (IT SLOPS OVER BY ONE BUT NOP THERE'S AN EXTRA WORD ANYWAY.) LDA F.CRB NOW PLANT THE REQUIRED BLANKS ADA K2 FOR BETWEEN THE LINE NUMBER LDB BLNKS STB A,I ADA K49 DO FOR BOTH BUFFERS STB A,I * * INITIALIZATION FOR EACH MODULE. * JSB NEW.F MAIN DOES IT. DLD F.ERN+1 UPDATE CUMULATIVE ERROR TOTALS. ADA F.ERF ADB F.ERF+1 DS8uT F.ERN+1 CLA CLEAR COUNTERS FOR NEW MODULE. STA F.ERF STA F.ERF+1 LDA F.STA FIRST MODULE ? SZA JMP NOFTN NO. DONE HERE. JMP CME YES. GO SCAN 'FTN' CARD. SKP * SEGMENT NAME FETCHER. * LSE.F NOP ISZ LSE.F IGNORE PARAM. JSB SEG.F FORM THE SEGMENT NAME. DFSEG NOP PTR TO SEGMENT #. ISZ DFSEG BUMP TO NEXT. JMP LSE.F,I EXIT. * * SEGMENT NUMBERS. * DSEGS DEF *+1 DEC 0,1 THOSE WHICH USE CARD BUFFER. DEC 2,3,5,6 & THOSE WHICH DON'T. DEC 4 FINALLY, THIS SEGMENT. * * ERROR HANDLING FOR FILES. * ERROR LDA K99 ERROR ON PASS FILE WRITE IT JMP ABT IS AN ERROR 99 * INERR JSB OPN.C ERROR ON SOURCE FILE TRY LIST DEF C.LST JMP TRMSL IF PROBLEMS SKIP ON OUT LDA K98 INPUT FILE PROBLEMS JMP ABT * BERR CPA KM201 IF NO BINARY FILE JMP NOBIN GO SET IT UP LDA K97 OPEN ERROR ON BINARY FILE JMP ABT NOBIN CLA CLEAR THE STA BFLG BINARY FLAG JMP BERX CONTINUE THE SET UP SPC 4 K2 DEC 2 DERR1 DEF ERR1 ERROR RECOVERY ADDR. K3 DEC 3 K5 DEC 5 KM3 DEC -3 KM7 DEC -7 RSAVE NOP NOLIN NOP NUMBER OF LINES/PAGE K98 DEC 98 KM98 DEC -98 K49 DEC 49 SKP CME CLA,CCE INITIALIZE FLAGS. STA F.ERN (ZAP THE ERROR COUNTS.) STA F.ERN+1 STA F.ERN+2 JSB INIT * * READ "FTN/FTN4,B,L,A/M,T" * * * ********************* * * COMPILER ENTRANCE * * ********************* SPC 1 * WHERE IN WE BUILD THE OPTION CONTROL WORD FROM THE 'FTN' CONTROL * STATEMENT. * * THE FORMAT OF THE WORD IS (ONE BIT PER LETTER): * * 0 SIJ QXY EFD BCT AML * * S = USE .SMAP/.SRES INSTEAD OF .EMAP/.ERES . * *I = USE 16-BIT INTEGER (VS 32-BIT) * J = USE 32-BIT INTEGER (VS 16-BIT) * Q = LIST LOAD ADDRESS OF EACH STATEMENT. * X = USE 48 BIT DOUBLE PRECISION (VS 64-BIT) * Y = USE 64 BIT DOUBLE PRECISION (VS 48-BIT) * E = DUMP THE FIRST PASS FILE & SYMBOL TABLE TO LISTING. * F = DO FULL FORM FEEDS EVEN IF A TTY. * D = COMPILE LINES THAT START WITH 'D' (VS THEIR COMMENTS) * B = SET INTERNALLY IF BINARY OUTPUT FILE IS PRESENT * C = PRODUCE A CROSS REFERENCE * T = PRODUCE A SYMBOL TABLE LISTING * A = PRODUCE AN ASSEMBLY LISTING * M = PRODUCE A MIXED LISTING * L = PRODUCE A SOURCE LISTING SKP * START BY MAKING SURE THE CARD STARTS 'FTN'. * JSB IC.F FORCE A CARD READ IN CLA,INA SET TO GET FIRST STA F.CC CHAR CCA STA F.STA SET FTN STMNT. READ FLAG STA F.NXN SET NO INPUT FLAG. JSB IDN.F INPUT DO NOT ASSIGN JSB NTI.F MOVE NID TO F.IDI DLD F.IDI CPA "FT" 'FT' RSS JMP ERR1 FTN4 CONTROL CARD MISSING LDA B GET NEXT TWO CHAR. ALF,ALF TO LOW A AND B377 ISOLATE CPA "N" 'N' JMP CME06 JMP ERR1 FTN CONTROL CARD MISSING * * SCAN THE 'FTN' CARD AND SET UP OPTIONS. * CME05 JSB ICH.F NEXT CHARACTER. CME06 LDB F.TC C/R ? CPB B15 JMP PCONT YES. THAT'S ALL. CPB B54 ',' ? RSS JMP ERR1 NO. ERROR IN FTN CARD JSB ICH.F INPUT CHARACTER JSB CCO.F CONVERT CONTROL OPTION. SZA,RSS FOUND ? JMP CME10 NO. IOR NLTEM YES. SET THE OPTION(S) STA NLTEM AND B30K I & J OPTIONS. CPA B30K BOTH SET NOW ? JMP ERR1 YES, ERROR. LDA NLTEM AND B3000 X & Y OPTIONS. CPA B3000 BOTH SET NOW ? JMP ERR1 YES, ERROR. LDA B a THE OPTION BY ITSELF. IOR DUPS REPEATED ? CPA DUPS JMP ERR1 YES, ERROR. STA DUPS JMP CME05 GO FOR MORE. SKP * LAST RESORT, CHECK FOR DIGIT (ERR0). * CME10 LDB OPTSE NOT IN TABLE. CHECK FOR DIGIT. ADB BM61 SW.N SSB JMP ERR1 < '0' ADB KM9. SSB,RSS JMP ERR1 > '9' ADB ERR0 DIGIT; BUILD ERR ROUTINE NAME STB F.ER0 CLB ONLY ALLOW ONCE. STB SW.N JMP CME05 AGAIN. * * END OF CONTROL STATEMENT. SET CONTROL WORD. * PCONT CLA END OF CTRL STMT. STA F.NXN LDA NLTEM X OR Y SELECTED ? AND B3000 SZA JMP PCON1 YES. LDA B1000 NO. ASSUME Y. LDB Z.DBL X DEFAULT ? CPB K3 RAL YES. THEN X. PCON1 STA NEWOP LDA NLTEM I OR J SELECTED ? AND B30K SZA JMP PCON2 YES. LDA B20K NO. ASSUME I. LDB Z.INT J DEFAULT ? CPB K2 RAR YES. SET J. PCON2 IOR NEWOP COMBINE I J WITH X Y. STA NEWOP IOR NLTEM SET THE STA F.CCW CONTROL WORD SKP * IF OPTIONS ON 'RU,FTN', USE THEM. * JSB PRM.C GET THE OPTIONAL CONTROL PRAMS DEF K5 STB AD SET THE PARAMETER ADDRESS LDA KM6 SET COUNTER FOR NO. OF PRAMS STA COUNT CLOP LDB AD START LOOP CLE,ERB CONVERT TO A WORD ADDRESS LDA B,I GET THE WORD SEZ,RSS ROTATE IF ALF,ALF NEEDED AND B377 ISOLATE THE WORD SZA,RSS ANY ZERO'S INVALIDATE THE WHOLE THING JMP OPTNS SO BAIL OUT * JSB CCO.F CONVERT CONTROL OPTION. AND KK01 DISALLOW I,J,X,Y. IOR NEWOP STA NEWOP SET DOWN THE NEW WORD ISZ AD STEP THE ADDRESS ISZ COUNT AND THE COUNT M JMP CLOP DO THE NEXT CHAR. STA F.CCW IF WE GET HERE THEN SET THE NEW CONTROL WORD SKP * CONSTRUCT THE OPTIONS PART OF MAIN HEADER. * OPTNS LDA BLNKS SET THE FIRST WORD TO BLANKS, STA F.OPT LDA DFOPT AND USE .MVW TO PROPOGATE IT. RAL,CLE,SLA,ERA REMOVE EXACTLY ONE INDIRECT. LDA A,I RAL SET UP THE BYTE ADDR IN HEADER. STA T1OPT RAR RESTORE WORD ADDR FOR .MVW LDB A (A) = ADDR FIRST, (B) = ADDR 2ND. INB JSB .MVW DEF K5 6 WORDS ALTOGETHER. NOP LDA F.CCW SET UP COPY OF OPTIONS. STA T2OPT LDA DLOPT AND POINTER INTO (LISTING) OPTS TABLE. STA T3OPT LDA F.ER0 WAS THERE AN 'ERR0' DIGIT ? AND B377 SZA IF NOT PRESENT, CPA B60 OR '0', JMP OPT01 THEN IGNORE. * LDB A ELSE PRINT IT FIRST. JMP OPT02 * * CHECK THE NEXT OPTION (SET); GET LIST CHAR. * OPT01 ISZ T3OPT ADVANCE TO THE NEXT OPTION. ISZ T3OPT DLD T3OPT,I SEE IF CURRENT OPTION(S) ON. SZA,RSS FIRST, ARE WE DONE ? JMP NIXOP YES. QUIT. * AND T2OPT NO. HERE ARE OPTIONS IN QUESTION. CPA T3OPT,I ARE ALL SPECIFIED ONES SET ? RSS YES. JMP OPT01 NO. SKIP THIS ONE. * XOR T2OPT YES. REMOVE THOSE BITS. STA T2OPT * * INSERT (B) IN THE LISTING. * OPT02 ADB BM40 CORRECT FOR EXISTING BLANK. LDA T1OPT SET UP TO STORE. CLE,ERA (A) = ADDR, (E) = BYTE. SEZ,RSS IF UPPER BYTE, BLF,BLF MOVE THE DATA UP THERE. ADB A,I INSERT THE CHARACTER. STB A,I REPLACE WORD. ISZ T1OPT ADVANCE BYTE ADDRESS. JMP OPT01 GO TRY FOR ANOTHER. SKP DFOPT DEF F.OPT MAY HAVE INDIRECT ! T1OPT NOP BYTE ADDRE6SS OF OPTIONS IN HEADER. T2OPT NOP REMAINING OPTIONS FROM OPTION WORD. T3OPT NOP POINTER WITHIN OPTIONS PRINTING TABLE. BM400 OCT 177400 BM40 OCT -40 B60 OCT 60 * DLOPT DEF *-1 LIST OPTIONS TABLE. (-2) OCT 04001,121 Q,L = Q K1 OCT 00001,114 L OCT 00016,115 M,A,T = M B14 OCT 00014,101 A,T = A B10 OCT 00010,124 T OCT 00020,103 C OCT 00200,106 F OCT 00100,104 D B1000 OCT 01000,131 Y OCT 02000,130 X B10K OCT 10000,112 J B20K OCT 20000,111 I OCT 40000,123 S OCT 0 SKP * * DISMISS FTN STMT. SET UP BINARY FLAG. * NIXOP LDA DNIX SET F.EQE TO POINT TO HERE INCASE STA F.EQE OF ERROR 90 (FIRST STMT. IS A CONTINUE) CLA,CLE CLEAR E FOR IN6.F (NOT A NEW MODULE) STA F.FLN SET FLAG SO FIRST LINE # PICKED UP. JSB INIT SET UP TO CHECK FOR CONTINUED LINES JSB CTL.F PRESERVE TITLE FOR PASS 2. NIX01 JSB SNC.F DISMISS THE FTN STATEMENT CLA CLEAR THE ERROR SWITCH STA F.EQE SO OTHER ERRORS DO STD. THING LDA F.CCW MODIFY THE CONTROL WORD IOR B40 ALWAYS DO BINARY LDB BFLG UNLESS SZB,RSS NO XOR B40 FILE GIVEN FOR OUTPUT STA F.CCW SET THE FLAG WORD JMP PPNM * DNIX DEF NIX01 SKP * CONVERT CONTROL OPTIONS SUBROUTINE. * INPUT: (A) = OPTION LETTER. * OUTPUT:(A) = CORRESPONDING BIT(S). NONE-->0. * CCO.F NOP CONVERT CONTROL OPTIONS. STA OPTSE USE ORIGINAL VALUE TO END TABLE. LDB DOPTS SET UP POINTER. STB T1CME CLB,INB START WITH L=1. CCO01 CPA T1CME,I THIS ONE ? JMP CCO02 YUP. * RBL NO. TRY NEXT. ISZ T1CME JMP CCO01 * CCO02 LDA B SAVE ACTUAL OPTION. CPB K2 M ? IOR B14 YES, SET A & T. CPB K4 A ? IOR B10 YES, SET T. CPB B4000 Q ? IOR K1 YES, SET L. CPB OPTSX NOT FOUND ? CLA IF SO, RETURN A=0. JMP CCO.F,I EXIT. A=OPTIONS, B=SINGLE OPTION. * * OPTIONS TABLE. JUST THE CHARACTERS. * DOPTS DEF *+1 OPTIONS TABLE. OCT 114 L = 1 OCT 115 M = 2 OCT 101 A = 4 OCT 124 T = 10 OCT 103 C = 20 "B" OCT 102 B = 40 OCT 104 D = 100 OCT 106 F = 200 OCT 105 E = 400 OCT 131 Y = 1000 OCT 130 X = 2000 OCT 121 Q = 4000 OCT 112 J =10000 OCT 111 I =20000 OCT 123 S =40000 OPTSE BSS 1 MISSING = 100000 OPTSX OCT 100000 SKP PRMPT ASC 1,]_ PROMPT WITH ']' NLTEM NOP T1CME NOP TEMP FOR CME & CCO. DUPS NOP FOR CATCHING DUPLICATES. BM61 OCT -61 KM9. DEC -9 "N" OCT 116 'N' "FT" ASC 1,FT ERR0 OCT 51072 ASC 1,R0 +10 Z.INT DEF Z$INT+0 1/2 WORD INTEGER DEFAULT. Z.DBL DEF Z$DBL+0 3/4 WORD DOUBLE PRECISION DEFAULT. Z.LPP DEF Z$LPP+0 DEFAULT # LINES PER PAGE. KM6 DEC -6 AD NOP COUNT NOP B377 OCT 377 NEWOP NOP B15 OCT 15 B54 OCT 54 ',' K99 DEC 99 K67 DEC 67 KM201 DEC -201 B40 OCT 40 B3000 OCT 3000 B4000 OCT 4000 B30K OCT 30000 KK01 OCT 144777 TO ZAP I,J,X,Y. BFLG OCT 40 BINARY FLAG (SET FOR BINARY) K97 DEC 97 DMAN DEF NOFT2 ERROR RETURN ON INPUT ERROR SKP * *************************** * * INITIALIZE VARIOUS SUBS * * *************************** SPC 1 * INPUT: E=1 IFF FIRST MODULE. SPC 1 INIT NOP CALL ALL THE INIT SUBS IN THE MAIN LDA NOLIN PASS THE LINE COUNT JSB IN1.F TO PSL.F ('E' PRESERVED) CLA ( A=0 FOR IN6.F LDB F.CRB PASS THE CARD BUFFER ADDRESS JSB IN6.F TO IC.F JSB IN3.F WS1.F JSB IN4.F FA.F JMP INIT,I RETURN * "D" OCT 104 "E" OCT 105 SPC 2 * ******************** * * CHECK FOR 'END$' * * ******************** SPC 1 NOFTN CLA,CLE STA F.FLN SET FLAG SO FIRST STMT # PICKED UP. JSB INIT CALL INIT SUBS LDA MFLC MOVE "FTN. " JSB MPN.F TO NBUF,ERBF,HEADL LDA DMAN SET UP ERROR RETURN STA F.EQE FOR POSSIBLE INPUT ERROR JSB CTL.F PRESERVE TITLE FOR PASS 2. NOFT2 JSB SNC.F TEST FOR END$ CARD CLA,INA STA F.CC SET CC=1 STA F.NXN SET NO INPUT FLAG JSB ICH.F CHECK FOR 'END$'. CPA "E" 'E' ? RSS YES JMP NOFT1 NO JSB ICH.F CPA "N" 'N' ? RSS YES JMP NOFT1 NO JSB ICH.F CPA "D" 'D' ? RSS YES JMP NOFT1 NO JSB ICH.F CPA "$" '$' JMP TRM YES, 'END$', WRAP IT UP. * NOFT1 CLA STA F.EQE CLEAR THE ERROR RETURN FLAG STA F.NXN RESET NO INPUT FLAG INA STA F.CC SET CC=1 STA F.SID AND THE SCAN FLAG SKP * ************************** * * REST OF INITIALIZATION * * ************************** * * SET UP: NAM, IMPLICIT TYPES, PROG NAME, TEMPS. * PPNM LDB F.DNB GET ADDRESS OF NAM RECORD BUFFER LDA PRNM GET ADDRESS OF PROTO NAM RECORD JSB .MVW MOVE PROTO TO BUFFER DEF K17. 17 WORDS NOP * LDA F.CCW 'J' OPTION ? AND B10K SZA,RSS JMP PPNM1 NO. LDA JTYP YES. MODIFY THE IMPLICIT TYPE TABLE. STA DINTY STA DINTY+1 STA DINTY+2 * PPNM1 LDA DTYP SET UP THE IMPLICIT TYPE ۑLDB F.DTY TABLE JSB .MVW IN F.IDN DEF K13 IT IS 13 WORDS LONG NOP * LDA MFLC GET THE DEFAULT NAME JSB MPN.F AND REINSERT IT IN THE NAM BUFFER SKP * ZERO OUT SOME STUFF IN MAIN. ALSO F.IDI . * LDB INITB CLEAR RBL,CLE,SLB,ERB LDB B,I CLA STA B,I LDA F.AT.-1 GET SIZE OF AREA STA RSAVE SAVE IT STB A INB JSB .MVW CLEAR THE AREA DEF RSAVE NOP JSB CDI.F SET F.IDI TO 0. * * SET UP STACKS. (& A COUPLE OF FLAGS). * LDA F.DP DATA POOL START LOCATION INA STA F.LO END OF ASSI TABLE LOC. +1 STA F.S2B STA F.S2T F.S2T=F.S2B=LO STA F.LSF F.LSF NON-0 (EXPECT 1ST STATEMNT) STA F.LSP LDA F.DO LAST AVAILABLE MEMORY LOCATION STA F.E STA F.D STA F.S1B STA F.S1T F.S1T=F.S1B=D * * JUST A LITTLE MORE CLEANUP, THEN LOAD 4.0 . * LDA F.CRB TELL F4.0 WHERE TO MOVE CARD BUFFER: STA F.IDI FROM, LDA F.DP ADA KM98 AND TO. STA F.IDI+1 CLA,INA RESET STA F.CC THE COLUMN COUNTER CLB STB F.NXN CLEAR THE NO INPUT FLAG JMP F.SEG GO TO SEGMENT 0. SKP MFLC DEF KK32 KK32 ASC 3,FTN. DEFAULT OBJ PROG NAME INITB DEF F.AT. INIT. TO 0 AREA BEGIN ADDR. * PRNM DEF *+1 PROTO NAM RECORD K17. DEC 17,0,0,0,0,0,0,0,0,4,99,0,0,0,0,0,0 K13 DEC 13 DTYP DEF *+1 BLNKS ASC 4, BLANKS HAPPEN TO BE REAL (A-H) DINTY OCT 10020,10020,10020 THESE ARE INTEGER (I-N) ASC 6, MORE REALS (M-Z) JTYP OCT 100200 TWO BYTES OF TYPE (DBI). K15 DEC 15 K21 DEC 21 K26 DEC 26 F.CRB NOP CARD BUFFER ADDRESS "$" OCT 44 SKP * TERMINATE COMPILE. (ERROR OOR END SOURCE) * FIRST, ERRORS. * ERR1 JSB PSI.F PRINT THE CONTROL LINE. CLA,INA,RSS ERR 1: ERROR IN 'FTN' DIRECTIVE. * ERR3 LDA K3 3: SYMBOL TABLE DOESN'T FIT. ABT JMP F.ABT SEND ERROR MSG; RETURNS TO 'TRM'. * * CLOSE BINARY FILE (IF ANY) * TRM LDA F.CCW CHECK IF BINARY FILE AND B40 IF SO SZA,RSS THEN JMP NXBIN JSB EOF.C MUST EOF ON IT DEF C.BIN RSS ERROR REPORT IT JMP NXBIN ELSE GO ON. CLA CLEAR BIN FLAG SO DON'T RE-REPORT. STA F.CCW LDB F.ERN ALREADY REPORTED IT ? LDA K97 SZB,RSS JMP ABT NO, DO SO NOW. * * SET UP THE ERROR COUNTS. * NXBIN DLD F.ERN+1 ACCUMULATE THE ERROR TOTALS ADA F.ERF ADB F.ERF+1 STA ERMX SET THE NUMBER OF ERRORS STB TOTER AND THE TOTAL ERROR COUNT LDA F.ERN DISASTER COUNT. STA DISCT PUT COUNT IN MATRIX ADA ERMX SUBTRACT CMA,INA THE ERRORS FROM THE TOTAL COUNT ADA B TO GET THE WARNINGS STA WAR SET THE # OF WARNINGS * * END THE LIST FILE. * JSB EOF.C DEF C.LST RSS IF ERROR REPORT IT JMP TRM1 ELSE GO ON. LDA K15 REPORT TO TTY. JMP EOFER SKP * WRITE END MESSAGE WITH ERROR TOTALS. * TRM1 CLA CLEAR CLB THE ERROR COUNTERS DST F.ERN+1 FOR POSSIBLE RE RUN STA F.STA ALSO THE BEEN HERE FLAG * LDA DISCT GET THE DISASTER COUNT CLE SUPPRESS LEADING ZEROES. JSB ASC.F CONVERT IT CPA BLNKS IF NONE LDA "NO" USE NO RRL 8 STB ENMES+6 SET IN THE MESSAGE. STA ENMES+7 * LDA ERMX GET THE ERROR COUNT CLE,SZA,RSS IF NONE (E=0, SUPPRESS JMP EXIT2 SKIP LEADING ZEROES) JSB ASC.F ELSE CONVERT IT STB ENMES+13 SET STA ENMES+14 IN THE MESSAGE * EXIT2 LDA WAR GET THE WARNNING COUNT CLE,SZA,RSS IF NONE (E=0, SUPPRESS JMP EXIT3 SKIP LEADING ZEROES) JSB ASC.F CONVERT IT STA ENMES+20 STB ENMES+19 * EXIT3 LDA SINGL CHANGE TO SINGULAR, CLB,INB IF ANY = 1. CPB DISCT STA ENMES+12 CPB ERMX STA ENMES+18 LDA SING. CPB WAR STA ENMES+25 * JSB WRT.C SEND THE NEWS DEF C.TTY TO THE TTY DEF ENMES DEF K26 NOP IGNOR ERRORS EXIT JSB END.C END IT ALL DEF TOTER SEND THE ERROR MATRIC JMP EXIT TRY AGAIN IF CLOSE ERROR * TOTER NOP ERROR MATRIX. KEEP DISCT NOP THESE ERMX NOP LINES WAR NOP IN DEC 2030 DATE CODE SEQUENCE. * ERMES ASC 21,/FTN4X: ACCESS FAILED ON LIST AND SOURCE. ENMES ASC 26,$END FTN4X: NO DISASTERS, NO ERRORS, NO WARNINGS. "NO" ASC 1,NO "00" ASC 1,00 SINGL ASC 1,, SINGULAR ENDING. SING. ASC 1,. WITH DOT INSTEAD OF COMMA. T1TRM NOP SKP * CAN'T USE LIST FILE. WRITE TO TTY. * TRML LDA K15 GET COUNT FOR MESSAGE RSS SKIP DOUBLE FAILURE TRMSL LDA K21 BOTH SOURCE AND LIST FAILED TO OPEN CLB CLEAR THE STB ERMX ERROR STB WAR AND WARNING COUNTS STB TOTER EOFER STA T1TRM SET FOR CALL JSB WRT.C SEND TO THE TTY DEF C.TTY DEF ERMES DEF T1TRM NOP IGNOR ERRORS (WHAT ELSE CAN WE DO HERE?) LDA T1TRM GET THE ERROR COUNT CPA K15 SET UP THE ERROR COUNTS CLB,INB,RSS ONE ERROR LDB K2 TWO ERRORS STB DISCT SET THE DISASTOR COUNT ADB TOTER SET THE COUNTS STB TOTER JMP TRM1 NOW GO DO THE EXIT SPC 2 END F4.4 ASMB,Q,C HED FTN4X COMPILER (F4X.5:PASS 3) NAM F4X.5,5 92834-16003 REV.2030 800731 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 5 *************************************** * * THIS OVERLAY TRANSLATES THE PSEUDOCODE GENERATED BY PASS 2 INTO * RELOCATABLE BINARY, AND GENERATES THE ASSEMBLY LISTING. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.CCW FTN OPTION WORD EXT F.CSZ COMMON SIZE EXT F.D.T ADDRESS OF '.' FUN. TABLE EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.EM EMA BIT IN A.T. EXT F.EMA F.A OF THE EMA MASTER.F EXT F.EMS EMA SIZE, DOUBLE WORD. EXT F.ER0 ERR0 NAME CHANGE OPTION. EXT F.ERF ERROR FLAG (# OF ER.F CALLS) EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.IU ITEM USAGE. EXT F.MSG MSEG SIZE ON $EMA(...) EXT F.REL SUB. PROG. RETURN LOCATION EXT F.RPL PROGRAM LOCATION COUNTER EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SEG LOAD A NEW SEGMENT EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.UFM F.A OF TWPE ENTRY FOR .UFMP EXT F.#M MAX # NON-DISC CONNECTIONS. EXT F.#N MAX # DISC CONNECTIONS. EXT F.#S BUFFER MULTIPLE & DS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT EJP.F PAGE EJECT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT MPN.F MOVE PROGRAM NAME (TO NAM RECORD ECT.) EXT MVW.F MOVE WORDS. EXT NAM.F COPY SYMBOL NAME. EXT PSL.F PRINT LINE ON PRINTER EXT SKL.F SKIP LINES ON LIST EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) * * LIBRARY UTILITIES * EXT .MVW MOVE WORDS MACRO EXT IFBRK BREAK CHECK ROUTINE * * OPSYSTEM INTERFACE: * EXT RED.C READ FILE ROUTINE EXT WRT.C WRITE FILE ROUTINE EXT RWN.C REWIND FILE ROUTINE EXT C.SC0 SCRATCH FILE FCB EXT C.BIN BINARY FILE FCB * * EXTERNAL IN THIS SEGMENT. * EXT END.F END PROCESSOR. * A EQU 0 B EQU 1 SUP SPC 1 K5 DEC 5 OVERLAY # SKP * ENTRY. * F4.5 JSB END.F END PROCESSING. CLA SHOULDN'T NEED ERROR RECOVERY ADDR, STA F.ERX BUT ZAP IT JUST IN CASE. LDA F.CCW SET UP LOCAL FLAGS AND B40 ISOLATE THE BINARY FLAG STA BFLG SAVE IT LDA F.ER0 IF AN ERR0 OPTION, SZA STA ERR0 CHANGE THE NAME TO 'ERRX' LDA F.CCW NOW PUT RAR,RAR M BIT IN LOW PART OF STA CCW LOCAL WORD CLA NEWBL STA COMCO SET COUT OF CURRENT BLOCK COMMON MODULE CCA SET TO NOT IGNOR STA IGNOR ANY THING CLA SET CURRENT ADDR IN CASE NULL PROG, STA ASA FOR END PROCESSING. JSB RWN.C REWIND 2ND PASS FILE DEF C.SC0 JMP ERROR ERROR ON PASS FILE ACCESS SPC 1 LDA F.SFF BLOCK DATA ? CPA K2 JMP FBL03 YES. START IT. JMP OTNAM NO. GO SEND THE NAME RECORD * NTATI OCT 007601 IGNOR NOP COMCO NOP T1FBL NOP COMMS NOP CURRENT MASTER ADDRESS K9 DEC 9 FBCFA DEF *+2 F.A OF FAKE BLANK COMMON HEADER. DEC 0 LINK: THIS IS LAST ITEM. B7200 OCT 7200 AT=BCOMI, IU=SUB, NT=0. OCT 0 LENGTH = 0. " OF SIZE. SZB M IF SIZE >= 8095 PAGES, CCA SET IT TO 8095. CLE,ERA (A) = # PAGES * 4. ARS,ARS # PAGES. IOR EMTYP ADD THE EMA TYPE BITS STA WBUF+1 SET IN WORD TWO OF THE RECORD LDA K7 7 WORD RECORD JSB .WRIT WRITE IT JSB SET SET UP TO CONTINUE THE EXT'S JMP FINAL GO PRINT SUMMARY, THEN DO DBL'S. * EMTYP OCT 140000 SKP * ****************************************** * * SHORTEN 6 CHAR. EXT NAMES TO 5 CHARS & * * * CHECK FOR DUPLICATE NAMES. * * ****************************************** SPC 1 * ENTRY: (A) = ADDR 5TH,6TH CHARS. * (T1EX) = F.A OF SYMBOL, OR -1:NAM OR -2:DOT FCT. * (T2EX) = (NEGATIVE) EXT ID IF NORMAL OR DOT FCT. * EXIT: SHORTENED IF 6 CHARS (WITH WARNING) * WARNING IF ANY DUPLICATES FOUND. * EXLNC NOP STA EXTM SAVE ADDRESS OF NAME LDB A,I GET LAST TWO CHARS. STB ERM5 SAVE LAST TWO CHAR IN MESSAGE BUF STB ERM6 SAVE LAST TWO CHAR IN MESSAGE BUF ADA KM2 COPY FIRST FOUR. DLD A,I FIRST FOUR. DST ERM1 SAVE IN BOTH PARTS. DST ERM2 LDA EXTM,I GET LAST CHAR AND B377 ISOLATE THE LAST CHAR CPA B40 IF BLANK JMP EXLNX NAME IS OK * ALF,ALF ELSE SHORTEN IT BY IOR B40 REMOVING THE 5TH CHARACTER. STA ERM6 STA EXTM,I ALSO IN RECORD. LDA ER68 AND JSB WAR.F SEND THE WARNING. LDA K14 AND THE MESSAGE LDB DERM LENGTH AND ADDRESS TO A,B JSB PSL.F PRINT IT EXLNX JSB GFA.F START SCAN FOR DUPLICATE. * EX01 JSB GNA.F GET THE NEXT ASSIGN ENTRY SZA,RSS JMP EXLNC,I END ALL OK OR REPORTED * LDA F.A,I GET THE TAG WORD AND B7600 F.AT & F.IU . CPA B2200 EXTERNAL SUBROUTINE ? RSS h YES SKIP CPA B7200 OR COMMON LABEL ? RSS JMP EX01 NO TRY NEXT ENTRY * LDA F.A MUST HAVE AN INA ORDINAL (NEGATIVE) LDA A,I SSA,RSS INTRINSIC OR NOT USED ? JMP EX01 YES, PASS IT BY. * LDB F.A GET ADDRESS CPB T1EX IF SAME ADDRESS THEN JMP EX01 IT IS THE SAME SYMBOL OK * JSB NAM.F ELSE COPY THE SYMBOL. DEF ERM1 (LEAVE SHORTENED ONE ALONE) LDA ERM1 CHECK FIRST TWO. CPA ERM2 RSS JMP EX01 NO, TRY NEXT ONE. LDA ERM3 CHECK 3RD & 4TH. CPA ERM4 RSS JMP EX01 NO. LDA ERM5 IF 6TH NOT BLANK DELETE 5TH. AND B377 6TH CHAR. LDB A (SAVE IN B) LDA ERM5 5TH & 6TH CHARS. CPB B40 IF 6TH NONBLANK, RSS (BLANK. LEAVE IT) ALF,ALF MOVE 6TH CHAR TO 5TH POSITION, AND BM400 AND CHANGE 6TH POSITION TO BLANK. IOR B40 CPA ERM6 HOW ABOUT 5TH CHAR ? RSS JMP EX01 NOPE. IS O.K. * LDA T1EX CHECK IF NAM OR DOT FCT. SSA,INA IF SO ALWAYS JMP EX08 REPORT * LDA A,I IF ORDINALS LDB F.A ARE INB CPA B,I THE SAME JMP EX01 WE ALREADY REPORTED THIS ONE * EX08 LDA K91 WARNING 91. LDB T1EX UNLESS: INB,SZB,RSS PROGRAM NAME: 85, LDA K85 INB,SZB,RSS OR DOT FUNCTION: 92. LDA K92 JSB WAR.F SEND THE MESSAGE (CAN'T USE ER.F) LDA K3 LDB DERM2 SEND THE NAME JSB PSL.F TO THE LIST DEVICE TOO * LDA T1EX IF IN NAM BUFFER INA,SZA,RSS THEN JMP EX01 DO NOT CHANGE * LDA T2EX ELSE USE CALLER'S SYMBOL LDB F.A TO REPLACE INB THE CURRENT SYMBOLS STA B,I JMP EX01 TRY NEXT SYMBOL M SKP * SOME MISCELLANEOUS SUBROUTINES. * CLOSE NOP FINISH & OUTPUT EXT RECORD. CCE LDA WORD RAL,ERA STA WBP1,I "EXT" RECORD DESIGNATOR CLE,ELA ADA WORD NO. OF SYMBOLS *3 ADA B3 JSB .WRIT JSB SET RE-INITIALIZE JMP CLOSE,I SPC 2 SET NOP LDA WBP2 'DEF WBUF+2' STA WLOC CLA SET WORD STA WORD JMP SET,I SKP * ******************************* * * CONVERT TO 5 DECIMAL DIGITS * * ******************************* * * CALLING SEQ: LDA * JSB AS5.F * DEF * * THE BUFFER WILL GET 5 DIGITS (LEADING ZERO SUPPRESS) & A BLANK. * AS5.F NOP LDB AS5.F GET, RESOLVE ADDR. ISZ AS5.F LDB B,I RBL,CLE,SLB,ERB JMP *-2 STB T1AS6 & SAVE. * SZA,RSS VALUE = 0 ? JMP AS601 YES. CHANGE TO '(NONE)'. * CLB,CLE START WITH FIRST 4 DIGITS. DIV K10 DIVIDE BY 10. (E=0 FOR LEADING STB T2AS6 SAVE LAST DIGIT. ZERO SUPPRESS) JSB ASC.F (E) HAS BEEN SET UP BY NOW. SWP INSERT IN BUFFER. DST T1AS6,I T1AS6 EQU *-1 ISZ T1AS6 ADVANCE TO THIRD WORD. ISZ T1AS6 LDA T2AS6 INSERT DIGIT,BLANK THERE. ALF,ALF ADA "0_" STA T1AS6,I JMP AS5.F,I DONE. * AS601 LDA DNONE ZERO, USE '(NONE)' LDB T1AS6 JSB .MVW DEF K3 NOP JMP AS5.F,I EXIT. * DNONE DEF NONE NONE ASC 3,(NONE) T2AS6 NOP LOWEST DIGIT. SKP DERM DEF *+1 ASC 1, ERM1 ASC 1, ERM3 ASC 1, ERM5 ASC 1, ASC 7, SHORTENED TO ERM2 ASC 1, ERM4 ASC 1, ERM6 ASC 1, K14 DEC 14 DERM2 DEF ERM2 KM3 DEC -3 KM4 DEC -4 KM2 DEC -2 EXTM NOP ER68 DEC 68 KM5 DEC -5 K7 DEC 7 K1 DEC 1 B1ɜ00 OCT 100 B600 OCT 600 BM400 OCT 177400 B2200 OCT 2200 F.AT=STRAB, F.IU=SUB: EXT SUB. ARR EQU B600 KK20 OCT 20000 KK774 OCT 177400 BLNKS ASC 2, EXORD NOP CTR1 NOP COUNTER FOR .TBL TABLE CTR2 NOP COUNTER FOR EXT ENTRY PTEXT NOP EXT POINTER CWA NOP CURRENT WORD ADDR. IN TABLES TEMP4 NOP MARKS WHEN SOURCE REC SPLIT NREC NOP ADDR OF NEXT RECORD IN RBUF RCYC NOP PHASE OF READ INDICATOR CYCLE RIIND NOP DATA INDICATOR FOR READ RSIND NOP DATA INDICATOR STRING FOR READ WBP1 DEF WBUF+1 WBP2 DEF WBUF+2 WBP3 DEF WBUF+3 WBP5 DEF WBUF+5 WBP59 DEF WBUF+59 * "0_" ASC 1,0 SINGL EQU BLNKS * EWMSG ASC 02, ** NWAR ASC 08, NO WARNINGS ** NERR ASC 07, NO ERRORS ** ASC 06, PROGRAM: PRSIZ ASC 03,(NONE) ASC 07, COMMON: CMSIZ ASC 03,(NONE) ENDK4 DEF EWMSG SKP * PRINT SUMMARY INFO. * FINAL CLA SKIP JSB SKL.F LINE ON THE LIST LDA F.RPL OUTPUT PROGRAM SIZE IN DECIMAL. JSB AS5.F DEF PRSIZ GETCW LDA F.CSZ OUTPUT COMMON SIZE IN DECIMAL. JSB AS5.F DEF CMSIZ LDA F.ERF # OF ERRORS CLE,SZA,RSS E=0, SUPPRESS LEADING ZEROES. JMP ENDP7 NONE. * LDB SINGL IF EXACTLY ONE ERROR, CPA K1 STB NERR+5 CHANGE ENDING TO SINGULAR. JSB ASC.F MAKE ASCII, STORE IN ERBUF STB NERR STA NERR+1 ENDP7 DLD F.ERF ANY WARNINGS?? CMA,INA ALL ERRORS ARE ALSO LOGED AS WARNINGS ADA B SO BACK THEM OUT CLE,SZA,RSS WELL?? (E=0, SUPPRESS LEADING ZEROES) JMP END10 NO SKIP CONVERSION * LDB SINGL IF EXACTLY ONE WARNING, CPA K1 STB NWAR+6 CHANGE ENDING TO SINGULAR. JSB ASC.F YES CONVERT WARNNING NUMBER STB NWAR SET IN MESSAGE STA NWAR+1 END10 LDB COMCO BLOCK DATA & NOT FIRST BLOCK, ~K SZB THEN JMP END11 DON'T PRINT IT AT ALL * LDA K36 LDB ENDK4 JSB PSL.F PRINT SIZES & NO. OF ERRORS END11 LDA CCW SET CONTROL STMT. DATA SLA IF LISTING BINARY JSB EJP.F EJECT PAGE SKP * ********************************** * * PROCESS DBL RECORDS * * ********************************** SPC 1 JSB TERM INIT DBL RECORD OUTPUT LDB DLBUF SET SLBUF LDA CCW SLA,RSS IF NOT LISTING ADB B3 NO, ALTER SLBUF TO PUT ASSY STB SLBUF CODE AT LEFT MARGIN. CLB STB TEMP4 SPC 2 * * READ INTERMEDIATE CODE * SPC 1 READ JSB IFBRK CHECK FOR BREAK DEF *+1 SSA WELL? JMP BREAK YES GO HANG IT UP JSB RED.C READ A RECORD FROM THE DEF C.SC0 2ND PASS FILE. DRBUF DEF RBUF BUFFER DEF B100 64 WORDS JMP ERROR READ ERROR GO REPORT AND EXIT * SSB IF EOF JMP END. GO SEND THE END RECORD * LDA DRBUF 'DEF RBUF' STA RLOC LDA RLOC,I EXAMINE FIRST WORD OF RECORD SZA,RSS SECTOR END? JMP READ YES, READ ANOTHER * SSA SOURCE OR XREF?? JMP SOURC YES GO HANDLE * STA CO SAVE COUNT ADA RLOC STA NREC BUFFER POSN OF NEXT RECORD JMP DPREP NO; GO TO DATA PREP ROUTN SPC 1 SOURC CPA KM2 IF XREF RECORD JMP READ IGNOR IT * RAL,CLE,ERA ELSE REMOVE THE FLAG BIT STA DRBUF,I AND RESTORE THE WORD LDA B RECORD SIZE TO A LDB DRBUF ADDRESS TO B JSB PSL.F WRITE IT JMP READ AND GO READ THE NEXT RECORD * CCW NOP CO NOP * B40 DEC 32 T2PUT NOP B3 DEC 3 K97 DEC 97 * ERROR LDA K99 READ ERROR ON PASS FILE JMP F.ABT ABORT COMPILE * BR EAK LDA K96 SET BREAK ERROR JMP F.ABT AND ABORT THE COMPILE * K96 DEC 96 K99 DEC 99 WERR LDA K97 WRITE ERROR ON BINARY FILE JMP F.ABT ABORT * B7000 OCT 7000 BCOMI EQU B7000 B7600 OCT 7600 MASK OVER F.AT, F.IU B1200 OCT 1200 F.AT=REL, F.IU=SUB = STMT FCT. DUM OCT 5000 REL OCT 1000 SUB OCT 200 KK01 DEF 0,I K36 DEC 36 TRANS NOP R4ORG OCT 120261 RADIX-40 'ORG' R4BSS OCT 047645 RADIX-40 'BSS' T1LAB NOP STMT FCT FLAG FOR LAB.F SKP * *************************** * * SUPPLY LABEL SUBROUTINE * * *************************** * * LAB.F NOP SCAN ASSIGNMENT TABLE LDA BMAX SET DELTA TO LARGER VALUE. STA DELTA JSB GFA.F START SCAN FOR SYMBOL WITH THIS ADDR. LAB0B CLA CLEAR STMT FCT FLAG. STA T1LAB LAB00 JSB GNA.F GET ASSIGNMENT ENTRY LAB0A SZA,RSS IF END OF TABLE JMP LAB01 THEN TRY FUNCTION/SUBROUTINE NAME. * LDA F.A,I GET FLAG WORD. AND B7000 ISOLATE THE F.AT FIELD CPA REL MUST BE EITHER RSS REL CPA DUM OR DUM RSS IF NOT JMP LAB00 REJECT IT * JSB FA.F FETCH F.AF LDB F.A (JUST IN CASE) JSB LAB? TRY THIS ADDRESS. LDA F.A,I STMT FCT ? AND B7600 I.E., F.AT=REL & F.IU=SUB ? CPA B1200 JMP LAB03 YES. * LDA F.EM NO. EMA FORMAL ? SZA,RSS (IF NON-FORMAL, DIDN'T GET THIS FAR) JMP LAB00 NO. SKIP IT. * DLD F.A,I YES. (B) = F.A OF DIM OR BCOMI. LDA F.IU ARRAY ? CPA ARR RSS (YES) JMP LAB04 NO. (B) = F.A OF BCOMI * ADB K2 ELSE IT'S IN WORD 2 OF THE DIM ENTRY. LDB B,I (IT WAS MOVED BY END.F) LAB04 ADB K2 FINALLY, GET THE ADDR OF THE PARAM. LDA B,I LDB F.ŪA (JUST IN CASE) JSB LAB? TRY THIS ADDR. JMP LAB00 SKIP TO NEXT. * LAB03 DLD F.A,I STMT FCT. (B) = EXTENSION ADDR. INB LDA B,I (A) = ADDR FIRST FORMAL. LDB F.A SAVE CURRENT F.A STB T1LAB STA F.A (A) = F.A = FIRST FORMAL. JMP LAB0A GO SEARCH FORMALS TOO. * LAB01 LDA T1LAB IS JUST END OF STMT FCT FORMALS ? STA F.A (JUST IN CASE) SZA WELL ? JMP LAB0B YES. RESUME AFTER STMT FCT. * LDB F.SBF NO, END. 0=MAIN, ELSE SUBROUTINE F.A LDA F.REL ENTRY POINT OF SUBPROGRAM. SZB IF NOT MAIN, JSB LAB? TRY THIS ADDR. * LDA F.UFM UNIT-FILE MAP ? SZA,RSS JMP LAB.F,I NO. EXIT. * INA YES. GET ITS ADDR, LDA A,I LDB DUFMP (ADDR OF LABEL) JSB LAB? AND TRY IT. JMP LAB.F,I TRIED THEM ALL. EXIT. * DUFMP DEF *+1,I DEF TO '.UFMP' ASC 3,.UFMP DFCBP DEF *+1,I DEF TO '.FCBP' ASC 3,.FCBP SKP * ROUTINE TO CHECK FOR MATCHING LABELS. * ENTRY: (A)=ADDR OF LABEL. * (B)=F.A OF LABEL OR DEF,I OF ASCII. * LAB? NOP CMA COMPUTE LABEL-* ADA ASA CMA SZA,RSS IS THIS SYMBOL A MATCH ? JMP LAB?2 YES. * SSA NO. IS IT BEFORE OR AFTER ? JMP LAB?,I BEFORE. IGNORE IT. * LDB DELTA AFTER. OLD MININUM. CMB,INB ADB A (CURRENT) - (OLD) SSB,RSS IS CURRENT < OLD ? JMP LAB?,I NO. IGNORE IT. * LDB MXORG YES. IS IT IN AREA ORD'D BACK OVER ? CMB,INB ADB ASA ADB A (LABEL) - (MAX ORG POINT) SSB,RSS STA DELTA NO, NEW MINIMUM TO NEXT SYMBOL. JMP LAB?,I DONE. * LAB?2 LDA LBUF+12 ALREADY GOT ONE ? CPA BLNKS RSS (NO) 5 JMP LAB?,I YES. DON'T BOTHER WITH OTHERS. * RBL,CLE,SLB,ERB NO. SYMBOL OR JUST ASCII ? JMP LAB?4 ASCII. * JSB STOL SYMBOL. PUT IN THE BUFFER. DBL LBUF+12 JMP LAB?,I AND GO ON. * LAB?4 STB LAB?5 ASCII. COPY IT. JSB MVW.F DEF LBUF+12 LAB?5 ABS *-* DEC 3 JMP LAB?,I DONE. * DELTA NOP MINIMUM DISTANCE TO NEXT SYMBOL. BMAX OCT 77777 MXORG OCT 0 MAX ADDR FROM WHICH ANY ORG BACK DONE. SKP * BSS HANDLER WITH LABELS INCLUDED. * ENTRY: (ASA)=CURRENT ADDR. * (A) =AMOUNT TO BSS. * EXIT: MIXED LISTING LINE PRINTED. * (ASA) UPDATED. * BSS.F NOP BSS01 STA T1BSS T1BSS = AMOUNT LEFT TO DO. SZA,RSS DONE ? JMP BSS.F,I YES. EXIT. * JSB CLR1 NO. CLEAR LIST BUFFER. LDA ADRST SET UP & PRINT STARTING ADDR. STA ASSLC LDB ASA JSB ASCI5 JSB LAB.F LOOK FOR LABEL & NEXT LABEL. LDA R4BSS OUTPUT 'BSS' JSB DSQZB LDB T1BSS IS THE NEXT LABEL BEFORE END OF BSS ? CMB,INB ADB DELTA (NEXT) - (BSS) LDA T1BSS IF NOT, USE FULL BSS, SSB IF SO, LDA DELTA USE OFFSET TO NEXT LABEL. LDB A SUBTRACT FROM TOTAL. CMB,INB ADB T1BSS STB T1BSS LDB A UPDATE CURRENT ADDR. ADA ASA STA ASA JSB ASCI5 OUTPUT OCTAL BSS COUNT. LDA "B" AND "B". JSB PUT.F JSB LIST LIST THE LINE. LDA T1BSS AND GO TRY FOR MORE. JMP BSS01 * T1BSS NOP AMOUNT LEFT TO DO. SKP * ** PREPARATION FOR DATA WORKING SEGMENT ** SPC 1 DPRE0 LDB F.SFF A.T. REFERENCE IS IT A BLOCK DATA FLAG? CPB K2 WELL CLB,RSS YES SKIP TO CHECK IF CURRENT ONE JMP DPR01 NO GO FETCH THE VALUE * CPA COMMS CURRENT MASTER? CCB YES SET FLAG STB IGNOR AS NEEDED CLA ORG IS IN THE ADDON JMP DPR02 GO SET IT UP * DPR01 INA STANDARD A.T. ORG LDA A,I GET THE VALUE JMP DPR02 AND CONTINUE * DPREP ISZ RLOC LDA RLOC,I COMPUTE NEW STORAGE ADDRESS IN A ISZ RLOC PUSH THE BUFFER POINTER RAL,CLE,SLA,ERA SKIPS IF FLAG, REMOVES JMP DPRE0 IF SYMBOL TABEL REF. GO CHECK * DPR02 ADA RLOC,I ADD ON TO ADDRESS CPA ASA IF NO CHANGE JMP CYCL SKIP THE BSS/ORG * LDB RLOC IF JUST AN INB ORG CPB NREC IGNOR THE RECORD (FROM DATA STMT. ECT.) JMP PNREC * LDB ASA B CONTAINS OLD ASA STA TRANS SAVE THE NEW ADDRESS CMB,INB ADA B STA TEMP2 SAVE THE DIFFERMENCE LDA IGNOR IF IGNORING SZA,RSS THEN JMP READ GO TO NEXT RECORD * LDA CCW IF LISTING NOT NEEDED SLA,RSS THEN JMP DPR00 SKIP THIS SET UP * LDA TEMP2 ORG OR BSS ? SSA JMP DPR03 ORG. * JSB BSS.F BSS. PRINT LINE(S). JMP DPR00 AND GO FINISH UP. * DPR03 JSB CLR1 ORG. CLEAR LIST BUFFER LDA R4ORG PRINT 'ORG' JSB DSQZB LDB TRANS CONVERT LOCATION. JSB ASCI5 LDA "B" FLAG IT AS JSB PUT.F OCTAL JSB LIST SEND TO THE PRINTER LDA ASA IS THE LWA+1 BEFORE ORG CMA,INA GREATER THAN MAX SO FAR ? ADA MXORG MAX - CURRENT LDB ASA (CURRENT) SSA IF SO, STB MXORG SET NEW MAX. DPR00 LDA TRANS GET THE NEW ADDRESS STA ASA AND SET IT JSB TERM OUTPUT THE OLD RECORD CYCL CCA CPA IGNOR IGNORING THIS DATA? RSS NO SKIP JMP READ YES GOI READ THE NEXT RECORD * STA RCYC SKP PNREC ISZ RLOC ADVANCE READ PTR LDA RLOC READ PTR AT START OF NEXT REC? CPA NREC JMP READ YES; GO TO BEGINNING SEGMENT ISZ RCYC NO; ANY IND BYTES LEFT? JMP RIND LDA RLOC,I NO. FETCH NEW BYTE WORD. STA RSIND LDA KM5 RELOAD BYTE COUNTER STA RCYC ISZ RLOC LDA RLOC GO TO BEGINNING ROUTINE IF PTR CPA NREC AT START OF NEXT RECORD JMP READ RIND LDA RSIND ALF,RAR STA RSIND AND K7 STA RIIND LDB WLOC SET B TO WLOC + LGTH NEXT WORD -1 CPA K7 IF OFFSET ENTRY RSS TREAT AS MR FOR NOW CPA K5 RSS CPA K6 DITTO BYTE ADDR. INB HANDLES WORD LGTH=2 CMB,INB ADB WBP0 ADB K58 SSB OUTPUT BUFFER FULL? JSB TERM YES. ISZ WLOC JSB CLR1 BLANK THE LIST BUFFER SPC 2 * ** ALTER DATA WORD AND STORE ** SPC 1 LDA CCW SET E ERA IF LIST REQUIRED CLA STA EXTN SET EXT ID TO ZERO STA DI2 SET THE NO SYMBOL FLAG STA WIIND STA CX CLEAR OFFSET STA OPCOD LDA RLOC,I READ AND STORE DATA STA WLOC,I STA OFSET STORE FOR OBJECT LISTING LDB RIIND SZB,RSS JMP R0 CONSTANT. CPB K2 JMP R2 ASCII CHAR PAIR. CPB K3 JMP R3 ABSOLUTE INSTRUCTION. CPB K6 JMP R6 BYTE DEF. AND KK01 =B100000, CALCULATE DI1 STA DI1 MREXT LDA WLOC,I GET OPCODE AND KK076 =B76000 STA CODE CPB K4 JMP R4 EXT REF. * STB WIIND 2-WORD MEM REF; SET WIIND=5 ADA DI1 STA OPCOD SAVE OPCODE & INDIRECT LDA RLOC,I GET OPERAND RELOCATION BITS AND B3 STA MR "ISZ RLOC ADV READ PTR LDB RLOC,I GET OPERAND RBL,CLE,SLB,ERB =0? CLEAR FLAG JMP INDRT NEGOF STB OPADD JMP CODE0 SPC 1 INDRT LDA RLOC,I GET THE WORD ADA K8 A NEGATIVE OFFSET OF 8 IS MAX SSA IF NOW NEGATIVE JMP ASTBR THEN ASSIGNMENT TABLE REF. * LDB RLOC,I ELSE IT IS A NEG. OFFSET SO JMP NEGOF RESTORE BE AND GO SET * ASTBR STB OPADD AREF LDA B,I GET FIRST WORD OF ENTRY AND B600 ISOLATE F.IU FIELD INB LDB B,I CPA ARR IF ARRAY JMP AREF GO ANOTHER LEVEL * ISZ DI2 SET THE SYMBOL USED FLAG CPA SUB SUBROUTINE ? JMP AREF2 YES. * LDA OPADD,I NO. GET TYPE. AND B170K CPA CHAR CHARACTER ? LDB B,I YES. (B) = ADDR DESCRIPTOR. JMP CODE0 * AREF2 LDA OPADD,I SUBROUTINE. WHAT KIND ? AND B7000 F.AT FIELD. CPA STRAB F.AT=STRAB ? RSS CPA BCOMI OR BCOMI ? JMP EXT YES, EXTERNAL SUB OR COMMON LABEL. * CPA REL F.AT=REL ? (ELSE F.AT=DUM) LDB B,I YES, STMT FCT, GET ADDR FROM EXTENSION. CODE0 LDA KK051 SET QUALIFIER='R ' STA QALST,I LDA K5 TEST THE RECORD TYPE CPA RIIND IF STD MR JMP MRIN GO TEST FOR DEF * STA WIIND ELSE SET TYPE TO MR ISZ RLOC GET THE OFFSET WORD LDA RLOC,I AND SET STA CX IT FOR FUTURE REF. ADB A SET PROPER ADDRESS MRIN LDA EXTN GET EXT NO. ADA CODE TEST IF INTERNAL DEF. SZA,RSS MUST NOT BE EXT REF. JMP DF YES. IT'S A DEF. * ISZ WLOC STB WLOC,I STORE ALTERED 2ND WORD ADB DI1 SET FULL ADDRESS IN B STB OFSET SET FOR LISTING CLA CLEAR A FOR FURTHER TESTS JMP MRTST * EXT CMB,INB SET THE EXT POSITIVE LDA K5 TEST IF STD. ONE WORD EXT CPA RIIND IS ALL THAT IS NEEDED JMP EXT1 YES ONE WORD ENTRY GO DO IT * STB EXTN NO A MR WITH OFFSET IS REQUIRED RBL,RBL FORM THE INSTRUCTION ADB WLOC,I FIX THE INSTRUCTION BY ADDING ADB K3 SET 'MR' FIELD TO ABSOLUTE STB WLOC,I THE ORDINAL CLB NOW CONTINUE TO SET UP THE OFFSET JMP CODE0 * EXT1 ADB WLOC,I FIX UP THE INSTRUCTION STB WLOC,I IN THE OUTPUT BUFFER LDA CCW SET THE LISTING BIT ERA IN E LDB K4 SET THE MR TYPE JMP MREXT GO SET UP A AND DO THE MR * SPC 1 DF ADB DI1 COMPLETE ADDRESS STB WLOC,I STB OFSET FOR OBJECT LISTING LDB MR COMPUTE WIIND INB STB WIIND MRTST LDB CCW IF NOT PRINTING CLE,SLB,RSS JMP NOPRT DONE WITH IT * CPA EXTN EXTERNAL REF? JMP NOTEX NO SKIP * LDA CODE EXT REF GET CODE JMP EXTS GO PUT TOGETHER * NOTEX LDB KK041 SET QUALIFIER ='C ' CPA MR IF NOT IN COMMON RSS SKIP THE RESET OF THE QUALIFIER STB QALST,I LDA CODE JSB INV.F PUT OPCODE INTO THE LIST BUFFER SKP * ** SUPPLY OPERAND SYMBOL ** SPC 1 LDB DI2 BIF BIT 15 IS ON THEN IT IS A SYMBOL SZB,RSS FROM THE SYMBOL TABLE WELL? JMP BRCH0 NOT IN TABLE SKP FURTHER CHECKS * LDA OPADD,I READ BASE WORD OF ENTRY SLA IF CONSTANT JMP SWTCH GO USE RELATIVE ADDRESS * LDB OPADD IT IS A REAL ENTRY IS IT A TEMP? JMP TRSYM GO PUT OUT THE SYMBOL SPC 1 BRCH0 LDA MR SKIP * OPERAND LOGIC IF COMMON SZA LOCATION JMP CNVT LDA KK025 '*+' LDB ASA COMPUTE DISTANCE BETWEEN OPERAND CMB,INB AND LOAD ADDRESSES CN ADB OPADD SSB IF NEGATIVE ADA K2 CHANGE TO '*-' SSB MAKE DISTANCE ABSOLUTE CMB,INB STA PUT2 SAVE THE PREFIX STB A AND KM8 =B177770, DISTANCE LESS THAN 8? SZA JMP CNVT NO. * ADB "0" =B60 YES CONVERT TO A CHARACTER LDA PUT2 SEND THE PREFIX JSB PUT2 LDA B GET THE OFFSET JSB PUT.F SEND TO THE BUFFER JMP TTDI1 SPC 1 SWTCH ISZ OPADD GET THE VALUE LDB OPADD,I FROM THE SYBMOL TABLE AND B170K F.IM: IS IT CPA CHAR CHARACTER ITEM ? LDB B,I YES. (B) = ADDR. STB OPADD AND SAVE IT * CNVT LDA OPLOC (A) = BUFFER POINTER. LDB OPADD (B) = VALUE. JSB ASCI6 PUT ADDRESS INTO THE BUFFER LDA "B" FLAG AS OCTAL JSB PUT.F LDB MR MR.F ROUTINE ADDS COMMON SYMBOL LDA "C" GET "C" CPB K2 IF IN COMMON JSB PUT.F ADD THE "C" TTDI1 LDB CX GET THE OFFSET SZB,RSS IF NONE JMP ITST GO TEST FOR INDIRECT * LDA B53 "+" PUT PROPER CONECTOR SSB IN THE BUFFER ADA K2 "-" FROM "+" JSB PUT.F SEND TO THE BUFFER SSB MAKE ABSOLUTE CMB,INB JSB ASCI5 PUT OFFSET IN THE BUFFER LDA "B" NOW PUT IN JSB PUT.F THE OCTAL INDICATOR ITST LDA B54 "," LDB DI1 IF INDIRECT FLAG NOT SET SZB,RSS THEN JMP PRINT GO PRINT WHAT WE HAVE * JSB PUT.F ELSE SEND A "," LDA "I" AND A JSB PUT.F "I" JMP PRINT AND THEN GO PRINT IT * * OPLOC DBR LBUF+17 TEMP2 NOP B53 OCT 53 '+' B170K OCT 170000 F.IM MASK. CHAR OCT 130000 F.IM=CHAR "0" OCT 60 "C" OCT 103 "B" OCT 102 B54 OCT 54 ',' "I" OCT 111 KM8 DEC -8 K2 DEC 2 K3 DEC 3 K6 DEC 6 K8 DEC 8 K58 DEC 58 B377 OCT 377 KK025 ASC 1,*+ KK400 OCT 40000 CBLNK ASC 1,C CROSS REF FLAG KK041 EQU CBLNK KK051 ASC 1,R KK076 OCT 76000 MR NOP MRI AND ASCII PARAMETER CODE NOP OP CODE CX NOP COMPLEX FLAG DI1 NOP BIT 15 WORD 1 DI2 NOP BIT 15 WORD 2 OPADD NOP OPERAND ADDR / BASE ADDR OP ENTR * * ** GENERATE ASSEMBLY LISTING ** SPC 1 R0 SEZ,RSS IF NOT PRINTING JMP NOPRT SKIP REST LDA R4OCT 'OCT' JSB DSQZB LDB WLOC,I CONVERT DATA TO ASCII LDA OPLOC GET ADDRESS OF OPCODE JSB ASCI6 JMP PRINT * * ASCII DATA. * R2 SEZ,RSS IF NOT PRINTING JMP NOPRT SKIP BUFFER SETUP * LDB A STORE ASCII CHARACTER PAIR AND B377 CPA B15 TRAILING CR? ADB B23 YES. SUBSTITUTE BLANK. STB TEMP2 LDA R4ASC 'ASC ' JSB DSQZB TO THE BUFFER LDA KK03 '1,' JSB PUT2 LDA TEMP2 JSB PUT2 PUT IN THE ASCI JMP PRINT * * BYTE DEF. * R6 STB WIIND SET OUTPUT RELOCATION = 6. CLA CLEAR INDIRECTION INDICATOR. STA DI1 LDA RLOC,I COPY RELOCATION BITS. RAL,CLE,ERA (MOVE L/R BIT TO (E).) AND B3 (NOTE: OPCOD=0 STILL) STA MR STA WLOC,I ISZ RLOC ADV READ PTR LDB KK051 SET QUALIFIER = 'R'. SZA UNLESS MR#0, LDB KK041 INWHICHCASE 'C'. STB QALST,I LDB RLOC,I GET OPERAND. STB OFSET SET WORD ADDR FOR LISTING. STB OPADD ELB BYTE ADDR. ISZ WLOC STB WLOC,I SET ADDRESS FOR OUTPUT, LDA CCW IF NOT PRINTING, SLA,RSS JMP NOPRT THEN DONE. * LDA R4DBL ELSE PRINT 'DBL', SLB LDA R4DBR OR 'DB3R'. JSB DSQZB JMP BRCH0 FINISH PRINTING. * R4OCT OCT 117146 RADIX-40 'OCT' R4ASC OCT 044525 RADIX-40 'ASC' R4DBL OCT 054566 RADIX-40 'DBL' R4DBR OCT 054574 RADIX-40 'DBR' KK03 ASC 1,1, '1,' B15 OCT 15 B23 OCT 23 B1777 OCT 1777 E.TBL NOP END OF .TBL + 1. ADEXT DEF EXTST BASE LOC. OF EXTST KK054 ASC 1,X EXTN NOP EXTERNAL ID # SKP R4 STB WIIND EXTERNAL REFERENCE; SET WIIND =4 SEZ,CLE,RSS IF NOT LISTING JMP NOPRT SKIP THE SET UP * EXTS LDB KK054 SET QUALIFIER ='X ' STB QALST,I JSB INV.F CONVERT AND STORE OPCODE LDA EXTN GET POSSIBLE EXT NO. SZA,RSS IF NONE THEN LDA WLOC,I PICK UP FROM THE INPUT STREAM AND B1777 =B1777 GET EXT ORDNL STA OFSET SET FOR PRINTING CMA,INA SET NEGATIVE FOR COMPARE STA EXTN LDA DI2 IS THE LDB OPADD SYMBOL ADDRESS SUPPLIED? SZA WELL JMP TRSYM YES GO MOVE IT * LDA EXTN GET THE SYMBOL NUMBER TO A LDB F.D.T SEARCH EXTERNAL TABLE FOR MATCH CONSR CPA B,I JMP FOND1 INB CPB E.TBL END OF .TBL REACHED? RSS YES. JMP CONSR JSB GFA.F START S.T. SCAN. FIXT1 JSB GNA.F NEXT ! SZA,RSS DONE ? JMP FOND2 YES. * DLD F.A,I NO. FIND EXT #. CPB EXTN JMP FOND2 YES. FOUND IT. JMP FIXT1 LOOK AGAIN. SPC 1 FOND2 LDB F.A TRSYM JSB STOL COPY STRING TO ASSY LIST BUFF DBR LBUF+17 JMP TTDI1 SPC 1 FOND1 LDA F.D.T COMPUTE LOCATION IN EXTERNAL CMA,INA SYMBOL TABLE OF ENTRY ADA B STA B ORDINAL. ADA B ADA B *3 ADA ADEXT STA B ADA B3 STA STP JSB STMV MOVE IN THE SYMBOL JMP TTDI1 GO TEST FOR INDIRECTS ETC. SKP ASSBF DB R LBUF+15 DMODT DEF MODT BASE LOC. OF MODT (MODE OF TEMP) T1PNT NOP SPC 1 R3 SEZ,RSS IF NOT PRINTING JMP NOPRT SKIP BUFFER SET UP * JSB INV.F ABSOLUTE INSTR: FIND MNEMONIC SPC 1 * ** FINISH AND PRINT ASSY LIST BUFFER ** SPC 1 PRINT LDB OFSET LDA ASSLC GET CURRENT LOCATION STA T1PNT SAVE IT LDA OBJST PRINT JSB ASCI6 OBJECT CODE TO ASCII OCTAL LDB ASA LDA ADRST STA ASSLC SET ADDRESS FOR ADDRESS JSB ASCI5 ADDRESS TO ASCII OCTAL JSB LAB.F ADD ANY LABEL LDA T1PNT RESTORE STA ASSLC THE CURRENT LOCATION JSB LIST OUTPUT LIST BUFFER LDB RIIND GET THE OFFSET IF ANY LDA EXTN IF EXTERNAL CPB K7 AND OFFSET SZA,RSS THEN SKIP TO PRINT IT JMP NOPRT NOPE SKIP THE EXTRA LINE * JSB CLR1 CLEAR THE BUFFER AND PRINT THE OFFSET LDA OBJST GET THE ADDRESS OF THE OFFSET LDB CX GET THE OFFSET JSB ASCI6 SEND IT TO THE BUFFER LDA B53 '+' JSB PUT.F SEND '+' TO THE BUFFER JSB LIST LIST IT SKP * ** POST RELOCATION BYTE ** SPC 1 NOPRT ISZ WORD ISZ ASA LDA WSIND ROTATE WSIND LEFT 1 IND ALF,RAR STORE AT RIGHT WIIND ADA WIIND STA WSIND ISZ WCYC BRANCH ONCE-IN-5 JMP PNREC LDA KM5. RESET WCYC=-5 STA WCYC LDA WSIND ROTATE WSIND LEFT 1 RAL STA STOWS,I CLA STA WSIND ISZ WLOC LDB WLOC STB STOWS JMP PNREC * OPCOD NOP OFSET NOP ASA NOP ACTUAL STORAGE ADDR. STOWS NOP STORG LOC OF NEXT WSIND WIIND NOP WCYC NOP WLOC NOP WRITE LOCATION POINTER WSIND NOP KM5. DEC -5 ADRST DBR LBUF+4 OBJST DBL LBUF+8 QALST DEF LBUF+11 ASSLC NOP SPC 1 * ****9************************************ * * SYMBOL FROM ASS. TBL. TO LIST BUFFER * * **************************************** * STOL NOP B IF ASS. TBL. ADDRESS ADB K2 B IS ADDRESS OF FIRST CHARS. LDA STOL,I P+1 IS ADDRESS OF WHERE TO PUT IT STA ASSLC SET IT ISZ STOL STEP TO RETURN ADDRESS LDA B,I GET THE FIRST ID WORD SSA,RSS IF NEGATIVE SKIP JMP STOL0 IT IS >0 STD. SYMBOL * AND BC4K REMOVE 4000 BIT. ALF,ALF POSITION TO GET LEAST RAR 4 DIGITS (LEFT 1+(6-#DIG)*3) STA STMV SAVE THE NUMBER. ADB KM2 GET THE ADDRESS OF THE LDA B,I IM AND GET IT ALF POSITION THE IM FIELD. AND B17 ISOLATE ADA DMODT INDEX INTO TABLE LDA A,I FETCH TEMPCELL MODE SYMBOL JSB PUT2 PUT IT IN THE BUFFER LDA KM4 GET DIGIT COUNT LDB STMV GET THE NUMBER TO B JSB NUM.F CONVERT FOUR DIGITS INTO THE BUFFER JMP STOL,I RETURN * STOL0 ADB KM2 SET UP F.A STB F.A JSB NAM.F COPY NAME TO LOCAL BUFFER. DEF STNAM LDB DFSTN (B) = ITS ADDRESS. LDA DFSTE SET END ADDRESS. STA STP JSB STMV MOVE THE SYMBOL JMP STOL,I RETURN * * STMV NOP SYMBOL MOVE B=ADDRESS,STP= STOP ADDRESS STOL1 CPB STP DONE? JMP STMV,I YES EXIT * LDA B,I GET FIRST TWO CHAR. ALF,ALF ROTATE TO AND B177 GET FIRST CHAR CPA B40 IF BLANK, JMP STMV,I QUIT, NO BLANKS ALLOWED. * JSB PUT.F PUT FIRST OUT FIRST LDA B,I GET NEXT AND B177 ISOLATE CPA B40 IF BLANK JMP STMV,I QUIT. * JSB PUT.F ELSE PUT IT OUT INB STEP B JMP STOL1 GO GET NEXT CHAR. * STP NOP B17 OCT 17 B177 OCT 177 DFSTN DEF *+1 q STNAM BSS 3 DFSTE DEF * SPC 1 SKP SPC 2 * ** FINISH AND OUTPUT DBL RECORD ** SPC 1 TERM NOP LDB WORD SZB,RSS JMP TERMX EMPTY RECORD. ADB KK601 =B60100 STB WBP1,I LDA WLOC IF A NEW CPA STOWS DBL FLAG WORD IS LAST JMP NORT SKIP THE ROTATE BIT * LDB WSIND ROTIN BLF,RBR ROTATE WSIND LEFT ONE IND ISZ WCYC JMP ROTIN * RBL COMPLETE PREPARATION OF WSIND STB STOWS,I ISZ WLOC NORT LDA WBP0 COMPUTE RECORD LENGTH CMA,INA ADA WLOC JSB .WRIT OUTPUT DBL RECORD * * INITIALIZE NEXT DBL RECORD * TERMX LDA KM5. =D-5 STA WCYC LDB WBP0 'DEF WBUF' ADB K4 STB WLOC STB STOWS CLA STA WORD WORDS OF OBJECT CODE STA WSIND LDA ASA SET RECORD ORIGIN STA WBP3,I JMP TERM,I * * ************************************ * * OUTPUT RELOCATABLE BINARY RECORD * * ************************************ SPC 1 .WRIT NOP LDB BFLG DOES HE WANT A SZB,RSS BINARY?? JMP .WRIT,I NO JUST EXIT * LDB WBP0 ALF,ALF WORD CNT TO LEFT HALF STA B,I POST WC IN BUFFER ALF,ALF CMA,INA ADA B3 STA WORD COUNTER INB LDA B,I GET TYPE WORD ADB K2. ADA B,I TALLY CHECKSUM INB ISZ WORD JMP *-3 STA WBP2,I POST IN BUFFER LDA WBP0,I ALF,ALF GET WORDCOUNT STA RECLN SET IT JSB WRT.C OUTPUT RECORD DEF C.BIN WBP0 DEF WBUF DEF RECLN JMP WERR WRITE ERROR REPORT IT * JMP .WRIT,I SPC 2 RECLN NOP BFLG NOP # 0 IF BINARY TO BE PRODUCED K2. DEC 2 KK601 OCT 60100 K4 DEC 4 DLBUF DEF LBUF BASE ADDRESS OF LIST BUFFER KK12{y0 OCT 120000 RLOC NOP SLBUF NOP ADDR OF 1ST WORD IN LIST OUTPUT WORD NOP NUMBER OF ENTRIES SPC 2 * ************************* * * FINISH DBL PROCESSING * * ************************* SPC 1 END. LDA ASA COMPUTE SIZE OF FINAL BSS. CMA,INA ADA F.RPL LDB CCW PRINTING ? SLB JSB BSS.F YES, OUTPUT BSS LINE(S). JSB TERM DUMP LAST DBL RECORD LDA CCW PRINTING ? SLA,RSS JMP END02 NO. * JSB CLR1 'END': CLEAR THE BUFFER, LDA ADRST INSERT LWA+1 ADDR, STA ASSLC LDB F.RPL JSB ASCI5 LDA R4END GET 'END', JSB DSQZB PUT IT IN BUFFER, LDA F.SBF SEE IF XFER ADDR. SZA WELL ? JMP END01 NO. GO PRINT. * LDB F.REL YES. CONVERT IT, JSB ASCI5 TO 5 OCTAL DIGITS, LDA "B" ADD "B", JSB PUT.F END01 JSB LIST AND LIST. END02 CLA SKIP A LINE JSB SKL.F ON THE LIST DEVICE LDA F.SFF IF BLOCK DATA SUB. PGM. CPA K2 THEN RSS (YES) JMP END03 NO. * LDA BLKN SEE IF SPECIAL BLANK COMMON; CPA " 57B, '.' CCA ADA BM13 IS IT A LETTER SSA,RSS ADA K7 YES, MAP 13B-44B TO 101B-132B CPA BM13 MAP 0 => 77B, '?' LDA K5 ADA B72 OTHERWISE MAP 1B-12B TO 60B-71B, '0'-'9' JSB PUT.F PRINT. (46B,47B UNUSED) JMP CONV,I RETURN SKP * MOVE TO OPCODE, PRINT 3 RADIX-40 CHARS & BLANK. * DSQZB NOP LDB ASSBF MOVE COLUMN CURSOR. STB ASSLC JSB DSQZ PRINT 3 CHARS FROM (A). LDA B40 AND B40 . JSB PUT.F JMP DSQZB,I EXIT. * B45 OCT 45 B72 OCT 72 BM13 OCT -13 K40 DEC 40 K1600 DEC 1600 * * EXIT CODE. * EXIT LDA B40 FILL WITH B40 CHAR JSB PUT.F JMP INV.F,I AND RETURN SPC 2 * MEMORY REGERENCE INSTRUCTIONS. * MRG OCT 054750 DEF (FAKED) OCT 115002 NOP (FAKED) OCT 044216 AND OCT 100624 JSB OCT 154204 XOR OCT 100262 JMP OCT 075304 IOR OCT 075554 ISZ OCT 043373 ADA OCT 043374 ADB OCT 052533 CPA OCT 052534 CPB OCT 105673 LDA OCT 105674 LDB OCT 134773 STA OCT 134774 STB SKP SRG ALF SHIFT/ROTATE GROUP. ELA ERA ALR RAR RAL ARS ALS OCT 40 CLE SLA OCT 27 ALF OCT 26 ELA OCT 25 ERA OCT 24 ALR OCT 23 RAR OCT 22 RAL OCT 21 ARS OCT 20 ALS SRGA OCT 044100 ALF OCT 060473 ELA OCT 061053 ERA OCT 044114 ALR OCT 130324 RAR OCT 130316 RAL OCT 044475 ARS OCT 044115 ALS OCT 052277 CLE OCT 134273 SLA OCT 044100 ALF OCT 060473 ELA OCT 061053 ERA OCT 044114 ALR OCT 130324 RAR OCT 130316 RAL OCT 044475 ARS OCT 044115 ALS SRGB OCT 047200 BLF OCT 060474 ELB OCT 061054 ERB OCT 047214 BLR OCT 130374 RBR OCT 130366 RBL OCT 047575 BRS OCT 047215 BLS OCT 052277 CLE OCT 134274 SLB OCT 047200 BLF OCT 060474 ELB OCT 061054 ERB OCT 047214 BLR OCT 130374 RBR OCT 130366 RBL OCT 047575 BRS OCT 047215 BLS SKP * ALTER/SKIP GROUP. * ASG CCA CLA CMA SEZ CCE OCT 2100 CLE CME SSA SLA INA SZA RSS ASGA OCT 051523 CCA OCT 052273 CLA OCT 052343 CMA OCT 133674 SEZ OCT 051527 CCE OCT 052277 CLE OCT 052347 CME OCT 134723 SSA OCT 134273 SLA OCT 075213 INA OCT 135353 SZA OCT 131645 RSS ASGB OCT 051524 CCB OCT 052274 CLB OCT 052344 CMB OCT 133674 SEZ OCT 051527 CCE OCT 052277 CLE OCT 052347 CME OCT 134724 SSB OCT 134274 SLB OCT 075214 INB OCT 135354 SZB OCT 131645 RSS SKP * MISCELLANEOUS INSTRUCTIONS. * DSG SWP OCT 135202 CLO OCT 052311 SOC OCT 134465 SOS OCT 134505 * * TWO-WORD SHIFTS. * RRR 16 OCT 131574 LSR 16 OCT 107044 ASR 16 OCT 044544 RRL 16 *\ OCT 131566 LSL 16 OCT 107036 ASL 16 OCT 044536 * * OTHER EAU. * EIG2 OCT 100200 MPY OCT 111763 OCT 100400 DIV OCT 055230 OCT 104200 DLD OCT 055376 OCT 104400 DST OCT 056046 SPC 3 * ** MODE OF TEMP CELL TABLE ** SPC 1 MODT NOP ASC 12,I.R.L.T.C.X.A.J.M.D.S.Z. LBUF ASC 1, BSS 46 LIST BUFFER RBUF BSS 128 READ BUFFER WBUF BSS 60 WRITE BUFFER SKP * ** EXTERNAL FUNCTION SYMBOL TABLE ** SPC 1 EXTST ASC 18,.DAD .FAD .XADD .TADD .CADD .DIN 6 ASC 18,.DSB .FSB .XSUB .TSUB .CSUB .DSBR 12 ASC 18,.DMP .FMP .XMPY .TMPY .CMPY .DDE 18 ASC 18,.DDI .FDV .XDIV .TDIV .CDIV .DDIR 24 ASC 18,.DNG ..FCM ..DCM ..TCM ..CCM .DCO 30 ASC 18,.ITOI .ITOJ .JTOI .JTOJ .CTOI .CTOJ 36 ASC 18,.RTOI .RTOJ .RTOR .RTOD .RTOT .FPWR 42 ASC 18,.DTOI .DTOJ .DTOR .DTOD .DTOT .EIO. 48 ASC 18,.TTOI .TTOJ .TTOR .TTOD .TTOT .TPWR 54 ASC 18,.IIO. .JIO. .RIO. .XIO. .TIO. .FIO. 60 ASC 18,.IAY. .JAY. .RAY. .XAY. .TAY. .BIO. 66 ASC 18,.IAE. .JAE. .RAE. .XAE. .TAE. .DTA. 72 ASC 18,EXEC .ENTR .DFER .CFER .GOTO .BAD. 78 ASC 18,.EMAP .ERES .FPAU .FSTP .TAPE ERR0 84 ASC 18,.FSIU .FSOU .ENTP .ARTN .DMAP .DRES 90 ASC 18,REIO XLUEX .IOOP .IOCL .IOIN .IOCN 96 ASC 18,.ICPX .CFTD .DCPX .TCPX .TDBL .DTBL 102 ASC 18,SQRT DSQRT .SQRT CSQRT %QRT $SQRT 108 ASC 18,/SQRT SIN DSIN .SIN CSIN %IN 114 ASC 18, /SIN #SIN COS DCOS .COS 120 ASC 18,CCOS %OS /ATN2 /COS #COS TAN 126 ASC 18,DTAN .TAN %AN $TAN /TAN TANH 132 ASC 18,DTANH .TANH %ANH ATAN DATAN .ATAN 138 ASC 18,%TAN ATAN2 DATN2 .ATN2 ALOG DLOG 144 ASC 18,.LOG CLOG %LOG $LOG /LOG #LOG 150 ASC 18,ALOGT DLOGT .LOGT %LOGT $LOGT /LOGT Ӄ156 ASC 18,EXP DEXP .EXP CEXP %XP $EXP 162 ASC 18,/EXP #EXP DABS .ABS CABS %ABS 168 ASC 18,%JABS %BS .DMOD AMOD DMOD .MOD 174 ASC 18,MOD %JMOD ISIGN .JSGN SIGN DSIGN 180 ASC 18,.SIGN %IGN %JSGN IDIM .JDIM DIM 186 ASC 18,.XDIM .DDIM MIN0 .JMN0 AMIN1 DMIN1 192 ASC 18,.MIN1 AMIN0 .AMNJ MIN1 .JMN1 MAX0 198 ASC 18,.JMX0 AMAX1 DMAX1 .MAX1 AMAX0 .AMXJ 204 ASC 18,MAX1 .JMX1 AIMAG CONJG AINT DDINT 210 ASC 18,.YINT %INT IFIX .FIXD .XFXS .XFXD 216 ASC 18,.TFXS .TFXD .CINT .CFXD %FIX %FIXD 222 ASC 18,IDINT %XFXD %TFXS %TFXD FLOAT .FLTD 228 ASC 18,SNGL .NGL REAL %LOAT %FLTD .XFTS 234 ASC 18,.TFTS .XFTD .TFTD DBLE .BLE .CDBL 240 ASC 18,.CTBL CMPLX %AND %DAND .DAND %OR 246 ASC 18,%DOR .DOR IXOR %DXOR .DXOR %OT 252 ASC 18,%DNOT .DEQV .ISH .JSH %ISH %JSH 258 ASC 18,%SSW ISSW .EXIT .FFRW .FIOI .MAE. 264 ASC 18,.SMAP .SRES .LIO. .LAY. .LAE. .MAY. 270 ASC 18,.SINH %SINH .COSH %COSH .ASIN %ASIN 276 ASC 18,.ACOS %ACOS .ASNH %ASNH .ACSH %ACSH 282 ASC 18,.ATNH %ATNH .CTAN %CTAN .DSNH %DSNH 288 ASC 18,.DCSH %DCSH .DASN %DASN .DACS %DACS 294 ASC 18,.DASH .DACH %DACH .DATH %DATH 300 ASC 18,.ZADD .ZSUB .ZMPY .ZDIV ..ZCM .ZTOI 306 ASC 18,.ZTOJ .ZMPX .ZINT .ZFXD .ZCPX .IZPX 312 ASC 18,.JZPX .FZPX .DZPX .CZPX .ZFER .ZSQR 318 ASC 18,.ZSIN %ZSIN .ZCOS %ZCOS .ZTAN %ZTAN 324 ASC 18,.ZLOG %ZLOG .ZEXP %ZEXP .ZABS .ZAIM 330 ASC 18,.ZCNG .NINT %NINT .NJNT %NJNT .IDNT 336 ASC 18,%IDNT .JDNT %JDNT .ANNT %ANNT .TNNT 342 ASC 18,%TNNT DEXEC .DNRW .DSRW 348 * NO.F EQU 348 NUMBER OF ENTRIES IN ABOVE TABLE .CHK. EQU *-EXTST-NO.F-NO.F-NO.F *** MUST BE ZERO *** * ERR0 EQU EXTST+83+83+83+1 ORG * END F4.5 ASMB,Q,C HED END STATEMENT PROCESSING. NAM END.F,8 f92834-16003 REV.2030 800821 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F..E 'E' BIT FROM A.T. EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTIONS WORD. EXT F.CSL CHARACTER STRING LENGTH. EXT F.D0 ARRAY ELEMEXT SIZE EXT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. EXT F.DNB DEF TO NAM RECORD. EXT F.EM EMA FLAG BIT IN A.T. EXT F.END END FLAG EXT F.ERF ERROR FLAG (# OF ER.F CALLS) EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.)  EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.ND NUMBER OF DIMENSIONS. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL EXT F.UFM ADDR OF UNIT-FILE MAP. EXT F.#M # NON-DISC CONNECTIONS. EXT F.#N # DISC CONNECTIONS. EXT F.#S BUFFER MULTIPLE. EXT F.#B # OF BUFFER BLOCKS. SKP * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM EXT CER.F COMPILER ERROR. EXT DAD.F DOUBLE INTEGER ADD. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (F.AT) EXT DIM.F DEFIND (F.IM) EXT DIU.F DEFINE (F.IU) EXT DL.F DEFINE LOCATION SUBROUTINE EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FC.F FETCH CONSTANT'S VALUE TO F.IDI EXT GCD.F GET VALUE OF CONSTANT INTEGER. EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GFC.F GET FIRST (CONSTANT) SYMBOL TABLE ENTRY. EXT GFD.F GET FIRST (DEF) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT IN2.F INITIALIZATION FOR OA.F EXT NAM.F COPY SYMBOL NAME. EXT NWE.F COMPUTE (B) = ITEM SIZE, FROM F.IM EXT OAI.F OUTPUT ABS. INSTRUCTION. EXT OAD.F OUTPUT ABS. DATA. EXT OC.F OUTPUT CONSTANT EXT ODD.F OUTPUT DEF TO DOT FUNCTION. EXT ODF.F OUTPUT DOT FUNCTION EXT OLR.F OUTPUT LOAD ADDRESS EXT OS.F FLUSH OA.F'S BUFFER. EXT OW.F OUTPUT WORD. EXT PDF.F PRODUCE DEF SUBROUTINE EXT PSL.F PRINT LINE ON PRINTER EXT SKL.F SKIP LINES ON LIST EXT WAR.F ERROR CO>MMEXT SUBROUTINE (WARNINGS) * * COMPILER LIBRARY ROUTINES: * EXT EOF.C EXT C.SC0 FCB FOR 2ND PASS FILE. * * ENTRY TO THIS MODULE. * ENT END.F * SUP A EQU 0 B EQU 1 SKP * ***************** * * END PROCESSOR * * ***************** SPC 1 END.F NOP ISZ F.END SET THE END FLAG LDA DENX9 SET THE ERROR RECOVERY ADDRESS. STA F.ERX (SHOULDN'T HAPPEN, BUT BE SAFE) JSB IN2.F RE-INITIALIZE OA.F * * DO SOME ERROR CHECKING. * CCA SET FLAG STA F.CC TO USE SHORT FORM ERROR MESSAGE LDB F.SPF GET CURRENT STMT. LEVEL ADB KM3 TEST IF MORE THAN JUST SPECS AND DATA LDA F.SFF IF BLOCK DATA SUBPROGRAM CPA K2 THEN CMB CHANGE SENSE OF TEST SSB IF PROGRAM AND NO EXECUTABLE OR BLOCK DATA WITH JMP ENDP1 THEN GO SEND ERROR * LDA F.SFF SZB,RSS IF JUST STMT. FUNCTIONS CPA K2 AND NOT BLOCK DATA JMP ENDP0 THEN * ENDP1 LDA K66 BITCH JSB WAR.F ERROR 66: SHOULD/SHOULD NOT HAVE EXEC. STMTS. SKP * IF FUNCTION, MAKE SURE IT HAS BEEN DEFINED. * ENDP0 CLA,INA JSB SKL.F SKIP TWO LINES LDA F.SBF SUBPROGRAM FLAG SET? STA F.A SZA,RSS JMP ENDP8 NO, MAIN; GENERATE STOP CALL * JSB FA.F FETCH ASSIGNS LDA F.IU LDB F.SFF IS IT A FUNCTION? SZB XOR VAR YES. LDB A LDA K46 SZB JSB WAR.F FUNCTION NAME NOT USED OR SUB NAME USED. LDA VAR IF FUNCTION, MAKE SURE LOC DEFINED. LDB F.SFF SZB JSB DIU.F JMP END01 * ENDP8 LDA F.SFF IF BLOCK DATA SUBPROGRAM CPA K2 THEN JMP ENDX3 SKIP REST OF THE END STMT. PROCESSING SKP * **************P*********** * * PROCESS EMA VARIABLES * * ************************* SPC 1 END01 JSB OLR.F STARTING DATA, MUST INIT RELOC. JSB GFA.F START SCAN (AGAIN). END1A JSB GNA.F GET NEXT ONE. SZA,RSS DONE ? JMP ENDP3 YES. * JSB FA.F FETCH ASSIGNS. LDA F.EM IF NOT EMA, LDB F.IU OR F.IU=SUB (E.G. EMA MASTER) SZA CPB SUB JMP END1A THEN IGNORE IT. * * EMA VARIABLE. GENERATE ZERO-DIM & N-DIM TABLES. * LDA F.AF F.A OF THE BCOMI ENTRY. STA T0STF SAVE IT, INA AND GET THE ADDRESS INFO. LDB A,I LOWER BITS OR TEMP WITH BASE ADDR. STB T8STF SAVE THAT. INA & ADVANCE TO WORD 2. LDB F.AT IF NOT FORMAL PARAM, CPB DUM JMP END1B (YES. THEN LEAVE ADDR OF .ENTR PARAM) * LDB T8STF THEN SAVE LOWER BITS IN WORD 2 FOR STB A,I THE SYMBOL TABLE LIST. END1B INA NOW COPY THE UPPER BITS. LDB A,I STB T7STF LDB F.A SAVE F.A TO CONTINUE SCAN. STB T2STF INB SET F.A TO DIM ENTRY (IF ANY) LDB B,I (ELSE HAPPENS TO BE BCOMI ENTRY) STB F.A LDA F.IU ARRAY ? CPA ARR RSS YES. JMP STF08 NO. DO ZERO-DIM CASE. * ADB K2 YES. SAVE THE OFFSET F.A, LDA B,I STA T9STF LDA F.AF SO WE CAN PUT THE BCOMI POINTER STA B,I THERE. (FOR F4.3; OTHERWISE IS LOST) LDA F.A,I GET THE REFERENCE BIT. AND K8 SZA,RSS REFERENCED WITH SUBSCRIPTS ? JMP STF08 NO. GO DO ZERO-DIM TABLE. SKP * FULL TABLE WITH BOUNDS. * LDA F.AF YES. SAVE ADDR BCOM OFFSET ENTRY. STA T0STF LDA F.CCW IF 'S' OPTION, AND B40K IOR F.DIS OR DOUBLE INTEGER SUBSCRIPT, STA T5STF THEN T5SrTF#0. LDA F.D0+1 SAVE # WORDS PER ELEMENT. STA T6STF LDA F.RPL DEFINE THE PROGRAM ADDR OF TABLE. JSB DAF.F LDA F.ND SAVE # OF DIM. STA T3STF RAL,CLE *2, LOWER & UPPER BOUNDS. (E=0) ADA F.A COMPUTE ADDR OF UPPER BOUND OF ADA K2 LAST DIMENSION (NOT USED) STA T1STF AND SAVE IT. LDA F.ND FIRST WORD = # DIM. CCE SINGLE INTEGER. JSB BIC.F * * LOOP THRU DIMENSIONS & OUTPUT TO TABLE. * LDA T3STF # DIM CMA,INA NEGATE & SAVE AS COUNTER. STA T4STF JMP STF02 SKIP LAST UPPER BOUND. * STF01 LDA T1STF,I UPPER BOUND. OUTPUT CONSTANT/TEMP. JSB OTV.F STF02 LDA T1STF BACK UP POINTER TO PREVIOUS UPPER BOUND. ADA KM2 STA T1STF INA AND GET F.A OF CURRENT LOWER. LDA A,I IN (A). LDB T5STF IF .EMAP/.ERES, SZB,RSS JSB OTV.F THEN OUTPUT (NEGATED) LOWER BOUND. ISZ T4STF DONE NOW ? JMP STF01 NO. LOOP. SKP * NOW THE # WORDS PER ELEMENT AND THE OFFSET. * LDA T6STF # WDS PER. CCE AS SINGLE INTEGER. JSB BIC.F LDA T2STF,I FORMAL PARAM ? AND B7000 CPA DUM JMP STF06 YES. GO USE CALCULATED VALUE. * LDA T5STF IF .EMAP/.ERES, SZA JMP STF04 (NO) * LDA T8STF THEN OUTPUT REVERSED BASE ADDR. LDB T7STF JMP STF05 OUTPUT THE VALUE. * STF04 LDB T9STF DOUBLE INT. GET VALUE OF JSB GCD.F CONSTANT OFFSET TO ELEMENT NOP (0,,0) JSB DAD.F ADD THE BASE. DEF T7STF NOP IGNORE OVERFLOW. SWP USE IN REVERSED ORDER. STF05 CLE E=0 FOR BIC.F JSB BIC.F OUTPUT OFFSET, TWO WORDS. JMP STF08 DONE WITH DIMENSIONED CASE. * STF06 LDA T7STF FORMAL. USE BASE OR (0,0). JSB OCT.F OUTPUT THAT. SKP * NOW DO TABLE FOR ZERO-DIMENSION CASE. * STF08 LDA T0STF,I CHECK THE REFERENCE BIT. AND K8 SZA,RSS JMP STF10 IF NOT REFERENCED. * LDA T0STF YES. DEFINE ITS LOCATION. STA F.A JSB DL.F CLA,CCE OUTPUT ZERO. JSB BIC.F LDA T2STF,I IS IT A FORMAL ? AND B7000 CPA DUM JMP STF09 YES. * LDB T7STF NO. (B,A) = OFFSET. LDA T8STF CLE OUTPUT AS DOUBLE INT. JSB BIC.F JMP STF10 DONE. * STF09 LDA T8STF FORMAL. OUTPUT THE TEMP. JSB OCT.F STF10 LDA T2STF RESTORE F.A, STA F.A JMP END1A & GO FOR NEXT ITEM. SPC 1 T0STF NOP F.A OF BCOMI ENTRY. T1STF NOP RUNNING BOUNDS POINTER. T2STF NOP F.A OF VARIABLE NAME ENTRY. T3STF NOP NUMBER OF DIMENSIONS. T4STF NOP COUNTER FOR BOUNDS LOOP. T5STF NOP SAVED VALUE OF F.DIS T6STF NOP SAVED VALUE OF # WDS PER ELEMENT. T7STF NOP UPPER OFFSET OR TEMP FOR (0,,0) T8STF NOP LOWER OFFSET OR TEMP FOR (0,,0) T9STF NOP SAVED F.A OF CONST OFFSET TO (0,,0) KM2 DEC -2 B7000 OCT 7000 MASK FOR F.AT DUM OCT 5000 F.AT=DUM SKP * ************************** * * OUTPUT EMA TABLE VALUE * * ************************** SPC 1 * ENTRY: (A) = F.A OF CONSTANT OR TEMP. * * IF TEMP, JUST OUTPUT IT. * IF CONSTANT, OUTPUT AS A SINGLE INTEGER * IF F.DIS=0 AND DOUBLE IF F.DIS=1. * OTV.F NOP LDB A,I CONSTANT OR TEMP ? SLB JMP OTV01 NOT NAMED. CONSTANT. * JSB OCT.F NAMED. TEMP, OUTPUT IT. JMP OTV.F,I EXIT. * OTV01 LDB A GET VALUE. JSB GCD.F NOP STB F.IDI+1 SET E=0 FOR DOUBLE, 1 FOR SINGLE. LDB F.DIS CMB,CLE,LINB,SZB,RSS (E=1 IFF F.DIS=0; SKIP IF F.DIS#0) LDA F.IDI+1 (SINGLE, PUT IT IN (A).) LDB F.IDI+1 (RESTORE (B)) JSB BIC.F OUTPUT IT. JMP OTV.F,I DONE. SKP * ****************************************************** * * PROCESS NAMED A.T. ITEMS (EXCEPT EMA & CHAR TEMPS) * * ****************************************************** SPC 1 ENDP3 JSB GFA.F START SCAN. ENDP4 CLA CLEAR STA IGNOR THE IGNOR SWITCH FOR LABEL GEN. JSB GNA.F GET NEXT F.A SZA,RSS JMP ENDPA END OF ASSIGNMENT TABLE JSB FA.F FETCH ASSIGNS * * IF EMA, SKIP. * IF ARRAY, SUBROUTINE OR COMMON LABEL, IGNORE. * LDB F.IU CPB SUB IF SUB OR COMMON LABEL, JMP ENDP4 THEN DONE WITH IT. * LDA F.EM EMA ? SZA JMP ENDP4 YES. IGNORE THIS TRIP. * CPB ARR IF ARRAY, JMP ENDP4 ALREADY DEFINED * * IF STMT #, GO SEE IF DEFINED. * CPA F.IU JMP ENDP9 F.IU=0, STATEMENT # * * ASSIGN ADDRESS. * LDA F.A SPECIAL CHECK FOR CHAR TEMP. ADA K2 LDA A,I NAME. TEMP IF < 0. LDB F.IM TYPE. CPB CHAR IF F.IM=CHAR, SSA,RSS AND TEMP, RSS NO. ASSIGN ADDR. JMP ENDP4 YES. SKIP IT. * LDA F.AT IF CPA REL ALREADY DEFINED ISZ IGNOR SET SWITCH LDA F..E REFERENCED ? SZA,RSS JMP ENDPG NO. * JSB AA.F ASSIGN ADDR TO VARIABLES SKP ENDPG LDA F.AF SEE IF SPECIAL IN-LINE ADDRESS TEMP. RAL,CLE,SLA,ERA F.AF<0 ? INA,RSS YES. POINT TO BASE ADDR. JMP ENDPI NO. GO ON. * * SPECIAL IN-LINE ADDRESS TEMP DUE TO A DEF TO * AN ADDR TEMP BEING GENERATED WHILE THE LOCATION * D COUNTER HUNG ON A SYMBOL (IN IMPLIED DO). * LDA A,I GET THE LOCATION COUNTER BASE. LDB F.A GET OFFSET ADB K2 FROM THE ENTRY LDB B,I AND RBL,CLE,ERB CLEAR THE SIGN ADA B PUT FINAL ADDRESS IN A JSB DAF.F DEFINE ADDRESS OF THIS SYMBOL * * IF F.IM=ADDR AND WASN'T ALREADY F.AT=REL, * DEFINE IT TO BE A TWPE CONSTANT HERE. * ENDPI LDA F.IM IF CPA ADR ADDRESS RSS SKIP JMP ENDP4 * LDA IGNOR IF ADDRESS AND ALREADY DEFINED SZA,RSS NO NOT ALREADY DEFINED JMP ENDP4 FORGET IT * LDA TWPE ELSE DEFINE AS A PGM TMP JSB DIM.F AND ISZ TWA GIVE IT LDB TWA A NAME LDA F.A ADA K2 STB A,I JMP ENDP4 SKP BCOM OCT 3000 F.AT = BCOM COM OCT 4000 F.AT = COM DENX9 DEF ENDX9 ERROR RECOVERY ADDRESS. K2 DEC 2 KM3 OCT -3 TWA OCT 122000 B40K OCT 40000 TWPE EQU B40K ADR OCT 70000 K66 DEC 66 IGNOR NOP K8 DEC 8 K46 DEC 46 REL OCT 1000 AT =1 ARR OCT 600 SUB OCT 200 VAR OCT 400 * * CHECK STATEMENT #'S. * ENDP9 JSB NAM.F MOVE THE SYMBOL IN. DEF MSG+1 LDB MSG+1 FIRST TWO CHARS. LSR 8 (B) = FIRST CHAR. CPB K64 STMT # ? RSS JMP ENDP4 NO. * LDA F.AT YES. DEFINED ? CPA REL JMP ENDP4 YES. * ISZ ER.F ELSE LOG AS AN ERROR LDA K32 NO. INVALID STMT. NO. (UNDEFINED) JSB WAR.F SEND THE MESSAGE LDA K10.. LDB ENDK3 "UNDEFINED" JSB PSL.F PRINT OUT UNDEFINED MESSAGE ISZ F.ERF F.ERF=F.ERF+1 JMP ENDP4 * K32 DEC 32 SKP * *************************** * * PROCESS CHARACTER TEMPS * * *************************** SPC 1 ENDP1$A JSB OLR.F OUTPUT LOAD ADDR NOW. JSB GFA.F START SCAN. ENDPB JSB GNA.F NEXT F.A SZA,RSS DONE ? JMP OVRLP YES. ONWARD... * ADA K2 NO. TEMP ? LDA A,I SSA,RSS JMP ENDPB NO. SKIP IT. * LDA F.A,I YES. CHAR ? AND B170K CPA CHAR RSS JMP ENDPB NO. SKIP IT. * * CHAR TEMP. MAY ACTUALLY BE DESCRIPTOR. * LDA F.A SAVE F.A . STA T2END DLD F.A,I (B) = EXTENSION ADDR. STB T1END SAVE IT. LDA B,I (A) = DESCRIPTOR ADDR = 0, OR ITEM,I . RAL,CLE,SLA,ERA WHICH ? (CLEAR SIGN) RSS (ITEM,I) JMP ENDPE DESCRIPTOR. GO ALLOCATE SPACE. * STA F.A ITEM. CHECK IT OUT. JSB FA.F LDA F.AT WHAT ADDRESSING MODE ? CPA DUM IF FORMAL, RSS CPA BCOM OR LABELLED COMMON, JMP ENDPE JUST LEAVE SPACE. * LDA F.AF SET BYTE ADDRESS IN DESCRIPTOR. CLE,ELA LDB T1END ADB K2 STA B,I ENDPE LDA F.RPL DEFINE THE TEMP. STA T1END,I ISZ T1END SEND LENGTH. LDA T1END,I JSB OAD.F CLA OUTPUT 'DBL ITEM' OR 'DBL 0'. LDB F.AT CPB COM SET UP MR FIELD. LDA K2 ISZ T1END AND WORD ADDR. LDB T1END,I CLE,ERB JSB OW.F OCT 140000 LDA T2END RESTORE F.A STA F.A LDA REL SET F.AT = REL. JSB DAT.F JMP ENDPB DONE WITH THIS ITEM (TEMP). * B170K OCT 170000 F.IM MASK. SKP * OUTPUT ALL NUMERIC CONSTANT, TRYING FOR OVERLAP. * * ALGORITHM: ALL ITEMS ALREADY OUTPUT ARE KEPT AT THE START OF * THE LIST, AND ALL OTHERS FOLLOW; A POINTER IS KEPT TO THE LAST * ITEM OUTPUT. THE ITEMS NOT YET OUTPUT ARE PROCESSED, BY TYPE, * (LONGEST TYPE FIRST) BY CHECKING FOR OVERLAP WITH CONSTANTS * ALREADY OUTPUT. IF A MATCH IS FOUND, THE ITEM'S ADDRESS IS SET * BUT IT IS LEFT IN THE NON-OUTPUT PART. IF NO MATCH IS FOUND, * THE ITEM IS OUTPUT AND MOVED TO JUST AFTER THE PREVIOUSLY OUTPUT * ITEM. * * START UP LOOPS. * OVRLP JSB OLR.F START NEW RELOC RECORD, JUST IN CASE. LDA DOVTY SET UP INDEX INTO TYPE TABLE. STA T1OVR JSB GFC.F (A) = F.A, DUMMY HEAD OF LIST. STA T4OVR SAVE FOR SCANS OF OUTPUT LIST. STA T2OVR SET UP AS LAST ITEM OUTPUT. OVR01 ISZ T1OVR BUMP TO NEXT TYPE. LDA T1OVR,I DONE ? SZA,RSS JMP END02 YES. * LDA T2OVR START NEW SCAN AFTER LAST ITEM OUTPUT. STA F.A OVR03 LDA F.A SAVE F.A OF LAST ENTRY (FOR DELINKING). STA T3OVR JSB GNA.F GET NEXT ENTRY. SZA,RSS DONE ? JMP OVR01 YES. * LDA A,I GET ITS TYPE. AND B170K CPA T1OVR,I RIGHT ONE ? RSS (YES) JMP OVR03 NO. SKIP IT. * JSB FA.F YES. FETCH ASSIGNS. LDA F..E USED ? SZA,RSS JMP OVR03 NO. IGNORE IT. * LDA F.AT IF ALREADY DEFINED, CPA REL JMP OVR13 THEN JUST ADD TO OUTPUT LIST. SKP * HAVE A CANDIDATE. SEARCH OUTPUT LIST FOR DUPS. * JSB NWE.F (B) = # WDS. STB T5OVR T5OVR = LENGTH. LDA F.A GET ADDR OF VALUE. ADA K2 STA T6OVR T6OVR = ADDR FIRST WORD. LDA T4OVR SET UP TO SCAN OUTPUT LIST. STA F.A OVR05 LDA F.A JUST LOOKED AT LAST ONE ? CPA T2OVR JMP OVR13 YES. DIDN'T FIND MATCH. * JSB GNA.F NO. GO ON TO NEXT. LDA A,I GET IT'S TYPE, AND B170K STA F.IM JSB NWE.F SO CAN GET IT'S LENGTH. CMB -(OLD LEN)-1 ADB T5OVR (NEW LEN)-(OLD LEN)-1 STB T7OVR - # OF POSITIONS WHICH OVERLAP. DLD F.A,I SEg/T ADDR OF FIRST POSITION. STB T8OVR LDA F.A AND ADDR OF FIRST WORD OF OLD CONST. ADA K2 STA T9OVR * * THE OLD CONSTANT MUST BE AS LONG OR LONGER. IF * LONGER, THERE IS MORE THAN ONE WAY TO OVERLAP. * TRY THEM ALL. * OVR07 LDA T5OVR LENGTH OF NEW. CMA,INA SET UP LOOP COUNTER FOR MATCH. STA TAOVR LDA T6OVR SET UP POINTER INTO NEW CONSTANT. STA TBOVR LDA T9OVR (A) = POINTER INTO OLD CONSTANT. OVR09 LDB A,I WORD IN OLD. CPB TBOVR,I SAME AS WORD IN NEW ? RSS (YES) JMP OVR11 NO. THIS POSITION DOESN'T MATCH. * INA YES. BUMP POINTERS. ISZ TBOVR ISZ TAOVR BUMP COUNT. DONE ? JMP OVR09 NO. COMPARE ANOTHER WORD. SKP * NEW MATCHES SOME OLD. DEFINE IT. * LDA T3OVR FIRST, GET IT'S F.A STA F.A JSB GNA.F LDA REL F.AT = REL, JSB DAT.F LDA T8OVR F.AF = ADDR. JSB DAF.F JMP OVR03 GO ON TO NEXT. * * OVR11 ISZ T9OVR NO MATCH. BUMP STARTING POINT IN OLD, ISZ T8OVR AND THE CORRESPONDING ADDR, ISZ T7OVR AND COUNT POSITIONS. JMP OVR07 NOT DONE YET. TRY THIS ONE. * JMP OVR05 ALL POSITIONS TRIED. GET NEXT OLD CONSTANT. * * NO MATCH OR HAS ALREADY BEEN OUTPUT. PUT IN * OUTPUT LIST, AND OUTPUT IF NOT DONE ADREADY. * OVR13 CCB FIRST, DELINK FROM LIST. ADB T3OVR LDA B,I F.A OF NEW CONST. ADA KM1 STA F.A (NOTE! F.A IS ONE LOW AT THIS POINT) LDA A,I ITEM AFTER THIS ONE. STA B,I LINK ITEM BEFORE TO ITEM AFTER. CCB GET ITEM AFTER LAST IN OUTPUT. ADB T2OVR LDA B,I STA F.A,I LINK NEW ITEM TO REST OF LIST. ISZ F.A (RESTORE F.A TO CORRECT VALUE) LDA F.A LINK OLD END OF OUTPUT LIST TO NEW ITEM. STA B,I STA T2OVR SET NEW POINTER TO END OF OUTPUT LIST. STA F.A HAS CONSTANT ALREADY BEEN OUTPUT ? JSB FA.F LDA F.A LDB F.AT CPB REL I.E., F.AT=REL ? RSS YES. DON'T REPEAT IT. JSB OTC.F NO. OUTPUT IT. A=F.A JMP OVR03 DONE. GET NEXT ONE. * T1OVR NOP T2OVR NOP T3OVR NOP T4OVR NOP T5OVR NOP T6OVR NOP T7OVR NOP T8OVR NOP T9OVR NOP TAOVR NOP TBOVR NOP KM1 DEC -1 DOVTY DEF * TYPE TABLE, WITH ORDER TO OUTPUT CONSTANTS. OCT 140000 COMPLEX*16 OCT 120000 REAL*8 OCT 050000 COMPLEX*8 OCT 060000 REAL*6 OCT 020000 REAL*4 DBI OCT 100000 INTEGER*4 OCT 110000 LOGICAL*4 INT OCT 010000 INTEGER*2 OCT 030000 LOGICAL*2 OCT 0 (END OF TABLE) SKP * SCAN FOR ALL CONSTANTS & OUTPUT THEM. * END02 JSB GFC.F SET UP SCAN OF CONSTANTS. END03 JSB GNA.F NEXT ONE. SZA,RSS DONE ? JMP END04 YES. JSB FA.F NO. FETCH ASSIGNS. LDA F..E LDB F.AT SZA IF NOT REFERENCED OR CPB REL ALREADY DEFINED THEN JMP END03 IGNORE IT. * LDB F.IM CHARACTER ? CPB CHAR RSS (YES) JSB CER.F NO. COMPILER ERROR. * * OUTPUT CHARACTER CONSTANT. * LDA F.CSL IS LENGTH: SZA,RSS ZERO ? JMP END3D YES. DESCRIPTOR ONLY. * ADA KM21 NO. > 20 CHARS ? SSA,RSS JMP END3D YES. DATA PART ALREADY OUTPUT. * DLD F.A,I (B) = ADDR EXTENSION. ADB K2 = LOCATION FOR BYTE ADDR. LDA F.RPL PUT IT THERE. ADA K2 (DESCRIPTOR GOES FIRST) CLE,ELA STA B,I * * SET UP STRING DESCRIPTOR. * END3D DLD F.A,I PUT ADDR OF DESCRIPTOR LDSA F.RPL IN EXTENSION. STA B,I INB GET LENGTH. LDA B,I JSB OAD.F OUTPUT AS CONSTANT. DLD F.A,I GET BYTE ADDR. ADB K2 LDB B,I CLE,ERB CONVERT TO WORD ADDRESS, CLA ERA AND COPY DBL/DBR BIT TO A<15>. JSB OW.F OUTPUT 'DBL' / 'DBR' . OCT 140000 R=6. * * IF SHORT, OUTPUT CONSTANT NOW. * LDA F.CSL LENGTH. ADA KM21 SHORT OR LONG ? SSA,RSS JMP END03 LONG. DONE. * LDA F.CSL SHORT. GET LENGTH AGAIN. INA ROUND UP TO WORDS. CLE,ERA CMA,INA,SZA,RSS NEGATE. ZERO WORDS ? JMP END03 YES. DESCRIPTOR ONLY. * STA T1END NO. SET UP COUNT. LDA F.A SET UP POINTER TO DATA. ADA K2 STA T2END END3C LDA T2END,I OUTPUT AS ASCII. JSB OW.F OCT 040000 ISZ T2END BUMP DATA POINTER. ISZ T1END BUMP COUNT. DONE ? JMP END3C NO. LOOP. JMP END03 YES. DONE. * T1END NOP COUNT. T2END NOP POINTER INTO ASCII DATA. KM21 DEC -21 CHAR OCT 130000 F.IM=CHAR * * SCAN FOR ALL DEF'S & OUTPUT THEM TOO. * END04 JSB GFD.F SET IT UP. END05 JSB GNA.F NEXT. SZA,RSS DONE ? JMP END06 YES. JSB FA.F NO. FETCH ASSIGNS. LDA F..E LDB F.AT SZA IF NOT REFERENCED OR CPB REL ALREADY DEFINED THEN JMP END05 IGNORE IT. JSB PDF.F OTHERWISE, OUTPUT IT. JMP END05 SKP * *************************************** * * OUTPUT THE UNIT-FILE MAP & FCB POOL * * *************************************** SPC 1 END06 LDA F.SBF IF SUBPROGRAM, LDB F.DNB OR SEGMENT, ADB K9 LDB B,I SZA,RSS CPB K5 JMP ENDX9 THEN NO UNIT-FILE MAP. * JSB OLR.F OUTPUT LOA_tD ADDR, AS USUAL. LDB F.RPL DEFINE ADDR OF UNIT-FILE MAP. LDA F.UFM INA STB A,I CCA FTN4X FLAG = -1. JSB OAD.F LDA F.#M 'ABS M' JSB OAD.F LDA F.#N 'ABS N' JSB OAD.F LDA F.#B 'ABS B' JSB OAD.F LDA F.#S 'ABS S' RAL,CLE,SLA,ERA CLEAR FLAG; WAS $FILES USED ? RSS YES. CLA,INA NO. S=1. JSB OAD.F * LDA F.#M ALLOCATE 4*M WORDS FOR UNIT-FILE MAP. ALS,ALS STA T1END AMOUNT SO FAR. LDA F.#S DS ? CPA B100K (FILES PRESENT BUT S=0) JMP END6A YES. * * NON-DS. * LDA F.#N NO. IF N = 0, SZA,RSS JSB OAD.F THEN DO 'DEF 0' LDB .FFIO ELSE DO 'DEF .FFIO' SZA (A=0 ON RETURN FROM OAD.F) JSB ODD.F * LDB F.#B B (NOTE: A=0, SO ASL SAFE.) INB,SZB,RSS IF -1 (FREESPACE), JMP END6B THEN JUST ALLOCATE UFMP SPACE. * LDB F.#B ELSE ALLOW FOR BUFFERS, DCB'S & FCB'S. ASL 2 4B ADB F.#N 4B+N ASL 5 32(4B+N) = 128B + 32N JMP END6B NOW ALLOCATE THAT PLUS UFMP SPACE. SKP * DS. * END6A LDA F.#N FILES ? LDB .DNRW IF NOT, .DNRW SZA LDB .DSRW IF SO, .DSRW JSB ODD.F DEF TO ONE OR OTHER. LDA F.#N N MPY K20 20N = SPACE FOR FCB'S & DCB'S. LDB A (B) = # WORDS. * * ALLOCATE (B) WORDS BUFFER SPACE & EXIT. * END6B LDA K84 (ERROR NUMBER) SSB,RSS ERROR IF ALREADY OVER 32767; ADB T1END ADD UFMP SPACE. SSB,RSS ERROR IF OVER 32767; ADB F.RPL (DO THE BSS) SSB IF TOTAL IS OVER 32767, JMP F.ABT THEN ABORT: MEM OFL. * STB F.RPL ELSE FINISH ALLOCATE, j JMP ENDX9 AND QUIT. * .FFIO ABS 261 .DNRW ABS 344 .DSRW ABS 345 K84 DEC 84 K5 DEC 5 K9 DEC 9 K20 DEC 20 B100K OCT 100000 SKP * ******************************** * * ROUTINE TO OUTPUT A CONSTANT * * ******************************** * OTC.F NOP STA F.A SET THE A.T. ADDRESS JSB FA.F FETCH ASSIGNS LDA F.AT HAS IT ALREADY BEEN OUTPUT ? CPA REL RSS YES. DON'T CHANGE LOCATION. JSB DL.F NO. DEFINE IT TO BE HERE. JSB FC.F MOVE THE CONSTANT TO F.IDI FOR OUTPUT. JSB OC.F SEND IT JMP OTC.F,I RETURN SPC 2 * ************************************************* * * ROUTINE TO ESTABLISH A CONSTANT AND OUTPUT IT * * ************************************************* * * * ENTER E=0 FOR DOUBLE INT, E=1 FOR INT, A,B= VALUE * BIC.F NOP BUILD INTEGER CONSTANT DST F.IDI SET ITS VALUE LDA INT GET THE TYPE SEZ,RSS IF TO BE DOUBLE INTEGER LDA DBI GET TYPE JSB ESC.F ESTABLISH CONSTANT JSB AI.F ASSIGN IT LDA F.A AND JSB OTC.F OUTPUT IT JMP BIC.F,I RETURN A=0,E=1 SPC 2 ENDK3 DEF MSG MSG ASC 10, UNDEFINED K10.. DEC 10 K64 DEC 64 K99 DEC 99 .BAD. ABS 77 SKP * ******************************* * * OUTPUT A CONSTANT OR A TEMP * * ******************************* SPC 1 * ENTRY: (A) = F.A OF EITHER ONE. TEMP GENERATED WITH ZEROES. * OCT.F NOP LDB A,I CHECK IF NAMED. SLB,RSS JMP OCT01 IF SO, IS TEMP FOR VAR DIM. * JSB OTC.F ELSE PRODUCT CONSTANT. JMP OCT.F,I AND EXIT. * OCT01 STA F.A VAR DIM. ALLOCATE TEMP. JSB DL.F ASSIGN TEMP HERE. JSB FA.F COMPUTE F.D0 = # WORDS. LDA F.D0+1 AND SET AS COUNTER. CMA,INA STA T1OCT OCT02 CLA OUTPUT THAT MAY ZEROES. JSB OAI.F ISZ T1OCT COUNT, JMP OCT02 AND LOOP. JMP OCT.F,I ALL DONE. * T1OCT NOP COUNTER FOR LOOP. SPC 2 * UPDATE THE FOLLOWING WHEN REVISING THE COMPILER: * ENDK5 DEF CMPID CMPID DEC 21 WORDCOUNT OF FOLLOWING TEXT ASC 14, FTN4X COMPILER: HP92834 REV ASC 7,.2030 (800821) SKP * END. IF ERRORS, OUTPUT 'JSB .BAD.' . * ENDX9 LDB .BAD. LDA F.ERF # OF ERRORS IN COMPILATION SZA JSB ODF.F 'JSB .BAD.' CLA JSB SKL.F YES, SKIP A LINE. * * END OF INTERPASS PROCESSING. FIRE UP PASS 3. * ENDX3 JSB OS.F FLUSH THE CURRENT RELOC. RECORD. JSB EOF.C END FILE ON 2ND PASS FILE. DEF C.SC0 JMP PASSE ERROR SEND 99 ERROR * LDB ENDK5 PRINT THE COMPILER ID LDA B,I NOW INB JSB PSL.F CLA JSB SKL.F SKIP A LINE JMP END.F,I NOW RETURN TO THE SEGMENT FOR PASS 3. * * DISASTER: PASS FILE ERROR. * PASSE LDA K99 ERROR ON EOF JMP F.ABT ABORT THE COMPILE * END ASMB,Q,C HED FTN4X COMPILER (F4X.6:CODE GENERATOR, PASS 2) NAM F4X.6,5 92834-16003 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 6 * *************************************** * * THIS OVERLAY IS THE CODE GENERATOR. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE ENTRY EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.CC COLUMN COUNT EXT F.CCW FTN OPTION WORD EXT F.D DO TABLE POINTER EXT F.ERX ERROR EXIT ADDRESS. EXT F.FLN FIRST LINE # IN THIS MODULE. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.LNA ADDRESS OF CURRENT LINE EXT F.LNL LENGTH OF CURRENT LINE EXT F.LNN LINE # OF CURRENT LINE EXT F.NC NAME CHANGE FLAG. EXT F.PAS PASS NUMBER. EXT F.PTF PERMANENT TEMP FLAG. EXT F.RES F.A OF CURRENT RESULT. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.SEG LOAD A NEW SEGMENT EXT F.T # WORDS ON STACK 1 EXT F.TL LENGTH OF TITLE LINE. EXT F.TTL LOCATION OF TITLE LINE. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT APT.F ALLOCATE 'PERMANENT' TEMP. EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT CAT.F COMMON CODE FOR TEMP ALLOCATION. EXT DAT.F DEFINE (F.AT) EXT DL.F DEFINE LOCATION SUBROUTINE. EXT^ EJP.F PAGE EJECT. EXT ER.F ERROR PRINT SUBROUTINE. EXT FA.F FETCH ASSIGNS EXT GCD.F GET CONSTANT INTEGER, IN DBL INT FORMAT. EXT IN2.F INITIALIZE OA.F EXT ITS.F INTEGER TEST EXT NST.F TEST FOR NOT A SUBROUTINE NAME EXT OAI.F OUTPUT ABS. INSTRUCTION EXT OMR.F OUTPUT MEMORY REF. INSTRUCTION EXT OLR.F OUTPUT LOAD ADDR. EXT OS.F FLUSH OA.F'S BUFFER. EXT PSL.F PRINT SOURCE LINE EXT RS1.F READ WORD FROM PASS FILE 1. EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) * * ENTRY POINTS IN F4.6 * ENT F.COC CURRENT OPCODE COUNT. ENT F.COP CURRENT OPCODE. ENT F.DFS 'DO' FINAL, STEP F.A'S. ENT F.GRX DEF TO GRD.F ENT F.LA1 PASS FILE ONE, 1ST LOOK-AHEAD. ENT F.LA2 PASS FILE ONE, 2ND LOOK-AHEAD. ENT F.RTP RESULT TYPE ENT F.S1N NEXT-TO-TOP OF STACK 1. ENT F.SRL F.A OF STMT FCT HIDDEN PARAM. ENT F.TPX TYPE OF EXPRESSION BEING PROCESSED. * ENT ATC.F ALLOCATE TEMP CELL. ENT ATM.F CONDITIONALLY ALLOCATE TEMP (TWO OPNDS). ENT DEF.F PRODUCE A DEF TO (B). ENT F1T.F FREE TEMP IF TOS. ENT F2T.F FREE TEMPS IF TOS OR NEXT-TO-TOP. ENT ITN.F INITIALIZE TEMP NAMES. ENT RD.F PASS FILE ONE READ WITH LOOK-AHEAD. ENT TAS.F CONDITIONALLY ALLOCATE TEMP. (LOOK-AHEAD) * * ENTRY POINTS IN AOP.F (ARITH & LOG & REL OP CODE GEN.) * EXT ADD.F ADD. EXT AND.F AND. EXT CO.F COMMUTE TOP TWO OPERANDS. EXT CTS.F CONVERT TOP OF STACK. EXT DIV.F DIVIDE. EXT EQV.F .EQV. EXT .EQ.F .EQ. EXT EXP.F EXPONENTIATION. EXT .GE.F .GE. EXT .GT.F .GT. EXT .LE.F .LE. EXT .LT.F .LT. EXT MP1.F MAP TOS IF EMA. EXT MP2.F MAP TOP TWO STACK ITEMS IF EMA. EXT MPY.F MULTIPLICATION. EXT NEG.F UNARY MINUS. EXT NOT.F .NOT. EXT .NE.F .NE. EXT .OR.F .OR. EXT SUB.F SUBTRACTION. EXT XOR.F .XOR. .NEQV. .EOR. * * ENTRY POINTS IN KWC.F (KEYWORD STMT CODE GEN) * EXT AGT.F ASSIGNED GOTO. EXT AIF.F ARITHMETIC IF. EXT ASP.F ASSIGN STATEMENT. EXT CAD.F ASCII DATA OUTPUT (FORMAT & DATA STMTS) EXT CGT.F COMPUTED GOTO. EXT DO.F DO. EXT DTA.F DATA STATEMENT. EXT DOT.F END OF DO LOOP. EXT EBR.F ENDFILE/BACKSPACE/REWIND (SAVE CODE). EXT EIF.F ENDIF. EXT ELS.F ELSE. EXT GTO.F GOTO. EXT IDO.F IMPLIED DO. EXT ILA.F ORDERING OF IMPLIED DO. EXT IOA.F I/O WHOLE ARRAY. EXT IOE.F I/O STATEMENT END (EXCEPT R/W). EXT IOK.F I/O STATEMENT KEYWORD. EXT IOL.F I/O LIST ITEM. EXT IOS.F I/O STATEMENT START. EXT LIF.F LOGICAL IF. EXT NR.F IMPLIED DO 'RECORD'. EXT PTM.F PROGRAM TERMINATION. (END) EXT RTN.F RETURN. EXT RWE.F READ/WRITE END. EXT STP.F PAUSE & STOP. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT CAR.F CLEAR ALL REGISTER DATA, INCL MAP STATUS. EXT FT.F FIND TYPE. EXT GRD.F GET REGISTER DATA. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT LD.F LOAD. EXT MIM.F MAP ITEM MODE. EXT PO1.F POP ONE ITEM OFF STACK. EXT PU1.F PUSH ONE ITEM ONTO STACK. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION. (LOAD TOS). EXT SMT.F SAVE MAPPED DATA. (FREE MAPS) EXT ST.F STORE. EXT VS1.F VOID STACK 1. * * ENTRY POINTS IN SAM.F *  EXT EA?.F SKIP IF (F.A) IS IN EMA. EXT FPE.F FORM PROGRAM ENTRANCE CODE. EXT SAL.F SUBROUTINE OR ARRAY REF, LEFT PAREN. EXT SAR.F SUBROUTINE OR ARRAY REF, RIGHT PAREN. * * COMPILER LIBRARY ROUTINES USED. * EXT WRT.C WRITE FILE ROUTINE. EXT C.SC0 2ND PASS FILE FCB. * * OTHER LIB. UTILITIES * EXT .MVW MOVE WORDS MACRO EXT IFBRK BREAK TEST. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 1 DEC 6 OVERLAY NUMBER SKP * *------------------* * * START HERE * * *------------------* * F4.6 ISZ F.PAS SET PASS NUMBER. JSB CAR.F INITIALIZE REGISTERS. LDA F.D INITIALIZE THE STACK. STA F.S1B JSB VS1.F LDA DP2ER SET UP ERROR EXIT ADDRESS. STA F.ERX CCA RESET LINE #. (BUMPED BEFORE USED) ADA F.FLN STA F.LNN JSB IN2.F INITIALIZE OA.F JSB RD.F INITIALIZE RD.F : JSB RD.F TWO WORDS OF LOOK-AHEAD. * * MAIN LOOP. READ PASS FILE. * RDPSF JSB RD.F NEXT ! CPA KM1 END ? JMP EXIT YES. GO FINISH UP. RAL,CLE,SLA,ERA CHECK & CLEAR SIGN. JMP RDPS2 OPERAND. * STA FULOP OPERATOR & COUNT. SAVE. AND B377 EXTRACT OPERATOR & SAVE. RDPS1 STA F.COP XOR FULOP EXTRACT COUNT & SAVE. ALF,ALF STA F.COC CLA ZERO THE COUNT OF WORDS USED. STA F.RSC (RECOVERY SKIP COUNT) * LDA F.COP CHECK OUT THE OPCODE: CMA,SSA,INA,SZA IF NEGATIVE OR ZERO, RSS (NO) HLT 12 PUNT. * ADA TBLSZ NO. (A) = (MAX) - (ACTUAL) SSA IN RANGE ? HLT 12 NO. PUNT. * LDA F.COP GET ROUTINE ADDR. ADA OPTBL LDA A,I LDB F.COP ENTER WITH (B) = OPCODE. JS(B A,I PROCESS OPERATOR. JMP RDPSF NEXT. * RDPS2 JSB PU1.F OPERAND. JUST STUFF ON STACK. JMP RDPSF SKP * ERROR CLEANUP. * F.P2E LDA F.RSC FIRST, SKIP REST OF OPERATOR. CMA,INA (ERRORS ONLY OCCUR ON OPERATORS) ADA F.COC F.COC-F.RSC = AMOUNT TO SKIP. F.P2A CMA,SSA,INA,SZA IS THERE ANY ? RSS YES. JMP F.P2C NO. (F.RSC>F.COC FOR 'IF' SHORT-CIRCUIT) * STA F.COC YES. SKIP IT. F.P2B JSB RD.F ISZ F.COC JMP F.P2B * F.P2C JSB RD.F LOOK FOR NEW STATEMENT. CPA KM1 END ? JMP EXIT YES, NO BREAK. * SSA OPEREAND ? JMP F.P2C YES, IGNORE. * STA FULOP SAVE. AND B377 EXTRACT OPERATOR & SAVE. STA F.COP XOR FULOP EXTRACT COUNT & SAVE. ALF,ALF STA F.COC CLA ZERO THE COUNT OF WORDS USED. STA F.RSC (RECOVERY SKIP COUNT) LDA F.COP CHECK OUT THE OPCODE: CPA K28 28 ? JMP P2C1 YES. GO ECHO LINE. * CPA K29 29 ? JMP P2C2 YES. GO COUNT LINE. * CPA K46 START-OF-STATEMENT ? JMP RDPS1 YES. DONE WITH CLEANUP. * XOR FULOP NO. SKIP JUNK AFTER THIS OPERATOR. ALF,ALF JMP F.P2A (A) = AMOUNT TO SKIP. * P2C1 JSB LST.F ECHO SKIPPED LINE. JMP F.P2C CONTINUE SKIPPING. * P2C2 JSB LNL.F COUNT SKIPPED LINE. JMP F.P2C CONTINUE SKIPPING. * * EXIT PASS 2. FLUSH CROSS-REF BUFFER, LOAD SEGMENT 5. * EXIT JSB CRPFL FLUSH. JSB OS.F ALSO FLUSH OA.F BUFFER LDB K5 LOAD SEG 5. JMP F.SEG SKP DP2ER DEF F.P2E PASS 2 ERROR EXIT ADDRESS. FULOP NOP COUNT & OPERATOR. F.COC NOP COUNT. (RIGHT JUSTIFIED) F.COP NOP OPERATOR. F.RSC NOP # WORDS USED FROM CURRENT OPERATOR. F.GRX DEF GRD.F X ACCESS: F.GRD => F.GRX => GRD.F OPTBL DEF TABLE-1 ADDR OPERATOR JUMP TABLE. K5 DEC 5 K28 DEC 28 K29 DEC 29 K46 DEC 46 SPC 2 * ******************************* * * NOTE START OF NEW STATEMENT * * ******************************* SPC 1 SNS.F NOP JMP SNS.F,I NOTHING TO DO FOR NOW. SPC 2 * *********************************** * * INITIALIZE TEMP CELL BASE NAMES * * *********************************** * ITN.F NOP * LDA DLINT JUST ZERO THEM OUT. LDB DLIN1 BY USING .MVW AND CONSTANT ZERO. JSB .MVW DEF K12 NOP JMP ITN.F,I DONE. SPC 2 * ***************** * * SEGMENT START * * ***************** SPC 1 SSS.F NOP LDA F.RPL SAVE F.RPL, STA T1SSS CLA WHILE WE ORG TO THE START, STA F.RPL JSB OLR.F JSB OAI.F AND OUTPUT 'NOP' TO KEEP LOADR HAPPY. LDA T1SSS THEN ORG BACK. STA F.RPL JSB OLR.F JMP SSS.F,I * T1SSS NOP SKP * ****************** * * INITIALIZATION * * ****************** * * PARAM IS TYPE OF INPUT EXPRESSION: * * = 0, STATEMENT FUNCTION. * =-1, SUBROUTINE CALL STATEMENT. * =-2, DO INITIAL PARAMETER. * =-3, LOGICAL UNIT #. * =-4, DO STATEMENT TERMINAL OR STEP-SIZE PARAMETER. * =-5, COMPUTED GO TO INDEX EXPRESSION. * =-6, ASSIGNMENT STATEMENT. * =-7, IF EXPRESSION. * =-8, INPUT I/O LIST ELEMENT OR L-VALUED KEYWORD. * =-9, OUTPUT I/O LIST ELEMENT OR R-VALUED KEYWORD. * INIT NOP JSB RD.F (A) = TYPE. STA T1INI SAVE FOR THE INHIBIT BIT, AND B377 AND SET UP F.TPX = NEGATIVE TYPE. CMA,INA STA F.TPX CPA KM5 COMPUTED GOTO ? (INHIBIT BIT = 0) JMP INIT1 YES, DON'T CLOBBER STACK. LD A F.D INITIALIZE STACK 1 (OPERAND STA F.S1B STACK ) BOUNDS TO LAST WORD STA F.S1T OF DO TABLE OR LAST WORD OF STA F.S1N DATA POOL. CLA STA F.T NO. OF WORDS ON STACK 1 INIT1 JSB CAR.F CLEAR ALL REGISTER STATUS. LDA T1INI INITIALIZE TEMPS ? ALF,ALF SLA,RSS (BIT 8 INHIBITS IT) JSB ITN.F YES. INITIALIZE TEMP CELLS. * * ENTRY SECTION * LDA F.A SAVE F.A OF POSSIBLE STATEMENT STA T1EE FUNCTION NAME LDB F.TPX IF STATEMENT FUNCTION, LDA F.SRL AND HIDDEN PARAMETER, SZB,RSS WELL ? SZA,RSS RSS (NO) JSB PU1.F YES. PUSH THAT PARAM ONTO STACK. JMP INIT,I INITIALIZATION DONE. * * COUNTERS FOR RE-USABLE TEMP CELLS. * DLINT DEF T.INT-1 USED TO ZERO OUT THE T.INT ARRAY. DLIN1 DEF T.INT DEC 0 THIS WORD MUST EXACTLY PRECEDE THE BSS!! T.INT BSS 12 ROOM FOR TYPES THRU TYPE 12 (COMPLEX*16) T1INI NOP FOR ORIGINAL PARAM WORD. SKP * ************************** * * EXPRESSION TERMINATION * * ************************** * * GET EXIT ADDRESS & EXT FLAG. IF NO EXT CHECK, EXIT. * TERM NOP LDB F.TPX CHECK TYPE OF INPUT EXPRESSION. ADB DTERM FIND EXIT ADDRESS. LDB B,I RBL,CLE,SLB,ERB CHECK IF EXTERNAL NAME ? JMP B,I NO. EXIT NOW. * * ELSE MAKE SURE NOT AN EXTERNAL NAME. * STB T4EE (SAVE EXIT ADDRESS) LDB F.S1T,I RESULT IS IN REGISTERS? SZB,RSS JMP EE70 YES. STB F.A NO - IF RESULT IS AN JSB FA.F EXTERNAL NAME, FLAG AS JSB NST.F ERROR 25. OTHERWISE CONTINUE. EE70 JMP T4EE,I EXIT. * DEF EE71 -9: OUTPUT LIST. CHECK. DEF EE71 -8: INPUT LIST. CHECK. DEF EE71 -7: IF. CH@ECK. DEF EE73,I -6: ASSIGNMENT. DEF EE71 -5: COMPUTED GOTO. CHECK. DEF EE63 -4: DO STEP/TERM. CHECK. DEF EE72 -3: UNIT #. CHECK. DEF EE60,I -2: DO INITIAL. DEF EE73,I -1: SUBR CALL. DEF EE67 0: STMT FCT. CHECK. DTERM DEF *-1 ADDRESS TYPE 0. * * END OF UNIT # - DITTO, AND MAKE SURE INTEGER. * EE72 JSB GT1.F F.IM = TYPE. JSB ITS.F ERROR IF NOT INTEGER. LDA INT ALSO, CONVERT INT*4 TO INT*2. JSB CTS.F (ON TOP OF STACK) EE71 JMP TERM,I * * I/O LIST ELEMENT. PROCESS IT ELSEWHERE. * EE73 JSB CAR.F VOID REGISTERS & MAPS, JUST IN CASE. JMP TERM,I EXIT. SKP * 'DO' INITIAL VALUE. CLEAR FLAG. * EE60 CLA CLEAR THE 'FINAL' & 'STEP' F.A'S. STA F.DFS STA F.DFS+1 LDA F.RTP SAVE THE 'DO' INDEX TYPE. STA F.DIT JMP EE73 VOID REG & EXIT. SPC 2 * DO STEP/TERM. CONVERT TO INDEX VAR TYPE. * EE63 LDA F.DIT CONVERT TO INDEX VAR TYPE. JSB CTS.F CONVERT TOS IF NEEDED. JSB MP1.F AND MAP IT IN, IF EMA. * LDB F.S1T,I (B) = RESULT. SZB IN REGISTER ? CPB K1 RSS YES. LOAD IF ADDR, STORE IN TEMP. JMP EE64A NO. (B) = F.A OF RESULT. * JSB SCG.F LOAD TO REG. LDA F.DIT ALLOCATE PERMANENT TEMP FOR IT. JSB APT.F (A) = F.A OF TEMP. STA T3EE SAVE THAT. LDB F.S1T,I STORE IN TEMP. JSB ST.F LDB T3EE RETURN F.A OF THE TEMP. EE64A LDA F.DFS SEE IF 'FINAL' OR 'STEP'. SZA WHICH ? STB F.DFS+1 'STEP'. SAVE IN F.DFS+1. SZA,RSS STB F.DFS 'FINAL'. SAVE IN F.DFS. JSB PO1.F POP OFF STACK. LDB F.DFS+1 STEP F.A OR ZERO. JSB GCD.F CHECK IF CONSTANT. JMP EE73 NO. * uS SZA,RSS YES. ZERO ? SZB JMP EE73 NO. O.K. * LDA K23 YES. WARNING 23. JSB WAR.F JMP EE73 NOW WAIT FOR STEP OR END. * F.DFS DEC 0,0 'DO' FINAL, STEP F.A'S. F.DIT NOP 'DO' INDEX VARIABLE TYPE. K23 DEC 23 SKP * STMT FCT. SAVE RESULT, MAKE TEMPS PERMANENT. * EE67 LDB T1EE IS IT REGISTER OR MEM RESULT ? JSB FT.F (A) = TYPE. JSB MIM.F MAP IT. SSB REG OR MEM ? JMP EE67A MEM. ALREADY STORED IT. * LDB T1EE REGISTER. CONVERT IF NEEDED. JSB FT.F JSB CTS.F LDB F.S1T,I (B) = TOS. JSB LD.F LOAD RESULT. * EE67A DLD T1EE,I (B) = EXTENSION ADDR. LDB B,I (B) = ENTRY POINT ADDR. LDA JMPII OUTPUT 'JMP ENTRY,I' JSB OMR.F JMP EE73 DONE. (VOID REG) SPC 1 KM5 DEC -5 KM1 DEC -1 K1 DEC 1 K12 DEC 12 INT OCT 010000 JMPII OCT 126000 T1EE NOP T3EE NOP T4EE NOP F.SRL NOP F.A OF (STMT FCT) HIDDEN PARAM. F.RTP NOP RESULT TYPE. F.S1N NOP NEXT TO TOP STACK LOCN F.TPX NOP TYPE OF INPUT EXPR. SPC 2 * ************************** * * SIMPLE SUBROUTINE CALL * * ************************** SPC 1 SSC.F NOP JSB SAL.F MARK THE SUBROUTINE NAME, JSB SAR.F AND GENERATE THE CALL. JMP SSC.F,I DONE! SKP * ******************** * * ASSIGN OPERATION * = * ******************** SPC 1 AO.F NOP LDB F.S1N,I GET RESULT TYPE. JSB FT.F JSB CTS.F CONVERT OPERAND IF NEEDED. LDA F.S1N,I IF DESTINATION CPA F.S1T,I =SOURCE, (MAYBE CONVERT USED TAS.F) JMP AO02 THEN SKIP IT. * JSB MP2.F MAP EITHER IF IN EMA. JSB SCG.F LOAD SOURCE VARIABLE LDA F.S1N,I A.T. POINTER OF STORING VAR. LDB F.S1T,I OA.T. POINTER OF LOADING VAR. JSB ST.F AO02 JSB PO1.F POP OPERANDS OFF STACK, JSB PO1.F BUT DON'T PUSH ANYTHING ONTO IT. JMP AO.F,I EXIT. * T1AO NOP F.A OF RHS WHILE RESOLVING EMA ARRAY. SPC 2 * *************************** * * INVERSE ASSIGN OPERATOR * * *************************** SPC 1 IAO.F NOP CCB GET THE ARRAY F.A ADB F.S1B LDB B,I RBL,CLE,ERB WIPE OFF THE ARRAY MARK BIT. JSB FT.F GET ITS TYPE, JSB CTS.F AND CONVERT RHS TO THAT. JSB MP1.F ALSO MAP RHS, IF NOT DONE YET. JSB SMT.F SAVE CURRENT MAPPED DATA, JSB SBR.F AND REGISTERS. JSB PO1.F POP RHS OFF STACK, STA T1AO AND SAVE, WHILE WE JSB SAR.F FINALLY RESOLVE THE ADDRESS. LDA T1AO NOW PUT THE VALUE BACK, JSB PU1.F AND JSB AO.F PERFORM AN ORDINARY ASSIGN. JMP IAO.F,I DONE. SKP * ******************************************** * * LOOK AHEAD FOR ASSIGNMENT TO AVOID TEMP * * ******************************************** * * TAS.F TRIES TO OPTIMIZE OUT CALLS TO .DFER & .CFER BY LOOKING * AHEAD FROM OPERATIONS WITH DBL/RE8/CPX RESULTS. IF (F.RTP) IS * DBL/RE8/CPX, THEN (F.RES) WILL BE SET TO THE RESULT F.A . * * MUST HAVE: 1) CURRENT OP IS = (CONVERSION). * OR 2) NEXT OP IS = (NORMAL OPERATION). * OR 3) NEXT OP IS (UNARY -), THEN =. * AND: THE NEXT OPERAND IS OF TYPE (F.RTP) * AND IS NOT IN EMA. * * ENTRY: (F.RTP) = RESULT TYPE OF CURRENT OPERATION. * (B) = POINTER TO NEXT OPERAND (ON STACK). * EXIT: (F.RES) = F.A TO USE FOR DEF TO RESULT. (DBL/RE8/CPX ONLY) * TAS.F NOP STB T1TAS SAVE THE OPERAND POINTER LDA F.RTP REGISTER RESULT ? JSB MIM.F SSB,RSS (IF SO, B>=0) JMP TAS.F,I NO. IGNORE CALL. * LDA F.COP YES. IS CURRENT OPERATOR ASSIGNMENT ? CPA EQOPC (MUST BE CONVERSION) JMP TAS02 YES. * LDA F.LA1 NO. IS NEXT OPERATOR ASSIGNMENT ? CPA EQOPC JMP TAS02 YES. GO CHECK TYPE. * CPA NGOPC HOW ABOUT NEGATION ? RSS JMP TAS01 NO. ASSIGN TEMP. * LDA F.LA2 YES. THEN ASSIGNMENT ? CPA EQOPC JMP TAS03 YES. O.K. UNLESS REGISTER. * TAS01 LDA F.RTP NO. ALLOCATE TEMP. JSB ATC.F STA F.RES SET FOR RESULT TO BE THERE. JMP TAS.F,I THAT'S ALL. * TAS03 LDB T1TAS,I NEGATE THEN ASSIGN. REGISTER ? SZB (WE CAN'T HANDLE THAT) CPB K1 JMP TAS01 YES. GO WITH TEMP. * LDA B,I ALSO CAN'T DO ADDR TEMPS. AND B170K CPA ADDR JMP TAS01 * TAS02 LDB T1TAS,I GET F.A OF NEXT OPERAND. JSB FT.F CHECK ITS TYPE CPA F.RTP SAME AS RESULT ? RSS YES. IT WORKS (IF NOT EMA). JMP TAS01 NO. ALLOCATE TEMP. * LDA T1TAS,I ALL O.K. UNLESS EMA. STA F.A JSB EA?.F HOW ABOUT IT ? RSS (NO. O.K.) JMP TAS01 EMA. IT ISN'T MAPPED YET. * STA F.RES WORKS. SET RESULT TO BYPASS TEMP. JMP TAS.F,I DONE. SKP T1TAS NOP EQOPC EQU K1 = OPERATOR #. K4 DEC 4 NGOPC EQU K4 UNARY MINUS OPERATOR #. ADDR OCT 70000 F.IM=ADDR B170K OCT 170000 F.IM MASK SPC 2 * **************************************** * * 2 OPERAND LOOK AHEAD FOR ASSIGNMENT * * **************************************** * * THIS ROUTINE CALL TAS FOR 2 OPERANDS * ENTRY: (F.RTP) = RESULT TYPE. *  EXACTLY TWO STACK ENTRIES FOR CURRENT OPERATION. * ATM.F NOP CONDITIONAL TEMP (NONE IF = NEXT) LDB F.S1N GET ADDRESS OF THE NEXT OPERAND INB TO B JSB TAS.F CALL TAS TO TEST IT AND AL}LOCATE JMP ATM.F,I RETURN SKP * **************** * * GENERATE DEF * * **************** SPC 1 DEF.F NOP OPERAND ASSUMED NOT TO BE IN REG CLA JSB SOA.F OUTPUT THE DEF JMP DEF.F,I SPC 2 * ************************ * * ALLOCATE A TEMP CELL * * ************************ SPC 1 ATC.F NOP LDB F.TPX ARE WE IN A STATEMENT FUNCTION ??? SZB,RSS JMP ATC01 YES. GO USE A PERMANENT ONE. * LDB F.PTF IS THE PERMANENT TEMP FLAG SET ? SZB JMP ATC01 YES. USE PERMAMENT ONE. * STA F.IM NO. (A)=F.IM OF TEMP CELL NEEDED ALF MAKE F.IM A SMALL INTEGER ADA DLINT (A)_ ADDRESS OF TEMP CELL NUMBER. ISZ A,I BUMP TO THE NEXT TEMP. LDA A,I FETCH THE TEMP NUMBER. (TRANSIENT TEMP) JSB CAT.F DO IT. JMP ATC.F,I DONE. * ATC01 JSB APT.F STMT FCT. MAKE IT PERMANENT. JMP ATC.F,I DONE. B377 OCT 377 K2 DEC 2 SKP * ***************************** * * FREE TEMP IF TOP-OF-STACK * * ***************************** SPC 1 * F1T.F CHECKS THE ITEM AT F.S1T, THE TOP OF THE OPERAND STACK. * IF IT IS A TEMP, AND IS THE MOST RECENTLY ALLOCATED OF ITS * TYPE, IT IS FREED, I.E. THE TEMP COUNTER FOR THAT TYPE IS * DECREMENTED, SO THE NEXT TEMP ALLOCATED OF THAT TYPE WILL BE * THIS TEMP AGAIN. * F1T.F NOP JMP F1T.F,I *** DOESN'T WORK !!! *** LDA F.S1T,I TOS. SZA IF REGISTER, CPA K1 JMP F1T.F,I THEN NOT TEMP. * LDB A,I 1ST WORD: LSB = F.NT ADA K2 LDA A,I 3RD WORD: NAME. RAL,CLE,SLA,ERA SIGN BIT OF NAME SET ? (CLEAR IT) SLB AND NAMED ? (F.NT=0) JMP F1T.F,I NO. NOT TEMP. * CLB TEMP. SEPERATE TYPE & NUMBER. RRL 5 (B) = TYPE IN LSB. (NAME<14:11>) ALF,ALF RE-ALIGN NUMBER. (NAME<10:0>) ALF,RAR (A) = NUMBER. ADB DLINT ADDR OF COUNTER, THIS TYPE. CPA B,I IS THIS TEMP MOST RECENTLY ISSUED ? CCA,RSS (YES) JMP F1T.F,I NO. CAN'T FREE ANY OTHER. * ADA B,I YES. FREE IT, STA B,I BY DECREMENTING COUNTER. JMP F1T.F,I EXIT. SPC 2 * ********************************** * * FREE 2 TEMPS FROM TOP OF STACK * * ********************************** SPC 1 * F2T.F WORKS LIKE F1T.F, BUT WILL EITHER OR BOTH OF THE TOP * 2 ITEMS ON THE OPERAND STACK. THREE CALLS TO F1T.F ARE NEEDED * BECAUSE IF BOTH ITEMS ARE TEMPS OF THE SAME TYPE, AND NEXT-TO-TOP * IS THE MOST RECENT AND TOP IS NEXT MOST RECENT, WE CAN'T FREE TOP * UNTIL WE'VE FREED NEXT-TO-TOP. LIKEWISE IF DONE IN REVERSE ORDER. * F2T.F NOP JMP F2T.F,I *** DOESN'T WORK !!! *** JSB F1T.F TRY TO FREE TOS. JSB CO.F SWAP. JSB F1T.F TRY TO FREE NEXT-TO-TOP. JSB CO.F SWAP BACK. JSB F1T.F TRY TOS AGAIN, JUST IN CASE. JMP F2T.F,I EXIT. SKP * ****************** * * PASS FILE READ * * ****************** SPC 1 RD.F NOP JSB RS1.F READ AHEAD A WORD. LDB F.LA2 JUST ROLL UP THE QUEUE: STA F.LA2 NEW WORD GOES ON BOTTOM. LDA F.LA1 TOP GOES TO (A). STB F.LA1 BOTTOM GOES TO TOP. ISZ F.RSC BUMP RECOVERY SKIP COUNT. JMP RD.F,I EXIT. * F.LA1 NOP LOOK-AHEAD 1. F.LA2 NOP LOOK-AHEAD 2. SPC 2 * ********************** * * DEFINE STATEMENT # * * ********************** SPC 1 DSN.F NOP JSB RD.F GET THE #. STA F.A SAVE IT. JSB FA.F FETCH ASSIGNS. LDB F.NC FORMAT ? CPB B140 (I.E., NC=3) JMP DSN.F,I YES. LEAVE F.A~F ALONE. JSB DL.F NO. SET F.AF = F.RPL JMP DSN.F,I & EXIT. * K3 DEC 3 B140 OCT 140 SKP * ************* * * LIST LINE * * ************* SPC 1 LST.F NOP JSB IFBRK BREAK ? DEF *+1 CLE,SSA (E=0 FOR ASC.F) JMP BREAK YES. QUIT. * ISZ F.LNN BUMP LINE # FOR WAR.F LDA F.LNN CONVERT TO ASCII. JSB ASC.F (E=0, SUPPRESS LEADING ZEROES) SWP STB T1LST SAVE '34' RRR 8 MAKE '4123' AND B377 THEN '-123' IOR B20K SO FIRST COLUMN IS BLANK. DST LINOL LDA T1LST NOW '34' AND B377 MAKE '-4' IOR B20K ALF,ALF THEN '4-' STA LINOL+2 SO FINALLY IS '-1234-' LDA F.COC (A) = LENGTH IN WORDS. STA F.LNL SAVE FOR WAR.F CMA,INA SET COUNTER. STA T1LST CMA,INA RESTORE. ADA K3 ACCOUNT FOR LINE #. STA T3LST FOR WRT.C LDA DLBUF SET POINTER. STA F.LNA FOR WAR.F AND STA T2LST US. * * COPY THE LINE TO OUR BUFFER. * LST01 JSB RD.F STA T2LST,I ISZ T2LST BUMP BUFFER ADDR. ISZ T1LST MORE ? JMP LST01 YUP. * * IF 'M' OPTION & NOT COMMENT, WRITE TO PASS FILE. * LDA F.CCW LOOK FOR 'M' OPTION. RAR (IN BIT 1) CCE,SLA,RSS (E=1) JMP LST02 NO. LDA LINOL YES. SET SIGN 1ST WD AS FLAG TO PASS 3. RAL,ERA (E=1) STA LINOL LDA LBUFF IS FIRST CHAR 'C' ? AND KK02 CPA "C" JMP LST02 YES, IGNORE IT. JSB OS.F NO. FLUSH CODE TO HERE JSB WRT.C WRITE THE LINE TO THE PASS FILE. DEF C.SC0 DLNOL DEF LINOL DEF T3LST JMP PASER IF PASS FILE ERROR. * * IF 'L' OPTION, LIST IT NOW. * LST02 LDA F.CCW LOOKz# FOR 'L' OPTION. SLA,RSS JMP LST.F,I NO. ALF HOW ABOUT 'Q' ? SSA,RSS JMP LST03 NO. * LDA DLNOL YES. REFORMAT WITH ADDRESS. LDB DLNL2 FIRST, MOVE LINE # BACK 6 CHARS. JSB .MVW DEF K3 NOP LDB F.RPL (B) = LOAD ADDRESS. CLA CONVERT. AFTER EACH LINE, (B,A) = RRR 12 00000000 00000111 22233344 45550000 BLF,RBL 00000000 11100000 22233344 45550000 RRL 6 00111000 00222333 44455500 00000000 ALF,ALF 00111000 00222333 00000000 44455500 ALF,RAR 00111000 00222333 00000444 55500000 RRR 3 00000111 00000222 33300000 44455500 BLF,RBL 11100000 22200000 33300000 44455500 LSR 5 00000111 00000222 00000333 00000444 ADB "00" DIGITS 1 & 2. ADA "00" DIGITS 3 & 4. STB LINOL STA LINOL+1 LDA F.RPL NOW DO LAST DIGIT & BLANK. AND K7 IOR "B0" BLANK,DIGIT ALF,ALF DIGIT,BLANK. STA LINOL+2 LDB DLNL2 (B) = ADDRESS. LDA T3LST (A) = OLD LENGTH. ADA K3 ACCOUNT FOR ADDRESS. JMP LST04 GO LIST & EXIT. LST03 LDB DLNOL WRITE ORDINARY LINE TO LISTING. LDA T3LST LST04 JSB PSL.F WRITE. JMP LST.F,I EXIT. SKP T1LST NOP T2LST NOP T3LST NOP KK02 OCT 177400 K7 DEC 7 B20K OCT 20000 BLANK IN UPPER BYTE. "C" BYT 103,0 "00" ASC 1,00 "B0" ASC 1, 0 DLNL2 DEF LINL2 ADDR LINE # IF 'Q' DLBUF DEF LBUFF ADDR ACTUAL SOURCE. LINL2 ASC 3,-1234- LINE # & BLANKS IF 'Q'. LINOL ASC 3,-1234- (LINE#,BLKS) OR (ADDR) *IN LBUFF BSS 40 *SEQUENCE. SPC 2 * ************************** * * PRINT COMPILER COMMENT * * ************************** SPC 1 * PRINTS A COMPILER COMMENT (E.G., EXTENDED ERROR INFO). * PCC.F NOP LDA F.COC SET UP COUNT. CMA,INA,SZA,RSS NEGATE. IF ZERO, JMP PCC.F,I IGNORE. * STA T1PCC LDA DLBUF SET UP BUFFER ADDR. STA T2PCC PCC01 JSB RD.F COPY FROM FILE TO BUFFER. STA T2PCC,I ISZ T2PCC ADVANCE BUFFER PTR. ISZ T1PCC BUMP COUNT. DONE ? JMP PCC01 NO. * LDB DLBUF WRITE LINE. LDA F.COC JSB PSL.F JMP PCC.F,I DONE. * T1PCC NOP COUNTER FOR COPY. T2PCC NOP BUFFER POINTER FOR COPY. SKP * ************************ * * COUNT UNPRINTED LINE * * ************************ SPC 1 LNL.F NOP JSB IFBRK BREAK ? DEF *+1 SSA JMP BREAK YES. QUIT. * ISZ F.LNN BUMP LINE #. CLA ZAP OTHER STUFF. STA F.CC JMP LNL.F,I EXIT. SPC 2 * ******************* * * TITLE DIRECTIVE * * ******************* SPC 1 TTL.F NOP LDA F.COC SET UP THE LENGTH. STA F.TL CMA,INA,SZA,RSS NEGATE FOR LOOP COUNTER. ZERO ? JMP TTL.F,I YES. JUST CLEARING IT, DONE. * STA T1TTL NO. T1TTL = COUNTER. LDA DFTTL SET UP POINTER. RAL,CLE,SLA,ERA REMOVE AT MOST ONE INDIRECT. LDA A,I STA T2TTL T2TTL = POINTER. TTL01 JSB RD.F GET A WORD, STA T2TTL,I PUT IT AWAY, ISZ T2TTL BUMP POINTER, ISZ T1TTL AND LOOP. JMP TTL01 JMP TTL.F,I DONE. * T1TTL NOP LOOP COUNTER. T2TTL NOP TITLE BUFFER POINTER. DFTTL DEF F.TTL TITLE BUFFER ADDR (MAY BE INDIRECT) SKP * ********* * * BREAK * * ********* SPC 1 BREAK LDA K96 DISASTER 96. JMP F.ABT * K96 DEC 96 SPC 2 * ******************* * * PASS FILE ERROR * * ******************* SPC 1 PASER LDA K99 DISASTR 99. JMP F.ABT . SPC 1 K99 DEC 99 SPC 2 * ****************** * * DELAYED ERRORS * * ****************** SPC 1 ERR.F NOP JSB RD.F CLASS. STA ER.F LDA F.LNN SAVE LINE #. STA T1ERR JSB RD.F LINE #. STA F.LNN JSB RD.F COLUMN. STA F.CC JSB RD.F ERROR NUMBER. JSB WAR.F ISSUE IT. LDA T1ERR RESTORE LINE #. STA F.LNN CLA CLEAR COLUMN NUMBER. STA F.CC JMP ERR.F,I EXIT. * T1ERR NOP SKP * ************************* * * CROSS REFERENCE PAIRS * * ************************* SPC 1 * THIS BUFFER IS USED TO WRITE CROSS REFERENCE PAIRS TO THE * INTERMEDIATE CODE STRING. THE RECORD GOES OUT WITH A FIRST * WORD = -2 TO DISTINGUISH IT FROM SOURCE ('M') OR CODE. * SEE CRP.F FOR FORMAT OF PAIRS. * * THERE ARE 16 PAIRS PER RECORD EXCEPT (POSSIBLY) THE LAST ONE. * THE WORD FOLLOWING THE LAST PAIR IS 0, USUALLY IN WORD 34. * THE RECORD IS FLUSHED BY "CRPFL". SPC 1 CRF.F NOP JSB RD.F A.T. PTR STA LWORD,I OUTPUT IT. ISZ LWORD BUMP POINTER TO BUFFER ISZ NWRDS BUMP COUNTER JSB RD.F LINE #. STA LWORD,I OUTPUT IT. ISZ LWORD BUMP BUFFER POINTER ISZ NWRDS BUMP WORD COUNT. FULL? JMP CRF.F,I NOT YET. JSB CRPFL YES. FLUSH IT. JMP CRF.F,I NOW DONE. * CRPFL NOP FLUSH CROSS-REF PAIR BUFFER. LDB DEFCR EMPTY ? CPB LWORD JMP CRPFL,I YES. DON'T BOTHER. CLA STA LWORD,I FLAG END OF BUFFER JSB WRT.C WRITE THE RECORD DEF C.SC0 ON THE SCRATCH FILE DEF CRBUF-1 INCLULDE THE FLAG WORD DEF K34 34 WORDS JMP PASER ERROR ON PASS FILE LDA KM32 REINITIALIZE NUMBER OF WORDS STA NWRDS LDA DEFC?R REINTIALIZE STARTING ADDRESS OF PAIRS STA LWORD JMP CRPFL,I * DEFCR DEF CRBUF CROSS REFERENCE BUFFER LWORD DEF CRBUF NWRDS DEC -32 KM32 DEC -32 K34 DEC 34 KM2 DEC -2 DON'T DELETE ! MUST PRECEDE CRBUF! CRBUF BSS 33 SKP * OPERATOR JUMP TABLE. SPC 1 TABLE DEF AO.F 1 = DEF ADD.F 2 + DEF SUB.F 3 - DEF NEG.F 4 UNARY - DEF MPY.F 5 * DEF DIV.F 6 / DEF EXP.F 7 ** DEF .OR.F 8 .OR. DEF AND.F 9 .AND. DEF NOT.F 10 .NOT. DEF .LT.F 11 .LT. DEF .LE.F 12 .LE. DEF .EQ.F 13 .EQ. DEF .NE.F 14 .NE. DEF .GE.F 15 .GE. DEF .GT.F 16 .GT. DEF EQV.F 17 .EQV. DEF XOR.F 18 .XOR. DEF IAO.F 19 INVERSE ASSIGN. DEF PTM.F 20 'END' (& RETURN IN MAIN) DEF RTN.F 21 'RETURN' DEF EBR.F 22 ENDFILE/BACKSPACE/REWIND (SAVE CODE). DEF STP.F 23 'STOP' DEF STP.F 24 'PAUSE' DEF ERR.F 25 ERRORS DELAYED FROM PASS 1. DEF SAL.F 26 START SUBROUTINE REF DEF SAL.F 27 START ARRAY REF DEF LST.F 28 LINE TO BE LISTED. DEF LNL.F 29 NEW LINE, NO LIST. DEF CRF.F 30 CROSS-REFERENCE PAIR. DEF FPE.F 31 PROGRAM ENTRY DEF INIT 32 START OF EXPRESSION DEF SSC.F 33 SIMPLE CALL DEF SAR.F 34 SUBROUTINE OR ARRAY DEF TERM 35 END OF EXPRESSION DEF ASP.F 36 'ASSIGN' DEF DSN.F 37 DEFINE STATEMENT #. DEF CAD.F 38 COPY ASCII DATA. (FORMAT & HOLLERITH) DEF AIF.F 39 'IF' (ARITHMETIC) DEF LIF.F 40 'IF' (LOGICAL) DEF GTO.F 41 'GOTO' (SIMPLE) DEF AGT.F 42 'GOTO' (ASSIGNED) DEF CGT.F 43 'GOTO' (COMPUTED) DEF DO.F 44 'DO' DEF DOT.F 45 'DO' END. N>DEF SNS.F 46 START NEW STATEMENT. DEF RWE.F 47 'READ','WRITE' END. DEF IDO.F 48 IMPLIED DO. DEF NR.F 49 NEW IMPLIED DO RECORD. DEF ILA.F 50 ORDERING OF IMPLIED DO. DEF DTA.F 51 'DATA' ITEM DEFINITION. DEF 0 52 (UNUSED) DEF 0 53 (UNUSED) DEF ELS.F 54 'ELSE' DEF EIF.F 55 'ENDIF' DEF PCC.F 56 PRINT COMPILER COMMENT. DEF EJP.F 57 $PAGE DEF TTL.F 58 $TITLE DEF MP1.F 59 EMA CALL-BY-REFERENCE. DEF MP1.F 60 EMA CALL-BY-VALUE. DEF SSS.F 61 STUPID SEGMENT START WORD. DEF IOA.F 62 I/O WHOLE ARRAY. DEF IOL.F 63 I/O LIST ITEM. DEF IOS.F 64 I/O STATEMENT START. DEF IOK.F 65 I/O STATEMENT KEYWORD. DEF IOE.F 66 I/O STATEMENT END (EXCEPT R/W) * TBLSZ ABS *-TABLE # OF ENTRIES IN THE TABLE. * END F4.6 ASMB,Q,C HED CONSTANT CHECKING AND FOLDING. NAM FLD.F,8 92834-16003 REV.2030 800320 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * ENT CF2.F CHECK/FOLD BINARY OPERATIONS (+-*/**). ENT CF1.F CHECK/FOLD UNARY OPS (UNARY-, CONV) * EXT F.A ASSIGNMENT TABLE ADDRESS (CURRENT ENTRY). EXT F.DID ADDRESS OF F.IDI EXT F.IDI INPUT ARRAY. EXT F.RES RESULT F.A EXT F.S1T TOP OF STACK 1. EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT AI.F ASSIGN ITEM. EXT CFC.F CHECK FOR CONSTANT. EXT EIC.F EXTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT. EXT FT.F FIND TYPE OF OPERAND IN (B). EXT MIM.F MAP (A)=F.IM TO SENSIBLE ORDER. EXT P2P.F POP 2 OPERANDS, PUSH ONE. * EXT .MVW * A EQU 0 B EQU 1 SUP * * THESE ROUTINES WERE STOLEN DIRECTLY FROM THE HFPP DIAGNOSTIC * (WRITTEN BY CRAIG CHATTERTON) ON 790820. SPC 2 * GLOBAL CONSTANTS & VARIABLES. * DFC1 DEF F.C1+0 DFC2 DEF F.C2+0 K1 DEC 1 K2 DEC 2 K3 DEC 3 K4 DEC 4 K5 DEC 5 K15 DEC 15 K64 DEC 64 K127 DEC 127 POSMX DEC 32767 * KM1 DEC -1 KM4 DEC -4 KM15 DEC -15 KM16 DEC -16 * UPBYT OCT 177400 LWBYT OCT 377 * SIGN BSS 1 TMP BSS 1 TMP2 BSS 1 * F.C1 BSS 5 F.C2 BSS 5 * ACC DEF ACC3 ACC3 BSS 5 SKP * ******************************** * * CHECK/FOLD BINARY OPERATIONS * * ******************************** SPC 1 * ENTRY: (F.S1N,I) = 1ST OPERAND. * (F.S1T,I) = 2ND OPERAND. * (A) = OPERATOR #: 0=+, 1=-, 2=*, 3=/, -1=NONE. * 4=COMPARE: RTN (A)=1ST WD DIFF. * * EXIT: RETURN POINT DEPENDS ON WHICH OPERAND(S) WERE CONSTANT: * (P+1) BOTH. IF +-*/, FOLDING COMPLETE. A,B=CODES. * (P+2) SECOND OPND CONST, (B) = CODE. * (P+3) FIRST OPND CONST, (A) = CODE. * (P+4) NEITHER OPND CONST. * CF2.F NOP STA OPNUM SAVE OPERATOR #. LDB F.S1N,I CHECK FIRST OPERAND. LDA DFC1 IF CONST, PUT IN F.C1 JSB CKUNP CHECK, UNPACK. (SETS TTYPE) ISZ CF2.F NOT CONST, BUMP RETURN. STB T1CF2 USE (B) EITHER WAY. LDB F.S1T,I CHECK 2ND OPERAND. LD&A DFC2 IF CONST, PUT IN F.C2 JSB CKUNP (SETS TTYPE) JMP CF2.4 NOT CONST. GO EXIT. * LDA T1CF2 CONST. WAS FIRST CONST ? CPA B100K JMP CF2.F,I NO. NO FOLDING. * LDA OPNUM EXCEPTION: ** SSA JMP CF2.5 YES, NO FOLDING. * CPA K4 ALSO COMPARE: JMP CF2.9 GO SUBTRACT & RETURN 1ST WORD. * LDA TTYPE MAP TYPE IN CASE INT/DBI. JSB MIM.F LDB OPNUM OPERATION. SZA,RSS INTEGER ? JMP CF2.6 YES, ALL SPECIAL CASES. * CPA K1 DOUBLE INT ? JMP CF2.7 YES. ADD & SUBTRACT ARE SPECIAL. * CF2.1 ADB DFCTS PICK ROUTINE. LDB B,I JSB B,I DO IT. JSB PACK RE-PACK, ENTER IN A.T. CF2.2 LDA F.A SET UP F.A OF RESULT. STA F.RES JSB P2P.F POP OPNDS, PUSH RESULT. JMP CF2.F,I DONE. IF FOLD, A&B GARBAGE. SKP CF2.4 ISZ CF2.F 2ND NOT CONST, ADJUST RETURN. ISZ CF2.F CF2.5 LDA T1CF2 RESTORE (A) = 1ST CONST VALUE. JMP CF2.F,I NON-FOLD EXIT. * * SPECIAL PROCESSING FOR INTEGER OPERATIONS. * CF2.6 LDA F.S1T,I INTEGER. GET 2ND OPND. ADA K2 STA T1CF2 JUST SAVE ADDR. LDA F.S1N,I GET 1ST OPND. ADA K2 LDA A,I 1ST OPND. ADB DCF2I SELECT OP. LDB B,I JMP B,I DCF2I DEF *+1 DEF CF2IA ADD DEF CF2IS SUB DEF CF2IM MPY DEF CF2ID DIV * CF2IA ADA T1CF2,I ADD. JMP CF2IP CF2IS CMA SUB. ADA T1CF2,I CMA JMP CF2IP CF2IM MPY T1CF2,I MPY. JMP CF2IP CF2ID LDB A ASR 16 DIV T1CF2,I DIV. CF2IP JSB EIC.F SET UP INT CONST. JMP CF2.2 SKP * SPECIAL PROCESSING: DOUBLE INT ADD/SUB. * CF2.7 SZB DOUBLE INT. ONLY: CPB K1 ADD/SUB. ERB,SLB YES. (E=FLAG, SKIP) JMP CF2.1 NO. NORMAL. * LDA F.S1T,I GET 2ND OPND. ADA K2 DLD A,I SEZ,RSS ADD OR SUB ? JMP CF2.8 ADD. LEAVE IT. * CMA SUB. NEGATE 2ND. CMB,INB,SZB,RSS INA CF2.8 DST F.C2 SAVE 2ND. LDA F.S1N,I GET 1ST. ADA K2 DLD A,I CLE ADD. ADB F.C2+1 SEZ INA ADA F.C2 DST F.IDI SET UP NEW CONST. LDA TTYPE TYPE = DBI. JSB ESC.F JSB AI.F JMP CF2.2 GO FINISH UP. * CF2.9 JSB SUBOP COMPARE. SUBTRACT: OPND1-OPND2. LDA F.C1 RETURN 1ST WORD OF RESULT. JMP CF2.F,I DONE. * T1CF2 NOP OPNUM NOP OPERATOR #. TTYPE NOP RESULT TYPE. KK01 OCT 100002 OPND=DBI, RESLT=REA. SPC 2 DFCTS DEF *+1 ROUTINE ADDRESSES FOR FOLDING. DEF ADDOP DEF SUBOP DEF MPYOP DEF DIVOP SKP * ************************************ * * CHECK/FOLD NEGATION & CONVERSION * * ************************************ SPC 1 * ENTRY: (A) = RESULT TYPE (CONVERSION ONLY). * (B) = ADDR OF OPERAND ON STACK. * (E) = OPERATION: 1=NEGATE, 0=CONVERT. * * EXIT: RETURN TO (P+1) IF CONSTANT. STACK UPDATED. * (P+2) IF NOT CONSTANT. * CF1.F NOP STB T0CF1 SAVE STACK POINTER. CCB SAVE OPERATION: ERB -1: NEGATE 0: CONVERT. STB T2CF1 STA T1CF1 SAVE RESULT TYPE. (CONV ONLY) LDA DFC1 UNPACK TO F.C1 IF CONSTANT. LDB T0CF1,I JSB CKUNP TRY IT. (SET TTYPE) RSS NOT CONSTANT. BUMP RTN & EXIT. JMP CF1.0 CONST. * CF1.3 ISZ CF1.F BUMP RTN, JMP CF1.F,I EXIT. * CF1.0 ISZ T2CF1 WHICH OPERATION ? JMP CF1.1 CONVERSION. * LDA TTYPE NEGATION. DON'T OFL ON MAX NEG INT. CPA INT FOR INT, ADFB K17 IT'S -2**15 CPA DBI FOR DBI, ADB K33 IT'S -2**31 SZB,RSS IS IT ONE OF THOSE ? (ALSO FLT ZERO) JMP CF1.F,I YES. NO OPERATION, DONE. * LDB DFC1 NEGATE. JSB COM5 JMP CF1.2 GO REPACK & REPLACE TOS. * CF1.1 LDA F.C1+1 SPECIAL CASE: AND UPBYT IF OPND = DBI LDB T1CF1 & RESLT = REA BLF,BLF ADB TTYPE (15:12=OPND TYPE, 7:4=RESULT TYPE) CPB KK01 THEN TRUNCATE STA F.C1+1 DON'T ROUND. LDA T1CF1 IS RESULT CPA CPX COMPLEX ? RSS CPA ZPX JMP CF1.3 YES. DON'T DO IT. * STA TTYPE NO. SET IT UP FOR PACKING. CF1.2 JSB PACK RE-PACK CONSTANT. LDA F.A REPLACE STACK FRAME. STA T0CF1,I STA F.RES ALSO SET UP F.RES, JUST IN CASE. JMP CF1.F,I ALL DONE ! SKP T0CF1 NOP STACK POINTER. T1CF1 NOP TYPE(S). T2CF1 NOP OPERATION: -1=NEGATE, 0=CONVERT. INT OCT 010000 DBI OCT 100000 CPX OCT 050000 ZPX OCT 140000 K17 DEC 17 K33 DEC 33 T1PAC NOP SPC 2 * ******************************* * * RE-PACK RESULT & MAKE CONST * * ******************************* SPC 1 PACK NOP JSB EXPCK HANDLE OFL/UFL. LDA TTYPE FIX UP F.IM JSB MIM.F MAP TO 0,4. (CAN'T BE CPX) SZA INT CPA K1 OR DBI ? JMP PACK1 YES. GO USE FIXOP. * STA T1PAC NO. REA/DBL/RE8, ROUND. JSB RND5 JSB EXPCK CHECK FOR UNDERFLOW/OVERFLOW. LDA T1PAC & PACK. JSB PAK5 JMP PACK2 * PACK1 JSB FIXOP INT/DBI, FIX IT. PACK2 LDA DFC1 COPY TO F.IDI LDB F.DID JSB .MVW DEF K4 NOP LDA TTYPE FORM A.T. ENTRY. JSB ESC.F JSB AI.F JMP PACK,I DONE. SKP * ************************************* V* * CHECK FOR CONST, UNPACK / ANALYZE * * ************************************* SPC 1 * ENTRY: (B) = F.A OF OPERAND. * (A) = ADDR TO UNPACK TO. * * EXIT: NOT CONSTANT: RETURN TO (P+1) WITH (B)=100000. * CONSTANT, RETURN TO (P+2) WITH: * (B) = VALUE: IF ZERO, ZERO. * IF +- POWER OF 2 IN [.5,2**31], THEN * SIGN * (2+LOG2(X)) * OTHERWISE +32767 . * CKUNP NOP STA T1CKU SAVE ADDR F.C1/F.C2 STB F.A SAVE F.A OF OPND. JSB FT.F FIND TYPE STA TTYPE AND SAVE IT. LDB F.A RESTORE F.A JSB CFC.F CHECK FOR CONSTANT. JMP CKU06 NO, GO SET B=100000 & EXIT. * LDA B COPY CONSTANT. FROM HERE... LDB T1CKU TO THERE. (ORIGINAL (A)) JSB .MVW COPY IT. DEF K4 NOP LDA TTYPE GET THE TYPE. CPA CPX IF COMPLEX, RSS CPA ZPX OR DOUBLE COMPLEX, JMP CKU06 DENY THAT IT'S CONSTANT. * JSB MIM.F MAP TO [0,5]. SEZ ARITHMETIC ? JMP CKU99 NO. ERROR. * ISZ CKUNP OTHERWISE ADMIT IT. LDB T1CKU ADDR OF DATA. SZA INT OR CPA K1 DBI ? JMP CKU01 YES. GO FLOAT. * JSB UNPK5 NO. UNPACK FLOATING. JMP CKU02 * CKU01 JSB FLTOP INT/DBI, FLOAT TO 5-WORD. SKP * IT'S UNPACKED, NOW ANALYZE IT. * CKU02 LDB T1CKU,I FIRST WORD. SZB,RSS ZERO ? JMP CKUNP,I YES. RETURN B=0. * CPB B100K PROBABLE NEG. POWER OF 2 ? JMP CKU03 YES. * CPB B40K PROBABLE POS. POWER OF 2 ? RSS YES. JMP CKU05 NO. NOT A POWER OF 2 AT ALL. * CKU03 ISZ T1CKU 1ST WORD IS O.K., MAKE SURE LDA T1CKU,I THAT 2ND = 3RD = 4TH = 0. ISZ T1CKU IOR T1CKU,I .OR.GZ 3RD ISZ T1CKU IOR T1CKU,I .OR. 4TH SZA WELL ? JMP CKU05 NO. NOT POWER OF 2. * ISZ T1CKU POWER OF 2. GET THE EXPONENT. LDA T1CKU,I SSB IF NEGATIVE POWER OF 2, INA ADJUST EXP. (A)=1+LOG2(X) NOW. SSA X < 0.5 ? JMP CKU05 YES. TOO SMALL. * ADA KM33 X > 2**31 ? SSA,RSS JMP CKU05 YES. TOO BIG. * ADA K34 (A) = 2+LOG2(X). SSB NEGATIVE NUMBER ? CMA,INA YES. NEGATE (A), TOO. LDB A COPY STATUS TO B. JMP CKUNP,I EXIT, (B) = STATUS. * CKU05 LDB POSMX UNKNOWN, RETURN (B)=32767. JMP CKUNP,I DONE. * CKU06 LDB B100K B=100000, FLAG FOR NOT CONSTANT. JMP CKUNP,I EXIT. * CKU99 LDA K57 NON-ARITHMETIC, ERROR. JSB ER.F * T1CKU NOP KM33 DEC -33 K34 DEC 34 K57 DEC 57 B100K OCT 100000 B40K OCT 040000 SKP * *************************** * * NEGATE: ((B)) = - ((B)) * * *************************** SPC 1 COM5 NOP STB TMP SAVE RSLT ADDR ADB K3 X0=-X0 LDA B,I CMA,CLE,INA STA B,I CMB,INB X1=X1'+COUT(X0) CMB LDA B,I CMA,SEZ,CLE INA STA B,I CMB,INB X2=X2'+COUT(X0) CMB LDA B,I CMA,SEZ,CLE INA STA B,I LDA TMP,I X3=X3'+COUT(X2) CMA,SEZ,RSS IF NO CIN, DONE JMP TNRM * SSA,INA ELSE INC, & CHECK FOR OVFLW JMP TNRM IF XIN WAS +, CHECK FOR NORM. OUTPUT * SSA,RSS WAS NEG. POS NOW ? JMP TNRM YES. O.K. * RAR NO, WAS -1, SHIFT RIGHT & BUMP EXP LDB TMP ADB K4 B=EXP ADDR ISZ B,I NOP IN CASE THE TUKEY TRIES TO SKIP TNRM STA TMP,I SAVE FIRST WD. LDB TMP RESTORE TMP ADDR JSB NORM5 i+ NORMALIZE, JUST IN CASE. JMP COM5,I SKP * ******************************************** * * RIGHT CIRCULAR SHIFT (E)_((B)) ONE BIT * * ******************************************** SPC 1 ER4 NOP STB TMP2 SAVE OPND ADDR. LDA KM4 LOOP 4 TIMES. STA TMP ER01 LDA B,I SHIFT. ERA STA B,I INB ISZ TMP DONE ? JMP ER01 NO, KEEP GOING. * LDB TMP2 YES, RESTORE (B) & EXIT. JMP ER4,I SPC 2 * ******************************************* * * LEFT CIRCULAR SHIFT (E),((B)) ONE BIT * * ******************************************* SPC 1 EL4 NOP STB TMP SAVE ADDR 1ST WORD AS STOPPING POINT. ADB K4 (B) = ADDR 5TH WORD. EL01 CMB,INB BACK UP TO PREVIOUS WORD, DON'T SET (E). CMB LDA B,I SHIFT. ELA STA B,I CPB TMP JUST DID FIRST WORD ? JMP EL4,I YES, EXIT. JMP EL01 NO, KEEP GOING. SPC 2 * *********************************** * * LOGICAL LEFT SHIFT (B) ONE WORD * * *********************************** SPC 1 EL4W NOP STB TMP SAVE OPND ADDR. INB 2ND => 1ST. LDA B,I STA TMP,I ISZ TMP INB DLD B,I 3RD => 2ND. STA TMP,I ISZ TMP LDA B 4TH => 3RD, CLB 0 => 4TH. DST TMP,I LDB TMP RESTORE (B) ADB KM2 JMP EL4W,I SKP * ************************************* * * LOGICAL LEFT SHIFT (B) ONE NIBBLE * * ************************************* SPC 1 EL4N NOP STB TMP SAVE ADDR OF OPND. DLD B,I 1ST WORD. RRL 4 STA TMP,I ISZ TMP DLD TMP,I 2ND WORD. RRL 4 STA TMP,I ISZ TMP DLD TMP,I t 3RD & 4TH WORDS. AND B7777 RRL 4 DST TMP,I LDB TMP RESTORE (B). ADB KM2 JMP EL4N,I DONE. * B7777 OCT 7777 SKP * ********************************************** * * ARITHMETIC RIGHT SHIFT ((B)),(E) ONE BIT * * ********************************************** SPC 1 AR4 NOP LDA B,I JUST COPY SIGN TO (E) ELA JSB ER4 AND DO CIRCULAR SHIFT. JMP AR4,I SPC 2 * ********************************************** * * ARITHMETIC RIGHT SHIFT ((B)) BY (A) BITS * * * (RETURN E=1 IFF BITS SHIFTED OUT) * * ********************************************** SPC 1 AR4N NOP CMA,INA,SZA,RSS NEGATE COUNT. ZERO ? JMP AR4N2 YES. GO CLEAR (E) & EXIT. * STA AR4NC SET -COUNT. CLA CLEAR STICKY BIT. STA AR4NS AR4N1 JSB AR4 DO A SHIFT. SEZ BIT LOST ? ISZ AR4NS YES. NOTE. ISZ AR4NC MORE ? JMP AR4N1 YES. LOOP. * LDA AR4NS BITS LOST ? AR4N2 CLE,SZA (IF NOT, E=0) CCE YES, E=1. JMP AR4N,I EXIT. * AR4NC NOP - COUNT AR4NS NOP SUM OF STICKY BITS. SKP * ******************** * * NORMALIZE ((B)) * * ******************** SPC 1 NORM5 NOP CLA INITIALIZE COUNTER. STA T1NRM LDA B,I SAVE FIRST WORD OF OPND. STA T2NRM * * FIRST, BY WORDS. * NRM5A LDA B,I (NEW) FIRST WORD. SZA IF ZERO, CPA KM1 OR -1, RSS THEN SHIFT. JMP NRM5C ELSE HIGH BIT IS IN THIS WORD. * LDA T1NRM ADD 16 TO COUNT. CPA K64 ALREADY SHIFTED 4 TIMES ? JMP NRM5B YES. RESULT = 0. * ADA K16 NO. COUNT THIS ONE. STA T1NRM JSB EL4W SHIFT. P LDA B,I SIGN WRONG NOW ? XOR T2NRM SSA,RSS JMP NRM5A NO, IS O.K., KEEP SHIFTING. * LDA T2NRM OVER-SHIFTED. COMPENSATE. ELA SET (E)=CORRECT SIGN. JSB ER4 SHIFT IT BACK. CCA CORRECT SHIFT COUNT. ADA T1NRM STA T1NRM JMP NRM5Z GO CORRECT EXPONENT. * NRM5B STO ZERO. SET OVFLW,E EBP=0 CLA ADB K4 STA B,I ADB KM4 CCE JMP NORM5,I SKP * THEN BY NIBBLES. * NRM5C LDA B,I NEED (ANOTHER) NIBBLE SHIFT ? AND B174K (A)=TOP NIBBLE. SZA CPA B174K RSS YES. JMP NRM5D NO. GO DO BIT SHIFTS. * JSB EL4N SHIFT, LDA T1NRM AND FIX UP COUNT. ADA K4 STA T1NRM JMP NRM5C TRY AGAIN. * * FINALLY, BIT SHIFTS. * NRM5D LDA B,I NEED A BIT SHIFT ? ELA CHECK MOST SIG. BITS FOR NORMALIZATION CMA,SEZ,SSA,RSS JMP NRM5Z IF BITS=01, NORMALIZED SEZ,CLE,SSA JMP NRM5Z OR IF BITS=10 JSB EL4 IF NOT NORM. SHIFT LEFT & TEST AGAIN ISZ T1NRM ALSO COUNT IT. JMP NRM5D * * ADJUST EXPONENT. * NRM5Z ADB K4 RSLT EXP= OPND EXP-#SHIFTS LDA T1NRM # SHIFTS. CMA,INA ADA B,I STA B,I ADB KM4 RESTORE (B). JMP NORM5,I * T1NRM NOP T2NRM NOP K16 DEC 16 KM2 DEC -2 B174K OCT 174000 SKP * **************************************** * * MANTISSA ADD: ((A)) = ((A)) + ((B)) * * **************************************** SPC 1 SUMOP NOP STB TMP SAVE 2ND OPND ADDR. * ADB K3 LOW MANT ADDR 2ND OPND LDB B,I SEZ,CLE IF CIN, INC WORD INB ADA K3 LOW MANT ADDR 1ST OPND / RESULT ADB A,I ADD IN 1ST OPND STB A,I  & REPLACE. * LDB TMP GET 3RD WD 2ND OPND. ADB K2 LDB B,I CMA,SEZ,CLE,INA PROPOGATE ANY PREVIOUS CARRY AND START INB DECREMENTING (A) WITHOUT SETTING (E). CMA FINISH SAFE DECREMENT OF (A). ADB A,I ADD TO 3RD WD 1ST OPND. STB A,I LDB TMP 2ND WORD, JUST LIKE 3RD. INB LDB B,I CMA,SEZ,CLE,INA INB CMA ADB A,I STB A,I * CLO LDB TMP,I HIGH MANT CMA,SEZ,CLE,INA IF CIN INC INB CMA (A) IS NOW ADDR 1ST OPND. SOC IF OVFLW, MUST DO SPECIAL ADD JMP SPAD ADB A,I B = UPPERS + CARRY SUM01 STB A,I LDB A (B) = RESULT ADDR. JMP SUMOP,I THATS ALL FOLKS * SPAD ADB A,I (1ST UPPER + CARRY = 40000B) + 2ND UPPER SSB,RSS IF A>0, THEN 2ND UPPER < 0, CLEAR OVFLW CLO JMP SUM01 GO HOME SKP * **************************** * * ADD: F.C1 = F.C1 + F.C2 * * **************************** SPC 1 ADDOP NOP LDA F.C1 IF FIRST OPND = 0, CLE,SZA,RSS JMP ADD02 RESULT EXP = 2ND EXP. * LDA F.C2 IF 2ND OPND = 0, SZA,RSS JMP ADD03 RESULT EXP = 1ST EXP. * LDA F.C2+4 FORM (1ST EXP) - (2ND EXP) CMA,INA ADA F.C1+4 SSA,RSS IF +, COMPL & TEST (1ST >= 2ND) JMP XGTY * ADA K64 A=64-DIFF (1ST < 2ND) LDB F.C2+4 RESULT EXP = 2ND EXP STB F.C1+4 LDB DFC1 (B) = ADDR 1ST OP. SSA IF<0,SWAMP-- 1ST=0 JMP SET0 JMP SHIFT ELSE SHIFT Y RIGHT * XGTY CMA,INA FORM 64 - DIFF ADA K64 LDB DFC2 (B) = ADDR OPND2 SSA IF <0, SWAMP-- 2ND=0 JMP SET0 * SHIFT ADA NEG65 A= =#SHIFTS-1 CMA COMPL CNT JSB AR4N SHIFT IT SEZ,RSS CHECK FOR STICKY BIT JMP ADD03 NO. DONE. * ADB K3 YES. OPND(0)=IOR(OPND(0),1) CLA,INA IOR B,I STA B,I JMP ADD03 * SET0 CLA CLEAR OPND STA B,I INB STA B,I INB STA B,I CLE,INB STA B,I JMP ADD03 SKP ADD02 LDA F.C2+4 (1ST OPND = 0) STA F.C1+4 ADD03 CLE NO CIN LDA DFC1 DO THE ADD LDB DFC2 JSB SUMOP SOC IF OVFLW, ADJUST RSLT JSB MOVFW JSB NORM5 JMP ADDOP,I * NEG65 DEC -65 SPC 2 * ********************************* * * SUBTRACT: F.C1 = F.C1 - F.C2 * * ********************************* SPC 1 SUBOP NOP LDB DFC2 NEGATE F.C2 JSB COM5 JSB ADDOP THEN ADD. JMP SUBOP,I SPC 2 * * ADJUST ((B)) AFTER OVERFLOW * SPC 1 MOVFW NOP STB T1MOF SAVE OPND ADDR JSB ER4 SHIFT OPND BACK ONE BIT LDA B,I A=OPND(3) ADB K3 B=OPND(0) ADDR SEZ,CLE,RSS IF LSB=1, CHECK FOR SIGN OF OPND JMP EXPUP SSA,RSS IF A<0, SET LSB OF OPND=1 JMP EXPUP CLA,INA IOR B,I STA B,I EXPUP INB B=EXP ADDR ISZ B,I EXP =EXP + 1 JMP *+1 IT COULD SKIP LDB T1MOF RESTORE OPND ADDR JMP MOVFW,I NOW GET OUT OF THIS HOLE * T1MOF NOP SKP * ********************************* * * MULTIPLY: F.C1 = F.C1 * F.C2 * * ********************************* SPC 1 MPYOP NOP JSB MDENT CLEAR ACCUMULATORS, COMPUTE SIGN. LDA NEG63 63 BITS TO WORRY ABOUT. STA MPCNT LDB DFC1 SHIFT MULTIPLICAND RIGHT TO AVOID OVERFLOW. JSB AR4 MPY01 LDB ACC SHIFT RUNNING SUM RIGHT. JSB AR4 LDB DFC2 PICK OFF THE NEXT MULTIPLIER BIT. JSB AR4 LDA ACC > SET UP TO ADD IN MULTIPLICAND. LDB DFC1 SEZ,CLE MULTIPLIER BIT SET ? (E=0 FOR SUMOP) JSB SUMOP YES, DO IT. ISZ MPCNT COUNT. DONE ? JMP MPY01 NO, GO ON. * LDA ACC COPY RESULT MANTISSA. LDB DFC1 JSB .MVW DEF K4 NOP LDA F.C1+4 FORM RESULT EXPONENT. ADA F.C2+4 STA F.C1+4 LDB DFC1 NORM RESULT LDA SIGN IF SIGN ODD, RSLT=-RSLT CLE,SSA JSB COM5 * JSB NORM5 * JMP MPYOP,I DRIVE HER HOME, BOYS * MPCNT BSS 1 NEG63 DEC -63 SKP * ******************************* * * DIVIDE: F.C1 = F.C1 / F.C2 * * ******************************* SPC 1 DIVOP NOP LDA F.C2 2ND OPND ZERO ? SZA,RSS JMP EXIT0 YES, RSLT EXP=TOO LARGE --OVFLW * LDA F.C1 1ST OPND ZERO ? SZA,RSS JMP DIVOP,I YES, RESULT = 0 = 1ST OPND * JSB MDENT TAKE ABS, COMPUTE SIGN. LDA DFC2 SET UP NEGATED 2ND OPND LDB YCOM JSB .MVW DEF K5 NOP LDB YCOM JSB COM5 LDA YCOME SEE IF 2ND OPND IS 1: CPA F.C2+4 I.E., SAME EXP IF + OR - ? RSS YES. NOT -1, NORMAL. JMP TSTR -1, SPECIAL CASE (YCOM NOT ALIGNED). * LDA NEG62 SET LOOP COUNT STA DVCNT DIVLP LDA F.C1 (A) HAS SIGN OF 1ST OPND. LDB DFC2 DECIDE WHETHER TO ADD OR SUB. CLE,SSA,RSS WELL ? (E=0 FOR SUMOP) LDB YCOM SUB. LDA DFC1 DO X=X+Y OR X=X-Y JSB SUMOP CLE NO SHIFT IN JSB EL4 X=X*2 CME Q0=-SIGN OF X DIVSH LDB ACC LEFT SHIFT RESULT. JSB EL4 Q=Q*2 * ISZ DVCNT DONE ? RSS JMP DVASB YES. * LDA F.C1 NO. IF 2 HIGH BITS SAME, KEEP SHIFTING. RAL,SLA IF NEG, COMPLEMENT. CMA k CLE,SSA NOW TEST 2ND BIT: (E=0) JMP DIVLP IF SET, NORMALIZED, DONE SHIFTING. * LDB DFC1 UNNORMALIZED. SHIFT DIVIDEND. JSB EL4 JMP DIVSH SHIFT RESULT USING SIGN(DIVIDEND) SKP DVASB LDB ACC DONE, BUT Q NEEDS ONE MORE SHIFT CCE FORCE LSB=1 FOR PROPER NEGATE ROUNDING. JSB EL4 * LDA ACC F.C1=ACC LDB DFC1 JSB .MVW DEF K4 NOP TSTR LDA F.C2+4 COMPUTE RESULT EXPONENT. CMA,INA ADA F.C1+4 INA STA F.C1+4 LDB DFC1 JSB NORM5 NORMALIZE RESULT LDA SIGN IF SIGN ODD, NEGATE. CLE,SSA JSB COM5 JMP DIVOP,I IS IT SOUP YET? * EXIT0 LDB LWBYT STORE ILLEGAL EXP IN RESULT EXP STB F.C1+4 STB F.C1 MAKE MANTISSA NON-ZERO SO NORM5 WORKS. LDB DFC1 RETURN (B)=ADDR RESULT. JMP DIVOP,I THAT SHOULD DO IT FOR NOW! * NEG62 DEC -62 DVCNT BSS 1 YCOM DEF *+1 BSS 4 YCOME BSS 1 SPC 2 * COMMON ENTRY CODE FOR MPYOP, DIVOP. * MDENT NOP LDA F.C1 COMPUTE RESULT SIGN. XOR F.C2 STA SIGN LDB DFC1 TAKE ABS(F.C1) LDA B,I SSA JSB COM5 LDB DFC2 TAKE ABS(F.C2) LDA B,I SSA JSB COM5 CLA,CLE CLEAR ACCUMULATOR & (E). STA ACC3 STA ACC3+1 STA ACC3+2 STA ACC3+3 STA ACC3+4 JMP MDENT,I EXIT. SKP * *************************** * * ROUND F.C1 TO (A) WORDS * * *************************** SPC 1 RND5 NOP STA WRDAJ CMA GET INDEX TO RNDING WORD ADA RNDBF LDB A 2ND OP TO SUMOP. LDA F.C1 (A) HAS SIGN OF OPND ELA E=CIN=1 IF OPND >=0 IE ADD 200B CME LDA DFC1 ADD ROUND WORD. JSB SUMOP SOC JSB MOVFW HANDLE OVERFLOW. CLA Z CLEAR MANTISSA WORDS AFTER ROUND WORD. LDB WRDAJ CPB K2 2-WORD ? STA F.C1+2 YES, CLEAR 3RD. RBR,SLB,RBL 4-WORD ? STA F.C1+3 NO, CLEAR 4TH. ADB KM1 MASK OFF LOWER 8 BITS OF LOW WORD ADB DFC1 LDA B,I AND UPBYT STA B,I LDB DFC1 JSB NORM5 MAY HAVE TO NORMALIZE. JMP RND5,I * WRDAJ BSS 1 * RNDBF DEF RNDBE OCT 0 OCT 0 OCT 0 OCT 177 OCT 177777 RNDBE OCT 177777 POINTS TO LAST WORD OF BUFFER SKP * ********************************** * * PACK F.C1 TO (A)-WORD FLOATING * * ********************************** SPC 1 PAK5 NOP CCB COMPUTE ADDR LAST WORD. ADB DFC1 ADB A LDA B,I CLEAR LOW BITS. AND UPBYT STA B,I LDA F.C1+4 FORMAT THE EXPONENT. RAL SIGN TO LSB, AND LWBYT 8 BITS ONLY. IOR B,I MERGE. STA B,I JMP PAK5,I EXIT. SPC 2 * ****************************************** * * UNPACK ((B)) IN PLACE, (A)-WD FLOATING * * ****************************************** SPC 1 UNPK5 NOP STB TMP ADB KM1 B=LOW MANT ADDR ADB A STB TMP2 LDA B,I A=LOW OPND WORD AND LWBYT FORM EXPONENT HALF SLA,RAR MOVE SIGN TO BIT 15, EXTEND IF NECESSARY IOR NEGXP LDB TMP STORE EXP IN 5TH WORD ADB K4 STA B,I LDA TMP2,I TRUNCATE LOW MANT TO UPPER BYTE. AND UPBYT STA TMP2,I CLA CLEAR EXTRA WDS. ((B))=EXPONENT. UNP01 ADB KM1 BACK UP FROM EXPONENT. CPB TMP2 AT LAST MANTISSA WORD ? JMP UNP02 YES. DONE. * STA B,I NO. CLEAR WORD IN BETWEEN. JMP UNP01 TRY AGAIN. * UNP02 LDB TMP RETURN (B) = OPERAND ADDR. JMP UNPK5,I SET THE CHUTE AND LET IT FLY * (a NEGXP OCT 177600 SKP * ************************************* * * CHECK F.C1 FOR UNDERFLOW/OVERFLOW * * ************************************* SPC 1 EXPCK NOP LDA F.C1+4 EXPONENT. SSA,RSS IF EXP>0,A=-EXP-1 CMA ADA PS128 CLO SSA,RSS IF EXP IN RANGE GO HOME JMP EXPCK,I STO OVERFLOW FLAG LDA F.C1+4 CHECK SIGN OF EXP SSA IF <0, UNDERFLOW JMP UNFLW LDA K127 ELSE SET TO MAX + STA F.C1+4 SET EXP. LDA POSMX SET 1ST WD TO 077777B STA F.C1 CCA SET NEXT 2 WORDS TO 177777B STA F.C1+1 STA F.C1+2 LDA UPBYT 4TH WORD= UPPER 8 BITS ONLY STA F.C1+3 JMP EXPCK,I * UNFLW CLA STA F.C1 SET ALL ZEROES. STA F.C1+1 STA F.C1+2 STA F.C1+3 STA F.C1+4 JMP EXPCK,I SET SAILS FOR THE INDIES PS128 DEC 128 SKP * ****************************************** * * FIX F.C1 TO INTEGER, A=0/1 FOR SNG DBL * * ****************************************** SPC 1 FIXOP NOP STA INTWD SAVE SINGLE-DOUBLE FLAG SZA IF DOUBLE, A=16-- #SHIFTS=15+16*INTWD-EXP LDA KM16 A<=-#SHIFTS ADA KM15 ADA F.C1+4 ADD EXP. (A) = - # SHIFTS. CLO CLEAR OVERFLOW FOR RETURN (SET LATER) SZA,RSS IF CNT=0,CHECK FOR ROUND JMP FXTRD (A=0 HERE, NO STICKY BIT) SSA,RSS IF CNT>0, OVERFLOW JMP FIXOV GO TEST * CMA,INA NEGATE COUNT LDB DFC1 JSB AR4N SHIFT CNT TIMES CLA FORM STICKY BIT. ELA * FXTRD LDB F.C1 IF #>=0, RETURN. SSB,RSS ELSE CHECK FOR ROUND JMP FIXOP,I * LDB INTWD 'OR' TOGETHER ALL BITS SZB,RSS AFTER END OF INTEGER. IOR F.C1+1 (ONLY FOR SINGLE INT) IOR F.C1+2 IOR F.C1+3 SZA,RSS ANY BITS SET ? JMP FIXOP,I NO, RETURN * LDB DFC1 YES, BUMP THE INTEGER. ADB INTWD GET LSW OF RESULT ISZ B,I IF NOT=0, DONE-- RETURN JMP FIXOP,I CPB DFC1 IF SINGLE INTEGER, RETURN JMP FIXOP,I ISZ DFC1,I ELSE ROUND UPPER WORD NOP IT COULD SKIP! JMP FIXOP,I FIXOV LDA POSMX A=32767=OVERFLOW # CCB B=-1, IN CASE DOUBLE INTEGER. DST F.C1 PUT IN RESULT STO OVERFLOW RETURN JMP FIXOP,I * INTWD BSS 1 SKP * ****************************************** * * CONVERT ((B)) FROM INTEGER TO INTERNAL * * * (A) = 0/1 FOR SNG/DBL INT * * ****************************************** SPC 1 FLTOP NOP INB ADVANCE TO 2ND WORD. CLE,ERA (A)=0, (E)=SNG/DBL FLAG. SEZ,RSS IF SINGLE INT, STA B,I DO 2ND WORD. INB STA B,I 3RD INB STA B,I 4TH INB ELA,ALF SNG:0 DBL:16 ADA K15 SNG:15 DBL:31 STA B,I SET EXPONENT VALUE. ADB KM4 NORMALIZE. JSB NORM5 JMP FLTOP,I EXIT. * END ASMB,Q,C HED REGISTER AND TYPE MANAGEMENT. NAM RTM.F,8 92834-16003 REV.2030 800416 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * * {EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.AF ADDRESS FIELD OF CURRENT A.T. ENTRY. EXT F.AT ADDRESS TYPE OF CURRENT A.T. ENTRY. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.OFE DATA POOL OVERFLOW ENTRY. EXT F.RES F.A OF CURRENT RESULT. EXT F.S1B BOTTOM OF STACK 1. EXT F.S1T TOP OF STACK 1. EXT F.S2T TOP OF STACK 2. EXT F.T # WORDS ON STACK 1. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT CFC.F CHECK FOR CONSTANT. EXT DAF.F DEFINE (F.AF) EXT DIM.F DEFINE (F.IM) EXT EDO.F ESTABLISH DATA WITH OFFSET. EXT EIC.F ESTABLICH INTEGER CONSTANT. EXT FA.F FETCH ASSIGNS EXT OA.F OUTPUT ASSIGNMEXT TABLE OPERAND EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODF.F OUTPUT DOT FUNCTION EXT ORI.F OUTPUT ABS. REGISTER INSTRUCTION. EXT SOA.F SET F.A=(B) AND OUTPUT (A). * * ENTRY POINTS IN F4.6 * EXT F.RTP RESULT TYPE EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT ATC.F ALLOCATE TEMP CELL. EXT DEF.F PRODUCE A DEF TO (B). * * ENTRY POINTS IN AOP.F * EXT ADD.F ADD. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * ENT F.ACA ST$kACK ADDR OF (A) REGISTER. ENT F.ACB STACK ADDR OF (B) REGISTER. ENT F.ACM STACK ADDR OF CURRENTLY MAPPED ITEM. * ENT ABB.F SET UP A/B BIT FROM F.RES TO A<11>. ENT AOR.F ALLOCATE ONE REGISTER. ENT CAR.F CLEAR REG DATA & MAP STATUS. ENT CBR.F CLEAR REGISTER DATA FOR BOTH REGISTERS. ENT CRD.F CLEAR REGISTER DATA (ONE REGISTER). ENT FT.F FIND TYPE. ENT GRD.F GET REGISTER DATA. ENT GT1.F GET TYPE OF TOP-OF-STACK. ENT GT2.F GET TYPE OF TWO TOP OPERANDS. ENT LD.F LOAD. ENT LDA.F LOAD INTO (A). ENT LDB.F LOAD INTO (B). ENT LDF.F LOAD FIRST WORD. (EITHER REGISTER). ENT LDO.F LOAD WITH OFFSET. ENT MIM.F MAP ITEM MODE. ENT P1P.F POP ONE STACK ITEM, PUSH RESULT. ENT P2P.F POP TWO STACK ITEMS, PUSH RESULT. ENT PO1.F POP ONE STACK ITEM. ENT PU1.F PUSH ONE STACK ITEM. ENT SBR.F STORE BOTH REGISTERS. ENT SCG.F START CODE GENERATION. (LOAD TOS). ENT SMT.F SAVE MAPPED DATA IN TEMP (FREE MAPS). ENT SRD.F STORE REGISTER DATA. ENT SRS.F STORE REGISTER DATA, SHORT FORM. ENT SRT.F STORE REGISTER INTO TEMP. ENT ST.F STORE. ENT VS1.F VOID STACK 1. * * ENTRY POINTS IN SAM.F * EXT EA?.F SKIP IF F.A IS IN EMA. EXT MAP.F MAP (F.A). * * MISCELLANEOUS LIBRARY. * EXT .MVW MOVE WORDS. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 2 * ****************** * * SET UP A/B BIT * * ****************** SPC 1 ABB.F NOP LDA F.RES JUST F.RES, ALF,ALF LEFT SHIFTED 11. ALF,RAR JMP ABB.F,I DONE. SKP * ************************************ * * MAP DATA & FREE MAPS (FOR LOADS) * * ****K******************************** SPC 1 * ENTRY: (B) = F.A TO BE MAPPED. * EXIT: (B) = F.RES = MAPPED F.A * MAPS SET FREE IF ITEM WAS OR IS MAPPED. * MFM.F NOP STB F.A CHECK IT OUT. STB F.RES SET F.RES IN CASE NOT MAPPED. LDA F.ACM IF THIS IS THE MAPPED ITEM, CPB A,I SZA,RSS (THERE MUST BE ONE) RSS (NO) JMP MFM01 THEN FREE THE MAPS & EXIT. * JSB EA?.F NO. IS IT IN EMA ? JMP MFM.F,I NO. DONE. * JSB MAP.F YES, MAP IT. MFM01 CLA NOW FREE UP THE MAPS. STA F.ACM JMP MFM.F,I DONE. (B) = F.A AGAIN. SPC 2 * ************************** * * LOAD FIRST WORD OF (B) * * ************************** SPC 1 LDF.F NOP JSB MFM.F MAP & FREE MAPS. STB T1LDF SAVE F.A SZB IN REGISTER ? CPB K1 JMP LDF01 YES. * JSB AOR.F NO. ALLOCATE ONE OR OTHER. JSB SRT.F AND FREE IT UP. DEF F.RES JSB ABB.F NOW LOAD 1ST WD. ADA LDAI LDB T1LDF JSB SOA.F JMP LDF03 GO SET REGISTER STATUS. * LDF01 JSB GRD.F CHANGE TO INTEGER. DEF T1LDF LDA INT JSB SRD.F DEF T1LDF LDB T1LDF LOAD FIRST WORD. JSB LD.F LDF03 LDA INT SET RESULT. JSB SRS.F DEF F.RES JMP LDF.F,I EXIT. * T1LDF NOP F.A OF ITEM TO LOAD. SKP * ***************** * * GENERATE LOAD * * ***************** SPC 1 * INITIALIZE, MAP IN IF EMA, CHECK IF IN REGISTER. * LD.F NOP (B) = A.T. POINTER TO LOADING VAR. JSB MFM.F MAP & FREE MAPS. (SETS F.A & F.RES) STB T0LD SAVE IT BRS REGISTER ? SZB JMP LD02 NO. * * IF DATA IN REG, DONE. * JSB GRD.F YES. GET INFO. DEF mT0LD STA F.RTP F.RTP = F.IM OF ITEM. SOS ADDR ? JMP LD.F,I NO. DATA IN REG, DONE. * * ADDR IN REG. DEPENDS ON DATA TYPE. * LDB T0LD YES. (B) = 0/1. CPA INT IF INTEGER JMP LD005 GO DO LDA CPA LOG SAME IF LOG JMP LD005 CPA REA IF REAL ARRAY JMP LD004 GO DO DLD CPA DBI SAME FOR DOUBLE INTEGER. JMP LD004 CPA LO4 SAME FOR DOUBLE LOGICAL. JMP LD004 * LD003 LDA F.RTP NOT LOADABLE. ALLOCATE TEMP, JSB ATC.F LDB T0LD AND COPY IT THERE, JSB ST.F TO MAKE SURE MAPS ARE FREE NOW. JMP LD.F,I EXIT. * * LOAD 2-WORD DATUM FROM ADDR IN REG. * LD004 LDA T0LD STORE OTHER REGISTER, WHICHEVER. CMA,INA INA STA T2LD JSB SRT.F DEF T2LD LDA .DLD DO 'DLD' JSB OAI.F (RTN A=0,E=1) ERA A=100000 IOR T0LD A,I / B,I JSB OAI.F THE DEF. JMP LD06 GO SET F.RES & REG STATUS. SKP * LOAD ONE-WORD DATUM FROM ADDR IN REG. * LD005 LDB T0LD IN (A) ? SZB,RSS JMP LD007 YES. GO DO 'LDA 0,I' * LDA F.ACA IN (B). IS (A) FREE ? SSA JMP LD008 YES. GO DO 'LDA 1,I' * LDA LDB1I NO. DO 'LDB 1,I' (B=1, F.RES) JMP LD009 * LD008 JSB CBR.F 'LDA 1,I', CLEAR BOTH REG (TO GET B) LD007 LDA LDA0I SET UP LDA 0/1,I ADA T0LD CLB F.RES=0. LD009 STB F.RES JSB OAI.F JMP LD05 GO SET REGISTER STATUS. * * LOAD FROM MEMORY. DEPENDS ON DATA TYPE. * LD02 JSB GIM.F (A) = F.IM STA F.RTP SAVE IN F.RTP CPA INT IF INTEGER, JMP LD03 OUTPUT LDA / LDB CPA LOG IF LOGICAL, JMP LD03 OUTPUT SAME. CPA REA IF REAL, JMP LD04 OUTPUT DLD RI CPA DBI DITTO DOUBLE INTEGER. JMP LD04 CPA LO4 AND DOUBLE LOGICAL. JMP LD04 JMP LD003 NOT LOADABLE, COPY TO TEMP. * * LOAD ONE WORD FROM MEM. ** ALLOCATE REGISTER ** * LD03 JSB AOR.F ALLOCATE EITHER ONE. JSB SRT.F FREE UP THE REGISTER. DEF F.RES LDB T0LD RESTORE F.A STB F.A JSB CFC.F CONSTANT ? JMP LD07 NO. * CLB YES. (B) = OPCODE TO FORM IT, IF ANY. SZA,RSS ZERO ? LDB CLAI YES. 'CLA' CPA KM1 -1 ? LDB CCAI YES. 'CCA' CPA K1 +1 ? LDB CLAII YES. 'CLA,INA' SZB,RSS ANY FOUND ? JMP LD07 NO. * LDA B (A) = INST. JSB ORI.F OUTPUT IT WITH A/B BIT. JMP LD05 GO FINISH UP. * LD07 JSB ABB.F FORM LDA / LDB ADA LDAI JSB OA.F LOAD THE WORD. JMP LD05 GO SET UP REGISTER INFO. * * LOAD TWO-WORD DATUM FROM MEMORY. * LD04 JSB SBR.F FREE UP BOTH REGISTERS. LDA .DLD JSB OAI.F OUTPUT 'DLD' LDB T0LD JSB DEF.F OUTPUT DEF R * * SET RESULT ADDR AND REGISTER STATUS. * LD06 CLA FOR (A) OR (A,B) STA F.RES LD05 LDA F.RTP F.IM JSB SRS.F STORE REG DATA. DEF F.RES JMP LD.F,I EXIT. SPC 1 T0LD BSS 1 T2LD BSS 1 .DLD OCT 104200 DOUBLE LOAD LDAI OCT 62000 CCAI CCA KM8 DEC -8 KM1 DEC -1 K0 DEC 0 K1 DEC 1 SKP * ************************* * * START CODE GENERATION * * ************************* SPC 1 * I.E., LOAD TOP-OF-STACK IF LOADABLE. * SCG.F NOP LDB F.S1T,I JSB FT.F GET TYPE, JSB MIM.F AND ANALYZE. SSB LOADABLE ? JMP SCG.F,I NO. * LDB F.S1T,I YES. LOAD IT. JSB LD.F JSB P1P.F  REPLACE TOS WITH REGISTER. JMP SCG.F,I SPC 2 * ************************** * * LOAD INTO (A) OR (A,B) * * ************************** SPC 1 LDA.F NOP JSB MFM.F MAP & FREE MAPS. CLAI CLA SET F.RES=0. STA F.RES SZB,RSS IS IT ALREADY IN (A) ? JMP LDA01 YES, IT'S O.K. * STB T1LDA NO. (REMEMBER F.A) JSB SRT.F STORE (A) TO GUARANTEE DEF K0 THAT THE LOAD WILL BE INTO IT. LDB T1LDA (RESTORE F.A) CPB K1 DATA/ADDR IN (B) ? RSS YES. JMP LDA01 NO. JUST GO LOAD. * JSB GRD.F YES. IF DATA, STILL NOT THERE. DEF K1 CLB,INB (IN CASE ADDR) SOS IF ADDR, WILL WORK. JMP LDA02 ELSE DATA. GO DO 'LDA B'. * LDA01 JSB LD.F JUST LOAD. WILL GO INTO (A). JMP LDA.F,I * LDA02 STA T1LDA (SAVE ITS F.IM) LDA LDA1 DO 'LDA B' JSB OAI.F ISSUE. JSB CBR.F VOID (B) (A TOO) LDA T1LDA SET UP A-REG DATA: TYPE, JSB SRS.F DO IT. DEF K0 JMP LDA.F,I DONE. * T1LDA NOP LDA1 LDA B SKP * ***************** * * LOAD INTO (B) * * ***************** SPC 1 * ENTRY: (B) = F.A OR REG # OF DATA TO LOAD. * EXIT: (F.RES) = 1 TO INDICATE (B). * LDB.F NOP JSB MFM.F MAP & FREE MAPS. CLA,INA SET F.RES=1. STA F.RES SZB,RSS DATA/ADDRESS IN (A) ? JMP LDB01 YES. * CPB K1 IN (B) ? JMP LDB00 YES. LEAVE IT ALONE FOR NOW. * STB T1LDB (PRESERVE (B)) JSB SRT.F NO. STORE CURRENT CONTENTS. DEF K1 LDB T1LDB (RESTORE (B)) LDB00 LDA F.ACA NOT IN (A). SAVE STATUS STA T1LDB OF (A) AND SET IT 'IN-USE'. CLA STA F.ACA JSB LD.F NOW LD.F FORCED TO USE (B). LDA T1LDB RESTORE STATUS OF (A).> STA F.ACA JMP LDB.F,I DONE. * LDB01 JSB SRT.F DATA/ADDRESS IN (A). FREE UP (B). DEF K1 JSB GRD.F WHICH ? DEF K0 (O=1 IFF ADDRESS) STA T1LDB (SAVE F.IM OF DATA) LDA LDB0 DO 'LDB A' SOC UNLESS ADDRESS, LDA LDB0I THEN MAKE IT 'LDB A,I' JSB OAI.F ISSUE INSTRUCTION. JSB CBR.F VOID (A). (B, TOO) LDA T1LDB SET UP B-REG INFO: TYPE, JSB SRS.F DO IT. DEF K1 JMP LDB.F,I DONE. * T1LDB NOP LDB0 LDB A SKP * ******************** * * LOAD WITH OFFSET * * ******************** SPC 1 * WILL SET UP ACCESS TO AN ITEM WHICH IS OFFSET FROM ANOTHER * ITEM. MAIN USE IS TO CONVERT DBI=>INT AND CPX=>REA. * * ENTRY: (A)=OFFSET. * (B)=F.A OF ITEM (MAY BE REG #). * (F.RTP)=RESULT TYPE. * * EXIT: (F.RES)=RESULT F.A OR REG #. IF WAS REG ON STACK, RESULT * IS REGISTER WITH SAME STACK ADDR, BUT STACK ISN'T UPDATED. * LDO.F NOP STA T1LDO T1LDO=OFFSET, LDA F.RTP STA T3LDO T3LDO=RESULT TYPE. STB F.A MAP IN IF EMA. JSB MAP.F STB T2LDO T2LDO=F.A JSB GRD.F DATA/ADDRESS IN REGISTER ? DEF T2LDO STB T4LDO IF SO, T4LDO = STACK ADDR, IF ANY. SSB WELL ? JMP LDO04 NO. * SOS YES. WHICH ? JMP LDO03 DATA. * * ADDRESS IN REGISTER, JUST ADD OFFSET. * LDO01 ERA ADDRESS. REMEMBER IF EMA. STA T5LDO LDA INT CHANGE TYPE TO INT, JSB SRS.F DEF T2LDO LDA T2LDO PUSH IT ONTO STACK, JSB PU1.F LDA T1LDO FORM OFFSET, JSB EIC.F JSB PU1.F PUT THAT ON STACK, AND JSB ADD.F ADD 'EM UP. (SETS F.RES) JSB PO1.F POP RESULT OFF STACK. STO CHANGE BACK TO ADDR, LDA T5LDO  AND RESTORE EMA STATUS. ELA LDO02 LDA T3LDO SET TYPE, LDB T4LDO AND STACK ADDR. SSB BUT IF WASN'T IN REGISTER BEFORE, CLB THEN DON'T VOID NOW. JSB SRD.F (E & O ALREADY SET UP) DEF F.RES JMP LDO.F,I THAT'S IT. SKP * DATA IN REGISTERS, JUST ADJUST REGISTER #. * LDO03 JSB CRD.F FIRST, ZAP THE OLD REGISTER DATA. DEF T2LDO LDA T2LDO NOW ADJUST REG #. ADA T1LDO STA F.RES CLO DATA (NOT ADDR), CLE NOT EMA. JMP LDO02 GO SET TYPE & STACK ADDR. * * IN MEMORY. IF POSSIBLE, USE DATA W/OFFSET. * LDO04 LDA T2LDO,I ALREADY DATA W/OFFSET ? LDB T1LDO (IN CASE NOT) AND B601 I.E., F.IU=ARR & F.NT=1 ? CPA B601 RSS YES. JMP LDO05 NO. * LDA T2LDO GET F.A OF MASTER, VALUE OF OFFSET. INA DLD A,I (A)=MASTER, (B)=OFFSET. STA T2LDO REPLACE MASTER, ADB T1LDO AND ADD OFFSET IN. STB T1LDO * LDO05 SZB,RSS OFFSET ZERO ? JMP LDO06 THEN CAN ALWAYS DO IT. * LDA T2LDO IN MEM. FORMAL ? STA F.A JSB FA.F / LDA F.AT I.E., F.AT=DUM ? CPA DUM JMP LDO07 YES. CAN'T USE DATA WITH OFFSET. * LDA F.IM ADDR TEMP ? CPA ADDR JMP LDO07 YES. LIKEWISE. * LDO06 LDA F.RTP USE DATA WITH OFFSET. STA F.IM SET UP F.IM=TYPE, LDA T1LDO OFFSET, LDB T2LDO FROM ITEM. JSB EDO.F ESTABLISH DATA WITH OFFSET. LDA F.A SET UP F.RES & EXIT. STA F.RES JMP LDO.F,I SKP * FORMAL PARAM OR ADDR TEMP. EITHER LOAD IT & ADJUST * REG #, OR LOAD ITS ADDRESS AND BUMP THAT. * LDO07 LDA F.IM GET ITEM'S TYPE. CPA ADwDR IF ADDRESS, LDA F.AF IT'S IN ITS F.AF JSB MIM.F SSB (CAN'T BE 1-WORD) 2 WORDS ? JMP LDO08 NO. MUST FUDGE ADDRESS. * LDA F.ACB IF 2-WORD ITEM IN (A,B), CPA K1 THEN HAVE TO STORE BOTH WORDS, SO BOTH JMP LDO09 REG WILL BE FREE, SO LOAD WHOLE ITEM. * AND F.ACA NO. ARE BOTH ALREADY FREE ? SSA (IFF BOTH F.AC* < 0) JMP LDO09 YES. LOAD WHOLE NUMBER. * LDO08 JSB AOR.F ALLOCATE A REGISTER FOR THE ADDRESS. JSB ABB.F SET UP A/B, ADA LDAII WITH LOAD INDIRECT, LDB T2LDO WHICH CANCELS ITEM'S INDIRECT. JSB SOA.F ISSUE IT. LDA T2LDO WAS ITEM MAPPED ADDRESS ? LDB F.ACM I.E., CPA B,I ITEM MATCHES STACK POSITION F.ACM, CCE,SZB,RSS AND F.ACM#0 ? (E=1, IN CASE EMA) CLE NO. SET NON-EMA REGISTER STATUS. LDA F.RES SET T2LDO=F.RES, STA T2LDO SO CAN USE REG OFFSET CODE ABOVE. JMP LDO01 GO DO IT. * * 2-WORD FORMAL OR ADDR TEMP & APPROPRIATE TO LOAD. * LDO09 LDB T2LDO THEN LOAD IT. JSB LD.F LDA F.RES SET UP T2LDO, STA T2LDO JMP LDO03 SO CAN USE NORMAL REG DATA CODE. * T1LDO NOP OFFSET. T2LDO NOP F.A OR REG # OF ITEM. T3LDO NOP RESULT TYPE. T4LDO NOP STACK ADDR IF REG. T5LDO NOP SAVED EMA (E) REGISTER STATUS. B601 OCT 601 MASK F.IU,F.NT & F.IU=ARR,F.NT=1. DUM OCT 5000 F.AT=DUM LDAII OCT 162000 OPCODE FOR LDA ,I SKP * ****************** * * GENERATE STORE * * ****************** SPC 1 ST.F NOP ASSUME F.IM OF SOURE, DEST SAME. CPA B STORE INTO SELF ? JMP ST.F,I YES. IGNORE. * STA T0ST SAVE A.T. PTR TO DESTINATION. STB F.A MAP IN THE SOURCE, IF NEED BE. JSB EA?.F CAREFUL! DON'T CALL MAP.jF IF NOT RSS IN EMA: IT MAY HAVE CALLED US. JSB MAP.F (RESULT IN A,B BOTH) STB T1ST SAVE A.T. PTR TO SOURCE. LDB T0ST JSB FT.F GET F.IM OF DESTINATION. * CPA INT IF INTEGER, RSS CPA LOG OR LOGICAL, JMP ST01 USE STA/STB. * CPA DBI IF DOUBLE INTEGER, RSS CPA REA REAL, RSS CPA LO4 OR DOUBLE LOGICAL, JMP ST03 USE DST. * LDA ST.F ELSE DBL/RE8/CPX/ZPX. SAVE ENTRY PT, STA T2ST AS WE MAY BE CALLED RECURSIVELY. LDA T1ST STACK UP THE F.A'S, FOR TWO REASONS: JSB PU1.F TO SURVIVE A RECURSIVE CALL, LDA T0ST AND TO BE UPDATED IF THEY ARE JSB PU1.F REGISTERS, SINCE: JSB SBR.F WE MUST STORE BEFORE DFER/CFER. JSB PO1.F RESTORE RESULT F.A, STA T0ST LDB A AND RE-FETCH TYPE. JSB FT.F LDB .CFER IF RE8 OR CPX, USE .CFER CPA DBL IF DBL, LDB .DFER USE .DFER CPA ZPX IF ZPX, LDB .ZFER USE .ZFER JSB ODF.F GENERATE JSB .ROUTINE LDB T0ST NOW SEND DEF'S TO F.A'S. JSB DEF.F RESULT ADDR, JSB PO1.F LDB A JSB DEF.F SOURCE ADDR. LDA T0ST (A) = F.A OF DEST. JMP T2ST,I DONE. * * USE 'DST' FOR REAL & DOUBLE INTEGER. * ST03 LDA .DST GENERATE 'DST' JSB OAI.F LDB T0ST GENERATE DEF DESTINATION. JSB DEF.F JMP ST02 SKP * USE STA/STB FOR INTEGER, LOGICAL & DOUBLE LOGICAL. * ST01 LDA T1ST SET UP STA / STB ALF,ALF ALF,RAR ADA STAI LDB T0ST (B)=F.A OF DEST. SZB IF DEST IS REGISTER, CPB K1 IOR B100K THEN SET INDIRECT BIT: MUST BE ADDR. JSB SOA.F OUTPUT 'STA' OR 'STB' * * IF REGISTER STORED, FREE IT UP. *  IF ADDRESS IN REGISTER USED, FREE IT UP TOO. * ST02 JSB GRD.F GET REG DATA. (IF NOT REG, B=-1) DEF T1ST FOR SOURCE. LDA T0ST IF ON STACK, REPLACE BY DEST F.A SSB,RSS (IF NOT IN USE, NO STORE) STA B,I (IF NOT ON STACK, B=0, NOP) JSB CRD.F NOTE THAT REG IS EMPTY NOW. DEF T1ST (IF NOT REG, NOP) JSB CRD.F NOW THE DESTINATION, WHICH IS A REGISTER DEF T0ST ONLY IF THE DESTINATION ADDR WAS IN IT. LDA T0ST RETURN (A)=F.A OF DEST. JMP ST.F,I EXIT. SPC 2 .DST OCT 104400 'DLD' .CFER ABS 75 .DFER ABS 74 .ZFER ABS 316 STAI OCT 72000 T0ST NOP DESTINATION F.A T1ST NOP SOURCE F.A T2ST NOP ENTRY POINT SAVED OVER RECURSIVE CALL. T1GST NOP T2GST NOP INT OCT 010000 REA OCT 020000 LOG OCT 030000 CPX OCT 050000 ZPX OCT 140000 DBL OCT 060000 B100K OCT 100000 DBI EQU B100K LO4 OCT 110000 RE8 OCT 120000 SKP * ************************** * * GENERATE STORE IN TEMP * * ************************** SPC 1 * ENTRY: (B) = F.A OR REGISTER NUMBER. * GST.F NOP FOR STORING A AND A-B INTO TEMPS STB T1GST SAVE F.A JSB GRD.F GET REG DATA. (O.K. IF NOT REG) DEF T1GST STB T2GST SAVE PLACE TO PUT NEW STACK ITEM. SOS ADDR ? JMP GST05 NO. * LDB T1GST YES. STORE IN ADDR TEMP. JSB GSA.F LDA F.A (A) = F.A OF TEMP. JMP GST04 GO FINISH UP. * GST05 JSB ATC.F DATA. ALLOCATE TEMP CELL LDB T1GST IN CASE OF DBL/CPX/ZPX FROM EMA JSB ST.F STORE INT, LOG OR REAL GST04 STA T2GST,I SET NEW A.T. POINTER IN STACK JSB CRD.F NOTE THAT REG IS EMPTY NOW. DEF T1GST JMP GST.F,I RETURN SPC 2 * ***************************** * * STORE MAPPED DATA IN TEMP * * ******sd*********************** SPC 1 SMT.F NOP LDB F.ACM ANYTHING IN MAPS ? SZB,RSS JMP SMT.F,I NO. * STB T2SMT YES. SAVE THE STACK ADDR. LDB B,I (B) = ITS F.A JSB FT.F GET ITS TYPE, JSB ATC.F ALLOCATE TEMP FOR IT, STA T1SMT SAVE TEMP'S F.A LDA F.IM IS IT LOADABLE ? JSB MIM.F LDA B (THE ANSWER IS IN (A)) LDB F.ACM,I IN CASE NOT, STB F.RES SET UP F.RES HERE. SSA,RSS WELL ? JSB LD.F LOADABLE. LOAD IT. LDB F.RES STORE SOURCE. LDA T1SMT F.A OF TEMP = STORE DEST. STA T2SMT,I REPLACE STACK FRAME. JSB ST.F STORE THE ITEM IN THE TEMP. CLA CLEAR OUT THE MAP POINTER. STA F.ACM JMP SMT.F,I DONE. * T1SMT NOP F.A OF TEMP. T2SMT NOP STACK ADDR OF MAPPED DATA. SKP * ******************************************* * * ALLOCATE ADDRESS TEMP AND STORE INTO IT * * ******************************************* SPC 1 * ENTRY: (B) = REG #. * GSA.F NOP ROUTINE TO ALLOCATE AN ADDRESS TEMP AND STB T1GSA STORE INTO IT. (SAVE REG #) JSB GRD.F GET TYPE OF DATA. DEF T1GSA STA T2GSA T2GSA = F.IM DATA. LDA ADDR ALLOCATE TEMP. JSB ATC.F LDA INT TEMPORARILY MAKE F.IM OF TEMP. INT JSB DIM.F LDA F.A STORE REGISTER CONTAINING LDB T1GSA ADDRESS IN TEMP CELL. JSB ST.F (ST.F USES DESTINATION TYPE) LDA ADDR JSB DIM.F CHANGE ITS F.IM BACK TO ADDRESS. LDA T2GSA INSERT F.IM OF ITEM BEING ADDRESSED JSB DAF.F INTO AF OF TEMP CELL A.T. ENTRY. JMP GSA.F,I RETURN F.IM OF DATA IN (A). * T1GSA NOP T2GSA NOP T1SER NOP ADDR OCT 070000 SKP * ************************ * * REGISTER INFORMATION * * ************************ F1 SPC 1 * THE A & B REGISTER INFORMATION IS ACCESSED BY THE FOLLOWING * ROUTINES, WHICH USE THE FOLLOWING CONVENTIONS: * * (A) = F.IM OF DATA. * (B) = -1 IF REGISTER FREE. * 0 IF IN USE BUT NOT ON STACK. * +1 IF 2ND WORD OF 2-WORD DATUM (B ONLY) * +2 IF 1ST WORD OF REVERSED DBL INT (B ONLY) * >2 IF ADDR OF ITEM ON STACK. * (O) = ADDRESS FLAG. REGISTER CONTAINS ADDRESS OF DATA. * (E) = EMA ADDRESS FLAG. DATA MUST BE COPIED BEFORE ANY * MAP CHANGES. IF E=1, MUST HAVE O=1. SPC 1 DFAF DEF F.AFA * KEEP THE FOLLOWING IN ORDER * * * F.AFA NOP (A) ADDRESS FLAG. * F.EFA NOP EMA FLAG. * F.IMA NOP ITEM MODE. * F.ACA NOP STACK ADDR. * F.AFB NOP (B) ADDRESS FLAG. * F.EFB NOP EMA FLAG. * F.IMB NOP ITEM MODE. * F.ACB NOP STACK ADDR. * * F.ACM NOP STACK ADDRESS OF MAPPED EMA ITEM. SPC 1 * ********************* * * GET REGISTER DATA * * ********************* SPC 1 GRD.F NOP LDA GRD.F,I GET REG #. ISZ GRD.F LDA0I LDA A,I CCB (B=-1) SZA REGISTER ? CPA K1 ALS,SLA,ALS YES. GET DATA. (A*4 & SKIP) JMP GRD.F,I NO. RETURN STATUS: FREE. * ADA DFAF FORM ADDR DATA. LDB0I LDB A,I SET (O) CLO ADB BMAX (OVERFLOWS IF B=1) INA SET (E) LDB A,I ERB INA SET (A) & (B) DLD A,I JMP GRD.F,I EXIT. * BMAX OCT 77777 SKP * *********************** * * STORE REGISTER DATA * * *********************** SPC 1 SRD.F NOP STA T1SRD+2 SET UP 4-WORD BLOCK. STB T1SRD+3 CLA ELA STA T1SRD+1 ERA A=0, E RESTORED. SOC INA STA T1SRD SEZ,SZA IF E=O=1, EMA ADDRESS, SSB AND REGISTER IS BEING SET IN-USE, RSS (NO) STB F.ACM THEN SET UP EMA STACK POINTER. LDB SRD.F,I GET REG #. ISZ SRD.F LDB1I LDB B,I SZB REGISTER ? CPB K1 RSS JMP SRD.F,I NO. DONE. * BLS,BLS FORM ADDR OF REG DATA. ADB DFAF LDA DT1SR SOURCE FOR COPY. JSB .MVW COPY DATA. DEF K4 NOP SKP * RESET STATUS OF B-REGISTER. (AS PART OF A-REG) * LDA F.ACB WAS B-REG ASSOCIATED WITH (A) ? CCB CPA K1 AS PART OF TWO-WORD NUMBER ? STB F.ACB YES. CPA K2 AS PART OF REVERSED DOUBLE INTEGER ? STB F.ACB YES. LDA F.ACA IS A-REG IN USE NOW ? LDB F.AFA AND DATA, NOT ADDR ? SSA,RSS (SKIP IF NOT IN USE) SZB (IN USE. SKIP IF DATA) JMP SRD.F,I NO. LEAVE (B) ALONE. * LDA F.IMA YES. 2-WORD VALUE ? CLB,INB CPA DBI DOUBLE INTEGER, STB F.ACB CPA REA REAL, STB F.ACB CPA LO4 DOUBLE LOGICAL. STB F.ACB IF ANY, SET NEW (B) STATUS. JMP SRD.F,I EXIT. * T1SRD BSS 4 DT1SR DEF T1SRD K2 DEC 2 K4 DEC 4 SPC 2 * ***************************** * * CLEAR ALL REGIGISTER DATA * * ***************************** SPC 1 CAR.F NOP JSB CBR.F FIRST, A & B REGISTERS. CLA THEN ANY EMA INFO. STA F.ACM JMP CAR.F,I THAT'S IT. SKP * *********************** * * CLEAR REGISTER DATA * * *********************** SPC 1 CRD.F NOP LDA CRD.F CONVERT TO SRD.FW CALL. STA SRD.F CCB WITH B=-1, NOT IN USE. JMP SRD.F+1 SPC 2 * ************************ * * CLEAR BOTH REGISTERS * * ************************ SPC 1 CBR.F NOP JSB CRD.F JUST ONE AT A TIME. DEF K0 JSB CRD.F DEF K1 JMP CBR.F,I SPC 2 * **************************** * * STORE REGISTER INTO TEMP * * **************************** SPC 1 SRT.F NOP LDA SRT.F,I GET REG #. ISZ SRT.F STA T1SRT T1SRT = ADDR OF REG #. JSB GRD.F GET DESCRIPTION. DEF T1SRT,I SSB ANYTHING THERE ? JMP SRT.F,I NO. (OR NOT REG.) * CPB K2 IS IT (B) & MPY EXTENSION ? JMP SRT.F,I YES, DON'T SAVE IT. * CPB K1 IS IT LOWER PART OF (A,B) ITEM ? CLB,RSS YES, SAVE BOTH OF THEM. LDB T1SRT,I NO, SAVE WHATEVER CALLER SAID. JSB GST.F JMP SRT.F,I EXIT. * T1SRT NOP SKP * ********************************* * * STORE BOTH REGISTERS IN TEMPS * * ********************************* SPC 1 SBR.F NOP JSB SRT.F DEF K0 JSB SRT.F DEF K1 JMP SBR.F,I SPC 2 * *********************************** * * STORE REGISTER DATA, SHORT FORM * * *********************************** SPC 1 * SAME AS SRD.F, EXCEPT SETS B,E,O TO ZERO. * SRS.F NOP LDB SRS.F COPY OUR ENTRY. STB SRD.F CLB,CLE B=0, E=0. CLO O=0. JMP SRD.F+1 NOW FAKE THE SRD.F CALL. SPC 2 * ************************* * * ALLOCATE ONE REGISTER * * ************************* SPC 1 * EXIT: (A)=(F.RES)=REG#, * AOR.F NOP LDA F.ACA CHECK REG USAGE. LDB F.ACB B-REG IS FREE IF SZB F.ACB # 0 ADB KM8 AND F.ACB < 8 B SSB WELL ? (SKIP IF (B) IN USE) SSA A-REG FREE ? CLA,RSS (A) FREE OR (B) IN USE, USE (A). CLAII CLA,INA OTHERWISE, USE (B). STA F.RES F.RES = REGISTER #. JMP AOR.F,I EXIT. SKP * *************** * * POP STACK 1 * * *************** SPC 1 PO1.F NOP TO UNSTACK AND DISCARD OPERANDS. LDA F.S1T IF REGISTER POPPED, CLB CLEAR ITS STACK POINTER(S). CPA F.ACA STB F.ACA CPA F.ACB STB F.ACB CPA F.ACM STB F.ACM LDA F.S1T,I (A) = OLD TOS. LDB F.T INB JUST ONE. STB F.T FROM STACK TO T. ADB F.S1B STB F.S1T NEW PTR TO TOP OPERAND ON STK1. INB STB F.S1N NEW PTR TO NEXT-TO-TOP OPERAND. JMP PO1.F,I SPC 2 * **************************************** * * POP ONE OR TWO OPERANDS, PUSH RESULT * * **************************************** SPC 1 P1P.F NOP POP 1. JSB PO1.F POP IT. LDA F.RES PUSH RESULT. JSB PU1.F JMP P1P.F,I SPC 1 P2P.F NOP POP 2. JSB PO1.F POP ONE AND JSB P1P.F LET P1P DO THE OTHERS. JMP P2P.F,I SKP * **************** * * PUSH STACK 1 * * **************** SPC 1 * STACK 1 IS THE OPERAND STACK. IT IS IN HIGH CORE, JUST BELOW THE * DO TABLE, AND GROWS TOWARD LOW CORE. THIS ROUTINE IS ENTERED WITH * (A) = WORD TO BE STACKED, GENERALLY AN (F.A) BUT (F.A,I) FOR AN * ARRAY OR SUBROUTINE WITH LIST FOLLOWING. 0/1 MEANS A/B REGISTERS. SPC 1 * (B) IS NOT DESTROYED BY THIS SUBROUTINE SPC 1 PU1.F NOP PUSH STACK 1 TO STACK OPERANDS. STB T0PU1 SAVE B REGISTER. CCB ADB F.T STB F.T T=T-1 ADB F.S1B STB F.S1T NEW PTR TO TOP OPERAND ON STK1. CPB F.S2T IF 2 TOP POINTERS THE SAME, JMP F.OFE DATA POOL OVERFLOW * INB SET NEXT-TO-TOP. STB F.S1N STA F.S1T,I STORE DATA. ARS REGISTER ? SZA JMP PU101 NO. * JSB GRD.F YES. SAVE STACK ADDR. DEF F.S1T,I LDB F.S1T CHANGE STACK POINTER. SEZ IF ADDRESS IN EMA, STB F.ACM SET UP MAPPED DATA STACK ADDR. JSB SRD.F DEF F.S1T,I PU101 LDB T0PU1 RESTORE (B), EXIT. JMP PU1.F,I SPC 1 T0PU1 NOP SPC 2 * **************** * * VOID STACK 1 * * **************** SPC 1 VS1.F NOP LDA F.S1T SET F.S1T = F.S1B, STA F.S1B CLA AND F.T = 0. STA F.T JMP VS1.F,I DONE. SKP * *************************** * * MAP & ANALYZE ITEM MODE * * *************************** SPC 1 * ENTRY: (A) = F.IM TO BE ANALYZED. * EXIT: (A) = MAPPED ITEM MODE: * 0=INT 1=DBI 2=REA 3=DBL 4=RE8 * 5=CPX 6=ZPX -1=OTHER * (B) = LENGTH INFO: * 0: 1 WORD 1: 2 WORDS -1: LONGER * (E) = NUMERIC DATA FLAG * 0: NUMERIC 1: LOGICAL, CHARACTER OR MISC. SPC 1 MIM.F NOP ALF PUT BITS IN LOW PART OF WORD. ADA DMIMT INDEX INTO TABLE. LDB A,I PICK APART TABLE ENTRY: CLA,CLE <15:8> => B (SIGN EXTENDED) ASR 8 <7> => E ELA,ARS <6:0> => A (SIGN EXTENDED) ARS,ARS ARS,ARS ARS,ARS ARS,ARS JMP MIM.F,I DONE ! * DMIMT DEF *+1 MIM TABLE: SEE ABOVE FOR DESCRIPTION. BYT -1,-1 UNDEF OR STMT # BYT 0,0 INTEGER*2 BYT 1,2 REAL*4 BYT 0,-1 LOGICAL*2 BYT -1,-1 TWPE BYT -1,5 COMPLEX*8 BYT -1,3 DOUBLE PRECISION*6 BYT -1,-1 ADDRESS BYT 1,1 INTEGER*4 BYT 1,-1 LOGICAL*4 BYT -1,4 DOUBLE PRECISION*8 BYT -1,-1 CHARACTER BYT -1,6 COMPLEX*16 SKP * ********************************* * * GET TYPES OF TOP TWO OPERANDS * * ********************************* SPC 1 GT2.F NOP GET F.IM OF TWO TOP OPERANDS LDB F.S1N,I JSB FT.F GET F.IM OF NEXT TO TOP OPERAND STA T1GT2 SAVE IT. JSB GT1.F GET F.IM OF TOP OPERAND. LDB T1GT2 (B)=TYPE(F.S1N), (A)=TYPE(F.S1T). JMP GT2.F,I * T1GT2 NOP SPC 2 * *************************** * * GET TYPE OF TOP OPERAND * * *************************** SPC 1 GT1.F NOP LDB F.S1T,I JSB FT.F GET F.IM OF TOP OPERAND STA F.RTP AND SAVE IT IN F.RTP JMP GT1.F,I SPC 2 * ************* * * FIND TYPE * * ************* SPC 1 FT.F NOP ENTERED WITH (B) = A.T. PTR. STB F.A JSB GRD.F IF IN REG, GET TYPE. DEF F.A STA F.IM (IN CASE YES.) SSB IF WASN'T REGISTER, JSB GIM.F GET FROM A.T. JMP FT.F,I EXIT. SPC 2 * ***************** * * GET ITEM MODE * * ***************** SPC 1 GIM.F NOP IF F.IM=ADDR FOR F.A, CHANGE IT. JSB FA.F FETCH ASSIGNS LDB F.IM (B) _ F.IM OF F.A CPB ADDR IF F.IM=ADDRESS, STA F.IM SET F.IM=AF F.A LDA F.IM MAKE SURE UPDATED F.IM IS IN (A) JMP GIM.F,I * END ASMB,Q,C HED ARITHMETIC & LOGICAL OPERATIONS CODE GENERATOR. NAM AOP.F,8 92834-16003 REV.2030 800818 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THYIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.IDI INPUT ARRAY. EXT F.S1T TOP OF STACK 1 * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CF1.F CHECK FOLDING ON UNARY OPERATIONS. EXT CF2.F CHECK FOLDING ON BINARY OPERATIONS. EXT CFC.F CHECK FOR CONSTANT. EXT CDI.F CLEAR IDI ROUTINE EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODF.F OUTPUT DOT FUNCTION EXT ORI.F OUTPUT ABS. REGISTER INSTRUCTION. EXT OZ.F OUTPUT MEM REF TO *+N. EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) * * ENTRY POINTS IN F4.6 * EXT F.ACB STACK ADDRESS FOR B-REG. EXT F.ACA STACK ADDRESS FOR A-REG. EXT F.COP CURRENT OPCODE. EXT F.LA1 1ST LOOK-AHEAD, 1ST PASS FILE. EXT F.LA2 2ND LOOK-AHEAD, 1ST PASS FILE. EXT F.RES RESULT F.A EXT F.RTP RESULT TYPE EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT ATC.F ALLOCATE TEMP CELL. EXT ATM.F CONDITIONALLY ALLOCATE TEMP (TWO OPNDS). EXT DEF.F PRODUCE A DEF TO (B). EXT F1T.F FREE TEMP IF TOS. EXT F2T.F FREE TEMP IF TOS OR NEXT-TO-TOP. EXT GDF.F GENERATE DOT FUNCTION CALL. EXT RD.F PASS FILE READ WITH LOOK-AHEAD. EXT TAS.F CONDITIONALLY ALLOCATE TEMP. (LOOK-AHEAD) * * ENTRY POINTS IN AOP.F (ARITHMETIC AND LOGICAL OPERATORS.) * ENT ADD.F ADD. ENT AND.F AND. ENT CON.F CONVERSION. ENT CO.F COMMUTE TOP TWO OPERANDS. ENT CTS.F CONVERT TOP OF STACK. ENT DIV.F DIVIDE. ENT EQV.F .EQV. ENT .EQ.F .EQ. ENT EXP.F EXPONENTIATION. ENT .GE.F .GE. ENT .GT.F .GT. ENT .LE.F .LE. ENT .LT.F .LT. ENT MP1.F MAP TOS IF EMA. ENT MP2.F MAP TOP TWO STACK ITEMS IF EMA. ENT MPY.F MULTIPLICATION. ENT .NE.F .NE. ENT NEG.F UNARY MINUS. ENT NOT.F .NOT. ENT .OR.F .OR. ENT SUB.F SUBTRACTION. ENT XOR.F .XOR. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT F.ACM STACK ADDR OF CURRENTLY MAPPED ITEM. * EXT ABB.F SET UP A/B BIT. EXT CAR.F CLEAR REGISTER DATA, INCLUDING MAPS. EXT CBR.F CLEAR REGISTER DATA FOR BOTH REGISTERS. EXT CRD.F CLEAR REGISTER DATA (ONE REGISTER). EXT FT.F FIND TYPE. EXT GRD.F GET REGISTER DATA. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT GT2.F GET TYPE OF TWO TOP OPERANDS. EXT LD.F LOAD. EXT LDA.F p LOAD INTO (A). EXT LDB.F LOAD INTO (B). EXT LDF.F LOAD FIRST WORD. (EITHER REGISTER). EXT LDO.F LOAD WITH OFFSET. EXT MIM.F MAP ITEM MODE. EXT P1P.F POP ONE STACK ITEM, PUSH RESULT. EXT P2P.F POP TWO STACK ITEMS, PUSH RESULT. EXT PO1.F POP ONE STACK ITEM. EXT PU1.F PUSH ONE STACK ITEM. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION. (LOAD TOS). EXT SRD.F STORE REGISTER DATA. EXT SRS.F STORE REGISTER DATA, SHORT FORM. EXT SRT.F STORE REGISTER INTO TEMP. * * ENTRY POINTS IN SAM.F * EXT MAP.F MAP IN EMA ITEM. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SKP * ********************************************* * * COMMUTE TO PUT REGISTER OR CONSTANT FIRST * * ********************************************* SPC 1 * * ENTRY: (F.S1N,I) = 1ST OPND, (F.S1T,I) = 2ND OPND. * (A) # 0: 1ST OPND WILL BE LOADED TO (A). * = 0: DON'T CARE. * (E) = 0: IF CONSTANT & MEM, CONSTANT FIRST. * = 1: DON'T COMMUTE JUST FOR CONSTANT. * EXIT: E=0 IF NO COMMUTE DONE, 1 IF COMMUTED. * CCO.F NOP LDB F.S1N,I IF OPND1 ADDR/DATA IN (A), SZB,RSS SZA,RSS AND WE WILL LOAD INTO (A), ALS,SLA,ERA (NO. SKIP & COPY (E) TO SIGN OF (A).) JMP CCO02 THEN LEAVE AS IS. (IN CASE ADDR). * STA T1CCO NO. SAVE (E). JSB GRD.F GET INFO ON 1ST OPND. DEF F.S1N,I SSB,RSS IS IT REGISTER ? (B>=0) JMP CCO00 YES. GO SEE IF DATA/ADDR. * LDB F.S1T,I NO. IS 2ND CONSTANT ? LDA T1CCO ALSO, DOES IT MATTER ? SSA,RSS SKIP IF IGNORING CONSTANTS. JSB CFC.F SKIP IF CONSTANT. CCB,RSS NO. GO SEE IF 2ND IS REG. (B=-1) JMP CC6O01 YES. COMMUTE. JMP CCO03 NO. * CCO00 SOS DATA (O=0) ? JMP CCO02 YES. DON'T COMMUTE. * CCO03 STB T1CCO NOW B>=0 IFF 1ST OPND IS ADDR. JSB GRD.F GET INFO ON 2ND OPND. DEF F.S1T,I SSB REGISTER ? JMP CCO02 NO. DON'T COMMUTE. * SOS DATA ? JMP CCO01 YES. COMMUTE. * LDA T1CCO ADDR. IS OPND1 ADDR TOO ? SSA,RSS JMP CCO02 YES. BOTH ARE, DON'T COMMUTE. * CCO01 JSB CO.F THEN COMMUTE. CCE,RSS AND SET E=1 TO SAY WE DID IT. CCO02 CLE E=0 SAYS WE DIDN'T. JMP CCO.F,I EXIT. * T1CCO NOP SKP * ******************** * * COMMUTE OPERANDS * * ******************** SPC 1 CO.F NOP CALLED WHEN COMM. IS REQUIRED. LDA F.S1T,I (A)_TOP OPERAND ON STACK 1. LDB F.S1N,I (B)_ NEXT-TO-TOP OPERAND ON STACK STB F.S1T,I TOP OPERAND _ (B) STA F.S1N,I NEXT-TO-TOP OPERAND _ (A) * LDA F.S1T UPDATE REGISTER INFO ON STACK: SZB,RSS STA F.ACA F.S1T=A CPB K1 STA F.ACB F.S1T=B LDA F.S1N LDB A,I SZB,RSS STA F.ACA F.S1N=A CPB K1 STA F.ACB F.S1N=B * LDB F.S1T (B)=F.S1T, (A)=F.S1N CPB F.ACM F.ACM = F.S1T ? JMP CO01 YES. (CAN'T DO BOTH) * CPA F.ACM NO. F.ACM = F.S1N ? STB F.ACM YES. CHANGE TO F.S1T JMP CO.F,I DONE. * CO01 STA F.ACM F.ACM=F.S1T, CHANGE TO F.S1N JMP CO.F,I DONE. SKP * ******* * * ADD * * ******* SPC 1 ADD.F NOP ADD TWO TOP OPERANDS. JSB MAT.F MATCH TYPES. JSB MP2.F MAP IF IN EMA. JSB F2T.F FREE TEMPS. CLA TRY TO FOLD. A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP ADD.F,I FOLDED. ALL DONE HERE. JMP ^ADD02 2ND CONST ONLY. JMP ADD01 1ST CONST ONLY. (COMMUTE.) * ADD00 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. CLA,CLE PUT REGISTER FIRST, OR CONSTANT. JSB CCO.F (A=0, USES EITHER REGISTER.) LDA F.RTP MAP TYPE. JSB MIM.F ADA DADDT GET DOT FUNCTION INFO. LDA A,I LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP ADD.F,I * ADD01 STA T1ADD 1ST CONST: SAVE CONST DESCRIPTION. JSB CO.F & COMMUTE. LDB T1ADD (B)=CONST DESCR. ADD02 SZB CONST=0 ? JMP ADD03 NO. * JSB PO1.F YES. JUST THROW IT AWAY. LDA F.S1T,I AND SET F.RES RIGHT. STA F.RES JMP ADD.F,I ALL DONE. * ADD03 LDA F.RTP OTHERWISE CAN ONLY HELP: CPA INT INTEGER JMP ADD04 * CPA DBI AND DOUBLE INTEGER. RSS JMP ADD00 REA/DBL/RE8/CPX, NOTHING SPECIAL. * CLA DOUBLE INTEGER: CPB K2 FOR X+1, LDA .DIN USE .DIN CPB KM2 FOR X+(-1), LDA .DDE USE .DDE SZA,RSS ONE OF ABOVE ? JMP ADD00 NO. ORDINARY. * STA T1ADD YES. SAVE INC/DEC. JSB PO1.F POP THE CONSTANT. LDB F.S1T,I LOAD THE ITEM. JSB LD.F LDB T1ADD DO THE INC/DEC. JSB ODF.F JMP ADD4A GO REPLACE TOS & EXIT. * ADD04 CPB K2 INTEGER, ONLY HELP IS X+1 RSS JMP ADD00 NO. ORDINARY. * JSB PO1.F YES. POP THE CONSTANT. LDB F.S1T,I LOAD THE ITEM. JSB LD.F LDA INAI 'INA' JSB ORI.F OUTPUT INA/INB. ADD4A JSB P1P.F REPLACE TOS WITH REGISTER. JMP ADD.F,I ALL DONE. * * INTEGER ADD. * ADD05 LDB F.S1N,I LOAD 1ST OP JSB LD.F LDB F.S1T,I ADD SECOND. JSB ABB.F SET UP ADA/ADB ADA 3ADAI JSB SOA.F OUTPUT ADA/ADB LDA F.S1T,I IF ADD TO ITSELF, CPA F.S1N,I JMP ADD06 DON'T FREE RESULT REGISTER ! * JSB CRD.F IF 2ND OPND IS IN REG, DEF F.S1T,I THEN FREE IT. ADD06 JSB P2P.F SET STACK RIGHT. JMP ADD.F,I * .DIN ABS 005 OFFSET FOR .DIN .DDE ABS 017 OFFSET FOR .DDE INAI INA ADAI OCT 42000 T1ADD NOP D.REG EQU 040000B BIT 14: REGISTERS PRESERVED. D.OPM EQU 020000B BIT 13: 1ST OPERAND IN MEMORY. D.RTN EQU 010000B BIT 12: USE RETURN ADDRESS. D.ER0 EQU 004000B BIT 11: ADD 'JSB ERR0' AFTER. * DADDT DEF *+1 ADD DOT FUNCTION TABLE. DEF ADD05,I INT, SPECIAL CASE. ABS 000+D.REG DBI, .DAD ABS 001+D.REG REA, .FAD ABS 002+D.OPM DBL, .XADD ABS 003+D.REG+D.OPM RE8, .TADD ABS 004+D.OPM CPX, .CADD ABS 300+D.REG+D.OPM ZPX, .ZADD SKP * ************ * * SUBTRACT * * ************ SPC 1 SUB.F NOP JSB MAT.F MATCH TYPES. JSB MP2.F MAP IF IN EMA. JSB F2T.F FREE TEMPS. CLA,INA TRY TO FOLD. A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP SUB.F,I FOLDED. ALL DONE HERE. JMP SUB06 2ND CONSTANT ONLY. JMP SUB03 1ST CONSTANT ONLY. * SUB01 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. LDA F.RTP MAP TYPE. JSB MIM.F ADA DSUBT GET DOT FUNCTION INFO. LDA A,I LDB F.S1T,I IF DOUBLE INTEGER AND 2ND OPND CPA .DSB IS IN (A,B), SZB JMP SUB02 (NO) * JSB CO.F THEN COMMUTE & USE REVERSE SUBTRACT. LDA .DSBR JMP SUB10 GO GENERATE CODE. * SUB02 CPA .FSB FLOATING, SZB AND IN (A,B) ? JMP SUB10 NO. * JSB GRD.F YES. ADDR OR DATA ? DEF K0 LDA .FSB (RESTORE DOT FUNCTION) SOC WELL ?  JMP SUB10 ADDR. CAN STORE THAT. * JSB NEG.F DATA. BETTER TO NEGATE & ADD. JSB ADD.F JMP SUB.F,I DONE. * SUB10 LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP SUB.F,I EXIT. SKP * 1ST OPND CONSTANT. * SUB03 CPA KM2 (-1) - X ? JMP SUB04 YES. * SZA 0-X ? JMP SUB01 NO. * JSB CO.F YES. DELETE ZERO: SWAP, JSB PO1.F POP IT. JSB NEG.F NEGATE X. JMP SUB.F,I DONE. * SUB04 LDA F.RTP (-1) - X CPA INT CAN HELP INTEGER JMP SUB05 * CPA DBI AND DOUBLE INTEGER. RSS JMP SUB01 BUT NOTHING ELSE. * SUB05 JSB CO.F FOR INT/DBI, JUST 1'S COMPLEMENT. JSB PO1.F REMOVE (-1). JSB SCG.F LOAD X. LDA CMAI DO 'CMA' OR 'CMB'. JSB ORI.F LDA CMBI DO 'CMB' LDB F.RTP ONLY IF DBL INT. CPB DBI JSB OAI.F JSB P1P.F REPLACE X WITH (A) OR (A,B). JMP SUB.F,I DONE. * * SECOND OPERAND CONSTANT. * SUB06 SZB X-0 ? JMP SUB07 NO. * JSB PO1.F YES. JUST REMOVE IT. LDA F.S1T,I AND SET F.RES RIGHT. STA F.RES JMP SUB.F,I DONE. * SUB07 LDA F.RTP INTEGER OR DOUBLE INT ? CPA INT JMP SUB08 * CPA DBI RSS JMP SUB01 NO, NO HELP. * SUB08 JSB NEG.F YES. NEGATE 2ND OPND. JSB ADD.F & ADD. JMP SUB.F,I DONE. SKP * INTEGER SUBTRACT. * SUB09 JSB GRD.F IS 2ND OPND IN REGISTER ? DEF F.S1T,I SSB,RSS SOC (AND DATA, NOT ADDR) RSS NO. JMP SUB08 YES. GO DO 'CM*,IN*' & 'AD*'. * JSB GRD.F IS 1ST OPND IN REGISTER ? DEF F.S1N,I SSB,RSS SOC (AND DAT2kA, NOT ADDR) JMP SUB08 NO. DITTO. * LDA CMAI YES. DO 'CM*', LDB F.S1N,I (FOR ORI.F, SET UP F.RES NOW) STB F.RES JSB ORI.F JSB ADD.F 'AD* X', LDA CMAI JSB ORI.F AND 'CM*' JMP SUB.F,I DONE. * DSUBT DEF *+1 SUBTRACT DOT-FUNCTION TABLE. DEF SUB09,I INT, SPECIAL CASE. .DSB ABS 006+D.REG DBI, .DSB .FSB ABS 007+D.REG REA, .FSB ABS 008+D.OPM DBL, .XSUB ABS 009+D.REG+D.OPM RE8, .TSUB ABS 010+D.OPM CPX, .CSUB ABS 301+D.REG+D.OPM ZPX, .ZSUB * .DSBR ABS 011+D.REG DOUBLE INTEGER REVERSED SUB * DBI OCT 100000 KM2 DEC -2 SKP * ********** * * NEGATE * * ********** SPC 1 NEG.F NOP GEN. CODE FOR UNARY MINUS. JSB MP1.F MAP IT IN IF IN EMA. JSB GT1.F GET ITEM TYPE. JSB MIM.F ANALYZE TYPE. SEZ,CCE NUMERIC DATA ? (E=1) JMP CON09 NO. ERROR. * LDB F.S1T STACK ADDR. JSB CF1.F IF CONSTANT, FOLD. JMP NEG.F,I YES. ALL DONE! * * IF DBL/RE8/CPX AND NOT IN-PLACE, SUBTRACT FROM ZERO. * LDA F.RTP NOT CONST. REGISTER OPERATION ? JSB MIM.F SSB,RSS JMP NEG02 YES. LET GDF.F SORT IT OUT. * LDA F.A IF NOT, SEE IF IT IS A TEMP CELL SZA (DON'T TEST REGISTERS) CPA K1 JMP NEG03 (REGISTER - USE SUBTRACT) * ADA K2 IS IT A TEMP ? LDA A,I SSAI SSA IF TEMP CELL, JMP NEG04 GENERATE JSB TO ..DCM/..TCM/..CCM/..ZCM * NEG03 LDB F.S1N GET POINTER TO NEXT OPERAND JSB TAS.F ALLOCATE DBL OR CPX TEMP CELL.IF NEEDED LDA F.RES IS IT JUST A NEGATE IN PLACE ? CPA F.S1T,I JMP NEG04 YES, DO THAT. * JSB CDI.F NO. IT'S FASTER & SMALLER TO DO A SUBTRACT LDA F.RTP FROM ZERO THAN TO COPY & NEGATE. JSB ESC.F JSB AI.F ENTER THE CONSTANT. LDA F.A PUSH ONTO STACK JSB PU1.F JSB CO.F & MAKE IT THE FIRST OPERAND. LDA F.RTP GET THE SUBTRACT INFO. JSB MIM.F ADA DSUBT FROM THE SUB.F TABLE. LDA A,I FLAGS & ORDINAL FOR PROPER CALL. LDB K2 2 OPERANDS. JSB GDF.F ISSUE SUBTRACT. JSB PU1.F PUSH RESULT ON STACK. JMP NEG.F,I DONE ! SKP * IN-PLACE OR IN REGISTERS. USE GDF.F . * NEG02 JSB F1T.F REGISTERS. FREE TEMP. NEG04 LDA F.S1T,I SET (F.RES) = (TOS) IN CASE IN-PLACE. STA F.RES LDA F.RTP GET THE FLAG ORDINAL WORD. JSB MIM.F ADA DNEGT FROM THE TABLE. LDA A,I INB,SZB DBL,RE8,CPX LOOK LIKE ZERO-OPERAND. CLB,INB DBI,REA LOOK LIKE ONE-OPERAND. JSB GDF.F (INT IS SPECIAL CASE.) LDA F.RTP HERE WE HAVE A PROBLEM BECAUSE THE JSB MIM.F ZERO-OPERAND FLAVOR OF THE GDF.F CALL SSB DIDN'T GET ITS RESULT/OPERAND POPPED, BUT NEG00 JSB PO1.F THE ONE-OPERAND ONE DID. FIX THAT HERE. LDA F.RES IN ANY EVENT, PUSH THE RESULT. JSB PU1.F JMP NEG.F,I DONE. SPC 1 DNEGT DEF *+1 NEGATION DOT-FUNCTION TABLE. DEF NEG01,I INT, SPECIAL CASE. ABS 024+D.REG DBI, .DNG ABS 025+D.REG REA, ..FCM ABS 026+D.OPM DBL, ..DCM ABS 027+D.REG+D.OPM RE8, ..TCM ABS 028+D.OPM CPX, ..CCM ABS 304+D.REG+D.OPM ZPX, ..ZCM * K1 DEC 1 K2 DEC 2 SPC 1 NEG01 JSB SCG.F LOAD INTEGER, SET RESULT = 0/1. LDA NEGI JSB ORI.F OUTPUT CM*,IN* FOR INTEGER NEG. JMP NEG00 * NEGI CMA,INA SKP * ************ * * MULTIPLY * * ************ SPC 1 MPY.F NOP JSB MAT.F MATCH TYPES. JSB MP2.F MAP IF IN EMA. ^ JSB F2T.F FREE TEMPS. LDA K2 TRY TO FOLD: A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP MPY.F,I BOTH CONSTANTS, DONE. JMP MPY03 2ND CONSTANT. JMP MPY02 1ST CONSTANT. * MPY01 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. CLA,CLE,INA PUT REGISTER FIRST (PREF A) OR CONSTANT. JSB CCO.F LDA F.RTP MAP TYPE. JSB MIM.F ADA DMPYT GET DOT FUNCTION INFO. LDA A,I LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP MPY.F,I DONE. * * ONE OPERAND CONSTANT. SPECIAL CASES. * MPY02 STA T1MPY FIRST ONE. COMMUTE. JSB CO.F LDB T1MPY MPY03 SZB,RSS X * 0 ? JMP MPY05 CPB K2 * 1 ? JMP MPY06 CPB KM2 * (-1) ? JMP MPY07 CPB K3 * 2 ? JMP MPY08 * LDA F.RTP ONLY CASES LEFT: CPA INT INTEGER TIMES SSB POSITIVE POWER OF 2. JMP MPY01 NO. * CPB BMAX POWER OF 2 AT ALL ? JMP MPY01 NO. * STB T1MPY YES. SAVE 2+LOG2(C). JSB PO1.F REMOVE C. LDA T1MPY X * 4 ? CPA K4 JMP MPY04 YES. SKP LDB F.S1T,I NO. OTHER POWER OF 2, LOAD X INTO (A). JSB LDA.F JSB SRT.F SHIFT DESTROYS (B), SO SAVE IT. DEF K1 LDA T1MPY FORM POWER OF 2. ADA KM2 ADA LSLI FORM 'LSL K' JSB OAI.F JSB P1P.F SET STACK RIGHT. JMP MPY.F,I DONE. * MPY04 JSB SCG.F X * 4, LOAD INTO EITHER REG. LDA MPY.4 FORM '*LR,R*L' JSB ORI.F JMP MPY.F,I (OTHER REG INTACT.) * MPY05 JSB CO.F X*0. RESULT=0. JSB CRD.F IF X WAS IN A REGISTER, FREE IT. DEF F.S1T,I * MPY06 JSB PO1.F X*1. JUST DISCARD THE 1. (OR 0) LDA F.S1T,I SET F.RES RIGHT. STA F.RES JMP MPY.F,I * MPY07 JSB PO1.F X*(-1). DISCARD IT, JSB NEG.F NEGATE. JMP MPY.F,I * MPY08 JSB MY2.F COMMON WITH DIVIDE BY 0.5 . JMP MPY.F,I * MY2.F NOP JSB PO1.F X*2. CHANGE TO X+X. LDA F.S1T,I DUPLICATE X. STA F.RES SET UP (F.RES) IN CASE MEM. LDA F.RTP NO. REGISTER DATA ? JSB MIM.F SSB,RSS JSB SCG.F YES. LOAD IT NOW (SET F.RES). LDA F.RES (IF WE DON'T, DUP STCK ENTRY NOT UPDATED) JSB PU1.F PUSH DUPLICATE ENTRY ONTO STACK. JSB ADD.F & ADD. JMP MY2.F,I DONE. * INT OCT 010000 F.IM=INT BMAX OCT 77777 K3 DEC 3 K4 DEC 4 SKP * INTEGER MULTIPLY. * MPY09 LDB F.S1N,I LOAD 1ST OPND INTO (A). JSB LDA.F (MIGHT BE IN (B), SO DO FIRST) LDA F.S1T,I IS 2ND OPND IN (B) ? CPA K1 JMP MPY10 YES. LEAVE IT. * JSB SRT.F NO. SAVE (B). DEF K1 MPY10 LDA .MPY ISSUE 'MPY' JSB OAI.F LDB F.S1T,I ISSUE 'DEF 2ND OPND' JSB DEF.F CLA SET RESULT TO BE (A), STA F.RES LDA INT OF TYPE INT. (THE B-REG STUFF STA F.RTP ABOVE GARBAGED IT.) JSB P2P.F FIX UP STACK. LDA K2 SET UP (B) REG TO BE STA F.ACB EXTENSION OF (A). JMP MPY.F,I DONE. SPC 2 T1MPY NOP LSLI LSL 16 PROTOTYPE 'LSL' FOR INT MPY. MPY.4 ALR,RAL MODEL FOR INTEGER MPY BY 4. * DMPYT DEF *+1 DEF MPY09,I INT, SPECIAL CASE. ABS 012+D.REG DBI, .DMP ABS 013+D.REG REA, .FMP ABS 014+D.OPM DBL, .XMPY ABS 015+D.OPM+D.REG RE8, .TMPY ABS 016+D.OPM CPX, .CMPY ABS 302+D.REG+D.OPM ZPX, .ZMPY SKP * *********** * * DIVIDE * * *********** SPC 1 DIV.F NOP JSB MAT.F MATCH TYPE>S. JSB MP2.F JSB F2T.F FREE TEMPS. LDA K3 TRY TO FOLD. A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP DIV.F,I TWO CONSTANTS. DONE. JMP DIV04 2ND IS CONSTANT. JMP DIV02 1ST IS CONSTANT. * DIV01 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. LDA F.RTP DETERMINE DOT FUNCTION ADDR. JSB MIM.F ADA DDIVT LDA A,I DOT FUNCTION DESCRIPTION. LDB F.S1T,I IF DOUBLE INTEGER AND 2ND OPND CPA .DDI IS IN (A,B), SZB JMP DIV1A (NO) * JSB CO.F THEN COMMUTE & USE REVERSE DIVIDE. LDA .DDIR DIV1A LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP DIV.F,I EXIT. * DIV02 SZA 0/X ? JMP DIV03 NO. * JSB CRD.F YES. IF X WAS IN A REGISTER, FREE IT. DEF F.S1T,I JSB PO1.F RESULT=0. LDA F.S1T,I SET F.RES RIGHT. STA F.RES JMP DIV.F,I * DIV03 LDA F.RTP NO. INTEGER ? CPA INT RSS JMP DIV01 NO. NO HELP. SKP * FOR (CONST)/X, CAN DO SIGN EXTENSION NOW. * JSB SBR.F YES, SAVE A & B. LDB F.S1N,I LOAD DIVIDEND INTO (A). JSB LDA.F LDA F.S1N,I GET SIGN OF CONSTANT. ADA K2 LDB A,I (B)=CONST. LDA CLBI IF +, DO 'CLB'. SSB LDA CCBI ELSE DO 'CCB'. JSB OAI.F JSB CO.F FIX UP STATUS: JSB P1P.F SET STACK & REG DATA RIGHT. JSB CO.F LDA K2 SET (B) STATUS TO INDICATE STA F.ACB THAT (B,A) IS A DBL INT. JMP DIV01 NOW LET IT TAKE ITS COURSE. * * 2ND OPND IS CONSTANT. * DIV04 SZB X/0 ? JMP DIV05 NO. * LDA K14 YES. WARNING. JSB WAR.F JMP DIV01 DON'T BOTHER TRYING TO OPTIMIZE IT. * DIlV05 CPB K1 X/0.5 ? JMP DIV06 YES. * CPB K2 X/1.0 ? JMP DIV07 YES. * CPB KM2 X/(-1) ? JMP DIV10 YES. * CPB K3 X/2.0 ? RSS (YES) JMP DIV01 NO, NOTHING SPECIAL. * LDA F.RTP YES. INTEGER*2 ? CPA INT RSS (YES) JMP DIV01 NO. CAN'T HELP. * JSB PO1.F YES. CHANGE TO SHIFT. POP THE 2, JSB SCG.F LOAD INTO EITHER REGISTER, LDA SSAI AND DO: 'SSI', JSB ORI.F LDA INAI 'INA' JSB ORI.F LDA ARSI 'ARS' JSB ORI.F JMP DIV.F,I THEN DONE. * DIV10 JSB PO1.F X/(-1). JUST NEGATE. DISCARD THE -1, JSB NEG.F & NEGATE. JMP DIV.F,I DONE. * DIV06 JSB MY2.F USE X*2. JMP DIV.F,I DONE. * DIV07 JSB PO1.F X/1, NOP. LDA F.S1T,I SET F.RES RIGHT. STA F.RES JMP DIV.F,I * K14 DEC 14 CCBI CCB SKP * INTEGER DIVIDE. * DIV08 LDA F.S1N,I IF 1ST OPND IN (A), LDB F.ACB AND (B,A) = DBL INT, CPB K2 SZA RSS NO. JMP DIV09 THEN CAN SKIP THE LOAD & EXTEND. * LDB F.S1N,I NO. LOAD 1ST OPND INTO (B). JSB LDB.F JSB SRT.F FREE UP (A). DEF K0 LDA ASRI DO 'ASR 16' JSB OAI.F DIV09 LDA DIVI DO 'DIV' JSB OAI.F LDB F.S1T,I DO 'DEF 2ND OPND' JSB DEF.F CLA SET RESULT IN (A). STA F.RES JSB CBR.F NOTHING IN (B) ANYMORE, LDA F.RTP BUT HAVE TO SET UP (A). JSB SRS.F DEF K0 JSB P2P.F JMP DIV.F,I DONE. * DDIVT DEF *+1 DOT FUNCTION TABLE FOR DIVIDE. DEF DIV08,I INT, SPECIAL CASE. .DDI ABS 018+D.REG DBI, .DDI ABS 019+D.REG REA, .FDV ABS 020+D.OPM DBL, .XDIV ABS 021+D.OPM+D.REG RE8, .TDIV ABS 022+D.OPM CPX, .CDIV ABS 303+D.REG+D.OPM ZPX, .ZDIV * .DDIR ABS 023+D.REG DBI, .DDIR (REVERSED) DIVI OCT 100400 SKP * ****************** * * EXPONENTIATION * * ****************** SPC 1 * DETERMINE FINAL TYPE, CHECK CONSTANTS. * EXP.F NOP JSB MP2.F MAP OPERAND(S) IN IF IN EMA. JSB F2T.F FREE TEMPS. JSB GT2.F GET TYPES. STA T2EXP SAVE EXPONENT TYPE. STB T1EXP SAVE BASE TYPE. CPA CPX IS EXPONENT COMPLEX ? RSS CPA ZPX OR DOUBLE COMPLEX ? JMP EXP99 YES, ERROR. * JSB MIM.F MAP EXPONENT TYPE. SEZ ARITHMETIC ? JMP EXP99 NO, ERROR. * STA T3EXP YES. SAVE IT. LDA T1EXP MAP BASE TYPE. JSB MIM.F SEZ ARITHMETIC ? JMP EXP99 NO, ERROR. * STA T4EXP SAVE MAPPED BASE TYPE. CMA,INA WHICH IS HIGHER TYPE ? ADA T3EXP LDB T1EXP (ASSUME BASE) SSA,RSS WELL ? LDB T2EXP EXPONENT. USE INSTEAD. STB F.RTP SET UP RESULT TYPE. LDA T4EXP RESTORE BASE TYPE. MPY K5 COMPUTE TABLE ADDR: 5 EXP TYPES. ADA T3EXP OFFSET = 5*(BASE TYPE)+(EXP TYPE) ADA DEXPT PLUS BASE. LDA A,I (A) = DOT FUNCTION WORD. SZA,RSS LEGAL COMBINATION ? JMP EXP99 NO, ERROR. * STA T3EXP YES. SAVE IT. CCA CHECK OUT CONSTANTS, BUT DON'T FOLD. JSB CF2.F JMP EXP02 BOTH CONSTANT. JMP EXP04 SECOND ONLY. JMP EXP09 FIRST ONLY. * * CAN'T USE CONSTANTS, ISSUE NORMAL CODE. * EXP01 JSB ATM.F NEITHER. ALLOCATE TEMP IF REQ'D. LDA T3EXP GENERATE THE CODE. LDB K2 TWO OPERANDS. EXP00 JSB GDF.F LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP EXP.F,I DONE. N SKP * FIRST CONSTANT. 1**X = 1. * EXP09 CPA K2 1**X ? JMP EXP03 YES. RESULT=1. JMP EXP01 NO. NO HELP. * * BOTH CONSTANTS. CHECK 1**C THEN SECOND. * EXP02 CPA K2 1**C ? RSS YES, RESULT = 1. JMP EXP04 NO. * EXP03 JSB CRD.F FOR CASE 1**X, DEF F.S1T,I IF X WAS IN REGISTER, FREE IT. JSB PO1.F JUST DISCARD CONSTANT OR X. LDB F.S1T AND CONVERT TO FINAL TYPE. JSB CON.F JMP EXP.F,I AND EXIT. * * SECOND CONSTANT. CHECK -1,0,0.5,1,2 . * EXP04 SZB,RSS X**0 ? JMP EXP01 YES, MAY BE ERROR, USE NORMAL. * CPB K2 X**1 ? JMP EXP03 YES. RESULT=X. * CPB KM2 X**-1 ? JMP EXP06 YES. * CPB K3 X**2 ? JMP EXP07 YES. * CPB K1 X**0.5 ? (CAN'T BE INT IF SO) JMP EXP08 YES. USE SQRT. * * TRY TO USE .FPWR OR .TPWR * LDA T1EXP IS BASE: CLBI CLB CPA REA REAL ? LDB .FPWR CPA RE8 DOUBLE ? LDB .TPWR SZB,RSS JMP EXP01 NO. NO HELP. * STB T4EXP YES. TRY TO USE .FPWR OR .TPWR . LDB F.S1T,I GET FIRST WORD OF CONSTANT. MUST BE +. ADB K2 LDA B,I SSA WELL ? JMP EXP01 NEGATIVE. NO HELP. * LDA T2EXP WHAT TYPE IS EXPONENT ? CPA INT INTEGER ? JMP EXP05 YES. ALWAYS O.K. * CPA DBI DOUBLE INTEGER ? RSS YES. JMP EXP01 NO. NO HELP. * DLD B,I CHECK THAT DOUBLE INT IS SMALL ENUF. SWP ASL 16 SOC WELL ? JMP EXP01 NO. HARD WAY. * LDA B YES. FORM SINGLE INT CONSTANT. JSB EIC.F JSB PO1.F REPLACE WITH SHORT CONSTANT. LDA F.A JSB PU1.F EXP05 JSB CO.F PUT THE EXPONENT FIRST. LDA T4EXP GET DOT FUNCTION INFO BACK. STA T3EXP USE IT INSTEAD OF OTHER. JMP EXP01 GO USE NORMAL CALL. * * X**(-1) = 1/X. * EXP06 JSB PO1.F POP (-1) OFF STACK. CLA,INA FORM A +1. JSB EIC.F JSB PU1.F PUSH ON STACK, JSB CO.F COMMUTE: HAVE +1,X. LDB F.S1T CONVERT X TO FINAL TYPE. JSB CON.F JSB DIV.F DIVIDE. JMP EXP.F,I DONE. * * X**2 = X*X. * EXP07 JSB PO1.F X**2, DO AS X*X. LDB F.S1T CONVERT X IF REQ'D. JSB CON.F LDA F.S1T,I DUPLICATE X. STA F.RES LDB F.S1T,I CONSTANT ? JSB CFC.F RSS JMP EXP10 YES. DON'T LOAD !!! * LDA T1EXP NO. REGISTER DATA ? JSB MIM.F SSB,RSS JSB SCG.F YES. LOAD IT NOW (SET F.RES). EXP10 LDA F.RES (OTHERWISE, DUP STCK ENTRY NOT UPDATED.) JSB PU1.F PUSH IT. JSB MPY.F DO X*X. JMP EXP.F,I DONE. SKP * X**0.5 = SQRT(X). * EXP08 JSB PO1.F X**0.5 . DISCARD 0.5 LDB F.S1T CONVERT TO FINAL TYPE IF NECESSARY. JSB CON.F LDA F.RTP MAP TYPE. JSB MIM.F ADA DSQT PICK SQRT,DSQRT,.SQRT LDA A,I DOT FUNCION WORD. CLB,INB ONE ARGUMENT. JMP EXP00 GO DO IT & FIX STACK. * EXP99 LDA K45 ILLEGAL EXPONENTIATION. JSB ER.F * T1EXP NOP T2EXP NOP T3EXP NOP T4EXP NOP K5 DEC 5 K45 DEC 45 REA OCT 020000 F.IM=REA RE8 OCT 120000 F.IM=RE8 SKP DEXPT DEF *+1 EXPONENTIATION DOT FUNCIONS. ABS 030+D.OPM+D.ER0 .ITOI ABS 031+D.OPM+D.ER0 .ITOJ NOP (INT**REA ILLEGAL) NOP (INT**DBL ILLEGAL) NOP (INT**RE8 ILLEGAL) * ABS 032+D.OPM+D.ER0 .JTOI ABS 033+D.OPM+D.ER0 .JTOJ NOP (DBI**REA ILLEGAL) NOP / (DBI**DBL ILLEGAL) NOP (DBI**RE8 ILLEGAL) * ABS 036+D.OPM+D.ER0 .RTOI ABS 037+D.OPM+D.ER0 .RTOJ ABS 038+D.OPM+D.ER0 .RTOR ABS 039+D.OPM+D.ER0 .RTOD ABS 040+D.OPM+D.ER0 .RTOT * ABS 042+D.OPM+D.ER0 .DTOI ABS 043+D.OPM+D.ER0 .DTOJ ABS 044+D.OPM+D.ER0 .DTOR ABS 045+D.OPM+D.ER0 .DTOD ABS 046+D.OPM+D.ER0 .DTOT * ABS 048+D.OPM+D.ER0 .TTOI ABS 049+D.OPM+D.ER0 .TTOJ ABS 050+D.OPM+D.ER0 .TTOR ABS 051+D.OPM+D.ER0 .TTOD ABS 052+D.OPM+D.ER0 .TTOT * ABS 034+D.OPM+D.ER0 .CTOI ABS 035+D.OPM+D.ER0 .CTOJ NOP (CPX**REA ILLEGAL) NOP (CPX**DBL ILLEGAL) NOP (CPX**RE8 ILLEGAL) * ABS 305+D.OPM+D.ER0 .ZTOI ABS 306+D.OPM+D.ER0 .ZTOJ NOP (ZPX**REA ILLEGAL) NOP (ZPX**DBL ILLEGAL) NOP (ZPX**RE8 ILLEGAL) * .FPWR ABS 041 .TPWR ABS 053 * DSQT DEF *-1 SQUARE ROOT DOT FUNCTION TABLE. ABS 102+D.REG+D.ER0 SQRT ABS 103+D.OPM+D.RTN+D.ER0 DSQRT ABS 104+D.OPM+D.RTN+D.ER0 .SQRT SKP * *************************** * * CHECK FOR TWO CONSTANTS * * *************************** SPC 1 * INPUT: TOP 2 VALUE ON STACK 1 TO BE CHECKED. * OUTPUT: RTN TO P+1: NEITHER IS CONSTANT. * P+2: FIRST (TOP) ONLY. (DFCN1=ADDR) * P+3: SECOND ONLY. (DFCN2=ADDR) * P+4: BOTH ARE CONSTANTS. (DFCN1,DFCN2) * IF THE SECOND ONE IS CONSTANT, ITS ADDRESS IS RETURNED IN (B) * AND ITS FIRST WORD IN (A). SPC 1 C2C.F NOP LDB F.S1T,I CHECK FIRST OPERAND. JSB CFC.F RSS NOT CONSTANT. ISZ C2C.F CONSTANT. BUMP RTN BY ONE. STB DFCN1 SAVE ADDR. LDB F.S1N,I CHECK SECOND OPERAND. JSB CFC.F JMP C2C.F,I NOT CONSTANT. ISZ C2C.F CONSTANT. BUMP RTN BY TWO. ISZ C2C.F STB DFCN2 SAVE ADDR. JMP C2C.F,I EXIT. * DFCN1 NOP DFCN2 NOP SKP * *************************************** * * .AND. .OR. .EQV. .NEQV. .XOR. .EOR. * * *************************************** SPC 1 AND.F NOP JSB AND00 AND: 0 * .OR.F NOP JSB AND00 OR: 1 * XOR.F NOP ALSO .NEQV. & .EOR. JSB AND00 XOR: 2 (ALSO .NEQV. & .EOR.) * EQV.F NOP JSB AND00 EQV: 3 * AND00 NOP COMMON ENTRY. LDA AND00 TRAPSE BACK THRU CALL. ADA KM2 (A)=ADDR OF CALLER'S ENTRY. LDB A,I (B)=RETURN ADDR, STB AND.F SAVE IT. CMA FORM (ADDR ENTRY) - (ADDR AND.F) ADA DFAND CMA ARSI ARS /2 = OPERATOR ORDINAL. STA T1AND T1AND = OP #. * JSB MP2.F MAP ITEM(S) IF IN EMA. JSB GT2.F GET TYPES. CPB LOG 1ST=LOG ? JMP AND02 YES. * CPB LO4 1ST=LO4 ? JMP AND02 YES. * CPB INT 1ST=INT ? JMP AND01 YES. * CPB DBI 1ST=DBI ? JMP AND04 YES. JMP AND99 NO. IMPROPER TYPE, ERROR 56. * * 1ST OPND IS INTEGER. * AND01 CPA DBI 2ND=DBI ? JMP AND05 YES. CONVERT 1ST TO DBI. * CPA INT 2ND=INT ? JMP AND03 YES. INT.OP.INT, SAME AS LOGICAL. JMP AND99 NO. ERROR. * * 1ST OPERAND IS LOG OR LO4, 2ND MUST BE TOO. * AND02 CPA LOG 2ND=LOG ? RSS YES. CPA LO4 OR LO4 ? RSS YES. JMP AND99 NO. MIXED, ERROR. SKP AND03 JSB F2T.F FREE TEMPS. CLA,CLE,INA PUT REGISTER FIRST (PREF A) OR CONSTANT. JSB CCO.F LDB F.S1N,I LOAD FIRST OPND INTO (A). JSB LDA.F (ONLY ONE WORD, EVEN IF LO4) LDA DANDI INDEX INTO INSTRUCION TABLE: ADA T1AND LDA A,I (A)=OPCODE: AND/IOR/XOR/XOR LDB F.S1T,I DO THE OPERATION. JSB SOA.F LDB T1AND IF IT WAS .EQV. , LDA CMAI DO 'CMA' CPB K3 WELL ? JSB OAI.F YES. LDA F.S1T,I WE WANT TO FREE 2ND OPND IF REGISTER, CPA F.S1N,I BUT NOT IF IT IS SAME AS FIRST OPND. JMP AND3A SAME. LEAVE RESULT INTACT. * JSB CRD.F DIFFERENT. FREE 2ND OPND (IF REGISTER) DEF F.S1T,I AND3A JSB P2P.F POP OPNDS, PUSH RESULT. JMP AND.F,I EXIT. * * DOUBLE INTEGER MASKING OPERATIONS. * AND04 CPA INT 1ST=DBI. 2ND=INT, RSS CPA DBI OR DBI ? RSS YES. O.K. JMP AND99 NO. MISMATCH. * AND05 JSB MAT.F CLOSE ENUF. CONVERT IF MUST. JSB F2T.F FREE TEMPS. JSB F2T.F IF THAT CREATED ANOTHER TEMP, FREE IT. LDA DBI SET TYPE. STA F.RTP CLA,CLE,INA PUT REGISTER FIRST (PREF A) OR CONSTANT. JSB CCO.F LDA DDAND INDEX INTO FUNCTION TABLE. ADA T1AND LDA A,I (A)=DOT FUNCTION #: .DAND/.DOR/.DXOR/.DEQV LDB K2 TWO OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP AND.F,I DONE. * AND99 LDA K56 ILLEGAL TYPE COMBINATION, ERROR 56. JSB ER.F * K56 DEC 56 LO4 OCT 110000 T1AND NOP OPERATOR: AND=0, OR=1, XOR=2, EQV=3. DFAND DEF AND.F FOR COMPUTING ABOVE. * DANDI DEF *+1 KEEP IN ORDER * OCT 012000 AND * OCT 032000 IOR * OCT 022000 XOR * OCT 022000 (FOR .EQV.) * * DDAND DEF *+1 KEEP IN ORDER * ABS 244+D.REG .DAND * ABS 247+D.REG .DOR * ABS 250+D.REG .DXOR * ABS 253+D.REG .DEQV * SKP * ******* * * NOT * * ******* SPC 1 NOT.F NOP JSB MP1.F MAP ITEM IF IN EMA. JSB F1T.F FREE TEMP. JSB GT1.F TYPE ? LDB F.S1T,I (B=F.A OF OPND) CPA DBI DOUBLE INTEGER ? JMP NOT01 YES. GO DO CMA & CMB. * CPA INT INTEGER ? RSS YES, CMA. CPA LOG LOGICAL ? RSS YES, CMA. CPA LO4 DOUBLE LOGICAL ? RSS YES, CMA (FIRST WORD ONLY). JMP AND99 NO, ILLEGAL TYPE. * LDA F.LA1 YES. TWO .NOT.'S IN A ROW ? CPA F.COP JMP NOT02 YES. THEY CANCEL. * JSB LDA.F NO. COMPLEMENT FIRST WORD ONLY. LDA CMAI OUTPUT CMA/CMB. JSB ORI.F COMPLEMENT. JSB P1P.F FIX UP STACK. JMP NOT.F,I DONE. * NOT01 LDA F.LA1 DBL INT. TWO NOT'S IN A ROW ? CPA F.COP JMP NOT02 YES. THEY CANCEL. * JSB LD.F LOAD WHOLE DOUBLE INTEGER. LDA CMAI OUTPUT 'CMA' JSB OAI.F LDA CMBI AND 'CMB' JSB OAI.F JSB P1P.F FIX UP STACK. JMP NOT.F,I DONE. * NOT02 JSB RD.F TWO .NOT.'S; JUST SKIP SECOND ONE. JMP NOT.F,I * O.NOT DEC 10 OPCODE FOR .NOT. SKP * **************************** * * CHANGE RESULT TO LOGICAL * * **************************** SPC 1 SLR.F NOP JSB GRD.F ASSUME IT'S IN A REGISTER. DEF F.RES LDA LOG CHANGE TYPE. JSB SRD.F DEF F.RES JMP SLR.F,I DONE. SPC 2 * SUBROUTINE TO REVERSE ORDER OF RELATIONAL OPERATION. * RRO.F NOP LDA F.COP CURRENT OPERATION. ADA DRLT1 INDEX INTO TABLE. LDA A,I GET OPCODE & OTHER STUFF. AND B37 PICK OUT OPCODE BITS. STA F.COP SET UP NEW OPCODE. JMP RRO.F,I DONE. SPC 2 * SUBROUTINE TO NEGATE RELՈATIONAL OPERATION. * NRO.F NOP LDA F.COP CURRENT OPERATION. ADA DRLT1 INDEX INTO TABLE. LDA A,I NEW OPCODE & JUNK. ALF,ALF RIGHT-JUSTIFY NEW OPCODE. RAL,RAL AND B37 ISOLATE IT. STA F.COP SET UP NEW OPCODE. JMP NRO.F,I DONE. SKP * ********************************* * * .LT. .LE. .EQ. .NE. .GE. .GT. * * ********************************* SPC 1 .LT.F BSS 0 .LE.F BSS 0 .EQ.F BSS 0 .NE.F BSS 0 .GE.F BSS 0 .GT.F BSS 0 REL.F NOP * * FIRST ACCOUNT FOR NEGATION (E.G. PREPROCESSORS). * REL03 LDA F.LA1 IS NEXT OPERATION .NOT. ? CPA O.NOT RSS (YES) JMP REL04 NO. * JSB RD.F YES. DISCARD THE .NOT. JSB NRO.F NEGATE SENSE OF THE OPERATOR. JMP REL03 TRY FOR MORE. * REL04 JSB MP2.F MAP ITEM(S) IF IN EMA. REL05 LDA K4 OPERATION = 4, COMPARE. JSB CF2.F EITHER CONSTANTS ? JMP REL40 BOTH. JMP REL10 SECOND. RSS FIRST. JMP REL11 NEITHER. * JSB CO.F FIRST. MAKE IT SECOND. JSB RRO.F AND REVERSE OPERATOR. JMP REL05 GO TRY AGAIN. * REL10 SZB,RSS SECOND CONSTANT. ZERO ? JMP REL12 YES. SPECIAL-CASE. * CPB KM2 -1 ? RSS (YES) JMP REL11 NO. NOT A SPECIAL CASE. * JSB GT2.F YES. IS IT: CPB INT INT*2, RSS CPB DBI OR INT*4 ? RSS JMP REL11 NO. NO HELP. * LDA F.COP YES. IS OPERATOR: CPA OP.GT .GT. RSS CPA OP.LE OR .LE. ? CCB,RSS (B=-1) JMP REL11 NO. NO HELP. * ADA B YES. .GT.-1 => .GE.0 STA F.COP AND .LE.-1 => .LT.0 JMP REL12 NOW TREAT CONSTANT AS ZERO. * * MATCH OPERAND TYPES, PROCESS BY TYPE. * REL11 JSB MAT.F  FIRST, MAKE SURE MATCHING TYPES. JSB F2T.F FREE TEMPS. LDA F.RTP INTEGER ? CPA INT JMP REL14 YES. * CPA DBI DOUBLE INTEGER ? JMP REL30 YES. * LDB F.COP A LITTLE CHECKING BEFORE WE GO ON... CPB OP.EQ IS IT .EQ. ? RSS CPB OP.NE OR .NE. ? JMP REL15 YES. * CPA CPX NO. THEN COMPLEX ILLEGAL. RSS CPA ZPX ALSO DOUBLE COMPLEX. JMP CON10 JMP REL50 ELSE CARRY ON... * REL15 CPA REA YES, .EQ. OR .NE., REAL ? JMP REL30 YES. GO USE .DCO AS IF DOUBLE INT. JMP REL50 NO. NORMAL SUBTRACT. SKP * INTEGER COMPARE. * REL14 LDA F.COP WHICH TEST ? CPA OP.EQ .EQ. ? RSS CPA OP.NE OR .NE. ? JMP REL02 YES. GO USE 'CPA'. * CPA OP.LE IF .LE., JSB CO.F COMMUTE. CPA OP.GT IF .GT., JSB CO.F COMMUTE. LDA CLOI ISSUE 'CLO' JSB OAI.F LDB F.S1T,I IS 2ND OPND CONSTANT ? JSB CFC.F WELL ? RSS NO. (SKIP THE SENSE REVERSAL LATER) CPA B100K YES. BUT IS IT MAX NEG ? CCA,RSS YES. CAN'T DO THAT ONE. CLA NO. (A=0 REVERSES SENSE) STA T2REL SAVE FLAG. SZA WHICH IS IT ? JMP REL00 NON-CONST. * JSB SUB.F CONST. DO NORMAL SUBTRACT. JMP REL01 & WILL REVERSE SENSE TOO. * * 2ND OPND NOT CONST: CLO / LDA <1ST> / CMA / ADA <2ND> / SOS / CMA * * 2ND CONST, NOT -32768: CLO / LDA -<2ND> / ADA <1ST> / SOC / CMA * REL00 JSB CO.F NOT CONST. WANT TO COMPL 1ST OPND, SO CCA PUT 1ST OPND ON TOP, CREATE (-1), JSB EIC.F JSB PU1.F AND PUT ON STACK. JSB CO.F MAKE IT (-1),(1ST OPND) JSB SUB.F THIS IS A ROUNDABOUT WAY OF 1'S COMPL. JSB ADD.F HAVE (2ND OPND)-(1ST OPND)-1 REL01 LDA @SOSI OVERFLOW CHECK. LDB F.COP WILL REVERSE SENSE IF CPB OP.GE .GE. XOR B100 CPB OP.LE OR .LE. XOR B100 ISZ T2REL NORMAL SUBTRACT REVERSES SENSE TOO. XOR B100 JSB OAI.F THERE IT GOES... LDA CMAI 'CMA' CHANGES (2ND)-(1ST)-1 INTO JSB ORI.F (1ST)-(2ND) (IF NO OFL) JSB SLR.F CHANGE RESULT TYPE TO LOGICAL. JSB P1P.F FIX UP STACK. JMP REL.F,I DONE. SKP * INTEGER .EQ. & .NE. * REL02 CLA,CLE .EQ. & .NE. COMMUTE IF HELPS. JSB CCO.F A=0: EITHER REG. E=1: CONSTANTS TOO. LDB F.S1N,I LOAD FIRST ONE. JSB LD.F JSB ABB.F FORM A/B BIT. ADA CPAI ISSUE CPA/CPB. LDB F.S1T,I TO SECOND OPND. JSB SOA.F JSB CRD.F FREE UP REGISTER CONTAINING 2ND OPND DEF F.S1T,I (MAY ALSO FREE 1ST, THAT'S O.K.) JSB PO1.F POP OPERANDS. JSB PO1.F JSB LLI.F SET UP LOGICAL IF INFO. LDA DRLT4 GET TABLE FOR CODE GEN. JMP REL90 DO IT. * * COMPARE TO ZERO. TAILORED SEQUENCES. * REL12 JSB F2T.F FREE TEMPS. JSB GT2.F (B) = TYPE OF NEXT-TO-TOP (TOP=ZERO). LDA F.COP (A) = OPERATION. CPB CPX IF COMPLEX, RSS CPB ZPX OR DOUBLE COMPLEX, RSS (YES) JMP REL06 NO. * CPA OP.EQ YES. THEN MUST BE .EQ. RSS CPA OP.NE OR .NE. JMP REL13 (YES) JMP CON10 ALL OTHERS ILLEGAL. * REL06 CPB DBI ALSO, IF DBI... RSS JMP REL13 (NO) * CPA OP.LT .LT. IS EASY (SIGN TEST) JMP REL13 * CPA OP.GE AND .GE. (SIGN TEST) JMP REL13 * CPA OP.LE BUT NOT .LE. JMP REL11 * CPA OP.GT OR .GT. JMP REL11 * LDB F.S1N,I FOR DOUBLE INT .EQ., .NE. JSB LD.F ZERO, MUST CHECK OUT  LDA IORBI BOTH WORDS; DO 'IOR B' JSB OAI.F (A=0) STA F.S1N,I NOTE THAT THE LOAD WAS DONE. * REL13 JSB LLI.F SET UP 'LOGICAL IF' INFO. JSB PO1.F POP THE ZERO OFF THE STACK. REL16 LDB F.S1T,I GET TYPE AGAIN. JSB GT1.F LDB K2 (B=2) CPA ZPX IF DOUBLE COMPLEX, BLS,SLB (YES. B=4) CPA CPX OR COMPLEX, RSS (YES) JMP REL07 NO. NO PROBLEM. * STB T3REL THEN LOAD UP FIRST WORD OF SECOND PART. LDA F.S1T,I IF ADDRESS IN REGISTER, SZA CPA K1 RSS (YES) JMP REL18 NO. * JSB SRT.F THEN SAVE IT: SINCE ADDRESS WILL BE USED DEF F.S1T,I TWICE, AND NO ONE ELSE KNOWS THAT. REL18 LDB INT CALL LOADED RESULT INTEGER. STB F.RTP LDA T3REL OFFSET TO SECOND PART. LDB F.S1T,I JSB LDO.F LOAD ITEM+2 OR ITEM+4. LDB F.RES MAKE SURE IT'S IN (A). JSB LDA.F LDA IORI 'OR' IN THE FIRST WORD OF FIRST PART. LDB F.S1T,I JSB SOA.F JMP REL09 * REL07 LDB F.S1T,I LOAD FIRST WORD OF ITEM. JSB LDF.F REL09 JSB PO1.F NOW POP THAT OFF STACK. LDA DRLT2 GET TABLE ADDR FOR COMPARE TO ZERO. JMP REL90 GO GENERATE CODE FOR IT. SKP * DOUBLE INTEGER COMPARE. * REL30 JSB LLI.F LOOK AHEAD FOR LOGICAL IF. LDB T1REL 0=VALUE, 1=IF & NO GOTO, 2=IF & GOTO. ADB KM2 >=0 IFF LOG IF & GOTO. LDA F.COP TRY TO GET THE BEST COMBINATION HERE: CPA OP.GE IF .GE., CMBI CMB COMMUTE IFF LOG IF & GOTO. CPA OP.GT IF .GT., CMB DITTO. SSB,RSS IS BEST CODE SEQUENCE FROM COMMUTING ? JMP REL31 NO. * JSB CO.F YES. COMMUTE, JSB RRO.F AND REVERSE OPERATOR. REL31 CLA,CCE A=0: EITHER REG. E=1: IGNORE CONSTANTS. JSB CCO.F ON OTHER HAN18D, IF ALREADY IN REGISTERS, SEZ THEN THAT IS MORE IMPORTANT. JSB RRO.F YUP. WE COMMUTE, HAVE TO REVERSE TOO. LDA .DCO NOW ISSUE THE .DCO CODE. LDB K2 TWO OPERANDS. JSB GDF.F ALL AUTOMATIC! LDA DRLT5 GET TABLE ADDR FOR STUFF THAT FOLLOWS. JMP REL90 AND GO ISSUE CODE. * * BOTH CONSTANTS, FOLD IT. * REL40 LDB F.COP INDEX TABLE OF VALUES. ADB DRLT1 GET WORD WHICH HAS 3-BIT LOG VALUES: LDB B,I 3/IF<, 3/IF>, 3/IF= SSA,RSS >=0 ? RBL YES, SKIP '<'. SZA,RSS =0 ? RBL YES, SKIP '>'. LDA B FORM LOGICAL CONSTANT. AND B100K STA F.IDI SET UP A.T. ENTRY. LDA LOG JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A SET IT UP AS RESULT. STA F.RES JSB P2P.F FIX UP STACK. JMP REL.F,I DONE. SKP * REA/DBL/RE8/CPX/ZPX COMPARE USING SUBTRACT. * REL50 JSB LLI.F FIGURE OUT IF LOGICAL IF FOLLOWS. LDA F.COP COMMUTE IF: CPA OP.LE .LE. RSS CPA OP.GT OR .GT. RSS JMP REL53 NEITHER. DON'T COMMUTE. * JSB CO.F YES. COMMUTE TO GENERATE BETTER CODE. JSB RRO.F REVERSE THE OP TOO. REL53 LDB F.RTP ON THE OTHER HAND, FOR REALS, CPB REA (IS IT REAL*4 ?) CLA,CCE,RSS A=0, E=-1 FOR CCO.F JMP REL54 NOT REAL. * JSB CCO.F BETTER TO HAVE REGISTER FIRST. SEZ DID THAT FORCE A COMMUTE ? JSB RRO.F YES, HAVE TO REVERSE OP THEN. REL54 JSB SUB.F ALL SET. SUBTRACT. JMP REL16 NOW TREAT AS COMPARE TO ZERO. * * SUBR TO LOOK AHEAD FOR LOGICAL IF. * SET UP: T1REL: 0=VALUE, 1=LOGIF, 2=LOGIF & GOTO. * T2REL: IF LOG IF, JUMP TARGET. * LLI.F NOP CLA ASSUME VALUE.  STA T1REL LDA K35 IS NEXT OPCODE THE END-OF-EXPRESSION ? CPA F.LA1 (IF NOT, 2ND CPA FAILS TOO.) LDA F.LA2 YES. IS OPERATOR AFTER NEXT LOGICAL IF ? CPA OPLIF RSS (YES) JMP LLI.F,I NO. * ISZ T1REL ADVANCE TO SECOND CODE SEQUENCE. JSB RD.F DISCARD END-OF-EXPRESSION. JSB RD.F DISCARD LOGICAL IF. JSB RD.F DISCARD SEQUENCE INFO. JSB RD.F GET F.A OF TWPE ENTRY. STA T2REL SAVE IT. DLD A,I GET ITS F.AF . CMB,SSB WHICH TYPE ? JMP LLI.F,I NORMAL. * STB T2REL GOTO. SET UP ITS F.A ISZ T1REL AND ADVANCE POINTER. JMP LLI.F,I DONE. SKP * GENERATE CODE BY TABLE. * REL90 LDB F.COP INDEX BY OPCODE: BLS *2 ADB F.COP *3. THREE CASES. ADA B START OF THREE-WORD BLOCK. LDB T1REL LOGICAL IF CHARACTERIZATION. ADA B ADDR OF CODE SEQUENCE DESCRIPTION. LDA A,I THE DESCRIPTION. STA T1REL SAVE FOR AWHILE. SZB VALUE OR LOGICAL IF ? JMP REL92 LOGICAL IF. NO VALUE HERE. * JSB SLR.F VALUE. SET IT UP. LDA F.RES ON STACK, TOO. JSB PU1.F JMP REL93 GO ISSUE CODE. * REL92 JSB CAR.F IF LOGICAL IF, ZAP REGISTER DATA. * * GENERATE UP TO FOUR INSTRUCTIONS ACCORDING TO THE * THE OPERATION AND WHETHER IT IS THE LAST ONE IN * A LOGICAL IF AND IF THE IF IS FOLLOWED BY 'GOTO'. * REL93 LDA T1REL EXTRACT NEXT VALUE. ALF LDB A (SAVE COPY) AND BM20 (A) = WORD WITH CODE ZAPPED. STA T1REL TO MAKE SURE WE STOP AFTER 4. XOR B HERE'S THE CODE ITSELF. ADA DRLT3 GET THE OPCODE OR PROCESSOR ADDR. LDA A,I RAL,CLE,SLA,ERA WHICH IS IT ? (CLEAR SIGN) JMP 0,I PROCESSOR. USE  IT. * LDB F.RES INSTRUCTION. ADD THE A/B BIT. BLF,BLF BLF,RBR SZA UNLESS NOP. ADA B JSB OAI.F ISSUE INSTRUCTION. JMP REL93 NEXT. * REL94 LDB T2REL JMP. ISSUE IT. LDA JMPI JSB SOA.F JMP REL93 NEXT. * REL95 LDA JMPI JMP *+3. LDB K3 JSB OZ.F JMP REL93 NEXT. * REL96 JMP REL.F,I DONE. * REL97 LDA JMPI RSS: JMP *+2 LDB K2 JSB OZ.F JMP REL93 SKP * TABLE DEFINING OPCODE MAPPING FOR ABOVE. * DRLT3 DEF *+1 DEF REL96,I 00B: END. DEF REL97,I 01B: RSS. (JMP *+2) CLA 02B: CLA. CLA,RSS 03B: CLA,RSS. CCA 04B: CCA. CCA,RSS 05B: CCA,RSS. CMAI CMA 06B: CMA. SSA 07B: SSA. SSA,RSS 10B: SSA,RSS. SZA 11B: SZA. SZA,RSS 12B: SZA,RSS. DEF REL94,I 13B: JMP DEF REL95,I 14B: JMP *+3 CMA,SSA,INA,SZA 15B: CMA,SSA,INA,SZA (SKIP IF <= 0) NOP 16B: NOP SPC 2 LOG OCT 030000 CPX OCT 050000 ZPX OCT 140000 B37 OCT 37 B100 OCT 100 B100K OCT 100000 BM20 OCT 177760 T1REL NOP T2REL NOP T3REL NOP 2/4 FOR CPX/ZPX COMPARE. OP.LT DEC 11 OP.LE DEC 12 OP.EQ DEC 13 OP.NE DEC 14 OP.GE DEC 15 OP.GT DEC 16 OPLIF BYT 2,50 LOGICAL IF OPCODE. K35 DEC 35 END-OF-EXPRESSION OPCODE. SOSI SOS JMPI OCT 26000 CPAI OCT 52000 IORI OCT 32000 IORBI IOR B .DCO ABS 029+D.REG * DRLT1 DEF *+1-11 REVERSALS: NEGATIONS: FOLDING: TRUE IF: OCT 101720 LT=>GT LT=>GE < OCT 122017 LE=>GE LE=>GT < = OCT 021615 EQ=>EQ EQ=>NE = OCT 141516 NE=>NE NE=>EQ < > OCT 061314 GE=>LE GE=>LT > = OCT 041413 GT=>LT GT=>LE > SKP * TABLE FOR COMPARE TO ZERO. * DRLT2 DEF *+1-11-11-11 BYT 0,0 .LT., VALUE: NOTHING. BYT 213,0 IF: SSA,RSS/JMP BYT 173,0 IF,GOTO: SSA/JMP BYT 244,0 .LE., VALUE: SZA,RSS/CCA BYT 333,0 IF: CMA,SSA,INA,SZA/JMP BYT 321,260 IF,GOTO: CMA,SSA,INA,SZA/RSS/JMP BYT 223,100 .EQ., VALUE: SZA/CLA,RSS/CCA BYT 233,0 IF: SZA/JMP BYT 253,0 IF,GOTO: SZA,RSS/JMP BYT 224,0 .NE., VALUE: SZA/CCA BYT 253,0 IF: SZA,RSS/JMP BYT 233,0 IF,GOTO: SZA/JMP BYT 140,0 .GE., VALUE: CMA BYT 173,0 IF: SSA/JMP BYT 213,0 IF,GOTO: SSA,RSS/JMP BYT 226,0 .GT., VALUE: SZA/CMA BYT 321,260 IF: CMA,SSA,INA,SZA/RSS/JMP BYT 333,0 IF,GOTO: CMA,SSA,INA,SZA/JMP * * INTEGER*2 .EQ. AND .NE. * DRLT4 DEF *+1-13-13-13 BYT 122 .EQ., VALUE: CCA,RSS/CLA BYT 33,0 IF: RSS/JMP BYT 260,0 IF,GOTO: JMP BYT 64,0 .NE., VALUE: CLA,RSS/CCA BYT 260,0 IF: JMP BYT 33,0 IF,GOTO: RSS/JMP * * TABLE FOR DOUBLE INTEGER COMPARE. * DRLT5 DEF *+1-11-11-11 BYT 25,40 .LT., VALUE: RSS/CCA,RSS/CLA BYT 261,260 IF: JMP/RSS/JMP BYT 33,0 IF,GOTO: RSS/JMP/--- BYT 345,40 .LE., VALUE: NOP/CCA,RSS/CLA BYT 301,260 IF: JMP*+3/RSS/JMP BYT 273,0 IF,GOTO: JMP/JMP/--- BYT 316,64 .EQ., VALUE: JMP*+3/NOP/CLA,RSS/CCA BYT 313,260 IF: JMP*+3/JMP/JMP BYT 276,0 IF,GOTO: JMP/NOP/--- BYT 316,122 .NE., VALUE: JMP*+3/NOP/CCA,RSS/CLA BYT 276,0 IF: JMP/NOP/--- BYT 313,260 IF,GOTO: JMP*+3/JMP/JMP BYT 23,100 .GE., VALUE: RSS/CLA,RSS/CCA "V BYT 33,0 IF: RSS/JMP/--- BYT 261,260 IF,GOTO: JMP/RSS/JMP BYT 343,100 .GT., VALUE: NOP/CLA,RSS/CCA BYT 273,0 IF: JMP/JMP/--- BYT 301,260 IF,GOTO: JMP*+3/RSS/JMP SKP * ***************************** * * MAP TOP OPERAND IF IN EMA * * ***************************** SPC 1 * NOTE: THIS ROUTINE ALSO CALLED FOR EMA CALL-BY-VALUE * PROCESSING; IT MAY BE CALLED EVEN IF TOS IS A SUB/FCT * NAME WITH SIGN BIT, OR A TWPE ENTRY. * MP1.F NOP LDA F.S1T,I CHECK IT OUT. SSA,RSS IF SUB/FCT ENTRY, CPA K1 OR ALREADY IN (B), JMP MP1.F,I THEN NOT IN EMA. * STA F.A ELSE TRY TO MAP IT. JSB MAP.F STB F.S1T,I UPDATE STACK REGARDLESS. CPB K1 WAS IT MAPPED ? RSS (YES) JMP MP1.F,I NO. DONE. * LDA F.S1T YES: STA F.ACB UPDATE B-REG STACK ADDR, STA F.ACM AND MAP STACK ADDR. JMP MP1.F,I SPC 2 * ********************************** * * MAP TOP TWO OPERANDS IF IN EMA * * ********************************** SPC 1 MP2.F NOP JSB MP1.F FIRST DO TOP OPERAND. LDA F.S1N,I THEN NEXT-TO-TOP. CPA K1 IF ALREADY IN (B), JMP MP2.F,I THEN NOT IN EMA. * STA F.A ELSE TRY TO MAP IT. JSB MAP.F STB F.S1N,I UPDATE STACK REGARDLESS. CPB K1 WAS IT MAPPED ? RSS (YES) JMP MP2.F,I NO. DONE. * LDA F.S1N YES: STA F.ACB UPDATE B-REG STACK INFO. STA F.ACM AND MAP STACK INFO. JMP MP2.F,I SKP * *********************** * * MATCH OPERAND TYPES * * *********************** SPC 1 MAT.F NOP JSB GT2.F GET TYPES OF TWO TOP OPERANDS STB T0MAT SAVE TYPE OF (F.S1N). JSB MIM.F ANALYZE F.RTP. SEZ qh LOGICAL ? JMP CON10 YES, ERROR. * CMA,INA WILL SUBTRACT FROM OTHER. STA T1MAT SAVE. LDA T0MAT ANALYZE OTHER TYPE. JSB MIM.F SEZ LOGICAL ? JMP CON10 YES, ERROR. * ADA T1MAT ORDINAL(F.S1N TYPE) - ORDINAL(F.RTP) SZA,RSS TYPES SAME ? JMP MAT.F,I YES. DONE. * SSA WHICH IS PREFERRED ? JMP MAT01 (F.RTP). SET THAT UP. * LDA T0MAT OTHER. CHANGE F.RTP, STA F.RTP LDB F.S1T AND CONVERT TOS. JMP MAT02 * MAT01 LDB F.S1N NEXT-TO-TOP OPERAND TO BE CONV. MAT02 JSB CON.F GENERATE CONVERSION CODE JMP MAT.F,I SPC 1 T0MAT NOP T1MAT NOP SKP * **************************** * * GENERATE CONVERSION CODE * * **************************** SPC 1 CON.F NOP STB T2CON (B)=POINT. TO STK ENT CONT ELEM. LDB B,I IF ITEM IS IN (B), CPB K1 JMP CON12 THEN SKIP THE EMA TEST. * STB F.A ELSE TRY TO MAP IT IN. JSB MAP.F STB T2CON,I UPDATE STACK. LDA T2CON IF THE ITEM WAS MAPPED, CPB K1 STA F.ACM UPDATE THE STACK POINTER FOR MAPS. * CON12 LDB T2CON,I GET ITS TYPE. JSB FT.F CPA F.RTP SAME AS RESULT TYPE ? JMP CON.F,I YES. IGNORE CALL. * STA T0CON T0CON = SOURCE TYPE. JSB MIM.F MAP THAT. SEZ NON-NUMERIC ? JMP CON08 YES. SPECIAL. * STA T1CON NO. SAVE MAPPED VALUE. LDA F.RTP MAP RESULT TYPE. JSB MIM.F SEZ LOGICAL ? JMP CON09 YES. SPECIAL. * .MPY MPY K7 NO. COMPUTE ADDR CONVERSION TABLE. ADA DCONT (A) = BASE OF SET OF SEVEN. ADA T1CON (A) = ADDR OF TABLE ENTRY. STA T1CON SAVE. LDA F.RTP FOR CF1.F : RESULT TYPE. LDB T2CON STACK ADDR. JSB CF1.F IFl CONSTANT, CONVERT IT. (E=0) JMP CON.F,I SUCCESSFUL. ALL DONE. * CLA SET F.RES=0 IN CASE NOT ASSIGNMENT. STA F.RES LDA F.RTP IS RESULT IN A REGISTER ? JSB MIM.F SSB,RSS JMP CON05 YES. NO TEMPS. * LDB F.S1N STACK ADDR NEXT OPND (INCASE ASSGN). LDA F.COP IS IT ASSIGNMENT ? CPA EQOPC (ONLY ONE SAFE TO BYPASS TEMP ON) JMP CON11 YES. GO TRY LOOK-AHEAD. * LDA F.RTP NO. ASSIGN TEMP NOW. JSB ATC.F STA F.RES JMP CON05 * CON11 JSB TAS.F ALLOCATE DBL/RE8/CPX/ZPX TEMP IF NEEDED. CON05 LDA T1CON,I GO TO SPECIAL CASES NOW BECAUSE RAL,CLE,SLA,ERA STACK ACTIVITY WILL DESTROY JMP A,I STATUS OF (B) AS EXTENSION OF (A). * LDA T2CON,I PUSH DUPLICATE ENTRY ONTO STACK FOR GDF.F JSB PU1.F JSB F1T.F FREE TEMP. LDA T1CON,I SET UP DOT FUNCTION GENERATION. CLB,INB ONE OPERAND. CON01 JSB GDF.F ISSUE CONVERSION CODE. (POPS STACK) CON02 JSB GRD.F IF RESULT IS IN (A), DEF F.RES LDB T2CON SET UP STACK POINTER. JSB SRD.F DEF F.RES LDA F.RES OVERWRITE STACK FRAME WITH RESULT. STA T2CON,I JMP CON.F,I ALL DONE. SKP * SPECIAL CASES: DBI => INT, CPX => REA, ZPX => RE8. * JUST OFFSETS. * CON03 CLA,INA,RSS DBI => INT, OFFSET=1, CON04 CLA CPX/ZPX => REA/RE8, OFFSET=0. LDB T2CON,I FROM THIS ITEM. JSB LDO.F (F.RTP ALREADY SET UP) JMP CON02 AND FIX UP STACK. * * SPECIAL CASE: INT => DBI * CON06 LDB T2CON,I LOAD IT INTO (B). LDA F.ACB UNLESS... CPA K2 (B) IS THE EXTENSION OF (A) SZB AND WE ARE CONVERTING (A). RSS (NO) JMP CON6A YES. JUST SWAP. * JSB LDB.F NO. LOAD (B). JSB SRT.F AND FREE (A). DEF K0 K LDA ASRI ISSUE 'ASR 16' JSB OAI.F CON6A LDA SWPI AND 'RRR 16' = SWAP. JSB OAI.F LDA DBI SET UP REGISTER DATA. LDB T2CON DOUBLE INT, STACK ADDR. CLOI CLO DATA. CLE JSB SRD.F DEF K0 IN (A,B). CLA SET RESULT IN STACK. STA T2CON,I LDB DBI RESTORE RESULT TYPE. STB F.RTP JMP CON.F,I DONE. * * SPECIAL CASE: REA => CPX, RE8 => ZPX. * CON07 LDA T2CON,I PUSH DUPLICATE ENTRY ON STACK. JSB PU1.F JSB CDI.F FORM A ZERO. LDB F.RTP MAKE IT SINGLE OR DOUBLE. LDA REA CPB ZPX LDA RE8 JSB ESC.F JSB AI.F LDA F.A PUSH ONTO STACK. JSB PU1.F LDA .CMPX DOT FUNCTION INFO FOR 'CMPLX' LDB F.RTP CPB ZPX LDA .ZMPX OR '.ZMPX' LDB K2 TWO OPERANDS. JMP CON01 JUST USE GDF.F NORMALLY. SKP * LOGICAL OPERAND(S). * CON08 BSS 0 CON09 LDA T0CON LOGICAL & LOGICAL STILL O.K. CPA LOG 1ST=LOG ? RSS CPA LO4 OR DBL LOG ? RSS JMP CON10 NO. ERROR. * LDA F.RTP 2ND=LOG ? CPA LOG RSS CPA LO4 OR DBL LOG ? RSS JMP CON10 NO. ERROR. * LDA LOG YES. SET RESULT TYPE = SINGLE LOGICAL. STA F.RTP JMP CON.F,I DONE! * CON10 LDA K57 OTHERWISE ERROR. JSB ER.F * T0CON NOP T1CON NOP T2CON NOP SKP * CONVERSION DOT FUNCTION TABLE. * DCONT DEF * (INT => INT DELETED) * DEF CON03,I DBI => INT ABS 212+D.REG IFIX ABS 214+D.OPM .XFXS (.DINT) ABS 216+D.OPM .TFXS (.TINT) ABS 218+D.OPM .CINT ABS 308+D.OPM .ZINT * DEF CON06,I INT => DBI K0 NOP ABS 213+D.REG .FIXD ABS 215+D.OPM .XFXD ABS 217+D.OPM .TFXD ABS 219+D.OPM .CFXD ABS 309+D.OPM .ZFXD * ABS 226+D.REG FLOAT ABS 227+D.REG .FLTD NOP ABS 228+D.OPM+D.RTN SNGL ABS 229+D.OPM+D.RTN .NGL DEF CON04,I CPX => REA ABS 229+D.OPM+D.RTN .SNGL (IGNORE 2ND PART) * ABS 233+D.REG .XFTS ABS 235+D.REG .XFTD ABS 237+D.OPM+D.RTN DBLE NOP ABS 100+D.OPM .TDBL ABS 239+D.OPM .CDBL ABS 100+D.OPM .TDBL (IGNORE 2ND PART) * ABS 234+D.REG .TFTS (.ITBL) ABS 236+D.REG .TFTD ABS 238+D.OPM+D.RTN .BLE ABS 101+D.OPM .DTBL NOP ABS 240+D.OPM .CTBL DEF CON04,I ZPX => RE8 * ABS 096+D.REG .ICPX ABS 097+D.REG .CFTD DEF CON07,I REA => CPX ABS 098+D.OPM .DCPX ABS 099+D.OPM .TCPX NOP ABS 310+D.OPM .ZCPX * ABS 311+D.REG .IZPX ABS 312+D.REG .JZPX ABS 313+D.REG .FZPX ABS 314+D.OPM .DZPX DEF CON07,I RE8 => ZPX ABS 315+D.OPM .CZPX * .CMPX ABS 241+D.OPM+D.RTN CMPLX .ZMPX ABS 307+D.OPM+D.RTN .ZMPX ASRI ASR 16 SWPI SWP * EQOPC EQU K1 K7 DEC 7 K57 DEC 57 SKP * ************************ * * CONVERT TOP-OF-STACK * * ************************ * * ENTRY: (A) = RESULT TYPE. * EXIT: F.RTP=RESULT TYPE, TOS CONVERTED. SPC 1 CTS.F NOP STA F.RTP F.RTP = RESULT TYPE. LDB F.S1T (B) = STACK ADDR. JSB CON.F DO IT. JMP CTS.F,I DONE. * END ASMB,Q,C HED SUBROUTINE AND ARRAY REFERENCE CODE GENERATION. NAM SAM.F,8 92834-16003 REV.2030 800731 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY E1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.AF ADDRESS FIELD CURRENT F.A EXT F.AT ADDRESS TYPE OF CURRENT F.A EXT F.AT. FLAG FOR BUILDING DIM/BCOMI ENTRIES. EXT F.CCW FTN OPTIONS WORD. EXT F.D0 ARRAY ELEMENT SIZE. EXT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. EXT F.EM EMA FLAG BIT IN A.T. EXT F.FES TWPE FOR FIRST EXECUTABLE. EXT F.FRF FUNCTION RESULT F.A (NON-STMT FCT). EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LUB ADDR OF LOWER-UPPER BOUNDS TABLE. EXT F.NC MISC A.T. DATA (INTRINSICS FLAG) EXT F.ND NUMBER OF DIMENSIONS EXT F.PCT F.A OF TEMP FOR 'PCOUNT'. EXT F.PTY PROGRAM TYPE. EXT F.R MISC BIT IN A.T. EXT F.REL SUB. PROG. RETURN LOCATION EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.SBF 0=MAIN, ELSE SUB/FCT F.A EXT F.SFF SUBROUTINE/FUNCTION FLAG. EXT F.SRL F.A OF HIDDEN PARAM IN STMT FCT DEF. EXT F.UFM F.A OF .UFMP . * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR CONSTANT. EXT DAF.F DEFINE (F.AF). EXT DAT.F DEFINE (F.AT). EXT EDO.F ESTABLISH DATA WITH OFFSET. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT ESD.F ESTABLISH DEF SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FC.F FETCH VALUE OF CONSTANT. EXT GCD.F GET CONSTANT DIMENSION VALUE SUB. EXT OA.F OUTPUT MEM REF WITH F.A EXT OAD.F OUTPUT ABS. DATA EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODD.F OUTPUT DEF TO DOT FUNCTION. EXT ODF.F OUTPUT DOT FUNCTION EXT OLR.F OUTPUT LOAD ADDRESS EXT OMR.F OUTPUT MEMORY REF. INSTRUCTION EXT ORI.F OUTPUT ABS INSTRUCTION, S. REGISTER INSTRUCTION. EXT OZ.F OUTPUT ZREL (OP *+N) EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F WARNING PRINT SUBROUTINE. * * ENTRY POINTS IN F4.6 * EXT F.COP CURRENT OP CODE. EXT F.LA1 1ST LOOK-AHEAD WORD FIRST PASS FILE. EXT F.PTF PERMANENT TEMP FLAG. EXT F.RES RESULT F.A EXT F.RTP RESULT TYPE EXT F.S1N NEXT-TO-TOP OF STACK 1. EXT F.TPX TYPE OF EXPRESSION BEING PROCESSED. * EXT APT.F ALLOCATE 'PERMANENT' TEMP. EXT DEF.F PRODUCE A DEF TO (B). EXT ITN.F INITIALIZE TEMP NAMES. EXT RD.F PASS FILE READ FOR PASS 2. EXT TAS.F CONDITIONALLY ALLOCATE TEMP. (LOOK-AHEAD) * * ENTRY POINTS IN AOP.F (ARITH/LOG/REL OP CODE GEN.) * EXT ADD.F ADD. EXT AND.F .AND. EXT CO.F COMMUTE TOP TWO OPERANDS. EXT CON.F CONVERSION. EXT CTS.F CONVERT TOP OF STACK. EXT MPY.F MULTIPLICATION. EXT NEG.F NEGATION. EXT NOT.F .NOT. EXT .OR.F .OR. EXT XOR.F .XOR. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT F.ACB B-REGISTER STACK ADDR. * EXT ABB.F SET UP A/B BIT. EXT AOR.F ALLOCATE ONE REGISTER. EXT CBR.F CLEAR REGISTER DATA, BOTH REGISTERS. EXT CRD.F CLEAR REGISTER DATA (ONE REGISTER). EXT FT.F FIND TYPE OF (B). EXT LD.F LOAD INTO EITHER REGISTER. EXT LDA.F LOAD INTO (A). EXT LDB.F LOAD INTO (B). EXT GRD.F GET REGISTER DATA. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT MIM.F MAP ITEM MODE. EXT P1P.F POP ONE ITEM OFF STACK, PUSH RESULT. EXT PO1.F POP ONE ITEM OFF STACK. EXT PU1.F PUSH ONE ITEM ONTO STACK. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION. (LOAD TOS). EXT SMT.F STORE MAPPED DATA (FREE MAPS). EXT SRD.F STORE REGISTER DATA. EXT SRS.F STORE REGISTER DATA, SHORT FORM. EXT SRT.F STORE REGISTER INTO TEMP. EXT VS1.F VOID STACK 1. * * ENTRY POINTS IN SAM.F * ENT EA?.F SKIP IF F.A IS IN EMA. ENT FPE.F FORM PROGRAM ENTRANCE CODE. ENT GDF.F GENERATE DOT FUNCTION CALL. ENT MAP.F MAP-IN IF IN EMA. ENT SAL.F SUBROUTINE OR ARRAY, LEFT PAREN. ENT SAR.F SUBROUTINE OR ARRAY, RIGHT PAREN. * * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SKP * **********F****************** * FORM PROGRAM ENTRANCE CODE * * **************************** * FPE.F NOP JSB OLR.F PUT OUT LOAD ADDRESS JSB VS1.F VOID STACK 1. LDA F.RPL SAVE THE ADDRESS OF STA T2FPE THE FIRST PRAM (FOR .ENTR) JSB RD.F GET SUB ROUTINE F.A STA F.A AND SET IT SZA IF ENTRY FOR BLOCK DATA OR MAIN, JMP FPE13 (NO) * LDB F.SFF WHICH IS IT ? (A=0) CPB K2 JMP FPE20 BLOCK DATA. NO ENTRY POINT. * JSB OAI.F MAIN. ISSUE 'NOP' IN CASE CALLED AS SUBR. LDA T2FPE SET THE TRANSFER ADDRESS. STA F.REL LDA F.PTY SEGMENT ? CPA K5 JMP FPE20 YES. DONE. * LDB .FIOI NO. 'JSB .FIOI' JSB ODF.F LDA TWPE SET UP TWPE ENTRY FOR .UFMP JSB ESC.F JSB AI.F LDB F.A SAVE ITS F.A, STB F.UFM JSB DEF.F AND DO 'DEF .UFMP' JMP FPE20 DONE. * * PUT OUT NOP'S & .ENTR CALL; DEFINE FORMALS TOO. THE FUNCTION * ITSELF IS LEFT UNDEFINED, AND WILL BE DEFINED LATER BY SUBTRACTING * ONE (TWO IF NON-REGISTER DATA) FROM THE ADDRESS OF THE FIRST * FORMAL. THIS ALLOWS THE FORMALS TO STAY LINKED TO THE FUNCTION * (FUNCTION F.AF POINTS TO FIRST FORMAL, FORMALS POINT USING LINK * WORDS) SO THAT TYPE CHECKING MAY BE DONE ON STMT FCT ARGUMENTS. * FPE13 STA T0FPE T0FPE = F.A OF SUBR/FCT. JSB FA.F COMPUTE F.D0 = # WDS IN RESULT. LDA F.A IF F.A=F.SBF (PROCESSING PGM ENTRY) LDB F.SFF AND F.SFF=0 (SUBROUTINE) CPA F.SBF WELL ? SZB RSS (NO, FUNCTION) JMP FPE00 YES. SUBROUTINE, NO HIDDEN PARAM. * CLA FUNCTION. (A=0) STA F.SRL SET F.SRL=0 IN CASE RESULT IN REG. LDB F.D0+1 GET SIZE OF RESULT. ADB KM3 IS IT < 3 ? SSB WELL ? JMP FPE00 ]YES. RESULT IN REGISTER(S). * JSB OAI.F NO. USE EXTRA DUMMY. (A=0) CCAI CCA SET (A)=F.RPL OF THE EXTRA DUMMY. ADA F.RPL LDA F.IM ALLOCATE TEMP AS RESULT. JSB APT.F LDA DUM SET F.AT=DUM JSB DAT.F LDA T2FPE SET F.AF=ADDR JSB DAF.F LDA F.A F.SRL=F.A OF TEMP. STA F.SRL LDB T0FPE RESTORE ASSIGNS OF FUNCTION. STB F.A CPB F.SBF IS THIS THE MAIN ENTRY ? STA F.FRF YES. SET RESULT F.A (DEFAULT=0). JSB FA.F SKP * OUTPUT NOP'S, DEFINE FORMALS, AND STACK * THEM UP FOR NEXT LOOP, SINCE LINKS GONE. * FPE00 LDA F.AF SET UP TO SCAN FORMALS. LDB T0FPE STATEMENT FUNCTION ? CPB F.SBF JMP FPE01 NO. F.AF HAS FORMALS LIST ADDR. * .DLD DLD T0FPE,I YES. FORMALS LIST IS IN 2-WORD EXTENSION, INB GET LINK, 2ND WORD. LDA B,I FPE01 SZA,RSS DONE ? JMP FPE02 YES. * STA F.A NO. SET AS CURRENT FORMAL. JSB PU1.F AND STACK IT. JSB FA.F AND GET ITS F.AF STA T1FPE TO SET AS THE NEXT ONE. LDA F.RPL DEFINE ADDR CURRENT FORMAL. USE DAF.F JSB DAF.F TO PUT ARRAY ADDRESSES IN 'DIM' ENTRY. CLA OUTPUT 'NOP' JSB OAI.F LDA T1FPE (A)=ADDR NEXT FORMAL; JMP FPE01 GO ON. * * 'NOP' / 'JSB .ENTR' / 'DEF PARAMS' * FPE02 LDA F.RPL SAVE LOCATION OF ENTRY STA T1FPE FIRST, FOR ENTRY CODE. LDB T0FPE STATEMENT FUNCTION ? CPB F.SBF JMP FPE03 NO. ENTRY FOR PROGRAM UNIT. * INB YES. GET THE EXTENSION ADDR, LDB B,I STA B,I AND PUT ENTRY PT IN 1ST WORD. JMP FPE14 * FPE03 STA F.REL PROG UNIT ENTRY. REMEMBER. FPE14 CLA OUTPUT 'NOP' FOR ENTRY. JSB OAI.F LDB F.PCT WAS 'PCOUNT' USED, LDA T0FPE ANLD THIS IS MAIN ENTRY (NOT STMT FCT) ? CPA F.SBF IF PROG ENTRY, SZB,RSS AND PCOUNT, JMP FPE16 (NO) * LDA LDAI THEN 'LDA ENTRY' LDB T1FPE JSB OMR.F LDA STAI 'STA ' LDB F.PCT JSB SOA.F FPE16 LDA F.S1T WAS PARAM LIST EMPTY ? CPA F.S1B RSS JMP FPE07 NO. * LDA LDAII YES. JUST DO: LDB T1FPE 'LDA ENTRY,I' JSB OMR.F LDA STAI 'STA ENTRY' LDB T1FPE JSB OMR.F JMP FPE20 NO LIST TO PROCESS. * FPE07 LDB .ENTP IF 'PCOUNT' CODE, MUST ALLOW FOR TWO LDA T1FPE WORDS BETWEEN ENTRY & .ENTP, ELSE INA USE .ENTR . CPA F.RPL LDB .ENTR JSB ODF.F 'JSB .ENTR/.ENTP' LDB T2FPE OUTPUT 'DEF PARAMS' JSB OMR.F SKP * LOOP THRU DUMMIES: * 1) IF EMA, COPY ITS ADDR. * 2) IF VARIABLE DIMENSIONS, COPY LOWER BOUND AND * COMPUTE & SAVE DIMENSION SIZE. * 3) IF NON-EMA VAR DIM, OR EMA AND DOUBLE INTEGER * SUBSCRIPTS USED, COMPUTE & SAVE ADDRESS OF * ELEMENT (0,...,0). * LDA F.S1B START OF LOOP. STA T1FPE T1FPE = PTR INTO STACK 1. LDA F.S1T SAVE F.S1T FOR CUTTING STACK. STA T6FPE FPE04 LDA T6FPE CUT STACK BACK DOWN. STA F.S1T JSB CBR.F DISCARD REGISTER INFO. LDA T1FPE DONE ? CPA F.S1T JMP FPE20 YES. * ADA KM1 NO. ADVANCE TO NEXT. STA T1FPE LDA A,I SET UP F.A STA F.A JSB FA.F FETCH ASSIGNS. LDA F.EM IN EMA ? STA T5FPE (SET TENTATIVE .EMAP FLAG) STA T7FPE (SET EMA FLAG) SZA,RSS JMP FPE05 NO. * * IN EMA. BUILD & LINK IN A FAKE BCOMI ENTRY. * LDA F.AF SAVE REL ADDR OFk PARAM. STA T2FPE LDA BCOMI SET F.AT. = BCOMI FOR AI.F STA F.AT. JSB AI.F CREATE THE BCOMI ENTRY. (F.EM SET) LDA F.A SAVE F.A OF BCOMI ENTRY. STA T4FPE LDB T1FPE,I LINK INTO THE PARAM. STB F.A JSB DAF.F LDA .DLD DO 'DLD PARAM,I' JSB OAI.F (A=0,E=1) LDB T2FPE (ADDR PARAM) LDA T4FPE SAVE IT IN WORD 2 OF BCOMI. ADA K2 STB A,I LDA KK01 DO THE DEF. JSB OMR.F LDA .DST START THE DST JSB OAI.F LDA DBI CREATE TEMP FOR REVERSED ADDR. JSB APT.F LDA T4FPE PUT ITS F.A IN BCOMI WORD 1. INA STB A,I JSB DEF.F FINISH: 'DST TEMP' LDA T1FPE,I RESTORE ITEM ASSIGNS. STA F.A JSB FA.F LDA F.IU ARRAY ? CPA ARR CLB,RSS (B=0) JMP FPE04 NO. ALL DONE. * LDA F.CCW YES. 'S' OPTION SET, OR AND B40K IOR F.DIS DOUBLE INTEGER SUBSCRIPTS ? SZA STB T5FPE YES. CLEAR .EMAP FLAG. LDA .DST DO FIRST PART OF DST. JSB OAI.F LDA DBI GET THE TEMP FOR IT. JSB APT.F LDA T4FPE PUT ITS F.A IN WORD 3 OF BCOMI. ADA K3 STB A,I JSB DEF.F AND FINISH 'DST TEMP' LDA T1FPE,I RESTORE ASSIGNS. STA F.A JSB FA.F JMP FPE06 GO DO MORE ARRAY PROCESSING. * FPE05 LDA F.IU NON-EMA. ARRAY ? CPA ARR RSS YES. KEEP GOING. JMP FPE04 NO. ALL DONE WITH THIS ONE. SKP * ARRAY: * FIGURE OUT DIMENSION TYPE, INT/DBI. * FPE06 JSB CBR.F FIRST, ZAP REGISTER DATA. JSB ITN.F AND INITIALIZE TEMP NAMES. LDA INT ASSUME SINGLE INTEGER FOR SUBS. LDB F.DIS IS THAT IT ? SZB LDA DBI NO. DOUBLE INT SUBS. STA T4FPE REMEMBER THAT. * * B NEGATE, SAVE LOWER BOUND. * COMPUTE (UPPER)-(LOWER)+1 * LDA F.A VAR DIM. PUSH THE ARRAY NAME ONTO STACK. IOR KK01 WITH SIGN. JSB PU1.F LDA F.ND SET UP LOOP THRU DIMS. CMA,INA STA T2FPE T2FPE = COUNTER. LDA F.LUB STA T3FPE T3FPE = BOUNDS TABLE POINTER. FPE08 LDA T3FPE,I LOWER BOUND. STA F.A FETCH ITS ASSIGNS. JSB FA.F LDB F.EM IN EMA ? LDA K48 SZB JSB ER.F YES. ERROR. * LDA T3FPE,I PUT LOWER BOUND ON STACK. JSB PU1.F LDA T4FPE CONVERT IF NECESSARY, JSB CTS.F JSB NEG.F AND NEGATE. LDB F.S1T,I CONSTANT ? JSB CFC.F RSS (NO, REGISTER SINCE WE NEGATED IT) JMP FPE09 YES. * LDA T5FPE (IF USING .EMAP, MAKE THE TEMP SZA PERMANENT 'CAUSE IT'S IN THE ISZ F.PTF .EMAP TABLE) JSB SRT.F NO, REG. SAVE NEGATED LOWER BOUND. DEF F.S1T,I DLD T3FPE,I NOW WANT TO SEE IF SHOULD REMEMBER JSB FT.F THAT IS IN REG TOO. WHAT TYPE IS UPPER ? CPA T4FPE IF CORRECT ONE, JMP FPE10 THEN CAN REMEMBER. * DLD T3FPE,I BUT ALSO, JSB CFC.F IF UPPER IS CONSTANT, CONV DOESN'T NEED REG. JMP FPE09 (NO. WILL USE TEMP INSTEAD) * FPE10 LDA T4FPE NOW RESTORE REGISTER STATUS. JSB SRS.F DEF K0 MUST HAVE BEEN (A). * CLA,RSS STACK: TEMP / REGISTER. FPE09 LDA F.S1T,I ELSE: CONSTANT/CONSTANT. JSB PU1.F (ONE FOR LATER, ONE FOR NOW) LDA F.S1N,I COPY THE TEMP OR CONSTANT F.A STA T3FPE,I INTO LOWER BOUND SLOT. ISZ T3FPE & ADVANCE TO UPPER BOUND. SKP * UPPER BOUND PART. * LDA T3FPE,I CHECK UPPER BOUND FOR EMA. STA F.A JSB FA.F LDB F.EM LDA K48 SZB WELL ? JSB ER.F YES. ERROR 48. * LDA T3FPE,I PUT UPPER BOUND ON STACK. JSB PU1.F LDA T4FPE CONVERT IF REQ'D. JSB CTS.F LDB F.S1T,I IS UPPER CONSTANT ? JSB CFC.F RSS JMP FPE12 YES. WILL INCREMENT UPPER. * LDB F.S1N,I NO. IS LOWER IN REG ? SZB,RSS JMP FPE11 YES. INCREMENT THAT. * JSB CFC.F NO. IS LOWER CONSTANT ? JMP FPE12 NO, LOWER IN MEM. INCR UPPER. * FPE11 JSB CO.F COMMUTE IF ADVANTAGEOUS. FPE12 CLA,INA ADD ONE TO WHATEVER IS ON TOP. JSB EIC.F JSB PU1.F JSB ADD.F JSB ADD.F ADD THE OTHER. LDB F.S1T,I IF RESULT IS NOT CONSTANT, JSB CFC.F JSB SCG.F LOAD IT. MUST MAKE LOCAL COPY. ISZ F.PTF (ALLOCATE PERMANENT TEMP) JSB SRT.F NOW PUT IN TEMP. DEF F.S1T,I JSB PO1.F POP THE RESULT, AND STA T3FPE,I REMEMBER IT INSTEAD OF UPPER BOUND. ISZ T3FPE ISZ T2FPE DONE WITH ALL DIMENSIONS, THIS FORMAL ? JMP FPE08 NO. JUST KEEP TRUCKIN' SKP * DONE WITH ALL DIMENSIONS OF THIS FORMAL. * COMPUTE THE ADDRESS OF ELEMENT (0,...,0). * LDA T5FPE UNLESS USING .EMAP, SZA JMP FPE04 INWHICHCASE THAT'S ALL WE DO. * JSB SAR.F YES. COMPUTE ADDR OF (0,...,0) LDA T7FPE DOING .SRES OR .DRES STUFF ? SZA JMP FPE15 YES. GO PUT IN TABLE. * JSB SCG.F LOAD CORRECTION. JSB ABB.F FORM A/B BIT. ADA ADAII ISSUE 'ADA PARAM' WITHOUT THE LDB T1FPE,I INDIRECT BIT. JSB SOA.F ISZ F.PTF (USE 'PERMANENT' TEMP) JSB SRT.F STORE THAT. (IT'S AN INTEGER) DEF F.S1T,I JSB PO1.F POP THE TEMP OFF, LDB T1FPE,I AND INSERT IN THE 'DIM' ENTRY. INB LDB B,I ADB K2 STA B,I JMP FPE04 ON TO THE NEXT FORMAL... * FPE15 LDA .DST PU?T THE RESOLVED .DMAP ADDRESS JSB OAI.F IN THE .DMAP TABLE. LDA T1FPE,I STA F.A GET THE BCOMI ADDR. JSB FA.F LDA F.AF HERE IT IS. ADA K3 NEED WORD 3. LDB A,I (B) = F.A OF TEMP. JSB DEF.F FINISH DST WITH DEF TO TEMP. JMP FPE04 ALL DONE! SKP * IF STATEMENT FUNCTION(S), JUMP AROUND. * FPE20 LDA T0FPE DOING ENTRY FOR PROGRAM UNIT ? LDB F.FES AND THERE WERE STATEMENT FUNCTIONS ? CPA F.SBF SSB PROGRAM. STMT FCT ? JMP FPE22 NOT PROG OR NO STMT FCT. * LDA JMPI ISSUE JUMP AROUND. JSB SOA.F * FPE22 LDB T0FPE IF PROGRAM NAME, STB F.A SZB JSB FA.F THEN RESTORE ASSIGNS. JSB VS1.F VOID STACK 1. JMP FPE.F,I EXIT. * .ENTR ABS 73 .TBL OFFSET OF .ENTR .ENTP ABS 86 .ENTP JSBI OCT 16000 ADAII OCT 142000 LDAII OCT 162000 LDAI OCT 062000 STAI OCT 072000 B40K OCT 040000 TWPE EQU B40K F.IM = TWPE. BCOMI OCT 7000 F.AT = BCOMI T0FPE NOP F.A OF SUB/FCT. T1FPE NOP STACK PTR FOR SCANNING LIST. T2FPE NOP COUNTER OF # DIMENSIONS. T3FPE NOP BOUNDS TABLE POINTER. T4FPE NOP INT DBI AS REQUIRED DIMENSION TYPE. T5FPE NOP .EMAP USAGE FLAG. T6FPE NOP SAVED VALUE OF F.S1T T7FPE NOP EMA FLAG. KK01 OCT 100000 DBI EQU KK01 KM3 DEC -3 K3 DEC 3 K5 DEC 5 K31 DEC 31 OPCODE FOR PROGRAM ENTRY. K48 DEC 48 .FIOI ABS 262 SKP * ******************************************** * * SUBROUTINE OR ARRAY CALL GENERATION CODE * * ******************************************** SPC 1 * FIRST, FLAG THE NAME SO WE CAN COUNT PARAMS. * SAL.F NOP LDA F.S1T,I JUST SET SIGN. IOR KK01 STA F.S1T,I JMP SAL.F,I DONE ! * * AT END, PROCESS PARAMS & GEN~ERATE CODE. * SAR.F NOP CLB,INB STB PNUM AT LEAST THE SUBPROG NAME ON STACK CLB NO ALTERNATE RETURNS YET. STB ANAR LDB F.S1T SUAR0 LDA B,I (A) = STACK CONTENTS SSA IF (A) <0, JMP SUAR1 NAME OF SUBPROG ON STACK FOUND. * SZA IF REGISTER, CPA K1 JMP SUAR5 THEN NOT STMT #. * LDA A,I ELSE CHECK IT: FIRST WORD A.T. ENTRY. AND KK04 F.IM & F.IU & F.NT SZA,RSS STMT # ? (F.IM=0, F.IU=0, F.NT=0) JMP SUAR6 YES. * LDA B,I NO. GET F.IM & F.AT . LDA A,I AND B177K CPA TWSTR IF F.IM=TWPE & F.AT=STR-ABS, JMP SUAR6 THEN MUST BE DO STATEMENT LABEL. * SUAR5 ISZ PNUM NOT STMT #. COUNT THE NORMAL PARAMETER. JMP SUAR7 * SUAR6 ISZ ANAR STMT #. COUNT THE ALTERNATE RETURN. SUAR7 INB ADVANCE IN STACK. JMP SUAR0 CONTINUE SCANNING PARAMS. * SUAR1 STB S1LOC REMEMBER STACK POS OF SUB/ARR NAME. STB S2LOC REMEMBER HOW MUCH TO POP LATER. ELA,CLE,ERA WIPE OFF SIGN BIT. STA B,I REPLACE ON STACK. STA F.A SET F.A TO POINT TO NAME JSB FA.F FETCH ASSIGNS FOR SUB OR ARR. LDA F.IU CPA ARR NAME IS ARRAY? JMP SUAR2 YES. * JSB JTS.F NO, GEN. CALL TO SUBPROG. RSS SUAR2 JSB AEA.F GEN. ARRAY ELEMENT ADDR CALC. * SUAR3 LDA F.S1T POP OPERANDS. THERE YET ? CPA S2LOC JMP SUAR4 YES. JSB PO1.F NO. KEEP GOING. JMP SUAR3 SUAR4 JSB P1P.F POP SUB NAME, PUSH RESULT. JMP SAR.F,I RETURN SPC 1 S2LOC NOP ADDR SUBR NAME ON STACK. PNUM NOP NUMBER OF PARAMETER TO SUB OR ARRAY. ANAR NOP ACTUAL NUMBER OF ALTERNATE RETURNS. B177K OCT 177000 MASK FOR F.IM & F.AT TWSTR OCT 042000 F.IM=TWPE & F.AT=STR-ABS. SPC 2 * ********************** *  * JUMP TO SUBPROGRAM * * ********************** SPC 1 JTS.F NOP LDA F.NC INTRINSIC ? CPA B40 RSS (YES) JMP JTS05 NO. * LDB S1LOC,I (A)=F.A OF SUB. GET DOT ORDINAL. INB LDB B,I ADDR OF INTRINSICS TABLE. LDA B,I FIRST WORD OF IT. SSA,RSS IS IT A SPECIAL ? JMP JTS20 NO. GO DO NORMAL INTRINSIC. * AND B777 YES. GET DOT ORDINAL, STA T1JTS AND SAVE. JSB SBR.F SAVE REGISTERS BUT NOT MAPS. LDB T1JTS (B) = DOT FUNCTION ORDINAL, JSB ODF.F ISSUE IT. JMP JTS09 * JTS05 JSB SMT.F SAVE MAPPED DATA FIRST, JSB SBR.F THEN OTHER REGISTERS. LDA JSBI LDB S1LOC,I JSB SOA.F OUTPUT JSB TO SUBPROG NAME * * DECIDE WHETHER SUBROUTINE OR FUNCTION REF. * JTS09 LDA S1LOC,I FIRST, RESTORE ASSIGNS. STA F.A JSB FA.F LDA F.IM AND SAVE F.IM OF SUBPROG NAME STA T0JTS LDB F.TPX (B) = TYPE OF INPUT EXPRESSION. LDA S1LOC (A) = NAME ADDR ON STACK 1. INA IF NOTHING STACKED BELOW IT, CPA F.S1B INB,SZB AND WER'E PROCESSING SUBROUTINE CALL, CCB NO. (B)=-1 AS FUNCTION FLAG. * * CHECK FOR STATEMENT FCT. IF SO, CAN'T BE SUBR. * LDA F.AT CPA REL WELL ? JMP JTS04 YES. GO CHECK. * SZB NO. FUNCTION OR SUBROUTINE ? JMP JTS03 FUNCTION. JMP JTS01 SUBROUTINE. * JTS04 SZB,RSS STMT FCT. CALLED AS SUBROUTINE ? JMP JTS58 YES. ERROR. SKP * CHECK TYPE & NUMBER OF STMT FCT ARGS. * LDA S1LOC,I (A) = F.A OF STMT FCT. DLD A,I (B) = ADDR OF STMT FCT A.T. EXTENSION. DLD B,I (B) = F.A OF FIRST FORMAL. LDA S1LOC (A) = INITIAL STACK POINTER. JMP JTS10 START IN MIDDLE. * JTS08 LDA T1JTS,I GET F.IU OF ACTUAL. LDA A,I AND B600 CPA SUB JUST CAN'T BE SUBROUTINE. JMP JTS60 THAT'S TOO BAD... * LDB T1JTS,I GET F.IM OF ACTUAL. JSB FT.F (IN CASE ADDR TEMP) STA T3JTS SAVE THAT, LDA T2JTS,I AND GET F.IM OF FORMAL. AND B170K CPA T3JTS SAME ? RSS YES. JMP JTS13 NO. ERROR. * CCB MOVE ON. GET LINK TO NEXT FORMAL. ADB T2JTS LDB B,I (B) = F.A NEXT FORMAL. LDA T1JTS JTS10 CPA F.S1T OUT OF ACTUALS ? JMP JTS11 YES. * ADA KM1 NO. MOVE ON TO NEXT. STA T1JTS SZB,RSS OUT OF FORMALS ? JMP JTS59 YES. TOO MANY ACTUALS. * STB T2JTS NO. SET UP F.A OF THIS ONE. JMP JTS08 GO COMPARE THEM. * JTS11 SZB,RSS OUT OF ACTUALS. HOW 'BOUT FORMALS ? JMP JTS03 YUP. MATCHES. * JTS13 LDA K60 WARNING 60: ARGUMENT MODE ERROR. JSB WAR.F ISSUE THE WARNING. SKP * FUNCTION. SEE IF RESULT IN MEM. * JTS03 LDA ANAR BUT FIRST, MAKE SURE LDB F.NC THAT THERE ARE NOT ALTERNATE CPB B40 RETURN, EXCEPT FOR INTRINSICS. JMP JTS31 NAMELY EXEC, REIO & XLUEX. * SZA NOT ONE OF THEM. MUST NOT HAVE JMP JTS58 ALTERNATE RETURNS. * JTS31 LDA T0JTS ANALYZE RESULT TYPE. STA F.RTP (FOR TAS.F) JSB MIM.F SSB,RSS REGISTER DATA ? JMP JTS02 YES. NO HIDDEN PARAMETER. * CLA CALLS TO DBL OR CPX FUNCTIONS LDB PNUM INB JSB OZ.F OUTPUT DEF *+N+2 LDB S1LOC GET LOCATION OF NEXT OPERAND INB JSB TAS.F ALLOCATE DBL OR CPX RESULT TEMP IF NEEDED LDB F.RES OUTPUT DEF TO RESULT. JSB DEF.F JMP JTS07 DO DO THE DEF'S. * JTS01 LDA F.NC SUBROUTINE. IF SPECIAL INTRINSIC, CPA B40 THEN CAN BE FUNCTION TOO. JMP JTS02 * LDB F.R ELSE MUST BE STRICTLY USED AS SUB. LDA K58 SZB JSB WAR.F THEN WARNING FOR USING AS SUBROUTINE. * JTS02 CLA REGISTER DATA OR SUBROUTINE. STA F.RES SET RESULT = (A) / (A,B) LDB PNUM JSB OZ.F OUTPUT DEF *+N+1 * * PRODUCE THE DEFS TO THE ACTUAL PARAMETERS. * JTS07 LDB S1LOC OUTPUT ARGUMENT DEFS CPB F.S1T ALREADY DONE LAST ONE ? JMP JTS18 YES. DONE. * ADB KM1 STB S1LOC POINTS TO NEXT ARG IN STACK LDB B,I SEE IF STATEMENT #. LDA B,I AND KK04 F.IM & F.IU & F.NT SZA,RSS IF ALL ZERO, JMP JTS07 THEN STATEMENT #: SKIP. * LDA B,I DITTO FOR END-OF-LOOP TWPE ENTRIES. AND B177K CPA TWSTR JMP JTS07 * LDA B,I SEE IF IT'S AN INTRINSIC. AND B7740 F.AT, F.IU, F.NC CPA B2240 F.AT=STRAB, F.IU=SUB, F.NC=1. JMP JTS16 YES. SPECIAL. * JSB DEF.F NO. ORDINARY DEF. JMP JTS07 * JTS16 INB INTRINSIC. GET TABLE ADDR. LDB B,I (B)=FWA INTRINSIC TABLE. LDA B,I A<8:0> = DOT FUNCTION ORDINAL. AND B777 ISOLATE IT, SWP PUT IN (B) FOR ODD.F, JSB ODD.F AND OUTPUT DEF TO DOT FUNCTION. JMP JTS07 * JTS18 LDA T0JTS STA F.RTP F.RTP = TYPE OF FUNTION RESULT JSB SRS.F SET UP REGISTER RESULT, IF ANY. DEF F.RES LDA ANAR ANY ALTERNATE RETURNS ? SZA,RSS JMP JTS.F,I NO. DONE. SKP * HANDLE SUBROUTINE ALTERNATE RETURNS. * LDA S2LOC,I SEE IF SPECIAL INTRINSIC. LDA A,I AND B140 STA T3JTS T3JTS=0 IF NOT SPECIAL. LDB ANAR (B=# ALT RTNS) CPA B40 RSS (YES) JMP JTS44 NO. GO SEE IF LONG OR SHORT FORM. * LDA K12 8(ERROR NUMBER) CPB K1 SPECIAL. EXACTLY ONE ALTERNATE RTN ? RSS (YES) JSB WAR.F NO. ERROR. * LDA JMPI SET UP T3JTS TO USE 'JMP'S. JMP JTS45 * JTS44 ADB KM3 NOT SPECIAL. MORE THAN TWO ALT RTNS ? SSB JMP JTS41 NO. SKIP HEADER CODE. * LDB .ARTN YES. ISSUE: JSB ODF.F 'JSB .ARTN' LDB ANAR INB & 'DEF *+N+1' CLA JSB OZ.F JTS45 STA T3JTS SET UP T3JTS TO DO 'DEF'S. * JTS41 LDA S2LOC SET UP LOOP THRU PARAMS. STA S1LOC CLA INITIALIZE RETURN NUMBER. STA T2JTS JTS42 LDB S1LOC DONE LAST ONE ? CPB F.S1T JMP JTS.F,I YES. DONE. * ADB KM1 NO. ADVANCE TO NEXT. STB S1LOC LDB B,I SEE IF STMT #. LDA B,I AND KK04 F.IM & F.IU & F.NT SZA,RSS IF ALL ZERO, STMT #. JMP JTS46 YES. DO IT. * LDA B,I NO. IF F.IM=TWPE & F.AT=STR-ABS, AND B177K CPA TWSTR RSS THEN DO STMT LABEL, STILL STMT #. JMP JTS42 ELSE NOT STMT #. * JTS46 LDB ANAR WHICH TYPE ARE WE DOING ? ADB KM3 LDA T3JTS SSB IF LONG FORM: MANY RETURN, SZA OR SPECIAL INTRINSIC, JMP JTS43 THEN DO 'DEF' OR 'JMP'. * ISZ T2JTS SHORT FORM. BUMP COUNTER. LDA T2JTS AND FORM CONSTANT FROM IT. JSB EIC.F LDA CPAI DO 'CPA COUNTER' JSB OA.F TO SEE IF IT'S THE RIGHT VALUE. LDA JMPI NOW DO 'JMP STMT#' JTS43 LDB S1LOC,I JSB SOA.F DEF OR JMP. JMP JTS42 GO FOR MORE. * K12 DEC 12 KK04 OCT 170601 MASK FOR F.IM & F.IU & F.NT .ARTN ABS 87 CPAI OCT 52000 JMPI OCT 26000 SKP * INTRINSIC FUNCTION. VERIFY FCT CALL, ARG COUNT. * JTS20 STB T0JTS SAVE ADDR OF INTRINSIC TABLE. LDA F.TPX IN SUBR CALL IF F.TPX=-1. LDB S1LOC AND NOTHING ELSE STACKED UP. INB CPB F.S1B INA,SZA WELL ? JMP JTS22 NO, FUNCTION REF, O.K. * JTS58 LDA K58 INTRINCIC USED AS SUBROUTINE. JSB ER.F JTS59 LDA K59 INCORRECT # OF ARGS. JSB ER.F JTS60 LDA K60 INCORRECT TYPE. JSB ER.F * JTS22 LDA T0JTS,I GET EXPECTED PARAM COUNT. ALF,RAR AND K7 (A)=EXPECTED COUNT. INA COMPARE TO PNUM, WHICH IS COUNT+1. CPA PNUM WELL ? JMP JTS23 MATCHES. * CCB NO. BUT IF PNUM > 1, ADB PNUM (SO COUNT > 0), CPA K4 AND VARIABLE NUMBER ALLOWED, SZB,RSS THEN ALLOW IT ANYWAY. JMP JTS59 ELSE ERROR. * * SCAN LIST TO SEE DETERMINE TYPE. ALLOW * MIXED INTEGER*2 AND INTEGER*4. * JTS23 CPA K1 ZERO-ARGUMENT INTRINSIC ? JMP JTS25 YES. * LDB F.S1T,I NO. GET F.IM OF LAST PARAM. JSB FT.F STA T1JTS SAVE THAT. CLA T2JTS = MIXED MODE FLAG. STA T2JTS LDB F.S1T T3JTS = STACK ADDR. STB T3JTS JTS24 LDA T3JTS,I F.A OF CURRENT ITEM. SZA REGISTER ? CPA K1 JMP JTS32 YES. DATA. * LDA A,I NO. CHECK OUT THE USAGE. AND B600 (A)=F.IU CPA SUB IS IT A SUBROUTINE ? JMP JTS60 YES. CAN'T DO THAT. * JTS32 ISZ T3JTS ON TO THE NEXT ITEM. LDB T3JTS CPB S1LOC IS THAT ALL ? JMP JTS25 (YES.) * LDB B,I (B)=F.A OF NEW ITEM, JSB FT.F GET ITS TYPE. CPA T1JTS SAME ? JMP JTS24 YES. GO ON. * ALF NO. MAYBE STILL O.K.; COMBINE IOR T1JTS WITH TYPE SO FAR, AND CPA KK02 SEE IF: INT/DBI ? RSS YES. CPA KK03 OR: DBI/INT ? RSS YES. JMP JTS60 NO. MIXED TYPES. ERROR. * ISZ T2JTS B MIXED INT/DBI, SET THE FLAG. JMP JTS24 AND GO ON. * * IF MIXED INT/DBI, CONVERT ALL TO DBI. * JTS25 LDA T2JTS WELL ? SZA,RSS JMP JTS27 ALL SAME. * LDA T0JTS,I MIXED. CHECK FOR EXCEPTION: AND B777 (A)=FORMAL PARAM VERSION. CPA %ISH ISHFT (INT*2) RSS CPA %JSH ISHFT (INT*4) JMP JTS27 IF EITHER, LEAVE IT MIXED. * LDA DBI NEITHER. ELSE SET RESULT TO DOUBLE INTEGER. STA F.RTP ALSO FOR CON.F STA T1JTS LDB F.S1T ENTER WITH (B)=STACK ADDR. JTS26 STB T2JTS CONVERT ONE TO DBI IF NOT ALREADY. JSB CON.F LDB T2JTS BUMP TO NEXT ONE. INB CPB S1LOC AT FCT NAME ? RSS YES, DONE. JMP JTS26 NO. GO ON. * * SEARCH INTRINSICS TABLE FOR FUNCTION * WITH MATCHING ARGUMENT TYPE. * JTS27 LDA T0JTS,I GET NUMBER OF ENTRIES. LSR 9 AND B17 CMA,INA SET UP COUNT. STA T2JTS JTS28 ISZ T0JTS ON TO NEXT ENTRY. LDA T0JTS,I TYPE WORD. ALF,ALF ALIGN, AND B170K AND EXTRACT ARG TYPE. CPA T1JTS RIGHT ONE ? JMP JTS29 YES. * ISZ T0JTS NO. SKIP IT, ISZ T2JTS AND BUMP COUNT. JMP JTS28 MORE TO CHECK. JMP JTS60 DIDN'T FIND IT, ERROR. * * GOT IT. CALL THE FUNCTION. * JTS29 LDB T0JTS,I FIRST, EXTRACT RESULT TYPE. RRR 4 AND B170K STA F.RTP JSB MIM.F REGISTER OR MEMORY RESULT ? SSB,RSS JMP JTS30 REGISTER. * LDB S1LOC MEMORY. TRY TO SHORT-CIRCUIT INB A DFER OR CFER. B=STK ADDR NXT OPND, JSB TAS.F USE TAS.F TO LOOK AHEAD, SET F.RES . JTS30 ISZ T0JTS GET THE DOT FUNCTION WORD. LDA T0JTS,I CCB SET (B) TO NUMBER OF PARAMS. ADB PNUM JSB GDF.F GENERATE THE CALL. JMP JTS.F,I CALLER MUST CLEAN UP STACK. SPC 2 T0JTS NOP T1JTS NOP T2JTS NOP T3JTS NOP B7000 OCT 7000 F.AT MASK. REL OCT 1000 F.AT=REL. B7740 OCT 7740 F.AT, F.IU, F.NC MASK. B2240 OCT 2240 F.AT=STRAB, F.IU=SUB, F.NC=1. B170K OCT 170000 F.IM MASK. B40 OCT 40 F.NC=1, INTRINSIC. KK02 OCT 010010 INT & DBI. KK03 OCT 100001 DBI & INT. B17 OCT 17 KM2 DEC -2 KM1 DEC -1 K1 DEC 1 K2 DEC 2 K7 DEC 7 K58 DEC 58 K59 DEC 59 K60 DEC 60 %ISH DEC 256 %JSH DEC 257 SKP * ************************************************ * * ROUTINE TO GEN .EMAP CALL FOR SIMPLE VARABLE * * ************************************************ * * ENTRY: F.A = A.T. PTR IN QUESTION. * EXIT: (A)=(B)=F.A=F.RES = (MAPPED) A.T. PTR * MAP.F NOP LDA F.A SET DEFAULT STA F.RES RESULT I.E. IT IS NOT IN EMA STA T1MAP ALSO SAVE IN CASE MAPPING. JSB EA?.F IS IT IN EA?.F JMP MAP00 NO EXIT * JSB SMT.F YES. SAVE ANYTHING CURRENTLY MAPPED. LDA T1MAP RESTORE F.A STA F.A JSB FA.F & ASSIGNS. CLB,INB STB PNUM SET NUMBER OF VARIABLES FOR AEA.F CLB SET NO. OF DIMS. STB F.ND SET NUMBER OF DIMENSIONS JSB AEA.F AEA DOES THE REST MAP00 LDA F.RES LOAD RESULT TO (A) LDB A AND (B), STA F.A AND SET F.A JMP MAP.F,I RETURN (RESULT IS IN REG) AND PTR. IN A * T1MAP NOP TO SAVE F.A OVER SMT.F CALL. SPC 2 * ***************************************************** * * ROUTINE TO TEST IF F.A POINTS AT AND EMA VARIABLE * * ***************************************************** * * SKIPS IF (F.A) IN EMA. (A) PRESERVED. (B) SET TO F.A * EA?.F NOP LDB F.A IF IN REGISTER, SZB CPB K1 JMP EA?.F,I THEN NOT IN EMA. * STA T1EA? JSB FA.F FETCH ASSIGNS LDA F.EM I.E., IS F.EM SET ? SZA ISZ EA?.F YES STEP THE RETURN TO INDICAT EMA LDA T1EA? (A) = ORIGINAL VALUE. LDB F.A (B) = F.A JMP EA?.F,I RETURN P+1 NOT EMA, P+2 EMA * T1EA? NOP SKP * ************************* * * ARRAY ELEMENT ADDRESS * * ************************* SPC 1 K25 DEC 25 K38 DEC 38 SUB OCT 200 F.IU=1 (SUBROUTINE) SPC 1 * INITIALIZE: T1AEA = F.A OF ARRAY. * T3AEA = ADDR F.A OF LAST U.B. + 1 * T6AEA = F.IM OF ARRAY. * T7AEA = # WDS PER ELEMENT. * TBAEA = DBL INT SUBSCR FLAG. * VERIFY # SUBS. * AEA.F NOP LDA F.IM T6AEA = ARRAY F.IM STA T6AEA LDA F.A T1AEA = ARRAY F.A STA T1AEA LDA F.DIS TBAEA = ARRAY F.DIS STA TBAEA LDA F.LUB ADDR OF BOUNDS TABLE. ADA F.ND + # SUBS, TWICE. ADA F.ND STA T2AEA T2AEA=T3AEA = LWA+1 BOUNDS TABLE. STA T3AEA LDB F.D0+1 WDS / ELEMENT. LDA F.ND ZERO-DIM ? SZA,RSS CCB YES, SET TO -1 STB T7AEA T7AEA = # WDS / ELEMENT. LDB F.ND # DIMENSIONS. CMB -(#DIM)-1 ADB PNUM +(#SUBS)+1 LDA K38 SZB #SUBS = #DIM ? JSB ER.F ERR: # SUBS .NE. # DIMENSIONS * * IF ZERO DIM, MUST BE EMA. * CPB F.ND F.ND=0 ? (B=0) JMP AEA20 YES. * * SET UP BACKWARD LOOP THRU SUBSCRIPTS TO: * 1) CONVERT SUBSCRIPTS TO INTEGER/DBL INT. * 2) CHECK IF ALL ARE = LOWER BOUND. * STB T8AEA CLEAR 'FIRST ELEMENT' FLAG. LDA INT SET UP TYPE TO CONVERT TO. LDB F.DIS DOUBLE INTEGER SUBSCRIPTING ?  SZB LDA DBI YES. CONVERT TO DBI, ELSE TO INT. STA T9AEA T9AEA = SUBSCRIPT TYPE TO USE. LDB F.S1T T4AEA = SUBSCRIPT POINTER. STB T4AEA SKP * CONVERT TO INTEGER. * AEA15 LDB B,I F.A OF SUBSCRIPT. SZB IF SUBSCRIPT IS IN REGISTERS, CPB K1 JMP AEA17 GO CHECK TYPE. STB F.A OTHERWISE MAKE SURE IT IS JSB FA.F NOT A SUBPROGRAM NAME. LDA K25 LDB F.IU CPB SUB JSB ER.F AEA17 LDA T9AEA IF REQ'D, CONVERT TO INT/DBI. STA F.RTP LDB T4AEA LOCATION OF CONVERSION SOURCE JSB CON.F CONVERT IT TO INTEGER (IF NOT ALREADY). * * IF SUBS. # L.B., CLEAR 'FIRST ELEMENT' FLAG. * LDB T3AEA BACK UP TO CURRENT LOWER BOUND. ADB KM2 STB T3AEA LDB B,I LOWER BOUND F.A JSB GCD.F IS IT CONSTANT ? JMP AEA18 NO. NOT FIRST ELEMENT. * CMAI CMA YES. IT WAS NEGATED; RESTORE IT. CMB,INB,SZB,RSS INA .DST DST T0AEA SAVE IT FOR NOW. LDB T4AEA,I SUBSCRIPT F.A JSB GCD.F IS IT CONSTANT ? JMP AEA18 NO. THEN NOT FIRST ELEMENT. * CPA T0AEA IS IT THE SAME ? RSS JMP AEA18 NO. * CPB T0AEA+1 RSS YES. LEAVE FLAG ALONE. AEA18 ISZ T8AEA TEST FAILS. NOT FIRST ELEMENT. * * END LOOP. * ISZ T4AEA NEXT SUBSCRIPT. LDB T4AEA CPB S1LOC DONE ? RSS YES. JMP AEA15 NO, CONTINUE. SKP * IF ALL SUBSCRIPTS = L.B., TREAT AS SIMPLE. * LDA T8AEA IS FLAG STILL SET ? LDB F.COP AND NOT IN PREAMBLE ? SZA,RSS CPB K31 PREAMBLE: F.COP=31. JMP AEA05 NO. * LDA T1AEA YES. TREAT AS SIMPLE. LDB T6AEA (A)=F.A, (B)=F.IM JMP AEA28 * * IF EMA, DOl@NE VIA SUBROUTINE/MICROCODE. * AEA05 LDA T1AEA RESTORE F.A, STA F.A JSB EA?.F AND SEE IF EMA. RSS NO. GO ON. JMP AEA20 YES. PROCESS EMA. * * LOOP THRU DIMENSIONS TO * COMPUTE CULULATIVE PRODUCTS OF DIMENSIONS. * LDA DTBAE T9AEA = CUMULATIVE DIMENSION POINTER. STA T9AEA AEA06 ISZ T3AEA SKIP LOWER BOUND. LDB T3AEA,I F.A OF DIMENSION SIZE (WAS U.B.) ISZ T3AEA JSB CFC.F CONSTANT ? CLA (NO, SET PRODUCT = 0) MPY T9AEA,I MULTIPLY BY OLD PRODUCT. ISZ T9AEA SET NEW CUM. PROD. STA T9AEA,I * * END LOOP. * LDB T3AEA SEE IF WE'RE DONE. CPB T2AEA I.E., BACK TO END OF DIMENSIONS. RSS YUP. JMP AEA06 NO, CONTINUE. * * INITIALIZE SUBSCRIPT COMPUTATION LOOP. * LDA F.S1T T4AEA = SUBSCRIPT PTR. STA T4AEA ISZ T3AEA T3AEA = DIM SIZE PTR. (LWA+2 HERE) CLA,INA MULTIPLIER = 1. STA T8AEA CLA OFFSET = 0. STA TAAEA JSB EIC.F VALUE = 0. JSB PU1.F ISZ PNUM REMEMBER TO POP LATER. SKP * TOP OF REVERSE LOOP. BACK UP POINTERS. * AEA09 LDA T3AEA T3AEA = DIM PTR. ADA KM2 STA T3AEA CCA T9AEA = CUMULATIVE PRODUCT PTR. ADA T9AEA STA T9AEA * * MULTIPLY BY DIMENSION (EXCEPT 1ST LOOP) * LDA T4AEA 1ST LOOP ? CPA F.S1N JMP AEA14 YES, SKIP IT. LDB T3AEA,I NO. CONSTANT ? JSB CFC.F JMP AEA13 NO. MPY T8AEA YES. UPDATE MULTIPLIER. STA T8AEA JMP AEA14 AEA13 JSB MVM.F NOT CONST: MULT VALUE BY MULTIPLIER, LDA T3AEA,I THEN BY DIMENSION. JSB PU1.F JSB MPY.F * * IF SUBSCRIPT & PREV. DIM CONSTANT, PRE-COMPUTE. *  AEA14 LDB T4AEA,I SUB CONST ? JSB CFC.F JMP AEA12 NO. * LDB T9AEA,I ALL PREV. DIM CONSTANT ? SZB,RSS (IF SO, PRODUCT IS NON-ZERO) JMP AEA12 NO. SOME VAR DIM SOMEWHERE. * MPY B YES. * CUMULATIVE PRODUCT. ADA TAAEA ADD TO OFFSET. STA TAAEA JMP AEA16 DONE HERE. * * ADD SUBSCRIPT. END LOOP. * AEA12 JSB MVM.F FIRST, MULT VALUE BY MULTIPLIER. LDA T4AEA,I THEN ADD SUBSCRIPT. JSB PU1.F JSB ADD.F AEA16 ISZ T4AEA TO PREVIOUS SUBSCRIPT. LDA T9AEA IF JUST DID FIRST SUBSCRIPT, CPA DTBAE RSS DONE. JMP AEA09 ELSE LOOP. SKP * MULTIPLY OFFSET*NW, VALUE*NW*MULTIPLIER. * LDA TAAEA OFFSET. MPY T7AEA STA TAAEA LDA T8AEA MULTIPLIER. MPY T7AEA *NW JSB EIC.F *VALUE. JSB PU1.F JSB MPY.F * * COMPUTE ADDRESS FOR NON-FORMALS. * LDB T1AEA SET UP F.A, STB F.A JSB FA.F AND FETCH ASSIGNS. LDA F.AT FORMAL PARAMETER ? CPA DUM JMP AEA30 YES. DIFFERENT. * CCB GET THE LOWER BOUND CORRECTION: ADB F.LUB IN WORD BEFORE FIRST LOWER BOUND. LDB B,I HERE'S THE F.A ADB K2 INDEX TO THE VALUE, LDA B,I AND GET IT. STA T0AEA SAVE LOWER-BOUND CORRECTION. LDB F.S1T,I SUBSCRIPT VALUE CONSTANT ? JSB CFC.F JMP AEA29 NO. * ADA TAAEA YES. ADD OFFSET. ADA T0AEA ADD LOWER-BOUND CORRECTION. LDB T1AEA ESTABLISH DATA WITH OFFSET ENTRY TO JSB EDO.F (ADDR) + (VALUE+OFFSET+CORRECTION) LDA F.A F.A OF ITEM. LDB T6AEA F.IM OF ITEM. JMP AEA28 CLEAN UP. * AEA29 LDA TAAEA ESTABLISH DEF TO (ADDR+OFFSET+CORRECTION) ADA T0AEA LOWER-BOUND-CORRECTION. xLDB T1AEA JSB ESD.F LDA F.A ADD VALUE. JMP AEA31 SKP * COMPUTE ADDRESS FOR FORMAL PARAMETER. * AEA30 LDA TAAEA ADD OFFSET TO VALUE. JSB EIC.F JSB PU1.F JSB ADD.F LDA T1AEA GET ADDR F.A OF INA (ADDR + LOWER_BOUND_CORRECTION) LDA A,I (A)=F.A OF DIM. ADA K2 ADDR IN DIM ENTRY FOR THE F.A LDA A,I F.A OF THE DEF. SZA,RSS IS IT PROLOGUE CODE ? JMP AEA.F,I YES, COMPUTING THE DEF, NOT USING. * AEA31 STA T0AEA SAVE F.A OF DEF. JSB SCG.F LOAD VALUE. JSB ABB.F SET UP A/B BIT. ADA ADAI ADA/ADB LDB T0AEA ADD DEF. JSB SOA.F LDB F.RES RESULT IS AN ADDR IN (A) OR (B). JMP AEA24 SPC 1 ADAI OCT 42000 DUM OCT 5000 * S1LOC NOP .EMAP ABS 78 EMA ARRAY ELEMENT ADDRESS CALCULATER .ERES ABS 79 AS ABOVE BUT WITHOUT MAPPING. .DMAP ABS 88 DOUBLE INTEGER VERSIONS. .DRES ABS 89 .SMAP ABS 264 .SRES ABS 265 .ERR0 ABS 83 SKP * EMA. * AEA20 JSB SMT.F SINCE WIPING OUT MAPS, SAVE MAPPED DATA. JSB SBR.F AND REGISTERS, FOR THAT MATTER. LDA T7AEA IF ZERO-DIMENSION, SSA (I.E., T7AEA<0) JSB EAC.F AND CALL-BY-REFERENCE, RSS (NO) JMP AEA25 THEN USE ADDRESS DIRECTLY. * LDA TBAEA NO. SINGLE OR DOUBLE INTEGER SUBSCRIPTS ? SZA JMP AEA21 DOUBLE. GO USE .DMAP/.DRES * LDA F.CCW SINGLE. 'S' OPTION SET ? RAL SSA,RSS JMP AEA35 NO. USE .EMAP/.ERES * LDB .SRES YES. USE .SMAP/.SRES JSB EAC.F LDB .SMAP JMP AEA32 OUTPUT JSB & GO ON. * AEA21 LDB .DRES DOUBLE. ASSUME .DRES JSB EAC.F IF CALL-BY-VALUE, LDB .DMAP USE .DMAP AEA32 JSB ODF.F ISSUE THE CALL, JMP AEA26 AND SKIP THE GARBAGE PARAMETERS. * AEA35 LDB .ERES SINGLE. ASSUME .ERES JSB EAC.F IF CALL-BY-VALUE, LDB .EMAP USE .EMAP JSB ODF.F SEND DOT FUNCTION CALL LDB PNUM COMPUTE THE DEF ERR RETURN ADDRESS ADB K2 *+NDIM+3 JSB OZ.F SEND IT LDA BMAX OUTPUT 77777B INSTEAD OF DEF TO EMA MASTER. JSB OAD.F AEA26 DLD T1AEA,I (B) = F.A OF THE DIM ENTRY (IF THERE) AND B600 GET F.IU CPA ARR ARRAY ? RSS JMP AEA36 NO. THEN (B) = F.A OF BCOMI ENTRY. * LDA T7AEA YES. USED AS ARRAY OR SIMPLE ITEM ? SSA,RSS JMP AEA36 ARRAY. USE (B) = F.A OF DIM ENTRY. * DLD B,I SIMPLE ITEM. INDEX TO THE BCOMI ENTRY. AEA36 JSB DEF.F LDA T7AEA GET ZERO-DIM FLAG. SSA IF ZERO-DIM CASE, JMP AEA23 GO SEND THE ERR0. * LDB F.S1T SET UP TO SEND STB T4AEA THE DEFS TO THE INDEXES AEA22 LDB T4AEA THE DEF'S TO THE INDEXES CPB S1LOC END OF LIST? JMP AEA23 YES GO WRAP IT UP * ISZ T4AEA SET IT FOR NEXT TIME LDB B,I GET THE A.T. POINTER JSB DEF.F SEND A DEF JMP AEA22 TRY AGAIN * AEA23 LDB .ERR0 NOW SEND A JSB ERR0 LDA F.CCW UNLESS 'S' OPTION, RAL,ELA (E=1 IFF 'S') LDA TBAEA OR DOUBLE INTEGER SUBSCRIPTS. SEZ,SZA,RSS WELL ? JSB ODF.F .EMAP/.ERES, ISSUE IT. (ERROR RETURN) CLB,INB SET FOR RESULT TO BE IN B-REG. JSB EAC.F CALL-BY-REF ? JMP AEA33 NO, SET UP AS ADDR & EXIT. * LDA DBI SET UP A-REG AS DOUBLE INTEGER. JSB SRS.F DEF K0 CLA F.RES=A. JMP AEA27 * AEA25 LDB T1AEA A.T. PTR INB GET DIM OR BCOM PTR LDB B,I LDA T1AEA,I CHECK IF ARRAY. AND B600 CPA ARR IF SO, INB,RSS SKIP THE DIM ENTRY RSS TO GET TO THE 6 LDB B,I BCOM ENTRY. INB LOAD EMA OFFSET. LDA B,I A = LSB. STA F.A IN CASE FORMAL. STA F.IDI IN CASE NOT. LDA T1AEA,I CHECK FOR THAT. AND B7000 CPA DUM WELL ? JMP AEA34 YES. USE THE TEMP. * ADB K2 LDB B,I B = MSB. STB F.IDI+1 SET CONSTANT VALUE. LDA DBI SET UP DOUBLE INT JSB ESC.F JSB AI.F ENTER IN TABLE. AEA34 LDA F.A GET A.T. PTR FOR CONSTANT OR TEMP. AEA27 LDB DBI 2-WORD ADDRESS, CALL IT DOUBLE INT. AEA28 STA F.RES NOTE LOCATION OF IT. STB F.RTP JMP AEA.F,I RETURN. * AEA24 CLE,RSS NON-EMA ADDR. AEA33 CCE EMA ADDR. STB T0AEA REG #. STB F.RES LDA T6AEA F.IM CLB NO STACK. STO ADDR IN REG. JSB SRD.F SET UP REG INFO. DEF T0AEA JMP AEA.F,I EXIT. * SPC 1 T0AEA BSS 2 T1AEA NOP T2AEA NOP T3AEA NOP T4AEA NOP T6AEA NOP T7AEA NOP T8AEA NOP T9AEA NOP TAAEA NOP TBAEA NOP SAVED VALUE OF F.DIS INT OCT 10000 F.IM=1 INTEGER B600 OCT 600 F.IU MASK ARR EQU B600 F.IU=ARRAY K0 DEC 0 BMAX OCT 77777 VALUE TO FAKE OUT .EMAP DTBAE DEF *+1 ADDR OF CUMULATIVE PRODUCT TABLE. DEC 1 THE TABLE. BSS 3 (LAST WORD COMPUTED BUT NOT USED) SPC 2 MVM.F NOP MULTIPLY VALUE BY MULTIPLIER. LDA T8AEA MULTIPLIER. JSB EIC.F FORM CONSTANT. JSB PU1.F JSB MPY.F MULTIPLY. CLA,INA RESET MULTIPLIER. STA T8AEA JMP MVM.F,I EXIT. * * SKIP IF CURRENT USE IS CALL-BY-REFERENCE. * EAC.F NOP STB T1EAC SAVE (B). LDA F.COP IF DOING PROGRAM ENTRY, CPA K31 JMP EAC04 THEN BY REFERENCE. * LDB T7AEA IF EXPLICIT SUBSCRIPTS, SSB,RSS LDA F.LA1 THEN MUST LOOK AHEAD. CPA K59 DOES IT HAVE CALL-BY-REF FORM ? RSS (YES) JMP EAC05 NO. BY VALUE. * LDB F.S1T SEARCH FOR THE SUBROUTINE NAME. EAC01 INB NEXT ITEM. (CAN'T BE ON TOP) LDA B,I SSA,RSS MARKED ? JMP EAC01 NO. NOT THERE YET. * RAL,CLE,ERA YES. CLEAR THE SIGN BIT. LDA A,I FIRST WORD TABLE ENTRY. STA T2EAC (SAVE FOR LATER) AND B600 SUBROUTINE ? CPA SUB RSS YES. GOT IT. JMP EAC01 NO. KEEP LOOKING. * LDA T2EAC YES. GET F.NC AND B140 CPA B40 INTRINSIC ? JMP EAC05 YES. BY VALUE. * LDA T2EAC NO. GET F.AT AND B7000 CPA REL F.AT=REL (STMT FCT) ? RSS YES. BY VALUE. (ELSE BY REF) EAC04 ISZ EAC.F BY REFERENCE. BUMP RETURN. EAC05 LDB T1EAC RESTORE (B). JMP EAC.F,I EXIT. * T1EAC NOP SAVED (B). T2EAC NOP 1ST WD OF ENTRY. B140 OCT 140 MASK FOR F.NC (INTRINSICS FLAGS) SKP * ****************************** * * GENERATE DOT FUNCTION CALL * * ****************************** SPC 1 * ENTRY: OPERAND(S) ON STACK, LAST OPERAND IS TOP-OF-STACK. * (A) = DOT FUNCTION INFORMATION: * BIT 15: CALL SPECIAL HANDLER, ADDR IN 14:0. * IF < 1000B, JUMP TABLE ORDINAL. * 14: REGISTERS PRESERVED BY FUNCTION. * 13: OPERAND(S) ALWAYS IN MEMORY. * 12: USE RETURN ADDRESS. * 11: ISSUE 'JSB ERR0' AFTER CALL. * 10: RESERVED. * 9: RESERVED. * 8-0: DOT FUNCTION ORDINAL, [0,511] . * * (B) = NUMBER OF OPERANDS. * * (F.RTP) = RESULT TYPE. * * (F.RES) = F.A OF RESULT, IF IN MEMORY. * * EXIT: 6 (A) = (F.RES) = F.A OF RESULT. * REGISTER DATA UPDATED AS REQUIRED. * OPERANDS POPPED FROM STACK, BUT RESULT NOT PUSHED * BACK (IN CASE EXPLICIT FUNCTION CALL). * * NOTE: GDF.F ASSUMES THAT THE DOT FUNCTION CALLED DOES NOT * ALTER THE STATE OF THE MAPS. IF GDF.F IS TO BE USED * TO CALL SOMETHING WHICH DOES ALTER THE MAPS, THE * ROUTINE SMT.F SHOULD BE CALLED FIRST. SPC 1 * ENTRY. CHECK FOR SPECIAL CASE. * GDF.F NOP STA T1GDF SAVE DOT INFO. RAL,CLE,SLA,ERA SIGN SET ? (CLEAR IT) JMP GDF30 YES. SPECIAL CASE. * * * GET RESULT INFO. DEFAULT = REG. * STB T2GDF SAVE OPND COUNT. LDA F.RTP DETERMINE IF RESULT FITS IN REG. STA T7GDF (ALSO SAVE TYPE) JSB MIM.F (B): -1,NOT REG. 0,(A). 1,(A,B). STB T4GDF T4GDF = RESULT REGISTER INFO. CLA (A)=0, RESULT F.A IF IN REG. SSB,RSS RESULT IN REGISTER(S) ? JMP GDF09 YES. * JSB GRD.F NO. ADDRESS IN REGISTER ? DEF F.RES LDA B (A)=STACK ADDR OR NEGATIVE. XOR KK01 IF ADDR IN REG, (A)=INDIRECT TO STACK. SSA,RSS WELL ? LDA F.RES NO. (A)=ACTUAL F.A LDB T4GDF RESTORE (B). GDF09 STA T5GDF SAVE RESULT F.A SKP * STORE REGISTERS ONLY IF WE HAVE TO. * LDA T1GDF DOES THE FUNCTION UNDERSTAND REGISTERS ? RAL (BIT 14) SSA JMP GDF10 YES. ANALYZE RESULT REGISTERS, TOO. * JSB SBR.F NO. JUST STORE REGISTERS. (EMA: ADDR ONLY) JMP GDF15 THAT WAS EASY ! * GDF10 SSB RESULT IN REGISTERS ? JMP GDF15 NO. DON'T HAVE TO STORE AT ALL. * LDA F.S1T YES. MAKE ROOM FOR RESULT, BUT DON'T STORE ADA T2GDF OPERANDS IN REGISTERS. STA T3GDF SET UP TO SCAN OPERANDS. LDABI LDA B ACCUMULATE DATA IN (A). (FOR IOR) GDF11 LDB T3GDF DONE ? CPB F.S1T JMP GDF12 YES. * ADB KM1 NO. GO ON TO NEXT. STB T3GDF LDB B,I OPERAND. SZB,RSS IN (A) ? IOR K4 YES, FLAG SO ISN'T SAVED. CPB K1 IN (B) ? IOR K2 DITTO. (MAY DO TWICE! A+A) JMP GDF11 * GDF12 STA T3GDF SAVE FLAGS. RAR,RAR SAVE (A) ? SLA I.E., NO OPERAND IN (A) ? JMP GDF13 NO. OPERAND IN (A), LEAVE IT. * JSB SRT.F YES. SAVE (A). DEF K0 GDF13 CLA,INA IS B-REG PART OF (A,B) DATA ? CPA F.ACB WELL ? JMP GDF15 YES. DON'T HAVE TO SAVE THEN. * LDA T3GDF FLAGS. SLA,RSS IS (B) PART OF RESULT ? JMP GDF15 NO. DON'T SAVE. * RAR,SLA YES. IS IT AN OPERAND ? JMP GDF15 YES. DON'T SAVE. * JSB SRT.F SAVE (B). DEF K1 SKP * LOAD (FIRST) OPERAND IF REQUIRED. * GDF15 LDA T1GDF SHOULD WE ? RAL,RAL (BIT 13) SSA JMP GDF16 NO, USE DEF(S). * CCA YES. GET IT. ADA T2GDF ADA F.S1T LDB A,I (B) = F.A OF OPERAND. JSB LDA.F ALWAYS PASS IN (A) OR (A,B). * * ISSUE JSB AND OPTIONAL RETURN ADDR. * GDF16 LDA T1GDF ISSUE THE JSB. AND B777 ORDINAL: BITS 8:0. LDB A JSB ODF.F LDA T1GDF RETURN ADDRESS ? ALF,RAR (BIT 12) SSA,RSS JMP GDF17 NO. * LDB T2GDF YES. (B) SET UP FOR 'DEF *+N' INB DEF *+N+1 LDA T4GDF RESULT IN REGISTERS ? SSA (-1=N0, 0=A, 1=A,B) INB NO. DEF *+N+2 CLA A=0, DEF. JSB OZ.F RETURN ADDR. * * ISSUE DEF'S TO RESULT AND OPERANDS. * GDF17 LDB T5GDF SET UP RESULT ADDRESS. RBL,CLE,SLB,ERB (IF ON STACK, M_AY HAVE BEEN STORED LDB B,I IN A TEMP, SO WANT UPDATED F.A) STB T5GDF & SAVE IT. LDA T4GDF RESULT IN REGISTERS ? SSA JSB DEF.F NO, ISSUE DEF TO RESULT. * LDA F.S1T SET UP LOOP THRU OPERANDS. ADA T2GDF (POINTS JUST BEFORE 1ST OPND) LDB T1GDF 1ST OPERAND IN REGISTER(S) ? RBL,RBL (BIT 13) SSB,RSS WELL ? ADA KM1 YES. SKIP IT. STA T3GDF SET UP LOOP. GDF19 LDA T3GDF DONE ? CPA F.S1T JMP GDF20 YES. * ADA KM1 NO. GO ON TO NEXT OPERAND. STA T3GDF LDB A,I ISSUE DEF TO IT. JSB DEF.F JMP GDF19 & LOOP. * * ISSUE OPTIONAL 'JSB ERR0'. * GDF20 LDA T1GDF IS OPTION SET ? ALF (BIT 11) LDB .ERR0 (ORDINAL OF ERR0) SSAI SSA WELL ? JSB ODF.F YES. DO IT. * * SET UP (F.RES) & (F.RTP). * LDA T5GDF JUST COPY RESULT ADDR. STA F.RES LDA T7GDF ALSO RESTORE RESULT TYPE. STA F.RTP * * POP OPERANDS & INVALIDATE ANY REGISTERS FOUND. * LDA T2GDF OPERAND COUNT. CMA,INA,SZA,RSS ANY ? JMP GDF22 NO. GO SET UP REG. * STA T3GDF ELSE T3GDF = -(COUNT) GDF21 JSB CRD.F IF OPERAND IN REGISTER, ZAP IT. DEF F.S1T,I JSB PO1.F POP OPERAND, ISZ T3GDF COUNT JMP GDF21 & LOOP. * * IF RESULT IN REGISTER(S), SET THAT UP. * GDF22 LDA T4GDF CAREFUL! MAY HAVE RESULT ADDRESS IN SSA REGISTER FOR DBL/RE8/CPX. JMP GDF23 SO IF ONE OF THOSE, DON'T CALL SRS.F * LDA F.RTP (A) = TYPE OF RESULT. JSB SRS.F REGISTER RESULT, UPDATE REG INFO. DEF F.RES GDF23 LDA F.RES RETURN (A) = RESULT F.A JMP GDF.F,I EXIT. SKP * BIT 15 SET, JUMP TO SPECIAL HANDLER. * GDF3D0 STA T1GDF (A) = LOW 15. AND B777 ARE THEY < 1000B ? CPA T1GDF RSS JMP T1GDF,I NO. IT'S AN ADDRESS, JUMP THERE. * LDB GDF.F (SAVE RTN ADDR, SO WE CAN MAKE A STB T6GDF RECURSIVE CALL TO GDF.F IF NEED BE) ADA DIITB INLINE INTRINSIC, INDEX LDA A,I INTO THE TABLE. JSB A,I PRODUCE CODE FOR THE OPERATOR. JSB PO1.F POP RESULT OFF STACK, GDF34 STA F.RES F.RES=RESULT. LDB A FIND TYPE. JSB FT.F STA F.RTP F.RTP=TYPE. JMP T6GDF,I EXIT USING SAVED ENTRY POINT. * B777 OCT 777 K4 DEC 4 DIITB DEF IITBL ADDR OF INLINE INTRINSICS TABLE. T1GDF NOP FLAGS & ORDINAL. T2GDF NOP # OPERANDS. T3GDF NOP POINTER/COUNTER. T4GDF NOP RESULT REGISTER FLAG. T5GDF NOP RESULT F.A T6GDF NOP SAVED ENTRY, FOR RECURSIVE CALLS. T7GDF NOP SAVED F.RTP * * INLINE INTRINSICS TABLE. * IITBL BSS 0 DEF CNVRT CONVERT TO RESULT TYPE. DEF ABS 1 DEF ABS 2 DEF ABS 3 DEF ISHFT 4 DEF AND.F IAND 5 DEF .OR.F IOR 6 DEF XOR.F IXOR 7 DEF NOT.F NOT 8 DEF NOT.F DNOT 9 DEF PCNT PCOUNT 10 * * ALL CONVERSIONS. * CNVRT NOP LDA F.RTP RESULT TYPE. JSB CTS.F CONVERT. JMP CNVRT,I SKP * INLINE ABSOLUTE VALUE, INT/DBI/REA. * ABS NOP LDB F.S1T,I CONSTANT ? JSB CFC.F JMP ABS01 NO. * SSA,RSS YES. POSITIVE OR NEGATIVE ? JMP ABS,I POSITIVE. JUST IDENTITY. JMP ABS02 NEGATIVE. NEGATE. (INT & DBI BOTH) * ABS01 LDB F.S1T,I NOT CONSTANT. LOAD IT. JSB LD.F JSB P1P.F MAKE STACK RIGHT FOR NEG.F JSB ABB.F FORM A/B BIT, ADA SSAI TO PICK SSA/VSSB. JSB OAI.F OUTPUT TEST, ABS02 JSB NEG.F AND NEGATION. JMP ABS,I GO CLEAN UP. * * PCOUNT(). * PCNT NOP LDA F.RTP SAVE RESULT TYPE. STA T1GDF LDA F.SBF MAIN ? SZA JMP PCNT1 NO. * JSB EIC.F YES. FORM INT ZERO. STA F.RES HERE IT IS. JMP PCNT2 GO STACK & EXIT. * PCNT1 JSB AOR.F SUBPROG. ALLOCATE REGISTER. JSB ABB.F GET A/B BIT. IOR LDAI 'LDA TEMP' LDB F.PCT JSB SOA.F LDA CMAI 'CMA' JSB ORI.F JSB ABB.F A/B BIT. IOR ADAII 'ADA TEMP,I' LDB F.PCT JSB SOA.F LDA INT SET UP REGISTER AS INTEGER. JSB SRS.F DEF F.RES PCNT2 LDA F.RES STACK UP THE RESULT. JSB PU1.F LDA T1GDF SET UP F.RTP & CONVERT JSB CTS.F TO DBL INT IF NEED BE. JMP PCNT,I DONE. SKP * SHIFT FUNCTION. IF VARIABLE COUNT, CALL LIBRARY. * ISHFT NOP LDB F.S1T,I SHIFT COUNT CONSTANT ? JSB CFC.F RSS NO. JMP SHFT1 YES. * LDB F.S1N,I LIBRARY. GET DATA TYPE. JSB FT.F JSB CTS.F CONVERT SHIFT TO MATCH. LDB F.RTP SELECT: LDA .ISH .ISH FOR INT*2, CPB DBI LDA .JSH .JSH FOR INT*4 LDB K2 TWO PARAMETERS. JSB GDF.F RE-ENTER TO ISSUE CODE. JMP T6GDF,I EXIT. * * CONSTANT SHIFT COUNT. TEST FOR LARGE OR ZERO. * SHFT1 JSB PO1.F GET VALUE. LDBAI LDB A JSB GCD.F AS A DOUBLE INTEGER. HLT 12 (MUST BE CONST) SWP TEST FOR VERY LARGE. ASL 16 SOC JMP SHFT2 YES. VALUE = 0. (O=1) * STB T1GDF SAVE VALUE. JSB GT1.F GET TYPE OF DATA. LDB T1GDF RESTORE VALUE TO TEST. SSB MUST TEST ABS VALUE, CMB,INB SINCE 2'S COMP IS ASYMMETRIC. ASL 10 CHECK FOR [-31,+31]. LDA F.IM IF SINGLE INTEGER, CPA INT ADB B FURTHER LIMIT TO [-15,+15]. SHFT2 CLA (A,B)=0 IN CASE LARGE SHIFT. CLBI CLB SOC WELL ? JMP SHFT4 TOO BIG, RESULT = 0. * LDB T1GDF REASONABLE SHIFT. ZERO ? SZB,RSS JMP ISHFT,I YES. RESULT = DATA. * SSB,RSS TAKE -ABS OF SHIFT COUNT. CMB,INB STB T2GDF LDB F.S1T,I IS DATA CONSTANT ? JSB CFC.F JMP SHFT6 NO. SKP * BOTH SHIFT & DATA CONSTANT. FOLD. * LDA F.S1T,I GET VALUE. STA F.A JSB FC.F IN (F.IDI) OR (F.IDI,F.IDI+1) LDA T1GDF SET (E) ELA TO SIGN OF SHIFT COUNT. LDB F.IDI CONSTANT TO (B,A), OR (B) WITH A=0. LDA F.IDI+1 SHFT3 SEZ IF NEGATIVE, LSR 1 RIGHT SHIFT. SEZ,RSS IF POSITIVE, LSL 1 LEFT SHIFT. ISZ T2GDF COUNT JMP SHFT3 & LOOP. * * CONSTANT RESULT, SET IT UP. * SHFT4 STB F.IDI VALUE. STA F.IDI+1 JSB GT1.F SET UP F.RTP JSB PO1.F DISCARD OLD DATA. LDA F.RTP TYPE. JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A RESULT. JMP GDF34 * * SHIFT CONSTANT. CHECK DATA TYPE. * SHFT6 JSB GT1.F WHAT IS IT ? CPA DBI JMP SHFT9 DOUBLE INTEGER. * CLAI CLA SINGLE. CHECK SPECIAL CASES: LDB T1GDF CPB K1 LEFT 1 ? LDA CLELA CLE,ELA CPB K2 LEFT 2 ? LDA ALRRL ALR,RAL INB,SZB,RSS RIGHT 1 ? LDA CLERA CLE,ERA SZA,RSS ANY OF THE ABOVE ? JMP SHFT7 NO. NOT A SPECIAL CASE. * STA T1GDF YES. USE IT. JSB SCG.F LOAD DATA IN EITHER REG. LDA T1GDF ISSUE INSTRUCTION, JSB ORI.F O MODIFIED BY REGISTER NUBMER. JMP ISHFT,I EXIT. * CLELA CLE,ELA ALRRL ALR,RAL CLERA CLE,ERA SKP * NORMAL SINGLE INTEGER. * SHFT7 SSB RIGHT OR LEFT ? JMP SHFT8 RIGHT. * LDB F.S1T,I LEFT: JSB LDA.F LDA X JSB SRT.F SAVE (B) DEF K1 LDA LSL00 LSL COUNT ADA T1GDF JMP SHF8A GO FINISH. * SHFT8 LDB F.S1T,I RIGHT: JSB LDB.F LDB X JSB SRT.F SAVE (A) DEF K0 LDA T1GDF LSR COUNT CMA,INA ADA LSR00 SHF8A JSB OAI.F JSB PO1.F DISCARD ORIGINAL DATA. JMP T6GDF,I DONE. SPC 2 R.REG EQU 040000B REGISTER BIT IN GDF.F CALL. .ISH ABS R.REG+254 FUNCTION INFO FOR SINGLE INT SHIFT. .JSH ABS R.REG+255 FOR DOUBLE INT. LSL00 LSL 16 LSR00 LSR 16 RRL00 RRL 16 RRR00 RRR 16 ANDI OCT 12000 K16 DEC 16 KM16 DEC -16 SPC 2 * SUBROUTINE TO PERFORM: 'AND =D 2**(16-COUNT)-1' * WHICH CLEARS THE UNUSED BITS IN DOUBLE INTEGER * SHIFTS OF 1-15 BITS. * SHM.F NOP LDA K16 FORM 16 - COUNT. ADA T2GDF ADA LSL00 LSL 16-COUNT. STA SHM01 WILL EXECUTE. CLA,INA 1. SHM01 ABS *-* LSL 16-COUNT: 2**(16-COUNT) ADA KM1 -1 JSB EIC.F MAKE THE CONSTANT. LDA ANDI 'AND' JSB OA.F JMP SHM.F,I EXIT. SKP * DOUBLE INTEGER DATA. IN-LINE. * SHFT9 JSB SCG.F LOAD INTO (A,B). LDB T1GDF TEST COUNT ? ASL 11 O=1 IFF 16-31 BITS, LEFT OR RIGHT. SSB WHICH ? JMP SHF11 RIGHT. * SOC LEFT. 1-15 OR 16-31 ? JMP SHF10 16-31. * JSB SHM.F 1-15 LEFT. CLEAR BITS SHIFTED OFF. LDA RRL00 RRL COUNT. ADA T1GDF JSB OAI.F JMP ISHFT,I EXIT. * SHF10 LDA LDABI 16-31 LEFT. JSFB OAI.F 'LDA B' LDA T1GDF ADA KM16 ADA LSL00 'LSL COUNT-16' CPA LSL00 RSS (UNLESS COUNT = 16) JSB OAI.F LDA CLBI JSB OAI.F 'CLB' JMP ISHFT,I DONE. * SHF11 SOC RIGHT. 1-15 OR 16-31 ? JMP SHF12 16-31. * LDA T1GDF RIGHT 1-15. CMA,INA ADA RRR00 RRR COUNT. JSB OAI.F JSB SHM.F CLEAR BITS SHIFTED IN. JMP ISHFT,I * SHF12 LDA LDBAI RIGHT 16-31. JSB OAI.F 'LDB A' LDA T1GDF CMA,INA ADA KM16 ADA LSR00 'LSR COUNT-16' CPA LSR00 RSS (UNLESS COUNT = 16) JSB OAI.F LDA CLAI JSB OAI.F 'CLA' JMP ISHFT,I DONE. * END ASMB,Q,C HED CODE GENERATION FOR KEYWORD STATEMENTS. NAM KWC.F,8 92834-16003 REV.2030 800821 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * e 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.AF ADDRESS FIELD CURRENT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.C OFFSET FOR CODE GEN. EXT F.CSL CHARACTER STRING LENGTH. EXT F.D0 ARRAY ELEMENT SIZE. EXT F.D DO TABLE POINTER. EXT F.DO LWA+1 DO TABLE. EXT F.DID ADDRESS OF F.IDI EXT F.EM EMA FLAG BIT IN A.T. ENTRY. EXT F.FRF FUNCTION RESULT F.A (NON-STMT FCT). EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURRENT ITEM USAGE. EXT F.L # ITEMS ON STACK 2 ?? EXT F.LO END OF A.T. + 1 EXT F.LUB ADDR OF LOWER/UPPER BOUNDS TABLE. EXT F.NAR NUMBER OF ALTERNATE RETURNS. EXT F.NC NAME CHANGE FLAG. EXT F.ND NUMBER OF DIMENSIONS EXT F.NIT NO-INLINE-TEMPS FLAG. EXT F.OFE DATA POOL OVERFLOW ENTRY. EXT F.REL SUB. PROG. RETURN LOCATION EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.SBF 0=MAIN, ELSE F.A OF SUBPROGRAM. EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.T # WORDS ON STACK 1 EXT F.VDM VARIABLE DIMENSIONS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR CONSTANT. EXT DAT.F DEFINE (F.AT) EXT DL.F DEFINE LOCATION SUBROUTINE. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT ESD.F ESTABLISH DEF SUBROUTINE EXT FA.F FETCH ASSIGNS EXT NWI.F SET F.D0 TO # WORDS IN ARRAY. EXT OA.F OUTPUT ASSIGNMEXT TABLE OPERAND EXT OAD.F OUTPUT ABS. DATA EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODF.F OUTPUT DOT FUNCTION EXT OID.F OUTPUT INSTRUCTION, DOT-OPERAND. EXT OLR.F OUTPUT LOAD ADDRESS EXT OMR.F OUTPUT MEMORY REF. INSTRUCTION EXT ORI.F OUTPUT ABS. REGISTER INSTRUCTION. EXT OW.F OUTPUT WORD EXT OZ.F OUTPUT ZREL (OP *+N) EXT PDF.F PRODUCE DEF EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) * * ENTRY POINTS IN F4.6 * EXT F.COC CURRENT OPCODE COUNT. EXT F.COP CURRENT OPCODE. EXT F.DFS 'DO' FINAL & STEP F.A'S. EXT F.RES RESULT F.A . EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT APT.F ALLOCATE PERMANENT TEMP. EXT ATC.F ALLOCATE TEMP CELL. EXT DEF.F GENERATE DEF TO (B). EXT ITN.F INITIALIZE TEMP CELL COUNTERS. EXT MAP.F MAP F.A IN FROM EMA IF NEED BE. EXT RD.F PASS FILE ONE READ WITH LOOK-AHEAD. * * ENTRY POINTS IN AOP.F (ARITH & LOG & REL OP CODE GEN.) * EXT ADD.F ADD. EXT CTS.F CONVERT TOP OF STACK. EXT MP1.F MAP TOS IF NEED BE. EXT MPY.F MPY. EXT NEG.F NEGATE. * * ENTRY POINTS IN KWC.F (KEYWORD STMT CODE GEN) * ENT AGT.F ASSIGNED GOTO. ENT AIF.F ARITHMETIC IF. ENT ASP.F ASSIGN STATEMENT. ENT CAD.F ASCII DATA OUTPUT (FORMAT & DATA STMTS) ENT CGT.F COMPUTED GOTO. ENT DO.F DO. ENT DTA.F DATA STATEMENT. ENT DOT.F END OF DO LOOP. ENT EBR.F ENDFILE/BACKSPACE/REWIND (SAVE CODE). ENT EIF.F ENDIF. ENT ELS.F ELSE. ENT GTO.F GOTO. ENT IDO.F IMPLIED DO. ENT ILA.F ORDERING OF IMPLIED DO. ENT IOA.F I/O WHOLE ARRAY. ENT IOE.F I/O STATEMENT END. ENT IOMpK.F I/O STATEMENT KEYWORD. ENT IOL.F I/O LIST ITEM. ENT IOS.F I/O STATEMENT START. ENT LIF.F LOGICAL IF. ENT NR.F IMPLIED DO 'RECORD'. ENT PTM.F PROGRAM TERMINATION. (END) ENT RTN.F RETURN. ENT RWE.F READ/WRITE END. ENT STP.F PAUSE & STOP. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT ABB.F SET UP A/B BIT. EXT CAR.F CLEAR ALL REGISTER DATA, INCL EMA INFO. EXT FT.F FIND TYPE. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT GRD.F GET REGISTER DATA. EXT LD.F LOAD. EXT LDA.F LOAD INTO (A). EXT LDB.F LOAD INTO (B). EXT LDF.F LOAD FIRST WORD OF DATA. EXT MIM.F MAP ITEM MODE. EXT PO1.F POP ONE STACK ITEM. EXT PU1.F PUSH ONE STACK ITEM. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION (LOAD TOS). EXT SMT.F STORE MAPPED DATA IN TEMP. EXT SRD.F SET REGISTER DATA. EXT SRS.F SET REGISTER DATA (SHORT FORM). EXT SRT.F STORE REGISTER IN TEMP. EXT ST.F STORE. * * ENTRY POINTS IN SAM.F (SUB & ARRAY MGR) * EXT EA?.F EMA CHECK. * * ENTRY POINTS IN LIBRARIES. * EXT .MVW MOVE WORDS INSTRUCTION. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SKP * ***************** * * PUSH DO STACK * * ***************** SPC 1 PUD.F NOP (A) = DATA TO PUSH. LDB F.T ANYTHING ON STACK 1 ? SZB JMP F.OFE YES. SOMEONE BLEW IT!!! CCB NO. MAKE ROOM. ADB F.D STB F.D STB F.S1B RESET LOCATION OF STACK 1. STB F.S1T STA B,I SAVE DATA. CMB,INB CHECK FOR COLLISION. ADB F.LO ADB F.L (STACK 2 MAY BE OBSOLETE ?) SS+'B JMP PUD.F,I NO. ALL DONE. JMP F.OFE YES. COMPLAIN. SPC 2 * **************** * * POP DO STACK * * **************** SPC 1 POD.F NOP RETURNS (A) = OLD TOS. LDA F.D IF STACK UNDERFLOW, CPA F.DO JMP POD01 JUST RETURN ZERO. * LDA F.D,I ISZ F.D JMP POD.F,I * POD01 CLA STACK UNDERFLOW. BE QUIET ABOUT IT, JMP POD.F,I IT PROBABLY STEMS FROM SOURCE ERROR. SKP * ************** * * ASCII DATA * * ************** SPC 1 CAD.F NOP LDA F.RPL SAVE OLD F.RPL STA T1CAD JSB RD.F GET F.RPL OF DATA. STA F.RPL ORG THERE. JSB OLR.F CCA SET UP LOOP COUNT ADA F.COC (WITHOUT F.RPL WORD) CMA,INA,SZA,RSS NEGATE. ZERO ? JMP CAD02 YES. DONE. STA T2CAD NO. COUNTER. * CAD01 JSB RD.F GET ONE. JSB OW.F OUTPUT IT. B40K OCT 40000 ISZ T2CAD COUNT & LOOP. JMP CAD01 * CAD02 LDA T1CAD RESTORE POSITION. STA F.RPL JSB OLR.F JMP CAD.F,I EXIT. * T1CAD NOP T2CAD NOP SPC 2 * ********************** * * DEFINE STATEMENT # * * ********************** SPC 1 DSN.F NOP JSB RD.F GET THE #. STA F.A SAVE IT. JSB FA.F FETCH ASSIGNS. LDA REL ALREADY DEFINED ? CPA F.AT JMP DSN01 YES. JSB DAT.F NO. DEFINE IT. F.AT=REL. LDB F.NC FORMAT ? CPB B140 (I.E., NC=3) JMP DSN.F,I YES. LEAVE F.AF ALONE. JSB DL.F NO. SET F.AF = F.RPL JMP DSN.F,I & EXIT. DSN01 LDA K27 DOUBLY DEFINED. FIRST DEF HOLDS. JSB WAR.F JMP DSN.F,I EXIT. * B140 OCT 140 SKP * **************** * * PAUSE & STOP * * **************** SPC 1 STP.F NOP JSB RD.F /(A) = F.A OF OCTAL CONSTANT. LDB A GO DO LOAD. JSB LD.F LDA F.COP (A)=23 FOR STOP, 24 FOR PAUSE. LDB .PAUS OFFSET FOR PAUSE. SLA WHICH ? LDB .STOP STOP. GET OFFSET. JSB ODF.F OUTPUT 'JSB .PAUS' OR 'JSB .STOP' JSB CAR.F ZAP REGISTER DATA. JMP STP.F,I EXIT. SPC 2 * ******************************************** * * SAVE CODE FOR ENDFILE, BACKSPACE, REWIND * * ******************************************** SPC 1 EBR.F NOP JSB RD.F READ CODE: -1/0/+1. STA T1EBR AND SAVE IT. JMP EBR.F,I EXIT. * T1EBR NOP XMIT CODE FROM EBR.F TO IOEB1. K27 DEC 27 .PAUS ABS 80 .STOP ABS 81 SKP * *********************** * * PROGRAM TERMINATION * * *********************** SPC 1 PTM.F NOP LDB F.SFF BLOCK DATA ? CPB K2 JMP PTM.F,I YES. NO CODE. * LDA CLAI 'CLA' JSB OAI.F LDB .EXIT 'JSB .EXIT' JSB ODF.F JMP PTM.F,I EXIT. SPC 2 * ********** * * RETURN * * ********** SPC 1 RTN.F NOP LDB F.SFF SUBROUTINE OR FUNCTION ? SZB,RSS JMP RTN01 SUBROUTINE. GO LOAD RTN #. * LDA JMPI FUNCTION. IF NOT FIRST RETURN, CPB K1 (I.E., F.SFF#1) RSS JMP RTN04 THEN JUST JMP TO FIRST RETURN (F.SFF) * LDA F.RPL ELSE NOTE LOCATION OF THIS CODE, STA F.SFF LDA F.FRF (A)=FINAL RESULT DESTINATION. LDB F.SBF (B)=RESULT SOURCE. SZARS SZA,RSS IN (A,B) OR HIDDEN DUMMY ? JMP RTN02 (A,B). JUST LOAD. * JSB ST.F MEMORY. DO DFER/CFER. JMP RTN03 * RTN01 LDB F.S1T,I SUBROUTINE. GET RETURN VALUE. JSB CFC.F CONSTANT ? CLA,INA IF NOT, USE 1 FOR ERROR CHECKING. CMA,SSA,INA,RSS IS RETURN VALUE NEGATIVE CONSTANT ? JMP RTN1A YES. WARN HIM. * ADA F.NAR (MAX VALUE) - (ACTUAL VALUE) SSA,RSS TOO BIG ? JMP RTN1B NO. * RTN1A LDA K12 YES. WARNING. JSB WAR.F * RTN1B LDB F.S1T,I (B) = F.A OF ALT RTN NUMBER. RTN02 JSB LDA.F REGISTER RESULT, LOAD. RTN03 LDA JMPII DO 'JMP ENTRY,I' LDB F.REL ENTRY LOCATION. RTN04 JSB OMR.F ISSUE CODE. JSB CAR.F ZAP REGISTER DATA. JMP RTN.F,I EXIT. * JMPI OCT 26000 JMPII OCT 126000 K12 DEC 12 SKP * ********** * * ASSIGN * * ********** SPC 1 ASP.F NOP JSB CAR.F CLEAR REGISTER DATA, JUST IN CASE. JSB RD.F GET STMT # F.A. LDB A SET UP DEF. CLAI CLA JSB ESD.F LDA F.A SAVE F.A FOR LATER. STA T1ASP JSB RD.F GET VARIABLE F.A. STA F.A MAP IT IN IF IN EMA. JSB MAP.F (MAY USE (B), BUT (A) FREE) STA T2ASP SAVE FOR THE STORE. LDA LDAI LOAD THE DEF. LDB T1ASP JSB SOA.F LDA STAI STORE IN VARIABLE. LDB T2ASP JSB SOA.F JSB CAR.F ZAP REGISTER DATA. JMP ASP.F,I EXIT. * T1ASP NOP T2ASP NOP SKP * ******************** * * 2-WAY & 3-WAY IF * * ******************** SPC 1 * COPY STATEMENT #'S. * AIF.F NOP JSB MP1.F MAP RESULT IN, JUST TO BE SAFE. JSB RD.F FIRST, COPY SEQUENCE #. CMA IS COMPLEMENTED IN F.AF OF STMT #'S. STA T0AIF JSB RD.F COPY FIRST STMT #. STA T1AIF JSB RD.F COPY 2ND STMT #. STA T2AIF LDB F.COC 2-WAY OR 3-WAY ? CPB K3 JMP AIF01 2-WAY. * JSB RD.F 3-WAY. COPY 3RD STMT #. STA T3AIF JMP AIF02 GO CHECK TYPE. * AIF01 STA T3AIF 2-WAY. SET 3RD = 2ND. JSB GT1.F CHECK FOR LOGICAL. CPA LOG IFii SO, RSS CPA LO4 OR DOUBLE LOGICAL, JMP AIF03 THEN TYPE IS O.K. * AIF02 JSB GT1.F 3-WAY OR 2-WAY, NOT LOGICAL. JSB MIM.F MUST BE NUMERIC TYPE. (I.E. E=0) LDB F.IM BUT NOT COMPLEX. LDA K61 OTHERWISE, WARNING 61. SEZ,RSS WELL ? (SKIP IF NON-NUMERIC) CPB CPX RSS CPB ZPX JSB WAR.F ONE OR OTHER, WARNING. * * CHECK FOR REDUNDANCY, DOUBLE INTEGER. * AIF03 LDA T3AIF 2=3 ? CPA T2AIF IF SO, THEN JUST SIGN TEST. JMP AIF14 YES. EASY FOR DOUBLE INTEGER TOO. * LDB F.IM DOUBLE INTEGER ? CPB DBI JMP AIF20 YES. HARDER. * LDB F.S1T,I NO. ONLY NEED FIRST WORD THEN. JSB LDF.F LDB T1AIF 1=2 ? CPB T2AIF JMP AIF06 YES. DO THAT. * CPB T3AIF 1=3 ? JMP AIF05 YES: SZA / JMP3 / JMP2 SKP * NO REDUNDANCY: SSA / JMP1 / SZA / JMP3 / JMP2 * JSB JNS.F 1=NEXT ? JMP AIF11 YES. * LDA SSAI 'SSA' JSB ORI.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F AIF05 LDB T3AIF 3RD = NEXT ? JSB JNS.F JMP AIF08 YES. * LDA SZAI NO. 'SZA' JMP AIF07 * AIF06 LDA KK03 1=2, DO 'CMA,SSA,INA,SZA' AIF07 JSB ORI.F LDA JMPI 'JMP 3' LDB T3AIF JSB SOA.F JMP AIF09 GO DO 'JMP 2' * AIF08 LDA SZARS 3=NEXT. 'SZA,RSS' JSB ORI.F AIF09 LDB T2AIF 'JMP 2' AIF9A JSB JNS.F IS THAT THE NEXT STATEMENT ? JMP AIF12 YES. DON'T DO IT. * AIF10 LDA JMPI YES. JUMP. JSB SOA.F AIF12 JSB CAR.F ZAP REGISTER DATA. JMP AIF.F,I DONE. * * 1=NEXT, 2#3: SZA,RSS / JMP2 / SSA,RSS / JMP3 * AIF11 LDA SZARS 'SZA,RSS' JSB ORI.F LDA JMPI 'JMP 2' LDB T2AIF JSB SOA.F LDA SSARS 'SSA,RSS'  JSB ORI.F LDB T3AIF 'JMP 3' JMP AIF10 SKP * 2=3: SSA / JMP1 / JMP 2=3 * AIF14 CPA T1AIF 1=2=3 ? JMP AIF09 YES. GO THERE. * LDB F.S1T,I NO. LOAD UP FIRST WORD. JSB LDF.F LDB T1AIF IS 1=NEXT ? JSB JNS.F (SAME TRICK AS ABOVE) JMP AIF15 YES. * LDA SSAI NO. 'SSA' JSB ORI.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F JMP AIF09 DO OPTIONAL 'JMP 2' * AIF15 LDA SSARS 1=NEXT. 'SSA,RSS' JSB ORI.F JMP AIF09 THEN OPTIONAL 'JMP 2' * * DOUBLE INTEGER. * AIF20 JSB SCG.F LOAD BOTH WORDS OF DOUBLE INTEGER. LDB T1AIF 1=3 ? CPB T3AIF JMP AIF24 YES: SZA,RSS / SZB / JMP 1=3 / JMP 2 * LDB T2AIF NO. 2=NEXT ? JSB JNS.F JMP AIF22 YES. * * USING .DCO * LDB .DCO 'JSB .DCO' JSB ODF.F CLA SET UP DOUBLE INTEGER ZERO. STA F.IDI STA F.IDI+1 LDA DBI JSB ESC.F JSB AI.F CLA 'DEF =J0' JSB OA.F LDA JMPI 'JMP 2' LDB T2AIF JSB SOA.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F LDB T3AIF 'JMP 3' JMP AIF9A BUT NOT IF IT'S TO NEXT STMT. SKP * DOUBLE INTEGER SKIPPING ON A & B. * AIF22 LDA SSAI 2=NEXT. 'SSA' JSB OAI.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F AIF24 LDA SZBRS 1=3. 'SZB,RSS' JSB OAI.F LDA SZAI 'SZA' (NOTE: F.RES=0 HERE FOR ORI.F) JMP AIF07 AND 'JMP 3' AND OPTIONAL 'JMP 2'. SPC 2 T0AIF NOP T1AIF NOP T2AIF NOP T3AIF NOP KK03 CMA,SSA,INA,SZA SKIP IF <= 0. K61 DEC 61 SSAI SSA SPC 2 * ************************************* * * TEST IF JUMP IS TO NEXT STATEMENT * * ****BK********************************* SPC 1 * ENTRY: (B) = F.A OF JUMP TARGET (STMT #). * T0AIF = COMPLEMENT OF CURRENT SEQUENCE #. * EXIT: (B) PRESERVED. * (A) DESTROYED. * SKIP IF NOT NEXT STATEMENT. SPC 1 JNS.F NOP LDA B GET F.AF OF STMT #. INA LDA A,I CPA T0AIF SAME AS COMPL SEQ # ? RSS YES. GOT ONE. ISZ JNS.F NO. PROBABLY MUST JUMP THERE. JMP JNS.F,I EXIT. SKP * ************** * * LOGICAL IF * * ************** SPC 1 LIF.F NOP JSB MP1.F MAP IT IN, JUST TO BE SAFE. JSB GT1.F GET RESULT TYPE. LDB A IS IT LOGICAL ? LDA K62 CPB LOG RSS CPB LO4 OR DOUBLE LOGICAL ? RSSI RSS JSB WAR.F NO, WARNING. JSB RD.F GET SEQ #. INA BUMP IT TO MATCH TRUE BRANCH SEQ #. CMA SET UP FOR JNS.F TO USE. STA T0AIF JSB RD.F GET F.A OF TWPE ENTRY. STA T1AIF SAVE IT. LDB F.S1T,I LOAD FIRST WORD OF DATA. JSB LDF.F DLD T1AIF,I (B) = F.AF OF TWPE ENTRY. LDA SSARS ('SSA,RSS' IN CASE NOT GOTO) CMB,SSB (IF WAS < 0, IS NOW F.A OF GOTO TARGET) JMP LIF01 NO. VANILLA. JSB JNS.F YES. SEE IF TARGET IS NEXT LINE. JMP LIF02 YES. NO CODE. STB T1AIF NO. SET IT AS JUMP TARGET. LDA SSAI AND ISSUE 'SSA' FIRST. LIF01 JSB ORI.F SKIP. LDA JMPI AND JUMP. LDB T1AIF JSB SOA.F LIF02 JSB CAR.F ZAP REGISTER DATA. JMP LIF.F,I EXIT. * LOG OCT 030000 LO4 OCT 110000 SKP * ******** * * ELSE * * ******** SPC 1 ELS.F NOP JSB RD.F ENDIF TARGET: JUMP THERE. RAL,CLE,ERA (CLEAR SIGN) LDB A LDA JMPI JSB SOA.F JSB RD.F ELSE TARGET: DEFINE IT. RAL,CLE,ERA (CLEAR SIGN) STA F.A JSB DL.F JMP ELS.F,I DONE. SPC 2 * ********* * * ENDIF * * ********* SPC 1 EIF.F NOP JSB RD.F ENDIF TARGET: DEFINE IT. RAL,CLE,ERA STA F.A SZA (MISSING IF NO 'ELSE') JSB DL.F JSB RD.F ELSE TARGET: DEFINE IT. RAL,CLE,ERA STA F.A SZA (MISSING IF 'ELSE' PART) JSB DL.F JMP EIF.F,I EXIT. SKP * **************** * * DO STATEMENT * * **************** SPC 1 DO.F NOP JSB RD.F (F.D+3) = F.A OF INDEX. JSB PUD.F LDA F.RPL (F.D+2) = F.RPL JSB PUD.F LDA F.DFS (F.D+1) = FINAL. JSB PUD.F LDA F.DFS+1 (F.D) = STEP SIZE. JSB PUD.F JMP DO.F,I THAT'S ALL, FOLKS. SPC 2 * ****************** * * DO TERMINATION * * ****************** SPC 1 * JUST SET UP THINGS FROM DO STACK. * DOT.F NOP JSB RD.F T1DO = F.A OF INDEX. STA T1DO JSB RD.F F.A OF TWPE FOR LOOP END. INA SAVE ADDR OF ITS F.AF STA T0DO JSB RD.F 0 IF OUTER, ELSE F.A OF STMT #. LDB F.RPL OUTER LOOPS GET START OF INDEX CODE. DLD A,I IF (A)=F.A, (B)=F.AF; IF (A)=0, NOP. STB T0DO,I DEFINE THE TWPE ENTRY. JSB POD.F F.DFS+1 = STEP SIZE. STA F.DFS+1 JSB POD.F F.DFS = FINAL VALUE. STA F.DFS JSB POD.F T0DO = JUMP TARGET. STA T0DO JSB POD.F GET F.A OF INDEX FROM STACK. CPA T1DO CHECK AGAINST PASS FILE. RSS O.K. JMP DOT01 WRONG. ERROR. * JSB DT.F USE COMMON CODE. JMP DOT.F,I DONE. * DOT01 LDA F.DO PROBLEM ON DO STACK. MUST BE DUE TO STA F.D PREVIOUS ERROR. JUST EXIT QUIETLY, JMP DOT.F,I WITH DO STACK CUT BACK. E SPC 2 * ************************** * * IMPLIED DO TERMINATION * * ************************** SPC 1 * JUST SET UP T0DO & T1DO, OTHERS ARE O.K. * IDO.F NOP JSB RD.F T1DO = F.A OF INDEX. STA T1DO JSB RD.F T0DO = JUMP TARGET. STA T0DO JSB DT.F USE COMMON CODE. JMP IDO.F,I DONE. SPC 2 K62 DEC 62 T0DO NOP T1DO NOP SKP * ************************* * * COMMON DO TERMINATION * * ************************* SPC 1 * FIRST, INCREMENT THE INDEX BY THE STEP. * DT.F NOP JSB CAR.F START WITH NO REGISTERS. LDA F.DFS+1 (A) = STEP SIZE. SZAI SZA DEFAULT ? JMP DT00 NO. * CLA,INA YES. SET UP CONSTANT 1. JSB EIC.F STA F.DFS+1 DT00 JSB PU1.F TOS=INDEX, NEXT=INCR. LDB T1DO GET PRECISION. JSB FT.F CPA DBI DOUBLE ? (INDEX, INCR HAVE SAME TYPE) JMP DT04 YES. DIFFERENT EMA HANDLING. * LDA T1DO SINGLE. PROCEED WITH THE ADD; JSB PU1.F IF THE INDEX HAS TO BE MAPPED IN, JSB ADD.F (B) STAYS INTACT SINCE ADD DONE IN (A). JSB SCG.F (JUST IN CASE ZERO INCR) LDA T1DO SEE IF IT HAD TO BE MAPPED. STA F.A JSB EA?.F JMP DT10 NO. NORMAL. * LDA INT YES. SET UP (B) AS ADDRESS, AGAIN. CLB,CLE BUT DON'T BOTHER WITH EMA. STO JSB SRD.F DEF K1 CLB,INB,RSS NOW USE (B) FOR THE STORE. DT10 LDB T1DO FINALLY, STORE INDEX BACK. LDA STAI JSB SOA.F * * DETERMINE: STEP SIZE: +CONST, VAR, -CONST. * FINAL: CONST, VAR. * LDB F.DFS+1 STEP SIZE. JSB CFC.F CONSTANT ? CLAR CLA,RSS NO. SET T1DO=0. IOR K1 YES. MAKE SURE NON-ZERO. STA T1DO T1DO=0 IF VAR, ELSE HAS SIGN OF CONST. LDB F.DFS (A) = FINAL VALUE. JSB CFC.F CONSTANT ? JMP DT01 NO. SKP * FINAL VALUE IS CONSTANT: NEGATE IT. * LDB T1DO CHECK STEP SIZE. NEGI CMA,INA NORMALLY, JUST NEGATE. CMB,SSB,INB,SZB STEP=+CONST ? ADA KM1 YES. NEGATE & DECREMENT. JSB EIC.F MAKE THE CONSTANT. LDB A GO ADD TO INDEX. CLA CLEAR FINAL=CONST FLAG. JMP DT02 * * FINAL VALUE IS VARIABLE: NEGATE INDEX. * DT01 LDB T1DO CHECK STEP SIZE. LDA NEGI FOR STEP=VAR OR +CONST, NEGATE. SSB BUT FOR -CONST, LDA CMAI NEGATE & DECREMENT. JSB OAI.F LDB F.DFS ADD FINAL VALUE. CCAI CCA SET FINAL=CONST FLAG. DT02 STA F.DFS * * ADD. IF STEP=VAR, DO 'XOR STEP'. * LDA ADAI JSB SOA.F LDA T1DO WELL ? SZA JMP DT03 NO. LDA XORI YES. LDB F.DFS+1 JSB SOA.F * * ISSUE THE SKIP. DO 'CPA STEP' IF STEP=VAR. * DT03 LDA SSAI DEFAULT IS 'SSA'. LDB T1DO STEP=+CON ? CMB,SSB,INB,SZB XOR K1 YES, CHANGE TO 'SSA,RSS' ISZ F.DFS FINAL=CONST ? XOR K1 YES, CHANGE TO OTHER. JSB OAI.F ISSUE SKIP. * LDA T1DO STEP=VAR ? SZA JMP DT08 NO. LDA CPAI YES. DO 'CPA STEP' LDB F.DFS+1 JSB SOA.F JMP DT08 SKP * DOUBLE INTEGER INDEX. * DT04 LDA T1DO IF EMA, MAP IT IN NOW. STA F.A JSB MAP.F JSB PU1.F PUT THE F.A ON THE STACK, JSB SBR.F AND IF EMA, SAVE THE ADDRESS. LDB F.S1T,I NOW COPY THE TOS ENTRY, STB T1DO WHICH IS F.A OF INDEX OR ADDR TEMP. JSB ADD.F ADD INCREMENT, JSB SCG.F AND MAKE SURE LOADED, EVEN IF INCR=0. LDB T1DO ( NOW MUST FIX UP ADDR TEMP IF EMA. LDA B,I SEE WHICH: AND B170K GET F.IM OF THE ITEM. CPA ADDR IF ADDR TEMP, RSS (YES) JMP DT09 NO. LEAVE ALONE. * LDA DBI YES. RESTORE THE TYPE OF THE TEMP, INB STA B,I SINCE WE ARE RE-USING AFTER A DEF. DT09 CLB STORE BACK. SINCE THE EMA ADDRESS LDA T1DO IS IN AN ADDR TEMP, NO OTHER TRICKS JSB ST.F REQUIRED TO RE-USE IT HERE. * * THEN USE .DCO . * LDB .DCO DO 'JSB .DCO' JSB ODF.F CLA AND 'DEF FINAL' LDB F.DFS JSB SOA.F LDB T0DO ALWAYS LOOP ON '='. LDA JMPI JSB OMR.F LDB F.DFS+1 IS STEP CONSTANT ? JSB CFC.F JMP DT06 NO. * SSA,RSS YES. + OR - ? JMP DT08 +, JUST ONE MORE JUMP TO TOP. * LDA RSSI -. 'RSS' FIRST. JMP DT07 * DT06 LDA CLAR VARIABLE. 'CLA,RSS' JSB OAI.F LDA CCAI THEN 'CCA' JSB OAI.F LDA XORI THEN 'XOR STEP' LDB F.DFS+1 JSB SOA.F LDA SSARS AND FINALLY, 'SSA,RSS'. DT07 JSB OAI.F * * ISSUE JUMP TO TOP OF LOOP. EXIT. * DT08 LDB T0DO (B) = SAVED F.RPL. LDA JMPI JSB OMR.F JSB CAR.F ZAP REGISTER DATA. JMP DT.F,I DONE. * CPAI OCT 52000 XORI OCT 22000 ADAI OCT 42000 LDAI OCT 62000 STAI OCT 72000 .DCO ABS 29 B170K OCT 170000 MASK FOR F.IM ADDR OCT 70000 F.IM=ADDR KM1 DEC -1 K3 DEC 3 SKP * *************** * * SIMPLE GOTO * * *************** SPC 1 GTO.F NOP JSB RD.F (A) = SEQ # OF GOTO. CMAI CMA SET UP T0AIF FOR JNS.F TEST. STA T0AIF JSB RD.F (A) = F.A OF TARGET STMT #. LDB A IS IT NEXT STATEMENT ? JSB JNS.F JMP GTO.F,I YES, NO CODE. hLDA JMPI ISSUE JUMP. JSB SOA.F JMP GTO.F,I EXIT. SPC 2 * ***************** * * ASSIGNED GOTO * * ***************** SPC 1 AGT.F NOP JSB RD.F GET VARIABLE F.A STA F.A JSB RD.F GET # ITEMS IN LIST. ADA F.T JUST THROW AWAY. STA F.T ADA F.S1B STA F.S1T INA STA F.S1N JSB FA.F FETCH ASSIGNS ON VAR. JSB MAP.F MAP IN IF EMA. STB F.RES SAVE IN CASE LOAD NOT DONE. LDA F.AT IF DUMMY OR CPA DUM RSS CPB K1 IN EMA, THEN JSB LD.F LOAD. F.RES = RESULT F.A LDA JMPII NOW ISSUE THE JUMP. LDB F.RES THRU THIS LOCATION. JSB SOA.F JSB CAR.F ZAP REGISTER DATA. JMP AGT.F,I DONE. * DUM OCT 5000 SKP * ***************** * * COMPUTED GOTO * * ***************** SPC 1 * DECIDE BETWEEN IN-LINE & .GOTO * CGT.F NOP JSB MP1.F MAP INDEX IN, JUST IN CASE. JSB RD.F GET SEQUENCE COUNTER. CMA SET UP FOR JNS.F STA T0AIF JSB RD.F GET LENGTH OF BRANCH LIST. STA T3GTO SAVE FOR EXIT. CMA,INA SAVE AS COUNTER. STA T2GTO LDB T3GTO SET UP PTR INTO STACK 1. ADB F.S1T (IT RUNS BACKWARDS) STB T1GTO (NOTE: STACK 1 ONLY MOVES AT 'DO') LDA INT CONVERT INDEX TO INTEGER. JSB CTS.F JSB PO1.F (A) = F.A OF INDEX. STA F.A SAVE IT. LDB A BRS REGISTER IFF B=0. LDA T2GTO - (# STMT NUMBERS) ADA K2 ONE OR TWO ITEMS ? SSARS SSA,RSS JMP CGT01 YES. GENERATE IN-LINE CODE. KK04 INA,SZA,RSS THREE AND VALUE IN REG ? SZB JMP CGT03 NO. USE '.GOTO' * * IN-LINE: * CMA,SSA,INA,SZA / (N-1)*(INA,SZA,RSS/JMP K) / JMP N. ? * CGT01 CPA K1 ONLY ONE STMT # ? (IT WORKS) JMP CGT06 YES. JUST JUMP. ISZ T2GTO (ONLY OUTPUT N-1 JUMPS NOW.) LDB F.A LOAD IF NOT ALREADY IN REG. JSB LD.F LDA KK03 'CMA,SSA,INA,SZA' (OR B) JSB ORI.F I.E., NEGATE & SKIP IF > 0. CGT02 LDA KK04 'INA,SZA,RSS' (OR B) JSB ORI.F LDB T1GTO,I 'JMP STMT' LDA JMPI JSB SOA.F CCB MOVE STACK PTR. ADB T1GTO STB T1GTO ISZ T2GTO LOOP THRU ALL. JMP CGT02 JMP CGT06 LAST JUMP, POP STACK & EXIT. * * USING '.GOTO' * CGT03 JSB SBR.F SAVE REGISTERS. LDB .GOTO OUTPUT 'JSB .GOTO' JSB ODF.F LDB T3GTO N = # STMTS. ADB K2 # STMTS + 2. JSB OZ.F OUTPUT 'DEF *+N+2' CLA OUTPUT 'DEF INDEX' LDB F.A (NOTE: THE (A) REGISTER IS NOT STORED, JSB SOA.F SO .GOTO MUST HANDLE 'DEF 0' RIGHT.) CGT05 LDB T1GTO,I OUTPUT THE DEFS. CLA JSB ESD.F JSB PDF.F CCB MOVE STACK PTR. ADB T1GTO STB T1GTO ISZ T2GTO LOOP THRU ALL. JMP CGT05 JMP CGT07 GO POP STACK & EXIT. * * OUTPUT LAST JUMP, POP STACK & EXIT. * CGT06 LDB T1GTO,I F.A OF IT. JSB JNS.F NEXT LINE ? JMP CGT07 YES. SKIP IT. LDA JMPI NO. DO JUMP. JSB SOA.F CGT07 LDA T3GTO CUT STACK BACK. ADA F.T STA F.T ADA F.S1B STA F.S1B INA STA F.S1N JSB CAR.F ZAP REGISTER DATA. JMP CGT.F,I DONE. SPC 1 T1GTO NOP T2GTO NOP T3GTO NOP .GOTO ABS 76 SKP * *********************** * * START I/O STATEMENT * * *********************** SPC 1 IOS.F NOP JSB RD.F GET STATEMENT TYPE. STA T1IOS CLA CLEAR OUT KEYWORD VALUE TABLE. STA KWVT xj LDA DKWVT INA LDB A INB JSB .MVW DEF K33 28 KEYWORDS, 6 MISC VALUES. NOP (TOTAL = 34, 33 ADDITIONAL) JSB ITN.F INITIALIZE TEMPS. (INHIBITED IN EXPR) JMP IOS.F,I THAT'S ALL FOR NOW. * T1IOS NOP I/O STATEMENT TYPE. SKP * *************** * * I/O KEYWORD * * *************** SPC 1 IOK.F NOP JSB RD.F GET KEYWORD # AND WHOLE ITEM FLAG. STA T1IOK SAVE. CLA,INA IS VALUE ON STACK ? CPA F.COC JMP IOK01 YES. DO THAT. * JSB RD.F NO. GET F.A OF VALUE. SZA,RSS IS IT '*' FORMAT ? JMP IOK03 YES. SKIP EMA CHECK TOO. * JSB PU1.F NO. PUT IT ON STACK. IOK01 LDA F.S1T,I IS ITEM IN EMA ? STA F.A (FOR EA?.F) JSB EA?.F EMA ? (A) PRESERVED. JMP IOK02 NO. * LDB T1IOS YES. READ/WRITE ? SZB CPB K1 RSS JMP IOK09 NO. ERROR. * LDB T1IOK YES. UNIT # ? RBL,CLE,ERB CPB K.UNT JMP IOK04 YES. O.K. FOR BACKWARDS COMPAT. * IOK09 LDA K48 OTHERWISE, JSB ER.F ERROR. * IOK04 JSB PO1.F EMA UNIT #, MAP IT. JSB MAP.F MAKE SURE THAT F.ACM IS UPDATED. JSB PU1.F * IOK02 JSB SMT.F FREE UP THE MAPS. (DATA TO TEMPS) JSB SBR.F SAVE BOTH REGISTERS. JSB PO1.F POP THE ITEM OFF THE STACK. (TO (A)). STA T2IOK SAVE THE ITEM F.A, AND LDA A,I SEE IF CHAR TEMP. AND KK05 F.IM & F.IU & F.NT CPA KK06 F.IM=CHAR, F.IU=VAR, F.NT=0 ? RSS (YES) JMP IOK05 NO. NOT CHAR TEMP. * LDA T2IOK YES. CHAR TEMP OR VAR. WHICH ? ADA K2 LDA A,I SSA,RSS JMP IOK05 VAR. LEAVE IT. * DLD T2IOK,I TEMP. (B) = EXTENSION ADDR. LDB B,I (B) = ADDR DESCRIPTOR / ITEM,I RBL,CLE,SLB,ERB IS IT SPECIAL ITEM,I ENTRY ? RSS (YES) JMP IOK05 NO. LEAVE IT. * LDA T1IOK YES. IS IT FORMAT ? RAL,CLE,ERA CPA K.FMT RSS (YES) JMP IOK08 NO. ORDINARY. * LDA B,I FORMAT. SEE IF ARRAY OR VAR. AND B600 CPA VAR IF VAR, RSS (YES) JMP IOK08 NO: THEN NORMAL FAKED STRING. * STB T3IOK THEN ASSIGN'ED FORMAT VARIABLE. DLD T2IOK,I (B)=ADDR DESCRIPTOR. INB SET LENGTH TO MAX. LDA BMAX STA B,I LDA LDAI SET UP LOAD. LDB T3IOK JMP IOK10 GO LOAD THE ADDRESS & FORMAT IT. * IOK08 LDA B,I GET ADDRESS TYPE OF ITEM. IOR B10 (MARK THE ITEM USED) STA B,I AND B7000 CPA BCOM IF LABELLED COMMON, JMP IOK06 CPA DUM OR FORMAL, RSS THEN SPECIAL PROCESSING. JMP IOK05 ELSE LEAVE IT. * LDA LDAII FORMAL. DO 'LDA ITEM', STB T3IOK (SAVE F.A OF FORMAL) IOK10 JSB SOA.F LOAD ITS ADDRESS. LDA CLELA SHIFT. JSB OAI.F LDB T2IOK STORE IN DESCRIPTOR. CLA,INA (SET OFFSET = 1 TO GET STA F.C TO 2ND WD OR DESCRIPTOR) LDA STAI JSB SOA.F LDA T3IOK RESTORE F.A TO DUMMY. STA F.A JSB FA.F FETCH ASSIGNS. LDA F.IU IF ARRAY, LDB F.VDM WITH VARIABLE DIMENSIONS, CPA ARR SZBRS SZB,RSS JMP IOK05 NO. DONE WITH DUMMY. * JSB CVA.F YES. CALCULATE ARRAY SIZE. JSB SCG.F MAKE SURE IT'S IN A REGISTER. LDA CLELA SHIFT TO GET # CHARS. JSB ORI.F JSB ABB.F GET A/B BIT. IOR STAI SET STA/STB. LDB T2IOK STORE LENGTH IN 1ST WD. JSB SOA.F JMP IOK05 DONE. * IOK06 CLA LABELLED COMMON. SET UP DEF. JSB ESD.F LDA LDAI AND LOAD IT. JSB :(OA.F LDA CLELA 'CLE,ELA' JSB OAI.F TO MAKE BYTE ADDR. LDB T2IOK STORE IN DESCRIPTOR. CLA,INA (IN 2ND WORD) STA F.C LDA STAI JSB SOA.F IOK05 LDA T2IOK (A) = ITEM F.A (AGAIN). IOK03 LDB T1IOK WHOLE ITEM BIT & KEYWORD ORDINAL. RBL,CLE,ERB COPY BIT TO (E) & CLEAR. RAL,ERA PUT WHOLE ITEM BIT ON ITEM. ADB DKWVT ADDR IN TABLE. STA B,I PUT KEYWORD VALUE IN TABLE. JMP IOK.F,I DONE. * T1IOK NOP WHOLE ITEM BIT & KEYWORD ORDINAL. T2IOK NOP SAVED F.A OF ITEM. T3IOK NOP SAVED F.A OF DUMMIED CHAR ITEM. KK05 OCT 170601 F.IM & F.IU & F.NT KK06 OCT 130400 F.IM=CHAR, F.IU=VAR, F.NT=0. LDAII OCT 162000 B600 OCT 600 F.IU MASK. ARR EQU B600 F.IU=ARR. VAR OCT 400 F.IU=VAR. CLELA CLE,ELA B7000 OCT 7000 F.AT MASK. BMAX OCT 77777 MAX POS INT. SKP * ********************* * * I/O STATEMENT END * * ********************* SPC 1 * DEFAULT 'IOSTAT' IF NECESSARY. * IOE.F NOP LDA V.IOS IS IOSTAT PRESENT ? SZA JMP IOE02 YES. * LDA F.IOT IOSTAT TEMP EXISTS ? SZA JMP IOE01 YES. * LDA INT NO. CREATE ONE. JSB APT.F STA F.IOT AND SAVE FOR NEXT TIME. IOE01 LDA F.IOT SET IOSTAT TO THE TEMP. STA V.IOS * * START BY SCANNING APPROPRIATE TEMPLATE AND: * 1) CHECKING TYPES, CONVERTING IF REQ'D. * 2) COUNTING # OF PARAMS TO BE ISSUED. * 3) ACCUMULATING BIT VECTOR. * IOE02 LDA DSTTP ADDR OF TABLE OF POINTERS. ADA T1IOS ORDINAL OF STMT. LDA A,I ADDR OF TEMPLATE. STA T1IOE WILL RE-USE THIS ONE. STA T2IOE THIS ONE FOR LOOPING. CLA ZERO OUT COUNT & BIT VECTOR. STA T3IOE STA T4IOE  STA T6IOE AND SPECIAL NEXTREC INFO. STA T7IOE AND SPECIAL MAXREC INFO.. * IOE04 LDA T2IOE,I NEXT TEMPLATE WORD. SZA,RSS DONE ? JMP IOE20 YES. * AND B77 KEYWORD ORDINAL. ADA DKWVT GET VALUE F.A STA T5IOE (SAVE ITS ADDR) LDA A,I CMA,CLE,INA E=1 IFF DOESN'T EXIST. DLD T2IOE,I LDA B (A) = 2ND WORD. LDB T2IOE,I BLF,BLF B<15> = BIT 7 OF DESCRIPTION. SEZ,RSS EXISTS ? JMP IOE06 YES. * SSB BIT 7: 0=DEFAULT, 1=LEAVE OUT. JMP IOE18 LEAVE OUT. DON'T COUNT EITHER. * CPA B100K SPECIAL CASE: IF VALUE = 100000B, JMP IOE05 THEN SET UP TO GENERATE 'NOP' LATER. * STA F.IDI ELSE SET UP VALUE. LDA K2 SET F.CSL=2, JUST IN CASE. STA F.CSL LDA T2IOE,I GET TYPE. AND B170K JSB ESC.F SET UP CONSTANT. JSB AI.F LDA F.A (A) = CONSTANT F.A IOE05 STA T5IOE,I INSERT IN TABLE. JMP IOE17 SKIP OTHER CHECKS. * IOE06 SSB,RSS EXISTS. BIT VECTOR ? JMP IOE07 NO. * IOR T4IOE YES. ADD NEW BIT. STA T4IOE * IOE07 LDB T5IOE,I F.A OF VALUE. RBL,CLE,ERB (CLEAR SIGN) JSB FT.F LDB A (B) = ACTUAL TYPE. LDA T2IOE,I GET EXPECTED TYPE. AND B170K SZA IF ANY TYPE O.K., (ZBUF) CPA B OR RIGHT TYPE, JMP IOE17 THEN DONE. * CPA INT INTEGER*2 EXPECTED, JMP IOE11 CPA DBI INTEGER*4, JMP IOE13 CPA LOG LOGICAL*2, JMP IOE15 * IOE16 LDA K26 WARNING 26: INT EXPECTED. JSB WAR.F JMP IOE17 * IOE15 CPB LO4 SHOULD BE LOGICAL*2, JMP IOE17 LOGICAL*4 IS O.K. AS IS. JMP IOE16 ELSE WARNING. * IOE11 CPB DBI SHOULD BE INT*2, IS IT INT*4 ? RSS JMP IOE16 NO. WARNING. * 5LDA T2IOE,I YES. O.K.; CONVERT NOW OR LATER ? ALF,ALF (TEST BIT 8) SLA IF 0, DO IT NOW. JMP IOE17 ELSE LATER. * IOE12 LDA T5IOE,I CONVERT DBI <==> INT. RAL,CLE,ERA (CLEAR SIGN) JSB PU1.F LDA T2IOE,I GET EXPECTED TYPE. AND B170K JSB CTS.F CONVERT. JSB SBR.F JSB PO1.F STA T5IOE,I JMP IOE17 NOW IT'S O.K. * IOE13 CPB INT SHOULD BE INT*4, IS IT INT*2 ? RSS JMP IOE16 NO. WARNING. * LDA T2IOE,I CHECK IF VALUE/RESULT. ALF,ALF (BIT 8) SLA,RSS 0=VALUE, 1=RESULT. JMP IOE12 VALUE. CONVERT AHEAD OF TIME. * LDB T5IOE,I RESULT: NEXTREC OR MAXREC IN INQUIRE. RBL,CLE,ERB (CLEAR SIGN) LDA T2IOE,I GET KEYWORD ORDINAL. AND B77 THESE ARE SPECIAL CASES WHERE A TEMP CPA K.NXR IS REQUIRED BECAUSE THE RESULT INQUIRE STB T6IOE (NEXTREC) STORES IS BIGGER THAN THE CPA K.MXR VARIABLE SPECIFIED FOR IT. STB T7IOE (MAXREC) LDA DBI ALLOCATE DBI TEMP FOR NOW. JSB ATC.F STA T5IOE,I AND PUT THE RESULT THERE. * IOE17 ISZ T3IOE COUNT THE PARAM. IOE18 ISZ T2IOE ADVANCE IN TABLE. ISZ T2IOE JMP IOE04 GO PROCESS NEXT ENTRY. * T1IOE NOP ADDR OF TEMPLATE TABLE, THIS STMT. T2IOE NOP POINTER INTO TEMPLATE TABLE. T3IOE NOP PARAM COUNT. T4IOE NOP BIT VECTOR.. T5IOE NOP ADDR OF CURRENT KEYWORD VALUE F.A T6IOE NOP SAVED 'NEXTREC' F.A WHEN INT*2 USED. T7IOE NOP SAVED 'MAXREC' F.A WHEN INT*2 USED. F.IOT DEC 0 F.A OF IOSTAT TEMP. K26 DEC 26 K33 DEC 33 K48 DEC 48 B77 OCT 77 .IOOP ABS 92 .IOCL ABS 93 .IOIN ABS 94 .IOCN ABS 95 .EXIT ABS 260 LDBI OCT 66000 SKP * SET UP VALUE OF BIT VECTOR. * IOE20 LDA V.BVT BIT VECTOR USED ? SZA,RSS (I>F SO, DEFAULT=0 SET UP) JMP IOE22 NO. * LDA T4IOE YES. SET IT UP. JSB EIC.F STA V.BVT * * EXECUTE STATEMENT-SPECIFIC CODE. * IOE22 LDA T1IOS STATEMENT TYPE. ADA DSJT1 JUST USE JUMP TABLE. LDA A,I JMP A,I * DSJT1 DEF *+1 DEF IOER1 READ DEF IOER1 WRITE DEF IOEO1 OPEN DEF IOEC1 CLOSE DEF IOEI1 INQUIRE DEF IOEB1 BACKSPACE/ENDFILE/REWIND. * IOEB1 LDA T1EBR -1/0/+1 CODE. JSB EIC.F FORM CONSTANT, LDB A (B) = ITS F.A, JSB LDA.F THEN CCA/CLA/CLA,INA LDB .IOCN BACKSPACE ENDFILE REWIND: .IOCN RSS * IOEO1 LDB .IOOP OPEN: .IOOP RSS * IOEC1 LDB .IOCL CLOSE: .IOCL RSS * IOEI1 LDB .IOIN INQUIRE: .IOIN JSB ODF.F 'JSB XXXXX' LDB T3IOE (A=0) INB # PARAMS + 1 JSB OZ.F 'DEF *+N+1' JMP IOE30 PRODUCE THE PARAMS. SKP * START OF READ OR WRITE. * IOER1 LDB V.RCL IS 'RECL' SUPPLIED ? SZB,RSS JMP IOER3 NO. NORMAL READ/WRITE. * JSB CFC.F YES. ENCODE/DECODE. CONSTANT ? JMP IOER5 NO. GO COPY TO STRING DESCR. * LDB V.SDS YES. INSERT INTO A.T. ENTRY INB FOR STRING DESCRIPTOR. LDB B,I ADDR OF EXTENSION. INB STA B,I 2ND WD OF EXTENSION = LENGTH. JMP IOER6 * IOER5 LDA LDAI COPY LENGTH TO STRING DESCRIPTOR. JSB SOA.F 'LDA LENGTH' LDA STAI LDB V.SDS JSB SOA.F 'STA DESCRIPTOR' * IOER6 LDA B40K SET ALEN = # RECORDS = 16384. JSB EIC.F STA V.ALN JMP IOER4 SKIP UNIT # LOAD. * IOER3 LDA V.UNT UNIT # SUPPLIED ? RAL,CLE,ERA (REMOVE SIGN BIT) SZA JMP IOER2 YES. GO LOAD IT. * LDA T1IOS NO. GET READ/WRITE FLAG. LDB .FSIU PICK Ap DOT FUNCTION ORDINAL. SZA READ=0, .FSIU LDB .FSOU PRINT=1, .FSOU LDA LDAI LOAD IT INTO (A). JSB OID.F JMP IOER4 DONE WITH STD-UNIT. SKIP OTHER. * IOER2 JSB PU1.F EXPLICIT UNIT #. CONVERT TO INT*2. LDA INT JSB CTS.F JSB PO1.F LDB A JSB LDA.F * * LOAD THE BIT VECTOR INTO (B). SEE IF FORMATTED. * IOER4 LDB V.FMT BUT FIRST, SET CHAR FORMAT BIT. RBL,CLE,ERB CHECK TO SEE IF FORMAT IS TYPE CHAR. SZB,RSS IF NO FORMAT, JMP IOER7 THEN NOT CHAR. * STB F.A GET ASSIGNS. JSB FA.F LDB F.IM (B) = FORMAT TYPE. CPB CHAR CHAR ? JMP IOER8 YES. * LDA F.IU NO. VARIABLE ? CPA VAR RSS (YES) JMP IOER7 NO. ARRAY OR STATEMENT #. * LDA F.AT YES. FORMAL PARAM ? CPA DUM RSS (YES) JMP IOER7 NO. CAN USE INDIRECT. * LDB F.A YES. ASSIGN'D FMT IN FORMAL PARAM. JSB LDB.F LOAD INTO (B), JSB GRD.F CHANGE TO AN ADDRESS, DEF K1 STO JSB SRD.F DEF K1 JSB SRT.F AND SAVE IN TEMP. DEF K1 LDA F.A NOW REPLACE THE FORMAT F.A STA V.FMT WITH THAT OF THE TEMP (WILL BE INLINE). * IOER7 CLA,CCE,RSS NOT CHAR. (A,E)=1. IOER8 CLA,CCE,INA CHAR. (A,E)=3. ELA (A) = 3 OR 1. XOR T1IOS BIT 0 = 1 FOR READ, 0 FOR WRITE. IOR T4IOE ADD REST OF BIT VECTOR. JSB EIC.F FORM CONSTANT, LDA LDBI AND LOAD IT JSB OA.F INTO (B). CLA (SET UP T1NR=0) STA T1NR LDA F.RPL (SET UP T2NR=F.RPL) STA T2NR * LDB V.FMT FORMAT INDICATOR. SZB,RSS BINARY ? (NO FORMAT) JMP RWS03 YES. * * FORMATTED. * RBL,CLE,ERB (CLEAR SIGN) SZB,RSS LIST-DIRtECTED ? JMP RWS01 YES. * STB F.A NO. SAVE FORMAT F.A FOR LATER. LDB .EIO. 'JSB .EIO.' JSB ODF.F JSB FA.F FETCH ASSIGNS FOR FORMAT. LDA F.IM IF TYPE INTEGER (AS OPPOSED TO CPA INT CHARACTER, ADDRESS OR STMT #) RSS CPA DBI CLA,CCE,RSS (A=0, E=1) JMP IOER9 (NO) * LDB F.IU AND SIMPLE VARIABLE, CPB VAR ERA,SLA THEN A=100000: DEF VAR,I IOER9 CLA ELSE A=0: DEF ARR/FMT/CHAR DES/* JSB OA.F JMP RWS02 * RWS01 LDB .FIO. 'JSB .FIO.' JSB ODF.F JMP RWS02 * * BINARY. * RWS03 LDB .BIO. ISSUE 'JSB .BIO.' JSB ODF.F RWS02 LDA TWPE FORM TWPE ENTRY FOR 'DEF END' JSB ESC.F JSB AI.F LDA F.A REMEMBER IT. STA T1RWS JMP IOE30 AND GO ISSUE REST OF PARAMS. * CHAR OCT 130000 F.IM = CHAR. .FSIU DEC 84 DOT ORDINAL OF STANDARD INPUT. .FSOU DEC 85 DOT ORDINAL OF STANDARD OUTPUT. SKP * OUTPUT DEF'S TO PARAMS. * IOE30 JSB CAR.F FIRST, VOID ANY REGISTERS. LDA T1IOE SET UP LOOP. STA T2IOE IOE32 LDA T2IOE,I TABLE ENTRY. SZA,RSS DONE ? JMP IOE34 YES. * AND B77 NO. GET ORDINAL. ADA DKWVT INDEX INTO TABLE, LDB A,I AND GET F.A OF VALUE. CPB B100K IF SPECIAL CASE, JMP IOE33 GO DO 'NOP' * ISZ F.NIT (INHIBIT INLINE TEMPS IN I/O PARAMS) RBL,CLE,ERB (CLEAR SIGN) SZB IF VALUE PRESENT, JSB DEF.F 'DEF VALUE' JMP IOE35 GO LOOP. * IOE33 CLA GENERATE 'NOP'. JSB OAI.F IOE35 ISZ T2IOE LOOP. ISZ T2IOE JMP IOE32 * * DO ANY POST-CONVERSIONS REQUIRED. * IOE34 LDA T1IOS IF READ OR WRITE, SZA CPA K1 JMP IOE37 DO 'DEF END' INSTEAD. * in JSB IOEP ELSE DO POST-CONV & END/ERR. JSB CAR.F FORGET ANY REGISTERS, JMP IOE.F,I AND EXIT. * IOE37 LDB T1RWS READ/WRITE. JSB DEF.F GENERATE 'DEF END-OF-LIST' JSB CAR.F JUST FOR GOOD MEASURE. JMP IOE.F,I DONE. SPC 4 IOEP NOP LDA T1IOE SET UP LOOP. STA T2IOE IOEP1 LDA T2IOE,I GET NEXT TABLE ENTRY. SZA,RSS DONE ? JMP IOEP6 YES. GO DO END & ERR. * ALF,ALF NO. IS IT RESULT ? SLA,RSS (BIT 8 SET ?) JMP IOEP3 NO. NO ACTION NEEDED. * LDA T2IOE,I YES, RESULT. GET INFO BACK. AND B77 KEYWORD ORDINAL. ADA DKWVT STA T5IOE SAVE TABLE ADDR. LDB A,I VALUE F.A RBL,CLE,ERB (CLEAR SIGN) SZB,RSS IF NO VALUE, JMP IOEP3 THEN FORGET IT. * JSB FT.F VALUE TYPE. LDB A LDA T2IOE,I GET EXPECTED TYPE. AND B170K CPA B SAME ? JMP IOEP4 YES. MAY STILL BE NEXTREC. * CPA INT EXPECTED = INT*2 ? JMP IOEP2 YES. ACTUAL MUST BE INT*4. JMP IOEP3 NO. MUST BE CHAR OR LOG, O.K. * IOEP4 LDA T2IOE,I TYPE SAME. IS IT NEXTREC/MAXREC, AND B77 (KEYWORD ORDINAL) CLB AND POST-CONVERSION REQUIRED ? CPA K.NXR NEXTREC, LDB T6IOE CPA K.MXR OR MAXREC ? LDB T7IOE SZB,RSS WELL ? JMP IOEP3 NO. THEN REALLY SAME. * LDA T5IOE,I YES. GET F.A OF THE TEMP USED. STB T5IOE (AND REMEMBER F.A OF REAL RESULT) RAL,CLE,ERA (CLEAR SIGN) JSB PU1.F CONVERT TO INT. LDA INT JSB CTS.F JSB SCG.F LOAD; MAY STILL BE IN MEM. LDB F.S1T,I STORE INTO INT*2 VAR. LDA T5IOE JSB ST.F JSB PO1.F JMP IOEP3 DONE. * IOEP2 LDB T5IOE,I LOAD RESULT FROM FIRST WORD. RBL,CLE,ERB (CLEAR SIGN) LDA LDBI E MUST LOAD EXPLICITLY. JSB SOA.F LDA INT SET B-REG RESULT. JSB SRS.F DEF K1 CLA,INA PUSH ON STACK, SO CAN JSB PU1.F CONVERT TO INT*4. LDA DBI JSB CTS.F LDB F.S1T,I STORE IT BACK. LDA T5IOE,I RAL,CLE,ERA (CLEAR SIGN) JSB ST.F IOEP3 ISZ T2IOE ADVANCE IN TABLE. ISZ T2IOE JMP IOEP1 * * DO END= AND ERR=. * IOEP6 LDA V.IOS IOSTAT F.A RAL,CLE,ERA (CLEAR SIGN) LDB V.END IF END= OR ERR= SUPPLIED, ADB V.ERR SZB,RSS CPA F.IOT OR IOSTAT NOT SUPPLIED, RSS THEN MUST CHECK IT. JMP IOEP,I ELSE LET USER FIGURE IT OUT. * JSB PU1.F NO. LOAD IOSTAT. LDA INT CHEAP WAY TO GET ONLY SECOND WORD. JSB CTS.F LDB F.S1T,I LOAD INTO (A). JSB LDA.F JSB PO1.F (NOTE: REG # IS IN F.RTP) LDA T1IOS READ ? SZA JMP IOEP8 NO. THEN NO END=. * LDA V.END YES. IF END= AND ERR= SAME, CPA V.ERR JMP IOEP8 THEN END= COVERED BY ERR=. * LDA SSAI ELSE DO 'SSA' JSB ORI.F LDB V.END WHERE ? SZB JMP IOEP7 END= PRESENT. * LDB .EXIT END= NOT PRESENT, JSB ODF.F 'JSB .EXIT' JMP IOEP8 * IOEP7 RBL,CLE,ERB END= THERE, (CLEAR SIGN) LDA JMPI JSB SOA.F ISSUE JUMP TO STATEMENT #. * IOEP8 LDA SZAI CHECK FOR ERROR: JSB ORI.F 'SZA' LDB V.ERR AS ABOVE, BUT USING ERR=. SZB JMP IOEP9 * LDB .EXIT JSB ODF.F JMP IOEP,I * IOEP9 RBL,CLE,ERB LDA JMPI JSB SOA.F JMP IOEP,I SKP * KEYWORD VALUE TABLE. * * EACH ENTRY CONTAINS THE F.A OF THE VALUE OF THE KEYWORD. * IF ZERO, VALUE NOT PROVIDED. * IF SIGN BIT SET, WHOLE ITEM TO BE USED (E.G. ARRAY) * SPECIAL CASE: 100000B IS FORMAT '*'. * DKWVT DEF * DEF ZEROTH VALUE. KWVT BSS 34 ROOM FOR 32 VALUES. V.END EQU DKWVT+1 END= VALUE. V.ERR EQU DKWVT+2 ERR= V.FMT EQU DKWVT+3 FMT= V.RCL EQU DKWVT+10 RECL= V.UNT EQU DKWVT+11 UNIT= V.IOS EQU DKWVT+19 IOSTAT= V.BVT EQU DKWVT+30 BIT VECTOR. V.SDS EQU DKWVT+33 INTERNAL FILE STRING DESCRIPTOR. V.ALN EQU DKWVT+34 INTERNAL FILE # RECORDS. K.FMT EQU K3 K.UNT DEC 11 K.MXR DEC 24 K.NXR DEC 25 SPC 2 * TABLES DESCRIBING THE PARAMETERS USED FOR VARIOUS I/O * STATEMENTS. EACH ENTRY HAS ONE OR TWO WORDS: * * BITS 15:12 PARAMETER TYPE. * 8 0=DATA, 1=RESULT. * 7 (IFF BIT 6) 0: 2ND WD HAS DEFAULT VALUE. (100000: NOP) * 1: 2ND WD HAS BIT VECTOR BIT. * 6 1=OPTIONAL, 0=REQUIRED. * 5:0 KEYWORD ORDINAL. * * LIST IS TERMINATED BY A ZERO WORD. * RDWRT EQU * READ/WRITE. OCT 130741 SDES: CHAR, OPTNL, RESULT, #33. OCT 14 OCT 010342 ALEN: INT*2, OPTNL, RESULT, #34. OCT 14 OCT 100304 REC: INT*4, OPTNL, DATA, #4. OCT 20 OCT 010723 IOSTAT: INT*2, OPTNL, RESULT, #19. OCT 40 OCT 000314 ZBUF: ANY, OPTNL, DATA, #12. OCT 300 OCT 010315 ZLEN: INT*2, OPTNL, DATA, #13. OCT 300 OCT 010337 SEC: INT*2, OPTNL, DATA, #31. OCT 1400 OCT 010340 TER: INT*2, OPTNL, DATA, #32. OCT 1400 OCT 0 SKP OPEN EQU * OPEN OCT 010013 UNIT: INT*2, REQ'D, DATA, #11. DEC 0 NO DEFAULT. OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 NO DEFAULT. OCT 130106 FILE: CHAR, OPTNL, DATA, #6. OCT 100000 DEFAULT = NOP. OCT 130105 USE: CHAR, OPTNL, DATA, #5. ASC 1,EX DEFAULT = 'EX' OCT 130126 STATUS: CHAR, OPTNL, DATA, #22. e ASC 1,UN DEFAULT = 'UN' OCT 130121 ACCESS: CHAR, OPTNL, DATA, #17. ASC 1,SE DEFAULT = 'SE' OCT 130107 FORM: CHAR, OPTNL, DATA, #7. OCT 100000 DEFAULT = NOP OCT 010112 RECL: INT*2, OPTNL, DATA, #10. OCT 100000 DEFAULT = 128 OCT 130116 BLANK: CHAR, OPTNL, DATA, #14. ASC 1,NU DEFAULT = 'NU' OCT 010111 NODE: INT*2, OPTNL, DATA, #9. DEC -1 DEFAULT = -1. OCT 010127 BUFSIZ: INT*2, OPTNL, DATA, #23. OCT 100000 DEFAULT = NOP OCT 010130 MAXREC: INT*2, OPTNL, DATA, #24. OCT 100000 DEFAULT = NOP OCT 0 * CLOSE EQU * CLOSE. OCT 010013 UNIT: INT*2, REQ'D, DATA, #11. DEC 0 NO DEFAULT. OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 NO DEFAULT. OCT 130126 STATUS: CHAR, OPTNL, DATA, #22. ASC 1,KE DEFAULT = 'KE' OCT 0 * BSENR EQU * BACKSPACE/ENDFILE/REWIND. OCT 010013 UNIT: INT*2, REQ'D, DATA, #11. DEC 0 OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 OCT 0 SKP INQUI EQU * INQUIRE. OCT 010113 UNIT: INT*2, OPTNL, DATA, #11. OCT 100000 DEFAULT: NOP. OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 OCT 130106 FILE: CHAR, OPTNL, DATA, #6. OCT 100000 DEFAULT: NOP. OCT 100430 MAXREC: INT*4, OPTNL, RESULT, #24. OCT 100000 DEFAULT: NOP. OCT 010136 BIT VECTOR. REQ'D, DATA, #30. DEC 0 OCT 030717 EXIST: LOG*2, OPTNL, RESULT, #15. K1 OCT 1 OCT 030725 OPENED: LOG*2, OPTNL, RESULT, #21. K2 OCT 2 OCT 010724 NUMBER: INT*2, OPTNL, RESULT, #20. OCT 4 OCT 030720 NAMED: LOG*2, OPTNL, RESULT, #16. B10 OCT 10 OCT 130710 NAME: CHAR, OPTNL, RESULT, #8. OCT 20 OCT 130705 USE: CHAR, OPTNL, RESULT, #5. OCT 40 OCT 130721 ACCESS: CHAR, OPTNL, RESULT, #17. OCT 100 OCT 130733 SEQ.: CHAR, OPTNL, RESULT, #27. OCT 200 OCT 130722 DIRECT: CHAR, OPTNL, RESULT, #18. OCT 400 OCT 130707 FORM: CHAR, OPTNL, RESULT, #7. B1000 OCT 1000 OCT 130732 FORMTD: CHAR, OPTNL, RESULT, #26. OCT 2000 OCT 130734 UNFMTD: CHAR, OPTNL, RESULT, #28. OCT 4000 OCT 010712 RECL: INT*2, OPTNL, RESULT, #10. B10K OCT 10000 OCT 100731 NXTREC: INT*4, OPTNL, RESULT, #25. OCT 20000 OCT 130716 BLANK: CHAR, OPTNL, RESULT, #14. OCT 40000 OCT 010711 NODE: INT*2, OPTNL, RESULT, #9. B100K OCT 100000 OCT 0 SPC 2 REL EQU B1000 F.AT=REL INT EQU B10K F.IM=INT TWPE EQU B40K F.IM=TWPE DBI EQU B100K F.IM=DBI SKP * TABLE TO ACCESS THE ABOVE TABLES BY STATEMENT ORDINAL. * DSTTP DEF *+1 DEF TO STATEMENT TEMPLATE TABLE POINTERS. DEF RDWRT 0 READ. DEF RDWRT 1 WRITE. DEF OPEN 2 OPEN. DEF CLOSE 3 CLOSE. DEF INQUI 4 INQUIRE. DEF BSENR 5 BACKSPACE/ENDFILE/REWIND. SKP * ****************** * * READ/WRITE END * * ****************** SPC 1 * IF OUTPUT, ISSUE 'JSB .DTA.' * RWE.F NOP LDA T1IOS FLAG. LDB .DTA. SZA WHICH ? JSB ODF.F WRITE, DO IT. * * DEFINE EXIT ADDRESS FOR FORMATTED; DO CONV, END/ERR. * LDA T1RWS F.A OF TWPE. INA ADDRESS TO STORE F.RPL . LDB F.RPL DO IT. STB A,I JSB IOEP CONVERSIONS, END=, ERR=. JSB CAR.F ZAP REGISTER DATA. JMP RWE.F,I DONE. SKP * **********************6******** * * NEW 'RECORD' IN IMPLIED DO * * ****************************** SPC 1 * COMPUTE LENGTH OF PREVIOUS RECORD. * NR.F NOP LDA T2NR F.RPL AT START OF RECORD. CMA,INA ADA F.RPL LENGTH OF RECORD. STA T1NR,I STORE IN TWPE ENTRY FOR LAST RECORD. * * SET T2NR=F.RPL . IF FIRST REC, SET T1ILA=F.RPL . * LDA F.RPL STA T2NR LDB T1NR IS IT THE FIRST TIME ? SZB,RSS STA T1ILA YES, REMEMBER. * * SAVE F.A OF TWPE FOR NEW RECORD. * JSB RD.F STA T1NR REMEMBER WHERE TO SAVE ITS LENGTH. ISZ T1NR I.E., IN SECOND WORD OF TWPE. CLB,CCE ORG TO IT. RAL,ERA JSB OW.F OCT 20000 JMP NR.F,I DONE. SKP * ******************************************* * * SET LOAD ADDRESS OF IMPLIED DO 'RECORD' * * ******************************************* SPC 1 ILA.F NOP JSB RD.F (A) = F.A OF RECORD TO DEFINE. INA ADDRESS TO PUT LOAD ADDRESS. LDB A,I SAVE ITS LENGTH. STB T2ILA LDB T1ILA REPLACE IT WITH LOAD ADDRESS. STB A,I ADB T2ILA UPDATE LOAD ADDRESS. STB T1ILA JMP ILA.F,I EXIT. SPC 2 T1RWS NOP F.A OF TWPE FOR LIST END, ELSE -1. * T1NR NOP F.A+1 OF TWPE ENTRY OF NEW RECORD. T2NR NOP F.RPL AT START OF CURRENT RECORD. * T1ILA NOP TRUE LOAD ADDRESS AT END CURRENT RECORD. T2ILA NOP LENGTH NEW RECORD. * .EIO. ABS 47 .FIO. ABS 59 .BIO. ABS 65 .DTA. ABS 71 SPC 2 * ****************************** * * I/O LIST ELEMENT PROCESSOR * * ****************************** SPC 1 * SEE IF IN REGISTERS OR ARRAY NAME. * IOL.F NOP LDA F.S1T,I F.A OF RESULT. SZA IN REGISTER(S) ? CPA K1 JM {P IOL01 YES. * STA F.A SET F.A TO ITEM. JSB MP1.F MAP IF IN EMA JSB GT1.F RESTORE F.IM CLA,INA DID IT GET MAPPED ? CPA F.S1T,I (IF SO, IN (B)) JMP IOL03 YES. ADDRESS IN REGISTERS. JMP IOL04 NO. NON-EMA VARIABLE OR CONSTANT. SKP * DATA OR ADDRESS IN REGISTERS. STORE IT. * IOL01 JSB GRD.F GET REG INFO. DEF F.S1T,I SOC ADDRESS ? JMP IOL02 YES. * LDB F.S1T,I NO. DATA. JSB SBR.F STORE IT. LDA F.A (A) = F.A OF DATA. JMP IOL04 * IOL02 STA F.IM SET TYPE OF ARRAY ELEMENT. LDA F.S1T,I REG #. IOL03 ALF,ALF STORE ADDRESS IN (A) OR (B). ALF,RAR (FORMS THE A/B BIT) ADA STAI LDB K2 STA/B *+2 JSB OZ.F (A=0). STA F.A SET F.A TO GENERATE NOP. * * MAKE COMPLEX INTO ARRAY. OUTPUT OTHERS. * IOL04 LDB F.IM TYPE ? CPB CPX IF COMPLEX, JMP IOL08 USE AS ARRAY, LENGTH=2. CPB ZPX DITTO, DOUBLE COMPLEX. JMP IOL07 * JSB MTR.F GET ORDINAL OF ROUTINE. DEF .IIO.-1 JSB ODF.F 'JSB ROUTINE' JSB OA.F OUTPUT DEF TO ELEMENT. JMP IOL05 DONE. EXIT. * * COMPLEX ELEMENT. DO AS REAL ARRAY. * IOL07 LDB .TAY (FOR DOUBLE COMPLEX, .TAY) RSS IOL08 LDB .RAY OUTPUT 'JSB .RAY.' JSB ODF.F JSB OA.F AND 'DEF ITEM' LDA K2 AND JSB OAD.F 'DEC 2' IOL05 JSB CAR.F ZAP REGISTER DATA. JMP IOL.F,I DONE. SPC 2 * .IIO. DEC 54,56,266 INT,REA,LOG K0 DEC 00 (TWPE) DEC 56,57 CPX,DBL DEC 00 (ADDR) DEC 55,266,58 DBI,LO4,RE8 CPX OCT 050000 ZPX OCT 140000 SKP * ************** * * ARRAY NAME * * ************** SPC 1 IOA.F NOP LDA F.S1s>T,I SET UP ASSIGNS. STA F.A JSB FA.F LDA F.VDM ANY VARIABLE DIMENSIONS ? SZA JMP IOA07 YES, GENERATE ARRAY SIZE CALC. CODE * CLA,INA STA F.D0+1 F.D0=1 (1ST WORD SHOULD BE ZERO) LDA F.IM CPA CPX F.IM=CPX? RSS CPA ZPX OR ZPX ? ISZ F.D0+1 YES, F.D0=2 JSB NWI.F F.D0=F.D0*(PRODUCT OF DIMENSIONS) DLD F.D0 SAVE ARRAY ELEMENT COUNT. DST T1IOA CCA (A)=-1 TO FLAG CONSTANT SIZE. JMP IOA10 * * VARIABLE ARRAY SIZE; GENERATE SIZE CALC. CODE. * IOA07 JSB CVA.F COMPUTE ARRAY SIZE, LEAVE ON STACK. LDA F.S1N,I RESTORE F.A & ASSIGNS FOR ARRAY. STA F.A JSB FA.F LDA F.S1T,I (A) = F.A OF SIZE. * * OUTPUT DOT FUNCTION. * IOA10 STA T3IOA F.A OF LENGTH. -1 IF CONST. LDB F.EM EMA ? SZB JMP IOA14 YES. * JSB MTR.F NO. GET ORDINAL OF ROUTINE. DEF .IAY.-1 STB T2IOA SAVE THE '.' FUNCTION OFFSET LDA T3IOA F.A OF LENGTH. SZA LENGTH IN (A) ? JMP IOA11 NO. * LDA STAI YES. DO 'STA *+3' LDB K3 JSB OZ.F (A=0) STA T1IOA+1 NOW SET UP TO OCT 0 IS GENERATED. CCA I.E., MAKE IT LOOK LIKE CONSTANT 0. STA T3IOA (STILL ON STACK, BUT WHO CARES ?) * IOA11 LDB T2IOA OUTPUT 'JSB .IAY.' ETC. JSB ODF.F JSB OA.F OUTPUT 'DEF ITEM' OR NOP. LDB T3IOA (B) = F.A OR -1 SSB,RSS SIZE CONSTANT ? JMP IOA13 NO. * LDA T1IOA+1 YES. (A) = SIZE, JSB OAD.F PUT IT INLINE. JMP IOL19 DONE. * IOA13 LDA B100K SIZE IN TEMP, JSB SOA.F INDIRECT SIZE (FORMAL PARAM) JMP IOL19 DONE. * .IAY. DEC 60 INT .RAY DEC 62,267 REA,LOG DEC 0 (TWPE) DEC 62,63 CPX,DBL DEC p0 (ADDR) DEC 61,269 DBI,LO4 .TAY DEC 64 RE8 DEC 0,64 CHAR,ZPX * .IAE. DEC 66,68,268 INT,REA,LOG DEC 0 (TWPE) DEC 68,69 CPX,DBL DEC 0 (ADDR) DEC 67,264,70 DBI,LO4,RE8 DEC 0,70 CHAR,ZPX SKP * OUTPUT ENTIRE EMA ARRAY. * IOA14 SSA SIZE CONSTANT ? JMP IOA15 YES. * JSB NEG.F NO. MUST NEGATE. (FORCES LOAD) LDA .SWP AND SWAP. JSB OAI.F 'SWP' JSB SRT.F NOW PUT IT IN TEMP. DEF K0 JSB PO1.F AND REMEMBER WHERE. STA T3IOA * IOA15 LDA F.S1T,I RESTORE ASSIGNS. STA F.A JSB FA.F JSB MTR.F GET ORDINAL OF ROUTINE. DEF .IAE.-1 JSB ODF.F OUTPUT THE JSB. DLD F.AF,I (B) = LOWER WORD OR F.A OF TEMP. LDA F.AT FORMAL PARAM ? CPA DUM JMP IOA16 YES. F.A OF TEMP. * LDA F.AF NO. GET UPPER WORD. ADA K3 LDA A,I .SWP SWP SET UP IN REVERSED ORDER. JSB DTR.F DEF TO THAT. JMP IOA17 ON TO LENGTH. * IOA16 JSB DEF.F FORMAL. GEN DEF TO TEMP, REVERSED ADDR. * IOA17 LDB T3IOA NOW DO LENGTH. IS IT A CONSTANT ? SSB JMP IOA18 YES. GO GENERATE IT. * JSB DEF.F NO. GENERATE DEF TO TEMP. JMP IOL19 AND DONE. * IOA18 LDB T1IOA GENERATE CONSTANT & DEF TO IT. LDA T1IOA+1 (IN REVERSED ORDER) CMB NEGATED. CMA,INA,SZA,RSS INB JSB DTR.F IOL19 JSB CAR.F ZAP REGISTER DATA. JMP IOA.F,I DONE. * T1IOA DEC 0,0 # WORDS IN ARRAY. T2IOA NOP OFFSET OF DOT FUNCTION. T3IOA NOP F.A OF DUMMY LENGTH, ELSE 0. SKP * ROUTINE TO CALCULATE VARIABLE ARRAY SIZE. * CVA.F NOP LDB F.ND GET # DIMS CMB,INB NEGATE. STB T1CVA & SAVE. LDA F.LUB ADDR BOUNDS TABLE. INA POINT IT TO FIRST DIM SIZE. STA T2CVA SET POINTER. LDA A,I GET F.A OF FIRST DIM SIZE, JSB PU1.F AND STACK IT. LDB F.EM IF EMA ARRAY, LDA DBI SZB JSB CTS.F ALL COMPUTATION IN DOUBLE INTEGER. JMP CVA02 START THE LOOP. * CVA01 ISZ T2CVA ADVANCE TO NEXT DIMENSION. ISZ T2CVA LDA T2CVA,I PUSH DIMENSION SIZE ON STACK. JSB PU1.F JSB MPY.F MULTIPLY INTO RUNNING PRODUCT. CVA02 ISZ T1CVA ANY MORE ? JMP CVA01 YES. DO THEM. * LDA F.IM COMPLEX ? CPA CPX RSS CPA ZPX RSS YES. JMP CVA.F,I NO. DONE. LDA K2 YES. DOUBLE IT. JSB EIC.F SET UP INTEGER 2, JSB PU1.F PUSH ON STACK, JSB MPY.F AND MULTIPLY. JMP CVA.F,I EXIT. * T1CVA NOP T2CVA NOP SKP * ROUTINE TO MAP TYPE TO ROUTINE ORDINAL. * MTR.F NOP LDB F.IM ITEM TYPE. LDA V.FMT SPECIAL TEST: IF FORMATTED, RAL,CLE,ERA (CLEAR SIGN) SZA,RSS JMP MTR01 LIST-DIRECTED/BINARY: LEAVE IT. * CPB LOG THEN PASS LOGICAL*2 LDB INT AS INTEGER*2, CPB LO4 AND LOGICAL*4 LDB DBI AS INTEGER*4. MTR01 BLF MOVE TYPE TO LOW 4 BITS. ADB MTR.F,I ADD TABLE BASE. ISZ MTR.F LDB B,I GET TABLE ENTRY. JMP MTR.F,I EXIT. SPC 2 * ROUTINE TO FORM DBL INT CONST & OUTPUT DEF TO IT. * DTR.F NOP DST F.IDI FORM IT. LDA DBI JSB ESC.F JSB AI.F ENTER IN SYMBOL TABLE. CLA OUTPUT DEF TO IT. JSB OA.F JMP DTR.F,I DONE. SKP * ************************ * * DATA STATEMENT ITEMS * * ************************ SPC 1 * GET THE ITEM F.A, THE OFFSET & THE REPEAT. * T ORG TO THE START OF THE DATA. * DTA.F NOP JSB RD.F COPY F.A & FETCH ASSIGNS. STA F.A SZA (UNLESS NONE: PROGM RELATIVE) JSB FA.F JSB RD.F AND OFFSET. STA T0DTA JSB RD.F AND REPEAT. CLB USE ASCII BIT: RAL,CLE,SLA,ERA IF CLEAR, USE R=0, LDB B40K ELSE USE R=2. STB T4DTA IN OW.F CALL. CMA,CCE,INA (NEGATE FOR LOOP) (E=1) STA T1DTA LDA F.RPL SAVE CURRENT POSITION. LDB T0DTA (B) = OFFSET. STA T0DTA LDA F.A PROGRAM RELATIVE ? SZA,RSS JMP DTA03 YES. (B) = ADDRESS. * LDA F.AT LABELLED COMMON ? (BLOCKDATA) CPA BCOM JMP DTA01 YES. HARDER. * ADB F.AF (B) = ADDRESS. DTA03 STB F.RPL ORG THERE. JSB OLR.F JMP DTA02 * DTA01 LDA F.AF BCOM. (A) = F.A OF OFFSET ENTRY. INA ADD THE BCOM OFFSET TO THE ARRAY OFFSET. ADB A,I CCE,INA GET F.A OF THE MASTER ENTRY. LDA A,I RAL,ERA ADD SIGN. JSB OW.F ISSUE THE ORG. OCT 20000 DTA02 LDA F.COC SET UP THE DATA WORD COUNT. CMA,INA ADA K3 THREE HEADER WORDS. STA T2DTA - # DATA WORDS. * * COPY THE DATA TO THE F.IDI BUFFER. * LDA F.DID COPY TO F.IDI STA T3DTA DTA05 JSB RD.F ONE AT A TIME. STA T3DTA,I ISZ T3DTA ISZ T2DTA COUNT 'EM JMP DTA05 SKP * OUTPUT THE BUFFER (REPEAT COUNT) TIMES. * DTA04 LDA F.COC SET UP COUNT (AGAIN) CMA,INA ADA K3 (3 HEADER WORDS) STA T2DTA LDA F.DID AND POINTER. STA T3DTA DTA06 LDA T3DTA,I OUTPUT ANOTHER WORD. JSB OW.F T4DTA ABS *-* R=0 (OCTAL) OR R=2 (ASCII) ISZ T3DTA BUMP POINTER, ISZ T2DTA AND COUNTER. JMP DTA06 IF MORE THIS ITEM. *  ISZ T1DTA BUMP REPEAT COUNTER. JMP DTA04 IF MORE TIMES. * LDA T0DTA RESTORE F.RPL STA F.RPL JSB OLR.F JMP DTA.F,I EXIT. * T0DTA NOP OFFSET SAVED F.RPL T1DTA NOP - REPEAT COUNT LEFT. T2DTA NOP BUFFER COUNTER. T3DTA NOP BUFFER POINTER. BCOM OCT 3000 F.AT=BCOM * END ̾ $ 92840-18001 1819 S C0122 LIMIT INTFC MOD              H0101 {ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: LIMIT INTFC MOD * SOURCE: 92840 - 18001 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM LIMIT,7 92840-16001 REV.1819 780515 EXT XLMIT,.OPTN,PLTER ENT LIMIT * * THIS IS THE INTERFACE MODULE FOR THE LIMIT COMMAND. * SPC 3 * * SPC 3 LIMIT NOP LDA LIMIT JSB .OPTN GO GET PARAMETER ADDRESSES DEF RTN PADR DEF PARM PARAME DEF M6 DEF .1 DEF .5 NUMBER OF PARAMETERS DEF .0 NO OPTIONAL PARAMETERS DEF RETRN RTN JMP CHECK JMP ENTRY * * THIS PORTION OF CODE DETERMINES WHETHER OR NOT CALL IS * INTERACTIVE OR AN ERROR. * CHECK CPA M4 INTERACTIVE JMP *+2 YES JMP ERROR NOT ENOUGH PARAMETERS LDA .2 ADD OFFSET TO CODE FOR INTERACTIVE SELECTION STA INTCD LDA DFINT STA PARM ENTRY JSB XLMIT DEF END PARM BSS 6 END JMP RETRN,I * SPC 2 * * SPC 2 * * * SPC 3 * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .43 IGCB NOP RTNER JMP RETRN,I * * CONSTANTS AND STORAGE * DFINT DEF INTCD INTCD NOP M6 DEC -6 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .5 OCT 5 RETRN NOP .43 DEC 43 * END    %, 92840-18002 1819 S C0122 LIMIT COMMAND              H0101 @FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: LIMIT C SOURCE: 92840 - 18002 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XLMIT(IND,IGCB,P1,P2,P3, 1P4), 92840-16001 REV. 1819 780515 INTEGER GICB,DIGTZ,GRIFX DIMENSION VAR(8),IBUFR(5),VAR1(4),CLPTS(4) EQUIVALENCE (VAR,XMM),(VAR(2),YMM),(VAR(3),V3),(VAR(4),V4) EQUIVALENCE (VAR(5),V5),(VAR(6),V6),(VAR(7),V7),(VAR(8),V8) EQUIVALENCE (VAR1,G1X),(VAR1(2),G1Y),(VAR1(3),G2X),(VAR1(4),G2Y) EQUIVALENCE (IBUFR(2),IB2),(IBUFR(4),IB4) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(5),IB5) C C THIS IS THE MODULE FOR PROCESSING THE LIMIT COMMAND C DATA MMSIZ/25010B/ DATA MMU/6/ DATA GICB/16/ DATA IBUFR/26404B/ DATA DIGTZ/6003B/ DATA IG12/8/ DATA IHCLP/32001B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN IFLG = 0 GO TO(60,70),IND C 60 IF(P1.GE.P2.OR.P3.GE.P4)GO TO 800 C COMPUTE NEW HARD CLIP LIMITS H1,H2 C 65 CALL GCBIM(MMU,1,XMM,0,1) G1X = P1 G1Y = P3 G2X = P2 G2Y = P4 C C GET DISPLAY SURFACE SIZE C CALL OUTPT(1,MMSIZ,1) CALL GCBIM(16,1,V3,8,1) C C C SEE IF POINTS ARE OUTSIDE MECHANICAL LIMITS C IFLG = -1 CALL CLPNG(G1X,CLPTS,V3,IFLG) IF(IFLG.EQ.1)GO TO 820 C C C C NOW MAKE SURE ENDPOINTS AR'   E INSIDE MECHANICAL LIMITS C IF(G1X.LT.V3)G1X = V3 IF(G1Y.LT.V4)G1Y = V4 IF(G2X.GT.V5)G2X = V5 IF(G2Y.GT.V6)G2Y = V6 C C CONVERT FROM MM TO MUS C G1X = G1X * XMM G1Y = G1Y * YMM G2X = G2X * XMM G2Y = G2Y * YMM CALL GCBIM(IG12,1,G1X,0,2) GO TO 66 C C INTERACTIVE CALL TO LIMIT C 70 CALL OUTPT(1,DIGTZ,1) CALL GCBIM(GICB,1,IB2,2,1) CALL OUTPT(1,DIGTZ,1) CALL GCBIM(GICB,1,IB4,2,1) IF(IB2.GE.IB4.OR.IB3.GE.IB5)GO TO 800 DO 75 K = 1,4 75 VAR(K) = IBUFR(K+1) C C C SET H1 AND H2 INTO DEVICE C 130 CALL GCBIM(IG12,1,VAR,0,WRITE) 66 CALL GPON(IGCB,3) C C SEE IF USER REALLY BLEW IT C IF(G1X.EQ.V3.AND.G1Y.EQ.V4.AND.V5.EQ.G2X.AND.V6.EQ.G2Y)RETURN C C NOW CHECK ON HARD CLIPPING CAPABILITY OF DEVICE C IF IT CANNOT CLIP REDEFINED HARD CLIP LIMITS SET BIT 3 FOR CLIPPING C ALGORITHM. C C CALL OUTPT(1,IHCLP,1) CALL GCBIM(16,1,IBUFR,1,1) IF(IBUFR.EQ.0)CALL GRSTS(2,77767B,10B) RETURN 800 CALL PLTER(10) 810 RETURN 820 CALL PLTER(34) RETURN END END$ L  &- 92840-18003 1819 S C0122 SETAR INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SET ASPECT RATIO (SETAR) * SOURCE: 92840 - 18003 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM SETAR,7 92840-16001 REV.1819 780515 ENT SETAR EXT .OPTN,XETAR,PLTER * * INTERFACE MODULE FOR SETAR(ASPECT RATIO) * SETAR NOP LDA SETAR JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .1 REQUIRED PARAMETERS DEF .1 ONE DEFAULT DEF DF1 DEF RETRN RTN JMP ERROR JSB XETAR SETAR DEF END PARM BSS 3 END JMP RETRN,I * M3 DEC -3 .1 OCT 1 DF1 DEF D1 D1 DEC 1. .0 OCT 0 RETRN NOP ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .68 IGCB NOP RTNER JMP RETRN,I .68 DEC 68 END  '- 92840-18004 2013 S C0122 &XETAR              H0101 mFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: SETAR C SOURCE: 92840 - 18004 C RELOC: 92840 - 16001 C C MODIFIED BY DJS 1/16/80 C CC*********************************************************** C SUBROUTINE XETAR(IND,IGCB,ASPCT), 92840-16001 REV.2013 800116 C INTEGER GRIFX DS2013 DIMENSION VAR(10),ICODE(3) DIMENSION IBUFR(5) EQUIVALENCE (VAR,DXGDU),(VAR(2),DYGDU),(AP,VAR(3)) EQUIVALENCE (BP,VAR(4)),(CP,VAR(5)),(DP,VAR(6)) EQUIVALENCE (G1X,VAR(7)),(G1Y,VAR(8)),(G2X,VAR(9)) EQUIVALENCE (G2Y,VAR(10)) C DATA EPSLN/.0001/ DS2013 C DATA IGTCH/4404B/ DS2013 DATA IHCLP/32001B/ C C THIS ROUTINE IS USED TO DETERMINE THE ASPECT RATIO OR C MORE SUCCINCTLY ADJUST THE GDU SPACE. C DATA ICODE/15B,11,8/ C AR = ASPCT C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C SET UP DEFAULT IF NECESSARY C IF(ASPCT.GT.0.) GO TO 50 EM1901 AR=1 EM1901 CALL PLTER(23) EM1901 C C GET GDUS AND A' - D' C 50 CALL GCBIM(ICODE,3,VAR,0,1) EM1901 C CALL OUTPT(1,IGTCH,1)    DS2013 C CALL GCBIM(16,1,IBUFR,4,1) DS2013 C C C C COMPUTE PRESENT ASPECT RATIO C 5 ARP = DXGDU/DYGDU C C SEE IF ASPECT RATIOS ARE EQUAL C C XTEST = ABS(AR - ARP) DS2013 C IF(XTEST.LE.EPSLN)RETURN DS2013 C C IS AR LONGER THAN IT IS HIGH OR VICE VERSA C IF(AR.LT.1.)GO TO 100 C C LONGER THAN HIGH AR > 1 C IF(ARP.GT.1.0.AND.AR.LT.ARP)GO TO 200 C C ADJUST GY C GO TO 300 C C HIGHER THAT IT IS WIDE C 100 IF(AR.GT.ARP.AND.ARP.LT.1.0)GO TO 300 C C ADJUST GX C 200 TMPAR = (( DXGDU - (DYGDU*AR))/2.) * AP G1X = G1X + TMPAR G2X = G2X - TMPAR C GO TO 400 C 300 TMPAR = (( DYGDU - ( DXGDU/AR))/2.) * CP G1Y = G1Y + TMPAR G2Y = G2Y - TMPAR 400 CALL GCBIM(8,1,G1X,0,2) EM1901 C C CALL GPON(IGCB,3) C DETERMINE HARD CLIPPING CAPABILITY OF DEVICE C CALL OUTPT(1,IHCLP,1) CALL GCBIM(16,1,IBUFR,1,1) IF(IBUFR.EQ.0)CALL GRSTS(2,77767B,10B) C C RETURN END END$   (/ 92840-18005 1819 S C0122 PLOTTER INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PLOTR * SOURCE: 92840 - 18005 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PLOTR,7 92840-16001 REV. 1819 780515 * EXT SETUP,PLTER,INDCK EXT .OPTN ENT PLOTR,GPON,.PLTR * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMANDS PLOTR * GPON * * SPC 3 * * CALLING SEQUENCE CALL PLOTR(ID,ACTION[,[,LUN,GCB],IOBUF,IOBL]) * * LUN AND GCB REQUIRED FOR ACTION = 1 AND 4 PLOTR NOP ISZ .PLTR SET FLAG FOR .OPTN LDA .40 STA ERCOD LDA PLOTR JSB .OPTN DEF *+8 DEF PARM DEF M8 # OF LOCATIONS IN PARM BUFFER DEF .1 DEF .4 FOUR REQUIRED PARAMETERS DEF .2 OPTIONAL PARAMETERS (IOBUF,IOBL) DEF DZER0 DEF RETRN USED TO SAVE RETURN ADDRESS JMP CKPRM LDB ACTON,I CPB .1 JMP ON CPB .4 JMP ON JMP CKPRM ON LDA IOBUF CHECK TO SEE IF IOBUF AND IOBL CPA DZER0 SEE IF DEFAULT ADDRESS WAS SUBSTITUTED JMP CHNG YES THEN IT MUST BE CHANGED JMP IBLCK CHECK ON IOBL LENGTH CHNG ADB M4 CHECK ON NUMBER OF PARAMTERS FOR PLOTR 1 OR 4 SZB JMP CHNG1 ACTION = 1 LDA DF1 CHANGE ACTION = 4 TO 1 STA ACTON JMP ERR8 CHNG1 LDA GCB I O BUFFER WILL LIVE IN GCB JSB INDCK INDIRECT CHECK STA B GCB(FWA) -> B ADA GCIO I O ADDRESS IN GCB ADB .5 6TH WORD OF GCB  STA B,I LDA GCIL IIO LENGTH INB STA B,I JMP ENTRY+1 CKPRM STA CNTR LDB ACTON ACTION PARAM PRESENT SZB,RSS JMP ERROR LDA B,I SZA ACTION = 0 * JMP CHK3 * CPA .3 ACTION = 3? (SUSPEND) * JMP CHK3 * CPA .2 * JMP CHK3 JMP ERR4 CHK3 LDA CNTR MAKE SURE WE HAVE ENOUGH PARAMETERS CPA M1 JMP CHKGC CPA .0 JMP CHKGC JMP ERROR CHKGC LDA GCB,I CPA M99 MAKE SURE GCB IS LEGAL JMP ENTRY+1 JMP ER199 IBLCK LDB GCB PUT AWAY I/O ADDRESS IN GCB(6) JSB INDCK ADB .5 STA B,I INB NOW LENGTH LDA IOBL,I MAKE SURE IOBL >=10 STA B,I ADA M20 SSA,RSS JMP ENTRY+1 POSITIVE OK LDA DF1 STA ACTON JMP ERR8 * * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD PARAMETER ERROR IGCB NOP RTNER CLA STA .PLTR LDA ERCOD CPA .8 JMP CHNG1 JMP RETRN,I * ERR4 LDA .4 STA ERCOD JMP ERROR * ERR8 LDA PARM,I CMA,INA STA PARM,I JMP CHNG1 * ER199 LDA .199 STA ERCOD JMP ERROR * SKP * * POWER ON CALL * GPON NOP LDA .67 STA ERCOD LDA GPON JSB .OPTN DEF GPRTN PADR DEF PARM DEF M8 DEF .2 DEF .1 LEVEL DEF .1 DEFAULT = 2 DEF DF2 DEF RETRN GPRTN JMP ERROR JMP ENTRY+1 SPC 3 * SPC 3 * * SPC 3 * * CALL TO SETUP FUNCTIONAL MODULE * ENTRY JMP ERROR CLA STA .PLTR JSB SETUP DEF END PARM NOP GCB NOP ID NOP ACTON NOP LUN NOP IOBUF NOP IOBL NOP END JMP RETRN,I * SPC 3 * * * SPC 3 * * * B EQU 1 .4 OCT 4 GCIO DEC 105 GCIL DEC 25 .14  OCT 14 .5 DEC 5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 DZER0 DEF .0 DEF .0 DF2 DEF .2 FRMFD DEF .14 A EQU 0 M8 DEC -7 M20 DEC -20 .67 DEC 67 .PLTR NOP .8 DEC 8 .199 DEC 199 DF1 DEF .1 .40 DEC 40 M1 OCT -1 M99 DEC -99 M4 OCT -4 CNTR NOP RETRN NOP ERCOD NOP * END  )1 92840-18006 2013 S C0122 &SETUP              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: SETUP C SOURCE: 92840 - 18006 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE SETUP(P1,P2,P3,P4,P5,P6, 1P7), 92840-16001 REV.2013 791211 C C THIS IS THE AGL FUNCTIONAL FOR THE AGL COMMANDS PLOTR, C FLUSH,GCLR,AND GPON. THE RELATION TO THE STATEMENTS IN THE C PROGRAM AND THESE COMMANDS IS AS FOLLOWS: C STATEMENT COMMAND C 10 PLOTR C 20 GPON C 30 GCLR C C THE STATEMENTS ARE GOTTEN TO BY THE CODE PASSED DOWN IN P1. C INTEGER P0,P4,P5 ,ICMND(5) ,GICB,POINT,ERROR(9) INTEGER P1,P2(2),P3,P6,READ,WRITE,ICODE(6) INTEGER GRIFX INTEGER FLUSH,HOME,DEFLT,PORG,GCLR,ERMSK(2) INTEGER GTPLT,GTCHR,ACTVE,RESET INTEGER SPEND,CLEAR,CSIZE,TRNFR,GTMMU,PTEND EM1901 DIMENSION VAR(17),IBUFR(12) DIMENSION CHR(2) EQUIVALENCE (ICMND,FLUSH),(ICMND(2),DEFLT),(ICMND(3),HOME) EQUIVALENCE (IBUFR(2),IB2),(IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (IBUFR(5),IB5),(XLIN,IB5) EQUIVALENCE (CHW,IBUFR(2)),(CHH,IBUFR(4)) EQUIVALENCE (VAR,G1X),(VAR(2),G1Y,BP),(VAR(3),G2X) EQUIVALENCE (VAR(4),G2Y,DP) EQUIVALENCE (AP,VAR),(CP,VAR(3)),(A,VAR(5)),(C,VAR(7)) EQUIVALENCE (VAR(6),V6) EQUIVALENCE (VAR(9),DXGDU),(VAR(10),DYGDU) EQUIVALENCE (VAR(11),PORGX),(VAR(12),PORGY),(VAR(13),PDIRX) EQUIVALENCE (VAR(14),PDIRY) EQUIVALENCE (VAR(15),XMU),(VAR(16),YMU),(VAR(1o7),XLDIR) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (ICODE(5),ICD5),(ICODE(6),ICD6) C C THE FOLLOWING DATA ASSIGNMENTS ARE THE FIRST WORDS IN THE GICB C THE GIC AND LENGTH. C C EM1840 C ERROR IS THE ERROR MASK. THE FIRST WORD ,PRESET TO -1, IS EM1840 C USED TO SPECIFY THE ERROR LOGGING LU. WORDS 2-5 ARE THE EM1840 C ACTUAL ERROR MASK, ASSOCIATED WITH ERRORS AS FOLLOWS: EM1840 C WORD 2 ERRORS 16 - 1 EM1840 C 3 32 - 17 EM1840 C 4 48 - 33 EM1840 C 5 64 - 49 EM81840 C IF THE BIT IS SET, THE ASSOCIATED ERROR IS A HARD ERROR EM1840 C DATA FLUSH/2000B/ DATA GICB/16/ DATA RESET/400B/ DATA DEFLT/1000B/ DATA IHARD/26404B/ DATA CLEAR/1400B/ DATA GCLR/1401B/ DATA HOME/2400B/ DATA GTPLT/4010B/ DATA INIT/22004B/ DATA GTCHR/4404B/ DATA CSIZE/7/ C C SY2013 CHANGED ERROR WORD 2 FROM 135577B TO 125577B C DATA ERROR/-1,125577B,173006B,176B,0/ SY2013 DATA LINE/23/ DATA ACTVE /20000B/ DATA SPEND/40000B/ DATA LFTPN/20400B/ DATA GTMMU/27004B/ DATA ICHW/10404B/ DATA ERMSK/28,27/ DATA READ/1/ DATA WRITE/2/ DATA TRNFR/3/ DATA PORG/14/ C C GIC FOR THE 2608A EM1901 DATA PTEND/3400B/ EM1901 C C IER1 = 0 ISUSP = 0 IERR = 0 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C THIS PORTION OF CODE ADDED 5/12/78 TO CORRECT FOR FAULTY ERROR C M!ESSAGES REPORTED IN THE IGERR COMMAND WHEN IT IS CALLED AFTER C TWO SUCESSIVE PLOTR CALLS. C THIS CODE CORRECTS THE PROBLEM BY CLEARING OUT A TEMPORARY BUFFER C USED TO TRANSMIT DATA TO AND FROM THE GCB (GRAPHICS CONTROL BLOCK). C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 2 I=1,12 2 IBUFR(I) = 0 C C SELECT AGL COMMAND C P0 = P1 P1 =IABS(P1) GO TO(10,20),P1 C C PLOTR C C C INITIALIZE GCB ADDRESS POINTER C 10 IF(P4.EQ.1.OR.P4.EQ.4)GO TO 110 C C 5 CALL GCBIM(99,1,P2,ISUSP) IF(ISUSP.NE.0)RETURN C C C CHECK ID ,THEN RESET DEVICE (ACTION = 0) C 100 CALL GCBIM(3,1,IBUFR,0,READ) IERR = 1 IF(P3.NE.IBUFR)GO TO 800 CALL OUTPT(3,ICMND,2) C C FOR THE 2608A, SIGNAL THE PLOT IS OVER SO BUFFERS WILL BE CLEARED EM1901 C OUT. THIS GIC NO-OPED BY NON 2608A DEVICES. EM1901 CALL OUTPT(1,PTEND,2) EM1901 C C CLEAR GCB CALL GCBIM(-99,1,P2) DO 109 K=1,128 109 P2(K) = 0 RETURN C C PLOTR IS ACTION = 1 (TURN ON DEVICE) C C C C SET THE LATEST ERROR CODE TO 0 AND ERROR LOGGING LU TO THE EM1840 C CURRENT CONSOLE BEFORE CALLING GCBIM FOR THE FIRST TIME EM1840 C NOTE THAT THIS IS THE ONLY TIME THAT HARDCODED INDICES TO EM1840 C THE GCB SHOULD BE USED. EM1840 C THIS IS THE ONLY PLACE WHERE THE GCB IS ACCESSED DIRECTLY EM1840 110 P2(2) = 0 P2(5) = LOGLU(DUMMY) EM1840 C C FIRST INITIALIZE FWA OF GCB POINTER (P2=GCB) CALL GCBIM(0,1,P2) C C SET WORD 1 OF ERROR TO THE CURRENT CONSOLE AND ENTER WITH EM1840 C ERROR MASK INTO GCB. THIS RESETTING OF LU IS REDUNDANT EM1840 C BUT SAFE EM1840  ERROR(1) = LOGLU(DUMMY) EM1840 CALL GCBIM(ERMSK,2,ERROR,0,WRITE) C C CHECK TO SEE IF THE LU NUMBER IS LEGAL EM1840 CALL PLTER(-97,P5) C C NON POSITIVE ID'S ARE NOT ALLOWED. CHECK HERE FOR THIS INPUT EM1840 C ERROR SO THE NEXT COMMAND WON'T BE CONFUSED WITH A GSWCH(0) EM1913 C CALL FROM SUBROUTINE(OUTPUT). CANNOT CHECK FOR BAD LU EM1840 C MATCH OR TOO LARGE ID AT THIS TIME AS INFO IS NOT EM1840 C AVAILABLE AT THIS LEVEL. EM1840 IF(P3.LE.0)GO TO 799 EM1840 C C CHECK TO SEE IF LU AND ID MATCH EM1840 CALL GSWCH(P3) EM1913 CALL PLTER(-98,ISUSP) IF(ISUSP.NE.0)RETURN C DO 112 K=1,5 112 P2(K) = 0 DO 114 K = 8,192 114 P2(K) = 0 ICODE = 25 IF(P4.EQ.4)P2(8) = 1000B IF(P0.LT.0)IB2 = 8 IBUFR = -99 C C SET BUFFERING BIT C IB3 = P5 IB4 = P3 CALL GCBIM(ICODE,1,IBUFR,0,WRITE) CALL GCBIM(ERMSK,2,ERROR,0,WRITE) C C INVOKE GPON(1) C GO TO 200 C C PLOTR IS ACTION = 2 (RE-ACTIVATE DEVICE) C20 CALL GCBIM(0,1,P2) C CALL PLTER(-98,ISUSP) C IF(ISUSP.EQ.15B.OR.ISUSP.EQ.0)GO TO 123 C RETURN C C CHECK FOR LEGAL ID AND RESET ERROR 13 IF ANY C C23 IERR = 9 C CALL GCBIM(3,1,IBUFR,0,READ) C IF(P3.NE.IBUFR)GO TO 800 C IF(ISUSP.EQ.15B)CALL PLTER(-99,ISUSP) C C GET STATUS FROM GCB AND MAKE SURE THIS IS A PREVIOUSLY C SUSPENDED GCB. C C IERR = 7 C CALL GRSTS(1,40000B,ISTAT) C IF(ISTAT.NE.SPEND)GO TO 800 C C RESET DEVICE TO ACTIVE C C CALL GRSTS(2,17777B,ACTVE) C C RETURN C C PLOTR IS ACTION = 3 (SUSPEND) C C30 IERR = 9 C CALL GCBIM(3,1,IBUFR,0,READ) C D IF(P3.NE.IBUFR)GO TO 800 C CALL GRSTS(2,17777B,SPEND) C C RETURN C C GPON(P2), WHERE P2 = LEVEL (1-3) C 20 CALL GCBIM(99,1,P2,ISUSP) IF(ISUSP.NE.0)RETURN IF(P3.LT.1.OR.P3.GT.3)GO TO 830 GO TO(200,210,220),P3 C C GPON LEVEL = 1 C SET DEFAULTS C 200 CALL OUTPT(1,DEFLT,2) C C GPON LEVEL = 2 CLEAR DISPLAY,LIFT PEN AND HOME IT C GET HARD CLIP LIMITS G1 AND G2 AND STORE IN GCB C C 210 CALL OUTPT(1,GTPLT,1) CALL GCBIM(GICB,1,8,1,TRNFR) IBUFR = CLEAR IB2 = LFTPN IB3 = HOME CALL OUTPT(3,IBUFR,2) C C C C C C GPON = LEVEL 3 RESET DEVICE AND COMPUTE TRANSFORMATION C CONSTANTS A' - D' WHERE A' ,C' = MU/GDU AND B',D' = OFFSETS. C C 220 CALL OUTPT(1,RESET,2) CALL GCBIM(8,1,G1X,0,1) DO 230 I= 9,10 230 CALL GCBIM(I,1,G1X,0,2) C C SET HARD CLIP LIMITS IN TO DEVICE C IBUFR = IHARD DO 233 I=2,5 233 IBUFR(I) = GRIFX(VAR(I-1)) CALL OUTPT(1,IBUFR,2) C C GET MU/MM C CALL OUTPT(1,GTMMU,1) CALL GCBIM(GICB,1,XMU,4,1) C C INITIALIZE STATUS WORD C CALL GRSTS(2,3000B,INIT) C C INITIALIZE CHARACTER SIZE INFO, (H,W), LORG AND LDIR(SLANT) C IBUFR = 0 IB2 = 0 IB3 = 0 IB4 = 1 XLIN = 0.0 CALL GCBIM(LINE,1,IBUFR,0,2) C C COMPUTE TRANSFORMATION CONSTANTS C DGX = G2X - G1X DGY = G2Y - G1Y DXMM = DGX/XMU DYMM = DGY/YMU DP = G1Y BP = G1X IF(DXMM.GE.DYMM)GO TO 235 DXGDU = 100.0 DYGDU = 100.0 * (DGY/DGX) GO TO 240 235 DYGDU = 100.0 DXGDU = 100.0* (DGX/DGY) 240 AP = DGX/DXGDU CP = DGY/DYGDU C C ESTABLISH CHARACTER SIZE INFO. C XS = 2.78 * .7 IBUFR = ICHW CHH = CP * 2.78 CHW = AP * XS CALL OUTPT(1,IBUFR,2) CALL GCBIM(7,1,CHW,0,2) CALL OUTPT(1,GTCHR,1) C C SY2013: 33 SN$"ETS THE SOFTWARE CHARACTER WIDTH AND HEIGHT(NDC UNITS) C SY2013: 34 INITS THE CHAR SLANT TO 0.0 (GCBIM(34)) C SY2013: GCBIM(35) SETS THE SOFTWARE LDIR TO 0.0 C CHW=2.78*.7 SY2013 CHH=2.78 SY2013 CALL GCBIM(33,1,CHW,0,2) SY2013 CALL GCBIM(GICB,1,7,1,3) SY2013 CALL GCBIM(34,1,0.0,0,2) SY2013 CALL GCBIM(35,1,0.0,0,2) SY2013 C DO 242 I=1,4 242 VAR(I+4) = VAR(I) C C PORGX = 0. PORGY = 0. PDIRX = 1.0 PDIRY = 0. XLDIR = 0. DO 245 I = 1,4 245 ICODE(I) = 10 + I ICD5 = 6 ICD6 = 22 CALL GCBIM(ICODE,6,VAR, 0,WRITE) IF(P4.EQ.4.AND.P1.EQ.1)CALL GRSTS(2,77677B,1000B) RETURN C C C 799 IERR = 2 800 CALL PLTER(IERR,1) RETURN C C 830 CALL PLTER(67) RETURN END END$ &$ * 5 92840-18007 1819 S C0122 GCLR INTFC MOD              H0101 4ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GCLR INTFC MODULE * SOURCE: 92840 - 18007 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GCLR,7 92840-16001 REV.1819 780515 * EXT .OPTN,XGCLR,PLTER ENT GCLR * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND GCLR(DISTANCE) * GCLR NOP LDA GCLR JSB .OPTN DEF GCRTN DEF PARM DEF M3 DEF .1 DEF .1 ONE REQUIRED PARAMETER IGCB DEF .1 ONE DEFAULE FORM FEED DEF FRMFD DEF RETRN GCRTN JMP ERROR JSB XGCLR DEF END PARM BSS 3 END JMP RETRN,I * SPC 2 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .45 IGCB NOP RTNER JMP RETRN,I * M3 DEC -3 .1 OCT 1 FRMFD DEF .14 .14 OCT 14 RETRN NOP .45 DEC 45 END " +1 92840-18008 1819 S C0122 GCLR COMMAND              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GCLR COMMAND C SOURCE: 92840 - 18008 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XGCLR(IND,IGCB,IP1), 92840-16001 REV.1819 780515 INTEGER GRIFX DIMENSION IBUFR(5),VAR(4) EQUIVALENCE(IBUFR(2),IB2) DATA IGCLR/1401B/ DATA IHARD/26404B/ DATA IHOME/1400B/ DATA ICLR/27401B/ DATA IPNUP/20400B/ C C THIS IS THE MODULE FOR THE AGL COMMAND GCLR(DISTANCE) C WHERE DISTANCE = PAGE ADVANCE OR FORM FEED FOR LINE PRINTERS C A NOP FOR GRPHIC DISPLAYS AND PEN UP FOR PLOTTERS. CV CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN IBUFR =IHOME C C SEE IF DEVICE CAN CLEAR C CALL OUTPT(1,ICLR,1) CALL GCBIM(16,1,IB2 ,1,1) IF(IB2 .EQ.0)GO TO 10 IBUFR = IGCLR IB2 = IP1 10 CALL OUTPT(1,IBUFR,2) CALL GCBIM(8,1,VAR,0,1) DO 20 I =2,5 IBUFR(I) = GRIFX(VAR(I-1)) 20 CONTINUE IBUFR = IHARD CALL OUTPT(1,IBUFR,2) RETURN END END$ S ,2 92840-18009 1819 S C0122 MARGIN INTFC MOD              H0101 1UASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MARGIN * SOURCE: 92840 - 18009 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MARGN,7 92840-16001 REV.1819 780515 EXT .OPTN,XMARG,PLTER ENT MARGN * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND MARGIN * MARGN NOP LDA MARGN JSB .OPTN DEF *+8 DEF PARM DEF M7 DEF .1 DEF .5 FOUR REQ'D PARAMETERS DEF .1 ONE OPTIONAL DEF DZER0 INDICATES CHARACTERS/1= GDU'S DEF RETRN JMP ERROR JSB XMARG DEF END PARM BSS 7 END JMP RETRN,I * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .41 IGCB NOP RTNER JMP RETRN,I * DZER0 DEF .0 .1 OCT 1 .5 OCT 5 .41 DEC 41 M7 OCT -7 .0 OCT 0 RETRN NOP END F -3 92840-18010 1819 S C0122 MARGIN COMMAND              H0101 /FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: MARGIN C SOURCE: 92840 - 18010 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XMARG(IND,IGCB,P1,P2,P3,P4, 1IP5), 92840-16001 REV.1819 780515 DIMENSION VAR(10),ICODE(3) EQUIVALENCE (VAR,CHRW),(VAR(2),CHRH),(V1X,VAR(3),G1X) EQUIVALENCE (VAR(4),V1Y,G1Y),(VAR(5),V2X,G2X) EQUIVALENCE (VAR(6),V2Y,G2Y),(AP,VAR(7)) EQUIVALENCE (VAR(9),CP) EQUIVALENCE (ICODE,ICSIZ),(ICODE(2),IG12),(ICODE(3),IADP) DATA ICSIZ/7/ DATA IG12/8/ DATA IADP/11/ C C THIS IS THE AGL FUNCTIONAL FOR THE MARGIN COMMAND. C THE CALLING SEQUENCE IS: C CALL MARGIN(LEFT,RIGHT,BOTTOM,TOP[,UNITS]) C C THE PARAMETERS REPRESENT CHARACTER SPACINGS OR GDUS(UNITS=1) C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GCBIM(ICODE,3,VAR,0,1) IF(IP5.LT.0.OR.IP5.GT.1)GO TO 800 IF(IP5)100,10,100 C C CHARACTER SPACINGS- NOW CHECK TO SEE IF ANY OF THE C PARAMETERS ARE NEGATIVE AND IF SO VIEWPORT VALUE(V1,V2) C IS COMPUTED USING A 90 DEGREE ROTATION OF CHARACTER FROM NORMAL. C 10 X1 = CHRW IF(P1.LT.0)X1 = -CHRH X2 = CHRW IF(P2.LT.0)X2 = -CHRH X3 = CHRH IF(P3.LT.0)X3 = -CHRW X4 = CHRH IF(P4.LT.0)X4 = -CHRW C C NOW COMPUTE VIEWPORT VALUES C 90 V2X = (G2X - G1X -(X2   *P2))/AP V2Y = (G2Y - G1Y - (X4 * P4))/CP V1X = (X1 * P1)/AP V1Y = (X3 * P3) /CP CALL VIEWP(IGCB, V1X,V2X,V1Y,V2Y) RETURN C C GDU'S C 100 X1 = AP X2 = AP X3 = CP X4 = CP GO TO 90 800 CALL PLTER(28) RETURN END END$ ?  .5 92840-18011 2013 S C0122 &MSCAL              H0101 x}FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: MSCALE C SOURCE: 92840 - 18011 C RELOC: 92840 - 16001 C C MODIFIED BY: DJS 1/16/80 >> GET RID OF GPS 15 ERROR C CC*********************************************************** C SUBROUTINE XSCAL(IN,IGCB,P1,P2), 92840-16001 REV.2013 800116 DIMENSION VAR(8),ICODE(3) EQUIVALENCE (VAR,DXGDU),(VAR(2),DYGDU),(VAR(3),G1X) EQUIVALENCE (VAR(4),G1Y),(VAR(5),G2X),(VAR(6),G2Y) EQUIVALENCE (VAR(7),XMM),(VAR(8),YMM) EQUIVALENCE (ICODE,IGDU),(ICODE(2),IG12) EQUIVALENCE(ICODE(3),MMU) C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL COMMAND MSCALE C WHICH DEFINES USER UNITS IN TERMS OF MILLIMETERS. C DATA IGDU/15B/ DATA IG12/8/ DATA MMU/6/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GCBIM(ICODE,3,VAR,0,1) C DS2013 C FAKE OUT VIEWP SO THAT A GPS 15 ERROR WON'T BE REPORTED DS2013 C DS2013 C DS2013 CALL GRSTS(2,77775B,0) DS2013 C C REDEFINE VIEWPORT SET HARD CLIP LIMITS = SOFT CLIP LIMITS C CALL VIEWP( IGCB,0.,DXGDU,0.,DYGDU) C C COMPUTE PARAMETERS FOR SCALE C XUU = (G2X - G1X)/XMM - P1 f  YUU = (G2Y - G1Y)/YMM - P2 XU1 = -P1 YU1 = -P2 CALL WINDW( IGCB,XU1,XUU,YU1,YUU) RETURN END END$ 0;  /6 92840-18012 1840 S C0122 &CLPON CLPON OR SCPOF CMDS SRCE             H0101 <;FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: CLPON\CLPOF COMMANDS C SOURCE: 92840 - 18012 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XCLPN(IN,IGCB), 92840-16001 REV.1840 780811 C CCCC C C IN=1 INDICATES CLPON CALL IN=2 INDICATES CLPOF CALL EM1840 C DIMENSION TFORM(10),ICODE(3) EM1840 C ICODE WILL CONTAIN THE INDICES INTO IGTBL EM1840 C TFORM WILL RECIEVE THE INFORMATION REQUESTED FROM THE GCB EM1840 C REAL XPHYS,YPHYS EM1840 C XPHYS AND YPHYS WILL RECIEVE THE CALCULATED LOGICAL POSITION EM1840 C EQUIVALENCE (TFORM(1),CPX),(TFORM(2),CPY),(TFORM(3),A), EM1840 1 (TFORM(4),B),(TFORM(5),C),(TFORM(6),D), EM1840 2 (TFORM(7),LOWRX),(TFORM(8),LOWRY), EM1840 3 (TFORM(9),UPPRX),(TFORM(10),UPPRY) EM1840 C CPX,CPY - THE CURRENT PEN POSITION IN MACHINE UNITS FROM GCB EM1840 C A,B,C,D - THE MU/NDC OR MU/WC TRANSFORM COEFFICIENTS FROM GCB EM1840 C C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A C SUSPENDED GCB. ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C GO TO(100,200),IN C C C TURN ON SOFT CLIPPING BY SETTING BIT 2 OF STATUS WORD = 1 100 CALL GRSTS(2,77773B,4) RETURN C C C +2C TURN OFF SOFT CLIPPING BY SETTING BIT 2 OF STATUS WORD = 0 EM1840 200 CALL GRSTS(2,77773B,0) C C IF THE CURRENT POSITION IS OUTSIDE SOFT CLIPPING BOUNDARIES, EM1840 C THE PHYSICAL PEN AND THE CP MAY NOT AGREE, SO MOVE THE EM1840 C PHYSICAL PEN TO AGREE WITH THE CP IN THIS CASE. EM1840 C SET THE INDICES TO THE GCB POINTER TABLE AND REQUEST THE DATA EM1840 C POINTER 18 IS TO THE LOGICAL PEN (I.E. CP) INDEX. FUNCTION EM1840 C IADCD RETURNS POINTER TO MU/NDC OR MU/WC TRANSFORMS, EM1840 C DEPENDING ON CURRENT MODE, GDU OR UDU. POINTER 10 IS TO EM1840 C THE SOFT CLIPPING BOUNDARIES INDEX. EM1840 ICODE(3)=10 EM1840 ICODE(2)=IADCD(DUMMY) EM1840 ICODE(1)=18 EM1840 CALL GCBIM(ICODE,3,TFORM,0,1) EM1840 C C CHECK TO SEE IF THE CURRENT PEN POSITION IS OUTSIDE THE SOFT EM1840 C CLIPPING BOUNDARIES. IF IT ISN'T THE PHYSICAL PEN POSITION EM1840 C SHOULD BE FINE AS IS, SO DO NOTHING MORE. EM1840 C C IF IT IS OUTSIDE, MAKE THE MOVE. EM1840 IF (CPX.LT.LOWRX) GO TO 300 EM1840 IF (CPX.GT.UPPRX) GO TO 300 EM1840 IF (CPY.LT.LOWRY) GO TO 300 EM1840 IF (CPY.GT.UPPRY) GO TO 300 EM1840 C C IT IS INSIDE SO NO MOVE IS NECESSARY EM1840 GO TO 500 EM1840 C C TRANSFORM FROM MACHINE UNITS TO NDC OR WC UNITS EM1840 300 XPHYS = (CPX-B)/A W EM1840 YPHYS = (CPY-D)/C EM1840 C C MOVE PEN TO CALCULATED POSITION SO LOGICAL AND PHYSICAL MATCH EM1840 CALL MOVE(IGCB,XPHYS,YPHYS) EM1840 C 500 RETURN EM1840 END END$ M 08 92840-18013 1819 S C0122 SHOW COMMAND              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: SHOW C SOURCE: 92840 - 18013 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XSHOW(IN,IGCB,U3X,U4X,U3Y, 1U4Y), 92840-16001 REV.1819 780515 DIMENSION VAR(4) EQUIVALENCE (VAR,V1X) EQUIVALENCE (VAR(2),V1Y),(VAR(3),V2X),(VAR(4),V2Y) C C C THIS MODULE IS RESPONSIBLE FOR PROCESSING THE AGL COMMAND C SHOW. SHOW ISOTROPICALLY SCALES USER UNITS U3-U4, GETTING C THE BIGGEST POSSIBLE AREA IN THE REGION OF INTEREST (VIEWPORT) C ON WHICH TO MAP USER UNITS. ESSENTIALLY SHOW REDEFINES C USER UNITS U1-U2 AND DISCARDS U3-U4. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C C GET CURRENT SOFT CLIP LIMITS C ICODE = 9 CALL GCBIM(ICODE,1,VAR,0,1) C C LOOK FOR ERRORS C IF(U3X.EQ.U4X.OR.U3Y.EQ.U4Y)GO TO 800 C C COMPUTE THE DELTA X AND Y FOR THE USER UNITS TO DETERMINE C MINIMUM SIDE. C DXUDU = U4X - U3X DYUDU = U4Y - U3Y DXV = V2X - V1X DYV = V2Y - V1Y DX = ABS(DXV/DXUDU) DY = ABS( DYV/DYUDU ) C C NOW DETERMINE WHAT TO ASSIGN TO U1 - U2 C C U1X = U3X U2X = U4X U1Y = U3Y U2Y = U4Y C C 20 IF(DX.EQ.DY)GO TO 120 C C U3,U4 HIT TOP AND BOTTOM EDGES OF VIEW SURFACE C SO ADJUST U3X AND U4X TO OBTAIN MAXIMUM SQUARE. c   C 100 IF(DX.LT.DY)GO TO 110 TEMP= ( ( ((DXV * DYUDU)/DYV) - DXUDU )/2. ) C C SEE U3,U4 ARE REVERSED C U1X = U3X - TEMP U2X = U4X + TEMP GO TO 120 C C U3,U4 HIT LEFT AND RIGHT SIDES THERE ADJUST U3Y AND U4Y C 110 TEMP = ( (((DYV * DXUDU)/DXV) - DYUDU )/2. ) U1Y = U3Y - TEMP U2Y = U4Y + TEMP C C CALL WINDOW TO COMPUTE TRANSFORMATION CONSTANTS AND C TO ESTABLISH USER UNITS = UDUS C 120 CALL WINDW( IGCB,U1X,U2X,U1Y,U2Y) RETURN 800 CALL PLTER(16) END END$ `  18 92840-18014 1819 S C0122 VIEWP INTF MOD              H0101 8ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: VIEWPE,VIEWPORT,CLIP * SOURCE: 92840 - 18014 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM VIEWP,7 92840-16001 REV.1819 780515 EXT SCLNG,.OPTN,PLTER ENT CLIP ENT VIEWP * * THIS IS THE INTERFACE MODULE FOR THE GRAPHICS * SCALING COMMANDS. * SPC 3 * SPC 3 VIEWP NOP LDA .42 STA ERCOD LDA .1 LOC1 STA CODE CODE FOR VIEWPE LDA VIEWP JSB .OPTN GO GET PARAMETER ADDRESSES DEF RTN PADR DEF PARM PARAME DEF M6 DEF CODE DEF .5 NUMBER OF PARAMETERS DEF .0 NO OPTIONAL PARAMETERS DEF RETRN RTN JMP CHECK JMP ENTRY * * THIS PORTION OF CODE DETERMINES WHETHER OR NOT CALL IS * INTERACTIVE OR AN ERROR. * CHECK CPA M4 INTERACTIVE JMP *+2 YES JMP ERROR NOT ENOUGH PARAMETERS LDA CODE ADD OFFSET TO CODE FOR INTERACTIVE SELECTION ADA .2 STA INTCD LDA DFINT STA PARM ENTRY JSB SCLNG DEF END PARM BSS 6 END JMP RETRN,I * SPC 2 * * SPC 2 * CLIP NOP LDA CLIP STA VIEWP LDA .46 STA ERCOD LDA .2 JMP LOC1 * SPC 2 * * * SPC 3 * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * CONSTANTS AND STORAGE * DFINT DEF INTCD INTCD NOP M6 DEC -6 M4 DEC -4 .0 OCT   0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .4 OCT 4 .5 OCT 5 .6 OCT 6 CODE NOP ERCOD NOP .46 DEC 46 .42 DEC 42 RETRN NOP * END \  29 92840-18015 2013 S C0122 &SCLNG              H0101 yFTN4,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: LOCATE,VIEWPORT,CLIP C SOURCE: 92840 - 18015 C RELOC: 92840 - 16001 C C MODIFIED BY: DJS 1/16/80 >> STOP GPS 15 REPORT FOR CLIP C CC*********************************************************** C SUBROUTINE SCLNG(IND, IGCB,P1,P2,P3, 1P4), 92840-16001 REV.2013 800116 DIMENSION VAR(8),ICODE(3),VAR1(4),IBUFR(5) DIMENSION IER1(2),IER2(2),IER3(2) INTEGER GICB INTEGER STATS,READ,WRITE,DIGTZ EQUIVALENCE (VAR,V1X,XMM),(VAR(2),YMM,V1Y) EQUIVALENCE (VAR(3),V2X),(VAR(4),V2Y) EQUIVALENCE (VAR(5),S1X),(VAR(6),S1Y) EQUIVALENCE (VAR(7),S2X),(VAR(8),S2Y) EQUIVALENCE (VAR1,A,AP) ,(VAR1(2),B,BP,G1X) EQUIVALENCE (VAR1(3),C,CP,G1Y),(VAR1(4),D,DP,G2X) EQUIVALENCE (IBUFR(2),IB2),(IBUFR(4),IB4) EQUIVALENCE(IBUFR(3),IB3) EQUIVALENCE (IBUFR(5),IB5) C C THIS IS THE AGL MODULE FOR THE SCALING COMMANDS: C LOCATE AND CLIP. C C THE VARIABLES IN THE EQUIVALENCE STATEMENTS HAVE THE FOLLOWING C MEANINGS: C G1 - G2 (X,Y) = HARD CLIP LIMITS C V1 - V2 " = MAPPING ENDPOINTS C S1 - S2 " = SOFT CLIP LIMITS C A - D = TRANSFORMATION CONSTANTS C DATA STATS/5/ DATA READ/1/ DATA WRITE/2/ DATA IV12/9/ DATA IG12/8/ DATA IS12/10/ DATA IADP/11/ DATA IAD/12/ DATA DIGTZ/6003B/ DATA GICB/16/ DATA IER1/11,17/ DATA IER2/12,19/ DATA IER3/14,18/ IBUFR = 26404B IFLG = 0 C ISTAT = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C CALL GRSTS(1,2,ISTAT) DS2013 C IF(ISTAT.NE.0)CALL PLTER(15) DS2013 INDX = IND C C SELECT COMMAND PROCESSOR C IF(IND.GT.2)GO TO 70 C C LOCATE - FIRST CHECK TO SEE IF P1=P2 OR P3=P4 C 10 IF(P1.EQ.P2.OR.P3.EQ.P4)GO TO 800 C C SEE IF S1 OR V1 IS LOWER LEFT AND S2 OR V2 IS UPPER RIGHT C C C C C GET AP TO DP OR G1-G2 AND CHRH,CHRW C GO TO(20,50),IND 20 CALL GCBIM(IADP,1,VAR1,0,READ) CALL GRSTS(1,2,ISTAT) DS2013 IF (ISTAT .NE. 0) CALL PLTER(15) DS2013 C GO TO (100,50),IND DS2013 C C COMPUTE V1,V2 AND S1,S2 C 100 V1X = AP * P1 + BP V1Y = CP * P3 + DP V2X = AP * P2 + BP V2Y = CP *P4 + DP 110 S1X = AMIN1(V1X,V2X) S2X = AMAX1(V1X,V2X) S1Y = AMIN1(V1Y,V2Y) S2Y = AMAX1(V1Y,V2Y) C IF(V1X.GT.V2X.OR.V1Y.GT.V2Y)CALL PLTER(IER1(INDX)) C C CLIP MAPPING ENDPOINTS TO THE HARD CLIP LIMITS H1,H2 C ICODE = 8 115 CALL GCBIM(ICODE,1,A,0,READ) IFLG = -1 CALL CLPNG(S1X,V1X,A,IFLG) IF(IFLG.EQ.1)GO TO 810 IF(S1X.LT.A.OR.S1X.GT.C)S1X = A IF(S1Y.LT.B.OR.S1Y.GT.D)S1Y = B IF(S2X.GT.C.OR.S2X.LT.A)S2X = C IF(S2Y.GT.D.OR.S2Y.LT.B)S2Y = D CALL GCBIM(IS12,1,S1X,0,WRITE) C C SEE IF THIS IS A CLIP OR VIEWP CALL C GO TO(117,55,117,55),IND 117 CALL GCBIM(IV12,1,S1X,0,WRITE) CALL GRSTS(2,67773B,4) V1X = 0. V1Y = 0. CALL GCBIM(18,1,V1X,0,2) RETURN C C CLIP C 50 ISTAT = IADCD(D) CALL GCBIM(ISTAT,1,VAR1,0,READ) GO TO 100 C 55 CALL GRSTS(2 ,77773B,4) RETURN C C C INTERACTIVE CALLS TO CLIP OR LOCATE. C 70 INDX = IND - 2 CALL OUTPT(1,DIGTZ,1) CALL GCBIM(GICB,1,IB2,2,1) CALL OUTPT(1,DIGTZ,1) CALL GCBIM(GICB,1,IB4,2,1) V1X = IB2 V2X = IB4 V1Y = IB3 V2Y = IB5 IF(IB2.EQ.IB4.OR.IB3.EQ.IB5)GO TO 800 GO TO 110 C C ERRORS C 800 CALL PLTER(IER2(INDX)) RETURN 810 CALL PLTER(IER3(INDX)) RETURN C END END$  3; 92840-18016 1819 S C0122 WINDOW INTF MOD              H0101 \ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SCALE OR WINDOW * SOURCE: 92840 - 18016 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM WINDW,7 92840-16001 REV.1819 780515 EXT WINDX,.OPTN,PLTER ENT SCALE ENT WINDW * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND * SCALE * SPC 3 WINDW EQU * SCALE NOP SCL1 LDA SCALE JSB .OPTN DEF RTN PADR DEF PARM DEF M6 DEF .1 DUMMY CODE DEF .5 DEF .0 NO OPTIONAL PARAMETERS DEF RETRN RTN JMP ERROR NOT ENOUGH PARAMETERS JSB WINDX DEF END PARM BSS 6 END JMP RETRN,I * * * CONSTANTS * .1 DEC 1 .5 OCT 5 .0 OCT 0 M6 OCT -6 .44 DEC 44 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .44 IGCB NOP RTNER JMP RETRN,I RETRN NOP END  4: 92840-18017 1819 S C0122 WINDW COMMAND              H0101 TFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: WINDOW C SOURCE: 92840 - 18017 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE WINDX(IND,IGCB,U3X,U4X,U3Y, 1U4Y), 92840-16001 REV.1819 780515 DIMENSION VAR(8) DIMENSION ICODE(4) EQUIVALENCE (VAR,V1X) EQUIVALENCE (VAR(2),V1Y),(VAR(3),V2X),(VAR(4),V2Y) EQUIVALENCE (VAR(5),A),(VAR(6),B),(VAR(7),C),(VAR(8),D) C C SCALE TAKES THE USER UNITS AND SETS UP THE MAPPING CONSTANTS C FOR TRANSLATING AND SCALING USER UNITS ONTO THE DEVICE C COORDINATE SURFACE. THE STATUS WORD IS SET (BIT 0= 1) TO C INDICATE UDU'S AT THE COMPLETION OF THIS CALL. C C DATA IV12/9/ DATA IUXY/27/ DATA IAD/12/ DATA IADP/11/ C C COMPUTE THE DELTA X AND Y FOR THE USER UNITS TO DETERMINE C MINIMUM SIDE. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN IF(U3X.EQ.U4X.OR.U3Y.EQ.U4Y)GO TO 800 DXUDU = U4X - U3X DYUDU = U4Y - U3Y CALL GCBIM(IV12 ,1,VAR,0,1) DXV = V2X - V1X DYV = V2Y - V1Y C C C C COMPUTE CONSTANTS FOR SCALE C 10 A = DXV /DXUDU B = V1X - (A* U3X) C = DYV /DYUDU D = V1Y - (C * U3Y) CALL GCBIM(IAD,1,A,0,2) C C NOW SET STATUS TO INDICATE A-D (MU/UDU) TRANSFORMATIONS C AND INVOKE SETUU USER UNITS = UDU'S. C CALL GRSTS6  (2,77774B,3) CALL SETUU(IGCB) RETURN 800 CALL PLTER(16,5) RETURN END END$ END$ ˘  5< 92840-18018 1819 S C0122 L/AXES INTF MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: AXES AND LAXES INTERFACE * SOURCE: 92840 - 18018 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM AXES,7 92840-16001 REV.1819 780515 ENT AXES,LAXES EXT PLTER EXT .OPTN EXT AXELS * * THIS IS THE INTERFACE MODULE FOR AGL COMMANDS * AXES,LAXES,GRID,LGRID,FRAME,FXD * AXES NOP LDA .1 CODE = 1 STA CODE LDA AXES AX1 JSB .OPTN DEF RTN PADR DEF PARM DEF M9 DEF CODE DEF .1 IGCB PARAMETER DEF .7 SEVEN OPTIONAL PARAMETERS DEF DZER0 TOP OF LIST OF DEFAULTS DEF RETRN * RTN JMP ERROR JSB AXELS DEF END PARM BSS 9 END JMP RETRN,I * * LABELED AXES * LAXES NOP LDA .2 CODE = 2 STA CODE LDA LAXES JMP AX1 * * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .62 IGCB NOP RTNER JMP RETRN,I * PARAMETERS AND CONSTANTS- DO NOT CHANGE ORDER * .0 DEC 0. DZER0 DEF .0 DEF .0 DEF .0 DEF .0 DF1 DEF D1 DEF D1 DEF D2 D1 DEC 1. CODE NOP .1 OCT 1 D2 DEC 2.0 .2 OCT 2 .7 OCT 7 DF2 DEF .2 M9 DEC -9 RETRN NOP .62 DEC 62 END  6< 92840-18019 2013 S C0122 &AXELS              H0101 zFTN4,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: AXES AND LAXES, GRID AND LGRID C SOURCE: 92840 - 18019 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE AXELS(IND, IGCB,P1,P2,P3, 1P4,P5,P6,P7), 92840-16001 REV.2013 800127 C REAL NUMTC DIMENSION VAR(12),XYORG(2),XYNOW(2) EM1913 DIMENSION ICODE(3),IBUFR(7) INTEGER READ,WRITE,EFLG C C VARIABLE TO SAVE STATE OF LINESTYLE SELECTED BIT FROM STATUS WORD EM1901 INTEGER LNSET EM1901 C EM1901 EQUIVALENCE (VAR,A),(VAR(2),B),(VAR(3),C),(VAR(4),D) EQUIVALENCE (VAR(5),X1),(VAR(6),Y1) EQUIVALENCE (AP,VAR(9)),(BP,VAR(10)),(CP,VAR(11)),(DP,VAR(12)) EQUIVALENCE (VAR(7),XEND),(VAR(8),YEND) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3) EQUIVALENCE (IBUFR(5),THETA),(IBUFR(2),XLNTH),(IBUFR(4),LRG) EQUIVALENCE (IBUFR(7),IERCD) C DATA READ/1/ DATA WRITE/2/ EM1901 C C BIT 11 IN STATUS WORD CONTAINS STATE OF LINESTYLE CALL EM1901 DATA LNSTS/4000B/ EM1901 DATA LNTYP/23/ C C THIS IS THE AGL MODULE FOR AGL COMMANDS AXES,LAXES,GRID C AND LGRID. C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANINGS: C PARAMETER MEANING DEFAULT C IND p 1=AXES,2=LAXES NONE EM1913 C 3=GRID,4=LGRID EM1913 C P1 X-TIC SPACING 0-NO TICS C P2 " Y-TIC SPACING 0 C P3 " X-ORIGIN 0 C P4 " Y-ORIGIN 0. C P5 " X-MAJOR COUNT 1.0 C P6 " Y-MAJOR COUNT 1.0 C P7 " MINOR TIC SIZE 2GDUS C************************************************************* C C DETERMINE UNITS MODE AND WHICH TRANSFORMATION CONSTANTS TO C USE. C ICD2 = 10 DS2013 ICD3 = 11 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN ICODE = IADCD(D) CALL GCBIM(ICODE,3,VAR,0,READ) C EM2013 C CONVERT MUS TO CURRENT UNITS MODE UDUS OR GDUS C XEND = (XEND - B)/A EM1913 YEND = (YEND - D)/C X1 = (X1 - B)/A Y1 = (Y1 - D)/C C EM1913 C BECAUSE OF TRUNCATION ERRORS IN FLOATING POINT ARITHMETIC, AND EM1913 C POSSIBLE ERRORS IN SOFTWARE FLOATING POINT ARITHMETIC ROUTINES, IT IS EM1913 C NECESSARY TO ADD AN EPSILON FACTOR TO SLIGHTLY ENLARGE THE WINDOW EM1913 C TO ENSURE NO ACCIDENTAL CLIPPING OF AXES AND LABELS EM1913 C EM1913 EPSIX = ABS(P1/1000.) EPSIY = ABS(P2/1000.) EM1913 X1 = X1-EPSIX AEM1913 Y1 = Y1-EPSIY EM1913 XEND = XEND+EPSIX EM1913 YEND = YEND+EPSIY EM1913 C EM1913 C C ABSOLUTIZE NECESSARY PARAMETERS C DON'T ABSOLUTIZE TIC SPACING IF LABELS INVOLVED, SINCE THE SIGN EM1913 C INDICATES LABEL ORIENTATION. EM1913 C EM1913 IF (IND.EQ.1.OR.IND.EQ.3) GO TO 10 EM1913 XP1 = P1 EM1913 XP2 = P2 EM1913 GO TO 20 EM1913 10 XP1 = ABS(P1) XP2 = ABS(P2) C EM2013 C ZERO IS AN ILLEGAL VALUE FOR TIC SPACING. EM2013 C SET TIC SPACING = 1. IF ZERO IS SPECIFIED EM2013 C OTHERWISE TAKE ABSOLUTE VALUE. EM2013 C EM2013 20 IF (P5 .NE. 0.) GOTO 21 EM2013 XP5 = 1. EM2013 GOTO 22 EM2013 21 XP5 = ABS(P5) EM2013 22 IF (P6 .NE. 0.) GOTO 23 EM2013 XP6 = 1. EM2013 GOTO 24 EM2013 23 XP6 = ABS(P6) EM2013 24 XP7 = ABS(P7) K EM2013 C EM1913 C C SAVE STATUS WORD BIT INDICATING WHETHER OR NOT LINESTYLE CALLED EM1901 C BY USER PROGRAM. THIS IS BIT 11 OF STATUS WORD. EM1901 C CALL GRSTS(READ,LNSTS,LNSET) EM1901 C C GET LINE TYPE, LDIR AND LORG AND SAVE FOR RESET WHEN DONE C ICODE = LNTYP ICD2 = 30 CALL GCBIM(ICODE,2,IBUFR,0,1) C EM1913 C C C C***********************************************************************EM1913 C* DO FOR X AXIS THEN Y AXIS *EM1913 C* SET THE LINESTYLE TO 0 FOR DRAWING OF AXIS *EM1913 C* DRAW AXIS *EM1913 C* CALL SUBROUTINE FOR TICS-GRIDS 'ABOVE' ORIGIN, UNLESS *EM1913 C* NO AXIS IS THERE *EM1913 C* CALL SUBROUTINE FOR TICS-GRIDS 'BELOW' ORIGIN, UNLESS *EM1913 C* NO AXIS IS THERE *EM1913 C* TURN CLIPPING OFF *EM1913 C* DRAW LABELS FOR AXIS - ORIGIN, RIGHT, LEFT *EM1913 C* TURN CLIPPING ON *EM1913 C***********************************************************************EM1913 C EM1913 C EM1913 C EM1913 C ******** X AXIS *** EM1913 C EM1913 CALL LINE(IGCB,0)  EM1913 C EM1913 C DRAW AXIS UNLESS ALL CLIPPED BECAUSE ORIGIN OUT OF WINDOW EM1913 C EM1913 IF (P4.LT.Y1) GO TO 25 EM1913 IF (P4.GT.YEND) GO TO 25 EM1913 C EM1913 C EM1913 C NO, NOT ALL CLIPPED SO DRAW AXIS EM1913 C EM1913 CALL MOVE(IGCB,X1,P4) EM1913 CALL DRAW(IGCB,XEND,P4) EM1913 C EM1913 C EM1913 C IF THERE AREN'T ANY TICS OR GRIDS, WE ARE DONE WITH THIS AXIS EM1913 C EM1913 25 IF (XP1.EQ.0.) GO TO 30 EM1913 C EM1913 C EM1913 C SET UP ARRAY CONTAINING ORIGIN POINTS FOR SUBROUTINE CALLS EM1913 C EM1913 XYORG(1) = P3 EM1913 XYORG(2) = P4 EM1913 I = 1 EM1913 J = 2 EM1913 C EM1913 C Q  EM1913 C SET UP SPACE BETWEEN TICS FOR THE UPPER DIRECTION EM1913 C EM1913 BETWN = ABS(P1) EM1913 C EM1913 C EM1913 C SET UP TIC MARK SIZE FOR MINOR TICS (SAME AS MAJOR TIC OFFSET EM1913 C TO ONE SIDE). THIS WILL BE 0 FOR CALLS WISHING GRID LINES AT EM1913 C MINOR TIC MARKS AS WELL AS MAJOR. EM1913 C EM1913 TICSZ = (XP7*CP)/C EM1913 C EM1913 C EM1913 C SEPARATE INTO GRIDS AND TICS EM1913 C EM1913 C EM1913 C CALL FOR TIC OR GRID MARKS ON UPPER AND LOWER HALVES, IF THERE EM1913 C IS ANY AXIS THERE, CHANGING DIRECTION OF SPACE BETWEEN TICS FOR EM1913 C LOWER HALF EM1913 C EM1913 IF(P3.LT.XEND)CALL G1TIC(IGCB,IND,Y1,YEND,X1,XEND,XYORG,I,J, EM1913 1 BETWN,TICSZ,XP5) EM1913 BETWN = -1. * BETWN EM1913 IF(P3.GT.X1)CALL G1TIC(IGCB,IND,Y1,YEND,XEND,X1,XYORG,I,J,BETWN, EM1913 1 TICSZ,XP5) EM1913 C G EM1913 C EM1913 C****LABELS FOR X AXIS*************************************** EM1913 C EM1913 C CHECK TO SEE IF LABELS WANTED EM1913 C EM1913 IF (IND.EQ.1.OR.IND.EQ.3) GO TO 30 EM1913 C EM1913 C MOVE TO LOVER EDGE OF SURFACE, SO IF LABELS ARE OUTPUT OUTSIDE OF EM1913 C HARDCLIP LIMITS, THEY WON'T APPEAR SOMEPLACE VERY STRANGE ON 2608 EM1913 C WHICH DOESN'T DO ANY HARDCLIPPING EM1913 C EM1913 CALL MOVE(IGCB,X1,Y1) EM1913 C EM1913 C NOW CALL FOR LABELS. LABELS ARE OUTPUT EVEN IF CORRESPONDING TICS EM1913 C AREN'T VISIBLE. THE ORDER IS ORIGIN,RIGHT OF ORIGIN, LEFT OF ORIGIN. EM1913 C SHUT OFF CLIPPING BEFORE DOING THE LABELING EM1913 C EM1913 CALL CLPOF(IGCB) EM1913 C EM1913 C SET UP SPACE BETWEEN MAJOR TICS (AND THEREFORE LABELS). EM1913 C EM1913 BETWN = ABS(P1)*XP5 EM1913 C EM1913 C FIRST OUTPUT LABEL AT ORIGIN,(IF ORIGIN IS OUTPUT),THEN TO RIGHT. EM1913 C FIND THE FIRST PART OF THE UPPER X AXIS(INCLUDING ORIGIN) WITHIN EM1913 C THE CLIPPING BOUNDARIES  EM1913 C EM1913 XYNOW = P3 EM1913 XYNOW(2) = P4 EM1913 26 IF (XYNOW.GE.X1) GO TO 27 EM1913 XYNOW = XYNOW + BETWN EM1913 GO TO 26 EM1913 C EM1913 C WE HAVE NOW GOTTEN ONTO THE BEGINNING OF THE AXIS AT LEAST SO EM1913 C NOW OUTPUT LABELS UNTIL WE ARE OFF UPPER END OF CLIPPED X AXIS EM1913 C EM1913 27 IF (XYNOW.GT.XEND) GO TO 28 EM1913 C EM1913 CALL LABAX(XP1,Y1,XYNOW,I,J,IGCB) EM1913 XYNOW = XYNOW + BETWN EM1913 GO TO 27 EM1913 C EM1913 C TO THE LEFT. FIND THE FIRST PART OF LOWER X AXIS WITHIN THE CLIPPING EM1913 C BOUNDARIES, GOING BACK TO ORIGIN EM1913 C EM1913 28 XYNOW = P3 EM1913 29 XYNOW = XYNOW - BETWN EM1913 IF (XYNOW.GT.XEND) GO TO 29 EM1913 C EM1913 C THEN KEEP OUTPUTTING LABELS UNTIL WE ARE OFF THE LOWER END OF THE EM1913 C CLIPPED LOWER X AXIS EM1913 C EM1913 31 IF (XYNOW.LT.X1) GO TO 32 EM1913 CALL LABAX(XP1,Y1,XYNOW,I,J,IGCB) EM1913 XYNOW = XYNOW - BETWN EM1913 GO TO 31 EM1913 C EM1913 C WE ARE FINISHED OUTPUTING LABELS FOR THE X AXIS, SO TURN CLIPPING EM1913 C BACK ON EM1913 C EM1913 32 CALL CLPON(IGCB) EM1913 C EM1913 C EM1913 C ********Y AXIS*** EM1913 C EM1913 CALL LINE(IGCB,0) EM1913 C EM1913 C DRAW AXIS UNLESS ALL CLIPPED BECAUSE THE ORIGIN IS OUT OF WINDOW. EM1913 C EM1913 30 IF (P3.LT.X1) GO TO 35 EM1913 IF (P3.GT.XEND) GO TO 35 EM1913 C EM1913 C EM1913 C NO, NOT ALL CLIPPED SO DRAW AXIS EM1913 C EM1913 CALL MOVE(IGCB,P3,Y1) EM1913 CALL DRAW(IGCB,P3,YEND) + EM1913 C EM1913 C EM1913 C IF THERE AREN'T ANY TICS OR GRIDS, WE ARE DONE WITH THIS AXIS EM1913 C EM1913 35 IF (XP2.EQ.0.) GO TO 45 EM1913 C EM1913 C EM1913 C SET UP ARRAY CONTAINING ORIGIN POINTS FOR SUBROUTINE CALLS EM1913 C EM1913 XYORG(1) = P4 EM1913 XYORG(2) = P3 EM1913 I = 2 EM1913 J = 1 EM1913 C EM1913 C EM1913 C SET UP SPACE BETWEEN TICS FOR THE UPPER DIRECTION EM1913 C EM1913 BETWN = ABS(P2) EM1913 C EM1913 C EM1913 C SET UP TIC MARK SIZE FOR MINOR TICS (SAME AS MAJOR TIC OFFSET TO EM1913 C ONE SIDE.) THIS WILL BE 0 FOR GRID CALLS WISHING GRID LINES AT MINOR EM1913 C TIC MARKS AS WELL AS MAJOR EM1913 C EM1913 TICSZ = (XP7*AP)/A C ' EM1913 C EM1913 C SEPARATE INTO GRIDS AND TICS. EM1913 C EM1913 C CALL FOR TIC OR GRID MARKS ON UPPER AND LOWER HALVES, IF THERE EM1913 C IS ANY AXIS THERE CHANGING DIRECTION OF SPACE BETWEEN TICS FOR LOWER EM1913 C HALF. EM1913 C EM1913 IF(P4.LT.YEND)CALL G1TIC(IGCB,IND,X1,XEND,Y1,YEND,XYORG,I,J, EM1913 1 BETWN,TICSZ,XP6) EM1913 BETWN = -1. * BETWN EM1913 IF(P4.GT.Y1)CALL G1TIC(IGCB,IND,X1,XEND,YEND,Y1,XYORG,I,J,BETWN, EM1913 1 TICSZ,XP6) EM1913 C EM1913 C EM1913 C****LABELS FOR Y AXIS*************************************** EM1913 C EM1913 C CHECK TO SEE IF LABELS WANTED EM1913 C EM1913 IF (IND.EQ.1.OR.IND.EQ.3) GO TO 45 EM1913 C EM1913 C NOW MOVE TO EDGE OF SURFACE, SO IF LABELS ARE OUTPUT OUTSIDE OF HARD EM1913 C CLIP LIMITS, THEY WON'T APPEAR SOMEPLACE VERY STRANGE ON 2608 WHEN EM1913 C THE MOVES ARE SURPRESSED EM1913 C EM1913 CALL MOVE(IGCB,X1,Y1) EM1913 C C EM1913 C NOW CALL FOR LABELS. LABELS ARE OUTPUT EVEN IF CORRESPONDING TICS EM1913 C AREN'T VISIBLE EM1913 C SHUT OFF CLIPPING BEFORE DOING THE LABELING EM1913 C EM1913 CALL CLPOF(IGCB) EM1913 C EM1913 C SET UP SPACE BETWEEN MAJOR TICS (AND THEREFORE LABELS). EM1913 C EM1913 BETWN = ABS(P2)*XP6 EM1913 C EM1913 C FIRST OUTPUT LABEL AT ORIGIN,(IF ORIGIN IS VISIBLE),THEN TO RIGHT. EM1913 C FIND THE FIRST PART OF THE UPPER Y AXIS (ORIGIN INCLUDED) WITHIN EM1913 C CLIPPING BOUNDARIES. EM1913 C EM1913 XYNOW = P4 EM1913 XYNOW(2) = P3 EM1913 126 IF (XYNOW.GE.Y1) GO TO 127 EM1913 XYNOW = XYNOW + BETWN EM1913 GO TO 126 EM1913 C EM1913 C WE HAVE GOTTEN ONTO THE BEGINNING OF THE AXIS AT LEAST,SO EM1913 C NOW OUTPUT LABELS UNTIL WE ARE OFF UPPER END OF CLIPPED Y AXIS EM1913 C EM1913 127 IF (XYNOW.GT.YEND) GO TO 128 EM1913 CALL LABAX(XP2,X1,XYNOW,I,J,IGCB)  EM1913 XYNOW = XYNOW + BETWN EM1913 GO TO 127 EM1913 C EM1913 C TO THE LEFT. FIND THE FIRST PART OF LOWER Y AXIS WITHIN THE CLIPPING EM1913 C BOUNDARIES, GOING BACK TO ORIGIN EM1913 C EM1913 128 XYNOW = P4 EM1913 129 XYNOW = XYNOW - BETWN EM1913 IF (XYNOW.GT.YEND) GO TO 129 EM1913 C EM1913 C THEN KEEP OUTPUTTING LABELS UNTIL WE ARE OFF THE LOWER END OF THE EM1913 C CLIPPED LOWER Y AXIS EM1913 C EM1913 131 IF (XYNOW.LT.Y1) GO TO 132 EM1913 CALL LABAX(XP2,X1,XYNOW,I,J,IGCB) EM1913 XYNOW = XYNOW - BETWN EM1913 GO TO 131 EM1913 C EM1913 C WE ARE FINISHED OUTPUTING LABELS FOR THE Y AXIS, SO TURN CLIPPING EM1913 C BACK ON EM1913 C EM1913 132 CALL CLPON(IGCB) EM1913 C EM1913 C WE ARE DONE WITH OUTPUTTING THE AXES AND LABELS. EM1913 C EM1913 C  EM1913 C RESET LINE TYPE AND LDIR C 45 CALL LINE(IGCB,IBUFR,XLNTH) CALL LDIR(IGCB,THETA) CALL LORG(IGCB,LRG) C C RESET STATUS WORD BIT INDICATING WHETHER OR NOT LINESTYLE CALLED EM1901 C BY USER PROGRAM EM1901 CALL GRSTS(WRITE,173777B,LNSET) EM1901 C CALL GCBIM(30,1,IERCD,0,2) RETURN END C C EM1913 C********************************************************************* EM1913 C EM1913 C EM1913 C EM1913 SUBROUTINE G1TIC(IGCB,LIND,BTTOM,TOP,ABEG,AEND,XYORG, EM1913 1I,J,TICSP,TICSZ,XP56), 92840-16001 REV.2013 800123 EM2013 C EM1913 C EM1913 C THE PARAMENTERS ARE AS FOLLOWS: EM1913 C EM1913 C IGCB - THE GRAPHICS CONTROL BLOCK EM1913 C LIND - CALL INDICATOR. 1=AXES 2=LAXES 3=GRID 4=LGRID EM1913 C 1 & 3 HAVE NO LABELS 2 & 4 HAVE LABELS EM1913 C BTTOM - THE BOTTOM OR BEGINNING OF THE OTHER AXIS. EM1913 C EM1913 C TOP - THE TOP OR END OF THE OTHER AXIS. GRIDS STRETCH FROM EM1913 C TOP TO BOTTOM. EM1913 C ABEG - THE BEGINNING OF THE AXIS ON WHICH TIC MARKS ARE MADE EM1913 C AEND - THE END OF THE AXIS WITH WHICH YOU ARE WORKING. EM1913 C XYORG - THE X AND Y VALUES AT THE 'ORIGIN' WHERE THE EM1913 C AXES CROSS. XYORG(1) IS THE VALUE FOR THE AXIS EM1913 C ON WHICH THE TIC MARKS ARE BEING MADE. EM1913 C I,J - INDICES FOR XYORG. I IS THE INDEX FOR THE X VALUE EM1913 C AND J IS THE Y VALUE INDEX. EM1913 C TICSP - SPACE BETWEEN TICS. IF LT 0 THEN WE ARE GOING LEFT, EM1913 C ELSE RIGHT. SHOULD NEVER BE CALLED WITH 0. EM2013 C TICSZ - MAJOR TIC OFFSET FROM AXIS, THEREFORE WHOLE LENGTH EM1913 C OF MINOR TIC. THIS WILL BE 0 FOR GRID CALLS WISHING EM1913 C GRID MARKS AT MINOR TIC MARKS. EM1913 C XP56 - THE NUMBER OF TICS PER MAJOR TIC MARK., EITHER P5 OR P6 EM2013 C FROM AXES-LAXES-GRID-LGRID CALL. SHOULD ALWAYS BE EM2013 C CALLED WITH VALUE > 0. EM2013 C EM1913 C EM1913 C EM1913 DIMENSION XYORG(2),XYNOW(2) EM1913 LOGICAL LCHNG EM1913 C EM1913 C WE ASSUME COMING IN THAT LINESTYLE = 0 EM1913 C EM1913 C WE ARE GOING TO CHANGE THE VALUE OF THESE PARAMETERS SO MAKE COPIES EM1913 C EM1913 TSPACE = TICSP EM1913 TNUMB = XP56 = EM1913 C EM1913 C THE SIGN OF THE SPACING IS A FUNCTION OF WHETHER WE ARE EM1913 C GOING UP OR DOWN THE AXIS, SETTING DIR TO 1 FOR UP, -1 FOR DOWN. EM1913 C EM1913 DIR = 1. EM1913 IF (TSPACE.LT.0.) DIR = -1. EM1913 C EM1913 C NOW THAT DIR IS DETERMINED SET UP CONSTANTS EM2013 C EM2013 DABEG = DIR * ABEG EM2013 DAEND = DIR * AEND EM2013 EM2013 C EM1913 C HALVE TICSZ TO GET MINOR TIC OFFSET FROM AXIS EM1913 C EM1913 ITICS = 0 EM1913 SZMIN = TICSZ/2. EM1913 XYNOW = XYORG EM1913 XYNOW(2) = XYORG(2) EM1913 C EM1913 C EM1913 C NOW SEPARATE INTO GRIDS AND TICS (GRID-LGRID AND AXES-LAXES) EM1913 C EM1913 IF (LIND.GT.2) GO TO 101 EM1913 C EM1913 C*******AXES WITH TICS************************** EM1913 C EM1913 C PREPARE TO OUTPUT A TIC. FIRST SEE THAT THE TICS REACH INTO SEEN EM1913 C REGION AT LEAST PARTIALLY. IF NO TICS WILL BE SEEN, WE ARE FINISHED. EM1913 C EM1913 IF ((XYNOW(2)+TICSZ).LT.BTTOM) GO TO 1000 EM1913 IF ((XYNOW(2)-TICSZ).GT.TOP) GO TO 1000 EM1913 C EM2013 C IF THERE ARE ONLY MAJOR TICS, SKIP OVER MINOR TIC CODE EM2013 C EM2013 IF (TNUMB.EQ.1.) GO TO 5 EM1913 C EM1913 C EM1913 C SEE IF THE MINOR TICS WILL BE SEEN ( MAJOR WILL SINCE WE GOT TO EM1913 C THIS POINT ). IF NOT, ONLY OUTPUT MAJOR. EM1913 C EM1913 IF ((XYNOW(2)+SZMIN).LT.BTTOM) GO TO 2 EM1913 IF ((XYNOW(2)-SZMIN).GT.TOP) GO TO 2 EM1913 GO TO 5 EM1913 C EM1913 C EM1913 C ONLY MAJOR TICS, SO SET UP ITICS & SPACING. EM1913 C EM1913 2 TSPACE = TSPACE * TNUMB EM1913 TNUMB = 1. EM1913 C E EM1913 C EM1913 C NEXT, SEE THAT WE'RE NOT OFF THE AXIS. IF WE ARE 'IN BACK OF' THE EM1913 C VISIBLE AXIS BECAUSE THE AXIS IS CLIPPED, KEEP MOVING UNTIL WE'RE EM1913 C ON, KEEPING TRACK OF MAJOR & MINOR COUNT. IF WE ARE OUT OFF THE END, EM1913 C RETURN BECAUSE WE ARE FINISHED. EM1913 C EM1913 5 XYNOW = XYNOW+ TSPACE EM1913 IF (DIR*XYNOW.GE.DABEG) GO TO 7 EM2013 C EM1913 ITICS = ITICS + 1 EM1913 IF (ITICS.EQ.TNUMB) ITICS = 0 EM1913 GO TO 5 EM1913 7 IF (DIR*XYNOW.GT.DAEND) GO TO 1000 EM2013 C EM1913 C EM1913 C INCREMENT TIC COUNT AND SEE IF MAJOR TIC. EM1913 C EM1913 ITICS = ITICS + 1 EM1913 IF (ITICS.NE.TNUMB) GO TO 10 EM1913 C EM1913 C EM1913 C SET UP A MAJOR TIC EM1913 C EM1913 SZTIC = TICSZ EM1913 ITICS = 0 EM1913 GO TO 20  EM1913 C EM1913 C EM1913 C SET UP A MINOR TIC EM1913 C EM1913 10 SZTIC = SZMIN EM1913 C EM1913 C EM1913 C OUTPUT A TIC, EITHER A MAJOR OR MINOR EM1913 C EM1913 20 XYNOW(2) = XYORG(2) + SZTIC EM1913 CALL MOVE(IGCB,XYNOW(I),XYNOW(J)) EM1913 XYNOW(2) = XYORG(2) - SZTIC EM1913 CALL DRAW(IGCB,XYNOW(I),XYNOW(J)) EM1913 C EM1913 C EM1913 C PREPARE FOR NEXT OUTPUTTING HERE SO CAN BYPASS CHECK ENSURING THAT EM1913 C WE ARE ON BEGINNING OF AXIS. EM1913 C EM1913 XYNOW = XYNOW + TSPACE EM1913 GO TO 7 EM1913 C EM1913 C C******GRIDS WITH GRIDLINES AND POSSIBLY MINOR TICS EM1913 C EM1913 C PREPARE TO OUTPUT A GRID. IF ALL GRID LINES EM1913 C ARE MAJOR, WE NEVER CHANGE LINESTYLE AND LCHNG=FALSE. & EM1913 C EM1913 101 LCHNG = .FALSE. EM1913 IF (TNUMB.EQ.1.) GO TO 105 EM1913 C EM1913 C EM1913 C IF MINOR TICS EXIST BUT ARE REALLY GRID LINES, SET UP LINESTYLE EM1913 C AND LNCHNG=TRUE. EM1913 C EM1913 IF (TICSZ.EQ.0.) GO TO 104 EM1913 C EM1913 C EM1913 C NOW MINOR TICS EXIST AND ARE NOT GRID LINES, SO CHECK TO SEE THAT EM1913 C THEY WILL BE SEEN AND DELETE IF NOT. EM1913 C EM1913 IF ((XYNOW(2)+SZMIN).LT.BTTOM) GO TO 102 EM1913 IF ((XYNOW(2)-SZMIN).GT.TOP) GO TO 102 EM1913 GO TO 105 EM1913 C EM1913 102 TSPACE = TSPACE * TNUMB EM1913 TNUMB = 1. EM1913 GO TO 105 EM1913 C EM1913 104 LCHNG = .TRUE. EM1913 CALL LINE(IGCB,1) EM1913 C EM1913 C P EM1913 C NEXT, SEE THAT WE'RE NOT OFF THE AXIS. IF WE ARE 'IN BACK OF' THE EM1913 C VISIBLE AXIS BECAUSE THE AXIS IS CLIPPED, KEEP MOVING UNTIL WE'RE ON, EM1913 C KEEPING TRACK OF MAJOR/MINOR COUNT. IF WE ARE OFF THE END, EM1913 C RETURN BECAUSE WE ARE FINISHED. EM1913 C EM1913 105 XYNOW = XYNOW+ TSPACE EM1913 IF (DIR*XYNOW.GE.DABEG) GO TO 107 EM2013 ITICS = ITICS + 1 EM1913 IF (ITICS.EQ.TNUMB) ITICS = 0 EM1913 GO TO 105 EM1913 107 IF (DIR*XYNOW.GT.DAEND) GO TO 999 EM2013 C EM1913 C EM1913 C INCREMENT GRID COUNT AND SEE IF MAJOR GRID. EM1913 C EM1913 ITICS = ITICS + 1 EM1913 IF (ITICS.NE.TNUMB) GO TO 110 EM1913 C EM1913 C EM1913 C OUTPUT A MAJOR GRID LINE EM1913 C EM1913 IF (LCHNG) CALL LINE(IGCB,0) EM1913 ITICS = 0 EM1913 XYNOW(2) = BTTOM EM1913 CALL MOVE(IGCB,XYNOW(I),XYNOW(J)) / EM1913 XYNOW(2) = TOP EM1913 CALL DRAW(IGCB,XYNOW(I),XYNOW(J)) EM1913 IF (LCHNG) CALL LINE(IGCB,1) EM1913 XYNOW = XYNOW + TSPACE EM1913 GO TO 107 EM1913 C EM1913 C EM1913 C DECIDE BETWEEN A MINOR TIC OR MINOR GRIDLINE EM1913 C EM1913 110 IF (LCHNG) GO TO 120 EM1913 C EM1913 C WE WANT ACTUAL TICS FOR MINOR MARKS EM1913 C EM1913 XYNOW(2) = XYORG(2) + SZMIN EM1913 CALL MOVE(IGCB,XYNOW(I),XYNOW(J)) EM1913 XYNOW(2) = XYORG(2) - SZMIN EM1913 CALL DRAW(IGCB,XYNOW(I),XYNOW(J)) EM1913 XYNOW = XYNOW + TSPACE EM1913 GO TO 107 EM1913 C C C WE WANT GRID LINES IN LINESTYLE = 1 FOR MINOR MARKS EM1913 C EM1913 120 XYNOW(2) = BTTOM EM1913 CALL MOVE(IGCB,XYNOW(I),XYNOW(J)) EM1913 XYNOW(2) = TOP EM1913 CALL DRAW(IGCB,XYNOW(I),XYNOW(J)) EM1913 XYNOW = XYNOW + GTSPACE EM1913 GO TO 107 EM1913 C EM1913 C EM1913 C PUT LINE BACK THE WAY WE FOUND IT EM1913 C EM1913 999 IF (LCHNG) CALL LINE(IGCB,0) EM1913 C EM1913 1000 RETURN EM1913 END EM1913 END$ EM1913 { 7S 92840-18020 1913 S C0122 &GRID GRID & LGRID INTERFACE MOD            H0101 _ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GRID,LGRID INTFC MOD * SOURCE: 92840 - 18020 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GRID,7 92840-16001 REV.1913 790117 ENT GRID,LGRID EXT .OPTN,PLTER EXT AXELS * * THIS IS THE INTERFACE MODULE FOR AGL COMMANDS * GRID AND LGRID. * GRID NOP LDA .3 EM1913 STA CODE LDA GRID GRID1 JSB .OPTN DEF RTN PADR DEF PARM DEF M9 EM1913 DEF CODE DEF .1 IGCB IS REQUIRED PARAMETER DEF .7 SEVEN OPTIONAL PARAMETERS DEF DZER0 TOP OF LIST OF DEFAULTS DEF RETRN * RTN JMP ERROR JSB AXELS DEF END PARM BSS 9 END JMP RETRN,I * * LABELED AXES * LGRID NOP LDA .4 CODE = 4 EM1913 STA CODE LDA LGRID STA GRID JMP GRID1 * * PARAMETERS AND CONSTANTS- DO NOT CHANGE ORDER RETRN NOP * .0 OCT 0 D0 DEC 0. .3 OCT 3 EM1913 .4 OCT 4 EM1913 DZER0 DEF D0 DEF D0 DEF D0 DEF D0 DF1 DEF D1 DEF D1 DEF D0 .7 OCT 7 DF2 DEF .1 EM1913 M9 DEC -9 EM1913 .63 DE~  C 63 D1 DEC 1. .1 OCT 1 EM1913 * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .63 IGCB NOP RTNER JMP RETRN,I CODE NOP END R  8? 92840-18021 1901 S C0122 &GRIDS GRID & LGRID COMMANDS SRC             H0101 -1FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GRID,LGRID C SOURCE: 92840 - 18021 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE GRIDS(IND,IGCB ,P1,P2,P3, 1P4,P5,P6,P7), 92840-16001 REV.1901 781020 DIMENSION VAR(15),BEGIN(2),IBUFR(6) DIMENSION ICODE(4) INTEGER READ,WRITE,EFLG EQUIVALENCE (VAR,A),(VAR(2),B),(VAR(3),C),(VAR(4),D) EQUIVALENCE (VAR(5),X1),(VAR(6),Y1) EQUIVALENCE (AP,VAR(9)),(BP,VAR(10)),(CP,VAR(11)),(DP,VAR(12)) EQUIVALENCE (VAR(7),XEND),(VAR(8),YEND) EQUIVALENCE (BEGIN(2),BEG2) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3) EQUIVALENCE (IBUFR(5),THETA),(XLNTH,IBUFR(2)) EQUIVALENCE (IBUFR(4),LRG),(ICODE(4),LNTYP) C DATA READ/1/ DATA WRITE/2/ EM1901 DATA LNTYP/23/ C C THIS IS THE AGL MODULE FOR AGL COMMANDS GRID AND LGRID. C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANINGS FOR EACH AGL COMMAND: C C PARAMETER AGL COMMAND MEANING DEFAULT C P1 X-TIC SPACING 0-NO TICS C P2 " Y-TIC SPACING 0 C P3 " X-ORIGIN 0 C P4 " Y-ORIGIN 0. C P5 " X-MAJOR COUNT 1.0 C P6 " Y-MAJOR COUNT 1.0 C P7 CROSS SIZE 0(NO CROSS) C*********************************************************(**** C C DETERMINE UNITS MODE AND WHICH TRANSFORMATION CONSTANTS TO C USE. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN ICODE = IADCD(D) ICD2 = 9 ICD3 = 11 CALL GCBIM(ICODE,4,VAR,0,READ) CALL GCBIM(LNTYP,1,IBUFR,0,1) C C WE ARE PROBABLY GOING TO CALL SUBROUTINE 'LINE' IN THIS PROCEDURE EM1901 C WHICH WILL ALTER BIT 11 IN THE STATUS WORD. SAVE STATE OF THIS BIT EM1901 C FOR RESETTING, SO IT DOESN'T FALSELY INDICATE USER CALL TO 'LINE' EM1901 CALL GRSTS(READ,4000B,LNSET) EM1901 C C CONVERT MU TO GDUS FOR LABELLING C C C CLIP X(ORIGIN),Y(ORIGIN) USING EITHER S1,S2 OR V1,V2 AS LIMITS. C XEND = (XEND - B)/A YEND = (YEND - D)/C X1 = (X1 - B)/A Y1 = (Y1 - D)/C C C ABSOLUTIZE PARAMETERS C XP1 = P1 XP2 = P2 GO TO(10,20),IND 10 XP1 = ABS(P1) XP2 = ABS(P2) 20 XP5 = ABS(P5) XP6 = ABS(P6) XP7 = ABS(P7) C C NOW BEGIN TO DRAW THE AXES, FIRST THE X AXES AND TIC MARKS C THEN THE Y AXES AND TIC MARKS. C CALL MOVE(IGCB,X1,Y1) BEGIN = X1 BEG2 = Y1 TICSZ =(XP7 * CP)/C IF(XP1.NE.0.)GO TO 25 CALL LINE(IGCB,0) CALL DRAW(IGCB,XEND,Y1) GO TO 110 C C INVOKE SUBROUTINE TO DRAW AXES FIRST THE X AXIS C AND THEN THE Y AXIS. C 25 CALL SUBGD(IND,BEGIN,Y1,YEND,XEND,TICSZ,P3,XP1,XP5,1,2,IGCB) 110 BEGIN = Y1 BEG2 = X1 TICSZ =(XP7 * AP)/A CALL MOVE(IGCB,X1,Y1) IF(XP2.NE.0.)GO TO 35 CALL LINE(IGCB,0) CALL DRAW(IGCB,X1,YEND) GO TO 45 35 CALL SUBGD(IND,BEGIN,X1,XEND,YEND,TICSZ,P4,XP2,XP6,2,1,IGCB) C C RESET LDIR AND LINE TYPE C 45 CALL LINE (IGCB,IBUFR,XLNTH) CALL LORG(IGCB,LRG) CALL LDIR(IGCB,THETA) C C RESET STATUS OF 'LINE CALLED' BIT EM1901 CALL GRSTS(WRITE,173777B,LNSET) EM1901 C RETURN END SUBROUTINE SUBGD(IND,BEGIN,ST1,ST2,ENDPT,TCSZ,ORG,P12,P56, 1I,J,IB), 92840-16001 REV.1901 781020 C C NOTE - THIS SUBROUTINE DOES NOT PRESERVE THE STATUS OF THE EM1901 C 'LINE CALLED' BIT, BIT 11 OF THE STATUS WORD. THIS IS DONE EM1901 C BY SUBROUTINE GRIDS WHICH IS THE ONLY CALLER OF SUBGD AT THIS EM1901 C TIME. IF SUBGD IS CALLED BY ANY OTHER ROUTINE, PRESERVING EM1901 C MUST BE DONE EM1901 C DIMENSION BEGIN(2) INTEGER READ,WRITE,GRIFX C C C ST1 = Y1 OR X1 C ST2 = YEND,OR XEND C THIS SUBROUTINE IS RESPONSIBLE FOR DRAWING THE GRIDS FOR THE C GRID AND LGRID COMMANDS. C BEG1 = BEGIN IORG = 0 IFLG = 1 C K = 0 XP12 = ABS(P12) EPSI = .1 * XP12 TCNT = 0. BEG2 = BEGIN(2) C C SEE IF MINOR TICS NOT DESIRED AND IF SO DRAW A MAJOR TIC MARK C C C C THIS PORTION OF THE ROUTINE IS RESPONSIBLE FOR DRAWING THE C MAJOR AND MINOR TIC MARKS. IF THIS IS A LABELED AXES (LAXES) C CALL THE LABEL DRAWING SUBROUTINE (LABL) IS INVOKED. C 100 LIN = 1 IF(TCNT.EQ.P56.OR.BEGIN.EQ.ORG.OR.P56.EQ.1.0.OR.TCNT.EQ.0.0) 1LIN = 0 CALL LINE(IB,LIN) C C SEE IF LIGHT LINES OR TIC MARKS ARE DESIRED. C IF(TCSZ.EQ.0.AND.LIN.EQ.1)GO TO 50 IF(LIN.EQ.0)GO TO 50 CALL LINE(IB,0) TIC1 = BEG2 + TCSZ TIC2 = BEG2 - TCSZ IF(I.EQ.2)GO TO 52 CALL MOVE(IB,BEGIN,TIC2) GRIDX = BEGIN GRIDY = TIC1 GO TO 55 C C Y AXIS 52 CALL MOVE(IB,TIC2,BEGIN) GRIDX = TIC1 GRIDY = BEGIN GO TO 55 C C DETERMINE WHICH AXES IS BEING DRAWN I= 1 FOR X AXIS, =2 FOR Y AXISL C 50 GRIDX = BEGIN GRIDY = ST2 IF(I.EQ.1)GO TO 55 GRIDX = ST2 GRIDY = BEGIN C C AVOID DRAWING OVER PREVIOUS X AXIS C 55 IF(K.EQ.0)GO TO 57 CALL DRAW(IB,GRIDX,GRIDY) 57 CALL MOVE(IB,BEGIN(I),BEGIN(J)) TCNT = TCNT + 1.0 C K = 1 C NOW SEE IF WE SHOULD DRAW A LABEL C IF(LIN.EQ.1)GO TO 200 IF(IORG.GE.0)TCNT = 1. IF(IND.NE.2)GO TO 200 CALL LABAX(P12,ST1,BEGIN,I,J,IB) C C C C COMPUTE X OR Y + (TIC SPACING) C 200 BEGIN = BEGIN + XP12 C C C DRAW LINE TO NEXT TIC MARK. C 205 CALL LINE(IB,0) IF(IORG.LT.0)GO TO 350 IF(BEGIN.GE.ORG .AND.ORG.GE.BEG1.AND.IORG.EQ.0)GO TO 300 250 CALL DRAW (IB, BEGIN(I),BEGIN(J)) IFLG = 2 IF(BEGIN.LE.ENDPT)GO TO 100 IF(ABS(BEGIN - ENDPT).GT.EPSI)RETURN C GO TO 100 C C FIRST SEE IF IFLG =1 FOR BEGINNING C 300 IF(IFLG.EQ.2)GO TO 310 IORG = 1 GO TO 250 C C CHECK TO SEE IF MAJOR TIC HAS ALREADY BEEN DONE C 310 SAVBG = BEGIN IORG = -1 BEGIN = ORG GO TO 250 C C C 350 BEGIN = SAVBG IT1 = GRIFX(BEGIN) IT2 = GRIFX(ORG) IF(TCNT.GT.P56.OR.IT1.GT.IT2)TCNT = TCNT - 1.0 IF(TCNT.EQ.P56.AND.IT1.LE.IT2)TCNT = 1.0 IF(IT1.EQ.IT2) BEGIN = BEGIN + XP12 IORG = 1 GO TO 250 C C END  9B 92840-18022 1819 S C0122 ABS PLT INT MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PLOT * SOURCE: 92840 - 18022 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PLOT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * PLOT. * EXT PLOTA,.OPTN,PLTER ENT PLOT * * PLOT NOP LDA .1 PLT STA CODE LDA PLOT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF CODE DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .1 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB PLOTA DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .47 IGCB NOP RTNER JMP RETRN,I * * * CHARACTER PLOT * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 .47 DEC 47 CODE NOP * END  :@ 92840-18023 1819 S C0122 ABS PLOT CMND              H0101 #FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: PLOT ABSOLUTE C SOURCE: 92840 - 18023 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE PLOTA(IND,IGCB,X,Y, 1PCNTL), 92840-16001 REV.1819 780515 INTEGER PCNTL,READ,WRITE,ICODE(2) C C C THIS IS THE FUNCTIONAL FOR THE AGL COMMANDS PLOT AND CPLOT C DATA READ/1/ DATA WRITE/2/ DATA ICHR/7/ DATA LDIR/22/ C IFLG = 0 ISTAT = 0 IST1 = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C CALL GRSTS(1,200B,ISTAT) XNEW = X YNEW = Y C C C NOW ASCERTAIN FROM THE PEN-CONTROL PARAMETER (PCNTL) WHAT C ACTIONS TO TAKE. THE FOLLOWING MODES ARE DEFINED FOR THE C PEN CONTROL PARAMETER: C C EVEN = PEN UP C ODD = PEN DOWN C + = PEN CHANGE AFTER MOTION C - = PEN CHANGE BEFORE MOTION C 10 IPC = IAND( IABS(PCNTL),1) + 1 IF(PCNTL.LT.0)GO TO 100 C C GO TO BRANCH FOR < 0 OR > = 0 C GO TO(70,75),IPC C C EVEN C 70 IF(ISTAT.NE.0)GO TO 85 C C 80 CALL MOVE(IGCB,XNEW,YNEW) IF(PCNTL.GT.0.AND.IPC.EQ.2)CALL PENDN(IGCB) C RETURN C C ODD C 75 IF(ISTAT.EQ.0)GO TO 80 85 CALL DRA  W(IGCB,XNEW,YNEW) IF(PCNTL.GE.0.AND.ISTAT.NE.0.AND.IPC.EQ.1)CALL PENUP(IGCB) RETURN C C PCNT LT 0 C 100 GO TO(80,85),IPC C END  ;B 92840-18024 1819 S C0122 ABS DRAW              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: ABSOLUTE DRAW C SOURCE: 92840 - 18024 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDRAW(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER GICB,DRPPN,READ,WRITE,PLTAB,GRIFX DIMENSION ICODE(3),VAR(12),IBUFR(8),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (IBUFR(5),DRPPN),(IBUFR(6),IB6) EQUIVALENCE (IBUFR(7),IB7),(IBUFR(8),IB8) EQUIVALENCE (VAR(9),XOLD),(VAR(10),YOLD) EQUIVALENCE (VAR(11),XNEW),(VAR(12),YNEW) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE (CLPTS,CLP1),(CLPTS(2),CLP2) C C C C THIS IS THE CORE MODULE FOR ABSOLUTE DRAWS C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA GICB/16/ DATA DRPPN/21000B/ DATA PLTAB/21402B/ C IFLG = 0 ISTAT = 0 IB6 = PLTAB CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU  ), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS ON. C ICD3 = 18 CALL GCBIM(ICODE,3,VAR, 0,READ) C C C C COMPUTE NEW POINTS AND CLIP AWAY THE FAT C XNEW =(A* X + B) YNEW = C * Y + D C C WRITE(6,3000)X,Y C000 FORMAT(2X,2(X,F10.3)) C C C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD, CLPTS,V5,IFLG) C WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2,CLP3,CLP4 C WRITE(6,1000)IFLG C000 FORMAT(2X,"IFLG = ",I4) C500 FORMAT("DRAW",2X,8(X,F5.2)) 22 IF(IFLG)600,100,600 C C NOW DROP-PEN AND MAKE A MARK C 100 IB3 = GRIFX(CLP1) IB4 = GRIFX(CLP2) IB7 = GRIFX(CLP3) IB8 = GRIFX(CLP4) IF(CLP1.EQ.XOLD.AND.CLP2.EQ.YOLD)GO TO 56 CALL OUTPT(4,IBUFR,2) GO TO 600 56 CALL OUTPT(2,DRPPN,2) C C SET STATUS WORD TO INDICATE PEN DOWN AND SET NEW POINTS C INTO GCB. 600 CALL GRSTS(2,67577B,10200B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20,8) C C CHECK FOR PREVIOUS CALL TO PORG (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$  <C 92840-18025 1819 S C0122 ABS MOVE              H0101 ؆FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: MOVE ABSOLUTE C SOURCE: 92840 - 18025 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XMOVE(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER PLTAB,GRIFX DIMENSION CLPTS(4) DIMENSION IBUFR(4),VAR(12),ICODE(3) EQUIVALENCE (VAR,A),(VAR(2),B),(VAR(3),C),(VAR(4),D) EQUIVALENCE (IBUFR,LFTPN),(VAR(5),V5),(VAR(9),XOLD) EQUIVALENCE (VAR(11),XNEW),(VAR(12),YNEW) EQUIVALENCE (IBUFR(2),PLTAB),(IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (CLP3,CLPTS(3)),(CLP4,CLPTS(4)) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3) C DATA LFTPN/20400B/ DATA PLTAB/21402B/ C C THIS IS THE MODULE FOR PROCESSING ABSOLUTE MOVES. C ISTAT = 0 IFLG = 0 IST1 = 0 ICD3 = 18 C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN ICODE = IADCD(D) ICD2 = IS1V1(D) CALL GCBIM(ICODE,3,VAR,0,1) C C COMPUTE NEW POINTS. C XNEW = (A * X) + B YNEW = (C * Y) + D C C CALL CLPNG(XOLD,CLPTS,V5,IFLG) IF(IFLG.NE.0)GO TO 20 10 IB3 = GRIFX(CLP3) IB4 = GRIFX(CLP4) CALL OUTPT(2,IBUFR,2) C C PUT NEW POINTS INTO GCB AND SET STATUS WORD = PENUP. C 20 CALL GCBIM(18,1,XNEW,4,2) CALL GRSTS(2,67577B,10000B) C C SET SOFT ERROR IF POINT OUTSIDE CLIPPING BOUNDARY C _   IF(IFLG.EQ.1)CALL PLTER(20,8) C C CHECK FOR PREVIOUS CALL TO PORG (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$ T  =D 92840-18026 1819 S C0122 PEN LINE INT MOD              H0101 81ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PEN AND LINE INTFC MOD * SOURCE: 92840 - 18026 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PEN,7 92840-16001 REV.1819 780515 ENT PEN,LINE EXT PLTSU,.OPTN,PLTER * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMANDS PEN * AND LINE-TYPE. * PEN NOP LDA .64 STA ERCOD LDA PEN JSB .OPTN GET PARAMETERS DEF RTN PADR DEF PARM PARAMETER BUFFER DEF M4 DEF .1 CODE DEF .2 # OF PARAMETERS DEF .0 # OF DEFAULTS DEF RETRN RTN JMP ERROR ENTRY JSB PLTSU FUNCTIONAL MODULE DEF END PARM BSS 4 END JMP RETRN,I * * LINETYP[(LINE TYPE #)[,(LENGTH)]] * LINE NOP LDA .65 STA ERCOD LDA LINE JSB .OPTN DEF RTN1 DEF PARM DEF M4 DEF .2 CODE DEF .1 NO REQUIRED PARAMETERS DEF .1 # OF DEFAULTS DEF DZER0 DEFAULTS DEF RETRN RTN1 JMP ERROR JMP ENTRY * * *CONSTANTS AND TEMPORARY STORAGE * .0 OCT 0 OCT 0 DZER0 DEF .0 DEF .0 .2 OCT 2 M4 OCT -4 .64 DEC 64 .65 DEC 65 .1 OCT 1 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP DEF ERCOD RTNER JMP RETRN,I RETRN NOP ERCOD NOP END    >E 92840-18027 1819 S C0122 PEN & LINE CMNDS              H0101 3FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: LINE AND PEN (PLOT SETUP) C SOURCE: 92840 - 18027 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE PLTSU(IND,IGCB,P1), 92840-16001 REV.1819 780515 INTEGER P1,SELPN,SELP0 INTEGER DFLIN DIMENSION NCODE(2),IBUFR(4),VAR(4) EQUIVALENCE (IBUFR(2),IB2),(IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (XLIN,IB3) DATA NCODE/15000B,15400B/ DATA IADP/11/ DATA DFLIN/17401B/ DATA LINT/20003B/ DATA NUMPN/16401B/ DATA SELPN/16001B/ DATA NUMPH/30001B/ DATA SELP0/14400B/ C C THIS ROUTINE PROCESSES THE AGL COMMANDS PEN(P1) AND C LINE(P1,P2).WHERE P1 FOR PEN IS THE PEN NUMBER AND C P1 FOR LINE IS THE LINE-TYPE NUMBER. PARAMETER P2 IS C THE LENGTH OF THE LINE. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C P2 = 0. IB3 = 0 ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN GO TO (10,20),IND C C DETERMINE IF PEN INDICATES -1 FOR ERASE OR -2 FOR COMPLEMENT C 10 IF(P1.GE.0)GO TO 15 IERR = 29 IP1 = -P1 IF(IP1.NE.1. AND.IP1.NE.2)GO TO 800 CALL OUTPT(1,NCODE(IP1),2) RETURN C C GET THE NUMBER OOF PENS AVAILABLE AND COMPUTE C PEN# MODULO #PENS IF P1 > #PENS. C 15 CALL OUTPT(1,NUMPH,1) CALL GCBIM(16,1,IB3,0,1) CALL GRSTS(1,4000B,ISUSP) C C IF THE NUMBER OF PHYSICAL PENS IS EQ 1   AND A PREVIOUS LINE C TYPE HAS BEEN SELECTED DO NOTHING. C NUMPN = LOGICAL PENS, NUMPH = PHYSICAL PENS C IF(ISUSP.NE.0.AND.IB3.EQ.1)GO TO 17 IB2 = P1 CALL OUTPT(1,NUMPN,1) CALL GCBIM(16,1,IB4,0,1) IF(P1.NE.0.AND.IB3.EQ.1)IB2 = P1 -1 IF(P1.GT.IB4.AND.IB3.EQ.1)IB2 = MOD(IB2,IB4) + 1 IF(P1.GT.IB3.AND.IB3.GT.1)IB2 = MOD(P1,IB3) + 1 IBUFR = SELPN IF(P1.EQ.0)IBUFR = SELP0 CALL OUTPT(1,IBUFR,2) RETURN C 17 CALL GCBIM(31,1,IB2,1,1) GO TO 600 C C LINE TYPE - MAXIMUM OF 6 PREDEFINED LINE TYPES C 20 IERR = 21 IF(P1.GT.6.OR.P1.LT.0)GO TO 800 IB2 = P1 C C SEE IF WE USE DEFAULT LINE TYPE C CALL GCBIM(IADP,1,VAR,0,1) C C CONVERT GDUS TO MUS C C XLIN = VAR * P2 C IBUFR = LINT C C PUT LINE TYPE AND LENGTH INTO GCB C 25 CALL GCBIM(31,1,IB2,0,2) CALL GRSTS(2,73777B,4000B) 600 IBUFR = DFLIN CALL OUTPT(1,IBUFR,2) RETURN 800 CALL PLTER(IERR,40) IF(IERR.EQ.29)RETURN IB2 = 0 GO TO 25 END  ?F 92840-18028 1819 S C0122 PDIR LDIR IN MOD              H0101 ,:ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PDIR AND LDIR * SOURCE: 92840 - 18028 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PDIR,7 92840-16001 REV.1819 780515 ENT LDIR,PDIR EXT .OPTN,LPDIR,PLTER * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMANDS * PDIR AND LDIR. * PDIR NOP CLA,INA CODE FOR PDIR(THETA) STA CODE LDA .59 STA ERCOD LDA PDIR PD1 JSB .OPTN DEF RTN PADR DEF PARM DEF M4 DEF CODE DEF .2 IGCB AND ANGLE DEF .1 ACTUALLY NO DEFAULTS ADDRESS IS USED FOR ERROR CHECKING DF0 DEF DZER0 DEF RETRN RTN JMP ERROR LDA PARM+3 CPA DZER0 JMP ENTRY ISZ CODE ENTRY JSB LPDIR DEF END PARM BSS 4 END JMP RETRN,I * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * LDIR NOP LDA .3 STA CODE LDA .58 STA ERCOD LDA LDIR JMP PD1 * DZER0 DEF .0 .0 OCT 0 CODE NOP RETRN NOP .1 OCT 1 .3 OCT 3 M4 DEC -4 .2 OCT 2 ERCOD NOP .58 DEC 58 .59 DEC 59 END  @F 92840-18029 2013 S C0122 &LPDIR              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: LDIR,PDIR C SOURCE: 92840 - 18029 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE LPDIR(IND,IGCB,P1,P2), 92840-16001 REV.2013 790904 DIMENSION IBUFR(5),VAR(4) EQUIVALENCE (IBUFR(2),IB2,X),(IBUFR(4),Y) EQUIVALENCE(VAR,A),(VAR(2),B),(VAR(3),C),(VAR(4),D) DATA LDIR/7002B/ DATA LDIRT/22/ DATA IPDIR/19/ XTEST =2.**14 C C 4-24-79 NOTE FROM STEVE YOUNG: AS OF NOW, THE ONLY WAY THIS CALL C IS USED IS TO PROCESS A CALL TO LDIR, WITH THE PARAMETER BEING AN C ANGLE. THEREFORE, IND = 3, P1 = AN ANGLE, AND P2 DOESN'T MATTER. C C THIS ROUTINE IS RESPONSIBLE FOR PROCESSING THE AGL COMMANDS C LDIR (LABEL DIRECTION) AND PDIR (PLOT DIRECTION). C THE IND INDICATES WHETHER THE PARAMETER IS AN ANGLE(RADIANS) C OR X AND Y COMPONENTS. C C IND P1 P2 C 1 THETA - PDIR C 2 X COMP Y COMP " C 3 THETA - LDIR C 4 X Y " C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C CONVERT P1 P2 TO CURRENT UNITS C IBUFR = IADCD(D) CALL GCBIM(IBUFR,1,VAR,0,1) GO TO(5,50,5,50),IND 50 X = P1 * A Y = P2 * C 5 GO TO(10,20,30,40),IND C C CHECK FOR OVERFLOW C 10 XSC = P1/3.1414 XSIN =d .5 * ABS(XSC + .5) XCOS = .5 * ABS(XSC) IF(XSIN.GT.XTEST.OR.XCOS.GT.XTEST)GO TO 800 IF(P1.GT.6.28)CALL PLTER(30) X = COS(P1) Y = SIN(P1) GO TO 25 C C USE GOOD OLD PYTHAGOREAN THEOREM TO COMPUTE SIN AND COSINE C 20 DENOM = SQRT(X**2 + Y**2) IF(DENOM.EQ.0.)GO TO 25 X = X/DENOM Y = Y/DENOM 25 CALL GCBIM(IPDIR,1,X,0,2) RETURN C C PROCESSING FOR LDIR C C FIRST SEE IF X OR Y = 0 AND IF SO MUST DETERMINE C ANGLE BY SUREPTITIOUS MEANS. C C + Y=+ C + X=0 C + C + C + C + C X= - + C Y = 0 + C +++++++++++++++++++++++++++++++++++++++ Y=0,X=+ C + C + C + C + C + C + C + C + Y = - C + X = 0 C C 40 IF(X.EQ.0.0.OR.Y.EQ.0.)GO TO 45 X = ATAN(Y/X) GO TO 35 45 IF(X)60,75,70 60 X = 3.14 GO TO 35 70 X = 0. GO TO 35 75 X= 1.57 IF(Y.LT.0.)X = 4.71 GO TO 35 C C AT THIS POINT THEANGLE HAS BEEN DETERMINED C 30 X = P1 35 IF(ABS(X).LE.6.28)GO TO 36 CALL PLTER(30) X = AMOD(X,6.28) 36 IF(X.LT.0.)X= 6.28 - ABS(X) IF(X.EQ.6.28)X = 0.0 C ***************************************************************** C OUTPUT A MESSAGE TO THE DEVICE TO SET THE PROPER LDIR, AND STORE C THE HARDWARE AND THE SOFTWARE LDIR INTO THE GCB. C IBUFR = LDIR CALL OUTPT(1,IBUFR,2) CALL GCBIM(LDIRT,1,X,0,2) CALL GCBIM(35,1,X,0,2) RETURN C 800 CALL PLTER(36) RETURN C END END$ S  AI 92840-18030 1819 S C0122 LORG COMMAND              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: LABEL ORIGIN C SOURCE: 92840 - 18030 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XLORG(INN,IGCB,MODE), 92840-16001 REV.1819 780515 DIMENSION IBUFR(2),LRBUF(2) EQUIVALENCE (IB2,IBUFR(2)),(LRBUF,L1),(LRBUF(2),L2) EQUIVALENCE (IBUFR,LRG) DATA LRG/6401B/ DATA LORNG/34002B/ DATA LARG/21/ C C THIS MODULE IS FOR THE AGL COMMAND LABLE ORIGIN (LORG) C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C LORG RANGE C CALL OUTPT(1,LORNG,1) CALL GCBIM(16,1,LRBUF,2,1) C C SEE IF MODE IS: 00 C LABELLING IS PERPINDICULAR TO AXIS. C IF(P12.LT.0)GO TO 25 CALL LDIR(IGCB,1.57) YLAB = (STRT - CHRWY) IF(IBUF.EQ.0)YLAB = STRT - (BYTE*CHRWY) CALL MOVE(IGCB,BEGIN,YLAB) GO TO 40 C C PARALLEL C 25 CALL LORG(IGCB,5) XLAB = BEGIN YLAB = (STRT - CHRHY) IF(IBUF.EQ.0)XLAB = XLAB - (HFBYT * CHRWX) CALL MOVE(IGCB,XLAB ,YLAB) GO TO 40 C C Y - AXIS C 50 IF(P12.LT.0)GO TO 55 XLAB = (STRT - CHRWX) IF(IBUF.EQ.0)XLAB = STRT - (CHRWX * BYTE) CALL MOVE(IGCB,XLAB,BEGIN) GO TO 40 55 CALL LDIR(IGCB,4.71) CALL LORG(IGCB,5)  YLAB = BEGIN XLAB = (STRT - CHRHX) IF(IBUF.EQ.0)YLAB = YLAB + (HFBYT *CHRWY) CALL MOVE( IGCB,XLAB,YLAB) C C OUTPUT LABEL C 40 CALL OUTPT(1,IFBUF,2) C C DON'T NEED TO MOVE THE PEN BACK WHERE IT WAS FOR AXELS OR TICS EM1913 C OR TO TURN CLIPPING BACK ON EM1913 RETURN END END$  EM 92840-18034 1819 S C0122 RPLOT INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: RPLOT * SOURCE: 92840 - 18034 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM RPLOT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMAND RPLOT. * EXT PLTRL,.OPTN,PLTER ENT RPLOT * * RPLOT NOP LDA RPLOT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .1 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB PLTRL DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .48 IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 M5 DEC -5 .1 OCT 1 .3 OCT 3 DF1 DEF .1 RETRN NOP OCT 0 A EQU 0 .48 DEC 48 * END  FL 92840-18035 1819 S C0122 RPLOT COMMAND              H0101 HFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: PLOT RELOCATABLE C SOURCE: 92840 - 18035 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE PLTRL(IND,IGCB,X,Y, 1PCNTL), 92840-16001 REV.1819 780515 INTEGER PCNTL,READ,WRITE C C C THIS IS THE FUNCTIONAL FOR THE AGL COMMAND IPLOT C DATA READ/1/ DATA WRITE/2/ C IFLG = 0 ISTAT = 0 IST1 = 0 C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C CALL GRSTS(1,200B,ISTAT) C C C NOW ASCERTAIN FROM THE PEN-CONTROL PARAMETER (PCNTL) WHAT C ACTIONS TO TAKE. THE FOLLOWING MODES ARE DEFINED FOR THE C PEN CONTROL PARAMETER: C C EVEN = PEN UP C ODD = PEN DOWN C + = PEN CHANGE AFTER MOTION C - = PEN CHANGE BEFORE MOTION C 10 IPC = IAND(IABS(PCNTL),1) + 1 IF(PCNTL.LT.0)GO TO 100 C C GO TO BRANCH FOR < 0 OR > = 0 C GO TO(70,75),IPC C C EVEN C 70 IF(ISTAT.NE.0)GO TO 85 C C SET BIT 4 OF STATUS FOR CALL TO MOVEI(IPLOT(X,Y,-2) C 80 CALL MOVER(IGCB,X,Y) IF(PCNTL.GT.0.AND.IPC.EQ.2)CALL PENDN(IGCB) C RETURN C C ODD C 75 IF(ISTAT.EQ.0)GO TO 80 85 CALL DRAWR(IGCB,X,Y) IF(PCNTL.GE.0.AND.ISTAT.NE.0.AND.IPC.EQ.1)CALL PENUP(IGCB) RETURN C C PCNT LT 0 C 100 GO TO(80,85),IPC END END$ #   GN 92840-18036 1819 S C0122 REL MOVE CMND              H0101 4FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: MOVE RELOCATABLE C SOURCE: 92840 - 18036 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XMOVR(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER LFTPN,READ,WRITE,PLTRL,PLTAB,GRIFX DIMENSION ICODE(5),VAR(16),IBUFR(8),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE(IBUFR(3),IB3) EQUIVALENCE (IBUFR(4),IB4),(IBUFR(5),LIFT), (IBUFR(6),PLTRL) EQUIVALENCE (IBUFR(7),IB7),(IBUFR(8),IB8) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (ICODE(5),ICD5) EQUIVALENCE (VAR(15),XNEW),(VAR(16),YNEW) EQUIVALENCE (VAR( 9),THETX),(VAR(10),THETY) EQUIVALENCE (VAR(11),PORGX),(VAR(12),PORGY) EQUIVALENCE(CLPTS,CLP1),(CLPTS(2),CLP2) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE(VAR(13),XOLD),(VAR(14),YOLD) C C C C THIS IS THE CORE MODULE FOR RELATIVE MOVE C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA LIFT/20400B/ DATA PLTAB/21402B/ DATA PLTRL/21402B/ C DATA ICD3,ICD4/19,17/ IFLG = 0 IST1 = 0 XNEW = 0. YNEW = 0. ISTAT = 0 ICD5 = 18 C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C C INITIALIQMZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 17 = PLOT ORIGINS (PORGX AND PORGY) C 18 = PREVIOUS X,Y C 19 = COS(THETA),SIN(THETA) C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS ON. C CALL GCBIM(ICODE,5,VAR, 0,READ) C C C COMPUTE NEW POINTS BY FIRST DOING TRANSLATION AND C SCALING, AND SECOND PERFORMING THE ROTATION. C THE ROTATION PROCESS INVOLVES ROTATING A VECTOR ABOUT C THE SAME ORIGIN AS THE ORIGINAL AXES, (ANGLES ARE COUNTER- C CLOCKWISE). THE CONSTANTS COS(THETA) AND SIN(THETA) RESIDE C IN THE GCB AND ARE DETERMINED FROM PDIR(THETA). C THE OTHER THING THAT HAS TO BE DONE HERE IS TO COMPUTE C THE NEW ENDPOINTS AND CLIP(IF SOFT CLIPPING IS ON). C C C RE-ESTABLISH ORIGIN C PORGX = PORGX * A + B PORGY = PORGY * C + D IF(X.NE.0.)XNEW = A * X IF(Y.NE.0.)YNEW = C * Y XN = (XNEW * THETX) - (YNEW * THETY) YN = (XNEW * THETY) + (YNEW * THETX) XNEW = XN + PORGX YNEW = YN + PORGY C C C C WRITE(6,2500)X,Y C500 FORMAT(2X,2(X,F5.2)) C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD ,CLPTS,V5,IFLG) C WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2,CLP3,CLP4 C500 FORMAT("DRAW",2X,8(X,F5.2)) C WRITE(6,7500)PORGX,PORGY C500 FORMAT(2X,"PORGS",2X,2(X,F7.2)) 22 IF(IFLG)600,25,600 C C NOW LIFT-PEN AND MOVE TO X,Y C 25 IB7 = GRIFX(CLP3) IB8 = GRIFX(CLP4) CALL OUTPT(2,LIFT,2) C C SET STATUS WORD TO INDICATE PEN UP AND SET NEW POINTS C INTO GCB. C 600 CALL GRSTS(2,67577B,10000B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20) RETURN END END$ h  HP 92840-18037 1819 S C0122 REL DRAW CMND              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: DRAW RELOCATABLE C SOURCE: 92840 - 18037 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDRWR(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER DRPPN,READ,WRITE,PLTRL,GRIFX INTEGER PLTAB DIMENSION ICODE(5),VAR(16),IBUFR(8) ,CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE(IBUFR(3),IB3) EQUIVALENCE (IBUFR(4),IB4),(IBUFR(5),DRPPN),(IBUFR(6),PLTRL) EQUIVALENCE (IBUFR(7),IB7),(IBUFR(8),IB8) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (ICODE(5),ICD5) EQUIVALENCE (VAR(15),XNEW),(VAR(16),YNEW) EQUIVALENCE (VAR(9) ,THETX),(VAR(10),THETY) EQUIVALENCE (VAR(11),PORGX),(VAR(12),PORGY) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE (CLP1,CLPTS(1)),(CLP2,CLPTS(2)) EQUIVALENCE(VAR(13),XOLD),(VAR(14),YOLD) C C C C THIS IS THE CORE MODULE FOR RELATIVE DRAW C DATA READ/1/ DATA WRITE/2/ DATA DRPPN/21000B/ DATA LFTPN/20400B/ DATA PLTRL/21402B/ DATA PLTAB/21402B/ C DATA ICD3,ICD4/19,17/ IFLG = 0 ISTAT = 0 XNEW = 0. YNEW = 0. CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C ICD5 = 18 C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C 19 = COS(THETA),SIN(THETA) C ICODE = IADCD(D) ICD2 = IS1V1(D) C C CALL GCBIM(ICODE,5,VAR, 0,READ) C C C COMPUTE NEW POINTS BY FIRST DOING TRANSLATION AND C SCALING, AND SECOND PERFORMING THE ROTATION. C THE ROTATION PROCESS INVOLVES ROTATING A VECTOR ABOUT C THE SAME ORIGIN AS THE ORIGINAL AXES, (ANGLES ARE COUNTER- C CLOCKWISE). THE CONSTANTS COS(THETA) AND SIN(THETA) RESIDE C IN THE GCB AND ARE DETERMINED FROM PDIR(THETA). C THE OTHER THING THAT HAS TO BE DONE HERE IS TO COMPUTE C THE NEW ENDPOINTS AND CLIP(IF SOFT CLIPPING IS ON). C C C RE-ESTABLISH ORIGIN C PORGX = PORGX*A +B PORGY = PORGY*C + D IF(X.NE.0.)XNEW = A*X IF(Y.NE.0.)YNEW = C * Y XN = (XNEW * THETX) - (YNEW * THETY) YN = (XNEW * THETY) + (YNEW * THETX) XNEW = XN + PORGX YNEW = YN + PORGY C C CHECK TO SEE IF UNITS = GDUS C C C NOW DO DE CLIPPING. C WRITE(6,2500)X,Y C500 FORMAT(2X,2(X,F7.2)) C 20 CALL CLPNG(XOLD ,CLPTS,V5,IFLG) C WRITE(6,5500)CLP1,CLP2,CLP3,CLP4,XNEW,YNEW,XOLD,YOLD C500 FORMAT("DRAW",2X,8(X,F5.2)) C WRITE(6,7500)PORGX,PORGY,THETX,THETY C500 FORMAT(2X,"PORGS",4(X,F7.2)) C 22 IF(IFLG)600,25,600 C C NOW DROP-PEN AND MAKE A MARK C 25 IB7 = GRIFX(CLP3) IB8 = GRIFX(CLP4) IB3 = GRIFX(CLP1) IB4 = GRIFX(CLP2) IF(CLP1.EQ.XOLD.AND.CLP2.EQ.YOLD)GO TO 27 CALL OUTPT(4,IBUFR,2) GO TO 600 27 CALL OUTPT(2,DRPPN,2) C C SET STATUS WORD TO INDICATE PEN DOWN AND SET NEW POINTS C INTO GCB. 600 CALL GRSTS(2,67577B,10200B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20) RETURN END END$   IQ 92840-18038 1819 S C0122 PEN DOWN CMND              H0101 .FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: PEN DOWN C SOURCE: 92840 - 18038 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XPNDN(IN,IGCB), 92840-16001 REV.1819 780515 INTEGER DRPPN DIMENSION VAR(8) DIMENSION CLPTS(4) EQUIVALENCE ( P1,VAR),( P2,VAR(2)),( P3,VAR(3)),( P4,VAR(4)) EQUIVALENCE (V1X,VAR(5)) C C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 DRPPN = 21000B CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GCBIM(18,1,VAR,0,1) P3 = P1 P4 = P2 ICODE = IS1V1(D) CALL GCBIM(ICODE,1,V1X,0,1) ICODE = 0 CALL CLPNG(P1,CLPTS,V1X,ICODE) IF(ICODE.NE.0)GO TO 10 CALL OUTPT(1,DRPPN,2) 10 CALL GRSTS(2,77577B,200B) RETURN END END$  JP 92840-18039 1819 S C0122 INCREMENTAL MOVE              H0101 AFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: MOVE INCREMENTAL C SOURCE: 92840 - 18039 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XMOVI(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER READ,WRITE,PLTIN,GRIFX DIMENSION ICODE(4),VAR(14),IBUFR(4),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTIN) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (VAR(11),XOLD),(VAR(12),YOLD) EQUIVALENCE (VAR(13),XNEW),(VAR(14),YNEW) EQUIVALENCE (VAR( 9),THETX),(VAR(10),THETY) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) C C C C THIS IS THE CORE MODULE FOR INCREMENTAL MOVE C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA PLTIN/21402B/ C DATA ICD3,ICD4/19,18/ IFLG = 0 IST1 = 0 ISTAT = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C 19 = COS(THETA),SIN(THETA) C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS% ON. C CALL GCBIM(ICODE,4,VAR, 0,READ) C C C C COMPUTE NEW POINTS BY FIRST DOING TRANSLATION AND C SCALING, AND SECOND PERFORMING THE ROTATION. C THE ROTATION PROCESS INVOLVES ROTATING A VECTOR ABOUT C THE SAME ORIGIN AS THE ORIGINAL AXES, (ANGLES ARE COUNTER- C CLOCKWISE). THE CONSTANTS COS(THETA) AND SIN(THETA) RESIDE C IN THE GCB AND ARE DETERMINED FROM PDIR(THETA). C THE OTHER THING THAT HAS TO BE DONE HERE IS TO COMPUTE C THE NEW ENDPOINTS AND CLIP(IF SOFT CLIPPING IS ON). C C CALL GRSTS(1,10000B,ISUSP) XNEW = 0. YNEW = 0. IF(X.EQ.0.)GO TO 72 XNEW =(A* X) 72 IF(Y.EQ.0.)GO TO 75 YNEW = C * Y 75 XN = (XNEW * THETX) - (YNEW * THETY) YN = (XNEW * THETY) + (YNEW * THETX) IF(ISUSP.NE.0)GO TO 77 XN = XN + B YN = YN + D 77 XNEW = XN + XOLD YNEW = YN + YOLD C C C C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD, CLPTS,V5,IFLG) C C DEBUGGING C CD WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2 CD00 FORMAT("MOVEI ",2X,8(X,F5.2)) CD WRITE(6,7500)X,Y CD00 FORMAT(2X," POINTS X,Y",2X,2(X,F5.2)) C 22 IF(IFLG)600,25,600 C C NOW DROP-PEN AND MAKE A MARK C 25 IB3 = GRIFX(CLP3) IB4 = GRIFX(CLP4) CALL OUTPT(2,IBUFR,2) C C SET STATUS WORD TO INDICATE PEN UP AND SET NEW POINTS C INTO GCB. 600 CALL GRSTS(2,67577B,10000B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20,11) C C CHECK FOR PREVIOUS CALL TO PORG (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$ k  KS 92840-18040 1819 S C0122 INCREMENTAL DRAW              H0101 XWFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: DRAW INCREMENTAL C SOURCE: 92840 - 18040 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDRWI(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER DRPPN,READ,WRITE,PLTIN,GRIFX INTEGER PLTAB DIMENSION ICODE(4),VAR(14),IBUFR(8),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE (IBUFR(5),DRPPN),(IBUFR(6),PLTIN),(IBUFR(7),IB7) EQUIVALENCE (IBUFR(8),IB8) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (VAR(9),THETX),(VAR(10),THETY) EQUIVALENCE (VAR(11),XOLD ),(VAR(12),YOLD ) EQUIVALENCE (VAR(13),XNEW), (VAR(14),YNEW) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE (CLPTS,CLP1),(CLPTS(2),CLP2) C C C C THIS IS THE CORE MODULE FOR INCREMENTAL DRAW C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA PLTAB/21402B/ DATA DRPPN/21000B/ DATA PLTIN/21402B/ C DATA ICD3,ICD4/19,18/ IFLG = 0 ISTAT = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C  19 = COS(THETA),SIN(THETA) C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS ON. C CALL GCBIM(ICODE,4,VAR, 0,READ) C C C C COMPUTE NEW POINTS BY FIRST DOING TRANSLATION AND C SCALING, AND SECOND PERFORMING THE ROTATION. C THE ROTATION PROCESS INVOLVES ROTATING A VECTOR ABOUT C THE SAME ORIGIN AS THE ORIGINAL AXES, (ANGLES ARE COUNTER- C CLOCKWISE). THE CONSTANTS COS(THETA) AND SIN(THETA) RESIDE C IN THE GCB AND ARE DETERMINED FROM PDIR(THETA). C THE OTHER THING THAT HAS TO BE DONE HERE IS TO COMPUTE C THE NEW ENDPOINTS AND CLIP(IF SOFT CLIPPING IS ON). C C CALL GRSTS(1,10000B,ISUSP) XNEW = 0. YNEW = 0. IF(X.EQ.0.)GO TO 72 XNEW =(A* X) 72 IF(Y.EQ.0. )GO TO 75 YNEW = C * Y 75 XN = (XNEW * THETX) - (YNEW * THETY) YN = (XNEW * THETY) + (YNEW * THETX) C IF(ISUSP.NE.0)GO TO 77 XN = XN + B YN = YN + D 77 XNEW = XN + XOLD YNEW = YN + YOLD C C CHECK TO SEE IF UNITS = GDUS C C C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD, CLPTS,V5,IFLG) C C DEBUGGING C C WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2,CLP3,CLP4 C500 FORMAT("DRAWI ",2X,8(X,F5.2)) C WRITE(6,7500)X,Y C500 FORMAT(2X,"POINTS X,Y ",2(X,F7.2)) C C WRITE(6,8500)IFLG C500 FORMAT(2X,"IFLG =",K6) C 22 IF(IFLG)600,25,600 C C NOW DROP-PEN AND MAKE A MARK C 25 IB3 = GRIFX(CLP1) IB4 = GRIFX(CLP2) IB7 = GRIFX(CLP3) IB8 = GRIFX(CLP4) IF(CLP1.EQ.XOLD.AND.CLP2.EQ.YOLD)GO TO 35 CALL OUTPT(4,IBUFR,2) GO TO 600 35 CALL OUTPT(2,DRPPN,2) C C SET STATUS WORD TO INDICATE PEN DOWN AND SET NEW POINTS C INTO GCB. 600 CALL GRSTS(2,67577B,10200B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20,11) C C CHECK FOR PREVIOUS CALL TO PORG  (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$ > LT 92840-18041 1819 S C0122 PLOT ORIGIN              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: PLOT ORIGIN (PORG) C SOURCE: 92840 - 18041 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XPORG(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 DIMENSION XY(2) EQUIVALENCE (XY(2),YX) DATA IPORG/17/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C SET BIT INDICATING PORG HAS BEEN CALLED C CALL GRSTS(2,77377B,400B) XY = X YX = Y CALL GCBIM(IPORG,1,XY,0,2) RETURN END END$  MS 92840-18042 1819 S C0122 TRANSMIT COMND              H0101 -GFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: TRANSMIT C SOURCE: 92840 - 18042 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XXMIT(IN,IGCB), 92840-16001 REV.1819 780515 DATA IXMIT/2000B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C THIS IS THE AGL COMMAND PROCESSOR FOR THE BUFFER FLUSH C COMMAND (XMIT). C C FIRST SEE IF I/O BUFFER WAS DECLARED (PLOTR(4)), AND C IF NOT SET A SOFT ERROR INDICATION AND RETURN. C ISTAT = 0 CALL GRSTS(1,1000B,ISTAT) IF(ISTAT.EQ.0)CALL PLTER(33) CALL OUTPT(1,IXMIT,2) RETURN END END$  NT 92840-18043 1819 S C0122 INC PLOT INT MOD              H0101 (NASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: IPLOT * SOURCE: 92840 - 18043 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM IPLOT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMAND IPLOT. * EXT PLOTI,.OPTN,PLTER ENT IPLOT * * IPLOT NOP LDA IPLOT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .1 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB PLOTI DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .49 IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .1 OCT 1 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 CODE NOP .49 DEC 49 * END / OU 92840-18044 1819 S C0122 INCREMENT PLOT              H0101 J-FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: PLOT INCREMENTAL C SOURCE: 92840 - 18044 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE PLOTI(IND,IGCB,X,Y, 1PCNTL), 92840-16001 REV.1819 780515 INTEGER PCNTL,READ,WRITE C C C THIS IS THE FUNCTIONAL FOR THE AGL COMMAND IPLOT C DATA READ/1/ DATA WRITE/2/ C IFLG = 0 ISTAT = 0 IST1 = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C CALL GRSTS(1,200B,ISTAT) C C C NOW ASCERTAIN FROM THE PEN-CONTROL PARAMETER (PCNTL) WHAT C ACTIONS TO TAKE. THE FOLLOWING MODES ARE DEFINED FOR THE C PEN CONTROL PARAMETER: C C EVEN = PEN UP C ODD = PEN DOWN C + = PEN CHANGE AFTER MOTION C - = PEN CHANGE BEFORE MOTION C 10 IPC =IABS(PCNTL) IPC = IAND(IPC,1) + 1 IF(PCNTL.LT.0)GO TO 100 C C GO TO BRANCH FOR < 0 OR > = 0 C GO TO(70,75),IPC C C EVEN C 70 IF(ISTAT.NE.0)GO TO 85 C C 80 CALL MOVEI(IGCB,X,Y) IF(PCNTL.GT.0.AND.IPC.EQ.2)CALL PENDN(IGCB) C RETURN C C ODD C 75 IF(ISTAT.EQ.0)GO TO 80 85 CALL DRAWI(IGCB,X,Y) IF(PCNTL.GE.0.AND.ISTAT.NE.0.AND.IPC.EQ.1)CALL PENUP(IGCB) RETURN C C PCNT LT 0 C 100 GO TO(80,85),IPC END END$    PW 92840-18045 2013 S C0122 &CSIZE              H0101 uASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: CSIZE INTFC MOD * SOURCE: 92840 - 18045 * RELOC: 92840 - 16001 * * * ************************************************************* * SY2001 ADDED CODE TO ALSO ACCEPT A FOURTH OPTIONAL * PARAMETER. THIS PARAMETER SPECIFIES WHETHER THE CSIZE * UNITS ARE IN NDC OR WC SPACE. IT DEFAULTS TO NDC SPACE * FOR BACKWARD COMPATIBILITY. * * NAM CSIZE,7 92840-16001 REV.2013 120379 EXT .OPTN,XSIZE EXT PLTER ENT CSIZE * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND CSIZE * CSIZE NOP LDA CSIZE JSB .OPTN DEF RTN PADR DEF PARM DEF M5 DEF .2 DEF .1 ONE REQUIRED PARAMETER IGCB DEF .4 4 DEFAULTS ASPECT RATIO,SLANT,HEIGHT,AND NDC UNITS DEF DZER0 TOP OF LIST FOR DEFAULTS DEF RETRN RTN JMP ERROR JSB XSIZE DEF END PARM BSS 6 END JMP RETRN,I SPC 2 DFLT DEC 2.78 .0 DEC 0. DZER0 DEF DFLT DEF .0 DEF .0 DEF .0 THIS CALL DEFAULTS TO NDC SPECIFICATION .1 OCT 1 .2 OCT 2 .4 DEC 4 M5 DEC -5 RETRN NOP ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .50 IGCB NOP RTNER JMP RETRN,I * .50 DEC 50 END Mh QW 92840-18046 2013 S C0122 &XSIZE              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: CSIZE C SOURCE: 92840 - 18046 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XSIZE(IND,IGCB,P1,P2,P3,IP4) +,92840-16001 REV.2013 790925 C********************************************************* C IBUFR INCREASED FROM 5 TO 7 WORDS. SY 4-24-79 C P3A HOLDS THE USER REQUESTED CHARACTER SLANT. C C IP4 ADDED 9-25-79 TO INDICATE WHETHER THE CSIZE SPECIFICATION C IS IN NDC UNITS OR WC UNITS. C IP4 = 0 TO INDICATE NDC SPECIFICATION. C = 1 TO INDICATE WC SPECIFICATION. C C************************************************************ DIMENSION VAR(4),IBUFR(7),ICHBF(9) INTEGER ICODE(2) EQUIVALENCE (IBUFR(2),CHRW,SLANT),(IBUFR(4),CHRH) EQUIVALENCE (IBUFR(6),P3A) EQUIVALENCE (ICHBF,CWMIN),(ICHBF(3),CHMIN) EQUIVALENCE (ICHBF(5),CWMAX),(ICHBF(7),CHMAX),(ICHBF(9),ICHB9) EQUIVALENCE (VAR,A),(VAR(3),C) C DATA ICHW/10404B/ DATA ISLNT/7402B/ DATA ICHMM/33011B/ DATA ISLOF/10000B/ DATA ICHR/4404B/ DATA ICLSZ/4404B/ C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL COMMAND CSIZE. C C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANING C P1 = CHARACTER HEIGHT,P2= ASPECT RATIO,P3=SLANT C XCH = P1 IF(P1.EQ.0)XCH = 2.78 XCW =XCH * P2 IF(P2.EQ.0)XCW = .7 * XCH CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB. C ISUSP = 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C C RETRIEV CHARACTER SIZE INFORMATION FROM THE DEVICE SUBROUTINE. C CALL OUTPT(1,ICHMM,1) CALL GCBIM(16,1,ICHBF,9,1) C C TRANSFORM UNITS INTO MUS AND COMPUTE CHARACTER WIDTH C WHICH IS EQUAL TO ASPECT RATIO * CHAR HEIGHT *CONVERSION FACTOR. C IADP=11 IF (IP4 .EQ. 1) IADP=12 CALL GCBIM(IADP,1,VAR,0,1) CHRH =XCH * C CHRW = XCW * A C***************************************************************** C C NOW CHECK ON MIN AND MAX CHARACTER SIZES DEVICE WILL TOLERATE C IF(CHRH.LT.CHMIN)CHRH = CHMIN IF(CHRH.GT.CHMAX)CHRH = CHMAX IF(CHRW.LT.CWMIN)CHRW = CWMIN IF(CHRW.GT.CWMAX)CHRW = CWMAX C C CHECK TO MAKE SURE DEVICE CAN HANDLE NEGATIVE CSIZE C IF(P1.LT.0.0.AND.ICHB9.EQ.0)CALL PLTER(22) IF(P2.LT.0.0.AND.ICHB9.EQ.0)CALL PLTER(22) IBUFR = ICHW CALL OUTPT(1,IBUFR,2) CALL GCBIM(7,1,CHRW,0,2) CALL OUTPT(1,ICHR,1) CALL GCBIM(16,1,7,1,3) C C NOW FOR THE SLANT IF P3 = 0. SLANT OFF COMMAND IS EMITTED C IBUFR = ISLNT IF(P3.EQ.0.)IBUFR = ISLOF SLANT = P3 C IF (IADP .EQ. 12) CALL GANG3(IGCB,P3,SLANT,ICHBF) SLANT=AMOD(SLANT,6.28) C IF(ABS(P3).GT.6.28)SLANT = AMOD(P3,6.28) CALL OUTPT(1,IBUFR,2) C******************************************************************* C NOW UPDATE GCB WITH NEW CHARACTER HEIGHT,WIDTH SLANT ETC. C STORE IN SAME UNITS AS SPECIFIED BY THE USER. C CHRH=P1 CHRW=P1*P2 P3A=P3 ICODE(1)=33 ICODE(2)=34 CALL GCBIM(ICODE,2,CHRW,0,2) C C SET THE BIT IN THE STATUS WORD TO INDICATE WHETHER YOU WILL USE C WC OR NDC CHARACTER PLOTTING FROM NOW ON. C IOR=0 IF (IP4 .EQ. 1) IOR=40000B CALL GRSTS(2,37777B,IOR) RETURN END END$ ӊ  RZ 92840-18047 1819 S C0122 DSIZE INTF MOD              H0101 "$ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DEVICE SIZE * SOURCE: 92840 - 18047 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM DSIZE,7 92840-16001 REV.1819 780515 EXT .OPTN,XDSIZ,PLTER ENT DSIZE * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND DSIZE. * CALLING SEQUENCE: * CALL DSIZE(XGDU,YGDU<,CHAR HEIGHT,ASPECT RATIO <,XRES,YRES>>) * DSIZE NOP LDA DSIZE RET ADDRESS JSB .OPTN DEF RTN DEF PARM DEF M8 DEF .1 CODE (MEANINGLESS FOR THIS COMMAND) DEF .3 # OF REQUIRED PARAMETERS DEF .4 # OF OPTIONAL PARAMETERS DEF DZER0 DEF RETRN RTN JMP ERROR JSB XDSIZ DEF END PARM BSS 8 END JMP RETRN,I * DZER0 DEF .0 DEF .0 DEF .0 DEF .0 .0 BSS 2 ANY VALUES RETURNED STORED HERE IF DEFAULTED. .1 OCT 1 .3 OCT 3 .4 OCT 4 M8 DEC -8 .56 DEC 56 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .56 IGCB NOP RTNER JMP RETRN,I RETRN NOP END M SY 92840-18049 2013 S C0122 &GDSTT              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: DEVICE STATUS (GDSTT) C SOURCE: 92840 - 18049 C RELOC: 92840 - 16001 C C C CC*********************************************************** C C SY2001 CHANGED &GDSTT TO IMPLEMENT GDSTT(9) FOR SOFTWARE TEXT. C VARIABLE GD9 HOLDS THE FOUR REAL VALUES THAT GET RETURNED TO THE C USER FOR GDSTT(9) WHEN SOFTWARE TEXT IS ON. C C SUBROUTINE XDSTT(INN,IGCB,INDEX,INDIC, 1IARRY),92840-16001 REV.2013 790904 DIMENSION INDEX(2),IARRY(2) DIMENSION ICAP(10) C C***********************************************************************SY2013/ LOGICAL GSOFT REAL GD9(4) INTEGER IGD9(8) EQUIVALENCE (GD9,IGD9) C**********************************************************END OF SY2013 MOD* EQUIVALENCE (ICAP,ID),(ICAP(2),ICLR),(ICAP(3),NUMPN) EQUIVALENCE (ICAP(4),NCURS),(LORG,ICAP(5)) EQUIVALENCE (ICAP(6),ISLNT),(ICLIP,ICAP(7)),(LDIR,ICAP(8)) EQUIVALENCE (ICHR,ICAP(9)) EM1913 C C THIS IS THE COMMAND PROCESSOR FOR THE AGL COMMAND C GDSTT. THIS COMMAND INFORMS THE USER OF THE DEVICE C CAPABILITIES. C C CALLING SEQUENCE PARAMETERS: IGCB -GCB C INDEX - ARRAY CONTAINING INTEGER VALUES WHICH INDICATE C WHICH CAPABILITY IS OF INTEREST. C INDIC - NUMBER OF ENTRIES IN INDEX. C IARRY - RETURN BUFFER WHERE DATA IS TO GO. C C THE ARRAY ICAP CONTAINS THE GRAPHIC INTERPRETIVE CODES C NECESSARY TO RETRIEVE THE DATA FROM THE DEVICE OR DEVICE C SUBROUTINE. C DATA ID/ 3003B/ DATA ICLR/27401B/ ?   DATA NUMPN/30001B/ DATA NCURS/30401B/ DATA LORG/31001B/ DATA ISLNT/31404B/ DATA ICLIP/32001B/ DATA MAXCP/9/ EM1913 DATA LDIR/33403B/ DATA ICHR/32410B/ EM1913 DATA GD9/.055555555,.944444445,0.0,.65625/ SY2013 C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN J = 1 IF(INDIC)800,800,5 C******************************************************************* C DO LOOP STARTS HERE. C 5 DO 500 I=1,INDIC INST = INDEX(I) IF(INST.LE.0.OR.INST.GT.MAXCP)GO TO 800 C***************************************************************** C TRAP OUT A CALL TO GDSTT(9) IF SOFTWARE TEXT IS ALSO ON SY2013 C IF ((INST .NE. 9) .OR. (.NOT. GSOFT(IGCB))) GO TO 10 DO 8 L=1,8 8 IARRY(J+L-1)=IGD9(L) J=J+8 GO TO 500 C C END OF SY2013 ADDITION SY2013 C************************************************************************ C 10 ITHNG = ICAP(INST) C C NUMBER OF ITEMS ASSOCIATED WITH GIC C NUM = IAND(ITHNG,377B) C C CALL DEV. SUB. TO GET DATA C CALL OUTPT(1,ITHNG,1) CALL GCBIM(16,1,IARRY(J),NUM,1) J = J + NUM 500 CONTINUE C RETURN C 800 CALL PLTER(27) RETURN END END$ AQ  T[ 92840-18050 2013 S C0122 &GSTAT              H0101 wFTN,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GSTAT C SOURCE: 92840 - 18050 C RELOC: 92840 - 16001 C C C CC*********************************************************** C C SY2001 MAKES A MOD TO HANDLE A GSTAT(14) CALL WHEN SOFTWARE C TEXT IS ENABLED. GSTAT(14) INQUIRES ABOUT LDIR. C SY2001 ALSO ADDS NEW CALL OF GSTAT(17) TO INQUIRE IF SOFTWARE C TEXT IS CURRENTLY ON. C C**************************************************************** C SUBROUTINE XGSTT(INN,IGCB,INDX,LOOP, 1IARRY), 92840-16001 REV.2013 790904 C LOGICAL GSOFT SY2013 INTEGER PNPOS,PENZ DIMENSION IARRY(2),IGTBL(20),ICODE(3),INDX(2) DIMENSION IBUFR(4) DIMENSION VAR(4),VAR1(4) C C THIS ROUTINE IS RESPONSIBLE FOR RETURNING THE C GRAPHICS PACKAGE STATUS INFORMATION TO THE USER. C EQUIVALENCE (IBUFR,IB1),(IBUFR(2),IB2),(IBUFR(3),IB3) EQUIVALENCE(IGTBL,PNPOS),(IGTBL(2),PENZ),(IGTBL(3),IG12) EQUIVALENCE(IGTBL(4),IV12),(IGTBL(5),IS12),(IGTBL(6),IAD) EQUIVALENCE(IGTBL(7),IADP),(IGTBL(8),IPRG),(IGTBL(9),ICHR) EQUIVALENCE(IGTBL(10),IGDU),(IGTBL(11),IUNIT),(IGTBL(12),LINE) EQUIVALENCE(IGTBL(13),LORG),(IGTBL(14),LDIR),(IGTBL(15),IPDIR) EQUIVALENCE(IGTBL(16),N),(IGTBL(17),ISOFT) EQUIVALENCE (VAR,X1),(VAR(2),Y1),(VAR(3),X2) EQUIVALENCE (VAR(4),Y2),(VAR1,A),(VAR1(2),B),(VAR1(3),C) EQUIVALENCE (VAR1(4),D) C C C THE FOLLOWING DATA ITEMS ARE POINTER INTO THE GRAPHICS CONTROL C BLOCK VIA THE GCB INTERFACE MODULE (GCBIM). C A NEGATIVE NUMBE R INDICATES SOMETHING SPECIAL MUST BE DONE. C C DATA IPXY/5003B/ DATA PNPOS,PENZ/-3,-1/ DATA IG12,IV12,IS12/-4,-5,-6/ DATA IADP,IAD/-8,-9/ DATA IPRG,ICHR/-10, -7/ DATA IGDU,IUNIT/2015B,-2/ DATA LINE,LORG/ -11,425B/ DATA LDIR,IPDIR/1026B,2023B/ C DATA LDIR2/1043B/ DATA ISOFT/-12/ C DATA N/432B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C FIRST DETERMINE IF WE HAVE AN ERROR INDX<1 OR > 17 SY2013 C THEN IF NO ERROR COMPUTE POINTER INTO IGTBL TO GET C GET THE CORRECT INDEX FOR THE GCB. IF THE POINTER IS C NEGATIVE GO DO SOMETHING SPECIAL. C J = 1 IF(LOOP)800,800,5 5 DO 550 I = 1,LOOP INTST = INDX(I) IF(INTST.LE.0.OR.INTST.GT.17)GO TO 800 C C NOW LOOP AROUND AN FILL IARRY WITH ALL THE DATA REQUESTED C IPTR = IGTBL(INTST) IF(IPTR.LT.0)GO TO 100 C**************************************************************SY2013 MOD C IF IPTR IS INQUIRING ABOUT LDIR, SEE IF SOFTWARE TEXT IS ENABLED. C IF SO, MODIFY IPTR TO RETURN THE SOFTWARE LDIR VALUE. C IF ((IPTR .EQ. LDIR) .AND. (GSOFT(IGCB))) IPTR=LDIR2 C C*******************************************************END OF SY2013 MOD C C DETERMINE THE NUMBER OF WORDS THAT WILL BE FILLED UP C IN IARRY. C NUM = IAND(IPTR,177400B)/400B IPTR = IAND(IPTR,377B) CALL GCBIM(IPTR,1,IARRY(J),0,1) GO TO 500 C C GET INFO FROM STATUS WORD C 100 IPTR = -IPTR GO TO(110,120,130,140,140,140,150,160,160,125,165,175),IPTR SY2013 110 ISTAT = 0 CALL GRSTS(1,200B,ISTAT) IARRY(J) = ISTAT/200B NUM = 1 GO TO 500 C C UNITS MODE: 0=GDUS,1=UDUS,AND 3 = USER UNITS = GDUS C 120 CALL GRSTS(1,1 ,ISTAT) u^ IARRY(J) = ISTAT NUM = 1 GO TO 500 C C PORG X,Y C 125 CALL GCBIM(17,1,IARRY(J),0,1) NUM = 4 GO TO 500 C C PEN POSITION (X,Y) C 130 CALL OUTPT(1,IPXY,1) CALL GCBIM(16,1,IBUFR,3,1) 135 X1= IB1 Y1= IB2 NUM = 4 GO TO 200 C C G1,G2 OR V1,V2 OR S1,S2 C 140 IPTR = IPTR + 4 CALL GCBIM(IPTR,1,VAR,0,1) NUM = 8 GO TO 200 C C CHARACTER SIZE C 150 CALL GCBIM(7,1,VAR,0,1) ICD = IADCD(D) CALL GCBIM(ICD,1,VAR1,0,1) X1 = X1/A Y1 = Y1/C NUM = 4 GO TO 300 C C A - D OR A' - D' C 160 IPTR = IPTR + 3 CALL GCBIM(IPTR,1,VAR,0,1) Y1 = Y1/X1 Y2 = Y2/X2 NUM = 8 GO TO 300 165 CALL GCBIM(31,1,IBUFR,0,1) IARRY(J) = IBUFR NUM = 1 GO TO 500 C********************************************************************** C SY2013 ADDS INQUIRY ABOUT WHETHER SOFTWARE TEXT IS ON. C 175 IARRY(J)=0 IF (GSOFT(IGCB)) IARRY(J)=1 NUM=1 GO TO 500 C C CONVERT VALUES OF INTEREST TO CURRENT UNITS (UDUS OR GDUS) C 200 IPTR = IADCD(D) CALL GCBIM(IPTR,1,VAR1,0,1) X1 = (X1 - B)/A Y1 = (Y1 - D)/C X2 = (X2 - B)/A Y2 = (Y2 - D)/C C C NOW DO DE TRANSFER (TRICKERY AT ITS BEST) C 300 CALL GCBIM(16,1,VAR,NUM,2) CALL GCBIM(16,1,IARRY(J),NUM,1) 500 J= J + NUM 550 CONTINUE C RETURN 800 CALL PLTER(26,11) RETURN END END$ | U] 92840-18051 1819 S C0122 GPMM CMND              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GPMM C SOURCE: 92840 - 18051 C RELOC: 92840 - 16001 C C C CC*********************************************************** C REAL FUNCTION XPMM(IN,IGCB,GMM), 92840-16001 REV.1819 780515 DIMENSION VAR(6),ICODE(2) EQUIVALENCE (VAR,XMU),(VAR(3),AP),(ICODE,MUMM) EQUIVALENCE (ICODE(2),IADP) DATA MUMM/6/ DATA IADP/11/ C C GPMM CONVERTS MILLIMETERS TO GDU'S. THE EQUATION C FOR DOING THE CONVERSION IN UNITS FORM IS AS FOLLOWS: C C GDU'S = (MM * MU'S/MM * GDU/MU) C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C START - RETRIEVE CONSTANTS FROM GCB C CALL GCBIM(ICODE,2,VAR,0,1) XPMM = (GMM *XMU)/AP RETURN END END$ = V\ 92840-18052 1913 S C0122 &FRAME FRAME COMMAND             H0101 cFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: FRAME C SOURCE: 92840 - 18052 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XFRME(INN,IGCB), 92840-16001 REV.1913 781206 INTEGER DRPPN,PLTAB,GRIFX EM1913 DIMENSION VAR(4),IBUFR(18) EM1913 EQUIVALENCE (VAR(1),XL),(VAR(2),YL),(VAR(3),XU),(VAR(4),YU) EM1913 EQUIVALENCE (IBUFR(1),LFTPN),(IBUFR(2),PLTAB) EM1913 EQUIVALENCE (IBUFR(3),IXL),(IBUFR(4),IYL),(IBUFR(5),DRPPN) EM1913 EQUIVALENCE (IBUFR(7),IXU),(IBUFR(11),IYU) EM1913 C DATA LFTPN/20400B/ DATA DRPPN/21000B/ DATA PLTAB/21402B/ C C THIS ROUTINE IS FOR THE AGL COMMAND "FRAME", WHICH DRAWS C A NICE LITTLE BOX AROUND THE CURRENT WINDOW MAPPING END- C POINTS. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C FIRST GET THE APPROPRIATE CODE FOR V1,V2, OR S1,S2 EM1913 C ICODE = IS1V1(D) CALL GCBIM(ICODE,1,VAR,0,1) C C NOW INTERGERIZE THE REAL VALUES IN VAR(I) C LOWER X = VAR(1) LOWER Y = VAR(2) EM1913 C UPPER X = VAR(3) UPPER Y = VAR(4) EM1913 C IXL = GRIFX(XL) EM1913) IYL = GRIFX(YL) EM1913 IXU = GRIFX(XU) EM1913 IYU = GRIFX(YU) EM1913 C C SET THE GIC CODES AND THE GIC DATA TO BE PASSED INTO THE ARRAY. EM1913 C THE STARRED COMMENT LINES HAVE ALREADY BEEN DONE VIA EQUIVALENCE EM1913 C STATEMENTS. THE NEED FOR THESE STATEMENTS MUST BE RE-EVALUATED EM1913 C WHENEVER CODE IS CHANGED. EM1913 C C WE MOVE COUNTER-CLOCKWISE AROUND THE FRAME, OR, USING THE EM1913 C INDICES OF VAR EM1913 C 1,2 -> 3,2 -> 3,4 -> 1,4 -> 1,2 EM1913 C C C C** IBUFR(1) = LFTPN EM1913 C** IBUFR(2) = PLTAB EM1913 C** IBUFR(3) = IXL EM1913 C** IBUFR(4) = IYL EM1913 C** IBUFR(5) = DRPPN EM1913 IBUFR(6) = PLTAB EM1913 C** IBUFR(7) = IXU EM1913 IBUFR(8) = IYL EM1913 IBUFR(9) = PLTAB EM1913 IBUFR(10) = IXU EM1913 C** IBUFR(11) = IYU EM1913 IBUFR(12) = PLTAB EM1913 IBUFR(13) = IXL EM1913 IBUFR(14) = IYU EM1913 IBUFR(15) = PLTAB EM1913 IBUFR(16) = $ IXL EM1913 IBUFR(17) = IYL EM1913 IBUFR(18) = LFTPN EM1913 C C C NOW SEND OUT THE WHOLE ARRAY OF GICS, 8 IN TOTAL EM1913 C CALL OUTPT(8,IBUFR,2) EM1913 RETURN END END$ / W_ 92840-18053 1819 S C0122 LABEL INTF MOD              H0101 %ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: LABEL,LABON,LABOF * SOURCE: 92840 - 18053 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM LABEL,7 92840-16001 REV.1819 780515 ENT LABEL EXT .OPTN,XLABL,PLTER * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMANDS * LABEL AND LORG. * LABEL NOP LDA LABEL JSB .OPTN DEF RTN1 PADR DEF PARM DEF M5 DEF .1 CODE DEF .1 REQUIRED PARAMETERS DEF .1 ONE DEFAULT DEF DZER0 DEFAULT VALUE DEF RETRN RTN1 JMP ERROR ENTRY JSB XLABL DEF RTNER PARM BSS 5 END JSB PLTER ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .66 IGCB NOP RTNER JMP RETRN,I * * * DZER0 DEF .0 RETRN NOP .0 OCT 0 .1 OCT 1 .2 OCT 2 M5 DEC -5 .66 DEC 66 END z{ X^ 92840-18054 1819 S C0122 LBL LBN LBF CMNS              H0101 uFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: LABEL,LABON,LABOF C SOURCE: 92840 - 18054 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XLABL(IND,IGCB,IP1), 92840-16001 REV.1819 780515 DATA LABL/23000B/ C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL COMMAND LABEL(MODE), C THE PARAMETER IP1 = MODE. C C C LABEL C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C 10 IF(IP1.LT.0.OR.IP1.GT.2)GO TO 810 IP =IABS(IP1)+ 1 GO TO (300,100,200),IP 100 CALL LABON(IGCB) RETURN 200 CALL LABOF(IGCB) RETURN C C SHORT LABEL C 300 CALL OUTPT(1,LABL,2) C C SET BIT 4 TO INDICATE SHORT LABEL C CALL GRSTS(2, 77757B,20B) 800 RETURN 810 CALL PLTER(31,IGCB) GO TO 300 END SUBROUTINE LABON(IGCB), 92840-16001 REV.1819 780515 INTEGER STLAB C C THIS ROUTINE IS RESPONSIBLE FOR PROCESSING THE AGL COMMANDS C LABON (LABEL ON) AND LABOF(LABLE OFF). C DATA STLAB/23400B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL OUTPT(1,STLAB,2) C C SET BIT INDICATING LABEL MODE C CALL GRSTS(2,77677B,100B) RETURN END    SUBROUTINE LABOF(IGCB), 92840-16001 REV.1819 780515 INTEGER STPLB DATA STPLB/24000B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GRSTS(2,77677B,0) CALL OUTPT(1,STPLB,2) RETURN END END$ M  Y` 92840-18055 1819 S C0122 SETUU SETGU              H0101 YFTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: SETUU AND SETGU COMMANDS C SOURCE: 92840 - 18055 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XSETU(IN,IGCB), 92840-16001 REV.1819 780515 C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C SET BIT 1 OF STATUS WORD TO INDICATE USER UNITS C GO TO(100,200),IN 100 CALL GRSTS(2,77776B,1) RETURN C C SET BIT 1 OF STATUS WORD = 0 TO INDICATE GDU'S C 200 CALL GRSTS(2,77776B,0) RETURN END : Z` 92840-18056 1819 S C0122 INTAC INTF MOD              H0101 /ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: INTERFACE FOR WHERE,CURSOR,DIGITIZE * SOURCE: 92840 - 18056 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM WHERE,7 92840-16001 REV.1819 780515 EXT INTAC,.OPTN,PLTER ENT WHERE,CURSR,DIGTZ,POINT * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMANDS * WHERE,CURSOR,DIGITIZE AND POINT. * WHERE NOP LDA .1 STA CODE LDA .55 STA ERCOD LDA WHERE WHR1 JSB .OPTN DEF RTN PADR DEF PARM DEF M5 DEF CODE DEF .3 3 REQUIRED PARAMETERS DEF .1 OPTIONAL PARAM. DEF BLNK DEF RETRN RTN JMP ERROR JSB INTAC DEF END PARM BSS 5 END JMP RETRN,I * CURSR NOP LDA .53 STA ERCOD LDA .2 STA CODE LDA CURSR JMP WHR1 * DIGTZ NOP LDA .54 STA ERCOD LDA .3 STA CODE LDA DIGTZ JMP WHR1 * POINT NOP LDA .52 STA ERCOD LDA .4 STA CODE CLA STA BLANK LDA POINT JMP WHR1 * BLNK DEF BLANK BLANK NOP RETRN NOP .1 OCT 1 .2 OCT 2 M5 DEC -5 .52 DEC 52 .53 DEC 53 .54 DEC 54 .55 DEC 55 ERCOD NOP .3 OCT 3 .4 OCT 4 CODE NOP ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * END    [b 92840-18057 1819 S C0122 INTAC CMNDS              H0101 'FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: INTERACTIVE COMMANDS:WHERE,CURCOR,DIGITIZE C SOURCE: 92840 - 18057 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE INTAC(IND, IGCB,XCORD,YCORD, 1IZCRD), 92840-16001 REV.1819 780515 INTEGER GRIFX INTEGER CURSR,DIGTZ,POSCR DIMENSION VAR(8),ICODE(2),IBUFR(3),ENDPT(4) DIMENSION IEBUF(4) EQUIVALENCE (VAR,A),(VAR(2),B),(VAR(3),C) EQUIVALENCE (VAR(4),D),(VAR(5),X),(VAR(6),Y) EQUIVALENCE (VAR(7),X0),(VAR(8),Y0) EQUIVALENCE (ENDPT,G1X),(ENDPT(2),G1Y),(ENDPT(3),G2X) EQUIVALENCE (ENDPT(4),G2Y) EQUIVALENCE (ICODE(2),ICD2),(IBUFR(2),IB2),(IBUFR(3),IB3) C DATA X0/0./ DATA Y0/0./ DATA CURSR/5403B/ DATA DIGTZ/6003B/ DATA POSCR/25402B/ C THIS IS THE FUNCTIONAL MODULE FOR PROCESSING THE C INTERACTIVE AGL COMMANDS WHERE, CURSOR, DIGITIZE AND POINT. CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C GET THE APPROPRIATE CONSTANTS TO CONVERT XCORD AND YCORD C TO CURRENT UNIT SYSTEM (UDU'S OR GDU'S). C ICD2 = 18 ICODE = IADCD(D) CALL GCBIM(ICODE,2,VAR,0,1) GO TO(10,20,30,40),IND C C WHERE - GET LOGICAL PEN POSITION C 10 CALL GRSTS(1,600B,IZCRD) IF(IZCRD.NE.0)IZCRD = 1 15 XCORD = (X - B)/A YCORD = (Y - D)/C RETURN C C CURS4*  OR - GET CURSOR POSITION WITHOUT WAIT C 20 CALL OUTPT(1,CURSR,1) 25 CALL GCBIM(16,1,IBUFR,3,1) X = IBUFR Y = IB2 IZCRD = IB3 GO TO 15 C C DIGITIZE C 30 CALL OUTPT(1,DIGTZ,1) GO TO 25 C C POINTER C 40 X = XCORD * A + B Y = YCORD * C + D C C GET HARD CLIP ENDPOINTS C IBUFR = POSCR IB2 = GRIFX(X) IB3 = GRIFX(Y) CALL OUTPT(1,IBUFR,2) RETURN END END$   \c 92840-18058 1901 S C0122 &HDERR HARD ERROR INTFC MOD SRC             H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: HARD ERROR * SOURCE: 92840 - 18058 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM HDERR,7 92840-16001 REV.1901 781020 ENT HDERR EXT .OPTN,HERR EXT PLTER * * THIS IS THE INTERFACE MODULE FOR CHANGING EM1901 * SOFT ERRORS TO FIRM ERRORS FOR REPORTING PURPOSES EM1901 * HDERR NOP LDA HDERR JSB .OPTN GO RETRIEVE PARAMETERS DEF RTN DEF PARM DEF M3 EM1901 DEF .1 CODE DEF .2 REQUIRED PARAMETERS DEF .0 NO OPTIONAL PARAMETERS EM1901 DEF DZERO DEF RETRN RTN JMP ERROR JSB HERR DEF END PARM BSS 3 EM1901 END JMP RETRN,I * *PARAMETER ERROR * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF ERTN DEF .57 IGCB NOP ERTN JMP RETRN,I .57 DEC 57 .2 OCT 2 * M3 DEC -3 EM1901 RETRN NOP .1 OCT 1 DZERO DEF .0 .0 OCT 0 * END / ]c 92840-18059 2013 S C0122 &HERR              H0101 _FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: HARD ERROR C SOURCE: 92840 - 18059 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE HERR(IND,IGCB,ICODE), 92840-16001 REV. 2013 790904 SY2013 C C THIS PROCEDURE TAKES THE INTEGER VALUE IN ICODE AND INDEXES C INTO THE ERROR MASK BUFFER TO GET THE MASK WORD AND BIT OF C INTEREST. SOFT ERRORS ARE UPDATED TO FIRM ERRORS FOR REPORTING EM1901 C PURPOSES. EM1901 C DIMENSION IEBUF(4),IESOFT(4) EM1901 C DATA MAXER/64/ EM1901 DATA IERR/27/ DATA IREAD/1/ EM1901 DATA IWRIT/2/ EM1901 C C INITIALIZE THE SOFT ERROR MASK. WORD 1 HAS ERRORS 16-1, WORD 2, 32-17 EM1901 C WORD 3, 48-33, AND WORD 4, 64-49, AS IN THE GCB ERROR MASK. EM1901 C BIT IS TURNED ON IF CORRESPONDING ERROR IS SOFT BUG, OFF IF ERROR IS EM1901 C HARD, FIRM, OR NON-EXISTENT. EM1901 C C SY2013 CHANGED IESOFT(1) FROM 42200B TO 52200B. (ERROR 13 IS SOFT) C DATA IESOFT/52200B,4771B,1B,0/ EM1901 C C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C RETURN EvC  RROR 32 IF REQUEST IS FOR REPORTING OF OBVIOUSLY NON-SOFT EM1901 C ERRORS. NEGATIVE NUMBERS ARE RESERVED FOR FMP ERRORS AND WE ONLY HAVE EM1901 C 4 WORDS WITH 64 BITS IN GCB'S ERROR MASK. IF(ICODE.LE.0.OR.ICODE.GT.MAXER)GO TO 800 C C COMPUTE MASK BIT AND WORD INDEX INTO A 4 WORD ERROR MASK EM1901 IMPY = MOD(ICODE,16) INDX = ICODE/16 + 1 IF(IMPY)60,50,60 50 INDX = INDX -1 IMSK = 100000B GO TO 65 60 IMSK = 2**(IMPY -1) C C SEE IF ERROR IN QUESTION IS A LEGAL SOFT ERROR BY APPLYING THE MASK EM1901 C TO THE SOFT ERROR STRING. IF IT ISN'T, THEN REPORT AN ERROR 32. EM1901 65 ITST = IAND(IESOFT(INDX),IMSK) IF (ITST.EQ.0) GO TO 800 C C RETRIEVE THE ERROR MASK FROM THE GCB EM1901 CALL GCBIM(IERR,1,IEBUF,0,IREAD) EM1901 C C MAKE FIRM BY TURNING ON BIT IN GCB'S ERROR MASK. NOTE, IT IS NOT AN EM1901 C ERROR TO REQUEST HDERR OF THE SAME SOFT ERROR TWICE, SO DON'T CHECK EM1901 C BITS STATE TO SAVE OVERHEAD, AS DOUBLE SETTING WON'T HAPPEN OFTEN. EM1901 IEBUF(INDX) = IOR(IEBUF(INDX),IMSK) EM1901 CALL GCBIM(IERR,1,IEBUF,0,IWRIT) EM1901 RETURN 800 CALL PLTER(32) RETURN END END$ C }  ^e 92840-18060 1819 S C0122 LGERR INTF MOD              H0101 ,ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: LGERR INTFC MOD * SOURCE: 92840 - 18060 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM LGERR,7 92840-16001 REV.1819 780515 ENT LGERR EXT .OPTN,XGERR,PLTER EXT PLTER * * THIS IS THE INTERFACE MODULE FOR THE ERROR HANDLING COMMAND * LGERR(LU). * LGERR NOP LDA LGERR LG1 JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .1 IGCB REQUIRED PARAMETER DEF .1 DEF DF0 DEFAULT LU = 1 DEF RETRN RTN JMP ERROR JSB XGERR DEF END PARM BSS 3 END JMP RETRN,I * RETRN NOP M3 DEC -3 .1 DEC 1 .0 OCT 0 DF0 DEF .0 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .61 IGCB NOP RTNER JMP RETRN,I .61 DEC 61 END  _e 92840-18061 1819 S C0122 IGERR CMND              H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: IGERR C SOURCE: 92840 - 18061 C RELOC: 92840 - 16001 C C C CC*********************************************************** C INTEGER FUNCTION XIGER(IN,IGCB), 92840-16001 REV.1819 780515 DATA IERR/30/ C C REPORT THE MOST RECENT ERROR C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) CALL PLTER(-98,ISUSP) IF(ISUSP.NE.0)GO TO 10 CALL GCBIM(IERR,1,XIGER,0,1) CALL GCBIM(IERR,1,0,1,2) RETURN 10 XIGER = ISUSP RETURN END END$ ` `f 92840-18062 1819 S C0122 LGERR COMMAND              H0101 6FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: LOG ERROR C SOURCE: 92840 - 18062 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XGERR(IND,IGCB,NUM), 92840-16001 REV.1819 780515 DATA LUERR/28/ CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL ERROR SETUP C COMMAND LGERR (DEFINE ERROR LOG DEVICE). C LUER = NUM IF(NUM.EQ.0)LUER = 1 10 CALL GCBIM(LUERR,1,LUER,0,2) RETURN C END END$ .$ ag 92840-18063 1819 S C0122 CHAR PLOT INTFC              H0101 D!ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PLOT * SOURCE: 92840 - 18063 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM CPLOT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * CPLOT. * EXT CHPLT,.OPTN,PLTER ENT CPLOT * * CPLOT NOP LDA .1 PLT STA CODE LDA CPLOT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF CODE DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .1 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB CHPLT DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .47 IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 .47 DEC 51 CODE NOP * END Z bh 92840-18064 2040 S C0122 &CHPLT SOURCE             H0101 FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: CPLOT COMMAND C SOURCE: 92840 - 18064 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE CHPLT(IND,IGCB,XI,YI, 1IPCTL), 92840-16001 REV.2040 800807 C LOGICAL GSOFT,GWC,WCFLAG SY2013 DIMENSION VAR(7),ICODE(3),IBUFR(8) EQUIVALENCE (VAR,CHRW),(VAR(2),CHRH),(VAR(3),THETA) EQUIVALENCE(VAR(4),A),(VAR(6),C) EQUIVALENCE(ICODE,ICHR),(ICODE(2),LDIR),(ICODE(3),ICD3) EQUIVALENCE (IBUFR,IB1),(IBUFR(2),IB2),(VAR(5),B) EQUIVALENCE (VAR(7),D) C C THIS IS THE AGL MODULE FOR PROCESSING THE CHARACTER C PLOT COMMAND. IX = # CHARACTERS IN X DIRECTIONS C IY = # " " Y DIRECTION C DATA ICHR/7/ DATA IPXY/5003B/ DATA LDIR/22/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C********************************************************************** C MOD BY SY2013. SET UP THE PROPER VALUES TO INQUIRE FOR ACCORDING C TO WHETHER SOFTWARE OR HARDWARE TEXT IS ENABLED. C IUNIT=IADCD(IDUMY) IF (GSOFT(IGCB)) GO TO 100 C*********************************************************************** C HARDWARE TEXT IS ON. COMPUTE HTOT AND WTOT. C ICODE=7 ICODE(2)=22 ICD3=IUNIT CALL GCBIM(ICODE,3,VAR,0,1) C WTOT=(XI*CHRW)/A k   SY2040 HTOT=(YI*CHRH)/C SY2040 GO TO 2000 C*********************************************************************** C SOFTWARE TEXT IS ON. SET UP WC OR NDC SPACE ACCORDING TO HOW USER C ENTERED HIS CSIZE CALL. C 100 CONTINUE WCFLAG=GWC(IGCB) IF (WCFLAG) CALL SETUU(IGCB) IF (.NOT. WCFLAG) CALL SETGU(IGCB) C*********************************************************************** C RETRIEVE THE CHARACTER HEIGHT AND WIDTH IN UNITS SPECIFIED IN THE C CSIZE CALL. C GET LDIR IN WC. C ICODE=33 ICODE(2)=35 CALL GCBIM(ICODE,2,VAR,0,1) WTOT=XI*VAR(1) HTOT=YI*VAR(2) THETA=VAR(3) D WRITE(1,105) THETA D105 FORMAT(/"CHPLT: WC LDIR = ",F13.5) C******************************************************************** C CONVERT LDIR TO NDC IF YOU WANT NDC PLOTTING. C IF (WCFLAG) GO TO 2000 CALL GANG3(IGCB,THETA,TEMP,IBUFR) D WRITE(1,107) TEMP D107 FORMAT(/"CHPLT: MU LDIR = ",F13.5) CALL GANG4(IGCB,TEMP,THETA,IBUFR) D WRITE(1,115) THETA D115 FORMAT(/"CHPLT: NDC LDIR = ",F13.5) C********************************************************************* C COMPUTE VALUES FOR X AND Y IN CURRENT UNIT MODE C 2000 CONTINUE THETX=COS(THETA) THETY=SIN(THETA) C X=WTOT*THETX-HTOT*THETY Y=WTOT*THETY+HTOT*THETX C********************************************************************** C CALL IPLOT TO DO THE PLOTTING C CALL IPLOT(IGCB,X,Y,IPCTL) IF (IUNIT .EQ. 12) CALL SETGU(IGCB) IF (IUNIT .NE. 12) CALL SETUU(IGCB) RETURN END *  cj 92840-18065 1819 S C0122 MSCAL INTFC MOD              H0101 nASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MSCAL INTFC MOD * SOURCE: 92840 - 18065 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MSCAL,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MSCAL. * EXT XSCAL,.OPTN,PLTER ENT MSCAL * * MSCAL NOP LDA MSCAL JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XSCAL DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 75 CODE NOP * END  dj 92840-18066 1819 S C0122 CLP ON OF INT MOD              H0101 xASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: CLPON\CLPOF INTFC MOD * SOURCE: 92840 - 18066 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM CLPON,7 92840-16001 REV 1819 780515 EXT .OPTN,PLTER,XCLPN ENT CLPON,CLPOF * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND CLPON * * CLPON NOP LDA .1 STA CODE LDA .76 STA ERCOD LDA CLPON CLP JSB .OPTN DEF RTN DEF PARM DEF M2 DEF CODE DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XCLPN DEF END PARM BSS 2 END JMP RETRN,I * CLPOF NOP LDA .2 STA CODE LDA .77 STA ERCOD LDA CLPOF JMP CLP * ERROR JSB PLTER DEF RTNER DEF ERCOD RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .77 DEC 77 .76 DEC 76 .2 OCT 2 ERCOD NOP CODE NOP .1 OCT 1 .0 OCT 0 END k ek 92840-18067 1819 S C0122 SHOW INTF MOD              H0101 *ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SHOW * SOURCE: 92840 - 18067 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM SHOW,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * SHOW. * EXT XSHOW,.OPTN,PLTER ENT SHOW * * SHOW NOP LDA SHOW JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M6 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .5 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XSHOW DEF END PARM BSS 6 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M6 DEC -6 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 78 CODE NOP * END / fl 92840-18068 1819 S C0122 DRAW INTFC MOD              H0101 NASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DRAW * SOURCE: 92840 - 18068 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM DRAW,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * DRAW. * EXT XDRAW,.OPTN,PLTER ENT DRAW * * DRAW NOP LDA DRAW JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XDRAW DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 69 CODE NOP * END # gm 92840-18069 1819 S C0122 MOVE INTFC MOD              H0101 9ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MOVE * SOURCE: 92840 - 18069 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MOVE,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MOVE. * EXT XMOVE,.OPTN,PLTER ENT MOVE * * MOVE NOP LDA MOVE JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XMOVE DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 70 CODE NOP * END  hn 92840-18070 1819 S C0122 DRAWI INTFC MOD              H0101 \ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DRAWI * SOURCE: 92840 - 18070 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM DRAWI,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * DRAWI. * EXT XDRWI,.OPTN,PLTER ENT DRAWI * * DRAWI NOP LDA DRAWI JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XDRWI DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 71 CODE NOP * END "} io 92840-18071 1819 S C0122 MOVEI INTFC MOD              H0101 zASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MOVEI * SOURCE: 92840 - 18071 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MOVEI,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MOVEI. * EXT XMOVI,.OPTN,PLTER ENT MOVEI * * MOVEI NOP LDA MOVEI JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XMOVI DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 72 CODE NOP * END  jp 92840-18072 1819 S C0122 DRAWR INTFC MOD              H0101 gASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DRAWR * SOURCE: 92840 - 18072 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM DRAWR,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * DRAWR. * EXT XDRWR,.OPTN,PLTER ENT DRAWR * * DRAWR NOP LDA DRAWR JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XDRWR DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 73 CODE NOP * END Z kq 92840-18073 1819 S C0122 MOVER INTFC MOD.              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MOVER * SOURCE: 92840 - 18073 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MOVER,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MOVER. * EXT XMOVR,.OPTN,PLTER ENT MOVER * * MOVER NOP LDA MOVER JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XMOVR DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 74 CODE NOP * END L lr 92840-18074 1819 S C0122 LORG INTFC MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: LORG INTFC MOD * SOURCE: 92840 - 18074 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM LORG,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XLORG ENT LORG * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND LORG * * LORG NOP LDA LORG JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .2 TWO REQUIRED PARAMETERS DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XLORG DEF END PARM BSS 3 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .79 RTNER JMP RETRN,I * M3 OCT -3 RETRN NOP .79 DEC 79 .2 OCT 2 .1 OCT 1 .0 OCT 0 END  ms 92840-18075 1819 S C0122 FXD INTFC MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: FXD INTFC MOD * SOURCE: 92840 - 18075 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM FXD,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XFXD ENT FXD * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND FXD * * FXD NOP LDA FXD JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .2 TWO REQUIRED PARAMETERS DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XFXD DEF END PARM BSS 3 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .80 RTNER JMP RETRN,I * M3 OCT -3 RETRN NOP .80 DEC 80 .2 OCT 2 .1 OCT 1 .0 OCT 0 END 8 nt 92840-18076 1819 S C0122 PENUP INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PEN UP INTFC MOD * SOURCE: 92840 - 18076 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PENUP,7 92840-16001 REV 1819 780515 EXT .OPTN,PLTER,XPNUP ENT PENUP * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND PENUP * * PENUP NOP LDA PENUP JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XPNUP DEF END PARM BSS 2 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF ERCOD RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP ERCOD DEC 81 .1 OCT 1 .0 OCT 0 END i ou 92840-18077 1819 S C0122 PENDN INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: * SOURCE: 92840 - 18077 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PENDN,7 92840-16001 REV 1819 780515 EXT .OPTN,PLTER,XPNDN ENT PENDN * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND PENDN * * PENDN NOP LDA PENDN JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XPNDN DEF END PARM BSS 2 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF ERCOD RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP ERCOD DEC 82 .1 OCT 1 .0 OCT 0 END  pv 92840-18078 1819 S C0122 PORG INTFC MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PORG * SOURCE: 92840 - 18078 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PORG,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * PORG. * EXT XPORG,.OPTN,PLTER ENT PORG * * PORG NOP LDA PORG JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XPORG DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 83 CODE NOP * END  qw 92840-18079 2040 S C0122 &GPSNM SOURCE             H0101 ASMB,R,L * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GPSNM -- GPS LIBRARY HEADER * SOURCE: 92840 - 18079 * RELOC: 92840 - 16001 * * * ************************************************************* NAM GPS78,7 92840-16001 REV.2040 800807 END g rx 92840-18080 2013 S C0122 &GCBIM              H0101 o~FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GCBIM (PART 2 GRAPHICS LINKAGE MODULE) C SOURCE: 92840 - 18080 C RELOC: 92840 - 16002 C C C CC*********************************************************** C SUBROUTINE GCBIM(ICODE,ICDL,IBUFR,IBUFL, 1IRW), 92840-16002 REV.2013 790904 DIMENSION IBUFR(2),IBUFL(2),IGCBF(12) DIMENSION ICODE(2),IGTBL(35) INTEGER PNPOS,ERMSK,ERRLU,ERRCD C C MNEMONIC EQUIVALENCES BETWEEN VALUES IN THE IGTBL AND WHAT C THESE VALUES ARE SUPPOSED TO REPRESENT (E.G. VALUES V1 AND V2 C MNEMONIC EQUIVALENCE IV12). C C THE VALUES IN THE IGTBL CONTAIN THE GCB POINTER IN BITS 0-7 C AND THE LENGTH OF THE DATUM IN BITS 8-15. C C EQUIVALENCE (IGTBL,IGCBL),(IGTBL(2),LUN),(IGTBL(3),ID) EQUIVALENCE (IGTBL(4),IOBUF),(IGTBL(5),ISTAT),(IGTBL(6),MUMM) EQUIVALENCE (IGTBL(7),ICSZE),(IGTBL(8),IG12) EQUIVALENCE (IGTBL(9),IV12),(IGTBL(10),IS12),(IGTBL(11),IADP) EQUIVALENCE (IGTBL(12),IAD),(IGTBL(13),IGDU),(IGTBL(14),IPORG) EQUIVALENCE (IGTBL(15), LORG),(IGTBL(16),IGICB) EQUIVALENCE (IGTBL(17),IPRG), (IGTBL(18),ICLIP) EQUIVALENCE (IGTBL(19), IPDIR),(IGTBL(20),IPSCL) EQUIVALENCE (IGTBL(21),LRG),(IGTBL(22),LDIR) EQUIVALENCE(IGTBL(23),LINE) ,(IGTBL(24),PNPOS) EQUIVALENCE (IGTBL(25),LNTH),(IGTBL(26),N),(IGTBL(27),IUXY) EQUIVALENCE (IGTBL(28),ERRLU),(IGTBL(29),ERMSK),(IGTBL(30),ERRCD) EQUIVALENCE (IGTBL(31),LNTYP),(IGTBL(32),IOSAV) C************************************************************* C 5-26-79 THREE NEW LOGICAL PTRS ADDED INTO IGTBL. C 1) ICHAR POI0NTS TO THE SOFTWARE WIDTH, AND HEIGHT. C 2) ICSLN POINTS TO THE SOFTWARE SLANT. C 3) ICDIR POINTS TO THE SOFTWARE LDIR. C C THE VALUES ARE STORED EXACTLY AS THE USER REQUESTED IN THE CSIZE CALL. C EQUIVALENCE (IGTBL(33),ICHAR),(IGTBL(34),ICSLN) EQUIVALENCE (IGTBL(35),ICDIR) C C C THIS IS THE GRAPHICS CONTROL BLOCK INTERFACE MODULE C THAT IS RESPONSIBLE FOR INTERFACING BETWEEN THE GCB C AND OTHER MODULES ON THE GRAPHICS PACKAGE. C C CALLING SEQUENCE: CALL GCBIM(ICODE,ICDL,IRW,IBUFR) C WHERE : ICODE = ARRAY OF CODES WHICH CORRESPOND TO C TO THE VARIABLE(S) OF INTEREST IN THE GCB. C ICODE >0 BUT NOT 99 -RETRIEVE OR STORE DATA INTO GCB. C ICODE = 0 - SAVE GCB ADDRESS AND SET 99 INTO FW OF GCB. C ICODE = -99 - CLEAR FIRST WORD OF GCB (PLOTR(0)) C ICODE = 99 - AGL COMMAND OTHER THAN PLOTR(1 OR 4). C CHECK FOR EXISTENCE OF 99 IN FIRST WORD AND C SAVE ADDRESS LOCALLY. ERROR IF 99 NOT IF FIRST C WORD. C C ICDL = LENGTH OF ICODE C IRW = 1(READ),2(WRITE),3(TRANSFER) C IBUFR= BUFFER TO BE FILLED OR EMPTIED C IBUFL= 0 IF LENGTH ASSOCIATED WITH GCB POINTER IS C TO BE USED. C NE.0 - IF LENGTH IN IBUFL IS TO BE USED. C NONZERO IBUFL IS USED FOR SUCH THINGS AS C IOBUF, GICB AND DEVICE SUBROUTINE SCRATCH AREA. C C C DATA LNTH /2001B/ DATA N/517B/ DATA IUXY/2120B/ DATA IGCBL/ 401B/ DATA LUN/ 403B/ DATA ID/ 404B/ DATA IOBUF/1006B/ DATA IOSAV/544B/ DATA ISTAT/ 410B/ DATA LNTYP/1511B/ DATA MUMM/ 2011B/ DATA ERRLU/405B/ DATA ERMSK/534B/ DATA ERRCD/402B/ DATA ICSZE/2015B/ DATA IG12/4021B/ DATA IV12/4031B/ DATA IS12/4041B/ DATA IADP/4051B/ DATA PNPOS/2117B/ } DATA IAD/ 4061B/ DATA LINE/3111B/ DATA IGDU/2071B/ DATA IPORG/4101B/ DATA LORG/1514B/ DATA IGICB/ 530B/ DATA ICLIP/ 2075B/ DATA IPRG/2101B/ DATA IPDIR/2105B/ DATA IPSCL/1103B/ DATA LRG/514B/ DATA LDIR/1115B/ C*************************************************************** C 3 NEW PTRS ADDED 5-26-79 BY STEVE YOUNG. C ICHAR IS 4 WORDS LONG (SOFTWARE CHAR WIDTH AND HEIGHT), POINTS TO C WORD 185 IN THE GCB. C ICSLN IS 2 WORDS LONG (SOFTWARE CHARACTER SLANT), POINTS TO C WORD 189 IN THE GCB. C ICDIR IS 2 WORDS LONG (SOFTWARE CHAR DIRECTION) AND POINTS TO C WORD 191 IN THE GCB. C DATA ICHAR/2271B/ DATA ICSLN/1275B/ DATA ICDIR/1277B/ IND = 0 C C C IF(ICODE.EQ.0)GO TO 5 IF(ICODE.EQ.99)CALL ABSAD(ICODE,0,IBUFR) ISTS = 0 CALL PLTER(-98,ISTS) IF(ISTS.EQ.0)GO TO 5 C C CALL ABSAD(8,1,ISTS ,1,IND) C IF(IND.LT.0)GO TO 4 C IND = IAND(ISTS , 40000B) C IF(IND.EQ.0)GO TO 5 C IF(IND.EQ.40000B)CALL PLTER(13) C IBUFL = 1 C RETURN C SEE IF A PLOTR(0) CALL OR PLOTR(1) C IF(ICODE.EQ.99)IBUFL = 1 RETURN C C 5 IF(ICODE.EQ.99)RETURN IF(ICODE)100,150,50 C C TRANSMIT DATA TO/FROM GCB C 50 J = 1 IF(IRW.EQ.3)GO TO 210 DO 200 I=1,ICDL ICD = ICODE(I) IPTR = IAND(IGTBL( ICD),377B) LNGTH = IBUFL IF(IBUFL)52,52,55 52 LNGTH = (IAND(IGTBL(ICD),177400B))/400B 55 CALL ABSAD(IPTR,IRW,IBUFR(J),LNGTH,IND) IF(IND)800,60,800 60 J = J + LNGTH 200 CONTINUE RETURN C C THIS PORTION OF CODE IS RESPONSIBLE FOR TRANSFERRING DATA C FROM ONE SECTION OF THE GCB TO ANOTHER. C 210 IPTR = IAND(IGTBL(ICODE),377B) CALL ABSAD(IPTR,1,IGCBF,10,IND) DO 220 I = 1,IBUFL ICD = IBUFR(I) IPTR = IAND(IGTBL(ICD),377B) LNGTH = (IAND(IGTBL(ICD),177400B))/400B 1CALL ABSAD(IPTR,2,IGCBF(J),LNGTH,IND) J= J +LNGTH 220 CONTINUE RETURN C C SAVE GCB ADDRESS C 150 CALL ABSAD(ICODE,IRW,IBUFR,LNGTH,IND) RETURN C C RE-INIT GCB C 100 CALL ABSAD(ICODE,0,IBUFR) RETURN C C ERROR GCB DOES NOT EXIST- C 800 RETURN END C C C CC*********************************************************** C SUBROUTINE PLTER(IERCD,IRTN), 92840-16002 REV. 1913 790130 INTEGER PRMER(8),PRM1,PRM2,PRM3,PRM4,PRM5,PRM6,PRM7,PRM8 EM1901 INTEGER HDMSK(7),HDERR(7) EM1901 DIMENSION IBUFR(5),ICODE(2),MSG(14) DIMENSION MEQT(4) DIMENSION IERR(4) EM1913 EQUIVALENCE (IBUFR,LUER),(MSG(4),MSG4),(MSG(5),MSG5) EQUIVALENCE (IBUFR(2),IB2),(MSG(6),MSG6),(MSG(7),MSG7) EM1901 EQUIVALENCE (MSG(8),MSG8),(PRMER,PRM1),(PRMER(2),PRM2) EM1901 EQUIVALENCE (PRMER(3),PRM3),(PRMER(4),PRM4),(PRMER(5),PRM5) EM1901 EQUIVALENCE (PRMER(6),PRM6),(PRMER(7),PRM7),(PRMER(8),PRM8) EM1901 C C THIS ROUTINE IS RESPONSIBLE FOR LETTING THE USER KNOW C WHEN THERES BEEN A MESS UP. C DATA MSFLG/0/ EM1901 DATA MSG/2H ,2HGP,2HS ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , EM1913 1 2H ,2H ,2H / EM1913 DATA MEQT/2400B,3400B,17400B,5000B/ DATA PRMER/2H99,2H ,2H6 ,2H ,2H37,2H ,2HFM,2HP / EM1901 DATA IEFMT/37/ EM1901 DATA ICODE/28,27/ DATA HDERR/1,2,5,3/ DATA HDMSK/0,0,0,0,0,0,0/ DATA IERR/-97,40,199,4/ EM1913 C C C HANDLE SPECIAL CODES NOT REQUIRING MESSAGE OUTPUT. AN ATTEMPT EM1913 C IS BEING MADE HERE TO OPTIMIZE CODE FOR CALL PLTER(-98) BECAUSE EM1913 C IT IS CALLED SO OFTEN. THEREFORE, CODE MAY NOT BE IDEALLY EM1913 C STRUCTURED AND A SMALL AMOUNT OF EXTRA CORE MAY BE SACRIFICED. EM1913 C IF (IERCD.EQ.-98) GO TO 900 EM1913 IF (IERCD.EQ.-99) GO TO 900 EM1913 IF (IERCD.EQ.6) GO TO 820 EM1913 C C FROM NOW ON, OUTPUT OF ERROR MESAGES IS INVOLVED. THE MESSAGE EM1913 C BUFFER IS REFRESHED AFTER EACH USE SO IT'S ALREADY SET UP. EM1913 C EM1913 C SET THE DEFAULT UNIT FOR LOGGING HARD ERRORS TO THE CURRENT CONSOLE, EM1840 C THE VALUE RETURNED BY THE SYSTEM FUNCTION LOGLU EM1840 C LUER = LOGLU(DUMMY) EM1840 C C IENAM = IERCD C C CHECK ON HARD ERRORS 4 & 40 AND SPECIAL CALLS -97 & 199 EM1913 C 2 DO 7 K =1,4 IF(IERCD.EQ.IERR(K))GO TO (1000,800,840,99),K 7 CONTINUE C C MORE CHECKS C C C C GET LU# AND ERROR MASKS C IF(MSFLG.EQ.1.AND.IERCD.GT.39)GO TO 800 15 CALL ABSAD( 5,1,IBUFR,1,ICHR) C C IF LU FOR ERROR LOGGING STILL INITIALIZED AT -1, SET DEFAULT EM1840 C TO CURRENT CONSOLE BY CALLING SYSTEM FUNCTION LOGLU. EM1840 IF(LUER.EQ.-1)LUER = LOGLU(DUMMY) EM1840 C CALL ABSAD(80,1,IB2,4,ICHR) MSFLG = 0 C C ERR CODES 40-94 INDICATE PARAMETER ERRORS IN SUBROUTINE EM1901 IF(IERCD.GT.39)GO TO 800 C C IF IERCD IS LESS THAN -300, WE KNOW THAT WE HAVE AN FMP ERROR CODE EM1913 IF (IERCD.LT.-300) GO TO 400 EM1913 C IMPY = MOD(IERCD,16) INDX = IERCD/16 + 2 IF(IMPY.NE.0) GO TO 60 EM1913 50 INDX = INDX - 1 IMSK = 100000B GO TO 65i 60 IMSK = 2 **(IMPY -1) C C SEE WHAT TYPE OF ERROR HARD,SOFT OR FIRM C C FIRM?? C 65 ITST = IAND(IBUFR(INDX) ,IMSK) IF(ITST.EQ.0)GO TO 300 C C FIRM OR HARD ERROR THAT MUST BE REPORTED. C FIRST CONVERT ERROR CODE TO ASCII THEN OUTPUT TO ERROR C LOGGING DEVICE. C C 99 ICHR = 0 CALL CONVT(IENAM,MSG4,ICHR,1) ICHR = ICHR + 6 J = ICHR/2 + 1 C C C C SECTION 160 IS THE END PROCESSING FOR NORMAL, GPS 99, AND FMP ERRORS EM1901 160 CALL REIO(2,LUER,MSG,J) EM1913 C C C REFRESH THE MESSAGE BUFFER, CLEANING IT OUT AFTER USE FOT NEXT TIME EM1913 DO 5 K=4,14 EM1913 MSG(K) = 20040B EM1913 5 CONTINUE EM1913 C EM1913 C EM1913 C FIRM ERROR OR SOFT UPDATE ERROR WORD IN GCB C IF MSGFLG = 1 OR IERCD = 40 DO NOT UPDATE GCB SINCE WE DON'T C HAVE ONE YET. IERCD = 40 IS FROM PLOTR PARAMETER ERROR C AND MSGFLG = 1 INDICATES A MISSING GCB FROM ONE OF THE C OTHER AGL COMMANDS. C 300 IF(MSFLG.EQ.1.OR.IENAM.EQ.40.OR.IENAM.EQ.4)GO TO 305 CALL ABSAD(2 ,2,IENAM,1,ICHR) 305 MSFLG = 0 RETURN C C WE HAVE AN FMP ERROR, SIGNALED BY THE NEGATIVE FMP ERROR CODE. EM1913 C PLTER IS PASSED (FMP ERROR CODE - 300) SO A -99 FMP ERROR WON'T EM1913 C BE CONFUSED WITH A -99 SPECIAL REQUEST CODE. THIS EM1913 C TYPE OF ERROR WILL ALWAYS BE FIRM AND WILL BE LOGGED IN THE GCB AS EM1901 C ERROR 37. THE ERROR MESSAGE WILL LOOK LIKE GPS 37 FMP -XX. EM1901 400 MSG4=PRM5 EM1901 MSG5=PRM6 q EM1901 MSG6=PRM7 EM1901 MSG7=PRM8 EM1901 ICHR=0 EM1901 IENAM=IENAM + 300 EM1913 CALL CONVT(IENAM,MSG8,ICHR,1) EM1913 ICHR=ICHR+14 EM1901 J=ICHR/2+1 EM1901 IENAM=IEFMT EM1901 GO TO 160 EM1901 C C PLOTR PARAMETER ERROR C 800 MSG4 = PRM1 MSG5 = PRM2 IF(MSFLG.EQ.0)GO TO 805 C C SET ERROR MESSAGE = GPS 99 C 802 MSG4 = PRM3 MSG5 = PRM4 805 J = 6 CALL GTNAM(IENAM,MSG6,J) GO TO 160 C C MISSING GCB C C C ERROR 6 C 820 MSFLG = 1 RETURN C C ERROR 199 FROM ABSAD PLOTR 0,2,3 MISSING GCB C 840 IENAM = 40 GO TO 802 C C IERCD = -98 OR -99. -98 INDICATES TO RETRIEVE RECENT ERROR C CODE AND REPORT A HARD ERROR. A -99 INDICATES TO REPORT C A HARD ERROR AND CLEAR ERROR CODE. C 900 CALL ABSAD(2,1,IRTN,1,ICHR) C C WE WANT TO RETURN IF IRTN = 1,2,3,5. EM1913 C ELSE CONTINUE. THESE THREE TESTS EM1913 C REPLACE THE COMMENTED OUT DO-LOOP EM1913 C IN AN ATTEMPT TO OPTIMIZE EXECUTION EM1913 IF (IRTN.LE.0) GO TO 951 EM1913 IF (IRTN.GT.5) GO TO 951 EM1913 IF (IRTN.EQ.4) GO TO 951 EM1913 RETURN EM1913 C C DO 950 I=1,4 C IF(IRTN.EQ.HDERR(I))RETURN C950 CONTINUE C 951 MSFLG = 0 EM1913 IRTN = 0 IF(IERCD.EQ.-98)RETURN C C CLEAR ERROR WORD IN GCB C CALL ABSAD(2,2,IRTN,1,ICHR) RETURN C C 1000 IF(IRTN.GT.63.OR.IRTN.LT.0)GO TO 10010 EM1913 CALL EXEC(100015B,IRTN,IEQ5,IEQ4) GO TO 10010 C C MASK OUT DRIVER ID C 625 IEQ5 = IAND(IEQ5,37400B) DO 600 L=1,4 IF(IEQ5.EQ.MEQT(L))RETURN 600 CONTINUE C GO TO 10010 EM1913 C C REPORT ERROR 5 - ILLEGAL LU EM1913 C 10010 IENAM = 5 GO TO 99 END C CC*********************************************************** C SUBROUTINE CONVT(INTX,IABUF,ICHR,N), 92840-16002 REV. 1819 780515 DIMENSION IABUF(2),INTX(2),ICNV(4) DATA MINUS/55B/ DATA ICOMA/54B/ C C THIS ROUTINE CONVERTS N INTEGER VALUES IN "INTX" TO ASCII C AND PLACES IT IN "IABUF". THE FORMAT OF IABUF IF N=2 WHEN C FINISHED LOOKS LIKE: C WORD 1 D1X D2X C " 2 D3X D4X C " 3 D5X , C " 4 D1Y D2Y C " 5 D3Y D4Y C " 6 D5Y C C WHERE D(I) = ASCII DIGIT C C C IF A NEGATIVE NUMBER IS ENTERRED D1 BECOMES A MINUS SIGN C AND THE OTHER DIGITS ARE MOVED DOWN ONE. SOME OF THESE WORDS C MAY NOT BE FILLED UPON RETURN THEREFORE PARAMETER "ICHR" TELLS C THE ACTUAL NUMBER OF CHARACTERS IN IABUF. C C INITIALIZE PARAMETERS C DO 100 K = 1,N IX = INTX(K) IF(INTX(K))5,7,7 5 IX = -IX C C CONVERT INT TO ASCII C 7 CALL CNUMD(IX,ICNV) IF(INTX(K))10,20,20 C C SEE IF A MINUS AND IF SO INSERT MINUS SIGN INTO IABUF(I) C 10 I = ICHR/2 + 1 CALL BYTE(ICHR ,MINUS,IABUF(I)) ICHR = ICHR+1 20 DO 50 J =1,3 EC C PLACE EACH BYTE INTO IABUF C I= ICHR/2 + 1 IX = (IAND(ICNV(J) ,177400B))/400B IF(IX.EQ.40B)GO TO 40 CALL BYTE(ICHR ,IX,IABUF(I)) ICHR = ICHR + 1 I = ICHR/2 + 1 40 IX = IAND(ICNV(J) ,377B) IF(IX.EQ.40B)GO TO 50 CALL BYTE(ICHR ,IX,IABUF(I)) ICHR = ICHR + 1 50 CONTINUE I = ICHR/2 + 1 IF(K.EQ.N)RETURN CALL BYTE(ICHR,ICOMA,IABUF(I)) ICHR = ICHR + 1 I = ICHR/2 + 1 100 CONTINUE RETURN END C C CC*********************************************************** C SUBROUTINE BYTE(LR,IBYTE,IWRD), 92840-16002 REV. 1819 780515 DIMENSION MASK(2),MPY(2) DATA MASK/377B,177400B/ DATA MPY/400B,1/ C C C THIS ROUTINE IS RESPONSIBLE FOR PLACING A BYTE EITHER C IN THE LEFT OR RIGHT SIDE OF THE PARAMETER "IWRD". C THE PARAMETER LR INDICATES WHETHER IT IS THE RIGHT OR C LEFT SIDE. C LR = 1 LEFT SIDE C LR = 2 RIGHT SIDE C C THE PARAMETER LR IS INCREMENTED EACH TIME BY THE CALLING C PROGRAM. C L = IAND(LR,1) + 1 IB = IBYTE * MPY(L) IWRD = IOR(IAND(IWRD,MASK(L)),IB) RETURN END SUBROUTINE OUTPT(ICMND,IBUFR,IRW), 92840-16002 REV.1913 781218 INTEGER STPLB DIMENSION IBUFR(2) DATA IGICB/16/ DATA STPLB/24000B/ DATA IECHK/77400B/ C C THIS LITTLE ROUTINE IS RESPONSIBLE FOR SENDING C OUTPUT DATA TO THE GCB AND THEN INVOKING THE C DEVICE SUBROUTINE VIA GSWCH. EM1913 C C MAKE DEVICE SUBROUTINE CHECKS IF NECESSARY C ISTAT = 0 CALL PLTER(-98,ISTAT) IF(ISTAT.NE.0)RETURN CALL GRSTS(1,2000B,ISTAT) IF(ISTAT.NE.0)GO TO 5 CALL GCBIM(IGICB,1,IECHK,1,2) CALL GSWCH(0) EM1913 CALL GCBIM(IGICB,1,ISTAT,1,1) IF(ISTAT.NE.0)GO TO 150 CALL GRSTS(2,0,2000B) C CHECK ON LABEL MODE SITUATION. C ISTAT = 0 5 CALL GRSTS(1,100B,ISTAT) IF(ISTAT.EQ.0)GO TO 10 CALL GCBIM(IGICB,1,STPLB,1,2) CALL GSWCH(0) EM1913 CALL PLTER(35) C C RESET BIT C CALL GRSTS(2,77677B,0) 10 INDX = 1 DO 100 I = 1,ICMND L = IAND(IBUFR(INDX),377B) + 1 IF(IRW.EQ.1)L=1 CALL GCBIM(IGICB,1,IBUFR(INDX),L,2) CALL GSWCH(0) EM1913 INDX = INDX + L 100 CONTINUE RETURN 150 CALL PLTER(ISTAT) RETURN END C C CC*********************************************************** C SUBROUTINE GRSTS(ISET,MASK,NMASK), 92840-16002 REV.1819 780515 C C THIS ROUTINE IS RESPONSIBLE FOR SETTING AND UNSETTING C BITS IN THE GCB STATUS WORD, AND ALSO FOR SENDING C MASKED OUT PORTIONS OF THE STATUS WORD BACK TO THE C CALLER. C C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANING: C ISET = 1 RETRIEVE DATA FROM STATUS WORD C = 2 SET BIT(S) IS STATUS WORD. C MASK IS THE PATTERN TO BE ANDED WITH THE STATUS WORD C NMASK- FOR ISET = 1 THIS WORD WILL CONTAIN THE RESULTANT C STATUS WORD ANDED WITH MASK. C FOR ISET = 2 THIS IS THE BIT PATTERN TO BE INCLUSIVE ORED C WITH THE RESULT OF (MASK.AND.STATUS). C ISTAT = 0 CALL PLTER(-98,ISTAT) IF(ISTAT.NE.0)RETURN CALL ABSAD(8,1,ISTAT,1,IND) IST = IAND(ISTAT,MASK) GO TO(10,20),ISET 10 NMASK = IST RETURN C 20 ISTAT = IOR(IST,NMASK) CALL ABSAD(8,2,ISTAT,1,IND) RETURN END INTEGER FUNCTION IADCD(D), 92840-16002 REV.1819 780515 C THIS FUNCTION DETERMINES WHAT FLAVOR OF TRANSFORMATION C CONSTANTS TO USE: A' - D' = 11 MU/GDU C A - D = 12 MU/UDU C ISTAT = 0 IADCD =11 CALL GRSTS(1,1,ISTAT) IF(ISTAT.NE.0)IADCD = 12 RETURN END INTEGER FUNCTION IS1V1(D), 92840-16002 REV.1819 780515 C C THIS FUNTION DETERMINES WHETHER TO USE SOFT CLIP LIMITS C S1 - S2 OR HARD CLIP LIMITS G1-G2 C ISTAT = 0 IS1V1 = 8 CALL GRSTS(1,4,ISTAT) IF(ISTAT.NE.0)IS1V1 = 10 RETURN END SUBROUTINE PKBIN(INBUF,IOBUF,ICHR,NUM, 1N), 92840-16002 REV.1819 780515 DIMENSION INBUF(2),IOBUF(2) DIMENSION IMSK(3),ISHFT(3) DATA IMSK/70000B,1740B,37B/ DATA ISHFT/10000B,40B,1/ C C C THIS SUBROUTINE IS RESPONSIBLE FOR TAKING INTEGER VALUES C IN INBUF AND CONVERTING THEM TO INTO PACKED BINARY FORMAT C AND RETURNING THE VALUES IN IOBUF. C THE DIFFERENT FORMATS THAT ARE RETURNED IN IOBUF ARE IN C THE FOLLOWING FORMATS: C C INBUF IOBUF NUM C X,Y (0-1023) WD 1 BYT1\BYT2 1=ABSOLUTE C (HI-X,LO-X) C WD 2 BYT3\BYT4 C (HI-Y,LO-Y) C X,Y(-16-+15) WD 1 BYT1=X\BYT2=Y 2=SHORT INCREMENTAL C C X,Y(-16384 TO 16383) WD 1 BYT1\BYT2 3=LONG INCREMENTAL C (HI-DX,MID-DX) C WD 2 BYT3\BYT4 C (LO-DX,HI-DY) C WD 3 BYT5\BYT6 C (MID-DY,LO-DY) C C N = NUMBER OF PAIRS TO CONVERT K = 1 C C BRANCH TO APPROPRIATE PARSER C C GO TO (10,20,30),NUM C C ABSOLUTE C 10 DO 100 J=1,N IBYTE =(IOR(IAND(INBUF(J),1740B), 2000B))/40B CALL BYTE(ICHR,IBYTE,IOBUF(K)) K = IAND(ICHR,1) + K ICHR = ICHR+1 IBYTE = IOR(IAND(INBUF(J),37B),40B) CALL BYTE(ICHR,IBYTE,IOBUF(K)) K = IAND(ICHR,1) + K ICHR = ICHR+1 100 CONTINUE RETURN C C SHORT INCREMENTAL C C0 LOOP = N/2 C JJ = 0 C DO 200 J=1,LOOP C DO 198 KK =1,2 C JJ = JJ+1 C IBYTE = IOR(IAND(INBUF(JJ),37B),40B) C CALL BYTE(ICHR,IBYTE,IOBUF(K)) C K = IAND(ICHR,1) + K C ICHR = ICHR + 1 C98 CONTINUE C00 CONTINUE C RETURN C C LONG INCREMENTAL C C0 DO 300 J=1,N C DO 400 I=1,3 C INB = INBUF(J) C IBYTE = IOR((IAND(IMSK(I),INB)/ISHFT(I)),40B) C IF(INB.LT.0.AND.I.EQ.1)IBYTE = IOR(IBYTE,30B) C CALL BYTE(ICHR,IBYTE,IOBUF(K)) C K = IAND(ICHR,1) + K C ICHR = ICHR + 1 C00 CONTINUE C00 CONTINUE C RETURN END C NAME: CLIPPING ALGORITHM C C C CC*********************************************************** C SUBROUTINE CLPNG(POINT,CLPTS,ENDPT, 1IFLG), 92840-16002 REV.1819 780515 INTEGER OC1,OC2,OCODE DIMENSION POINT(4),CLPTS(4) C C THIS IS THE CLIPPING ALGORITHM FOR THE C AGL GRAPHICS PACKAGE. THE PARAMETERS IN THE CALLING C SEQUENCE HAVE THE FOLLOWING MEANINGS: C C POINT - 4 WORD ARRAY WITH VECTOR ENDPOINT X(B),X(A) C CLPTS - 4 WORD ARRAY WHICH WILL CONTAIN THE RESULTS OF THE C COMPUTATIONS CONTAINED WITHIN. C ENDPT - DIAGONAL END POINTS FOR WINDOW OR VIEWPORT C IFLG - = 0 IF X(A) IS INSIDE BOUNDARY C = 1 " " " OUTSIDE C C DELTA = .5 IF(IFLG.LT.0)DELTA = 0. IND = IFLG IFLG = 0 C C C C MAKE TRIVIAL TEST TO SEE IF LINE IS INVISIBLE C C OC1 = OCODE(POINT,ENDPT,DELTA) OC2 = OCODE(POINT(3),ENDPT,DELTA) IF(IAND(OC1,OC2).EQ.0)GO TO 90 50 IFLG = 1 IF(IND.LT.0)RETURN GO TO 200 C C LINE IS PARTIALLY VISIBLE OR COMPLETELY VISIBLE, THE C LINES OF CODE DETERMINE THIS. C 90 DO 95 I=1,4 CLPTS(I) = POINT(I) 95 CONTINUE IF(OC1.EQ.0)GO TO 100 CALL CLIPO(OC1,CLPTS(1),CLPTS(2),CLPTS(3),CLPTS(4),ENDPT) C C CLPTS 1 AND 2 NOW CONTAIN CLIPPED POINTS, NOW DEAL WITH C OTHER END-POINT. C 100 IF(OC2.EQ.0)GO TO 200 CALL CLIPO(OC2,CLPTS(3),CLPTS(4),CLPTS,CLPTS(2),bENDPT) IF(OC1.NE.0.OR .OC2.NE.0)GO TO 50 C C NOW SEE IF SOFT CLIPPING IS ON AND IF SO CUT OUT. IF HARD C CLIPPING IS IN FORCE ASCERTAIN WHETHER OR NOT THE HARD CLIP C LIMITS HAVE BEEN REDEFINED AND WHETHER OR NOT THE DEVICE CAN C HANDLE IT. IF THE DEVICE CAN DO ITS ON CLIPPING FOR REDEFINED C HARD CLIP LIMITS LET IT. C 200 ISTAT = 0 CALL GRSTS(1,4,ISTAT) IF(ISTAT.NE.0)RETURN CALL GRSTS(1,10B,ISTAT) IF(ISTAT.NE.0)RETURN C C LET DEVICE DO IT. C DO 250 I=1,4 CLPTS(I) = POINT(I) 250 CONTINUE IF(IFLG.EQ.1)CALL PLTER(20) IFLG= 0 RETURN END SUBROUTINE CLIPO(IOC,X1,Y1,X2,Y2, 1ENDPT), 92840-16002 REV.1819 780515 INTEGER OCODE DIMENSION ENDPT(4),XI(2),ENDXY(4) EQUIVALENCE (ENDXY,END1),(ENDXY(2),END2),(ENDXY(3),END3) EQUIVALENCE (ENDXY(4),END4) C C THIS ROUTINE PUSHES THE ENDPOINT X1,Y1 TOWARD THE C THE CLIPPING BOUNDARY IT IS HANGING OFF. C INDX = IOC DELTA = .5 C WRITE(6,500)(ENDPT(K),K=1,4) C00 FORMAT(2X,"ENDPOINTS =",4(X,F7.3)) C WRITE(6,1000)IOC,X1,Y1,X2,Y2 C000 FORMAT(2X,"OC,X1-Y2",2X,K6,4(X,F8.3)) C LOOP = 0 5 DX = X2 - X1 DY = Y2 - Y1 K = 1 SLOPE = DY/DX DO 7 L=1,4 7 ENDXY(L) = ENDPT(L) IF(INDX.GT.2)INDX = (INDX/4) + 2 GO TO(10,20,30,40),INDX C C PUSH TOWARD LEFT SIDE C 10 Y1 = Y1 + SLOPE * (ENDPT - X1) X1 = END1 GO TO 50 C C PUSH TOWARD RIGHT SIDE C 20 XR = END3 Y1 = Y1 + SLOPE * (XR - X1) X1 = XR GO TO 50 C C PUSH TOWARD BOTTOM C 30 YB = END2 X1 = X1 + (1/SLOPE) * (YB - Y1) Y1 = YB K = 2 GO TO 50 C C PUSH DOWN ON TOP C 40 YT = END4 X1 = X1 + (1/SLOPE) * (YT - Y1) Y1 = YT C K = 2 C TEST FOR INNESS C 50 XI = X1 XI(2) = Y1 C WRITE(6,2000)X1,Y1 C000 FORMAT(2X,"CLIPPED?;TRN POINTS X1,Y1",2(X,F7.3)) INDX = OCODE(XI,ENDPT,DELTA) IOC = INDX C WRITE(6,3000)INDX C000 FORMAT(2X,"ITST = ",K6) C LOOP = LOOP + 1 IF(LOOP.GT.10)RETURN IF(INDX.NE.0)GO TO 5 IOC = 0 RETURN C C TAKE CARE OF CORNER CASE C C00 IF(ABS(OVSLP - ABS(SLOPE)).GE.EPSI)RETURN C IOC = 0 C GO TO(610,620),K C10 Y1 = YEND C WRITE(6,2)Y1 C FORMAT(2X, "Y1 =",F7.2) C RETURN C20 X1 = XEND C WRITE(6,3)X1 C FORMAT(2X,"X1=",F7.2) C RETURN END INTEGER FUNCTION OCODE(POINT,ENDPT, 1DELTA), 92840-16002 REV.1819 780515 INTEGER GRIFX DIMENSION POINT(2),ENDPT(4) C C THIS LITTLE FUNTION IS RESPONSIBLE FOR COMPUTING C THE OUT CODES FOR THE CLIPPING ALGORITHM. C ICD1 = 0 ICD2 = 0 OCODE = 0 C C C WRITE(6,1200)IPT1,IPT2,POINT(1),POINT(2) C200 FORMAT(2X,2(X,I4),2X,2(X,F7.2)) C WRITE(6,1000)IEND1,IEND2,IEND3,IEND4 C000 FORMAT(2X,"IEND ",4(X,I3)) C C LOWER LEFT C IF(POINT(1).LT.(ENDPT(1) - DELTA)) ICD1 = 1 IF(POINT(2).LT.(ENDPT(2) - DELTA))ICD2 = 4 C C UPPER RIGHT C IF(POINT(1).GT.(ENDPT(3) + DELTA))ICD1 = 2 IF(POINT(2).GT.(ENDPT(4) + DELTA))ICD2 = 8 OCODE = ICD1 + ICD2 RETURN END END$ NT s 92840-18081 2013 S C0122 &ABSAD              H0101 gASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: ABSAD (PART 1 GRAPHICS LINKAGE MODULE) * SOURCE: 92840 - 18081 * RELOC: 92840 - 16002 * * * ************************************************************* * NAM ABSAD,7 92840-16002 REV.2013 790904 EXT .ENTR,PLTER,FLOAT,IFIX EXT .FLUN,..FCM,.IENT,BYTE EXT .PLTR,DPTR,GCBIM EXT ABS ENT ABSAD ENT DCTIM,EMULX,LNGTH,GIC,DCTAD ENT GSWCH,DCTXX,INDCK EM1913 ENT .OPTN,INTX,FLTAS,GETID,GTNAM ENT GRIFX * * THIS IS THE ABSOLUTE ADDRESS ROUTINE FOR THE GRAPHICS * ITS RESPONSIBILITY IS TO SAVE THE FIRST WORD ADDRESS * OF THE GRAPHICS CONTROL BLOCK (GCB), AND TO TRANSMIT * DATA TO AND FROM THE GCB. THIS ROUTINE IS ALSO CAPABLE * OF TRANSFERRING DATA TO AND FROM OTHER BUFFERS WHOSE * ABSOLUTE ADDRESSES RESIDE IN THE GCB (E.G. IOBUF). * * CALLING SEQUENCE: * CALL ABSAD(IPTR,IRW,IBUFR,IBLNT,IND) * * WHERE: IPTR = 0 SAVE FWA OF GCB * >0 POINTER INTO BUFFER OF INTEREST * IRW = 1(READ),2(WRITE) * IBUFR = ADDRESS OF MSTERY BUFFER * IBLNT = IBUFR LENGTH * * IND = ERROR INDICATOR * ********************************************************* SKP SPC 3 IPTR NOP IRW NOP IBUFR NOP IBLNT NOP IND NOP ABSAD NOP JSB .ENTR DEF IPTR LDA IPTR,I POINTER INTO BUFFER SZA,RSS = 0? JMP INIT YES THEN GO INITIALIZE FWABF CPA M99 JMP CLR CLEAR GCB, PLOTR(0) CALL MAYBE CPA .99 C  JMP CHK TRGCB LDA FWABF GCB FWA XFER ADA IPTR,I COMPUTE FWA(BUFFER) + IPTR - 1 ADA M1 LDB IRW,I CPB .1 READ? JMP READ STA TO WRITE LDA IBUFR STA FROM JMP XFER1 READ STA FROM LDA IBUFR STA TO XFER1 LDA IBLNT,I CMA,INA STA ABCTR * * NOW TRANSFER DATA FROM > TO * XLOP LDA FROM,I STA TO,I ISZ TO ISZ FROM ISZ ABCTR JMP XLOP JMP ABSAD,I ALL DONE * * INITIALIZE FWABF * INIT LDA IBUFR STA FWABF INIT1 LDA M99 SAVE -99 INTO FWA OF GCB STA IBUFR,I JMP ABSAD,I * SPC 3 CLR LDA FWABF SZA,RSS JMP ERR CLA STA IBUFR,I STA FWABF JMP ABSAD,I * * CHECK TO MAKE SURE THAT BUFFER HAS BEEN INITIALIZED AND * SAVE CURRENT ADDRESS OF GCB. * CHK LDA IBUFR,I CPA M99 JMP CKON OK JMP ERR SOMETHING WRONG CKON LDA IBUFR SAVE ADDRESS STA FWABF JSB INDCK STA B ADA .7 STATUS WORD LDA A,I AND .1000 I/O BUFFERING FLAG SZA JMP AXIT LDA B ADA GCIO REINITIALIZE I/O BUFFERING POINTER ADB .5 STA B,I AXIT JMP ABSAD,I * ERR LDA IBUFR STA FWABF JSB PLTER DEF RTN DEF .199 DEF .100 RTN LDA M99 STA IND,I JMP ABSAD,I JMP ABSAD,I SKP SPC 3 * * GRAPHICS INTEGERIZING ROUTINE * NUMBR NOP GRIFX NOP JSB .ENTR DEF NUMBR DLD NUMBR,I JSB ABS DST ASAV JSB IFIX INTEGERIZE NOP STA ATEMP JSB FLOAT FLOAT IT DST SUBT DLD ASAV FSB SUBT NUMBER - FLOATED INTEGER FMP .10E1 FRACTIONAL VALUE * 10. DST SUBT DLD D5 FSB SUBT 5 - FRACTION * 10. SSA > 5 ISZ ATEMP . SZA,RSS =5 ISZ ATEMP DLD NUMBR,I SEE IF NUMBER IS POSITIVE OR NEGATIVE SSA,RSS <0 JMP GREND LDA ATEMP CMA,INA JMP GRIFX,I GREND LDA ATEMP JMP GRIFX,I SKP SPC 3 *CONSTANTS AND TEMPORARY STORAGE * FWABF NOP TO NOP ASAV BSS 2 FROM NOP ABCTR NOP GCIO DEC 103 .1000 OCT 1000 .5 OCT 5 .99 DEC 99 M99 DEC -99 .100 DEC 100 * ATEMP NOP D5 DEC 5. .199 DEC 199 SKP * * * THIS MODULE IS PART OF THE INTERFACE BETWEEN USER * PROGRAMS AND THE AGL GRAPHICS PACKAGE. THIS PORTION * OF THE INTERFACE PROCESSES THE PARAMETER STRINGS BY * CHECKING FOR THE PRESENCE OF THE LEGAL NUMBER OF PARAMETERS * AND THE SETTING UP OF DEFAULT VALUES. * .OPTN NOP STA RETRN ADDRESS OF P+1 CLA STA MESS LDA PADR JSB INDCK STA PAD STA B LDA .PCNT JSB CLEAR LDA .OPTN P+1 RETURN ADDRESS JSB INDCK STA B LDA B,I STA .OPTN ADDRESS OF RETURN POINT INB ADDRESS OF PARAMETER BUFFER LDA B,I JSB INDCK STA TFBF FWA OF PARM BUFFER INB STB SAVB LDA B,I LDA A,I # OF WORDS IN PARM BUFFER LDB TFBF JSB CLEAR ISZ SAVB LDA SAVB,I STA TFBF,I CODE FOR AGL ROUTINE TO DETERMINE THE APPROPRIATE ISZ TFBF JMP ENTER PARMS BSS 10 BUFFER WHICH WILL CONTAIN PARAMETER ADDRESSES RETRN NOP RETURN ADDRESS TO CALLING ROUTINE ENTER JSB .ENTR GET ADDRESES FROM UP YONDER PADR DEF PARMS LDA .OPTN COMPUTE ADDRESS OF STORAGE FOR RETURN POINT JSB INDCK ADA M1 LDA A,I STA RTNAD ISZ SAVB BUMP TO P+3 (#OF PARAMETERS - #DEFAULTS) LDA SAVB,I LDA A,I LDB PAD SZA,RSS ARE THERE ANY PARAMETERS THAT ARE REQ'D JMP DF NO CMA,INA STA CNTR * * NOW CHECK FOR MISSING GCB PARAMETER * LDA .PLTR SEE IF PLOTR CALL SZA JMP PLOOP LDA PARMS,I FW OF GCB CPA M99 JMP PLOOP JSB PLTER MISSING GCB WARN PLTER TO GET READY FOR ERROR 99 DEF RTNER DEF .6 DEF .PCNT RTNER JMP MESUP * * NOW CHECK FOR THE EXISTENCE OF PARAMETERS THAT SHOULD BE * THERE. * PLOOP LDA B,I B POINTS TO PARM BUFFER (DEFAULTS) SZA,RSS IS THERE A PARAMETER THERE? JMP MESUP NO THEN AN ERROR - REPORT IT. STA TFBF,I ISZ TFBF INB BUMP TO NEXT PARAMETER ADDRESS ISZ CNTR JMP PLOOP CONTINUE DF ISZ SAVB NOW CHECK OUT EXISTENCE OF DEFAULTS LDA SAVB,I SHOULD THERE BE ANY ANYHOW? LDA A,I SZA,RSS JMP EXIT NO -THEN EXIT STAGE LEFT CMA,INA STA CNTR GET #OF DEFAULTS COMPLEMENT AND SET IN COUNTER ISZ SAVB BUMP TO TOL FOR DEFAULTS LDA SAVB,I STA SAVB SAVE ADDRESS FOR TOL DLOOP LDA B,I SZA DID THE PERSON ABOVE SUPPLY A DEFAUL PARAM? JMP SKPDF YES SETDF LDA SAVB,I DEFAULT VALUE ADDRESS STA TFBF,I SET DEFAULT ADDRESSES INTO TFPRM BUFFER ISZ TFBF ISZ SAVB ISZ CNTR JMP SETDF JMP EXIT ALL DONE SKPDF ISZ SAVB STA TFBF,I ISZ TFBF INB BUMP POINTER TO USER PARAMETERS ISZ CNTR JMP DLOOP EXIT LDA RETRN STA RTNAD,I LDA CNTR LDB MESS ERROR? SZB,RSS ISZ .OPTN JMP .OPTN,I * * * SPC 3 CLEAR NOP STA CNTR CLA ENDLP STA B,I INB ISZ CNTR JMP ENDLP JMP CLEAR,I SPC 3 MESUP ISZ MESS P+1 RETURN ERROR JMP EXIT * * POSSIBLE GOOD GCB - NOW CHECK OUT IF THERE ARE HARD ERRORS * OTHER THAN TYPE 6 ERROR. * CKOUT STB TEMP JSB PLTER DEF CKRTN !DEF M98 RETRIEVE ERROR DEF IERR CKRTN LDA IERR CPA .6 TYPE 6? JMP *+2 SOME WORK TO DO JMP CKEXT JSB PLTER DEF CKRT2 DEF M99 CLEAR ERRORS DEF IERR CKRT2 LDB PARMS INB LDA IERR STA B,I MAY CRASH IF USER REALLY BLEW IT CKEXT LDB TEMP JMP PLOOP SKP SPC 3 * * PARAMETERS AND CONSTANTS * B EQU 1 SAVB NOP .PCNT DEC -10 ADCNT NOP TFBF NOP RTNAD NOP MESS NOP M98 DEC -98 PAD NOP IERR NOP * SKP * THIS IS THE MODULE USED TO CONNECT THE AGL FUNCTIONAL MODULE * TO THE CORRECT DEVICE SUBROUTINE. * IF FOR SOME REASON THE USER DID NOT FORMAT THE DUMMY TABLE (DTBL) * CORRECTLY OR THAT HE IS USING THE WRONG DEVICE ID, THEN AN ERROR * MESSAGE IS EMITTED. * * GET DEVICE ID NUMBER. * IDCK NOP GSWCH NOP EM1913 JSB .ENTR DEF IDCK LDA IDCK,I SZA JMP RTG0 JUST CHECK OUT ID JSB GCBIM DEF RTG DEF .3 CODES FOR LUN AND ID. DEF .1 ONE VALUES DEF ID DEF .0 DEF .1 * SPC 3 * * GET THE DEVICE SUBROUTINE ADDRESS FROM THE DEVICE COMMAND TABLE. * * RTG LDA DP,I DUMMY TABLE POINTER SSA SEE IF DUMMY PUT NEGATIVE NUMBER JMP ERROR CLE,ERA #WORDS/2 LDB ID CMB,INB ADB A ID # > # ENTRIES IN TABLE SSB IF POSITIVE EVERYTHING OK JMP ERROR * * NOW COMPUTE ADDRESS FOR DEVICE SUBROUTINE AND DEVICE COMMAND * TABLE * LDA ID ADA M1 (ID # -1) > A ALS A*2 > A STA ID LDA DP JSB INDCK INDIRECT CHECK ADA .1 ADA ID ADDR(D.S) = ADDR(DPTR) + (ID-1)/2 LDB A,I DEVICE SUBROUTINE ADDRESS SZB,RSS SEE IF ZERO JMP ERROR STB DVGXX SAVE IT INA LDA A,I DEVICE COMMAND TABLE ADDRESS SZA,RSS SEE IF ZERO JMP ERROR JSB INDCK STA DCTXX LDA IDCK,I SZA,RSS JSB DVGXX,I SWEXT JMP GSWCH,I EM1913 * * * ERROR JSB PLTER DEF *+2 DEF .2 JMP GSWCH,I EM1913 * RTG0 STA ID JMP RTG * * SPC 3 INDCK NOP RSS LDA 0,I RAL,CLE,SLA,ERA JMP *-2 JMP INDCK,I * * INDIRECT CHECK USING REGISTER B INDCB NOP CL1901 RSS CL1901 LDB 1,I CL1901 RBL,CLE,SLB,ERB CL1901 JMP *-2 CL1901 JMP INDCB,I CL1901 * * DO NOT CHANGE POSITION OF CONSTANTS * .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .4 OCT 4 .6 OCT 6 .19 DEC 19 A EQU 0 ID NOP DCTXX NOP DP DEF DPTR DVGXX NOP OCT 3 SKP * THIS ROUTINE IS RESPONSIBLE FOR RETRIVING AND SAVING CERTAIN * INFORMATION NEEDED BY THE DEVICE SUBROUTINES. NAMELY: * * GIC = GRAPHIC INTERPRETIVE CODE * LNGTH = LENGTH OF GICB -1 * DCTAD = POINTER TO LOCATION IN COMMAND LINK TABLE (CLTBL(GIC)) * * DCTIM NOP JSB GCBIM GET GIC AND LENGTH DEF RTND DEF .16 GICB CODE DEF .1 ONE CODE DEF GICBL WHERE TO PUT IT DEF .1 DEF .1 READ RTND LDA GICBL AND LOBIT MASK OFF BITS 0-7 STA LNGTH LDA GICBL AND UPBIT BITS 8-15 ALF,ALF STA GIC LDA DCT JSB INDCK IN&DIRECT ADDRESS CHECK LDB A,I * * INB EMULATOR ADDRESS LDA B,I STA EMULX LDA GIC CPA .177 JMP DCTIM,I ADB GIC COMPUTE CLTBL(GIC) LDA B,I STA DCTAD JMP DCTIM,I * * DCT DEF DCTXX .16 DEC 16 GICBL NOP UPBIT OCT 177400 LOBIT OCT 377 LNGTH NOP GIC NOP DCTAD NOP EMULX NOP .177 OCT 177 * SKP * THIS ROUTINE IS RESPONSIBLE FOR RETRIEVING THE NAME OF THE * PROGRAM THAT HAS COMMITED A HARD ERROR. * BUFG NOP JL NOP GETID NOP JSB .ENTR DEF BUFG LDA BUFG SET UP ADDRESS COUNTER STA AGCTR LDA M3 WORD COUNTER STA IDCNT LDB XEQT ADDRESS OF ID SEGMENT FOR PROGRAM ADB IDNAM GOOP XLA B,I STA AGCTR,I INB ISZ AGCTR ISZ JL,I ISZ IDCNT JMP GOOP ADB M1 LDA B,I AND .1740 IOR .40 LDB AGCTR ADB M1 PUT LAST CHARACTER INTO BUFFER WITH BLANK STA B,I ISZ JL,I JMP GETID,I * XEQT EQU 1717B .1740 OCT 17400 .40 OCT 40 AGCTR NOP M3 OCT -3 IDNAM DEC 12 IDCNT NOP * SKP * * THIS ROUTINE IS RESPONSIBLE FOR RETRIEVING THE NAME OF AN * AGL COMMAND IN WHICH A MISSING PARAMETER ERROR WAS * DETECTED. * * THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING * MEANINGS: * ICD = ERROR CODE ASSOCIATED WITH THE COMMAND * MSBUF = BUFFER IN WHICH THE ASCII CHARACTERS FOR THE * COMMAND WILL BE PLACED. * JJ = WORD COUNTER (INCREMENTED FOR EACH WORD PLACED IN BUFFER). * SPC 3 ICD NOP MSBUF NOP JJ NOP GTNAM NOP JSB .ENTR DEF ICD GET PARAMETER ADDRESSES LDA ICD,I ADA M40 COMPUTE (ICD -40) -->A STA SAVE ALS A * 2 --> A ADA SAVE SAVE + A -->A STA SAVE LDA TOP TOP OF LIST FOR AGL COMMAND NAMES {JSB INDCK INDIRECT ADDRESS CHECK ADA SAVE STA SAVE POINTER TO CORRECT STRING LDA MSBUF SET UP ADDRESS COUNTER STA AGCTR LDA M3 STA IDCNT NAMLP LDA SAVE,I STA AGCTR,I ISZ JJ,I ISZ AGCTR ISZ SAVE ISZ IDCNT JMP NAMLP JMP GTNAM,I * SPC 2 SAVE NOP M40 DEC -40 SKP * * ASCII STRINGS * TOP DEF *+1 N40 ASC 3,PLOTR N41 ASC 3,MARGIN N42 ASC 3,VIEWP N43 ASC 3,LIMIT N44 ASC 3,WINDW N45 ASC 3,GCLR N46 ASC 3,CLIP N47 ASC 3,PLOT N48 ASC 3,RPLOT N49 ASC 3,IPLOT N50 ASC 3,CSIZE N51 ASC 3,CPLOT N52 ASC 3,POINT N53 ASC 3,CURSOR N54 ASC 3,DIGTZ N55 ASC 3,WHERE N56 ASC 3,DSIZE N57 ASC 3,HDERR N58 ASC 3,LDIR N59 ASC 3,PDIR N60 ASC 3, N61 ASC 3,LGERR N62 ASC 3,LAXES N63 ASC 3,LGRID N64 ASC 3,PEN N65 ASC 3,LINE N66 ASC 3,LABEL N67 ASC 3,GPON N68 ASC 3,SETAR N69 ASC 3,DRAW N70 ASC 3,MOVE N71 ASC 3,DRAWI N72 ASC 3,MOVEI N73 ASC 3,DRAWR N74 ASC 3,MOVER N75 ASC 3,MSCAL N76 ASC 3,CLPON N77 ASC 3,CLPOF N78 ASC 3,SHOW N79 ASC 3,LORG N80 ASC 3,FXD N81 ASC 3,PENUP N82 ASC 3,PENDN N83 ASC 3,PORG N84 ASC 3,XMIT N85 ASC 3,GDSTT EM1913 N86 ASC 3,GSTAT N87 ASC 3,GPMM N88 ASC 3,FRAME N89 ASC 3,SETUU N90 ASC 3,SETGU N91 ASC 3,IGERR N92 ASC 3,PICSV EM1901 N93 ASC 3,PICRP EM1901 N94 ASC 3,PICAD EM1901 N95 ASC 3,GFONT SY2013 N96 ASC 3,GTEXT SY2013 N97 ASC 3,GLEN SY2013 * * INDIRECT CHECK * SKP * * THIS%  ROUTINE TAKES AN ASCII STRING IN THE FOLLOWING FORMAT * * STRING (OCTAL ASCII VALUE) ACTUAL VALUE * 26461 -1 * 30464 14 * 20040 SPACE,SPACE * * AND STRIPS OFF THE ASCII FORMAT AND PLACES THE SIGN AND NUMERIC * IN THE FOLLOWING FORMAT: * QUANTITIES INTO A BUFFER IN THE FOLLOWING FORMAT. * * OUTPT WORD 1 = 4 * 2 = 1 * 3 = 1 * 4 = 55 = ASCII MINUS * * * A BYTE COUNTER IS INCREMENTED AND IS UPDATED EACH TIME * THIS ROUTINE IS CALLED. IF IN THE ABOVE EXAMPLE BYTE = 4 * UPON ENTERRING ROUTINE, UPON EXIT THE VALUE WOULD BE 8. * * THE DATA IN THE BUFFER SHOWN IS TAKEN AND CONVERTED TO OCTAL INTEGER * USING THE FOLLOWING ALGORITHM: * * INT = SUM((12BASE8)*I*IBUF(I+1), WHERE I = 0-4 AND IBUF IS THE BUFFER * DEFINED ABOVE. THE EXAMPLE ABOVE WOULD LOOK LIKE: * * 1 *(4) + 12 * (1) + 144 * (1) = 162BASE 8 = VALUE * * CALLING SEQUENCE: * * CALL INTX(INPUT,VALUE,BYTE) * * WHERE: INPUT = ASCII INPUT BUFFER * VALUE = INTEGER VALUE RETURNED * BYTE = BYTE COUNTER * * **************************************************************** * SKP SPC 3 INPUT NOP VALUE NOP BITE NOP INTX NOP JSB .ENTR DEF INPUT CLA STA SGNFL STA NUMF LDA BITE,I UPDATE POINTER INTO INPUT BUFFER CLE,ERA ADA INPUT STA INP LDB ADEND ADDRESS OF END OF BUFFER WHERE DATA IS TO GO MLOOP ADB N1 LDA BITE,I SEE IF THIS IS A RIGHT OR LEFT BITE SLA,RSS JMP EVEN LEFT BITE LDA INP,I AND LOMSK MASK OFF BITS 0-7 ISZ INP JMP CKLOP CHECK IT OUT EVEN LDA INP,I AND UPMSK MASK OFF BITS 8-15 ALF,ALF SHIFT TO BITS 0-7 CKLOP CPA PLUS PLUS SIGN? JMP STFLG GO SET SIGN FLAG k CPA MINUS - SIGN JMP STFLG DO SAME ADA M60 GET RID OF ASCII STA TEMP SZA,RSS MUST BE A NUMBER OR SOME OTHER ASCII CHARACTER JMP CONT A NUMBER SSA A<0? JMP CKNUM YES CMA,INA ADA .11 SSA JMP CKNUM NOT A NUMBER CONT LDA SGNFL SEE IF SIGN FLAG HAS BEEN SET SZA,RSS JMP PTSGN GO INSERT SIGN THEN DIGIT ISZ NUMF LEGITIMATE NUMBER LDA NUMF CPA .6 MAKE SURE WE HAVEN'T GONE PAST 5 DIGITS JMP CONVT LDA TEMP STA B,I JMP LOOP * * PTSGN LDA PLUS DEFAULT SIGN STA B,I ADB N1 LDA TEMP STA B,I ISZ SGNFL ISZ NUMF JMP LOOP * * CKNUM LDA NUMF SZA JMP CONVT JMP LOOP * * * STFLG ISZ SGNFL STA B,I JMP LOOP SPC 3 LOOP ISZ BITE,I JMP MLOOP SKP SPC 3 * * THIS PORTION OF THE ROUTINE CONVERTS THE VALUES IN BUFR TO INTEGER. * THE B REGISTER AT THIS TIME POINTS TO THE FIRST VALU TO BE CONVERTED * IN BUFR. * CONVT CLA STA VALUE,I LDA NUMF CMA,INA STA CNTR SET UP COUNTER INB POINT B TO FIRST NUMBER STB ADRPT LDA MPLR TOP OF LIST OF MULTIPLIER CONSTANTS STA MPADR ADDRESS COUNTER CLOOP CLB LDA ADRPT,I MPY MPADR,I C(BUFR) * MCON(I) STA TEMP ADA VALUE,I VALUE = VALUE + TEMP STA VALUE,I ISZ ADRPT ISZ MPADR ISZ CNTR JMP CLOOP LDA ADRPT,I SEE IF LAST WORD IS A MINUS CPA MINUS JMP COMP JMP INTX,I COMP LDA VALUE,I CMA,INA VALUE =-VALUE STA VALUE,I JMP INTX,I * * SKP * *TEMPORARY STORAGE AND CONSTANTS * LOMSK OCT 377 UPMSK OCT 177400 BUFR BSS 10 ADEND DEF * NUMF NOP CNTR NOP MPADR NOP MPLR DEF MCON MCON DEC 1 FDEC 10 DEC 100 DEC 1000 DEC 10000 ADRPT NOP INP NOP M60 OCT -60 .11 DEC 9 SGNFL NOP N1 DEC -1 TEMP NOP M5 OCT -5 COUNT NOP * SKP * * THIS ROUTINE CONVERTS A FLOATING POINT VALUE CONTAINED * IN NUM TO ASCII AND STORES THE RESULT IN IOBUF. * THE RESULTING FLOATING POINT VALUE IS FORMATTED * ACCORDING TO F7.N FORMAT, WHERE N HAS BEEN SPECIFIED * THE FXD(N) COMMAND. * NUM NOP IOBUF NOP IBYTE NOP N NOP SKPBK NOP FLTAS NOP JSB .ENTR DEF NUM LDA N,I STA RIGHT LDA IBYTE,I CLE,ERA ADA IOBUF STA FLTAD CLA STA UNFLG UNDERFLOW FLAG STA SIGN SIGN FLAG 1= MINUS STA EXPFL STA IN RTNR LDA RIGHT COMPUTE 7-(N+1) NUMBER OF DIGITS TO LEFT OF DECIMAL INA POINT. ADA M7 STA LEFT DLD NUM,I NOW CHECK TO SEE IF NUMBER IS WITHIN A FEASIBLE RANGE FOR DST SAVOU STA SAVA FOR F7.N FORMAT. STB SAVBB SZA SEE IF NUM = 0 JMP CONT0 SZB,RSS JMP FLT0 NUM = 0.0 CONT0 SSA,RSS SEE IF NUMBER IS NEGATIVE AND IF SO INSERT A MINUS JMP CONTF SIGN INTO THE I/O BUFFER AND COMPLEMENT THE NUMBER ISZ SIGN SET SIGN FLAG TO INDICATE MINUS JSB ..FCM COMPLMENT DST SAVA DST SAVOU ISZ LEFT ONE LESS DIGIT TO LEFT OF DECIMAL POINT NOP LDA MINUS JSB PACK INSRT MINUS SIGN INTO IOBUF CONTF LDA RIGHT ROUND OFF CLE,ALS LDB RNDOF INDIRECT CHECK CL1901 JSB INDCB CL1901 ADA B CL1901 DLD A,I FAD SAVA NUMB + (.5) **N DST SAVA FCONT LDA RIGHT CPA .6 NOW CHECK FOR UNDERFLOW JMP SPLCS IF N=6 OR 7 WE HAVE A SPECS+IAL SITUATION CPA .7 JMP SPLCS LDA RIGHT COMPUTE (N*2) CLE,ALS STA FLTMP LDB UNFLW INDIRECT CHECK CL1901 JSB INDCB CL1901 ADA B GET ADDRESS OF TOL OF UNDERFLOW CONSTANTS CL1901 DLD A,I DST SUBT DLD SAVA FSB SUBT NOW SEE IF NUM CONSTANT SZA,RSS JMP OVER NUM = CONSTANT JMP REGLR REGULAR CASE -SO GO DO F7.N * * SPLCS LDA SIGN SZA JMP LOWER DLD .EM6 DST SUBT JMP CHECK LOWER DLD .EM5 DST SUBT CHECK DLD SAVA FSB SUBT SSA JMP SPEN1 UNDERFLOW DLD SAVA FSB D1 SSA,RSS JMP SPEND SZA JMP SPEND JMP OVER SPEND LDA MINUS JMP OVER+1 SPEN1 LDA PLUS JMP UNDER+1 * SKP SPC 3 * * FORMAT PORTION FOR REGULAR F7.N * SPC 2 REGLR ISZ RIGHT LDA RIGHT COMPLEMENT COUNTER FOR NUMBER OF DIGITS TO THE CMA,INA RIGHT OF THE DECIMAL POINT. STA RIGHT JSB EXTCT SEPERATE THE INTEGER PORTION OF THE NUMBER FROM THE LDB SAVBB FRACTIONAL, JSB .FLUN EXTRACT EXPONENT AND MANTISSA(A=EXP,B=MANTISSA) SZA,RSS LOOK FOR 0 OR NEGATIVE EXPONENT JMP FRACT = 0 SSA JMP FRACT < 0 DLD SAVA REGLP ISZ IN CzOUNT THE NUMBER OF DIVISIONS FSB .10E1 MAKE NUMBER < 10.0 IF IT IS NOT ALREADY SSA JMP REG2 < 10.0 DLD SAVA DIVIDE BY TEN UTIL NUM IS < 10.0 FDV .10E1 DST SAVA JMP REGLP REG2 LDB IN CMB,INB STB IN REG3 JSB GCIN FIND GREATEST CONTAINED INTEGER (INTEGERIZE) ISZ LEFT JMP *+2 MORE DIGITS TO THE LEFT OF DECIMAL POINT JMP FRACT GO DO FRACTIONAL PART. ISZ IN NUMBER OF DIVIDES RUN OUT? JMP REG3 NO JMP FRACT * SKP SPC 3 * * FRACTIONAL PART OF CONVERSION * SPC 2 FRACT LDA EXPFL CHECK FOR EXPONENT NECESSITY LDB UNFLG SZA JMP OVER1 SZB JMP UNDR1 UNDERFLOW LDA DECPT JSB PACK INSERT DECIMAL POINT INTO IOBUF FRAC1 DLD FRAC GET FRACTIONAL PART OF NUMBER FMP .10E1 MAKE FRACTION > 1 DST SAVA FRLP ISZ RIGHT JMP *+2 JMP END JSB GCIN GET INTEGER AND INSERT INTO IOBUF JMP FRLP END LDA EXPFL SZA JMP UNDER JMP FLTAS,I * * * FORMAT 0 TO 0.XXX * SPC 2 FLT0 LDA RIGHT CMA,INA STA RIGHT LDA ASCN ASCII 0 JSB PACK LDA DECPT DECIMAL POINT JSB PACK LDA RIGHT SZA,RSS N=0 JMP FLTAS,I FLTLP LDA ASCN JSB PACK ISZ RIGHT JMP FLTLP JMP FLTAS,I * SPC 3 * * FIND GREATEST INTEGER AND INSERT INTO IOBUF * GCIN NOP DLD SAVA JSB .IENT GET GREATEST CONTAINED INTEGER NOP STA FLTMP ADA ASCN JSB PACK LDA FLTMP FLOAT INTEGER JSB FLOAT DST SUBT DLD SAVA COMPUTE NUM - FLTMP FSB SUBT FMP .10E1 DST SAVA JMP GCIN,I * SKP SPC 3 * PACK NOP STA NIBLE SAVE BYTE JSB BYTE DEF RTN1 DEF IBYTE,I 3 DEF NIBLE DEF FLTAD,I RTN1 ISZ IBYTE,I LDA IBYTE,I CLE,ERA INCREMENT IOBUF ADDRESS ADA IOBUF STA FLTAD JMP PACK,I * NIBLE NOP SPC 3 * * PACK BYTES INTO TEMPORARY BUFFER * * * SEPERATE INTEGER AND FRACTION PART OF NUMBER * EXTCT NOP DLD SAVA JSB .IENT GET INTEGER NOP JSB FLOAT DST SUBT DLD SAVA FSB SUBT GET FRACTION DST FRAC JMP EXTCT,I * FRAC BSS 2 SKP SPC 3 * * THIS ROUTINE FORMATS NUMBERS WHICH HAVE BEEN FOUND TO OVER- * FLOW THE F7.N FORMAT. THE NUMBERS ARE REFORMATTED ACCORDING * TO E7.0 FORMAT. * * FORMATS= XXXE+XX OR -XXE+XX * SPC 2 OVER LDA PLUS STA SPSGN SAVE ASCII PLUS SIGN IS TEMPORARY STORAGE ISZ EXPFL FLAG INDICATING EXPONENT DLD .10E2 100.0 DST TMPA LDB .3 NUMBER OF DIGITS TO LEFT OF DECIMAL POINT LDA SIGN NOW DETERMINE WHICH E7.0 FORMAT TO USE SZA,RSS JMP OVER0 DLD .10E1 10.0 DST TMPA LDB .2 OVER0 CMB,INB STB LEFT JMP REGLR OVER1 CLA STA IN COUNTER FOR NUMBER OF DIVIDES DLD SAVOU DST SAVA OVRLP FSB TMPA NUMBER - CONSTANT SZA,RSS JMP EXCNT SSA JMP EXCN0 DLD SAVA FDV .10E1 DIVIDE UNTIL NUMBER IS WITHIN RANGE DST SAVA ISZ IN JMP OVRLP * EXCN0 LDA IN ADA M1 STA IN * * NOW STORE AWAY .E+-XX * EXCNT LDA E JSB PACK LDA SPSGN SIGN + - JSB PACK LDA IN CLB DIV .10E1 STB TMPA ADA ASCN JSB PACK LDA TMPA ADA ASCN JSB PACK JMP FLTAS,I SPC 3 * * THIS SECTION OF CODE DEALS WITH THE UNDERFLOW CASE WHERE * A NUMBER UNDERFLOWS THE F7.N FORMAT. THE RESULTING NUMBERS * ARE FORMATTED ACCORDING TO THE FOLLOWING FORMAZXTTS: * -XXE-XX * XXXE-XX * UNDER LDA MINUS STA SPSGN ISZ UNFLG DLD XXX5 DST SAVA ROUND OFF VALUE DLD D99 DST TMPA LDB .3 LDA SIGN + OR - SIGN SZA,RSS JMP UNDR0 USE XX.E-XX FORMAT DLD XX5 DST SAVA DLD .9 DST TMPA LDB .2 USE -X.E-XX FORMAT UNDR0 CMB,INB NUMBER OF CHARACTERS TO LEFT OF DECIMAL POINT STB LEFT CLA STA MPCNT DLD SAVOU FAD SAVA DST SAVA UNDLP ISZ MPCNT DLD SAVA MULTIPLY NUMBER UNTIL FMP .10E1 IT IS > CONSTANT 9 OR 99 DST SAVA FSB TMPA SSA < CONSTANT JMP UNDLP JMP REGLR SPC 2 UNDR1 LDA MPCNT STA IN JMP EXCNT SKP SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * OVFLW DEF .10E6 RNDOF DEF D.5 UNFLW DEF D1 M1 OCT -1 M2 OCT -2 SAVA NOP SAVBB NOP SIGN NOP RIGHT NOP LEFT NOP M7 OCT -7 SUBT BSS 2 IN NOP BLANK OCT 40 FLTMP NOP ENFLG NOP .7 OCT 7 MINUS OCT 55 FLTAD NOP DECPT OCT 56 ASCN OCT 60 TMPA BSS 2 SAVOU BSS 2 PLUS OCT 53 E OCT 105 I1 OCT 1 EXPFL NOP SPSGN NOP .9 DEC 9. D99 DEC 99. MPCNT NOP UNFLG NOP .95 DEC .95 * * UNDERFLOW AND OVERFLOW CONSTANTS * .10E6 DEC 1000000.0 .10E5 DEC 100000.0 .10E4 DEC 10000.0 .10E3 DEC 1000.0 .10E2 DEC 100.0 .10E1 DEC 10.0 D1 DEC 1.0 DEC .1 DEC .01 DEC .001 DEC .0001 .EM5 DEC .00001 .EM6 DEC .000001 .26 DEC 26 D.5 DEC .5 DEC .05 XX5 DEC .005 XXX5 DEC .0005 DEC 5.E-5 DEC 5.E-6 DEC 5.E-7 DEC 5.E-8 * * END 1 5Z t 92840-18083 2001 S C0122 &DVG01 SOURCE             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DVG01 -- 2648A/ 2647A DEVICE SUBROUTINE * SOURCE: 92840-18083 * RELOC: 92840-16003 * PGMR: MODIFIED BY GSB 8-8-79 * * * ************************************************************* * NAM DVG01,7 92840-16003 REV.2001 790801 EXT EXEC,GCBIM,BYTE EXT EMULX EXT .IENT,FLOAT EXT REIO EXT INDCK EXT INTX EXT DCTIM EXT CONVT EXT FLTAS EXT GRSTS EXT SMLAB EXT PKBIN EXT LNGTH,GIC,DCTAD ENT DVG01 * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 2648A GRAPHICS * TERMINAL. THIS ROUTINE ALONG WITH DVR05 CONTROL THE * PICTURE DRAWING ON THE TERMINAL. * DVG01 NOP CLA INITIALIZE THE READ/WRITE FLAG AND BYTE COUNTER STA FIRST STA BUFLG STA FLTFG FLAG INDICATING FLOAT TO ASCII CONVERSION STA RWFLG COUNTER STA NUM STA NBYTE STA IBYTE STA SKPBK JSB DCTIM FILL UP GIC, LENGTH AND DEVICE COMMAND ADDR.(DCTAD) LDA GIC CPA .177 JMP ERRCK CHECK ON VALIDITY OF LU,ID,ETC LDA DCTAD SEE WHAT TYPE OF COMMAND THIS IS SSA EMULATOR? JMP EMULT YES SZA,RSS A NOP? JMP DVG01,I DO NOTHING A'TALL AND RETURN CONT LDB DCTAD A COMMAND ADDRESS LDA B,I SSA,RSS READ OR WRITE? JMP CONT0 READ ISZ RWFLG WRITE CMA,INA SET BYTE COUNT POSITIVE CONT0 STA NBYTE AND .1 COMPUTE NWORD = NBYTE/2 + REMAINDER L STA NWORD STA ODFLG = 0 IF EVEN, AND 1 IF ODD LDA NBYTE CLE,ERA NBYTE/2 ADA NWORD CMA,INA STA NWORD INB LDA B,I TERMINATOR SZA NOP? LDA A,I ADDRESS OF TERMINATOR STA TERM INB LDA B,I STA FIRST SAVE FIRST WORD OF COMMAND STRING STB DCTAD NOW POINT TO FIRST WORD OF COMMAND STRING JSB GTGLU CONT3 JSB BUFCK CHECK FOR I/O BUFFERING JSB SETUP XFER LDA DCTAD,I NOW TRANSFER COMMAND STRING TO THE I/O BUFFER STA ADCNT,I ISZ NWORD JMP CONT2 JMP XEND FINISHED CONT2 ISZ DCTAD ISZ ADCNT INCREMENT ADDRESS POINTERS JMP XFER CONTINUE XEND LDA ODFLG SZA,RSS ISZ ADCNT LDA RWFLG READ OR WRITE? SZA,RSS JMP READ JSB IGNOR SEE IF LENGTH ASSOCIATED WITH COMMAND IS TO BE IGNORED LDA LNGTH WRITE - NOW SEE IF ANY INTEGERS TO CONVERT TO ASCII SZA,RSS THIS IS LENGTH FROM GICB JMP XEND1 JSB CNVRT JMP FINI XEND1 LDA NBYTE NUMBER OF BYTES LDB .2 WRITE JSB OUTPT EXEC I/O JMP DVG01,I GO HOME BABY * * SKP SPC 3 * * PROCESS READ REQUEST. FIRST A WRITE MUST BE DONE TO * OUTPUT THE COMMAND CODE, AND THEN A READ MUST BE DONE TO * THE DEVICE INTO THE TALK MODE TO GET THE STATUS DATA. * * ALL STATUS COMMANDS COME BACK HERE. ALL BUT DEVICE ID ARE CONVERTED * FROM ASCII TO INTEGER. * * THIS CODE MODIFIED BY GSB 8-8-79 READ NOP LDA NBYTE LENGTH OF BUFFER LDB .2 WRITE JSB OUTPT OUTPUT STATUS REQUEST COMMAND LDB .1 NOW PUT DEVICE INTO TALK MODE LDA .40 TO GET DATA JSB OUTPT LDA FIRST **** IF DEVICE ID COMMAND DO NOT CONVERT CPA S1 **** JMP ID **** * LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER ZY CMA,INA LDB FIRST CPB S3 GET CURSOR POSITION? ADA .1 STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INPUT BUFFER INTAD NOP VALUE DEF IBYTE BYTE COUNTER RTINT LDA FIRST CPA S5 JMP FIXIT GET PLOT UNITS CPA S7 GET CHAR. SIZE JMP FIXIT CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF .16 GICB DEF .1 LENGTH OF FIRST PARAMETER ABOVE DEF INTX1 BUFFER TO BE FILLED OR EMPTIED DEF LNGTH LENGTH DEF .2 READ RTX LDA FIRST SEE IF THIS TO GET PLOT UNITS CPA S5 JMP G12CK TAKE CARE OF CASE WHERE GPON(2) CALL JMP DVG01,I * * IF DEVICE ID STATUS COMMAND SIMPLY RETURN AS ASCII * ID LDA INTIO GET ADDRESS OF BUFFER CONTAINING ID STA IDADD JSB GCBIM **** TRANSFER TO GICB DEF RTX2 **** RETURN ADDRESS DEF .16 **** GICB DEF .1 **** REFERENCING ONLY ONE VARIABLE (GICB) IDADD NOP **** ADDRESS OF BUFFER TO BE SENT TO GICB DEF .3 **** LENGTH OF ABOVE BUFFER DEF .2 **** WRITE RTX2 JMP DVG01,I **** ALL DONE! * * CHECK TO SEE IF G1 G2 ALREADY INITIALIZED AND IF SO DO NOT CHANGE * G12CK JSB GCBIM DEF RG12 DEF .8 DEF .1 DEF INTX1 DEF .0 DEF .1 RG12 DLD INTX1 SEE IF G1X = 0 SZA,RSS SZB JMP LVG12 LEAVE IT AS IS DLD INTX1+4 SEE IF G2X =0 SZA,RSS SZB JMP LVG12 JMP DVG01,I LVG12 LDB DF8 SET OLD POINTS INTO GCB LDA INX JSB GB JMP DVG01,I * FIXIT LDA INTAD,I JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN SPC 3 CNVRT NOP LDA LNGTH R INA STA LNTH JSB GB1 GO GET INTEGERS RTVRT LDA FLTFG IS THIS A FLOATING POINT SITUATION SZA NO THEN VAMOOSE JMP GLIDE GO GLIDE THE NUMBER INSTEAD OF FLOATING IT LDA FIRST GET FIRST CHR. OF CMD STRING AND DETERMINE AND MASK CHECK FOR A P(PLOT,IPLOT,RPLOT,DRAW,OR MOVE) CPA P JMP PACK GO DO SPECIAL DATA FORMATTING JMP CNVRT,I * PACK ISZ NUM LDA FIRST NOW LOOK AT SECOND CHR. OF CMND STRING TO AND .377 ASCERTAIN TYPE OF PLOT(ABSOLUTE,INCREMENTAL OR CPA I RELOCATABLE). JMP PKB ABSOLUTE * ISZ NUM * CPA J INCREMENTAL * JMP CHECK NOW WE MUST DETERMINE IF ITS SHORT INCREMENTAL * ISZ NUM OR LONG INCREMENTAL ( <-16 OR > +15) * JMP PKB RELOCATABLE *HECK LDA MIN2 SET UP TO EXAMINE X AND Y * STA TEMP * LDB INX POINTER TO INTEGERS *HKLP INB * LDA B,I * SSA,RSS IS IT NEGATIVE? * JMP CHKP NO * ADA .16 * SZA,RSS =0? * JMP CONCK =-16 * SSA <-16 * JMP CHNG * JMP CONCK YES IT IS * *HKP ADA M15 >+15? * SZA,RSS * JMP PKB * SSA,RSS * JMP CHNG *ONCK ISZ TEMP * JMP CHKLP * * GO TO PACKING ROUTINE TO FORMAT X,Y FOR TERMINAL * PKB JSB PKBIN DEF RTPK DEF INTX2 X,Y DEF ADCNT,I I/O BUFFER DEF NBYTE DEF NUM DEF LNGTH RTPK JMP RTCON * *HNG ISZ NUM LONG INCREMENTAL - SO INSERT SMALL K * LDA NBYTE * ADA M1 * STA TEMP * JSB BYTE * DEF RTCHG * DEF TEMP * DEF K LONG INCREMENTAL * DEF FWADR,I *TCHG JMP PKB SKP * * * ERROR CHECKING FOR DEVICE SUBROUTINE = DEVICE COMMAND TABLE * LU = 2648 = DVR05 OR DVR07 * ERRCK JSB GCBIM DEF ERR0 DEF .2 DEF .3 DEF LUN DEF .0 DEF .1 ERR0 JSB SETUP p LDA IOBUF STA IOB STA INTIO JSB EMULX,I INTERROGATE DEV. CMD.TABLE CPA .2648 JMP ERR1 OKAY LDA .3 JMP ERRPT REPORT ERROR ERR1 JSB IFTTY DEF *+2 DEF LUN LDA DTYPE CPA M2400 JMP ERR3 CPA M3400 DVR07? JMP ERR3 LDA .5 SOMETHIN SCREWED UP!! JMP ERRPT RR2 LDA S1 INTERROGATE DEVICE FOR ID STA FIRST TO MAKE SURE DEVICE MATCHES STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE LDA Z JSB TRBYT TERMINATOR LDA .1 STA LNGTH JMP READ+1 * EVID LDA INTX1 CPA .2648 JMP ERR3 OKDOKE = COPESETIC CPA .2647 JMP ERR3 LDA .5 JMP ERRPT MESSED UP ERR3 CLA ERRPT STA INTX1 LDA INX LDB DF1 JSB GB JMP DVG01,I SKP SPC 3 * * PROCESS * * SPECIAL INTERNAL UTILITY ROUTINES * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER STA BITE JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JMP TRBYT,I * BITE NOP * * OUTPT NOP I/O TRANSFER ROUTINE STB RW CMA,INA STA IOCNT LDA LUN STA LUN1 JSB IFTTY FIND OUT WHATS OUT THERE DEF *+2 DEF LUN LDA DTYPE CPA M3400 DVR07 JMP OUT1 YES DO NOT SET BIT 10 (TRANSPARENT MODE FOR DVR05) LDA LUN LDB RW CPB .2 SEE IF READ REQUEST AND IF SO DO NOT SET BIT 10 IOR .200 STA LUN1 OUT1 JSB REIO DEF RTOUT DEF RW DEF LUN1 IOB NOP DEF IOCNT RTOUT JMP OUTPT,I * .36 DEC 36 .38 DEC 38 LUN1 NOP * * * SKP SPC 3 * * MORE SPECIAL ROUTINES INVOKED THROUGHOUT THIS PROGRAM * SETUP NOP LDA ESCST ESC * STA IOBUF,I ISZ NBYTE BUMP BYTE COUNTER ISZ NBYTE LDA IOBUF INCREMENT IOBUF ADDRESS INA STA FWADR SAVE POINTER STA ADCNT JMP SETUP,I * * GET GRAPHICS LUN * GTGLU NOP JSB GCBIM DEF GTL DEF .2 DEF .3 DEF LUN DEF .0 DEF .1 LUN,IOBUF,IOBL GTL LDA IOBUF SET UP IO BUFFER ADDRESS POINTERS JSB INDCK STA IOBUF STA IOB STA INTIO JMP GTGLU,I * * THESE ARE COMMANDS WHERE THE LENGTH SPECIFICATION * ASSOCIATED WITH THE GIC IS IGNORED. * * IGNOR NOP LDA IGCNT STA NUM LDA IGCOD STA TEMP IGLOP LDA TEMP,I CPA FIRST JMP YES ISZ TEMP ISZ NUM JMP IGLOP JMP IGNOR,I YES CLA STA LNGTH IGNORE LENGTH FROM GICB JMP IGNOR,I * IGCNT DEC -3 IGCOD DEF *+1 OCT 66520 SLANT ON OCT 66517 SLANT OFF OCT 62150 CLEAR-IF CALLED FROM GCLR THERE WILL BE A 1 * SKP * * WRITE DATA TO GICB A= ADRRESS FROM WHENCE DATA IS TO COME * B = NUMBER OF WORDS * GB NOP STA ADDR STB NUMB JSB GCBIM DEF *+6 DEF .16 DEF .1 ADDR NOP NUMB NOP DEF .2 JMP GB,I * GB1 NOP JSB GCBIM RETRIEVE INTEGER VALUES TO BE CONVERTED DEF RTGB DEF .16 CODE FOR GICB DEF .1 DEF INTX1 WHERE TO PUT IT DEF LNTH DEF .1 READ IT MAN RTGB JMP GB1,I * * FINI JSB CONVT CONVERT FROM INTEGER TO ASCII DEF RTCON DEF INTX2 FROM HERE DEF IOB,I I/O BUFFER ADDRESS DEF NBYTE CURRENT NUMBER OF BYTES DEF LNGTH HOW MANY INTEGERS RTCON LDA NBYTE COMPUTE POINTER INTO I/O BUFFER CLE,ERA CALCULATE NBYTE/2 ADA IOBUF STA ADCNT ADDRESS POINTER LDA BUFLG I/O BUFFERING? SZA JMP BF3 YES LDA TERM JSB TRBYT INTSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP DVG01,I * * * * ROUTINE TO DETERMINE IF THE SPECIFIED LU IS INTERACTIVE * CALLED AS FOLLOWS: * * IFLAG = IFTTY(LU) JSB IFTTY * DEF *+2 * DEF LU * * * * * IFTTY NOP ENTRY DLD IFTTY,I GET RETURN ADDRESS & LU# LDB B,I GET THE LU # STA IFTTY SAVE RETURN ADDRESS STB ANLU# AND LU # * JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF ANLU# THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BIT HERE * JMP ITSNT IT AIN'T EVEN AN LU !!!! LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD STA DTYPE JMP IFTTY,I ITSNT CLA SET NON INTERACTIVE FLAG JMP IFTTY,I * * D13I OCT 100015 M2400 OCT 2400 M37 OCT 37 M3400 OCT 3400 MEQT OCT 37400 ANLU# NOP DTYPE NOP YTEMP NOP ZTEMP NOP SKP SPC 3 * * EMULATORS * EMULT STA TEMP JSB GTGLU JSB BUFCK LDA TEMP CMA,INA STA B CLA STA NBYTE LDA EM0 FWA OF EMULATOR POINTERS JSB INDCK ADA B LDA A,I JMP A,I EMUL1 LDA SMLAB ESC*L JSB INDCK STA DCTAD FAKE OUT ISZ FLTFG JMP CONT * * CONVERT THE NUMBER FROM FLOAT(GLIDE) TO ASCII * GLIDE JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN DEF SKPBK RTGLD JSB UPDTE LDA CR CARRAIGE RETURN JSB TRBYT JSB UPDTE LDA LF LINE FEED JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP DVG01,I * * GET NUMBER OF PENS * p$EMUL2 LDA DF6 LDB DF1 JSB GB TRANSFER TO GICB JMP DVG01,I * * LINE TYPES * EMUL4 JSB SETUP LDA .4 STA LNTH JSB GB1 PICK UP GICB AND DATA- LINE TYPE AND LENGTH LDA M2 PUT DEVICE INTO DRAWING MODE STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE LDA LB SMALL B JSB TRBYT LDA LT POINTER TO LINE TYPES JSB INDCK ADA INTX2 ADDR(LT) + LT# LDA A,I STA INTX2 DLD INTX2+1 LENGTH FDV D8 CALCULATE SCALE = LENGTH/8MUS JSB .IENT INTEGERIZE NOP LDB .1 SZA,RSS CHECK FOR 0 STB A STA INTX2+1 LDA .2 STA LNGTH LDA C TERMINATOR STA TERM JMP FINI * * LABEL DIRECTION - GICB LOOKS LIKE ( GIC/L),(ANGLE) * THE ANGLE IS IN FLOATING POINT. THE IDEA HERE IS TO * CONVERT THE ANGLE INTO: * * 1 (0 DEGREES) IF ANGLE IS BETWEEN 315 DEG AND 45 DEG * 2 (90 DEGREES) " " " " 45 " " 135 " * 3 (180 DEGREES) " " " " 135 " " 225 " * 4 (270 " ) " " " " 225 " " 360 " * * EMUL5 JSB SETUP LDA .3 STA LNTH JSB GB1 GET GICB LDA M MAKE IOBUF = ESC*LITTLE "M" JSB TRBYT CLA,INA LDIR = 1 STA LDIR DLD INTX2 NOW SEE IF THETA = 0 DEGREES SZA JMP EML51 SZB,RSS JMP EM5FN IT 0 EML51 LDA DEGPT POINTER TO ANGLE CONSTANTS IN RADIANS(DEG/57.3) STA TEMP EM5LP DLD TEMP,I FSB INTX2 C(DEGPT) - ANGLE SSA,RSS JMP EM5FN ANGLE < C(DEGPT) ISZ TEMP ANGLE > C(DEGPT) ISZ TEMP ISZ LDIR LDA LDIR CHECK FOR 360 CPA .5 JMP *+2 JMP EM5LP CLA,INA STA LDIR EM5FN LDA LDIR STA INTX2 LDA .1 STA LNGTH SET UP FOR CONVERSION TO ASCII LDA ~BIGN STA TERM JMP FINI * * NECESSARY CONSTANTS * LDIR NOP BIGN OCT 116 DEGPT DEF *+1 DEC .785 45 DEGREES DEC 2.355 135 DEG DEC 3.925 225 DEG DEC 5.455 315 DEG DEC 6.28 360 DEG * SPC 3 * * CHARACTER SIZE * EMUL6 JSB SETUP LDA .5 STA LNTH JSB GB1 GET GICB AND DATA LDA M JSB TRBYT DLD INTX2+2 FDV D10 COMPUTE SIZE = HEIGHT/10MUS JSB .IENT INTEGERIZE NOP LDB .1 SZA,RSS CHECK FOR 0 STB A STA INTX2 STB LNGTH LDA BIGM STA TERM JMP FINI * * GET DISPLAY SURFACE SIZE IN MILLIMETERS * EMUL9 LDA MMSIZ LDB DF8 8 WORDS JSB GB GO PUT IN GICB JMP DVG01,I * MMSIZ DEF *+1 DEC 0. DEC 0. DEC 239.6 LENGTH DEC 120. WIDTH * * DEFAULT LINE TYPE * EML10 JSB SETUP LDA MODE2 SET MODE STA ADCNT,I ISZ ADCNT LDA ATERM TERMINATOR A STA ADCNT,I LDA .5 LDB .2 JSB OUTPT LDA .2 STA LNTH JSB GB1 GET THE CONTENTS OF GICB LDA DFLT ADDRESS TO TOL FOR LINE TYPE NUMBERS JSB INDCK ADA INTX2 NUMBER FROM AGL LDA A,I GET 2648 EQUIVALENCE STA INTX2 LDA INX TRANSFER DATA BACK TO GICB LDB DF4 JSB GB LDA LNTYP FAKE OUT STA DCTAD JMP CONT GO PROCESS * * GET MU/MM * EML11 LDA DFD3 LDB DF4 JSB GB JMP DVG01,I * * FLUSH I/O BUFFER * EML12 JMP DVG01,I * * DEVICE CLEARING CHARACTERISTICS (TRUE CLEAR BIT 4=1) * EML13 LDA DF4 LDB DF1 JSB GB JMP DVG01,I * * NUMBER OF PHYSICALLY DIFFERENT PENS * EML14 LDA DF1 ONE PEN LDB DF1 JSB GB JMP DVG01,I * * NUMBER OF CURSORS * EML15 JMP EML14 * * LORGABILITY * EML16 JMP EML14 * *MAXIMUM CHARACTER SLANT * EML17 LDA DSLNT LDB DF4 JSB GB JMP DVG01,I * * DEVICE HARD CLIPPING CAPABILITY * EML18 LDA DF0 LDB DF1 JSB GB JMP DVG01,I * SPC 2 * SPC 2 * * MIN/MAX CHARACTER SIZES * EML19 LDA MMCSZ LDB DF9 JSB GB JMP DVG01,I * * LABEL DIRECTION CAPABILITY * EML20 LDA LBLDR LDB DF3 JSB GB JMP DVG01,I * * DEVICE ID (REPLACED BY A CALL TO OUTPUT IDENTIFY IE. * THIS INFO RETRIEVED DIRECTLY FROM TERMINAL. THIS CHANGE * MADE SO DRIVER COULD BE USED FOR 2648/2647) * *EML21 LDA ID26 * LDB DF3 * JSB GB * JMP DVG01,I * *ID26 DEF *+1 * ASC 3,2648A * JMP DVG01,I * * LORG RANGE * EML22 LDA DFL1 LDB DF2 JSB GB JMP DVG01,I * DFL1 DEF *+1 OCT 1 DEC 9 * * CHARACTER PLACEMENT * EML23 LDA ACINF LDB DF8 JSB GB JMP DVG01,I * ACINF DEF CINFO * CINFO DEC 0.00000 DEC 0.71429 DEC 0.00000 DEC 0.70000 SKP *CONSTANTS * * LINE TYPE EQUIVALENCY TABLE * DFLT DEF *+1 OCT 1 OCT 7 OCT 6 OCT 5 OCT 4 DEC 11 DEC 10 * * LINE TYPE COMMAND * LNTYP DEF *+1 DEC -1 DEF BB OCT 66400 "M BB OCT 102 * *POINTERS CONSTANTS ETC FOR EMULATORS * EM0 DEF * DEF EMUL1 DEF EMUL2 NOP DEF EMUL4 DEF EMUL5 DEF EMUL6 NOP NOP DEF EMUL9 DEF EML10 DEF EML11 DEF EML12 DEF EML13 DEF EML14 DEF EML15 DEF EML16 DEF EML17 DEF EML18 DEF EML19 DEF EML20 NOP DEVICE ID (REPLACED BY ENTRY IN DCT) DEF EML22 DEF EML23 * *LINE TYPES * LT DEF *+1 LT0 DEC 255  SOLID JACK!! LT1 DEC 170 DIMLY LIT LT2 DEC 224 DASHED LT3 DEC 254 LONG DASH LT4 DEC 235 CENTERLINE LT5 DEC 129 DOTS LT6 DEC 234 OPTIONAL C OCT 103 M OCT 155 D8 DEC 8.0 D10 DEC 10.0 BIGM OCT 115 LB OCT 142 "B M2 OCT 66462 "M2 LBLDR DEF *+1 OCT 1 DEC 1.57 * MMCSZ DEF *+1 DEC 7. DEC 10. DEC 56. DEC 80. OCT 0 * DF9 DEF .9 DF3 DEF .3 * SKP SPC 3 * * THIS PORTION OF THE DRIVER IS RESPONSIBLE FOR BUFFERING * PLOT COMMANDS (ESC*PX) SO THAT THE 2648A WILL OPERATE AT * ITS NORMAL VECTOR DRAWING SPEED. * BUFCK NOP JSB GRSTS CHECK STATUS TO SEE IF BUFFERING IS IN EFFECT DEF BFRTN DEF .1 GET STATUS DEF .1000 BIT 9 DEF BFTMP BFRTN LDA BFTMP SZA,RSS I/O BUFFERING? JMP BUFCK,I NO LDA LNGTH ALS STA BTEMP LDA DF1 JSB GB2 RETRIEVE CURRENT BUFFER LENGTH LDA RWFLG 0= READ,1= WRITE,3=EMULATOR CPA .1 JMP BF1 JMP EMPCK GO EMPTY BUFFER BF1 LDA FIRST SEE IF A PLOT COMMAND AND MASK CPA P JMP BF2 YES CONTINUE JMP EMPCK MODE CHANGE BF2 LDA GIC SEE IF "HOME PEN" CPA .5 JMP BUFCK,I YES GET OUT ISZ BUFLG SET FLAG TO INDICATE BUFFERING IN PROGRESS BF20 LDB BUFLN SEE IF CURRENT BUFFER LENGTH + NEW STUFF>IOBL STB NBYTE JSB UPDTE SZB IF ZERO STARTING A NEW STRING JMP BF2A JSB SETUP SET ESC* INTO I/O BUFFER LDA LP JSB TRBYT PREAMBLE PLOT COMMAND JSB UPDTE LDB NBYTE BF2A ADB .4 FOR GOOD MEASURE ADB BTEMP CLE,ERB CMB,INB ADB IOBL SSB JMP EMPCK FILLED TO THE TOP LDA FIRST EXTRACT SECOND BYTE OF PLOT COMMAND AND .377 IOR .32 5 INSURE LOWER CASE ASCII JSB TRBYT GO STORE IN IOBUF JSB UPDTE LDA LNGTH ANY INTEGERS TO CONVERT TO ASCII SZA,RSS JMP BF3 NO JSB CNVRT BF3 LDA NBYTE UPDATE BUFFER LENGTH STA BUFLN LDA DF2 JSB GB2 JMP DVG01,I * EMPCK LDB BUFLN SZB,RSS ANYTHING IN BUFFER JMP BUFCK,I NO-SO FORGET IT. LDA NBYTE STA BFTMP SAVE BYTE COUNT FOR NEW COMMAND. STB NBYTE JSB UPDTE LDA Z JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CLA STA BUFLN LDA BFTMP STA NBYTE LDA DF2 JSB GB2 LDA BUFLG SZA,RSS JMP BUFCK,I JMP BF20 * * RETRIEVE AND RESTORE CURRENT BUFFER BYTE COUNT * GB2 NOP STA GBRW JSB GCBIM DEF *+6 DEF .32 DEF .1 DEF BUFLN DEF .0 GBRW NOP JMP GB2,I * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT STA FWADR JMP UPDTE,I SKP SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP TEMP NOP NWORD NOP BTEMP NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP FWADR NOP INTX1 NOP INTX2 BSS 3 XMU NOP INTXX BSS 11 RW NOP IOCNT NOP * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .3 OCT 3 .16 DEC 16 .20 DEC 20 .200 OCT 2000 .77 OCT 77 .25 DEC 25 BFLSH OCT 2300 .1000 OCT 1000 S5 OCT 71465 S7 OCT 71467 S3 OCT 71463 .40 DEC 40 INX DEF INTX1 TERM NOP .377 OCT 377 .5 OCT 5 NUM NOP M16 DEC -16 M15 DEC -15 MASK OCT 177400 Z OCT 132 P OCT 70000 LP OCT 160 ESCST OCT 15452 ESC* I OCT 151 J OCT 152 ADCNT NOP IBYTE NOP RWFLG NOP ODFLG NOP LNTH NOP DF1 DEF .1 DF4 DEF .4 DF6 DEF .6NLH .6 OCT 6 .9 DEC 9 .137 OCT 137 S1 OCT 71461 CR OCT 15 LF OCT 12 DF2 DEF .2 .32 DEC 32 BUFLN NOP BFTMP NOP BUFLG NOP DFD3 DEF D3 D3 DEC 3. DEC 3. M1 OCT -1 MIN2 OCT -2 SKPBK NOP FLTFG NOP M4 OCT -4 K OCT 153 SMALL K DSLNT DEF .45DG .45DG DEC .785 DEC 0. DF0 DEF .0 DF8 DEF .8 .8 DEC 8 MODE2 OCT 66462 ATERM OCT 60400 .177 OCT 177 .2648 DEC 2648 .2647 DEC 2647 END JN u 92840-18084 2013 S C0122 &DCT01              H0101 ZqASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT01 -- 2648A/ 2647A DEVICE COMMAND TABLE * SOURCE: 92840-18084 * RELOC: 92840-16003 * PGMR: MODIFIED BY GSB 8-1-79 * * MODIFIED BY DJS 1-4-80 * - FIXED HOME PEN GIC - * * MODIFIED BY DJS 1-27-80 * - FIXED CLEAR SCREEN GIC - * ************************************************************* * NAM DCT01,7 92840-16003 REV.2013 800127 ENT DCT01 ENT SMLAB * * THIS IS THE DEVICE COMMAND TABLE FOR THE 2648A GRAPHICS * TERMINAL. * ********************************************************** * * COMMAND LINK TABLE (CLTBL) * SPC 3 DCT01 NOP DEF EML01 DEF RESET 1) RESET DEVICE NOP 2) DO NOTHING (SET MECH. LIMITS TO DEFAULTS) DEF CLEAR 3) DEVICE CLEAR DEC -12 4) XMIT DEF HOME 5) HOME PEN DEF DEVID 6) GET DEVICE ID NOP 7) (ALL DONE) DEF PLTUN 8) GET PLOT UNITS DEF PLTCH 9) GET CHARACTER SIZE INFORMATION DEF PNLOC 10) GET PEN LOCATION DEF CURSR 11) GET CURSOR LOCATION DEF DIGIT 12) DIGITIZE DEF LORG 13) LABEL ORIGIN DEC -5 14) LABEL DIRECTION DEF SLNT1 15) SLANT ON DEF SLNT0 16) SLANT OFF DEC -6 17) CHARACTER SIZE DEF PORG 18) PLOT ORIGIN NOP 19) SAVE NOP 20) ADD NOP 21) REPLACE DEF PNORG 22) PEN = ORIGIN DEF DRWCR 23) DRAW TO CURSOR NOP 24) DEF oSLPN0 25) SELECT PEN 0 DEF SLPN1 26) PEN= -1(ERASE) DEF SLPN3 27) PEN = -2 (COMPLEMENT) DEC -10 28) PEN 1-N DEC -2 29) GET # PENS DEC -3 30) ??? DEC -10 31) DEFAULT LINE TYPE DEC -4 32) LINE TYPE WITH LENGTH DEF PENUP 33) PEN UP DEF PENDN 34) PEN DOWN DEF PLTAB 35) PLOT ABSOLUTE DEF PLTRL 36) PLOT RELOCATABLE DEF PLTIN 37) PLOT INCREMENTAL SMLAB DEF SHRTL 38) SHORT LABEL DEF LGLAB 39) START LONG LABEL DEF STPLB 40) STOP LONG LABEL DEC -1 41) CONVERT FLOATING PT. TO ASCII, OUTPUT AS SHORT LABEL DEC -9 42) GET MAX DISPLAY SIZE IN MM. DEF CRABS 43) POSITION CURSOR ABSOLUTE DEF CRREL 44) " " RELATIVE NOP 45) RESET HARD CLIP LIMITS DEC -11 46) GET MU/MM DEC -13 47) DEVICE CLEARING CHARACTERISTICS DEC -14 48) # OF PHYSICALLY DIFFERENT PENS DEC -15 49) # OF CURSORS DEC -16 50) LORGABILITY DEC -17 51) MAX-CHAR SLANT DEC -18 52) HARD CLIPPING CAPABILITY DEC -23 53) INQUIRE CHARACTER PLACEMENT DEC -19 54) MIN/MAX CHARACTER SIZES DEC -20 55) LABEL DIRECTIONS DEC -22 56) LORG RANGE * * SPC 3 SKP SPC 3 * * ASCII COMMAND STRINGS * * FORMAT: WORD1 = NUMBER OF BYTES (N) WHERE * -N INDICATES A WRITE TO DEVICE * +N INDICATES A READ AFTER WRITE * WORD2 = NOP TERMINATOR WITHIN COMMAND STRING * DEF TERM - TERMINATOR AT ADDRESS TERM * WORD3 = FIRST WORD OF COMMAND STRING * ************************************************************** SPC 3 RESET DEC -2 NOP OCT 66522 "MR ("CHARACTER =LOWER CASE) * ESC*mr set graphics default * HOME DEC -8 k DS2013 NOP OCT 70141 ESC*pa lift pen OCT 64440 i data absolute, 0 x-cord OCT 20040 DS2013 OCT 20132 0 y-cord, z nop * PLTUN DEC 3 READ PLOT UNITS NOP OCT 71465 esc*s5 read display size ASC 1,Z z nop * PLTCH DEC 3 NOP OCT 71467 esc*s7 read graphics text status ASC 1,Z z nop * PNLOC DEC 3 NOP OCT 71462 esc*s2 read pen position ASC 1,Z * CURSR DEC 3 NOP OCT 71463 esc*s3 read graphics cursor position ASC 1,Z * DIGIT DEC 3 NOP OCT 71464 esc*s4 read cursor position and wait for key ASC 1,Z * SLPN0 DEC -3 NOP OCT 66460 esc*m0a select pen 0 ASC 1,A SLPN1 DEC -3 NOP OCT 66461 esc*m1a select pen 1 (erase?) ASC 1,A * DS2013 * DS2013 * SLPN2 IS NOT USED IN THE DCT DS2013 * DS2013 *SLPN2 DEC -3 DS2013 * NOP DS2013 * OCT 66462 esc*m2a select pen 2 DS2013 * ASC 1,A DS2013 * SLPN3 DEC -3 NOP OCT 66463 esc*m3a select pen 3 (compliment) ASC 1,A * DS2013 * DS2013 * SLPN4 IS NOT USED IN THE DCT DS2013 * DS2013 *S;LPN4 DEC -3 DS2013 * DEF B DS2013 * OCT 66462 esc*m2a?b select pen 2, line style replaces ? DS2013 * OCT 60400 DS2013 * DS2013 * DS2013 * DEFLN IS NOT USED IN THE DCT DS2013 * DS2013 *DEFLN DEC 1 DS2013 * DEF C DS2013 * OCT 66400 esc*m?c select line pattern, a number replaces ? DS2013 * DS2013 PENDN DEC -2 NOP OCT 70102 esc*pb lower the pen * PENUP DEC -2 NOP OCT 70101 esc*pa lift pen * PLTAB DEC -2 DEF Z OCT 70151 esc*pi data is absolute * PLTRL DEC -2 DEF Z OCT 70154 esc*pl?z data is relocatable, data replaces ? * PLTIN DEC -2 DEF Z OCT 70152 esc*pj?z set relocatable origin, info goes in place of ? * CLEAR DEC -13 Turn off zoom, clear graphics, and move to 0,0. NOP OCT 62150 d h DS2013 OCT 60433 a esc DS2013 OCT 25160 * p DS2013 OCT 60551 a i DS2013 OCT 20040 space space (X=0) DS2013 OCT 20040 space space (Y=0) DS2013 ASC 1,Z terminate DS2013 * DS2013 SHRTL DEC -1 DEF BLANK OCT 66000 esc*l?blank graphics label, string replaces ? * LGLAB DEC -2  NOP OCT 62123 esc*ds graphics mode on * STPLB DEC -2 NOP OCT 62124 esc*dt graphics mode off * DRWCR DEC -2 NOP OCT 70103 esc*pc use graphics cursor as new point * LORG DEC -1 DEF Q OCT 66400 esc*m?q set graphics text origin, info replaces ? * SLNT1 DEC -2 NOP OCT 66517 esc*mo turn on text slant * SLNT0 DEC -2 NOP OCT 66520 esc*mp turn off text slant * PORG DEC -1 DEF J OCT 66400 esc*m?j set relocatable origin, info replaces ? * *CRORG DEC -2 * NOP * OCT 66514 esc*ml set relocatable origin to graphics cursor position * PNORG DEC -2 NOP OCT 66513 esc*mk set relocatable origin to current pen position * CRABS DEC -1 DEF O OCT 62000 esc*d?o move graphics cursor absolute, info replaces ? * CRREL DEC -1 DEF P OCT 62000 move graphics cursor incremental * DEVID DEC 3 modified by GSB 8-8-79 NOP OCT 71461 get device id ASC 1,Z SPC 3 * * ERROR CHECKING * EML01 NOP LDA .2648 JMP EML01,I .2648 DEC 2648 * * TERMINATORS * *A OCT 101 DS2013 BLANK OCT 40 *B OCT 102 DS2013 *C OCT 103 DS2013 J OCT 112 O OCT 117 P OCT 120 *S OCT 123 DS2013 *T OCT 124 DS2013 Q OCT 121 Z OCT 132 * END J v 92840-18085 1940 S C0122 &DVG01              H0101 pjASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DVG02 -- 9872A, 7245A, 7225A DEVICE SUBROUTINE * SOURCE: 92840-18085 * RELOC: 92840-16004 * * * ************************************************************* * NAM DVG02,7 92840-16004 REV.1940 790720 * EXT EXEC,GCBIM,BYTE EXT REIO EXT .IENT EXT FLOAT EXT EMULX EXT INDCK EXT INTX EXT DCTIM EXT CONVT EXT LNGTH,GIC,DCTAD EXT GRSTS * ENT DVG02 9872A GRAPHICS PLOTTER ENT DVG03 7245A PLOTTER/PRINTER ENT DVG08 7225A PLOTTER ENT DVG23 7245A PLOTTER/PRINTER (ROTATION) * * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 9872A GRAPHICS * PLOTTER, THE 7245A PLOTTER/PRINTER, AND THE 7225A PLOTTER. * THIS ROUTINE ALONG WITH DVR37 CONTROLS THE PICTURE DRAWING * ON THE PLOTTERS. * * DVG03 EQU * 7245A PLOTTER/PRINTER DVG08 EQU * 7225A PLOTTER DVG23 EQU * 7245A PLOTTER PRINTER (ROTATION) DVG02 NOP 9872A GRAPHICS PLOTTER CLA INITIALIZE THE READ/WRITE FLAG AND BYTE STA RWFLG COUNTER STA FIN STA NBYTE BYTE COUNTER STA IBYTE BYTE COUNTER FOR SUBROUTINE CALLS LDA SEMCL SEMICOLON = TERMINATOR STA TERM TERMINATOR JSB DCTIM FILL UP GIC, LNGTH, DEV CMD ADDR (DCTAD) LDA GIC CPA .177 IF GIC = FIRST GIC JMP ERRCK THEN VERIFY ID AND LU JSB SETUP ELSE GET READY TO ACT ON GIC CONT LDA DCTAD CHECK COMMAND TYPE SSA IF CMD = EMULATOR JMP EMULT THEN GO TO DCT0X AND EXECUTE EMULX SZA,RSS IF CMD = NOP JMP DVG02,I THEN DO NOTHING AND RETURN LDB DCTAD ELSE ITS A COMMAND ADDRESS LDA B,I READ LENGTH OF CMD STRING SSA,RSS IS CMD A READ OR WRITE? JMP CONT0 READ -- RWFLG = 0 ISZ RWFLG WRITE - RWFLG = 1 CMA,INA SET BYTE COUNT POSITIVE CONT0 STA NBYTE STORE NUMBER OF WORDS AND .1 COMPUTE NWORD = NBYTE/2 + REMAINDER STA NWORD STA ODFLG ODFLG = 0 IF EVEN, 1 IF ODD LDA NBYTE CLE,ERA NBYTE/2 ADA NWORD CMA,INA STA NWORD SET WORD COUNTER NEGATIVE INB B = ADDRESS OF TERMINATOR LDA B,I SAVE TERMINATOR FOR LATER LDA A,I STA TERM TERMINATOR INB LDA B,I STA FIRST SAVE FIRST WORD OF COMMAND STRING STB DCTAD POINT TO FIRST WORD OF CMD STRING XFER LDA DCTAD,I TRANSFER CMD STRING TO THE I/O BUFFER STA ADCNT,I ISZ NWORD JMP CONT2 JMP XEND FINISHED CONT2 ISZ DCTAD ISZ ADCNT INCREMENT ADDRESS POINTERS JMP XFER CONTINUE XEND LDA ODFLG SZA,RSS ISZ ADCNT LDA RWFLG IS CMD A READ OR WRITE? SZA,RSS JMP READ READ LDA LNGTH WRITE - SEE IF INTS TO CONVERT TO ASCII SZA THIS IS LENGTH FROM GICB JMP CNVRT GO CONVERT TO ASCII JSB TRBYT GO INSERT TERMINATOR LDA NBYTE NUMBER OF BYTES LDB .2 WRITE JSB OUTPT EXEC I/O JMP DVG02,I DONE -- RETURN SKP * * READ DATA FROM DEVICE AND CONVERT TO INTEGER. FIRST A * A WRITE MUST BE DONE TO OUTPUT THE COMMAND CODE, THEN A * READ MUST BE DONE TO PUT THE DEVICE INTO THE TALK MODE TO * GET THE STATUS DATA. * READ NOP JSB TRBYT C FIRST INSERT TERMINATOR LDA NBYTE GET NUMBER OF BYTES LDB .2 WRITE JSB OUTPT OUTPUT STATUS REQUEST COMMAND * LDA M19 FILL BUFFER WITH BLANKS, INSURE THERE IS STA CNTR NO GARBAGE IN INPUT BUFFER LDA IOBUF ADDRESS OF I/O BUFFER -- SET TO ADDR CTR STA BACNT * BLOOP LDA BLNK STA BACNT,I ISZ BACNT ISZ CNTR JMP BLOOP * LDB .1 NOW PUT DEVICE INTO TALK MODE (READ) LDA .40 TO GET DATA JSB OUTPT * JSB INTEG GO CONVERT FROM ASCII TO INTEGER JSB GB2 TRANSFER RESULTS TO GICB JMP DVG02,I * CNVRT LDA LNGTH INA STA LNTH JSB GB1 RETRIVE INTEGER VALUES JMP FINI SKP ************************************************************** * * SPECIAL INTERNAL UTILITY ROUTINES * ************************************************************** * * SETUP -- SET UP IOBUF ADDRESS, GET LUN AND THE DEVICE * SUBROUTINE SAVE AREA IN GCB * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDR, IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES, THREE WORDS DEF LUN START AT BUFFER ADDRESS = LU NUMBER DEF .0 USE DEFAULT LENGTHS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO * * NOW CHECK BIT 4 OF STATUS WORD TO SEE IF A SHORT LABEL WAS * PREVIOUSLY EMITTED - IF SO EMIT LABEL TERMINATOR AND RESET BIT 4 * JSB GRSTS GET BIT 4 OF STATUS WORD DEF *+4 DEF .1 DEF BIT4 DEF TEMP LDA TEMP SZA,RSS IF BIT = 0 JMP SETUP,I THEN RETURN LDA ETX ELSE EMIT TERMINATOR (DEC 3) STA IOBUF,I ISZ NBYTE LDA .1 LDB .2 WRITE JSB OUTPT Y JSB GRSTS RESET BIT 4 DEF *+4 DEF .2 DEF MASK4 DEF .0 CLA STA NBYTE LDA IOBUF STA ADCNT RTSUP JMP SETUP,I SKP * * INTEG -- CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP OP = OUTPUT P1 AND P2 JMP FIXIT YES CPA OF OF = OUTPUT FACTOR JMP FIXIT CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE RTING JMP INTEG,I * * FIXIT -- CONVERT INTEGER TO FLOATING POINT * FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I STORE RESULT IN REGISTERS A AND B ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * GB2 -- TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP JSB GCBIM TRANSFER DATA TO AGL DEF RTGB2 DEF .16 DEF .1 DEF INTX1 DEF LNGTH DEF .2 WRITE RTGB2 JMP GB2,I SKP * * GB1 -- RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP JSB GCBIM RETRIEVE INTEGER VALUES FROM GCB DEF RTGB1 DEF .16 DEF .1 DEF INTX1 DEF LNTH DEF .1 READ RTGB1 JMP GB1,I * * FINI: 1) CONVERTS INTEGER TO ASCII * 2) TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT) * 3) RETURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I/O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 WRITE JSB OUTPT LDA FIN SZA,RSS JMP DVG02,I RTFIN JMP FIN,I * * TRBYT -- INSERT TERMINATOR INTO THE I/O BUFFER * TRBYT NOP LDA TERM SEMICOLON JSB PTBYT RTTBT JMP TRBYT,I SKP * * PTBYT -- PUT A BYTE INTO THE I/O BUFER * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE RTPBT JMP PTBYT,I * BITE NOP * * UPDTE -- UPDATE BYTE COUNTER FOR THE I/O BUFFER * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * OUTPT -- INPUT/OUTPUT OF DATA (EXEC READ/WRITE CALLS) * OUTPT NOP I/O TRANSFER ROUTINE STB RW LDB TERM CPB .137 CHECK FOR CR/LF SUPRESSION JMP *+2 INA CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT LDA .137 BACKSPACE JSB PTBYT SUPRESS CR/LF JSB REIO DEF RTOUT DEF RW READ/WRITE CODE DEF LUN LOGICAL UNIT NUMBER IOB NOP DEF IOCNT RTOUT JMP OUTPT,I SKP * * ERRCK -- MAKE SURE LU COINCIDES WITH ID * ERRCK JSB SETUP * JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF LUN THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BIT HERE JMP ITSNT NOT AN LU -- GPS 5 * LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD LDB A SAVE EQT TYPE FIELD LDA ZTEMP GET THE SUBCHANNEL BITS AND M37 STA ZTEMP ADA B CONFIGURE B REGISTER RETURN WORD STA DTYPE CPB M1740 IF DVR05 JMP ERR1 THEN DO ONE MORE CHECK FOR SUBCHANNEL ITSNC*T LDA .5 JMP ERRPT ERR1 JSB EMULX,I ASK DEVICE COMMAND TABLE ABOUT ITSELF CPA .9872 IS IT A 9872A? JMP ERR2 CPA .7245 IS IT A 7245A? JMP ERR2 CPA .7225 IS IT A 7225A? JMP ERR2 CPA .3 IS IT A GPS 3? JMP ERR3 CPA .5 IS IT A GPS 5? JMP ERR3 LDA .3 SOMETHING IS WRONG -- MAKE IT A GPS 3 JMP ERR3 ERR2 CLA ERR3 STA INTX1 LDA .1 STA LNGTH JSB GB2 LDA INTX1 SZA JMP DVG02,I JSB EXEC DEVICE CLEAR DEF *+3 DEF .3 DEF LUN LOGICAL UNIT NUMBER JMP DVG02,I ERRPT LDA .5 GPS 5 JMP ERR3 SKP * * CONSTANTS AND TEMPORARY STORAGE * .9872 DEC 9872 9872A GRAPHICS PLOTTER .7245 DEC 7245 7245A PLOTTER/PRINTER .7225 DEC 7225 7225A PLOTTER .177 OCT 177 * D13I OCT 100015 M1740 OCT 17400 M37 OCT 37 MEQT OCT 37400 ANLU# NOP DTYPE NOP YTEMP NOP ZTEMP NOP EMULT JSB EMULX,I JMP DVG02,I * A EQU 0 A REGISTER B EQU 1 B REGISTER * NBYTE NOP NWORD NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP INTXX BSS 8 RW NOP READ/WRITE CODE IOCNT NOP SKP * * DO NO CHANGE POSITION OF THESE CONSTANTS * .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .3 OCT 3 .16 DEC 16 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX DEF INTX1 INX1 DEF INTX4 .21 DEC 21 .7 DEC 7 TERM NOP TERMINATOR ETX OCT 1400 ETX -- DECIMAL 3 (TERMINATOR) BIT4 OCT 20 TEMP NOP MASK4 OCT 77757 SEMCL OCT 73 SEMICOLON DF7 DEF .7 .600 OCT 6000 .137 OCT 137 BACKSPACE ADCNT NOP IBYTE NOP RWFLG NOP READ/WRITE FLAG ODFLG NOP ODD/EVEN FLAG LNTH NOP SKPBK NOP OP ASC 1,OP OP = OUTPUT P1 AND P2 OF ASC 1,OF OF = OUTPUT *($FACTORS M19 DEC -19 BACNT NOP CNTR NOP BLNK OCT 20040 END G* w 92840-18086 1940 S C0122 &DCT02              H0101 ^xASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT02 - 9872A/B/S DEVICE COMMAND TABLE * SOURCE: 92840 - 18086 * RELOC: 92840 - 16005 * * * ************************************************************* * NAM DCT02,7 92840-16005 REV.1940 790720 ENT DCT02 * EXT EXEC,TAN,COS,SIN,FLOAT,.IENT EXT ABS EXT FLTAS EXT CONVT EXT LNGTH,GIC,DCTAD EXT GCBIM,INTX,BYTE,INDCK EXT REIO * THIS IS THE DEVICE COMMAND TABLE FOR THE 9872 HARD COPY * PLOTTER. * * * COMMAND LINK TABLE (CLTBL) * SPC 3 DCT02 NOP DEF EML02 DEF RESET RESET PLOTTER DEF DEFLT DEFAULT P1,P2 DEC -26 PAGE FEED NOP FLUCH DEF HOME HOME PEN DEC -19 DEVICE ID NOP DEF PLTUN GET PLOT UNITS OCT -1 " (GET CHARACTER INFORMATION) DEF PNLOC GET PEN LOCATION DEF PNLOC CURSOR DEC -4 DIGITIZE NOP LORG DEC -7 LDIR DEC -8 SLANT ON DEF SLOFF SLANT OFF DEC -9 CHAR. SIZE DEC -13 SET RELATIVE ORIGIN NOP NOPS NOP NOP NOP NOP NOP DEF SELPN SELECT PEN 0(RETURN TO HOLDER) NOP PEN = -1 NOP PEN = -2 DEF SELPN PEN = 1-N DEC -5 GET NUMBER OF PENS DEC -6 DEFINE LINE TYPE DEC -10 LINE TYPE DEC -10 LINE TYPE WITH LENGTH DEF PENUP DEF PENDN DEF PLTA.B DEC -2 PLOT RELOCATABLE DEF PLTIN DEF LGLAB SHORT LABEL DEF LGLAB LABEL MODE DEF STPLB LABEL MODE TERMINATOR DEC -3 FLT TO ASCII DEC -11 DISPLAY SURFACE SIZE IN MM NOP NOP DEC -24 SET P1,P2 DEC -12 GET MU/MM DEC -14 GET DEVICE CLEARING CHARACTERISTICS DEC -15 NUMBER OF PHYSICALLY DIFFERENT PENS DEC -20 # OF CURSORS DEC -16 LORGABILITY DEC -17 MAX. CHARACTER SLANT DEC -18 HARD CLIPPING CAPABILITY DEC -25 INQUIRE CHARACTER PLACEMENT DEC -21 DEC -22 DEC -23 * * * ASCII COMMAND STRINGS * SPC 3 RESET DEC -2 6 BYTES, WRITE DEF SEMCL ASC 1,DF COMMAND STRING * DEFLT DEC -5 DEF SEMCL ASC 3,IP;IW * HOME DEC -16 DEF SEMCL ASC 8,PU;PA15720,10380 * PLTUN DEC 2 DEF SEMCL ASC 1,OP PNLOC DEC 2 DEF SEMCL ASC 1,OC * LNTYP DEC -2 DEF SEMCL ASC 1,LT * PENDN DEC -2 DEF SEMCL ASC 1,PD * PENUP DEC -2 DEF SEMCL ASC 1,PU * PLTAB DEC -2 DEF SEMCL PA ASC 1,PA * PLTIN DEC -2 PLOT INCREMENTAL DEF SEMCL ASC 1,PR * SELPN DEC -2 DEF SEMCL ASC 1,SP LGLAB DEC -2 DEF HT LB ASC 1,LB STPLB DEC -1 DEF HT OCT 1400 DECIMAL 3 * SLOFF DEC -2 DEF SEMCL ASC 1,SL STP12 DEC -2 DEF SEMCL ASC 1,IW * * SEMCL OCT 73 HT OCT 137 .3 OCT 3 * SKP * SPC 3 * * UTILITY ROUTINES FOR EMULATORS * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSbB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL TERMINATOR STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE * JMP SETUP,I * * CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP STA GCBCD JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF GCBCD DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * * RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF GCBCD DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FINI DOES THE FOLLOWING: * 1. CONVERTS INTEGERS TO ASCII * 2. TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3. RETURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP FIN,I * * EXIT DVG10 AND SET MODE TO LABEL IF NOT ALREADY SET * SPC 3 SPC 3 * * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * BITE NOP * OUTPT NOP I/O TRANSFER ROUTINE CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT STB RW JSB REIO DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I * * SKP SPC 3 * * EMULATORS * EML02 NOP JSB SETUP GO GET IOBUF,IOBL,LUN AND FXD N LDA GIC CPA .177 JMP ERRCK LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA STA B LDA EM0 TOP OF LIST OF EMULATORS AND OTHER THINGS. JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE POINTER LDB LNGTH INB STB LNTH LDA A,I JMP A,I * EM0 DEF * DEF EMUL1 DEF EMUL2 DEF EMUL3 DEF EMUL4 DEF EMUL5 NOP DEFINE LINE TYPE DEF EMUL7 DEF EMUL8 DEF EMUL9 DEF EML10 DEF EML11 DEF EML12 DEF EML13 DEF EML14 DEF EML15 DEF EML16 DEF EML17 DEF EML18 DEF EML19 DEF EML20 DEF EML21 DEF EML22 DEF EML23 DEF EML24 DEF EML25 DEF EML26 * SKP SPC 2 * * CHARACTER SPACING INFORMATION * EMUL1 LDA .7 JSB GB1 GET CURRENT CHARACTER SIZE LDA .16 JSB GB2 JMP EML02,I * * * DEFAULT VALUES = WIDTH * 1.5 * 400 MU MM * HEIGHT * 2. * 400MU/MM * * CHRW DEC 171. CHRH DEC 300. CHW DEC 2.4 .004 * 600 DEC 4.0 .005 * 800 DEC 15720. DEC 10380. OCT 0 D1.5 DEC 1.5 D2.0 DEC 2.0 SPC 3 * RELATIVE PLOTTING (RPLOT(X,Y) * EMUL2 LDA .32 GET PORGX,PORGY * JSB GB1 * LDA INTX1 * STA PORGX * LDA INTX2 * STA PORGY * LDA .16 NOW GET NEW POINTS * JSB GB1 * LDA PORGX COMPUTE PORG(X,Y) + NEWPOINTS * ADA INTX2 * STA INTX2 * LDA PORGY * ADA INTX3 * STA INTX3 * LDA PA * JSB WRDST INSERT PLOT ABSOLUTE COMMAND INTO IOBUF * JSB FIN CONVERT VALUES TO ASCII AND OUTPUT * JMP EML02,I * SPC 3 * * FLOAT TO ASCII * EMUL3 LDA .3 ETX STA TERM LDA LB JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I * * * FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN F7.N DEF SKPBK RTGLD JMP GLIDE,I * * * * SPC 3 * * DIGITIZE * EMUL4 LDA DP DIGITIZE POINT -TURN ON ENTER LIGHT JSB PROUT EM4LP LDA OS OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF POINT LDB .1 JSB OUTPT HAS BEEN ENTERRED LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER LDA INTX1 AND .4 SZA JMP GETPT BIT 2 IS SET GO GET POINT JMP EM4LP CONTINUE LOOPING UNTIL WHATS -ITS ENTERS POINT GETPT LDA OD OUTPUT DIGITIZED POINT JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG LDA .16 JSB GB2 JMP EML02,I * PROUT NOP OUTPUT ASCII COMMAND IN THE A REGISTER JSB WRDST STORE WORD IN IOBUF JSB TRBYT OLDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT JMP PROUT,I * * ASCII COMMANDS * OD ASC 1,OD OS ASC 1,OS DP ASC 1,DP * * NUMBER OF PENS SIMULATED OR OTHERWISE * EMUL5 LDA .4 FOUR PENS STA INTX1 LDA .16 JSB GB2 JMP EML02,I ** * LABEL DIRECTION * GICB = DEGREES- 9872 WANTS RUN,RISE * * EMUL7 LDA .3 STA FXDN SET UP FOR FLOAT TO ASCII CONVERSION LDA DI ABSOLUTE DIRECTION JSB WRDST LDA .16 JSB GB1 GO GET THETA DLD INTX2 DST INTX4 SAVE FOR RISE COMPUTATION JSB COS COMPUTE RUN NOP DST INTX2 JSB CLGCK EML71 JSB GLIDE CONVERT TO FLOATING POINT LDA COMA JSB PTBYT DLD INTX4 JSB SIN NOP COMPUTE RISE DST INTX2 JSB CLGCK EML72 JSB GLIDE JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I SPC 3 * * CLUGE BECAUSE OF PROBLEMS WITH 1.57 RADIANS (90 DEGREES) * CLGCK NOP JSB ABS FSB SMALL SSA,RSS JMP CLGCK,I DLD DBL0 DST INTX2 JMP CLGCK,I * SMALL DEC .0009 * * CHARACTER SLANT * EMUL8 LDA .3 STA FXDN SET UP FOR 3 CHARACTER TO RIGHT OF . LDA SL SLANT MNEMONIC JSB WRDST LDA .16 JSB GB1 GET ANGLE DLD INTX2 JSB TAN COMPUTE TAN(THETA) NOP DST INTX2 JSB GLIDE FLOAT TO ASCII JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I * SL ASC 1,SL * * CHARACTER SIZE * GICB = WIDTH/HEIGHT * EMUL9 LDA .3 STA FXDN LDA .16 JSB GB1 DLD INTX4 GET HEIGHT AND SAVE DST TEMP LDA SI JSB WRDST DLD INTX2 WIDTH FDV CSIZW MU/CM/MU DST INTX2 JSB GLIDE LDA COMA JSB PTBYT DLD TEMP FDV CSIZH DST INTX2 JSB GLIDE JSB TRBYT LDB .2 LDA NBYTE JSB OUTPT JMP EML02,I * CSIZW DEC 600. MU/CM CSIZH DEC 800. SI ASC 1,SI * * LINE TYPES - GICB = LT#, * EML10 LDA .3 STA FXDN LDA .16 JSB GB1 GET DATA FROM GCB LDA LT LINE TYPE COMMAND JSB WRDST LDA INTX2 LT = 0 FOR SOLID SZA,RSS JMP FIN11 ADA LT0 GET LINE TYPE EQUIVALENCE FOR 9872 LDA A,I JSB PTBYT LDA LNGTH IS THERE A LENGTH SPECIFICATION CPA .1 JMP FIN12 FIN10 LDA INTX2 CPA .5 JMP FIN11 LDA INTX2 IOR .1 ADA PCLT0 STA TEMP ADDRESS OF PERCENT DIVIDER DLD INTX3 FDV TEMP,I DST INTX2 LDA COMA JSB PTBYT JSB GLIDE FLOAT TO ASCII FIN11 JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I FIN12 LDA INTX2 IS LT = 1(DIM) CPA .1 JMP *+2 YES JMP FIN14 DLD D22 DST INTX3 JMP FIN10 CONTINUE * FIN14 LDA COMA JSB PTBYT SET DEFAULT LINE TYPE LENGTH BACK TO 4% LDA ASC4 JSB PTBYT JMP FIN11 * * LINE TYPES AND PERCENT VALUES * LT ASC 1,LT DI ASC 1,DI LT0 DEF * LT1 OCT 61 LT2 OCT 62 LT3 OCT 63 LT4 OCT 65 LT5 OCT 60 LT6 OCT 66 * * 1% VALUES OF LINE TYPE LENGTHS * PCLT0 DEF * PCLT1 DEC 45. DEC 60. DEC 135. DEC 180. BSS 2 DEC 180. * ASC4 OCT 64 D22 DEC 22.5 SPC 3 * GET DISPLAY SIZE IN MM * EML11 LDA SIZMM LENGTH LDB DF8 JSB GB JMP EML02,I * SIZMM DEF SZMM * SPC 3 * GET MACHINE UNIT/MM VALUES * EML12 LDA DF40 LDB DF4 JSB GB JMP EML02,I * * * SET RELATIVE ORIGIN * aEML13 LDA .16 JSB GB1 LDA .32 IOSAV JSB GB2 JMP EML02,I * DEVICE CLEARING CAPABILITY * EML14 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EML02,I * SPC 2 * PHYSICAL PENS * EML15 LDA DF4 LDB DF1 JSB GB JMP EML02,I * SPC 2 * * LORGABILITY - NONE * EML16 JMP EML14 SPC 2 * * MAX. CHAR SLANT * EML17 LDA CHSLT LDB DF4 JSB GB JMP EML02,I * SPC 2 * * DEVICE HARD CLIPPING CAPABILITY * EML18 LDA DF1 LDB DF1 JSB GB JMP EML02,I DF40 DEF D40 * SPC 2 * * DEVICE ID * EML19 LDA IDCD LDB DF3 JSB GB JMP EML02,I * * MIN/MAX CHARACTER SIZES * EML21 LDA DFCHR LDB DF9 JSB GB JMP EML02,I * DFCHR DEF CHW DF9 DEF .9 .9 DEC 9 * * LABEL DIRECTION INFO. FOR DSTAT OR WHOEVER * EML22 LDA LBLDR LDB DF3 JSB GB JMP EML02,I * LBLDR DEF *+1 OCT 2 DBL0 DEC 0. * IDCD DEF .987A .987A ASC 3,9872A * EML20 LDA DFL0 LDB DF1 JSB GB JMP EML02,I * * LORG RANGE * EML23 LDA DFL0 LDB DF2 JSB GB JMP EML02,I * DFL0 DEF DBL0 * * * SET HARD CLIP LIMITS * EML24 LDA .16 JSB GB1 GET LIMITS G1,G2 LDA IP SET SCALING POINTS P1,P2 JSB WRDST JSB FIN OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT LDA IW SET WINDOW JSB WRDST JSB FIN JMP EML02,I * IP ASC 1,IP IW ASC 1,IW * * CHARACTER PLACEMENT * EML25 LDA ACINF LDB DF8 JSB GB JMP EML02,I * * CLEAR PAGE FEED ETC * EML26 CLA CLEAR THE I/O COUNT STA NBYTE BYTE COUNTER=0 LDA IOBUF GET ADR OF I/O BUFFER STA ADCNT AND STORE IT * * SEND THE FOLLOWING COMMAND SEQ (PU IW PA15720,10380 PG) * TO PICK UP PEN AND MOVE IT TO THE UPPER RIGHT HAND EDGE OF * THE PLOTTER, AND DO A PAGE FEED. * CLA SET THE BYTE COUNT TO ZERO MTOP STA MYCNT SAVE CURRENT COUNT LDA CMDAR GET ADR OF STRING TO SEND ADA MYCNT ADD OFFSET INTO STRING LDA A,I GET WORD OF DATA FROM STRING * JSB WRDST STORE IT IN THE IO BUFFER * LDA MYCNT GET COUNT AND INC IT ADA .1 MYCNT=MYCNT+1 CPA .11 CK FOR 11 (END OF STRING) JMP MOUT FOUND IT, ALL DONE JMP MTOP NOPE, KEEP ON LOOPING * * MOUT JSB TRBYT STORE A TERMINATOR INTO I/O BUF * LDA NBYTE GET NUMBER OF BYTES TO TRANSFER LDB .2 SET READ/WRITE CODE TO WRITE JSB OUTPT WRITE I/0 BUFFER TO DEVICE * *SINCE THE 9872A OR B WILL GIVE AN ERROR WITH THE PG COMMAND *WE MUST SEND A OE (OUTPUT ERROR) COMMAND TO CLEAR THE POSSIBLE *ERROR STATE. * CLA CLEAR THE I/O COUNT STA NBYTE BYTE COUNTER=0 LDA IOBUF GET ADR OF I/O BUFFER STA ADCNT AND STORE IT * LDA OE LOAD AND SEND OE COMMAND JSB WRDST STORE OP CODE IN I/O BUFFER * JSB TRBYT STORE A TERMINATOR INTO I/O BUF * LDA NBYTE GET NUMBER OF BYTES TO TRRANSFER LDB .2 SET READ/WRITE CODE TO WRITE JSB OUTPT WRITE I/O BUFFER TO DEVICE * *NEXT WE READ BACK TO RESULT TO CLEAR THE BUS. * LDA .40 GET NUMBER OF BYTES TO TRANSFER LDB .1 SET READ/WRITE CODE TO READ JSB OUTPT READ 40 BYTES FROM DEVICE * *ALL DONE LETS RETURN * JMP EML02,I * * COMMAND STRING FOR CLEAR * CMDAR DEF *+1 ADR OF START OF STRING ASC 12,PU;IW;PA15720,10380;PG * * ACINF DEF CINFO * CINFO DEC 0.00000 DEC 0.66667 DEC 0.00000 DEC 0.50000 SPC 2 SKP GB NOP STA ADDR ADDRESS OF DATA STB NUM NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 DEF .1 ADDR NOP NUM NOP DEF .2 JMP GB,I * * STORE A WORD INTO THE IOBUF * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE JMP WRDST,I SKP * * * ERROR CHECKING * ERRCK JSB EXEC DEF *+3 DEF .3 DEF LUN * LDA OE CLEAR OUT ANY PENDING ERRORS JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OI OUTPUT IDENTIFICATION JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OE OUTPUT ERROR JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER LDA INTX1 BIT ONE BETTER BE SET AND .1 SZA IS BIT 1 EQUAL TO 0? JMP OKAY IF SO THEN DEVICE MUST BE 9872A * *NOTE THAT THE ABOVE TEST (OI COMMAND RESULTS IN ERROR) IS THE ONLY *KNOWN WAY TO IDENTIFY THE 9872A. THE OI COMMAND WILL NOT RESULT *IN AN ERROR FOR THE 9872B/S SO THE RETURNED STRING IS CKED. * *IS DEVICE 9872B/S ? * CLA CLEAR I/O COUNT STA NBYTE NBYTE=0 LDA IOBUF GET THE ADDR OF IO BUFFER STA ADCNT AND STORE IT * LDA OI SEND THE OUTPUT IDENTIFICATION COMMAND JSB WRDST STORE INTO IO BUFFER JSB TRBYT TERMINATOR TO IO BUFFER LDA NBYTE GET BYTE COUNT LDB .2 SET R W FLAG TO WRITE JSB OUTPT d_ SEND COMMAND (OI) * *NOW SET UP TO READ IN ID STRING * LDA .40 SET UP TO READ 40 BYTES LDB .1 SET R W FLAG TO READ JSB OUTPT READ DATA * LDA IOB GET THE ADR OF IO BUFFER STA BUFAD GET THE FIRST 2 WORDS DLD BUFAD,I CPA PART1 IS WORD 1 OF IO BUF AN ASCII 98 JMP CHEK2 YES - CONTINUE DEVICE CK JMP ERR3 NO - A GPS 3 ERROR HAS OCCURRED CHEK2 CPB PART2 IS WORD 2 OF IO BUF AN ASCII 72 JMP OKAY YES - DEVICE ID OKAY, NO ERROR ERR3 LDA .3 NO - A GPS 3 ERROR HAS OCCURRED JMP EML02,I RETURN TO DVG OKAY LDA .9872 GET DEVICE ID CODE INTEGER JMP EML02,I AND RETURN TO DVG * OE ASC 1,OE PG ASC 1,PG OI ASC 1,OI .177 OCT 177 .9872 DEC 9872 M7 DEC -7 PART1 ASC 1,98 PART2 ASC 1,72 BUFAD NOP SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP IOCNT NOP TEMP BSS 2 MYCNT BSS 1 * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .32 DEC 32 .40 DEC 40 .5 OCT 5 INX DEF INTX1 .17 DEC 17 .21 DEC 21 .7 DEC 7 .137 OCT 137 TERM NOP DF7 DEF .7 .600 OCT 6000 PR ASC 1,PR .11 DEC 11 SZMM DEC 0. DEC 0. .400 DEC 400. MACHINE LENGTH IN MM .285 DEC 285. MACHINE HEIGHT IN MM DF8 DEF .8 .8 DEC 8 DVCLR DEF .0 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 COMA OCT 54 GCBCD NOP DF4 DEF .4 DF1 DEF .1 DF3 DEF .3 DF2 DEF .2 ADCNT NOP IBYTE NOP LNTH NOP SKPBK NOP .6 DEC 6 OP ASC 1,OP D40 DEC 40.0 DEC 40. END eHFBBH x 92840-18087 1913 S C0122 &DCT03 7245A COMMAND TABLE SOURCE            H0101 EASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT03 -- 7245A DEVICE COMMAND TABLE * SOURCE: 92840-18087 * RELOC: 92840-16006 * * * ************************************************************* * NAM DCT03,7 92840-16006 REV.1913 790123 ENT DCT03 * EXT EXEC,TAN,COS,SIN,FLOAT EXT INDCK,INTX,GCBIM,BYTE EXT CONVT,FLTAS EXT LNGTH,GIC,DCTAD EXT .IENT EXT REIO * THIS IS THE DEVICE COMMAND AND EMULATOR MODULE FOR THE * 7245 PLOTTER/PRINTER. * DCT03 NOP DEF EML03 DEF RESET RESET DEVICE DEF DEFLT DEF PAGE FORM FEED NOP DEF HOME HOME PEN DEC -23 GET DEVICE ID NOP GET CAPABILITIES (NOT USED) DEF PLTUN GET PLOT UNITS P1 AND P2 OCT -1 GET CHARACTER SPACE SIZE INFORMATION DEF PNLOC GET PEN LOCATION DEF CRLOC GET CURSOR LOCATION OCT -2 DIGITIZE DEF LORG SET LABEL ORIGIN OCT -3 LABEL DIRECTION OCT -4 SLANT ON DEF SLOFF SLANT OFF OCT -5 SET CHARACTER SIZE OCT -6 SET RELATIVE ORIGIN(PORG) NOP SET PLOT DIRECTION NOP SET SCALE NOP SET ORIGIN = CURSOR NOP SET ORIGIN = PEN NOP DRAW TO CURSOR NOP SELECT CHARACTER SET NOP SELECT PEN 0 NOP SELECT PEN -1 (ERASE) NOP SELECT PEN -2(COMPLEMENT) DEC -9 DEC -8 GET NUMBER OF PENS NOP  DEFINE LINE TYPE(NOT USED) DEC -9 SELECT DEFAULT LINE TYPE DEC -9 DEFAULE LINE TYPE WITH LENGTH DEF PENUP PEN UP DEF PENDN PEN DOWN DEF PLTAB PLOT ABSOLUTE DEC -10 PLOT RELATIVE DEF PLTIN PLOT INCREMENTAL DEF SHTLB SHORT LABEL DEF STLAB START LONG LABEL DEF STPLB STOP LONG LABEL MODE DEC -11 FLOAT TO ASCII DEC -12 SURFACE SIZE IN MM DEF POSCR POSITION CURSOR NOP POSITION CURSOR RELATIVE DEC -22 SET P1,P2 DEF GTMUM GET MU/MM DEC -13 GET DEVICE CLEARING CHARACTERISTICS DEC -14 NUMBER OF PHYSICALLY DIFFERENT PENS DEC -18 NUMBER OF CURSORS DEC -15 LORG-ABILITY DEC -16 MAXIMUM CHARACTER SLANT DEC -17 DEVICE HARD CLIPPING CAPABILITY DEC -24 INQUIRE CHARACTER PLACEMENT DEC -19 DEC -20 DEC -21 * * ASCII COMMAND STRINGS FIRST WORD = NUMBER OF BYTES * SECOND WORD = TERMINATOR RESET DEC -2 2 BYTES, WRITE DEF SEMCL ASC 1,DF COMMAND STRING * DEFLT DEC -5 DEF SEMCL ASC 3,IP;IW * PAGE DEC -2 DEF SEMCL PG ASC 1,PG * HOME DEC -14 DEF SEMCL ASC 7,PU;PA200,11000 * ID DEC 2 DEF SEMCL OI ASC 1,OI * PLTUN DEC 2 DEF SEMCL OP ASC 1,OP PNLOC DEC 2 DEF SEMCL ASC 1,OA * CRLOC DEC 2 DEF SEMCL ASC 1,RC * LORG DEC -2 DEF SEMCL ASC 1,LO * LNTYP DEC -2 DEF SEMCL ASC 1,LT * PENDN DEC -2 DEF SEMCL ASC 1,PD * PENUP DEC -2 DEF SEMCL ASC 1,PU * PLTAB DEC -2 DEF SEMCL PA ASC 1,PA * PLTIN DEC -2 PLOT INCREMENTAL DEF SEMCL ASC 1,PR * SELPN DEC -2 DEF SEMCL ASC 1,LT STLAB DEC -2 DEF HT ASC 1,LB STPLB DEC -1 DEF HT OCT 1400 DECIMAL 3 * SLOFF DEC -2 DEF SEMCL ASC 1,SL STP12 DEC -2 DEF SEMCL IW ASC 1,IW * SHTLB DEC -2 DEF HT LB ASC 1,LB * GTMUM DEC 2 DEF SEMCL ASC 1,OF * POSCR DEC -2 DEF SEMCL ASC 1,PC * HT OCT 137 SKP * * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL TERMINATOR STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE * JMP SETUP,I * * CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP STA GCBCD JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF GCBCD DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * * RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 tGCB DEF GCBCD DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FINI DOES THE FOLLOWING: * 1. CONVERTS INTEGERS TO ASCII * 2. TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3. RETURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP FIN,I * * SPC 3 SPC 3 * * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * BITE NOP * OUTPT NOP I/O TRANSFER ROUTINE CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT STB RW JSB REIO DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I * * SKP SPC 3 * * EMULATORS * EML03 NOP JSB SETUP GO GET IOBUF,IOBL,LUN AND FXD N LDA GIC CPA .177 JMP ERRCK LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA STA B LDA EM0 TOP OF LIST OF EMULATORS AND OTHER THINGS. JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE POINTER LDB LNGTH INB STB LNTH LDA A,I JMP A,I * EM0 DEF * DEF EMUL1 DEF EMUL2 DEF EMUL3 DEF EMUL4 DEF EMUL5 DEF EMUL6 DEF EMUL7 DEF EMUL8 DEF EMUL9 DEF EML10 DEF EML11 DEF EML12 DEF EML13 <DEF EML14 DEF EML15 DEF EML16 DEF EML17 DEF EML18 DEF EML19 DEF EML20 DEF EML21 DEF EML22 DEF EML23 DEF EML24 * SKP SPC 2 * * CHARACTER SPACING INFORMATION * EMUL1 LDA .7 JSB GB1 GET CURRENT CHARACTER SIZE LDA .16 JSB GB2 JMP EML03,I * * DEFAULT VALUES = WIDTH * 1.5 * 400 MU MM * HEIGHT * 2. * 400MU/MM * * CHRW DEC 81. CHRH DEC 324. CHW DEC -7400. DEC -11000. DEC 7400. DEC 11000. OCT 1 D1.5 DEC 1.5 D2.0 DEC 2.0 SPC 3 * RELATIVE PLOTTING (RPLOT(X,Y) * EML10 LDA .32 GET PORGX,PORGY * JSB GB1 * LDA INTX1 * STA PORGX * LDA INTX2 * STA PORGY * LDA .16 NOW GET NEW POINTS * JSB GB1 * LDA PORGX COMPUTE PORG(X,Y) + NEWPOINTS * ADA INTX2 * STA INTX2 * LDA PORGY * ADA INTX3 * STA INTX3 * LDA PA * JSB WRDST INSERT PLOT ABSOLUTE COMMAND INTO IOBUF * JSB FIN CONVERT VALUES TO ASCII AND OUTPUT * JMP EML03,I * SPC 3 * * FLOAT TO ASCII * EML11 LDA .3 ETX STA TERM LDA LB JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I * * * FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN F7.N DEF SKPBK RTGLD JMP GLIDE,I * * * * SPC 3 * * DIGITIZE * EMUL2 LDA DP DIGITIZE POINT -TURN ON ENTER LIGHT JSB PROUT EM4LP LDA OS OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF POINT LDB .1 JSB OUTPT HAS BEEN ENTERRED LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER5 LDA INTX1 AND .4 SZA JMP GETPT BIT 2 IS SET GO GET POINT JMP EM4LP CONTINUE LOOPING UNTIL WHATS -ITS ENTERS POINT GETPT LDA OD OUTPUT DIGITIZED POINT JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG LDA .16 JSB GB2 JMP EML03,I * PROUT NOP OUTPUT ASCII COMMAND IN THE A REGISTER JSB WRDST STORE WORD IN IOBUF JSB TRBYT LDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT JMP PROUT,I * * ASCII COMMANDS * OD ASC 1,OD OS ASC 1,OS DP ASC 1,DP * * NUMBER OF PENS SIMULATED OR OTHERWISE * EMUL8 LDA .6 SIMULATED PENS (LINE TYPES) STA INTX1 LDA .16 JSB GB2 JMP EML03,I ** * LABEL DIRECTION * GICB = DEGREES- 9872 WANTS RUN,RISE * * EMUL3 LDA .3 STA FXDN SET UP FOR FLOAT TO ASCII CONVERSION LDA DI ABSOLUTE DIRECTION JSB WRDST LDA .16 JSB GB1 GO GET THETA DLD INTX2 DST INTX4 SAVE FOR RISE COMPUTATION JSB COS COMPUTE RUN NOP DST INTX2 EML71 JSB GLIDE CONVERT TO FLOATING POINT LDA COMA JSB PTBYT DLD INTX4 JSB SIN NOP COMPUTE RISE DST INTX2 EML72 JSB GLIDE JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I SPC 3 * * CHARACTER SLANT * EMUL4 LDA .3 STA FXDN SET UP FOR 3 CHARACTER TO RIGHT OF . LDA SL SLANT MNEMONIC JSB WRDST LDA .16 JSB GB1 GET ANGLE DLD INTX2 JSB TAN COMPUTE TAN(THETA) NOP DST INTX2 JSB GLIDE FLOAT TO ASCII JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I * SL ASC 1,SL * * CHARACTER SIZE& * GICB = WIDTH/HEIGHT * EMUL5 LDA .3 STA FXDN LDA .16 JSB GB1 DLD INTX4 GET HEIGHT AND SAVE DST TEMP LDA SI JSB WRDST DLD INTX2 WIDTH FDV CSIZW MU/CM/MU DST INTX2 JSB GLIDE LDA COMA JSB PTBYT DLD TEMP FDV CSIZH DST INTX2 JSB GLIDE JSB TRBYT LDB .2 LDA NBYTE JSB OUTPT JMP EML03,I * CSIZW DEC 600. MU/CM CSIZH DEC 800. SI ASC 1,SI * * LINE TYPES - GICB = LT#, * EMUL9 LDA .3 STA FXDN LDA .16 JSB GB1 GET DATA FROM GCB LDA LT LINE TYPE COMMAND JSB WRDST LDA INTX2 LT = 0 FOR SOLID SZA,RSS JMP FIN11 ADA LT0 GET LINE TYPE EQUIVALENCE FOR 9872 LDA A,I JSB PTBYT LDA LNGTH IS THERE A LENGTH SPECIFICATION CPA .1 JMP FIN12 FIN10 LDA INTX2 CPA .5 JMP FIN11 LDA INTX2 IOR .1 ADA PCLT0 STA TEMP ADDRESS OF PERCENT DIVIDER DLD INTX3 FDV TEMP,I DST INTX2 LDA COMA JSB PTBYT JSB GLIDE FLOAT TO ASCII FIN11 JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I FIN12 LDA INTX2 IS LT = 1(DIM) CPA .1 JMP *+2 YES JMP FIN14 DLD D22 DST INTX3 JMP FIN10 CONTINUE * FIN14 LDA COMA JSB PTBYT SET DEFAULT LINE TYPE LENGTH BACK TO 4% LDA ASC4 JSB PTBYT JMP FIN11 * * LINE TYPES AND PERCENT VALUES * LT ASC 1,LT DI ASC 1,DI LT0 DEF * LT1 OCT 61 LT2 OCT 62 LT3 OCT 63 LT4 OCT 65 LT5 OCT 60 LT6 OCT 66 * * 1% VALUES OF LINE TYPE LENGTHS * PCLT0 DEF * PCLT1 DEC 45. DEC 60. DEC 135. DEC 180. BSS 2 DEC 180. * ASC4 OCT 64 D22 DEC 22.5 SPC 3 * GET DISPLAY SIZE IN MM * EML1K!2 LDA SIZMM LENGTH LDB DF8 JSB GB JMP EML03,I * SIZMM DEF SZMM * SPC 3 * * * SET RELATIVE ORIGIN * EMUL6 LDA .16 * JSB GB1 * LDA .32 IOSAV * JSB GB2 * JMP EML03,I SPC 2 * * ERASE PAGE ADVANCE * EMUL7 LDA PG JSB WRDST LDA ONE JSB WRDST LDB .2 LDA .4 JSB OUTPT JMP EML03,I * ONE OCT 30473 * DEVICE CLEARING CAPABILITY * EML13 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EML03,I * SPC 2 * PHYSICAL PENS * EML14 LDA DF1 LDB DF1 JSB GB JMP EML03,I * SPC 2 * * LORGABILITY * EML15 JMP EML14 SPC 2 * * MAX. CHAR SLANT * EML16 LDA CHSLT LDB DF4 JSB GB JMP EML03,I * SPC 2 * * DEVICE HARD CLIPPING CAPABILITY * EML17 JMP EML14 * EML18 LDA DF0 LDB DF1 JSB GB JMP EML03,I * * MIN/MAX CHARACTER SIZES * EML19 LDA DFCHR LDB DF9 JSB GB JMP EML03,I * .9 DEC 9 DF9 DEF .9 DFCHR DEF CHW * * LABEL DIRECTION INFORMATION * EML20 LDA LBLDR LDB DF3 JSB GB JMP EML03,I * LBLDR DEF *+1 OCT 2 DEC 0. SPC 2 * * LORG RANGE * EML21 LDA DFL1 LDB DF2 JSB GB JMP EML03,I * DFL1 DEF *+1 OCT 1 DEC 9 * * EML22 LDA .16 JSB GB1 GET G1,G2 LDA IP JSB WRDST JSB FIN CLA STA NBYTE LDA IOBUF STA ADCNT LDA IW JSB WRDST JSB FIN JMP EML03,I * IP ASC 1,IP * EML23 LDA IDCD LDB DF3 JSB GB JMP EML03,I * IDCD DEF .724A .724A ASC 3,7245A * * CHARACTER PLACEMENT * EML24 LDA ACINF LDB DF8 JSB GB JMP EML03,I * ACINF DEF CINFO * CINFO DEC 0.00000 DEC 0.66667 DEC 0.00000  DEC 0.50000 SKP * * * ERROR CHECKING * ERRCK JSB EXEC SELECT DEVICE CLEAR DEF *+3 DEF .3 DEF LUN * LDA OE JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OI SEN OUT ID AND SEE IF IT FLIES JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OE JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 NOW EXAMINE STATUS WORD LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER LDA INTX1 CHECK BIT 1 AND .1 SZA,RSS JMP LAST1 LAST CHECK FOR DEVICE ERRPT LDA .3 JMP EML03,I * LAST1 CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OI JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT * LDA IOB STA BUFAD DLD BUFAD,I CPA PART1 JMP CHEK2 JMP ERR3 CHEK2 CPB PART2 JMP OKAY ERR3 LDA .3 JMP EML03,I OKAY LDA .7245 JMP EML03,I * PART1 ASC 1,72 PART2 ASC 1,45 BUFAD NOP * OE ASC 1,OE .7245 DEC 7245 SKP GB NOP STA ADDR ADDRESS OF DATA STB NUM NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 DEF .1 ADDR NOP NUM NOP DEF .2 JMP GB,I * * STORE A WORD INTO THE IOBUF * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE JMP WRDST,I SKP SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP IN<:6TX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP IOCNT NOP TEMP BSS 2 * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .32 DEC 32 .3 OCT 3 SEMCL OCT 73 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX1 DEF INTX4 INX DEF INTX1 .7 DEC 7 TERM NOP DF3 DEF .3 .600 OCT 6000 SZMM DEC 5. 200 * .025 DEC 5. -32,727* .025 DEC 180. .819 DEC 270. MACHINE HEIGHT IN MM (32767 * .025) DVCLR DEF .2 DF8 DEF .8 .8 DEC 8 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 .03 OCT 1400 COMA OCT 54 M7 OCT -7 .177 OCT 177 GCBCD NOP DF4 DEF .4 DF2 DEF .2 DF1 DEF .1 DF0 DEF .0 ADCNT NOP IBYTE NOP LNTH NOP SKPBK NOP M1 OCT -1 .6 DEC 6 .13 DEC 13 END ]< y 92840-18088 1913 S C0122 &DVG07 9874A DEVICE SUBRT. SRCE             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DVG07 -- 9874A DEVICE SUBROUTINE * SOURCE: 92840-18088 * RELOC: 92840-16007 * * * ************************************************************* * NAM DVG07,7 92840-16007 REV. 1913 790123 EXT EXEC,GCBIM,BYTE EXT .IENT EXT FLOAT EXT EMULX EXT INDCK EXT INTX EXT DCTIM EXT CONVT EXT LNGTH,GIC,DCTAD EXT GRSTS EXT REIO ENT DVG07 * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 9872A HARD COPY * PLOTTER, THE HP 7245A PLOTTER PRINTER, AND THE 9874A * DIGITIZER. THIS ROUTINE ALONG WITH DVR37 CONTROLS THE * DEVICES. * DVG07 NOP CLA INITIALIZE THE READ/WRITE FLAG AND BYTE COUNTER STA RWFLG COUNTER STA FIN STA NBYTE STA IBYTE LDA SEMCL SEMICOLON - TERMINATOR STA TERM JSB DCTIM FILL UP GIC, LENGTH AND DEVICE COMMAND LDA GIC ADDRESS (DCTAD) SKP CPA .177 JMP ERRCK JSB SETUP CONT LDA DCTAD SEE WHAT TYPE OF COMMAND THIS IS SSA EMULATOR? JMP EMULT YES SZA,RSS A NOP? JMP DVG07,I DO NOTHING A'TALL AND RETURN LDB DCTAD A COMMAND ADDRESS LDA B,I SSA,RSS READ OR WRITE? JMP CONT0 READ ISZ RWFLG WRITE CMA,INA SET BYTE COUNT POSITIVE CONT0 STA NBYTE AND .1 COMPUTE NWORD = NBYTE/2 + REMAINDER STA NWORD STA ODFLG = 0 IF EVEN, AND 1 IF ODD LDA NBYTE CLE,ERA NBYTE/2 ADA NWORD CMA,INA STA NWORD INB LDA B,I LDA A,I TERMINATOR STA TERM INB LDA B,I STA FIRST SAVE FIRST WORD OF COMMAND STRING STB DCTAD NOW POINT TO FIRST WORD OF COMMAND STG XFER LDA DCTAD,I NOW TRANSFER COMMAND STG TO THE I/O BUFF STA ADCNT,I ISZ NWORD JMP CONT2 JMP XEND FINISHED CONT2 ISZ DCTAD ISZ ADCNT INCREMENT ADDRESS POINTERS JMP XFER CONTINUE XEND LDA ODFLG SZA,RSS ISZ ADCNT LDA RWFLG READ OR WRITE? SZA,RSS JMP READ LDA LNGTH WRITE - SEE IF ANY INTS TO CONVERT TO ASC SZA THIS IS LENGTH FROM GICB JMP CNVRT YES GO CONVERT TO ASCII JSB TRBYT GO INSERT TERMINATOR LDA NBYTE NUMBER OF BYTES LDB .2 WRITE JSB OUTPT EXEC I/O JMP DVG07,I GO HOME BABY SKP * * * * PROCESS READ REQUEST. FIRST A WRITE MUST BE DONE TO * OUTPUT THE COMMAND CODE, AND THEN A READ MUST BE DONE TO * THE DEVICE INTO THE TALK MODE TO GET THE STATUS DATA. * READ NOP JSB TRBYT FIRST INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT OUTPUT STATUS REQUEST COMMAND LDA M19 FILL BUFFER WITH BLANKS STA CNTR LDA IOBUF STA BACNT SPC 1 BLOOP LDA BLNK STA BACNT,I ISZ BACNT ISZ CNTR JMP BLOOP SPC 1 LDB .1 NOW PUT DEVICE INTO TALK MODE LDA .40 TO GET DATA JSB OUTPT JSB INTEG GO CONVERT FROM ASCII TO INTEGER JSB GB2 TRANSFER RESULTS TO GICB JMP DVG07,I SPC 1 CNVRT LDA LNGTH INA STA LNTH JSB GB1 RETRIVE INTEGER VALUES JMP FINI SKP * * SPECIAL INTERNAL UTILITY ROUTINES * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB  DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO * * NOW CHECK BIT 4 OF STATUS WORD TO SEE IF A SHORT LABEL WAS * PREVIOUSLY EMITTED - IF SO EMIT LABEL TERMINATOR AND RESET BIT 4 * JSB GRSTS DEF *+4 DEF .1 DEF BIT4 DEF TEMP LDA TEMP SZA,RSS BIT SET? JMP SETUP,I NO JSB GRSTS RESET BIT 4 DEF *+4 DEF .2 DEF MASK4 DEF .0 CLA STA NBYTE LDA IOBUF STA ADCNT JMP SETUP,I * * CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CPA OF JMP FIXIT CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE SKP * * TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF .16 DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * * RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF .16 GICB DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGBd1 JMP GB1,I * * FINI DOES THE FOLLOWING: * 1. CONVERTS INTEGERS TO ASCII * 2. TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3. RETURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT LDA FIN SZA,RSS JMP DVG07,I JMP FIN,I SKP * * EXIT DVG07 AND SET MODE TO LABEL IF NOT ALREADY SET * * * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * BITE NOP * OUTPT NOP I/O TRANSFER ROUTINE STB RW LDB TERM CPB .137 JMP *+2 INA CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT LDA .137 JSB PTBYT SUPRESS CRLF JSB REIO DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I SKP ERRCK JSB SETUP * JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF LUN THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BIT HERE * JMP ITSNT IT AIN'T EVEN AN LU !!!! LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD LDB A AND SAVE IT LDA ZTEMP GET THE SUBCHANNEL BITS AND M37 STA ZTEMP ADA B CO-NFIGURE B REGISTER RETURN WORD STA DTYPE CPB M1740 IF DVR 05 THEN JMP ERR1 DO ONE MORE CHECK FOR SUB CHANNEL ITSNT LDA .5 JMP ERRPT ERR1 JSB EMULX,I NOW ASK DEVICE COMMAND TABLE ABOUT ITSELF CPA .9874 JMP ERR2 CPA .3 JMP ERR3 SOMETHING IS VERY WRONG CPA .5 JMP ERR3 LDA .3 JMP ERR3 ERR2 CLA ERR3 STA INTX1 LDA .1 STA LNGTH JSB GB2 LDA INTX1 SZA JMP DVG07,I JSB EXEC DEVICE CLEAR DEF *+3 DEF .3 DEF LUN JMP DVG07,I ERRPT LDA .5 JMP ERR3 SKP .9872 DEC 9872 .7245 DEC 7245 .9874 DEC 9874 .177 OCT 177 * * D13I OCT 100015 M1740 OCT 17400 M37 OCT 37 MEQT OCT 37400 ANLU# NOP DTYPE NOP YTEMP NOP ZTEMP NOP * * EMULT JSB EMULX,I JMP DVG07,I A EQU 0 B EQU 1 NBYTE NOP NWORD NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP INTXX BSS 8 RW NOP IOCNT NOP * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .3 OCT 3 .16 DEC 16 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX DEF INTX1 INX1 DEF INTX4 .21 DEC 21 .7 DEC 7 TERM NOP ETX OCT 1400 BIT4 OCT 20 TEMP NOP MASK4 OCT 77757 SEMCL OCT 73 DF7 DEF .7 .600 OCT 6000 .137 OCT 137 ADCNT NOP IBYTE NOP RWFLG NOP ODFLG NOP LNTH NOP SKPBK NOP OP ASC 1,OP OF ASC 1,OF M19 DEC -19 BACNT NOP CNTR NOP BLNK OCT 20040 END  z 92840-18089 1913 S C0122 &DCT07 9874A CMND TBLE SRC             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT07 -- 9874A DEVICE COMMAND TABLE * SOURCE: 92840-18089 * RELOC: 92840-16007 * * * ************************************************************* * NAM DCT07,7 92840-16007 REV. 1913 790123 ENT DCT07 * EXT EXEC,FLOAT EXT INDCK,INTX,GCBIM,BYTE EXT CONVT,FLTAS EXT LNGTH,GIC,DCTAD EXT REIO * * THIS IS THE DEVICE COMMAND AND EMULATOR MODULE FOR THE * 9874A DIGITIZER. * DCT07 NOP DEF EML07 DEF RESET RESET DEVICE DEF DEFLT DEFAULT NOP FORM FEED NOP NOP HOME PEN DEC -1 GET DEVICE ID NOP GET CAPABILITIES DEF PLTUN GET PLOT UNITS P1 AND P2 NOP GET CHARACTER SPACE SIZE INFORMATION DEF CRLOC GET PEN LOCATION DEF CRLOC GET CURSOR LOCATION OCT -2 DIGITIZE NOP SET LABEL ORIGIN NOP SET LABEL DIRECTION NOP SLANT ON NOP SLANT OFF NOP SET CHARACTER SIZE NOP SET RELATIVEW ORIGIN (PORG) NOP SET PLOT DIRECTION NOP SET SCALE SKP NOP SET ORIGIN = CURSOR NOP SET ORIGIN = PEN NOP DRAW TO CURSOR NOP SELECT CHARACTER SIZE NOP SELECT PEN 0 NOP SELECT PEN -1 (ERASE) NOP SELECT PEN -2 (COMPLEMENT) NOP LINE TYPE NOP GET NUMBER OF PENS NOP DEFINE LINE TYPE NOP SELECT DEFAULT LINE TYPE NOP DEFAULT LINE TYPE WITH LENGTH NOP PEN UP NOP PEN DOWN NOP PLOT ABSOLUTE NOP PLOT RELATIVE NOP PLOT INCREMENTAL NOP SHORT LABEL NOP START LONG LABEL NOP STOP LONG LABEL MODE DEC -3 FLOAT TO ASCII DEC -4 SURFACE SIZE IN MM NOP POSITION CURSOR NOP POSITION CURSOR RELATIVE DEC -5 SET P1,P2 DEF GTMUM GET MU/MM DEC -6 GET DEVICE CLEARING CHARACTERISTICS NOP NUMBER OF PHYSICALLY DIFFERENT PENS NOP NUMBER OFC CURSORS NOP LORGABILITY NOP MAXIMUM CHARACTER SLANT DEC -7 DEVICE HARD CLIPPING CAPABILITY DEC -8 INQUIRE CHARACTER PLACEMENT NOP NOP NOP SKP * * ASCII COMMAND STRINGS FIRST WORD = NUMBER OF BYTES * SECOND WORD = TERMINATOR * RESET DEC -5 5 BYTES, WRITE DEF SEMCL ASC 3,DF;SG COMMAND STRING * DEFLT DEC -20 DEF SEMCL ASC 10,IP0,0,17500,12600;IW * PLTUN DEC 2 DEF SEMCL OP ASC 1,OP * CRLOC DEC 2 DEF SEMCL ASC 1,OC * GTMUM DEC 2 DEF SEMCL ASC 1,OF SKP * * SETUP * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL TERMINATOR STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE RTSET JMP SETUP,I * * INTE:G -- CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE RTING JMP INTEG,I SKP * * FIXIT * FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * GB2 -- TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND * TRANSFER THIS DATA TO GICB. * GB2 NOP STA GCBCD JSB GCBIM TRANSFER DATA TO AGL DEF RTGB2 DEF GCBCD DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTGB2 JMP GB2,I * * GB1 -- RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO * INTX1(LNTH) * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF GCBCD DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FIN -- 1) CONVERTS INTEGERS TO ASCII * 2) TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3) RETURNS TO CALLER * FIN NOP JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT RTFIN JMP FIN,I SKP * * TRBYT * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT RTTBT JMP TRBYT,I * * PTBYT * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE RTPBT JMP PTBYT,I * BITE NOP * * UPDTE * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT RTUDT JMP UPDTE,I * * OUTPT * OUTPT NOP I/O TRANSFER ROUTINE STB RW LDB TERM CPB .137 CHECK IF SUPRESS CRLF ALREADY HERE JMP *+2 YES, DONT INCREMENT CONUT INA GOING TO ADD SUPRESS CMA,INA STA IOCNT COUNT OF TRANSFER IN CHARACTERS LDA .137 NEED SUPRESS JSB PTBYT STORE IT JSB REIO DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I SKP * * EMULATORS * EML07 NOP JSB SETUP GO GET IOBUF,IOBL,LUN AND FXD N LDA GIC CPA .177 JMP ERRCK LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA STA B LDA EM0 TOP OF LIST OF EMULATORS AND OTHER THINGS. JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE POINTER LDB LNGTH INB STB LNTH LDA A,I JMP A,I * * EM0 DEF * DEF EMUL1 DEF EMUL2 DEF EMUL3 DEF EMUL4 DEF EMUL5 DEF EMUL6 DEF EMUL7 DEF EMUL8 * * EMULATOR #1 -- GET DEVICE ID * EMUL1 LDA IDCD LDB DF3 JSB GB JMP EML07,I * IDCD DEF .984A .984A ASC 3,9874A SKP * * EMULATOR #2 -- DIGITIZE * EMUL2 NOP EM4LP LDA OS OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF POINT LDB .1 JSB OUTPT HAS BEEN ENTERRED LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER LDA INTX1 AND .4 SZA JMP GETPT BIT 2 IS SET GO GET POINT JMP EM4LP CONTINUE LOOPING UNTIL WHATS -ITS ENTERS POINT GETPT LDA OD OUTPUT DIGITIZED POINT JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .4 STA LNGTH JSB INTEG LDA .3 RESET LENGTH TO EXPECTED 3 PARAMETERS STA LNGTH LDA .16 JSB GB2 JMP EML07,I * * PROUT * PROUT NOP JSB WRDST JSB TRBYT LDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT RTPRO JMP PROUT,I * OD ASC 1,OD OS ASC 1,OS SKP * * EMULATOR #3 -- FLOAT TO ASCII * EMUL3 LDA .3 ETX STA TERM LDA LB JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT JSB NBYTE LDB .2 JSB OUTPT JMP EML07,I LB ASC 1,LB * * GLIDE -- FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN F7.N DEF SKPBK RTGLD JMP GLIDE,I * * EMULATOR #4 -- GET DISPLAY SIZE IN MM * EMUL4 LDA SIZMM LENGTH LDB DF8 JSB GB JMP EML07,I * SIZMM DEF SZMM * * EMULATOR #5 -- SET P1,P2 * EMUL5 LDA .16 JSB GB1 GET G1,G2 LDA IP JSB WRDST JSB FIN JMP EML07,I * IP ASC 1,IP SKP * * EMULATOR #6 -- DEVICE CLEARING CAPABILITY * EMUL6 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EML07,I * * EMULATOR #7 -- DEVICE HARD CLIPPING CAPABILITY * EMUL7 LDA DF1 LDB DF1 JSB GB JMP EML07,I * * EMULTOR #8 -- CHARACTER PLACEMENT * EMUL8 LDA ACINF LDB DF8 JSB GB JMP EML07,I * ACINF DEF CINFO * CINFO DEC 0.00000 DEC 0.00000 DEC 0.00000 DEC 0.00000 SKP * * ERROR CHECKING * ERRCK JSB EXEC SELECT DEVICE CLEAR DEF *+3 DEF .3 DEF LUN * LDA OE CLEAR OUT PENDING ERoROR JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OI SEND OUT ID AND SEE IF IT FLIES JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OE JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 NOW EXAMINE STATUS WORD LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER LDA INTX1 CHECK BIT 1 AND .1 SZA JMP ERRPT GOT PROBLEMS CLA STA NBYTE REINITIALIZE BYTE COUNT LDA IOBUF STA ADCNT REINITIALIZE ADDR CTR TO TOP OF BUFFER SKP * LDA OI JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG LDA INTX1 JMP EML07,I ERRPT LDA .3 JMP EML07,I * OE ASC 1,OE OI ASC 1,OI * * GB * GB NOP STA ADDR ADDRESS OF DATA STB NUM NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 DEF .1 ADDR NOP NUM NOP DEF .2 RTGB JMP GB,I * * WRDST -- STORE A WORD INTO THE IOBUF * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE RTWRD JMP WRDST,I SKP * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP IOCNT NOP TEMP BSS 2 * * DO NOT CHANGE POSITION OF THESE CONSTANTS * .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .3M*($2 DEC 32 .3 OCT 3 SEMCL OCT 73 .137 OCT 137 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX1 DEF INTX4 INX DEF INTX1 .7 DEC 7 TERM NOP DF3 DEF .3 .600 OCT 6000 SZMM DEC 0. ORIGIN 0.,0. DEC 0. DEC 435. UPPER RIGHT 435.,315. .315 DEC 315. DVCLR DEF .2 DF8 DEF .8 .8 DEC 8 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 .03 OCT 1400 COMA OCT 54 M7 OCT -7 .177 OCT 177 GCBCD NOP DF4 DEF .4 DF2 DEF .2 DF1 DEF .1 DF0 DEF .0 ADCNT NOP IBYTE NOP LNTH NOP SKPBK NOP M1 OCT -1 .6 DEC 6 .13 DEC 13 END 'p* { 92840-18090 2013 S C0122 &DVG06              H0101 ijASMB,R,Q,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DVG06 -- 1350A DEVICE SUBROUTINE * SOURCE: 92840 - 18090 * RELOC: 92840 - 16008 * PGMR: DJS * * MODIFIED BY DJS 1/27/80 * - MOVED 1350 INITIALIZATION SEQUENCE FROM * DCT06 TO DVG06 --- * ************************************************************* * NAM DVG06,7 92840-16008 REV.2013 800127 EXT EXEC,GCBIM,BYTE EXT EMULX EXT INDCK EXT DCTIM EXT CONVT EXT LNGTH,GIC,DCTAD EXT GRSTS EXT REIO * ENT DVG06 HP 1310 CRT ENT DVG16 HP 1311 CRT ENT DVG26 HP 1317 CRT ENT DVG36 HP 1321 CRT * **************************************************************** * * * >>>>>> 1350A DEVICE SUBROUTINE <<<<<<<< * * * * THE 1350A IS CURRENTLY SUPPORTED WITH 4 DIFFERENT CRT'S. * * THE CRT'S AND THEIR DEVICE SUBROUTINE ENTRY POINT ARE: * * * * HP 1310 DVG06 * * HP 1311 DVG16 * * HP 1317 DVG26 * * HP 1321 DVG36 * * * **************************************************************** HED 1350A DEVICE SUBROUTINE DVG06 NOP +m HP 1310A CRT = CRT #0 CLA JMP SVCRT * DVG16 NOP HP 1311A CRT = CRT #1 LDA .1 JMP SVCRT * DVG26 NOP HP 1317A CRT = CRT #2 LDA .2 JMP SVCRT * DVG36 NOP HP 1321A CRT = CRT #3 LDA .3 * SVCRT STA CRT# SAVE THE CRT # CLA STA BUFLG CLEAR THE BUFFER FLAG STA NBYTE SET # BYTES IN BUFFER TO 0 JSB DCTIM FILL UP GIC, LENGTH AND DEVICE COMMAND ADDR.(DCTAD) LDA GIC GET THE GIC CPA .177 IS THIS THE ERROR CHECK GIC? JMP ERRCK YEP! CHECK IT OUT * JSB SETUP NOPE! SET EVERYTHING UP LDA DCTAD SEE WHAT TYPE OF COMMAND THIS IS SSA EMULATOR? JMP EMULT YES * SZA,RSS A NOP? JMP DV6RT YEP! DO NOTHING AND RETURN * LDB DCTAD A COMMAND ADDRESS LDA B,I B HAS THE # OF BYTES IN THE COMMAND STRING CMA,INA SET BYTE COUNT POSITIVE * * COMPUTE # OF WORDS IN THE COMMAND STRING * STA NBYTE SAVE # BYTES AND .1 COMPUTE NWORD = NBYTE/2 + REMAINDER STA ODFLG = 0 IF EVEN, AND 1 IF ODD LDA NBYTE CLE,ERA NBYTE/2 ADA ODFLG ADD ON THE EXTRA BYTE CMA,INA MAKE IT NEGATIVE STA NWORD AND SAVE IT FOR THE TRANSFER COUNTER * INB LDA B,I LDA A,I GET THE COMMAND STRING TERMINATOR STA TERM AND SAVE IT FOR LATER INB STB DCTAD NOW POINT TO FIRST WORD OF COMMAND STRING * * TRANSFER THE COMMAND STRING TO THE I/O BUFFER * XFER LDA DCTAD,I GET THE NEXT WORD IN THE COMMAND STRING STA ADCNT,I STUFF IT IN THE I/O BUFFER ISZ NWORD TRANSFERRED ALL OF THE WORDS? JMP XFER1 NOT YET! GO UPDATE POINTERS * JMP XEND YEP! * XFER1 ISZ DCTAD INCREMENT COMMAND STRING POINTER ISZ ADCNT INCREMENT I/O BUFFER POINTER JMP XFER GO TRANS>FER ANOTHER WORD * * * XEND LDA ODFLG GET EXTRA BYTE FLAG SZA,RSS WAS THERE AN EXTRA BYTE? ISZ ADCNT YEP! BUMP UP THE I/O BUFFER POINTER LDA BUFLG GET THE BUFFER FLAG SZA,RSS ARE WE CURRENTLY BUFFERING PLOT ABSOLUTES? JMP CONT0 NOPE! * LDA BUFLN GET THE PREVIOUS # OF BYTES IN THE BUFFER ADA NBYTE ADD IT TO THE # OF BYTES WE JUST PUT IN STA NBYTE AND SAVE IT CONT0 LDA LNGTH GET LENGTH OF ANY INFO IN THE GICB(END POINTS) SZA,RSS IS THERE ANY DATA FOR US IN THE GICB? JMP CONT3 NOPE! MOVE ON * INA YEP! IT MUST BE ENDPOINTS STA LNTH JSB GB1 GO TRANSFER THE GICB TO INTX1 THRU INTX1+LNTH DLD INTX2 GET THE ENDPOINTS DST PX UPDATE THE PEN POSITION JSB CONVT GO CONVERT THE ENDPOINTS TO ASCII WITH A COMMA DEF CONT3 SEPERATING THEM DEF INTX2 STARTING ADDRESS OF THE ENDPOINTS DEF IOBUF,I PUT THE ASCII RESULTS IN THE I/O BUFFER DEF NBYTE WITH THIS OFFSET DEF LNGTH # OF NUMBERS TO CONVERT (2) * CONT3 JSB TRBYT STICK THE TERMINATOR IN THE I/O BUFFER LDA GIC GET THE GIC CPA .5 IS IT A HOME PEN? JMP SAV00 YEP! SAVE THE ORIGIN * JMP CONT4 NOPE! MOVE ON * SAV00 CLA SAVE (0,0) STA PX IN PX STA PY AND PY CONT4 LDA BUFLG GET THE BUFFERING FLAG SZA,RSS ARE WE BUFFERING THIS TIME (PLOT ABSOLUTE)? JMP OUTIT NOPE! DUMP THE BUFFER * LDA LNGTH GET THE LENGTH (PLOT ABSOLUTE FLAG) SZA,RSS IS THIS A PLOT ABSOLUTE JMP CONT5 NOPE! MOVE ON * LDA CR YEP! GET THE PA TERMINATOR JSB PTBYT AND STUFF IT IN THE I/O BUFFER * CONT5 LDA NBYTE GET THE TOTAL # OF BYTES IN THE BUFFER STA BUFLN AND SAVE IT SO IT CAN BE PUT IN THE SAVE \7AREA JMP DV6EX GO WRITE OUT THE SAVE AREA * OUTIT LDA NBYTE GET THE # OF BYTES IN THE BUFFER JSB OUTPT OUTPUT THE BUFFER TO THE 1350 JMP DV6EX GO HOME BABY SKP ************************************************************* * * * SPECIAL INTERNAL UTILITY ROUTINES * * * ************************************************************* * * ******************************************************** * SETUP: GET THE NECESSARY WORKING VARIABLES FOR * * DEVICE SUBROUTINE. IF BUFFERING IS BEING * * USED IT WILL BE HANDLED HERE. * ******************************************************** * SETUP NOP JSB GCBIM GO GET THE DEVICE SAVE AREA DEF CKBUF RETURN DEF .32 DEVICE SAVE AREA POINTER IN THE GCB DEF .1 1 POINTER DEF BUFLN STARTING ADDRESS OF THE SAVE AREA DESTINATION DEF .7 WE ONLY WANT 7 WORDS OF THE SAVE AREA DEF .1 READ IT * CKBUF LDA IOFLG GET BUFFERING FLAG (0 = NO BUFFERING) SZA ARE WE BUFFERING (PLOTR(4))? JMP GOTSV YEP! GO GET THE ADDRESS OF THE USER'S BUFFER * LDA ADBUF NOPE! NEED THE ADDRESS OF THE LOCAL I/O BUFFER JMP BUFI GO MAKE IT CLEAN * GOTSV LDA IOBUF GET THE ADDRESS OF THE USER'S BUFFER BUFI JSB INDCK MAKE IT CLEAN STA IOBUF SHOVE IT BACK IN STA IOB PUT IT HERE FOR OUTPT STA ADCNT INITIALIZE THE WORKING BUFFER ADDRESS POINTER * JSB GRSTS GO SEE IF WE'RE IN LABEL MODE DEF *+4 RETURN DEF .1 READ STATUS WORD DEF BIT4 LABEL MODE MASK DEF TEMP MASKED STATUS WORD * LDA TEMP GET THE MASKED STATUS WORD SZA,RSS LABEL MODE? JMP BUFCK NOPE! GO SEE IF WE'RE BUFFFERING * LDA ETX YEP! GET THE TEXT TERMINATOR STA ADCNT,I STUFF IT IN THE I/O BUFFER LDA .1 WE ONLY HAVE 1 BYTE JSB OUTPT GO FEED IT TO THE 1350 JSB GRSTS RESET TEXT MODE BIT DEF *+4 RETURN DEF .2 WRITE DEF MASK4 LABEL MODE MASK DEF .0 THIS TURNS THE BIT OFF * * BUFCK LDA IOFLG GET THE I/O FLAG SZA,RSS BUFFERING OPTION? JMP SETUP,I NOPE! EXIT SETUP * * * THE FOLLOWING CODE IS ONLY EXECUTED IF THE BUFFERING * OPTION IS BEING USED (PLOTR(4)). * * LDA GIC SEE IF CURRENT COMMAND QUALIFIES AS ONE FOR BUFFERING CPA .33 PEN UP? JMP BF2 YEP! BUFFER IT * CPA .34 PEN DOWN? JMP BF2 YEP! BUFFER IT * CPA .35 PLOT ABSOLUTE? JMP BF2 YEP! BUFFER IT * JMP EMPCK NONE OF THE ABOVE. GO EMPTY BUFFER * BF2 ISZ BUFLG SET THE BUFFERING IN PROGRESS FLAG LDB BUFLN GET THE CURRENT BUFFER LENGTH * * CHECK FOR POSSIBLE BUFFER OVERFLOW * STB NBYTE SAVE IT IN THE WORKING BYTE COUNTER JSB UPDTE GO UPDATE THE WORKING ADDRESS COUNTER ADB .6 ADD ON MAXIMUM COMMAND LENGTH LDA LNGTH GET # ENDPOINTS (0 OR 2) SZA ANY ENDPOINTS TO SEND ADB .10 YEP! BETTER ADD ON MAX # CHARS POSSIBLE CLE,ERB CALCULATE CURRENT BUFFER LENGTH CMB,INB ADB IOBL MAXIMUM BUFFER LENGTH - CURRENT BUFFER LENGTH SSB POSSIBLE OVERFLOW? JMP EMPCK YEP! BE SAFE AND EMPTY THE BUFFER * LDA NBYTE GET # OF BYTES IN BUFFER AND .1 ON A FULL SZA,RSS WORD BOUNDARY? JMP SETUP,I YEP! GET BACK TO THE ACTION * LDA CR NOPE! STUFF AN JSB PTBYT EXTRA CR INTO THE BUFFER ISZ BUFLN AND UPDATE THE BUFFER LENGTH JMP SETUP,I GO SEE SOME AC+TION * * EMPTY BUFFER * EMPCK LDA BUFLN GET THE BUFFER LENGTH SZA,RSS IS ANYTHING THERE? JMP SETUP,I NOPE! NO NEED TO EMPTY IT * JSB OUTPT YEP! FEED IT TO THE 1350 CLA ZERO OUT STA BUFLN THE BUFFER LENGTH STA NBYTE AND THE # BYTES LDA DCTAD SSA IS THIS AN EMULATOR? JMP EMSAV YEP! DUMP THE SAVE AREA TO THE GCB * SZA,RSS IS IT A NOP? JMP EMSAV YEP! DUMP THE SAVE AREA TO THE GCB * LDA IOBUF INITIALIZE THE STA ADCNT WORKING BUFFER ADDRESS COUNTER JMP SETUP,I GET OUT OF HERE * EMSAV JSB SAVAR SEND THE SAVE AREA BACK TO THE GCB FOR LATER JMP SETUP,I GET OUT OF HERE SKP ******************************************************* * * * GB2: TRANSFER INTX1(1)... INTX1(LNGTH) TO THE GICB * * * ******************************************************* * GB2 NOP JSB GCBIM TRANSFER DATA TO THE GICB DEF RTX RETURN DEF .16 POINTER TO THE GICB DEF .1 1 POINTER DEF INTX1 STARTING ADDRESS OF DATA TO BE TRANSFERRED DEF LNGTH # OF WORDS TO TRNASFER DEF .2 WRITE IT RTX JMP GB2,I GO BACK TO WHERE WE WAS * ******************************************************* * * * GB1: TRANSFER THE GICB TO INTX1(1)...INTX1(LNTH) * * * ******************************************************* GB1 NOP JSB GCBIM RETRIEVE INTEGER VALUES FROM GICB DEF RTGB1 RETURN DEF .16 POINTER TO THE GICB DEF .1 1 POINTER DEF INTX1 PUT THE DATA HERE DEF LNTH # OF WORDS TO TRANSFER DEF .1 READ IT RTGB1 JMP GB1,I * * *********************************************************** * * * SAVAR: TRANSFER THE WORKING SAVE AREA TO THE DEVICE * * SAVE AREA IN THE GCB FOR SAFE KEEPING. * * * *********************************************************** * * SAVAR NOP JSB GCBIM TRANSFER THE WORKING SAVE AREA TO THE GCB DEF SAVED RETURN DEF .32 POINTER TO THE DEVICE SAVE AREA DEF .1 1 POINTER DEF BUFLN STARTING ADDRESS OF THE WORKING SAVE AREA DEF .3 WE ONLY NEED TO SAVE THE 1ST 3 WORDS DEF .2 WRITE IT SAVED JMP SAVAR,I * ************************************************************** * * * TRBYT: INSERT THE COMMAND TERMINATOR INTO THE I/O BUFFER * * * ************************************************************** * * TRBYT NOP LDA TERM GET THE TERMINATOR AND .177 MAKE SURE WE HAVE ONE BYTE JSB PTBYT STUFF IT IN THE I/O BUFFER JMP TRBYT,I * * ******************************************************** * * * PTBYT: PUT A BYTE INTO THE I/O BUFFER * * * * ON ENTRY: A CONTAINS THE BYTE TO BE INSERTED * * * ******************************************************** * * PTBYT NOP STA BITE SAVE THE BYTE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE GO INSERT THE BYTE DEF RTBYT RETURN DEF NBYTE OFFSET OF WHERE TO PUT THE BYTE (L OR R) DEF BITE THIS IS THE BYTE DEF ADCNT,I BUFFER POINTER * RTBYT ISZ NBYTE UPDATE THE BYTE COUNT JSB UP-DTE GO UPDATE THE BUFFER POINTER JMP PTBYT,I * BITE NOP * ******************************************************** * * * UPDTE: UPDATE THE WORKING I/O BUFFER POINTER * * * ******************************************************** * * UPDTE NOP LDA NBYTE GET THE # OF BYTES IN THE BUFFER CLE,ERA DIVIDE BY 2 ADA IOBUF ADD IT TO THE STARTING ADDRESS OF THE BUFFER STA ADCNT STUFF IT IN THE WORKING BUFFER POINTER JMP UPDTE,I * ************************************************* * * * OUTPT: OUTPUT THE I/O BUFFER TO THE 1350 * * * * ON ENTRY: A CONTAINS # OF BYTES TO OUTPUT * * * ************************************************* * * OUTPT NOP CMA,INA REIO NEEDS A STA IOCNT NEGATIVE BYTE COUNT JSB REIO FEED THE BUFFER TO THE 1350 DEF RTOUT RETURN DEF .2 WRITE IT DEF LUN THE LU # OF THE 1350 IOB NOP THE BEGINNING BUFFER ADDRESS DEF IOCNT # OF BYTES TO TRANSFER RTOUT JMP OUTPT,I * **************************************** * DEVICE SUBROUTINE EXIT POINTS * **************************************** * DV6EX JSB SAVAR COME HERE IF THE SAVE AREA IS TO BE SAVED DV6RT LDA CRT# EXIT DRIVER THROUGH CORRECT RETURN ADDRESS RAL RETURN ADDRESS IS ADA CRT# IN DVG06 + CRT# * 3 ADA ADVG6 LDA A,I JMP A,I SKP * * ************************************************ * * * ERROR CHECKING CODE * * * ************************************************ * * ERRCK JSB GCBIM GET THE FOLLOWING ITEMS FROM THE GCB: DEF ERRA LUN DEF .2 BUFFER ADDRESS DEF .2 BUFFER LENGTH (MAX) DEF LUN DEF .0 DEF .1 * ERRA JSB EXEC MAKE A STATUS REQUEST TO CHECK THINGS OUT DEF *+6 RETURN DEF D13I STATUS REQUEST CODE DEF LUN THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BIT HERE * JMP ITSNT IT AIN'T EVEN AN LU !!!! * LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD LDB A AND SAVE IT LDA ZTEMP AND M37 GET THE SUBCHANNEL BITS ADA B CONFIGURE B REGISTER RETURN WORD CPB M1740 IF DVR 37 THEN JMP ERR1 SO FAR SO GOOD! * ITSNT LDA .5 GPS ERROR 5 JMP ERR3 WE DIDN'T FLY SO MOVE ON * ERR1 JSB EMULX,I NOW ASK DEVICE COMMAND TABLE ABOUT ITSELF CPA .1350 IS IT THE 1350 DEVICE COMMAND TABLE? JMP ERR2 YEP ! WE'RE OKAY * CPA .5 GPS ERROR 5? JMP ERR3 YEP! GO LOG IT * LDA .3 SOMETHING IS WRONG SO JMP ERR3 LOG A GPS ERROR 3 * ERR2 JSB GRSTS SEE IF THIS IS A PLOTR(4) (BUFFERING) DEF ERRB RETURN DEF .1 READ THE STATUS WORD DEF .1000 MASK FOR BUFFERING BIT DEF IOFLG RESULT OF CALL * ERRB LDA IOFLG GET BUFFERING BIT SZA SUPPOSED TO BUFFER? JMP ERRD YEP! USE THE USER'S BUFFER * LDA ADBUF NOPE! GET ADDRESS OF THE INTERNAL BUFFER STA IOBUF AND STUFF IT AWAY JMP CBUF GET A CLEAN ADDRESS * ERRD LDA IOBUF GET THE ADDRESS OF THE USER'S BUFFER CBUF JSB INDCK MAKE IT CLEAN STA IOBUF STUFF IT BACK IN * * TRANSFER THE INITIAL SAVE AREA INTO THE GCB * JSB GCBIM TRANSFER THE WORKING SAVE AREA TO THE GCB DEF GOINT RETURN DEF .32 DEVICE SAVE AREA POINTER DEF .1 1 POINTER DEF BUFLN STARTING ADDRESS OF WORKING BUFFER DEF .10 10 WORDS IN SAVE AREA DEF .2 WRITE IT * * SEND THE 1350 THE REQUIRED INITIALIZATION STRING DS2013 * DS2013 GOINT LDA INITA GET ADDRESS OF INITIALIZATION STRING DS2013 STA IOB STUFF IT HERE FOR OUTPUT DS2013 LDA .20 THERE'S 20 BYTES IN THE INIT SEQUENCE DS2013 JSB OUTPT FEED THE INIT SEQUENCE TO THE 1350 DS2013 * CLA NO ERRORS !!!! * ERR3 STA INTX1 INTX1 HAS THE ERROR CODE LDA .1 1 WORD TO STA LNGTH SEND BACK JSB GB2 GIVE THE ERROR CODE TO THE GICB JMP DV6RT LEAVE THE DRIVER * * EMULT JSB EMULX,I JMP DV6RT SKP ************************************************ * * * CONSTANTS * * * ************************************************ * A EQU 0 B EQU 1 * .0 DEC 0 .1 DEC 1 .3 DEC 3 .5 DEC 5 .6 DEC 6 .7 DEC 7 .10 DEC 10 .16 DEC 16 .20 DEC 20 DS2013 .32 DEC 32 .33 DEC 33 .34 DEC 34 .35 DEC 35 .177 OCT 177 OCTAL .1000 OCT 1000 .1350 DEC 1350 CR OCT 15 CARRIGE RETURN ETX OCT 1400 TEXT TERMINATOR BIT4 OCT 20 MASK FOR READING LABEL MODE MASK4 OCT 77757 MASK FOR SETTING LABEL MODE D13I OCT 100015 STATUS REQUEST CODE FOR EXEC M1740 OCT 17400 DVR37 CODE M37 OCT 37 MASK TO GET HP-IB SUBCHANNEL BITTS MEQT OCT 37400 MASK TO GET HP-IB EQT * * ************************************ * * * ADDRESSES * * tp * ************************************ * ADVG6 DEF DVG06 ADBUF DEF BUFR INTERNAL BUFFER ADDRESS * * * ************************************************* * * * LOCAL VARIABLES * * * ************************************************* * * BUFR BSS 15 INTERNAL I/O BUFFER NBYTE NOP # OF BYTES IN I/O BUFFER NWORD NOP # OF WORDS IN A COMMAND SEQUENCE BUFLG NOP CURRENT BUFFERING FLAG (0= NO CURRENT BUFFERING) IOCNT NOP - NBYTE (USED BY REIO) DTYPE NOP DRIVER TYPE YTEMP NOP EQT WORD 5 ZTEMP NOP LOWER 5 BITS IS SUBCHANNEL # TERM NOP COMMAND TERMINATOR TEMP NOP TEMPORARY VARIABLE ADCNT NOP WORKING I/O BUFFER POINTER ODFLG NOP 0 IF ON AN EVEN WORD BOUNDARY LNTH NOP # OF WORDS TO TRANSFER TO GCB SKP ***************************************************************** * * * TABLE AREA * * * * !!!! DO NOT CHANGE SEQUENCE OF INDIVIDUAL TABLES !!!!! * * * ***************************************************************** * *********************************** DS2013 * * DS2013 * 1350 INITIALIZATION SEQUENCE * DS2013 * * DS2013 *********************************** DS2013 * DS2013 * DS2013 * DS2013 * 3B 1END OF TEXT DS2013 * 20B POWER CLEAR DS2013 * EM ERASE MEMORY DS2013 * EN ERASE FILE NAMES DS2013 * EX ERASE AUXILARY DISPLAY INFO DS2013 * SN STOP NAMING FILES DS2013 * SX STOP SETTING AUXILARY BITS DS2013 * UM UNBLANK MEMORY DS2013 * DS2013 * DS2013 INITA DEF *+1 STARTING ADDRESS OF THE INIT SEQUENCE DS2013 OCT 1424 DS2013 ASC 9,:EM:EN:EX:SN:SX:UM DS2013 * * ********************************** * * * GCBIM TABLE USED IN ERRCK * * !! DO NOT CHNAGE ORDER !! * ********************************** * * .2 OCT 2 GCB POINTER FOR THE LUN .4 OCT 4 GCB POINTER FOR THE BUFFER ADDRESS AND LENGTH * * ************************************* * * * WORKING DEVICE SAVE AREA TABLE * * !! DO NOT CHANGE ORDER !! * ************************************* * * BUFLN NOP CURRENT BUFFER LENGTH PX NOP X POSITION OF PEN PY NOP Y POSITION OF PEN IOFLG NOP I/O FLAG (0=NO BUFFERING) LUN NOP GRAPHICS LU # IOBUF NOP BUFFER STARTING ADDRESS IOBL NOP MAXIMUM BUFFER LENGTH TCSIZ NOP 1350 CSIZE(0,1,2,3) LDIR NOP 1350 LDIR (0,4) CRT# NOP CRT # (0,1,2,3) * * *********************************************** * * * WORKING VARIABLE TABLE FOR GCB TRANSFERS * * !! DO NOT CHANGE SEQUENCE !! * *********************************************** * * INTX1 NOP INruNLHTX2 NOP INTX3 NOP INTX4 NOP END "N | 92840-18091 2013 S C0122 &DCT06              H0101 WwASMB,R,Q,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * NAME: DCT06 -- 1350A DEVICE COMMAND TABLE * SOURCE: 92840-18091 * RELOC: 92840-16008 * PGMR: KH 5/18/78 * * MODIFIED BY: DJS SEPT 27, 1979 > GOT THE DCT TO WORK * MODIFIED BY: DJS JAN 27, 1980 > FIXED RESET GIC (1) * ********************************************************************** * NAM DCT06,7 92840-16008 REV.2013 800127 EXT FLOAT EXT .IENT EXT FLTAS EXT LNGTH EXT GIC EXT DCTAD EXT GCBIM EXT BYTE EXT INDCK EXT REIO * ENT DCT06 * * ********************************************************************** * * * THIS IS THE DEVICE COMMAND TABLE FOR THE 1350A GRAPHICS * * TANSLATOR. GRAPHICS/1000 SUPPORTS THE HP 1350A WITH THE * * FOLLOWING CRT'S: * * * * HP 1310A HP 1317A * * HP 1311A HP 1321A * * * * * ********************************************************************** HED * ********************** * CONSTANTS * ********************** * * A EQU 0 A REG. B EQU 1 B REG. * P0 OCT 0,0,0,0 P1 OCT 1 P2  OCT 2 P3 OCT 3 P4 OCT 4 P8 DEC 8 P9 DEC 9 P10 DEC 10 P12 DEC 12 P16 DEC 16 P26 DEC 26 P32 DEC 32 P48 DEC 48 B137 OCT 137 USED TO SUPRESS CR-LF WHEN STARTING TEXT MODE B177 OCT 177 ERRCK GIC (FIRST ONE THAT THE DCT SEES) DG45 DEC .785 45 DEGREES IN RADIANS DG135 DEC 2.355 135 DEGREES IN RADIANS B377 OCT 377 LOWER BYTE MASK COMMA OCT 54 COMMA * 26000 SEMCL OCT 73 SEMI-COLON CRLF OCT 6412 CR LF M3 DEC -3 SKP * * ********************** * TEXT * ********************** * * TX ASC 1,TX TEXT (LABEL) MODE COMMAND CS ASC 1,CS CHAR. SIZE COMMAND ID ASC 3,1350A ID NAME * * ********************* * ADRESSES * ********************* * * AP0 DEF P0 AP1 DEF P1 AP2 DEF P2 AP3 DEF P3 AP4 DEF P4 AP8 DEF P8 AP9 DEF P9 AID DEF ID ADDRESS OF ID NAME AMMCS DEF MMCS MIN-MAX CHAR. SIZE STARTING ADDRESS ACINF DEF CINF CHARACTER PLACEMENT INFO ADDRESS APLTU DEF PLTU PLOT UNIT 1ST CHAR. ADDRESS INX DEF INTX1 TEMP AREA ADRESS SKP *********************************************************************** * * * >>>>>>>>>>>>>>>>> TABLE AREAS <<<<<<<<<<<<<<<<<<<<<<<< * * * * DO NOT CHANGE SEQUENCE OF THE INDIVIDUAL TABLES !!!!!! * * * *********************************************************************** * * *********************************************************** * DISPLAY SURFACE TABLE. THE SIZES ARE IN MILLIMETERS * *********************************************************** * ADSMM DEF *+1 STARTING ADDRESS OF DISPLAY SURFACE TABLE DEF DSMM0 HP 1310 CRT DEF DSMM1 HP 1311 CRT DEF DSMM2 HP 1317 CRT DEF DSMM3 HP 1321 CRT * * THE DISPLAY SURFACE COORDINATES FOR THE CRT'S ARE IN THE * FOLLOWING SEQUENCE: * * X MIN MM * Y MIN MM * X MAX MM * Y MAX MM * ************* * HP 1310 * ************* * DSMM0 DEC 0. DEC 0. DEC 279. DEC 279. * ************* * HP 1311 * ************* * DSMM1 DEC 0. DEC 0. DEC 216. DEC 216. * ************* * HP 1317 * ************* * DSMM2 DEC 0. DEC 0. DEC 254. DEC 254. * ************* * HP 1321 * ************* * DSMM3 DEC 0. DEC 0. DEC 305. DEC 305. SKP ************************************************************** * * * COMMAND LINK TABLE * * !!!! DO NOT CHANGE SEQUENCE !!!! * ************************************************************** DCT06 NOP DEF EMSUB EMMULATOR ENTRY ADDRESS DEF RESET 1 RESET (POWER ON) NOP - 2 DEFAULT P1, P2 DEF PCLR 3 CLEAR SCREEN NOP - 4 FLUSH I-O BUF. DEF HOPEN 5 HOME PEN (0,0) DEC -1 6 *GET I.D. NOP - 7 - DEC -2 8 *GET PLOT UNIT P1, P2 DEC -3 9 *GET CHAR. SIZE DEC -4 10 *GET PEN LOCATION DEC -4 11 *GET CURSOR LOCATION DEC -4 12 *DIGITIZE NOP - 13 SET LABEL ORIGIN DEC -5 14 LABEL DIRECTION NOP - 15 SET CHAR. SLANT ON NOP - 16 SET CHAR. SLANT OFF DEC -6 17 SET CHAR. SIZE (MU) NOP - 18 SET RELATIVE ORIGIN NOP - 19 SET PLOT DIRECTION NOP - 20 SET SCALE NOP - 21 SET ORIGIN = CURSOR LOCATION NOP - 22 SET ORIGIN = PEN LOCATION NOP - 23 DRAW TO CURSOR NOP - 24 SELECT CHAR. SET DEF PENUP 25 SELECT PEN # 0  NOP - 26 SELECT PEN # -1 NOP - 27 SELECT PEN # -2 NOP - 28 SELECT PEN # (1-N) DEC -7 29 *GET # OF PENS NOP - 30 DEFINE LINE TYPE NOP - 31 SELECT DEFAULT LINE TYPE NOP - 32 LINE TYPE WITH LENGTH DEF PENUP 33 PEN UP DEF PENDN 34 PEN DOWN DEF PLTAB 35 PLOT ABSOLUTE NOP 36 PLOT RELATIVE NOP 37 PLOT INCREMENT DEF LABEL 38 SHORT LABEL DEF LABEL 39 START LABEL MODE DEF ETXT 40 TERM. LABEL MODE DEC -8 41 FLOAT PT. TO ASCII CODE DEC -9 42 *GET SURFACE SIZE IN MM NOP - 43 POSITION CURSOR ABSOLUTE NOP - 44 POSITION CURSOR RELATIVE NOP - 45 SET G1, G2 DEC -10 46 *GET MACHINE UNITS PER MM DEC -11 47 *GET DEVICE CLEARING CHARACTERISTICS DEC -12 48 *GET # OF PHYSICALLY DIFFERENT PENS DEC -13 49 *GET # OF DIFFERENT TYPES OF CURSORS DEC -14 50 *LORGABILITY DEC -15 51 *MAX. CHAR. SLANT (TAN ANGLE) DEC -16 52 *HARD CLIPPING CAPABILITY DEC -17 53 CHARACTER PLACEMENT DEC -18 54 *GET MIN-MAX CHAR. SIZE (MU) DEC -19 55 *GET LABEL DIRECTION CAPABILITY DEC -20 56 *GET LORG RANGE ************************************************************** SKP ************************************************************** * ASCII COMMAND STRINGS - FOR DIRECT DUMP TO I-O BUFFER * * * * FIRST WORD = NUMBER OF BYTES * * NEG. = WRITE TO DEVICE * * POS. = READ FROM DEVICE * * * * SECOND WORD = TERMINATER * * * * NEXT N WORDS = DATA * * * * !!!!!! DO NOT CHANGE SEQUENCE OF COMMANDS STRINGS !!!!!! * ************************************************************** *********************** * RESET GIC=1 * *********************** * * * THE RESET GIC WAS CHANGED TO REMOVE ALL NECESSARY 'ONE TIME ONLY' * 1350 INITIALIZATION. THE DEVICE INITIALIZATION IS NOW PERFORMED * IN DVG06 AFTER ERROR CHECKING HAS BEEN SUCCESSFULLY COMPLETED. * RESET DEC -4 DS2013 DEF CRLF * OCT 1424 CHAR(3) CHAR(20) DS2013 * OCT 6412 DS2013 * ASC 1,EM ERASE MEMORY DS2013 * OCT 6412 DS2013 * ASC 1,EX ERASE AUX. BITS DS2013 * OCT 6412 DS2013 * ASC 1,EN ERASE SEGMENT NAMES DS2013 * OCT 6412 DS2013 * ASC 1,UM UNBLANK MEMORY DS2013 * OCT 6412 DS2013 ASC 2,CS0, SET TO SMALLEST CHAR. SIZE * *********************** * CLEAR SCREEN GIC=3 * *********************** * PCLR DEC -2 DEF CRLF ASC 1,EM ERASE MEMORY * *********************** * HOME PEN GIC=5 * *********************** * HOPEN DEC -12 DEF CRLF ASC 2,PE0, LIFT PEN UP OCT 6412 ASC 3,PA0,0; MOVE TO HOME LOCATION * *********************** * PEN UP GIC=25 * *********************** * PENUP DEC -4 DEF CRLF ASC 2,PE0, LIFT PEN UP * *********************** * PEN DOWN GIC=33 * *********************** * PENDN DEC -4 DEF CRLF PE ASC 2,PE1, PUT PEN DOWN * *********************** * START TEXT GIC=39 * *********************** * LABEL DEC -8 DEF B137LX SUPPRESS CR-LF ASC 2,PE1, OCT 6412 ASC 1,TX START TEXT MODE * *********************** * END TEXT GIC=40 * *********************** * * ETXT DEC -1 DEF CRLF OCT 1400 ETX * ************************ * PLOT ABSOLUTE GIC=35 * ************************ * PLTAB DEC -2 DEF SEMCL ASC 1,PA ************************************************************** SKP **************************************** * * * EMMULATOR TABLE * * !!! DO NOT CHANGE SEQUENCE !!! * * * **************************************** * * SBTBL DEF * TABLE ADDRESS DEF SUB06 GET I.D. DEF SUB08 GET PLOT UNIT DEF SUB09 GET CHAR. SIZE DEF SUB10 GET PEN LOCATION, CURSOR LOCATION DEF SUB14 SET LABEL DIRECTION DEF SUB17 SET CHAR. SIZE DEF SUB29 GET # OF PENS DEF SUB41 FLT PT. TO ASCII CONVERSION DEF SUB42 GET GET SURFACE SIZE IN MM DEF SUB46 GET MACHINE UNITS PER MM DEF SUB47 GET DEVICE CLEARING CHARACTERISTICS DEF SUB48 GET # OF PHYSICALLY DIFFERENT PENS DEF SUB49 GET # OF DIFFERENT TYPES OF CURSORS DEF SUB50 GET LORGABILITY INFOMATION DEF SUB51 GET MAX. CHAR. SLANT DEF SUB52 GET HARD CLIPPING CAPABILITY DEF SUB53 GET CHARACTER PLACEMENT INFO DEF SUB54 GET MIN-MAX CHAR. SIZE DEF SUB55 GET LABEL DIRECTION CAPABILITY DEF SUB56 LORG RANGE * SKP * ************************************************ * MACHINE UNIT PER MILLIMETER TABLE * ************************************************ * AMUMM DEF *+1 STARTING ADDRESS OF MACHINE UNIT PER MM TABLE DEF MUMM0 HP 1310 CRT DEF MUMM1 HP 1311 CRT DEF MUMM2 HP 1317 CRT DEF MUMM3 HP 1321 CRT * * THE MACHINE UNIT / MM TABLE IS IN TYlHE FOLLOWING ORDER: * * X MU / MM * Y MU / MM * **************** * HP 1310 * **************** * MUMM0 DEC 3.663 DEC 3.667 * **************** * HP 1311 * **************** * MUMM1 DEC 4.731 DEC 4.736 * **************** * HP 1317 * **************** * MUMM2 DEC 4.024 DEC 4.028 * **************** * HP 1321 * **************** * MUMM3 DEC 3.351 DEC 3.354 SKP ****************************************************** * * * MIN / MAX CHARACTER SIZE (MACHINE UNITS) TABLE * * * ****************************************************** * MMCS DEC 12.0 X MIN CHAR. SIZE (MU) DEC 16.0 Y MIN CHAR. SIZE (MU) DEC 96.0 X MAX CHAR. SIZE (MU) DEC 128.0 Y MAX CHAR. SIZE (MU) ****************************************************** * * ****************************************************** * * * MIN / MAX DISPLAY SIZE COORDINATE (MU) TABLE * * * ****************************************************** * PLTU DEC 0. X MIN (MU) DEC 0. Y MIN (MU) DEC 1022. X MAX (MU) DEC 1023. Y MAX (MU) ****************************************************** * * ****************************************************** * * * CHARCTER PLACEMENT INFORMATION TABLE * * * ****************************************************** * CINF DEC 0. X MIN IN CHAR. CELL DEC .6667 X MAX IN CHAR. CELL DEC 0. Y MIN IN CHAR. CELL DEC 0.6 Y MAX IN CHAR. CELL ****************************************************** * * ******************************************************* *  * * LABEL DIRECTION CAPABILITY TABLE * * * ******************************************************* * LBLDR DEF *+1 OCT 1 FIXED INCREMENTS (THE 1350 IS ONLY * CAPABLE OF 0 AND 90 ROTATIONS) DEC 1.57 INCREMENT ANGLE (90 DEG.) ******************************************************* SKP *********************************************************** * * * WORKING VARIABLES * * * *********************************************************** * * ADCNT BSS 1 WORKING ADDRESS COUNTER FOR I/O BUFFER BITE BSS 1 "PUTBYTE" TEMPORARY REG. GCBCD BSS 1 GRAPHICS CONTROL BLOCK CODE NBYTE BSS 1 # OF BYTES TO BE STORED IN I-O BUFFER IOCNT BSS 1 I-O COUNT FOR EXEC (-NBYTE) LNTH BSS 1 # WORDS TO TRANSFER TO GCB TEMP BSS 1 TEMPORARY REGISTER FXDN BSS 1 FORMAT F7.N WHERE N = FXDN * * ************************************************************** * GCB INTERFACE VARIABLES * ************************************************************** * INTX1 BSS 1 DO INTX2 BSS 1 NOT INTX3 BSS 1 CHANGE INTX4 BSS 1 SEQUENCE INTX5 BSS 4 !!!!!! ************************************************************** * * ************************************************************** * * * DEVICE SAVE AREA VARIABLES * * !!!! DO NOT CHANGE SEQUENCE !!!! * * * ************************************************************** * BUFLN BSS 1 CURRENT BUFFER LENGTH (NOT USED IN DCT) PX BSS 1 X POSITION OF CURSOR (MU) PY BSS 1 Y POSITION OF CURSOR (MU) IOFLG BSS 1 BUFFERING FLAG (NOT USED IN DCT) LUN BSS 1 LU # OF GRAPHICS DEVICE IOBUF BSS 1 BEGINNING ADDRESS OF I/O BUFFER IOBL BSS 1 TOTAL LENGTH OF I/O BUFFER (NOT USED IN DCT) TCSIZ BSS 1 CURRENT CHARACTER SIZE (0,1,2 OR 3) LDIR BSS 1 CURRENT LABEL DIRECTION (0=0, 4=90) CRT# BSS 1 CRT # (0=1310, 1=1311, 2=1317, 3=1321) * ************************************************************** SKP ************************************************************** * * * ENTRY ROUTINE FOR ALL EMULATED COMMANDS * * * ************************************************************** * * EMSUB NOP EMULATOR ENTRY PONIT LDA GIC GET THE GIC CPA B177 ERROR CHECK GIC (1ST ONE THAT THE DCT SEES) JMP ERRCK YEP! GO DO ERROR CHECK * JSB SETUP GO SET THINGS UP LDA DCTAD GET EMULATE SUB CODE (DCT ADDRESS) CMA,INA CHANGE SIGN (TO POSITIVE) STA B AND STORE IT IN B-REG. LDA SBTBL GET ADDRESS OF EMULATOR TABLE JSB INDCK AND TAKE OUT THE INDIRECT BIT ADA B COMPUTE THE POINTER LDB LNGTH # OF ITEMS IN GIC (EX. PA = 2) INB INCREMENT TO ACCOMODATE CONTROL WORD STB LNTH AND STORE IT AS TOTAL LENGTH LDA A,I JMP A,I JMP TO SUB-- FOR EMULATE * * ************************** * ERROR CHECKING * ************************** * ERRCK LDA .1350 GET 1350 FOR DCT/DVG CHECK JMP EMSUB,I * .1350 DEC 1350 SKP ***************************************************** * * * EMMULATOR ROUTINES * * * ******************************************_*********** * * ************************************** * GET THE ID OF THE DEVICE (1350A) * ************************************** * SUB06 LDA AID GET ADDRESS OF ID LDB AP3 IT'S 3 WORDS LONG JMP USGB SEND IT BACK IN THE GICB * * ****************************** * GET THE PLOT UNITS P1,P2 * ****************************** * SUB08 JSB GCBIM GET THE MECHANICAL LIMITS FROM THE GCB DEF *+6 RETURN DEF P8 GCB LOGICAL POINTER #8 DEF P1 1 POINTER DEF INTX1 PUT INFO IN INTX1-INTX8 DEF P0 DEFAULT LENGTH = 8 WORDS DEF P1 READ IT * * * SEE IF G1X AND G2X = 0 IF YES, DO NOT CHANGE * IF NO, XFR DEFAULT G1 AND G2 TO GICB * DLD INTX1 GET G1X SZA,RSS G1X UPPER=0 SZB YEP ! G1X LOWER=0 JMP SB081 NOPE! SEND BACK CURRENT G1,G2 * DLD INTX5 GET G2X SZA,RSS G2X UPPER=0 SZB YEP! G2X LOWER=0 JMP SB081 NOPE! SEND BACK CURRENT G1,G2 * LDA APLTU ADDRESS OF DEFUALT PLOT UNIT LDB AP8 P1 = 0, 0 P2 = 1022, 1023 JMP USGB SHIP BACK DEFAULTS * SB081 LDA INX GET ADDRESS OF GCB TEMPS (INTX1) LDB AP8 THERE'S 8 BYTES JMP USGB SHIP BACK CURRENT G1,G2 * * **************************************** * GET THE CURRENT CHARACTER SIZE * **************************************** * * SUB09 LDB TCSIZ B=1350 CSIZE CMB,INB B= SHIFT COUNT LDA P1 SET MULTIPLY FACTOR CLE * * CONVERT TCSIZ (0,1,2,3) TO GET MULTIPLY FACTOR(0,2,4,8) * SB091 SZB,RSS SHIFTED ENOUGH? JMP SB092 YEP! * RAL SHIFT LEFT INB INCREMENT SHIFT COUNT JMP SB091 SEE IF WE'RE DONE * SB092 STA TEMP SAVE MULTIPLY FACTOR MPY P12 GET WIDTH IN MU'S JSB FLOAT CONVERT TO FLOAT DST INTX1 PUT IT IN GCB TDEMP1,2 LDA TEMP GET THE MULTIPLY FACTOR MPY P16 GET HEIGHT IN MU'S JSB FLOAT CONVERT IT TO FLOAT DST INTX1+2 PUT HEIGHT IN GCB TEMP3,4 LDA P16 GET GICB POINTER JSB GB2 SEND THE CHAR. INFO BACK IN THE GCB JMP EMSUB,I EXIT THRU EMULATE ROUTINE * * ********************************** * GET THE CURRENT PEN POSITION * ********************************** * * SUB10 JSB GCBIM GET PX AND PY FROM THE SAVE AREA DEF GOTXY RETURN DEF P32 SAVE AREA POINTER DEF P1 1 POINTER DEF BUFLN SAVE AREA TABLE ADDRESS DEF P3 3 BYTES DEF P1 READ IT * GOTXY DLD PX GET PEN POSITION INFO. DST INTX1 STORE IT FOR TRANSFER CLA IN CASE IT USES IZ PARM STA INTX3 SHIP BACK A 0 IN IZ LDA P16 GET GICB POINTER JSB GB2 SEND POSITION BACK IN THE GICB JMP EMSUB,I EXIT THRU EMULATE ROUTINE * * * *************************** * SET LABEL DIRECTION * *************************** * * LDIR = 0 (0 DEG.) IF REQUESTED ANGLE >=0 AND <45 * LDIR = 1 (90 DEG.) IF REQUESTED ANGLE >=45 AND <135 * LDIR = 0 (0 DEG.) IF REQUESTED ANGLE >135 * SUB14 LDA P16 GET GICB POINTER JSB GB1 PUT GICB INFO INTO INTX1,3 LDA P0 SET LABEL STA LDIR DIRECTION TO 0 DLD DG45 GET 45 DEG. IN RADIANS FSB INTX2 CHECK OUT THE ANGLE REQUESTED SSA,RSS IS ANGLE < 45 DEG. JMP OUTCS YEP! LDIR=0 -- GO OUTPUT IT * DLD DG135 GET 135 DEG. IN RADIANS FSB INTX2 CHECK OUT THE ANGLE REQUESTED SSA IS ANGLE >135 DEGREES JMP OUTCS YEP! LDIR=0 -- GO OUTPUT IT * LDA P4 NOPE! IT'S IN BOUNDS STA LDIR SET LDIR = 4 = 90 DEGREES JMP OUTCS GO OUTPUT IT * ******************************** * SET THE CHARACTER SIZE * ******************************** * * SUB17 LDA P16 GET CHAR INFO FROM GICB JSB GB1 DLD INTX4 READ IN CHAR. HEIGHT JSB .IENT CONVERT TO INTEGER NOP NO ERROR ROUTINE SZA,RSS IS IT ZERO? JMP SAVSZ YEP, SAVE THE CSIZE * ALF,ALF SHIFT CSIZE 8 BITS TO THE LEFT LDB A CHECK FOR AND B377 BIG CSIZE SZA IS IT A BIGGY? JMP BIGSZ YEP! SET TO THE BIGGEST SIZE * LDA M3 SHIFT COUNTER=-3 SLOOP CLE,ELB SHIFT CSIZE LEFT ONE SEZ CSIZE = 2 OR 3? JMP NEGA YEP! GO SAVE IT * INA UPDATE SHIFT COUNT SZA DONE SHIFTING? JMP SLOOP NOPE! SHIFT IT AGAIN JMP SAVSZ YEP! SET CSIZE TO SMALLEST SIZE * NEGA CMA,INA MAKE CSIZE POSITIVE JMP SAVSZ GO SAVE IT * BIGSZ LDA P3 WE GOT THE BIGGY SAVSZ STA TCSIZ SAVE THE CSIZE JMP OUTCS OUTPUT CHAR. SIZE TO 1350 * * ***************************** * GET THE NUMBER OF PENS * ***************************** * SUB29 LDA AP1 # OF PENS = 1 LDB AP1 JMP USGB * * ************************************** * OUTPUT LABELS FOR LAXES AND LGRID * ************************************** * SUB41 LDA PE MAKE JSB WRDST SURE LDA PE+1 THAT JSB WRDST THE LDA CRLF PEN JSB WRDST IS DOWN LDA TX GET MNUMONIC FOR TEXT MODE (TX) JSB WRDST AND PUT IT IN I-O BUFFER LDA P16 GET DATA JSB GB1 FROM GICB JSB GCBIM GET THE FXDN FROM THE GCB DEF GOTFX RETURN DEF P26 FXDN LOGICAL POINTER DEF P1 1 POINTER DEF FXDN PUT IT IN FXDN DEF P0 DEFAULT LENGTH = 1 DEF P1 READ IT * GOTFX JSB GLIDE DO FLT PT. TO ASCII CONVERSION LDA P3 TEXT TERMINATOR JSB PTBYT PUT THE TERMINATOR IN THE BUFFER LDA NBYTE GET # OF BYTES LDB P2 THIS IS A WRITE(RW = 2) JSB OUTPT AND DO I-O XFR JMP EMSUB,I EXIT THRU EMULATE ROUTINE * * ******************************* * GET THE DISPLAY LIMITS * ******************************* * SUB42 LDA ADSMM GET ADDRESS OF DISPLAY SIZE TABLE JSB INDCK MAKE IT GOOD ADA CRT# INDEX IN WITH THE CRT# LDA A,I GET THE ADDRESS OF THE DISPLAY LIMITS LDB AP8 THERE'S 8 WORDS JMP USGB SHIP THE DISPLAY SIZE BACK IN THE GICB * * ******************************************* * GET THE MACHINE UNITS PER MILLIMETER * ******************************************* * SUB46 LDA AMUMM GET ADDRESS OF THE MU/MM TABLE JSB INDCK MAKE IT GOOD ADA CRT# INDEX IN WITH THE CRT# LDA A,I GET THE CRT'S MU/MM ADDRESS LDB AP4 THERE'S 4 WORDS JMP USGB SHIP THE MU/MM BACK IN THE GICB * ***************************************** * GET THE DEVICE CLEARING CAPABILITY * ***************************************** * * SUB47 LDA AP2 TRUE CLEAR (ERASE) MASK = 2 LDB AP1 ONLY 1 WORD JMP USGB SHIP IT BACK IN THE GICB * **************************** * GET # OF DIFFERENT PENS * **************************** * SUB48 JMP SUB29 # OF PENS = 1 * * ********************** * GET # OF CURSORS * ********************** * * SUB49 LDA AP0 # OF CURSORS = 0 LDB AP1 JMP USGB * ********************* * GET LORGABILITY * ********************* * SUB50 JMP SUB49 LORGABILITY = NO * * ******************************* * GET CHAR SLANT CAPABILITY * ******************************* * SUB51 LDA AP0 CHAR. SLANT = NO LDB AP4 JMP USGB * * ***************************** * GET CLIPPING CAPABILITY * ***************************** * SUB52 JMP SUB49 NO HARD CLIPPING CAPABILITY * * *********************************** * GET CHARACTER PLACEMENT INFO * *********************************** * SUB53 LDA ACINF ADDRESS OF CHARACTER PLACEMENT INFO LDB AP8 JMP USGB * * ************************************ * GET MIN/MAX CHARACTER SIZES * ************************************ * SUB54 LDA AMMCS MIN-MAX CHAR. SIZE LDB AP9 JMP USGB * * ************************** * GET LDIR CAPABILITY * ************************** * SUB55 LDA LBLDR LABEL DIRECTION = HORIZONTAL AND VERTICAL ONLY LDB AP3 JMP USGB * * ************************* * GET LORG CAPABILITY * ************************* * SUB56 LDA AP0 LORG =1 ONLY LDB AP2 JMP USGB SKP ******************************************************************* * * * UTILITY SUBROUTINES * * * ******************************************************************* * * * ********************************************** * * * USGB: WRITE DATA INTO THE GICB * * * * ON ENTRY: A = ADDRESS OF DATA (CONSTANTS)* * B = ADDRESS OF # OF WORDS * ********************************************** * * USGB STA ADDR ADDRESS OF DATA STB NUM ADDRESS OF # OF DATA ITEMS JSB GCBIM GRAPHICS CONTROL BLOCK INTERFACE MODULE DEF *+6 DEF P16 ICODE ( GCB POINTER ) DEF P1 LENGTH OF ICODE ADDR NOP BUFFER NAME * DEF ADDR,I NUM NOP BUFFER LENGTH * DEF NUM,I DEF P2 WRITE JMP EMSUB,I EXIT THRU EMULATE ROUTINE * ********************************* * * * GB1: READ DATA FROM GCB * * =N * * ON ENTRY: A = GCB POINTER * ********************************* * * GB1 NOP READ DATA FROM GICB STA GCBCD STORE THE GCB CODE (POINTER) JSB GCBIM GRAPHICS CONTROL BLOCK INTERFACE MODULE DEF *+6 DEF GCBCD GCB CODE (POINTER) DEF P1 LENGTH OF THE CODE DEF INTX1 BUFFER NAME DEF LNTH BUFFER LENGTH DEF P1 READ (RW = 1) JMP GB1,I RETURN * ********************************* * * * GB2: WRITE DATA INTO THE GCB * * * * ON ENTRY: A = GCB CODE * ********************************* * GB2 NOP WRITE DATA INTO GICB STA GCBCD STORE THE GCB CODE (POINTER) JSB GCBIM GRAPHICS CONTROL BLOCK INTERFACE MODULE DEF *+6 DEF GCBCD ICODE = GCB CODE (POINTER) DEF P1 LENGTH OF THE CODE = 1 DEF INTX1 BUFFER NAME DEF LNGTH BUFFER LENGTH DEF P2 WRITE (RW = 2) JMP GB2,I RETURN * ********************************************** * * * GLIDE: CONVERT FLT PT. TO ASCII * * * * ON ENTRY: INTX2 CONTAINS THE NUMBER TO * * BE CONVERTED * ********************************************** * GLIDE NOP JSB FLTAS FLT PT. TO ASCII CONVERSION DEF *+6 DEF INTX2 DATA TO BE CONVERT DEF IOBUF,I PUT RESULT BACK IN HERE DEF NBYTE # OF BYTES DEF FXDN FORMAT F7.N DEF TEMP JMP GLIDE,I RETURN * ******************************************* * * * OUTPT: WRITE TO THE DEVICE * * * * ON ENTRY: A = # OF BYTES TO BE SENT * ******************************************* * * OUTPT NOP I-0 XFR ROUTINE CMA,INA CHANGE SIIGN (TO POSITIVE) STA IOCNT MAKE IT A BUFFER COUNTER FOR OUTPUT JSB REIO XFR CONTROL TO RTE (LINK TO DVR37 ??) DEF *+5 DEF P2 ICODE 2=WRITE DEF LUN CONTROL INFO. ICNWD=LU # IOB NOP BUFFER LOCATION DEF IOCNT BUFFER LENGTH JMP OUTPT,I RETURN * * ******************************************* * * * PTBYT: PUT A BYTE INTO THE I/O BUFFER * * * * ON ENTRY: A = THE BYTE TO BE INSERTED * ******************************************* * * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE PUT CURRENT BYTE INTO NEXT AVAILABLE SPACE DEF *+4 DEF NBYTE # OF BYTES DEF BITE THE BYTE TO BE SEND DEF ADCNT,I I-O BUFFER ISZ NBYTE INCREMENT BYTE COUNT JSB UPDTE UPDATE ADDRESS COUNTER JMP PTBYT,I RETURN * ********************************************* * * * SETUP: SET UP VARIABLES NEEDED BY THE DCT * * * ********************************************* * * SETUP NOP JSB GCBIM READ DATA FROM GCB DEVICE SAVE AREA DEF *+6 RETURN DEF P32 ICODE FOR DEV. SUB. BUFFER AREA DEF P1 LENGTH OF ICODE = 1 DEF BUFLN STARTING ADDRESS OF SAVE AREA VARIABLES DEF P10 SAVE AREA SIZE =10 WORDS DEF P1 READ-WRITE CODE 1 = READ NOLOD LDA IOBUF GET THE BUFFER ADDRESS JSB INDCK MAKE IT CLEAN STA IOBUF SAVE IT AGAIN STA IOB BUFFER ADDRESS FOR OUTPUT STA ADCNT VARIABLE ADDRESS COUNTER LDA P0 CLEAR STA NBYTE THE BYTE COUNTER JMP SETUP,I RETURN * * ********************************************* * * * UPDTE: UP DATE THE ADDRESS COUNTER (ADCNT)* * * ********************************************* * UPDTE NOP UP DATE LDA NBYTE GET # OF BYTES CLE,ERA DIVIDE BY 2 ADA IOBUF ADD IT TO I-O BUFFER ADDRESS STA ADCNT STORE IT AS AN ADDRESS COUNT JMP UPDTE,I RETURN * ********************************************* * * * WRDST: STORE A WORD IN THE I/O BUFFER * * * * ON ENTRY: A = WORD TO BE SAVED * ********************************************* * * WRDST NOP STA ADCNT,I PUT IT IN THE BUFFER ISZ ADCNT BUMP UP THE ADDRESS COUNT ISZ NBYTE ADD 2 TO ISZ NBYTE THE BYTE COUNT JMP WRDST,I RETURN * ******************************************** * * * OUTCS: OUTPUT THE CHARACTER SIZE/LDIR * * TO THE 1350 * ******************************************** * * OUTCS LDA CS GET MNUMONIC FOR CHAR. SIZE JSB WRDST AND PUT IT IN I/O BUFFER LDA LDIR GET THE 1350 LDIR IOR TCSIZ OR IT WITH THE 1350 CSIZE IOR P48 MAKE IT ASCII JSB PTBYT PUT IT IN THE I/O BUFFER LDA COMMA MAKE COMMA THE TERMINATOR JSB PTBYT STICK IT IN THE I/O BUFFER LDA NBYTE GET # BYTES TO OUTPUT LDB P2 JSB OUTPT OUTPUT THE BUFFER TO THE 1350 JSB GCBIM SAVE THE CSIZE AND LDIR IN THE SAVE AREA DEF *+6 RETURN DEF P32 SAVE AREA PTR IN THE GCB DEF P1 1 POINTER DEF BUFLN START OF SAVE AREA VARIABLES DEF P9 9 WORDS (WE DON'T NEED TO SAVE THE CRT#) DEF P2 WRITE IT JMP EMSUB,I EXIT THRU EMULATE ROUTINE * * END EOF Qljffl } 92840-18092 1940 S C0122 &DVG05              H0101 moASMB,R,F,L,C * * * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * * * * * * * NAME: DVG05 -- 7221A/B/S DEVICE SUBROUTINE * * SOURCE: 92840-18092 * * RELOC: 92840-16011 * * * * * * * *************************************************************** * NAM DVG05,7 92840-16011 REV.1940 790726 EXT EXEC,GCBIM EXT EMULX EXT FLTAS EXT REIO EXT INTX EXT .IENT EXT GRSTS EXT DCTIM EXT LNGTH,GIC,DCTAD ENT DVG05 * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 7221 GRAPHICS * PLOTTER. THIS ROUTINE ALONG WITH DVR05 CONTROL THE PICTURE * DRAWING ON THE PLOTTER. * * DVG05 NOP CLA INITIALIZE THE VARIOUS FLAGS STA RWFLG STA FGMBA FLAG MULTIPLE BYTE ANGLE 0=NOT FROM MBA 1=YES STA MBAOF FLAG TO SET BIT 16 OF MBN 0=NO SET 1=YES SET JSB DCTIM GET GIC LNGTH,DCTAD * * THIS IS WHERE WE NEED TO CHECK IF GIC = 177 IF SO * NEED TO DO A LOT OF INTITIALIZING * JSB BUFCK NEED TO CHECK IF BUFFERING IS IN EFFECT LDA GIC CHECK FOR INTIAL COMMAND CPA B177 IS IT THE FIRST ONE JMP INIT YES, CHE'CK THE SIGNON AND THEN EXIT FROM DRIVER LDA .1 READ REQUEST JSB GB32 GO AND READ THE GLOBALS JSB GBLUN GET THE LUN, BUFFER ADDRESS, AND BUFFER LENGTH LDA LPLCM CHECK TO SEE IF PREVIOUS COMMAND WAS LABELING CPA .N2 WAS IT LABELING?? JMP *+2 YES, PROCEED TO OUTPUT A ETX TO TURN OFF LABELING JMP CONTB NO, CONTINUE ON NORMALLY LDA .ETX POINTER TO ETX STA IOB LDA .8 NUMBER OF BYTES LDB .2 WRITE IT OUT JSB OUTPT LDA .N1 NEED TO RESET THE POINTER STA LPLCM FOR LAST PLOTTER COMMAND NON-DRAW CONTB LDA BUFFG NEED TO CHECK IF BUFFERING IS IN EFFECT SZA JMP CONTA YES, BUFFERING THUS WE DO NOT NEED TO PUB ESC.( IN CLA STA CBFCT CLEAR THE COMPUTER BUFFER FLAG LDA ESC. LOAD THE FWA OF THE ESC.( SEQUENCE LDB .3 THERE ARE THREE BYTES JSB TRANS STORE INTO THE BUFFER CONTA LDA DCTAD START CHECKING FOR TYPE OF COMMAND STRING SSA EMULATOR? JMP EMULT YES SZA,RSS A NOP? JMP EXIT1 YES, A NOP SO UPDATE GLOBAL AND EXIT CONT LDB DCTAD ACTUAL COMMAND ADDRESS LDA B,I READ LENGHT OF STRING SSA,RSS READ OR WRITE? JMP CONT0 READ,SET RWFLG=0 ISZ RWFLG WRITE,SET RWFLG=+1 CMA,INA SET BYTE COUNTER POSITVE CONT0 STA NBYTE STORE POSITIVE BYTE COUNTER LDA B INB LDA B,I LOAD THE INFORMATION TYPE STA TYPE LDA RWFLG SZA READ? JMP CONT1 NO, CONTINUE INB YES,NEED TO GET THE NEXT WORD LDA B,I YES, NEED TO LOAD THE INSTRUCTION TYPE FOR READS STA INTYP THIS IS THE LETTER OF THE REAL TIME COMMAND CONT1 INB GET FIRST WORD OF COMMAND STRING STB DCTAD NOW DCTAD POINTS TO THE FIRST COMMAND STRING STB CMDAD STORE AWAY THE COMMAND\ STRING ADDRESS LDA TYPE IS TYPE=0 SZA,RSS JMP LITRT YES, GO TO LITERAL RETURN TO COMPUTER LDA CMDAD LOAD THE STARTING ADDRESS OF TRANSFER LDB NBYTE NUMBER OF BYTES TO TRANSFER CPB B340 NULL LENGTH COMMAND STRING JMP *+2 YES, DON'T TRANSFER ANYTHING JSB TRANS TRANSFER THE DATA LDA RWFLG SZA,RSS IS IT A READ CONT2 JSB RITE YES, TRANSMIT THE BUFFER CONT3 LDA RWFLG SZA,RSS IS IT A READ REQUEST JSB RDCHK YES, GO OFF AND READ THE INPUT LDA .N1 LAST COMMAND FLAG LDB TYPE SSB IS THERE ANY THING SPECIAL TO DO JMP EXIT NO, GO HOME SKP SPC 3 * * * SPECIAL MODE LDA .SPEC LOAD THE FWA OF THE SPECIAL CASES ADA B LOAD WHAT WAS IN TYPE TO FWA TO GET INDEX PROPERLY LDB A,I NEED TO LOAD THE POINTER TO THE ROUTINE JMP B,I GO TO THE PROPER ROUTINE NOW * * * * RESET SPECIAL #1 * RDVAR IS FILLED WITH * GX1,GY1,GX2,GY2 RESPECTIVELY * * NOW WE NEED TO LOAD ~W INTO THE BUFFER * * RESET LDA .RSET INSERT THE DEFAULTS (TILDE,UNDERSCORE) INIT LDB .4 4 BYTES LONG (TILDE,W) SET GRAPHIC LIMITS JSB TRANS TRANSFER THE DATA * * NOW PUT IN THE PARAMETERS FOR GRAPH LIMITS * LDA RWD1 CONVERT GX1,GY1 LDB RWD2 TO MBP STA GX1MU STORE GX1 LOWER LEFT AWAY STB GY1MU STORE GY1 AWAY JSB MBP LDA RWD3 CONVERT GX2,GY2 LDB RWD4 TO MBP STA GX2MU STORE GX2 UPPER RIGHT AWAY STA GY2MU STORE GY2 AWAY JSB MBP * LDA .RSET GET FWA OF THE RESET PREAMBLES ADA .2 GET THE TILDE,S FOR SCALING LDB .2 TWO BYTES LONG JSB TRANS GO AND PUT IT IN THE BUFFER * * LDA RWD1 A=GX2-GX1 CMA,INA ADA RWD3 SSA NEED ABSOLUTE VALUsE OF (GX2-GX1) CMA,INA LDB RWD2 B=GY2-GY1 CMB,INB ADB RWD4 SSB NEED ABSOLUTE VALUE (GY2-GY1) CMB,INB JSB MBP CONVERT TO MBP LDA .RSET GET FWA OF THE RESET PREAMBLES ADA .3 LOOK FOR THE RESET/CHARACTER SIZE LDB .5 IT IS 5 BYTES LONG JSB TRANS GO AND PUT IT IN THE BUFFER LDA .N1 LOAD THE LAST PLOTTER COMMAND TO NON-DRAW JMP EXIT * * * NUMBER 8 * RESET P1,P2 * * GX1,GY1,GX2,GY2 IN RDVAR *NEED TO SEND BACK GX3-GX1, GY4-GY2 * AND UPDATE ~S UPDATE GLOBALS * * GTG12 LDA .RSET GET FWA OF THE ~S PREAMBLE ADA .2 MOVE POINTER TO THE ~S PART LDB .2 G1,G2 SCALLING JSB TRANS PUT (0,GX2-GX1 IN ADDR) LDA RWD1 LOAD THE GX1 LOWER LEFT COORDINATE STA GX1MU STORE IN GLOBAL VARIABLE FLT DST INTX1 PUT IT AWAY TO SEND BACK TO THE COMPUTER LDA RWD2 LOAD THE GY1 LOWER LEFT COORDINATE STA GY1MU GLOBAL FLT DST INTX3 PUT IN BUFFER LDA RWD3 LOAD THE GX2 UPPER RIGHT COORDINATE STA GX2MU GLOBAL FLT DST INTX5 PUT IN BUFFER LDA RWD4 LOAD THE GY2 UPPER RIGHT COORDINATE STA GY2MU GLOBAL FLT DST INTX7 PUT IN BUFFER LDA .RDBF THE BUFFER THE FLT PT NUMBERS ARE LDB .8 8 WORDS TO RETURN JSB GBRET LDB RWD2 B=GY2-GY1 CMB,INB ADB RWD4 SSB RWD4=ABS(GY2-GY1) CMB,INB LDA RWD1 A=GX2-GX1 CMA,INA ADA RWD3 SSA RWD3=ABS(GX2-GX1) CMA,INA JSB MBP PUT THE SCALING DATA AWAY LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN SPC 3 * * * * NUMBER 10 AND 11 * * OUTPUT CURRENT PEN POSITION IN PU * * X,Y PEN STATUS IN RDVAR * * RWsD1=X POSITION IN MACHINE UNITS * RWD2=Y POSITION IN MACHINE UNITS * RWD3=PEN STATUS 0=UP;1=DOWN * * OUTCP LDB .3 NUMBER OF RETURN PARAMETERS LDA RDVAR FWA OF THE DATA JSB GBRET STORE IT IN THE GCBIM LDA .N1 ASSUME THEY SHOULD START OVER FOR LAST PLOT CMD JMP EXIT * * * * NUMBER 12 DIGITIZE * OUTPUT THE DIGITIZED PEN POSITION IN MU. * NEED TO CONVERT PU TO MU * SEND BACK THE RWD1=X POSITION IN MU. * RWD2=Y POSITION IN MU. * RWD3=PEN STATUS 0=UP 1=DOWN * * DIGIT LDA GX1MU LOAD THE GRAPHIC LIMIT X VALUE ADA RWD1 A = GX1MU + CURRENT X POSITION STA RWD1 * CONVERT THE MU LDA GY1MU VALUE TO PU BY OFFSETTING LL AMOUNT ADA RWD2 B = GX2MU + CURRENT Y POSITION STA RWD2 PUT THE Y PLOTTER UNIT VALUE AWAY LDA RDVAR GET THE FWA OF THE BUFFER TO BE TRANSFERED LDB .3 THREE LONG JSB GBRET SEND IT BACK TO THE GICB LDA .N1 ASSUME SHOULD START FOR LAST PLOTTER COMMAND JMP EXIT RETURN * * * * * NUMBER 15 * SET CHARACTER SLANT ON * NEED TO CONVERT TO MBA * * SLANT LDA .16 NEED TO GET THE SLANT ANGLE PARAMETER FROM GCBIM LDB .3 THERE ARE THREE WORDS TO GET JSB GBGET GET IT DLD SLANG LOAD IN 90 DEGREES IN RADIANS FSB INTX2 7221 SLANT = 90 DEGREES - AGL SLANT ANGLE JSB MBA LDA .N1 LAST PLOTTER COMMAND IS NOT-DRAW JMP EXIT * * NUMBER 17 * * CONVERT X,Y PARAMETER IN GCBIM TO MBP * FLOATING POINT PARAMETERS * MBPOT LDA .16 GET THE FLOATING POINT PARAMETERS LDB .5 THERE ARE FIVE WORDS JSB GBGET DLD INTX4 LOAD THE Y PORTION OF MBP JSB .IENT INTEGERIZE THE FLOATING POINT NUMBER NOP STA INTX1 v| STORE INTEGER VALUE AWAY DLD INTX2 LOAD THE Y PROTION OF MBP JSB .IENT INTEGERIZE THE FLOATING POINT NUMBER NOP LDB INTX1 JSB MBP CONVERT THE DATA LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * NUMBER 24 * * CONVERT X,Y PARAMETER IN GICBM MBP * * THIS IS THE INTEGER FORMAT * * MBPBN LDA .16 GET THE PARAMETERS FROM THE GIC LDB .3 THERE ARE TWO INTEGER FORMAT NUMBERS + THE HEADER JSB GBGET LDA INTX2 GET THE X VALUE LDB INTX3 GET THE Y VALUE JSB MBP CONVERT THE DATA TO MBP FORMAT LDA .N1 LAST PLOTTER COMMND IS A NON-DRAW JMP EXIT RETURN * * * * NUMBER 28 * SELECT PEN (1-N) * * SLPEN LDA .16 SELECT PEN (); GET THE DATA FROM GIC LDB .2 THERE IS THE HEADER AND THE PEN NUMBER JSB GBGET LDA INTX2 LOAD THE PEN NUMBER JSB SBN CONVERT TO BINARY SYNTAX LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * * NUMBER 31 AND 32 * * ENTER RWD1 = LINETYPE * NEED TO FIND OUT IF * LNGHT=1 IMPLIES DEFAULT LENGTH * LNGTH=2 IMPLIES SPECIFIED LENGTH * * DASHL LDA .16 GET PARAMETERS FROM GIC LDB .4 THERE ARE 4 WORDS HEADER,LINETYPE,FL PT LENGTH JSB GBGET LDB INTX2 LOAD THE LINE TYPE NUMBER IN ADB .LNTP ADD TO INDEX OF LINETYPES LDA B,I LOAD THE POINTER TO # OF BYTES LDB A,I NOW LOAD THE NUMBER OF BYTES IN INA INCREMENT OVER THE 1ST WORD OF INSTRUCTION STRING JSB TRANS GO AND TRANSMIT IT * * NOW CHECK FOR LINE TYPE * LDA INTX2 LOAD THE LINE TYPE AGAIN CPA .5 IS THE LINETYPE (DOTS AT END POINTS) JMP DASH0 YES, THE LENGTH IS ENCODED AREADY IN THE STRING CPA .0 y IS THE LINE TYPE (SOLID LINES) JMP DASH0 YES, THE LENGTH IS NOT SENT OUT CPA .1 IS THE LINETYPE (DIME LINES) JMP DASH0 YES, THE LENGTH IS NOT SENT OUT LDA .460 LOAD THE DEFAULT LENGTH LDB GIC LOAD THE TYPE OF COMMAND CPB .31 IS A DASHLINE WITH DEFULT LENGTH JMP DASH1 YES, USE .460 AS THE DEFAULT LENGTH DLD INTX3 LOAD THE FLOATING POINT NUMBER IN A/B JSB .IENT INTEGERIZE NOP DASH1 JSB MBN CONVERT DATA DASH0 LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * * NUMBER 43 * POSITION CURSOR ABSOLUE WITH PEN UP * PEN = CURSOR ON THIS PLOTTER, THUS WE ONLY NEED TO * USE REGULAR MOVE; THIS ACTUAL USES THE MBPBN ROUTINE * * * MVCUR LDA .16 GET THE PARAMETERS FROM THE GIC LDB .3 THERE ARE TWO INTEGER FORMATS NUMBER +HEADER JSB GBGET LDA GX1MU LOAD THE OFFSET CMA,INA A = X PU - X OFFSET ADA INTX2 LDB GY1MU LOAD THE Y OFFSET CMB,INB B = Y PU - Y OFFSET ADB INTX3 JSB MBP CONVER THE DATA TO MBP FORMAT LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * * * * NUMBER 45 * USED TO SET THE GRAPHIC LIMITS G1 AND G2 * THE PARAMETERS ARE INTEGER FROM THE GIC * * * SG1G2 LDA .16 SET G1 AND G2; GET THE PARAMETERS LDB .5 FIVE WORDS INCLUDING HEADER JSB GBGET LDA INTX2 GET GX1 LDB INTX3 GET GY1 STA GX1MU STORE GLOBAL GX1 AWAY STB GY1MU STORE GLOBAL GY2 LOWER LEFT AWAY JSB MBP GO CONVERT THE LOWER LEFT HAND CORNER LDA INTX4 GET GX2 LDB INTX5 GET GY2 STA GX2MU STORE GLOBAL GX2 UPPER RIGHT AWAY STB GY2MU STORE GLOBAL GY2 JSB MBP GO CONVERT THE UPPER RIGHT HAND CORNER LDA .RSET NEED TO LOAD THE GRI;DDING FACTOR ADA .2 THIS IS A TILDE,S INSTRUCTION LDB .2 THERE ARE TWO BYTES JSB TRANS LDA INTX2 NEED TO CALCULATE THE GRID RANGE CMA,INA A = ABS( GX2 - GX1) ADA INTX4 SSA MAKE SURE ITS A POSITIVE RANGE CMA,INA LDB INTX3 NEED TO CALCULATE THE Y COMPONENT CMB,INB B = ABS( GY2 - GY1) ADB INTX5 SSB MAKE SURE ITS A POSITIVE RANGE CMB,INB JSB MBP LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT SKP SPC 3 * * A = EMULATOR # COMES IN AS A NEGATIVE NUMBER * * THIS IS USED TO FIND THE CORRECT EMULATOR TO EXECUTE * * EMULT CMA,INA THIS IS THE EMULATOR SECTION LDB EM0 FWA OF EMULATOR POINTERS ADA B NOW INDEX TO THE PROPER PLACE LDB A,I NEED TO LOAD THE POINTER TO THE ROUTINE JMP B,I JUMP TO THE PROPER ROUTINE SPC 3 * * * NUMBER 3 * PAGE FEED * * A PAGE FEED COMMAND WILL BE GIVEN HERE THE 7221. IF THE * PLOTTER IS A 7221A OR 7221B THE PLOTTER WILL GIVE AN ERROR. * (THE 7221S WITH CHART ADVANCE PAPER WILL GIVE A PAGE FEED). * THE ERROR STATE WILL BE READ TO CLEAR THE ERROR CONDITION. * * PAGEF LDA .MCMD LOAD ADR OF COMMAND STRING (PG) LDB .3 TRANSFER NUMBER OF BYTES IN COMMAND(+TERM) JSB TRANS AND SEND IT * * SINCE THE 7221A WILL GIVE AN ERROR WITH A PAGE FEED COMMAND * AN OUTPUT ERROR WAS SENT TO CLEAR THE ERROR AT THE END OF * THE LAST COMMAND STRING. NOW WE MUST READ FROM THE PLOTTER * TO CLEAR THE BUS. * JSB RITE WRITE OUT BUFFER * JSB RWAIT WAIT UNTIL BUFFER IS EMPTY * LDA .MOE LOAD ADR OF MY OUTPUT ERROR CMD STA IOB STORE IT. LDA .7 SEND ( ESC.(ESC.E LDB .2 WRITE OUT CMMD JSB OUTPT DO THE DEVICE WRITE * LDA .RDBF START OF READ IO AREA STA IOB * LDA .40 MAX OF 40 BYTES TO READ LDB .1 READ BACK ERROR NUM ETC JSB OUTPT PERFORM READ * JMP HOME ALL DONE WITH PAGE FEED SEND THE PEN HOME * * * * * NUMBER 4 * TRANSMIT I/O BUFFER * * ONLY NEED TO EMPTY THE BUFFER IF IT HAS ANYTHING * * XMIT JSB RITE GO AND EMPTY THE COMPUTER BUFFER LDA .N1 ASSUME SHOULD START FOR LAST PLOTTER COMMAND JMP EXIT * * * * * NUMBER 5 * HOME PEN * * GET THE UPPER RIGHT HARD CLIP REGION * * HOME LDA .P LOAD SMALL P IN BUFFER LDB .1 1 BYTE LONG JSB TRANS LDA GX1MU NEED TO CALCULATE THE RANGE CMA,INA A=ABS(GX2-GX1) ADA GX2MU SSA CMA,INA LDB GY1MU NEED TO CALUCLATE Y RANGE CMB,INB B=ABS(GY2-GY1) ADB GY2MU SSB CMB,INB JSB MBP CONVERT IT LDA .1 LAST PLOTTER COMMAND WAS A MOVE + PARAMETER JMP EXIT RETURN * * * NUMBER 5 * GET CHARACTER SPACING/WIDTH * * NEED TO GET OLD VALUE * * GTCHR JSB GCBIM CALL GCBIM(7,1,(),4,1) DEF *+6 DEF .7 GET CHARACTER SPACING HEIGHT/WIDTH DEF .1 DEF INTX1 PUT INTO BUFFER LOCATION DEF .4 NEED TWO FLOATING POINT NUMBERS DEF .1 READ * * NOW CHECK FOR DEFAULTS * DLD INTX1 WIDTH SZA,RSS IS WIDTH = 0 SZB JMP EML1 NOT EQUAL 0, THUS USE GICB VALUES. DLD INTX3 CHECK THE HEIGHT SZA,RSS IS THE HEIGHT = 0 SZB JMP EML1 # = 0 THUS USE THESE VALUES DLD CHRW THUS WIDTH AND HEIGHT = 0 IMPLY DEFAULTS DST INTX1 STORE THE DEFAULT WIDTH DLD CHRH DST INTX3 STORE THE DEFAULT WIDTH EML1 LDA .RDBF LOCATION OF BUFFER LDB .4 FOUR ITEMS TuO BE TRANSFERRED JSB GBRET TRANSFER TO GICB LDA .N1 ASSUME SHOULD START OVER FOR LAST PLOTTER CMD JMP EXIT RETURN CHRW DEC 125. CHARACTER WIDTH CHRH DEC 250. CHARACTER HEIGHT SPC 3 * * * * NUMBER 35 * PLOT ABSOLUTE * * CPENS = 0 IMPLIES UP * 1 IMPLIES DOWN * * LPLCM = -1 IMPLIES NON-MOVE OR NON-DRAW COMMAND * 1 IMPLIES DRAW AND MOVE WITH PARAMETERS * PLABS LDB CPENS PLOAT ABSOLUTE, LOAD COMPUTER PEN STATUS 0=UP,1=DN LDA BUFFG BUFFER FLAG 0=NO BUFFERING 1 = YES BUFFERING SZA,RSS IS THERE BUFFERING JMP PLAB3 NO,THUS WE NEED TO PUT IN THE MOVE OR DRAW IN CPB LPLCM YES, CHECK FOR REDUNDENT DRAWS, PEN AND LAST CMD = JMP PLAB2 YES, JUST NEED TO CONVERT DATA TO MBP FORM PLAB3 LDA .P NO, NEED TO INSERT P/Q SZB IS IT A DRAW OR A MOVE?? LDA .Q YES, USE DRAW LDB .1 1 BYTE LONG JSB TRANS INSERT COMMAND PLAB2 LDB LNGTH LOAD THE NUMBER OF PARAMETERS IN WORDS INB NEED TO ADD ONE FOR THE HEADER INFORMATION LDA .16 JSB GBGET GO AND GET THE PASSED PARAMETERS LDA .RDBF NEED TO SET-UP THE INDEX POINTER INA MOVE ONE PAST THE HEADER INFORMATION STA PLTCT PLOT ABSOLUTE POINTER LDB LNGTH NOW SET UP THE LOOP CONTROL COUNTER CMB,INB STB LNTH LENTH OF THE LOOP COUNTER PLAB1 LDA GX1MU NEED TO CALCULATE THE P.U. FROM M.U. CMA,INA X MU = X PU - X OFFSET(GX1) ADA PLTCT,I ISZ PLTCT MOVE POINTER TO THE LDB GY1MU NEED TO CALCULATE PU FROM MU CMB,INB Y MU = Y PU - Y OFFSET(GY1) ADB PLTCT,I ISZ PLTCT SET TO THE NEXT COORDINATE PAIR JSB MBP GO AND CONVERT LDA LNTH CHECK TO SEE IF WE HAVE ANY MORE PARAMETERS ADA .2 NOTE THIS IS A DO UNTIL STRUCTURE AND THUS g STA LNTH ASSUME WE SHOULD GO THROUGH AT LEAST ONCE SSA ARE YES DONE?? JMP PLAB1 NO, DO THE NEXT PAIR LDA .1 YES, LOAD DRAW AS THE LAST PLOTTER COMMAND JMP EXIT RETURN SPC 3 * * * * NUMBER 38 AND 39 * SHORT AND LONG LABEL * * * * LABEL JSB CKANG LABEL MODE AND NEED TO CHECK THE PLOTTER ANGLE JSB RITE GO AND OUTPUT THE CURRENT BUFFER LDA .N2 LAST PLOTTER COMMAND IS A LABEL ON MODE STA LPLCM WILL BE USED AS FLAG IN READ NOT TO TURN OFF PLOTTER JSB RWAIT GO AND WAIT UNTIL THE PLOTTER BUFFER IS EMPTY LDA .LLAB IT IS A LONG LABEL STA IOB STORE AWAY FWA FOR OUTPUT LDA .5 NUMBER OF BYTES TO OUTPUT LDB .2 WRITE JSB OUTPT WRITE IT OUT TO THE PLOTTER INHIBIT CR/LF LDA .0 SINCE WE DON'T KNOW HOW MUCH THE USER WILL PUT INTO STA PBFLN PLOTTER BUFFER ASSUME THERE IS NO SPACE JMP EXIT1 BY PASS THE OUTPUT OF EXIT * * * NEED TO LOOK AT THIS ALOT MORE * * NUMBER 42 * FLOAT ASCII * * CONVT JSB CKANG NEED TO CHECK THE PLOTTER ANGLE JSB RITE NEED TO FLUSH OUT THE COMPUTER BUFFER SO WE CAN * GUARANTEE THE ASCII LABEL WILL BE SENT CONTINOUS. LDA .LLAB CONVERT FLOATING POINT TO ASCII LDB .5 JSB TRANS TRANFER SHORT LABEL OVER LDA .16 NEED TO GET THE FLOATING POINT NUMBER LDB .3 1 WORD FOR HEADER + 2 WORDS FOR FLT PT NUMBER JSB GBGET GET NUMBER DLD INTX2 GET THE NUMBER AND PUT INTO THE SMALLER BUFFER DST RWD1 THIS WILL ALLOW FLOAT TO ASCII ROUTINE MORE SPACE LDA .0 LOAD THE BYTE COUNTER STA TEMP USE A TEMPORARY VARIABLE CAUTION JSB FLTAS FLOAT TO ASCII ROUTINE DEF RTFL RETURN POINT DEF RWD1 THE NUMBER TO BE CONVERTED (FROM BUFFER) DEF INTX1 THE CONVERTED ASCII NUMBER (TO BUFFER) DEF TEMP THE NUMBER OF BYTES DEF FXDN THE FLOATING POINT FRACTION REPRESENTATION DEF SKPBK USE FOR FUTURE ENHANCEMENTS RTFL LDA .RDBF POINTER TO THE ASCII NUMBER BUFFER LDB TEMP THE NUMBER OF BYTES TO TRANSFER JSB TRANS LDA DFETX POINTER TO THE B1400 WHICH IS A ETX. LDB .1 NEED ONLY ONE BYTE, THIS IS A TERMINATOR JSB TRANS FOR THE SHORT LABEL MODE LDA .N1 JMP EXIT * * CHARACTER PLACEMENT * CPLMT LDA ACINF LDB .8 JSB GBRET LDA .N1 JMP EXIT * ACINF DEF CINFO * CINFO DEC 0.00000 DEC 0.66667 DEC 0.00000 DEC 0.50000 * * * * CKANG NOP CHECK ANGLE OF PLOTTER COMPARED TO LABEL LDA .22 GET THE LABEL ANGLE LDB .2 TWO WORDS LONG; REPRESENTS A FLT PT NUMBER JSB GBGET LDA INTX1 GET THE ANGLE OF ROTATION CPA PANG1 DOES LABEL ANGLE = PLOTTER ANGLE JMP *+2 YES THE FIRST PART DOES GO CHECK 2 WORD JMP SLAN0 NO, GO AND SEND THE ANGLE TO THE PLOTTER LDB INTX2 GO AND CHECK THE SECOND WORD OF FLT PT # CPB PANG2 ARE THE TWO ANGLES EQUAL JMP CKAN1 YES, AND SKIP OUTPUTTING THE ANGLE TO PLOTTER SLAN0 LDA .WW WRITE OUT "WW"; SEND LABEL ANGLE LDB .2 TWO BYTE LONG JSB TRANS LOAD PRE-AMBLE DLD INTX1 LOAD AND CONVERT JSB MBA CONVERT TO MULTIBYTE ANGLE DLD INTX1 UPDATE GLOBAL DST PANG1 PLOTTER ANGLE CKAN1 JMP CKANG,I RETURN SPC 3 * * * NUMBER 2 * USED TO DEFAULT LL AND UR * * DFG12 LDA .520 NEED TO UPDATE THE GLOBALS STA GX1MU X LOWER LEFT LDA .1572 ACTUALLY LOADING IN 15720 STA GX2MU X UPPER RIGHT LDA .380 STA GY1MU Y LOWER LEFT LDA .1038 ACTUALLY LOADING IN 10380 STA GY2MU Y UPPER RIGHT  LDA .N1 LAST PLOTTER COMMAND WAS NOT A DRAW JMP EXIT RETURN * * * * NUMBER 33 * PEN UP ROUTINE * NEED ONLY TO STORE THE GLOBAL AWAW * CPENS COMPUTER PEN STATUS 0=UP 1=DOWN PENUP CLA SET CPENS=0 IMPLES PEN UP STA CPENS LDA .0 MEANS THE LAST WAS A PEN-UP COMMAND JMP EXIT GO AND UPDATE THE GLOBALS * * * * NUMBER 34 * PEN DOWN ROUTINE * NEED TO ONLY SOTRE THE GLOBALS AWAY * CPENS COMPUTER PEN STATUS 0=UP 1=DOWN * PENDN LDA BUFFG CHECK TO SEE IF WE ARE BUFFERING SZA,RSS IF SO NEED TO CHECK PEN STATUS JMP PEND1 NO, SO GO AHEAD AND INSERT THE LOWER CASE Q LDA LPLCM YES, CHECK THE LAST PLOTTER COMMAND CPA .1 WAS IT A DRAW?? JMP PEND2 YES, DON'T OUTPUT THE LOWER CASE Q PEND1 LDA .Q POINTER TO THE LOWER CASE Q LDB .1 ONE BYTE LONG JSB TRANS OUTPUT IT TO THE BUFFER PEND2 LDA .1 LAST PLOTTER COMMAND STA CPENS COMPUTER PEN STATUS GLOBAL JMP EXIT FINISH IT UP SKP SPC 3 * * SPC 3 * * * * * ENTER A=FWA OF DATA TO INPUT * B=NUMBER OF BYTES * * CBFCT = EXACT NUMBER OF BYTES * CURRENTLY IN THE BUFFER * RANGE 0 TO N RANGE. * * * TRANS NOP TRANSFER THE ENTER BUFFER IN A TO IOBUFFER STB BYTES STORE THE NUMBER OF BYTES TO BE TRANSFERRED SZB,RSS ARE THERE ANY BYTES TO BE TRANSFERRED JMP TRANS,I NO, GO BACK STA TEMP7 STORE AWAY THE FWA POINTER JSB CBFCK CHECK THE BUFFER SPACE LDB TEMP7 GET THE FWA POINTER LDA CBFCT GET THE COMPUTER BUFFER COUNT ARS SHIFT THE NUMBER OF BYTES TO NUMBER OF WORDS TO ADA CBFAD THIS POINTS TO FIRST ENTRY 1 STA TEMP9 PTR TO 1ST WORD WITH AVAILABLE SPACE LDA CBFCT IS THERE ODD NUMBER OF BYTES SLA IN THE IO BUFFER?? JMP TRAN3 YES, ODD NUMBER OF BYTES LDA BYTES SET UP THE LOOP COUNTER INA ROUND UP THE THE NEAREST WHOLE INTEGER ARS CMA,INA NEGATE THE LOOP COUNTER STA TLOOP TRAN2 LDA B,I NO, EVEN NUMBER OF BYTES THUS ITS EASY STA TEMP9,I STORE AWAY IN THE IO BUFFER INB INCREMENT THE FROM BUFFER AREA ISZ TEMP9 INCREMENT THE TO BUFFER AREA POINTER ISZ TLOOP ARE WE DONE? JMP TRAN2 NO, GO THRU AGAIN JMP TRAN6 YES, GO AND UPDATE THE GLOBALS TRAN3 LDA BYTES SET UP THE LOOP COUNTER CMA,INA NEGATE THE LOOP COUNTER STA TLOOP TRAN4 LDA B,I LOAD THE WORD FROM BUFFER ALF,ALF NEED THE HIGH BYTE AND LOBYT MASK OFF THE BYTE STA TEMP8 STORE HIBYTE INTO LOW BYTE OF TEMP8 LDA TEMP9,I GET THE TO BUFFER WORD AND MASK OFF HIGH BYTE AND HIBYT IOR TEMP8 STORE HIBYTE INTO LOW BYTE STA TEMP9,I STORE AWAY THE FIRST HALF OF FROM BUFFER WORD ISZ TEMP9 INCREMENT THE TO BUFFER POINTER ISZ TLOOP INDEX LOOP COUNTER JMP *+2 CONTINUE THE LOOP JMP TRAN6 DONE LDA B,I LOAD THE SECOND BYTE UP ALF,ALF MOVE THE HIGH BYTE TO LOW BYTE AND HIBYT GET THE HIGH BYTE STA TEMP9,I STORE AWAY THE HIGH BYTE;WITH LOW BYTE CLEAR INB MOVE TO THE NEXT WORD ISZ TLOOP ARE WE DONE? JMP TRAN4 NO GO THRU THE LOOP AGAIN TRAN6 LDA CBFCT UPDATE THE GLOBAL ADA BYTES STA CBFCT JMP TRANS,I RETURN SPC 3 * * * SPC 3 * * INTIALIZING ROUTINE * THIS IS DONE EVERYTIME THE SYSTEM DOES A RESET * WE NEED TO INIT THE VARIOUS GLOBAL VARIABLES * * * INIT CLA [ NEED TO INITIALIZE THE GLOBAL FOR DRIVER PACKAGE STA CBFCT UPDATE GLOBALS; COMPUTER BUFFER COUNT STA PANG1 PLOTTER ANGLE FOR CHAR/RELATIVE MOVES STA PANG2 SECOND PART OF THE FLOATING PT. ANGLE STA CPENS COMPUTER PEN STATUS STA GX1MU LOWER LEFT GRAPHIC LIMITS STA GX2MU UPPER RIGHT GRAPHIC LIMITS STA GY1MU LOWER LEFT STA GY2MU UPPER RIGHT LDA .38 NEED TO ASSUME THERE IS SOME SPACE INTIALLY STA PBFLN PLOTTER BUFFER LENGTH LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW STA LPLCM JSB GBLUN LDA ESC. LOAD THE FWA OF THE ESC.( SEQUENCE LDB .3 THREE BYTES TO TRANSFER JSB TRANS TRANSFER THE ESC SEQ TO THE COMPUTER BUFFER LDA .HAND NEED TO LOAD THE HANDSHAKING STUFF LDB .19 THERE ARE 19 BYTES JSB TRANS GO AND TRANSFER IT JSB EMULX,I INTERROGATE DEVICE COMMAND TABLE CPA .7221 RIGHT COMMAND TABLE?? JMP INIT3 YES, GO AND CHECK PROPER I/O DRIVER LDA .3 NO, REPORT ERROR JMP INIT5 INIT3 JSB IFTTY GO AND CHECK IF DVR05 DEF *+2 DEF LUN LDA DTYPE CPA B2400 IS IT DVR05? JMP INIT4 YES, EVERTHING IS OK LDA .5 NO, REPORT ERROR JMP INIT5 INIT4 CLA EVERYTHING IS OK RETURN A ZERO INIT5 STA INTX1 PUT THE RETURN VARIABLE IN BUFFER LDA .RDBF POINTER TO READ BUFFER LDB .1 ONE PARAMETER TO RETURN JSB GBRET RETURN SUBROUTINE LDA .N1 LOAD THE LAST PLOTTER COMMAND MEANS NON-DRAW JMP EXIT EXIT ROUTINE * * IFTTY NOP ENTRY POINT TO GET DRIVER NUMBER DLD IFTTY,I GET RETURN ADDRESS AND LUN STA IFTTY STORE THE RETURN ADDRESS LDA B,I GET THE LOGICAL UNIT NUMBER AND B77 MASK OFF THE TRANSPARENT BIT STA ANLU# SAVE LUN NUMBER JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF ANLU# THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BITS HERE * JMP ITSNT ERROR NOT VALID LUN NUMBER, SEND BACK ZERO LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD STA DTYPE JMP IFTTY,I GO BACK ITSNT CLA SET NON-INTERACTIVE FLAG JMP IFTTY,I GO BACK * * D13I OCT 100015 EXEC #13., AND ERROR CHECK INVOKED .7221 DEC 7221 NAME OF PLOTTER B2400 OCT 2400 MASK FOR PROPER DRIVER NUMBER (5) MEQT OCT 37400 MASK OFF THE DRIVER NUMBER ANLU# NOP LUN NUMBER TO FIND INFO ABOUT DTYPE NOP TEMPORARY VARABLE YTEMP NOP ZTEMP NOP SPC 3 * * EXIT ROUTINE CHECK NEED TO STORE THE LAST PLOTTER CO * AND CHECK THE BUFFG BUFFER FLAG FOR RITE OR NOT * ALSO UPDATE THE GLOBAL VARIABLES IN GICB * * * A = NUMBER FOR LAST COMMAND * 0 = DRAW * 1 = MOVE * -1 = OTHER COMMANDS * * * CHECK FOR EXIT OUT OF THE ROUTINES EXIT STA LPLCM STORE LAST PLOTTER COMMAND LDA GIC XMIT GIC IF SO WE NEED TO FORCE A LOWER CASE CPA .4 Z IN THERE TO TERMINATE THE TOTAL SEQUENCE JMP EXITA PUT THE TERMINATOR IN AND SEND IT OFF LDA BUFFG BUFFER FLAG 0=NO BUFFERING; 1=YES BUFFERING SZA IS THERE BUFFERING JMP EXIT1 YES, DO NOT TRANSMIT THE BUFFER LDA CBFCT LOAD THE COMPUTER BUFFER COUNT CPA .3 CHECK TO SEE IF IT IS AN EMPTY BUFFER JMP EXIT1 YES, IT IS DON'T WRITE ANYTHING OUT EXITA LDA .Z NO, PUT IN TERMINATOR AND TRANSMIT THE BUFFER LDB .1 ONLY ONE LONG JSB TRANS TRANSM>IT IT LDA .N1 NEED TO PUT IN NON-DRAW/NON-MOVE STA LPLCM PUT IT AWAW EXIT0 JSB RITE GO AND TRANSMIT THE COMPUTER BUFFER EXIT1 LDA .2 WRITE JSB GB32 UPDATE THE GLOBALS JMP DVG05,I RETURN, AND LET'S GO HOME SPC 3 * * * * * SPC 3 * * * RETURN VALUE IN BUFFER FLAG * BUFFG 0 = NO, BUFFERING * 1 = YES, BUFFERING * * THIS ROUTINE WILL GO AND GET THE BUFFERING STATUS * BUFCK NOP SEE IF BUFFERING IS IN EFFECT JSB GRSTS CHECK TO SEE IF BUFFERING DEF BUFRT IS IN EFFECT DEF .1 GET STATUS DEF B1000 GET BIT 9;BUFFERING STATUS BIT DEF BUFFG RETURN VALUE; 0 =NO; 1=YES; I/O BUFFERING BUFRT JMP BUFCK,I * * * * * * * IS USED TO CHECK FOR COMPUTER BUFFER FULL * * ENTER WITH B = NUMBER OF BYTES TO ADD TO COMPUTER BUFFER * CBFCK NOP CHECK FOR COMPUTER BUFFER FULL ADB .3 B=TOTAL OF COMPUTER BUFFER SPACE NEEDED ADB CBFCT 3 IS ADDED TO END FOR THE ESC . ) SEQUENCE CMB,INB ADD COMPUTER BUFFER COUNT ADB CBFLN B=CBFLN-(CBFCT+ADDITIONAL DATA) SSB IS THERE GOING TO BE ANY OVERFLOW JSB RITE YES; NEED TO OUTPUT THE DATA TO PLOTTER JMP CBFCK,I NO, RETURN * * * * * * * * * * * SPC 3 * * RITE NOP OUTPUT THE COMPUTER BUFFER TO THE PLOTTER LDA .3 NEED TO CHECK FOR AN EMPTY BUFFER CPA CBFCT THERE ARE ALWAYS AT LEAST THREE IN BUFFER JMP RITE,I RETURN JSB CKPSI NEED TO CHECK PLOTTER BUFFER SIZE JSB TRBYT NEED TO ADD TERMINATOR TO END;UPDATE CBFCT LDA CBFAD COMPUTER BUFFER ADDRESS STA IOB LOCATION OF BUFFER TO OUTPUT LDA CBFCT NUMBER OF BYTES LDB .2 WRITE JSB OUTPT LDA CBFCT UPDATE PLOTTER BUFFER LENGTH CMA,INA ADA PBFLN PBFLN=PBFLN-CBFCT STA PBFLN JSB GBLUN GET THE ACTUAL COMPUTER BUFFER ADDRESS LDA CBFAD LDB ESC.1 NEED TO INSERT THE ESC.( SEQUENCE IN I/O BUF STB A,I INA LDB ESC.2 STB A,I LDA .3 THIS IS THE STARTING COMPUTER BUFFER COUNT STA CBFCT RESET THE COMPUTER BUFFER COUNTER JMP RITE,I GO BACK * * * WANT TO MAKE THIS TRANSPARENT TO THE REST OF THE * SYSTEM ,WHICH WILL ENABLE THE ENQ/ACK HANDSHAKE * TO WORK BY TAKING THIS OUT. * * IS THRE ROOM IN THE PLOTTER * * CKPSI NOP CHECK PLOTTER SIZE CKPS LDA CBFCT CMA,INA COMPUTER BUFFER COUNT ADA PBFLN A=PLOTTER BUFFER LENGTH - COMPUTER BUFFER COUNTER SSA,RSS IS THERE ROOM IN THE PLOTTER JMP CKPSI,I YES, GO BACK * NO, NEED TO OUTPUT AS MUCH AS WE CAN, LESS ONE THEN * WE UPDATE THE PTR'S AND COUNTER AND LET THE CALLING * ROUTINE FINISH THE LAST WRITE TO THE DEVICE.. * * * NEED TO FIX THE NEXT ROUTINE UP HAVE A PROBLEM OF OUTPUTING * PARTIAL DATA ARRAY AMOUNT. * ALSO NEED TO UPDATE THE GLOBALS PBFLN,CBFCT,CBFAD * CKPS0 LDA PBFLN CKECK TO SEE IF WE NEED MORE ROOM IN PLOTTER CKPS2 ADA .N20 MAKE SURE THERE AT LEAST 20 BYTES AVAILABLE SSA,RSS IS THERE ANY ROOM JMP *+3 YES, OUTPUT IT JSB RDBFL NO, READ NEW BUFFER AVAILABLE LENGTH JMP CKPS NEED TO GO AND COMPARE AGAINST COMPUTER BUFFER LENGTH LDA CBFAD LOAD THE COMPUTER BUFFER LOCATION STA IOB THIS WILL BE USED AS OUTPUT POINTER LDA PBFLN NOW CHECK AMOUNT OF ROOM IN PLOTTER BUFFER ARS ROUND TO THE NEAREST WORD STA TEMP2 PLOTTER BUFFER LENGHT ROUNDED DOWN TO NEAREST WORD ADA CBFAD STORE AWAY THE TWO WORDS THAT WILL BE * PLACED REPLACED WITH THE ESC.)N SEQUENCE LDB A,I STB OUT1 LDB TERM STB A,I PUT THE ESC.) SEQUENCE AT THE END INA LDB A,I STB OUT2 NOW WE HAVE PUT IT IN OUT1,OUT2 LDB TERM1 REST OF THE ESC.) SEQUENCE STB A,I LDA TEMP2 ALS CONVERT TO # OF BYTES FROM # OF WORDS ADA .4 A = NUMBER OF BYTES TO TRANSMIT LDB .2 WRITE JSB OUTPT OUTPUT THE DATA CLB NOW UP DATE THE PLOTTER BUFFER LENGTH STB PBFLN ALWAYS ASSUME THERE IS NO SPACE LEFT * IN REALITY IT SHOULD BE A ONE OR ZERO;TAKE WORSE CA LDA TEMP2 UPDATE THE GLOBALS ALS CONVERT TO NUMBER OF BYTES CMA,INA ADA CBFCT CBFCT = CBFCT - AMOUNT OF DATA SENT ADA .4 ROOM FOR THE PREAMBLE REMEMBER THERE IS A NULL THERE STA CBFCT NEEDED TO UPDATE THE COMPUTER BUFFER COUNT LDA TEMP2 ADA CBFAD THE START OF THE SEQUENCE ADA .N2 NEED TO ADD ESC.( SEQUENCE BACK IN BEGINNING STA CBFAD UPDATE COMPUTER BUFFER ADDRESS(LOCATION) LDB .N4 LOOP COUNTER STB TEMP2 LDB TBUF FWA OF THE ESC.( OUT1 OUT2 SEQUENCE BUFFER STB TEMP3 CKPS1 LDB TEMP3,I STORE THE PREAMBLE & RESTORE THE REPLACED DATA STB A,I ISZ TEMP3 INA ISZ TEMP2 JMP CKPS1 GO AND DO ANOTHER LOOP JMP CKPS WE ARE DONE GO BACK * * * VARIABLES FOR THIS ROUTINE * * TBUF DEF ESC FWA OF THE ESC.( OUT1 OUT2 BUFFFER ESC OCT 33 ESCAPE CHARACTER (NULL,ESC) .LP OCT 027050 DOT LEFT PARAN (PERIOD,LEFT PARENTHESIS) OUT1 NOP TEMPORARY STORAGE OUT2 NOP TEMPORARY STORAGE TEMP2 NOP TEMPORARY STORAGE .ASKB DEF ASKB THE POINTER TO THE ESC.(ESC.B SEQUENCE ASKB OCT 15456 ESC . OCT 24033 ( ESC OCT 027102 . B * * * * * BE NICE IF THERE WAS A PAUSE HERE TO ALLOW TIME * OFOR THE PLOTTER TO MUNCH ON DATA BEFORE ANOTHER IO * RDBFL NOP READ THE PLOTTER BUFFER SIZE ESC . B SEQUENCE LDA .ASKB POINTER TO THE ESC . B SEQUENCE STA IOB LOCATION OF THE BUFFER ESC.(ESC.B SEQUENCE LDA .1 NUMBER OF PARAMETERS TO CONVERT STA LEN THERE ARE ONE PARAMETER ON A BUFFER SIZE REQUEST JSB READ GO AND READ THE BUFFER SIZE LDA RWD1 LOAD THE NUMBER OF BYTES AVAILABLE IN THE BUFFER ADA .N40 NEED TO SUBSTRACT THE PREBUFFER IN 7221 STA PBFLN PLOTTER BUFFER LENGHT JMP RDBFL,I RETURN * * SKP SPC 3 * * READ THE GLOBAL VARIABLES * * GCBIM(32,1,(),?,1) * READ = 1 * WRITE = 2 * * GB32 NOP GCBIM(32,1,(),?,1) STA RW READ WRITE FLAG JSB GCBIM DEF *+6 DEF .32 GET GCBIM GLOBAL DATA DEF .1 ONE ITEM DEF CBFCT LOCATION OF BUFFER DEF .10 NUMBER OF ITEMS DEF RW READ/WRITE FLAG JMP GB32,I * * * * GET IOBUF ADDRESS PTR AND IOBL BLOCK LENGTH * GCBIM(2,1,(),2,1) * * * GBLUN NOP GET IOBUF ADDR, IOBL LENGTH, LUN JSB GCBIM DEF GBLRT DEF .2 NOTE WE ARE GOING TO READ ITEMS 2,4,26 DEF .3 NOTE THAT WE ARE GOING TO READ 3 GICBM ITEMS DEF LUN NOTE THAT LUN,CBFAD,CBFLN,FXDN MUST BE IN SEQUENCE DEF .0 TAKE THE DEFAULT FOR THE 3 ITEMS DEF .1 READ GBLRT LDA LUN ESTABLISH TRANSPARENT MODE IN DVR05 IOR B2000 SET BIT-10 FOR TRANSPARENT MODE IN DVR05 STA LUN LDA CBFLN LOAD THE COMPUTER BUFFER LENGHT ADA .N1 REDUCE THE SIZE BY ONE WORD ALS CONVERT WORDS TO BYTES STA CBFLN NOW BUFFER LENGTH IS IN BYTES JMP GBLUN,I RETURN * * * * ENTER A = GICBM # TO READ * B = NUMBER OF PARAMETErRS * EXIT DATA IN INTX1 BUFFER * * * GBGET NOP GET DATA FROM THE GIC STA NUMB THE NUMBER OF GICB TO READ STB SIZE THE NUMBER OF PARAMETERS TO BE TRANSFERRED JSB GCBIM CALL GCBIM(NUMB,1,INTX1,2,SIZE) DEF *+6 DEF NUMB THE NUMBER OF GICB TO READ DEF .1 GET ONE SET DEF INTX1 LOCATION OF BUFFER DEF SIZE NUMBER OF PARAMETERS DEF .1 READ ONLY JMP GBGET,I * * GBRET NOP GRAPHIC CONTROL BLOCK RETURN STA ADDR A IS WHERE THE DATA IS AT STB NUMB B IS NUMBER OF WORDS TO SEND JSB GCBIM GCBIM(16,1,ADDR,NUMB,2) DEF *+6 DEF .16 DEF .1 ADDR NOP LOCATION OF THE BUFFER DEF NUMB NUMBER OF PARAMETERS DEF .2 WRITE JMP GBRET,I * ADD THE TERMINATOR TO THEN END * * TRBYT NOP NEED TO ADD TERMINATOR TO THE END LDB CBFCT LOAD THE COMPUTER BUFFER COUNT BRS SHIFT OVER TO MAKE IT WORDS ADB CBFAD WORD ADDRESS OF THE FIRST AVAILABLE BYTE STB TEMP9 LDA CBFCT SLA IS THE HOLE ON THE MSB OR LSBYTE OF THE AVAIL WORD JMP TRBY1 ITS ON THE LSBYTE OF THE WORD LDB TERM LOAD THE ESC PERIOD SEQUENCE IN DIRECTLY STB TEMP9,I STORE IT AWAY IN THE BUFFER ISZ TEMP9 MOVE UP THE POINTERS BY ONE LDB TERM1 LOAD THE RIGHT ) IN STB TEMP9,I PUT THE RIGHT ) IN JMP TRBY2 NOW UPDATE THE COUNTER TRBY1 LDA TEMP9,I LOAD THE LAST WORD OF THE CURRENT BUFFER AND HIBYT CLEAR OUT THE LOWER BYTE IOR B33 INSERT THE ESC CHARACTER STA TEMP9,I STORE IT AWAY ISZ TEMP9 INCREMENT THE POINTER LDA TERM2 LOAD THE PERIOD LEFT ) STA TEMP9,I UPDATE THE BUFFER ISZ TEMP9 MAKE ROOM FOR THE BACK SPACE CHARACTER LDA TERM3 LOAD THE CONTROL H IN STA TEMP9,I STORgE IT TRBY2 LDA CBFCT NOW UPDATE THE COMPUTER BUFFER COUNTER ADA .4 WE PUT IN FOUR MORE (ESC, . , ), CONTROL H ) STA CBFCT JMP TRBYT,I WE ARE DONE AND RETURN * * OUTPUTS THE BUFFER WITH A NUMBER OF BYTES * ENTER WITH A= BYTE COUNT * B= READ = 1; WRITE = 2 * IOB= PTR TO THE START OF THE BUFFER TRANSFER AREA * LUN= LOGICAL UNIT NUMBER * * * OUTPT NOP CMA,INA STA IOCNT NEGATIVE VALUE OF BYTE COUNT STB RW READ/WRITE FLAG;1=READ;2=WRITE CPB .2 IS IT A WRITE REQUEST JMP OUTST YES, THUS DO NOT DELETE TRANSPARENT MODE LDA LUN NO, NEED TO MAKE NON-TRANSPARENT MODE AND B77 JUST MASK OFF THE LOGICAL UNIT NUMBER STA LUN OUTST JSB REIO READ/WRITE REIO ROUTINE DEF RTOUT RETURN ADDRESS DEF RW READ/WRITE FLAG DEF LUN LOGICAL UNIT NUMBER IOB NOP BUFFER LOCATION DEF IOCNT HOW MANY? RTOUT LDA LUN PUT TRANPARENT BIT BACK ON, IF ON DOESN'T MATTER IOR B2000 SET BIT-10 SO WHAT IF WE DO THIS UNNECCESARLY STA LUN IT TAKES CODE THE SAME AMOUNT OF CODE THE OTHERWAY JMP OUTPT,I RETURN SKP SPC 3 * * THIS IS USED TO SEE WHAT KIND OF READ IS NEEDED * * RDCHK NOP READ CHECK JSB RITE OUTPUT THE COMPUTER BUFFER LDA INTYP SSA,RSS ARE WE SUPPOSE TO WAIT? JSB RWAIT YES, GO AND WAIT UNTIL THE BUFFER IS EMPTY * * NOW PERFOR IN THE ACTUAL REQUEST * RCONT LDB INTYP GET THE PROPER COMMAND SSB NEED THE ABOLUTE VALUE OF TYPE CMB,INB ADB ESCTB INDEX TO THE PROPER COMMAND LDA ESC.3 PUT IN PROPER CODE IN ESC. SEQUENCE AND HIBYT MASK OFF THE HIGH BYTE STA ESC.3 LDA B,I GET THE PROPER LETTER COMMAND AND LOBYT MASK OFF THE LETTER ONLY IOR ESC.3 STORE IT IN THE ESC SEQUENCE STA ESC.3 LDA B,I GET THE NUMBER OF PARAMETERS ALF,ALF ITS IN THE HIGH BYTE PUT IT IN THE LOW BYTE AND LOBYT MASK IT OFF STA LEN STORE IT AWAY AS NUMBER OF PARAMETERS IN READ LDA ESC. LOCATION OF ESC SEQUENCE STA IOB JSB READ JMP RDCHK,I * * * THIS ROUTINE IS USED TO READ THE PLOTTER BUFFER SIZE * WHICH MEANS TO WAIT UNTIL THE PLOTTER BUFFER IS COMPLETELY * EMPTY. * * RWAIT NOP READ BUFFER SIZE, BUT WAIT UNTIL IT'S EMPTY LDA ESC.3 NEED TO USE ESC.(ESC.L SEQUENCE AND HIBYT MASK OFF THE MOST SIGNIFICANT BYTE IOR .76 PUT IN A 'L' IN STA ESC.3 NOW ESC. HAS ESC.(ESC.L SEQUENCE IN IT LDA ESC. LOAD THE ESC SEQUENCE POINTER STA IOB PUT ESC SEQUENCE AS OUTPUT BUFFER LDA .1 ONE PARAMETER LONG STA LEN JSB READ GO GET BUFFER LENGHT LDA RWD1 BUFFER IS NOW EMPTY ADA .N40 NEED TO SUBSTRACT THE PREBUFFER IN 7221 STA PBFLN UPDATE THE GLOBAL VARIABLE JMP RWAIT,I RETURN * * * SKP * * * READ NEED TO PUT POINTER IN IOB FOR OUTPUT * COMMAND WITH ESC.( PRECEEDING. * * ASSUME 3 WORDS LONGS * * LEN = # PARAMETERS * * IOBUF SHOULD BE CLEAN * * PUT THE ANSWER IN RDVAR * * READ NOP READ AN INQUIRY LDA .6 ASSUME 3 WORDS OF OUTPUT LDB .2 WRITE REQUEST JSB OUTPT LDB .SPAC NEED TO PUT SPACES IN THE BUFFER LDA .N15 SO THE FORMATTER MAY WORK CORRECTLY STA TEMP9 ASSUME 15 WORDS IN BUFFER LDA .RDBF THIS IS THE BUFFER FWA READ1 STB A,I PUT SPACES IN THE BUFFER INA ISZ TEMP9 INCREMENT POINTERS JMP READ1 CONTINUE ON LDA .RDBF READ BUFFER LOCATION  STA IOB RESOTRE THE I/O BUFFER LDA .40 ONE LINE LENGTH LDB .1 READ JSB OUTPT LDA LPLCM LOAD LAST PLOTTER COMMAND CPA .N2 IS IT A LABEL ON MODE?? JMP READ,I YES, GO BACK HOME LDA .TERM NO, NEED TO TURN OFF THE PLOTTER STA IOB POINTS TO THE ESC . ) SEQUENCE (TERMINATOR) LDA .4 THREE BYTES LONG FOR THE TERMINATOR LDB .2 WRITE JSB OUTPT LDA LEN NOW CONVERT THE DATA SZA,RSS NO PARAMETER CONVERSION NECESSARY JMP READ,I RETURN CMA,INA STA LEN NEGATIVE # PARAMETER CLA STA IBYTE LDA .RDBF FROM I/O BUFFER STA INTIO LDA RDVAR STA INTAD PUT THE PARAMETER IN RDVAR INTLP JSB INTX DEF RTINT INTIO NOP FROM BUFFER INTAD NOP TO BUFFER DEF IBYTE COUNT OF WHICH CELL IN RDVAR RTINT ISZ INTAD ISZ LEN JMP INTLP JMP READ,I * SKP SPC 3 * * * LITERAL RETURN * ENTER GIC, LNGTH,DCTAD * * LITRT LDA CMDAD LITERAL RETURN; LOAD THE LOCATION OF LITERAL STRING LDB NBYTE LOAD THE NUMBER OF BYTES INB ROUND UP TO THE NEAREST WORD BOUNDARY BRS DIVIDE BY TWO TO GIVE WORDS JSB GBRET PUT INTO GCBIM(16,1,A,B,2) JMP EXIT1 UPDATE GLOBALS AND RETURN * * SKP SPC 3 * * THIS IS USED TO SEND DATA BACK TO THE GCBIM * * ENTER WITH DATA IN A * FORMAT *DDDDDD RANGE 0 TO 63 * * SBN NOP SINGLE BYTE NUMBER JSB CHECK CHECK FOR THE 6 BIT ON/OFF;AND STORE IT JMP SBN,I WE ARE FINISHED SPC 3 * * * ENTER WITH A = VALUE * * FORMAT 110NNNN 110NNNN 110NNNN * *NNNNNN *NNNNNN * *NNNNNN * * * MBN NOP MULTIPLE BYTE NUMBER , STA DATAX STORE VALUE TO BE CONVERTED LDB FGMBA CHECK TO SEE IF FROM MBA ROUTINE CPB .1 IF SO NEED TO USE 3 BYTE ROUTINE JMP MBN3 YES, GO TO THREE BYTE ROUTINE AND B76K ELSE MBN SZA CHECK TO SEE HOW MANY BYTES JMP MBN3 NEED THREE BYTES LDA DATAX AND B1760 SZA JMP MBN2 NEED TWO BYTES MBN1 LDA DATAX THEN WE NEED ONE BYTE JSB HDCK ONE BYTE STORE OF HEAD VALUE IN I/O BUFFER JMP MBN,I DONE WITH ONE BYTE PARAMETER MBN2 LDA DATAX 2 BYTE PARAMETER ALF,ALF NEED BITS 9-6 TO 3-0 RAL,RAL JSB HDCK STORE HEAD VALUE IN I/O BUFFER JMP BLAST SKIP TO LAST BYTE OF MBP3 WHICH IS IDENTICAL MBN3 LDA DATAX THREE BYTE PARAMETER ALF NEED BIT 14-12 TO 2-0 LDB MBAOF CHECK TO SEE IF WE NEED TO SET BIT 16 SZB THIS IS FROM THE MBA ROUTINE IOR .8 SET BIT 4 IMPLIES ANGLES > 90 DEGREES. JSB HDCK STORE HEAD VALUE IN I/O BUFFER LDA DATAX SECOND BYTE OF MBN ALF,ALF MOVE BITS 11-6 TO 5-0 RAL,RAL JSB CHECK SPC 3 BLAST LDA DATAX LAST BYTE JSB CHECK JMP MBN,I GO BACK HOME SPC 3 * THIS IS USED TO CHECK TO SEE IF * BIT 7 IS TO BE COMPLEMENTED OR NOT * CHECK NOP SET UP 6/7 BIT OF BYTE AND B77 MASK OFF THE BITS 5-0 STA TEMP AND B40 MASK OFF THE BIT-6 SZA,RSS IS BIT 6=0 LDA .64 YES, SET BIT 7 OTHERWISE LEAVE BIT 6 SET IOR TEMP SET BIT 6 OR 7 ALF,ALF NEED TO MOVE TO HIBYTE TO OUTPUT ONE BYTE STA SINGL PUT IT INTO THE TEMPORARY BUFFER TO BE TRANSFERRED LDB .1 NOW SET UP THE PARAMETERS FOR JSB TRANS ROUTINE LDA .SING SET UP THE POINTER JSB TRANS JMP CHECK,I * SPC 3 * * *  USED TO PUT IN HEADER FORMAT * FORMAT IS 110NNNN * * HDCK NOP HEADER CHECK FOR PARAMETER CONVERSION ROUTINES AND B17 MASK OFF THE 3-0 BITS IOR B140 NEED TO INSERT THE HEADING PREAMBLE ALF,ALF NEED TO MOVE TO HIBYTE TO GET OUTPUTTED STA SINGL STORE INTO THE TEMPORARY BUFFER TO BE TRANSFERRED LDB .1 1 BYTES LONG LDA .SING POINTER TO THE TEMPORARY BUFFER JSB TRANS TRANSFER THE DATA OVER JMP HDCK,I RETURN * * * SPC 3 * * MULTIPLE BYTE PARAMETERS * * FORMAT 110XXYY 110XXXX 110XXXX 110XXXX 110XXXX * *XYYYYY *XXXXYY *XXXXXX *XXXXXX * *YYYYYY *XYYYYY *XXXXYY * *YYYYYY *YYYYYY * *YYYYYY * * * MBP NOP MULTIPLE BYTE PARAMETERS STB DATAY STA DATAX IOR B CHECK TO FIND OUT WHICH MAGNITUDE IS LARGER STA TEMP AND B74K BITS 13-11 ANY ON? SZA JMP MBP5 YES, WE HAVE A 5 BYTE PARAMETER LDA TEMP AND B3400 BIT 10-8 ANY ON? SZA JMP MBP4 GO TO 5 BYTE PARAMETER LDA TEMP AND B340 BITS 7-5 ANY ON? SZA JMP MBP3 WE HAVE 3 BYTE PARAMETER LDA TEMP AND B34 BITS 4-2 ANY ON? SZA JMP MBP2 TWO BYTE PARAMETER JMP MBP1 ELSE ONE BYTE PARAMETER * * * MBP5 LDA DATAX FIVE BYTE PARAMETER ALF MOVE THE BITS OVER TO GET LSB'S RAL,RAL 13-10 TO 3-0 BITS MOVEMENT JSB HDCK LDA DATAX SECOND BYTE ALF,ALF GET THE NEXT BYTE OF INFORMATION ALF MOVE BITS 904 TO 5-0 JSB CHECK LDA DATAY THIRD BYTE PARAMETER ALF SHIFT OVER TO GET THE Y BITS AND .3 MASK OFF WHAT WE NEED STA TEMP LDA DATAX THE SECOND HALF OF THE THRID BYTE AND B17 MOVE BITS 3-0 TO 5-2 RAL,RAL MOVE IT TO THE PROPER PLACE IN MBP IOR TEMP MERGE THE Y AND X BITS FOR BYTE 3 JSB CHECK LDA DATAY FOURTH BYTE ALF,ALF MOVE BITS 11-6 TO 5-0 RAL,RAL JSB CHECK LDA DATAY FIFTH BYTE JSB CHECK GO AND STORE IT JMP MBP,I * * * MBP4 LDA DATAX WE HAVE A FOUR BYTE MBP ALF,ALF SHIFT OVER BITS 10-7 TO 3-0 RAL JSB HDCK LDA DATAX SECOND BYTE RAR MOVE BITS 6-1 TO 5-0 JSB CHECK GO AND PUT IT IN LDA DATAX THIRD BYTE BYTE AND .1 MASK OFF THE ONE BIT WE NEED ALF,RAL MOVE BITS 0 TO BIT 5 STA TEMP STORE IT AWAY; NEED IT LATER TO MERGE WITH THE Y LDA DATAY ALF,ALF SHIFT BITS 10-6 TO 4-0 RAL,RAL AND B37 MASK OFF THE 5 BITS WE NEED IOR TEMP MERGE THE X AND Y TOGETHER JSB CHECK LDA DATAY FOURTH BYTE JSB CHECK STORE IT JMP MBP,I RETURN * * * MBP3 LDA DATAX 3 BYTE PARAMETER ALF,ALF MOVE THE BITS 7-4 TO 3-0 ALF JSB HDCK INSERT THE HEADER IN LDA DATAX SECOND BYTE AND B17 GET THE 4 BITS 3-0 TO 5-2 RAL,RAL SHIFT IT OVER FOR POSITIONING STA TEMP SAVE FOR MERGE LATER LDA DATAY ALF,ALF MOVE 7-6 TO 1-0 RAL,RAL NEED TO SHIFT OVER 12 AND .3 NEED THE TWO Y BITS IOR TEMP MERGE THE X AND Y TOGETHER JSB CHECK LDA DATAY THRID BYTE JSB CHECK JMP MBP,I * * * MBP2 LDA DATAX GOING AFTER THE TWO BYTE PARAMETER RAR SHIFT BITS 4-1 TO 3-0 JSB HDCK LDA DATAX SECOND BYTE AND .1 ALF,RAL MOVE OVER TO POSITION 0 TO 5 STA TEMP LDA DATAY AND B37 NEED TO MASK OFF THE LAST 5 BITS OF Y IOR TEMP MERGE THE X AND Y TOGETHER JSB CHECK PUT IT AWAY JMP MBP,I * * * MBP1 LDA DATAX HAVE ONE BYTE MODE AND .3 MOVE BITS 1-0 TO 3-2 RAL,RAL MOVE THE 2 BITS TO PROPER PLACE STA TEMP LDA DATAY AND .3 MOVE BITS 1-0 TO 1-0 IOR TEMP MERGE THE X AND Y TOGETHER JSB HDCK NEED TO PUT THE HEADER INFO IN AND PUT INTO BUFFER JMP MBP,I * * * * * * * FOR MBA MULTIPLE BYTE ANGLE WE NEED TO HAVE * FLOATING POINT SO WE CAN CONVERT FROM * RADIANS TO DEGREES AND TO BINARY SYNTAX * NEED FOR THE 7221 * * 10430.03 * X RADIANS = D BINARY DEGREES * MBA NOP THIS IS MULTIPLE BYTE ANGLE FMP MBACT MULTIPLY BY THE 10430.03 CONSTANT DST TEMP8 THIS IS THE FLOATING REPRESENTATION OF MBA FSB B77.K NEED TO CHECK FOR ANGLES > 90 DEGREES FIX LDB .1 INDICATES OVERFLOW BITS OR > 90DEGREES SSA,RSS ARE WE OVER 90 DEGREES? JMP MBA1 YES, USE A AND B AS IS DLD TEMP8 NO, ANGLE IS <= 90 DEGREES FIX PUT IT IN THE FORM FOR MBN TO USE LDB .0 CLEAR OVERFLOW FLAG MBA1 STB MBAOF STORE OVERFLOW FLAG LDB .1 NEED TO SET FLAG FOR MBA SO MBN ROUTINE KNOWS IT STB FGMBA IS FROM MBA TO DO THREE BYTE PART JSB MBN GO AND CONVERT IT SINCE ITS THE SAME AS MBN CLA RESET THE FLAG TO NOT-FROM MBA STA FGMBA STA MBAOF CLEAR THE OVERFLOW FLAG JMP MBA,I RETURN SKP SPC 3 * * * * * DATA VARIABLESL * .SING DEF SINGL USED FOR TEMPORARY BUFFER LOCATION IN CONVERSIONS SINGL NOP * * ESC. DEF ESC.1 ESC.1 OCT 015456 ESC . ESC.2 OCT 024033 (ESC ESC.3 OCT 027040 . BLANK } SPC 3 .ETX DEF ETXNO USED TO POINT TO THE ETX TERMINATOR SEQUENCE ETXNO OCT 015456 ESC . OCT 024003 ( ETX OCT 015456 ESC . OCT 024410 ) BACK SPACE (CONTROL H) SPC 3 .TERM DEF TERM START OF TERMINATOR SEQUENCE TERM OCT 015456 ESC. TERM1 OCT 024410 ) CONTROL H TERM2 OCT 027051 PERIOD, ) TERM3 OCT 004000 CONTROL H, NULL SPC 3 HIBYT OCT 177600 MOST SIGNIFICANT BYTE LOBYT OCT 000377 LEAST SIGNIFICANT BYTE SPC 3 RDVAR DEF RWD1 THE PARAMETER FROM READ RWD1 BSS 1 RWD2 BSS 1 RWD3 BSS 1 RWD4 BSS 1 SPC 3 ESCTB DEF * START OF ESC SEQ TABLE OCT 001501 3 A; NUMBER OF PARAMETERS, LETTER OF OUTPUT COMMAND OCT 000502 1 B OCT 001503 3 C OCT 002104 4 D OCT 001505 3 E OCT 000506 1 F OCT 002107 4 G OCT 000110 0 H OCT 000111 0 I OCT 000112 0 J OCT 000113 0 K OCT 000514 1 L SPC 3 .RSET DEF RSET FOR RESET COMMAND RSET OCT 077121 TILDE P - DEFAULT LABEL FONT OCT 077127 TILDA W (W) SET GRAPHIC LIMITS OCT 077123 TILDA S (~S) SET GRIDDING OCT 077045 TILDA % (~%) SET CHARACTER SIZE OCT 063467 SMALL G7(g7) PARAMETER VALUES FOR (125,250) OCT 035000 COLON (: ) SPC 3 * * ETX,ESC.M10:17:10:13:ESC.J SEQUENCE * .HAND DEF HAND FWA FOR START HANDSHAKING HAND OCT 1433 TURN OFF TEXT MODE IF ON (ETX,ESC) OCT 027115 SET UP HANDSHAKE MODE (.,M) OCT 30460 WITH 10 MILLISECOND DELAY (1,0) OCT 35461 DC1 CHARACTER TRIGGER (SEMICOLON,1) OCT 33473 (7,SEMICOLON) OCT 30060 TRY NO ECHO BYPASS CHARACTER(0,0) OCT 35461 CR TERMINATOR FOR PLOTTER (SEMICOLON,1) OCT 31472 (3,:) OCT 15456 CANCEL ANY CURRENT REQUESTS (ESC,.) OCT 45000 (J,NULL) SPiC 3 * * GLOBALS * CBFCT BSS 1 COMPUTER BUFFER COUNTER PBFLN BSS 1 PLOTTER BUFFER LENGTH LPLCM BSS 1 LAST PLOTTER COMMAND PANG1 BSS 1 PLOTTER ANGLE PANG2 BSS 1 PLOTTER ANGLE PART TWO (REAL NUMBER) CPENS BSS 1 PLOTTER PEN STATUS GX1MU BSS 1 GRAPHIC LIMIT X MIN GX2MU BSS 1 GRAPHIC LIMIT X MAX GY1MU BSS 1 GRAPHIC LIMIT Y MIN LENGTH GY2MU BSS 1 GRAPHIC LIMIT Y MAX * * * .LNTP DEF LNTP LINE TYPE REFERENCE LNTP DEF LNTP0 LINETYPE 0 SOLID LINES DEF LNTP1 1, DIME DEF LNTP2 2,SHORT DASH DEF LNTP3 3,LONG DASH DEF LNTP4 4,CENTER LINE DEF LNTP5 5,DOTS AT END POINT DEF LNTP6 6,DOUBLE CENTER LINE * * PATLN DEC 460.0 DEFAULT DASHLINE LENGTH * LNTP0 OCT 0 DEFAULT SOLID LINES LNTP1 OCT 5 LENGTH IN BYTES OCT 020101 SPACE, CAPITAL A DIM LINES OCT 020141 SPACE , LOWER CASE A OCT 022000 $ DOLLAR SIGN, NULL LNTP2 OCT 2 BYTES OCT 022505 PERCENT , CAPITAL E; SHORT DASH LNTP3 OCT 2 OCT 021501 POUND SIGN, CAPITAL A LONG DASH LNTP4 OCT 4 OCT 023501 SINGLE QUOTE MARK,CAPITAL A; CENTER LINE OCT 020501 EXCLAIMATION POINT,CAPITAL A LNTP5 DEC 8 NUMBER OF BYTES OCT 077122 TILDE R - VARIABLE DASH LINE FORMAT OCT 020101 SPACE ,CAPITAL A OCT 020143 SPACE ,SMALL C OCT 037477 QUESTION ,QUESTION MARK LNTP6 OCT 6 OCT 020101 PERCENT ,CAPITAL A; DOUBLE CENTER LINES OCT 020501 EXCLAMATION,CAPITAL A OCT 020501 EXCLAMATION,CAPITAL A * A EQU 0 B EQU 1 BUFFG BSS 1 BUFFER FLAG NBYTE BSS 1 ABSOLUTE NUMBER OF BYTES IN CMD $ BYTES BSS 1 NUMBER OF BYTES IN CMD $ TYPE BSS 1 NUMBER OF BYTES IN CMD $ INTYP BSS 1 READ INSTRUCTION TYPE FOR READ REQUESTS * RW BSS 1 READ/WRITE FOR GCBIM FGMBA NOP MBA FLAG 0=NOT FROM MBA 1=YES FROM MBA ROUTINE MBAOF NOP MBA OVERFLOW FLAG 0=NO SET BIT-16 1=YES SET BIT-16 DFETX DEF B1400 POINTER TO THE 1400 OCTAL (ETX) * * .0 OCT 0 .1 OCT 1 .1038 DEC 10380 Y UPPER RIGHT DEFAULT LIMIT .10 DEC 10 .11 DEC 11 .1572 DEC 15720 X UPPER RIGHT DEFAULT LIMIT .16 DEC 16 .19 DEC 19 .2 OCT 2 READ LUN NUMBER ALSO KEEP NEXT TWO WORDS ALWAYS TOGETHER .4 OCT 4 READ CBFAD,CBFLN .26 DEC 26 READ THE AXIS FIX # FXDN .200 OCT 200 .SPAC OCT 20040 THIS IS SPACES IN BOTH BYTES FOR INPUT BUFFER CLEAR .22 DEC 22 .3 OCT 3 .380 DEC 380 Y LOWER LEFT DEFAULT LIMIT .31 DEC 31 .32 DEC 32 .38 DEC 38 .39 DEC 39 .40 DEC 40 .41 DEC 41 .64 DEC 64 .460 DEC 460 .5 OCT 5 .520 DEC 520 X LOWER LEFT DEFAULT LIMIT .6 OCT 6 .7 OCT 7 .76 DEC 76 A CAPITAL L .8 DEC 8 .N1 OCT -1 .N15 DEC -15 .N2 OCT -2 .N20 DEC -20 .N3 OCT -3 .N4 OCT -4 .N40 DEC -40 .N5 OCT -5 B1000 OCT 1000 B140 OCT 140 B1400 OCT 1400 ETX IS THE HIGH BYTE B17 OCT 17 B177 OCT 177 B1760 OCT 1760 B200 OCT 200 B2000 OCT 2000 B33 OCT 33 B34 OCT 34 B3400 OCT 3400 B340 OCT 340 B37 OCT 37 B40 OCT 40 B60 OCT 60 B6400 OCT 6400 CARRIAGE RETURN, FOR SHORT LABEL TERMINATOR B74K OCT 74000 B76K OCT 76000 B77 OCT 77 B77.K DEC 32767. THIS FOR MBA ROUTINE SPC 3 CMDAD BSS 1 COMMAND ADDRESS = DCTAD RWFLG BSS 1 =0 READ, -1 WRITE IOCNT BSS 1 I/O COUNTER FOR # BYTES TO BE TRANSFERRED TEMP BSS 1 TEMPORARY VARIABLE IN CONVERSIONS ROUTINES TEMP3 BSS 1 TEMPORARY STOREGE TEMP7 BSS 1 TEMPORARY STORAGE TEMP8 BSS 1 TEMPORAY STORAGE FOR TRANS TEMP9 BSS 1 TEMPORARY STORAGE FOR TRANS ROUTINE TLOOP BSS 1 LOOP COUNTER FOR TRANS ROUTINE PLTCT BSS 1 PLOT ABSOLUTE PARAMETER POINTER LNTH BSS 1 LENGHT OR NUMBER OF PARAMETERS .RDBF DEF INTX1 READ BUFFER LOCATION INTX1 BSS 1 INTX2 BSS 1 INTX3 BSS 1 INTX4 BSS 1 INTX5 BSS 1 INTX6 BSS 1 INTX7 BSS 1 INTX8 BSS 1 INTX9 BSS 11 NUMB BSS 1 NUMBER OF ITEMS SIZE BSS 1 NUMBER OF ITEMS LEN BSS 1 # OF PARAMETER TO CONVERT IN READ REQUEST * * * LUN BSS 1 LOGICAL UNIT NUMBER CBFAD BSS 1 COMPUTER BUFFER ADDRESS LOCATION CBFLN BSS 1 COMPUTER BUFFER LENGTH FXDN BSS 1 READ THE AXIS FORMAT NUMBER * * * .SPEC DEF * FWA FOR SPECIAL TABLES DEF RESET DEF GTG12 GET G1,G2 DEF OUTCP OUTPUT CURRENT POINT DEF DIGIT OUTPUT THE DIGITIZE POINT DEF SLANT OUTPUT THE SLANT FOR CHARACTERS DEF MBPOT MBP OUTPUT FLOATING POINT NUMBER DEF MBPBN MBP OUTPUT BINARY NUMBER DEF SLPEN SELECT PEN NUMBER DEF DASHL DASH LINE TYPE SELECTION DEF DASHL DASH LINE WITH PATTERN LENGTH SPECIFIED DEF MVCUR MOVE CURSOR NEED TO OUTPUT BINARY # IN MBP DEF SG1G2 SET G1,G2; GRAPHIC LIMITS DEF DFG12 DEFAULT G1 AND G2 DEF PENUP PEN-UP * * * EM0 DEF * FWA FOR EMULATOR TABLE DEF XMIT TRANSMIT I/O BUFFER DEF HOME HOME THE PEN DEF GTCHR GET CHARACTER DATA DEF PLABS PLOT ABSOLUTE DEF LABEL LABEL MODE DEF CONVT CONVERT TO ASCII DEF PENDN PEN DOWN DEF CPLMT CHARACTER PLACEMENT DEF PAGEF PAGE FEED SPC 3 .P DEF P P OCT 70000 SMALL P (LOWER CASE P) .Q DEF Q Q OCT 070400 SMALL Q (LOWER CASE Q) .Z DEF Z Z OCT 75000 SMALL Z (LOWER CASE) * AGCT DEC 1.0 CONVERSION RADIANS TO DEGREES TO MBA FORMAT .LLAB DEF LLAB LLAB OCT 077134 TILDE, BACKSLASH (,\) OCT 061576 ETX,TILDE DEFINES THE LABEL TERMINATOR OCT 023400 SINGLE TICK MARK, NULL - TURN LABEL MODE ON DF .SLAB DEF SLAB SHORT LABEL MODE SLAB OCT 077134 TILDE, BACK SLASH OCT 066576 CARRIAGE RETURN, TILDE OCT 023400 SINGEL TIC MARK, NULL SPC 3 * .WW DEF WW WW OCT 073567 SMALL WW (ABSOLUTE ROTATE) SKPBK NOP USED IN FLOAT TO ASCII ROUTINE * BUFFER EMPTY 1=NO,WAIT; 0 = YES, WAIT IBYTE BSS 1 INTX ROUTINE DATAX BSS 1 X VALUE USED IN CONVERSION ROUTINE DATAY BSS 1 Y VALUE USED IN CONVERSION ROUTINE * MBACT DEC 10430.03 FLOATING POINT ANGLE CONSTAND SLANG DEC 1.570795 FLOATING POINT OF 90 DEGREES USED IN SLANT ROUTINE * * .MCMD DEF MCMD COMMAND STRING TO DO PAGE FEED MCMD OCT 077053 (TILDE,+) OCT 76433 (],ESC) TERM,START OF OUTPUT ERROR (ESC.E) .MOE DEF MOE COMMAND STRING TO DO OUTPUT ERROR MOE OCT 15456 (ESC,.) OCT 24033 ((,ESC) OCT 27105 (.,E) OCT 76400 (],NOP) TERM END 7 ~% 92840-18093 1940 S C0122 &DCT05              H0101 [|ASMB,R,F,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * * * * NAME: DCT05 -- 7221A/B/S DEVICE COMMAND TABLE * * SOURCE: 92840-18093 * * RELOC: 92840-16011 * * * * * ************************************************************** * NAM DCT05,7 92840-16011 REV.1940 790720 ENT DCT05 * * THIS IS THE DEVICE COMMAND TABLE FOR THE 7221 PLOTTER * ************************************************************** * * COMMAND LINK TABLE (CLTBL) * * SPC 3 DCT05 NOP DEF INIT 0 THIS IS TO EMULATE THE NAME OF DEVICE DEF RESET 1 RESET DEVICE/EXCEPT P1,P2 DEF DFP12 2 DEFAULT P1/P2 DEC -9 3 FORM FEED/PAGE ADVANCE (CALLS HOME PEN) DEC -1 4 TRANSMIT I/O BUFFER DEC -2 5 HOME PEN DEF GETID 6 GET ID NOP 7 ????? DEF GTG12 8 GET G1,G2 IN P.U. DEC -3 9 GET CHARACTER SPACING/WIDTH DEF OUTCP 10 OUTPUT CURRENT PEN POSITION IN PU.] DEF OUTCP 11 OUTPUT CURRENT CURSOR POSITION IN PU. DEF DIGIT 12 DIGITIZE NOP 13 LABEL ORIGIN NOP 14 SET LABEL DIRECTION DEF CHRSL 15 SET CHARACTER SLANT ON DEF CHRSO 16 CHARACTER SLANT OFF (DEF CHRSI 17 CHARACTER SIZE NOP 18 SET RELOCATABLE ORIGIN NOP 19 SET RELOCATABLE ANGLE NOP 20 SET RELOCATABLE SCALING NOP 21 SET ORIGIN = CURSOR NOP 22 SET ORIGIN = PEN POSITION NOP 23 DRAW TO CURSOR DEF CHRST 24 SELECT CHARACTER SET DEF PEN0 25 SELECT PEN 0 (PUT PEN AWAY) NOP 26 ERASE PEN NOP 27 COMPLEMENT PEN DEF PENN 28 SELECT PEN (1-N) DEF GETPN 29 GET # OF PENS NOP 30 DEFINE LINE TYPE DEF LNTY0 31 SELECT PREDEFINED LINETYPE WITH DEFAULT LENGTH DEF LNTYP 32 SELECT PREDEFINED LINETYPE, LENGTH DEF PENUP 33 PEN-UP DEC -7 34 PEN-DOWN ROUTINE DEC -4 35 PLOT ABSOLUTE NOP 36 PLOT RELOCATABLE NOP 37 PLOT INCREMENTAL DEC -5 38 SHORT LABEL DEC -5 39 LONG LABEL NOP 40 STOP LONG LABEL MODE DEC -6 41 CONVERT FLOATING TO ASCII AND OUTPUT DEF GETDS 42 GET DISPLAY SIZE DEF MCUR 43 POSITION CURSOR ABSOLUTE NOP 44 POSITION CURSOR RELATIVE DEF SG1G2 45 SET G1,G2 DEF GETMU 46 GET MU/MM DEF GETZE 47 GET DEVICE CLEAR CHARACTERISTICS DEF GETPN 48 GET # OF DIFFERENT PENS DEF GETZE 49 GET # OF DIFFERENT CURSORS DEF GETZE 50 GET LORG CAPABILITY DEF GETSL 51 GET MAX SLANT ANGLE DEF GET1 52 GET HARD CLIP CAPABILITY DEC -8 53 INQUIRE CHARACTER PLACEMENT DEF GETCS 54 GET CHARACTER SIZE DEF GETLD 55 GET LABEL DIRECTION DEF GETLO 56 GET LABEL ORIGIN RANGE * HED ASCII COMMAND STRINGS * * ASCII COMMAND STRINGS FOR DEVICE COMMAND TABLE FOR 7221 * * FORMAT: WORD1 = NUMBER OF BYTES (N) * -(N) INDICATES A WRITE TO DEVICE * +(N) I NDICATES A READ AFTER WRITE * * * WORD2 = INDICATES TYPE OF COMMAND * -1 INDICATES TRUE R/W TYPE (NO SPECIAL) * CONDITIONS TO WORRY ABOUT. * * >1 INDICATES NEED OF SOME SORT OF PARAMETER * CONVERSION. * * =0 INDICATES A LITERAL STRING IS RETURN * TO THE CALLING ROUTINE. * * * * WORD3 = FIRST WORD OF COMMAND STRING * OR IF READ MODE THEN WORD 3 IS THE READ * INSTRUCTION NUMBER, THEN WORD 4 IS THE * FIRST COMMAND STRING INSTRUCTION. * * SPC 3 INIT NOP THIS IS USED FOR INIT CYCLE NEED TO RETURN DEVICE NAME LDA .7221 THE DEVICE NAME JMP INIT,I GO HOME .7221 DEC 7221 * * * RESET DEC +36 RESET GIC: SETS UP HANDSHAKING&DEFAULTS DEC 1 NEED SOME SPECIAL HANDLING DEC 7 USED TO DENOTE OUTPUT OF THE GRAPHIC LIMIT COMMAND OCT 1433 TURN OFF TEXT MODE IF ONE (ETX, ESC) * HANDSHAKE MODE: ESC.M10;17;10;13: OCT 27115 SET UP HANDSHAKE MODE (.,M) OCT 30460 WITH 10 MILLISECOND DELAY (1,0) OCT 35461 DC1 CHARACTER TRIGGER( ,1) OCT 33473 (7,SEMICOLON) OCT 30073 NO ECHO BYPASS CHARACTER (0,SEMICOLON) OCT 030463 CR TERMINATOR FOR PLOTTER(1,3) OCT 035033 :,ESC START OF CLEAR ERRORS ESC .E OCT 027105 .E CLEAR ERRORS * OCT 15456 CLEAR OUT OUTPUT REQUESTS (ESC .J ) OCT 045176 J TILDE OCT 056143 BACK SLASH, ETX - DEFAULT LABEL TERMINATOR OCT 015456 ESC . - DEFAULT INDEPENDENT HANDSHAKE OCT 044072 H : OCT 077126 TILDE V - DEFAULT PEN VELOCITY OCT 077121 TILDE Q - DEFAULT DASH LINES SOLID OCT 077057 TILDE SLASH - DEFAULT SLANT OCT 073572 LOWER >CASE W, LOWER CASE Z - DEFAULT ROTATION,TERMINATOR * * DFP12 DEC -9 SET-UP DEFAULT P1,P2 DEC 13 YES, SPECIAL HANDLING UPDATE GLOBALS OCT 77127 (TILDE,W) SET-UP DEFAULT P1 AN P2 OCT 077123 (TILDE S) SET UP DEFAULT SCALING OCT 067107 (SMALL N,G) UPPER-RIGHT VALUE (15200,10000) OCT 041134 (B,BACK SLASH) OCT 050175 (P,TERM) END OF CMD SEQ * * * GETID DEC 6 GET THE GRAPHIC DEVICE ID DEC 0 JUST RETURN THE LITERAL STRING FOLLOWING DEC 0 NOTHING SPECIAL TO DO ASC 3,7221A RETURN THE ID * * * GTG12 OCT 340 GET G1, G2 IN PLOTTER UNITS DEC +2 NEED TO OFFSET G2 BY G1 AND PUT ZEROES IN G1 DEC +7 READ GX1,GY1,GX2,GY2 (ESC.G) * * * OUTCP OCT 340 OUTPUT THE CURRENT POINT DEC +3 NEED TO OFFSET POINT BY G1 AMOUNT DEC +3 OUTPUT THE CURRENT POINT (ESC.C) * * * DIGIT OCT 340 DIGITIZE DEC +4 DIGIT NEEDS ONLY LOAD IT INTO THE GICBM DEC +4 (ESC . D) * * * CHRSL DEC -2 LABEL SLANT ON WITH SPECIFIED ANGLE DEC +5 NEED TO CONVERT RADIANS TO MBA PARAMETERS ASC 1,~/ LABEL SLANT ON PREAMBLE (TILDE,BACKSLASH) * * * CHRSO DEC -2 LABEL SLANT OFF DEC -1 NO SPECIAL HANDLING ASC 1,~/ DEFAULT SLANT BACK TO ZERO (TILDE,BACKSLASH) * * * CHRSI DEC -2 SET CHARACTER SIZE DEC +6 NEED TO CONVERT X,Y TO MBP FORMAT ASC 1,~% LABEL SIZE PREAMBLE (TILDE,PERCENT SIGN) * * * CHRST DEC -2 SET CHARACTER SETS DEC +7 NEED TO CONVERT X,Y TO MBP FORMAT ASC 1,~P CHARACTER SET SELECT PREAMBLE (TILDE,P) * * PEN0 DEC -1 PUT THE PEN AWAY DEC -1 NO SPECIAL HANDLING ASC 1,v SELECT PEN 0 (LOWER CASE V) * * * PENN DEC -1 PICK PEN N DEC 8 Y NEED TO CONVERT TO SBN ASC 1,v PREAMBLE FOR PEN SELECT (LOWER CASE V) * * * GETPN DEC 2 RETURN THE NUMBER OF PENS DEC 0 DEC 0 OCT 4 THERE ARE FOUR PENS ON THE 7221. * * * LNTY0 DEC -2 SELECT LINE TYPE DEC 9 NEED TO PICK SEND THE PROPER LINE TYPE ASC 1,~Q PREAMBLE FOR FIX DASH LINE TYPES (TILDE,Q) * * * LNTYP DEC -2 SELECT LINE TYPE DEC 10 NEED TO PICK THE PROPER LINE TYPE AND LENGTH ASC 1,~Q PREAMBLE FOR FIX DASH LINE TYPE (TILDE,Q) * * * PENUP DEC -1 PEN-UP DEC 14 NEED TO SET LOGICAL PEN POSITION ASC 1,p MOVE TO THE NEXT POINT * * * * * * *ETX DEC -1 STOP LONG LABEL MODE * DEC -1 NO SPECIAL HANDLING * OCT 1400 (ETX) * * * GETDS DEC 16 RETURN THE DISPLAY SIZE IN MM DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 0.0 LOWER LEFT IN MM (XLL) DEC 0.0 (YLL) DEC 400. X HEIGHT IN MM(FLOATING POINT) DEC 280. Y HEIGHT IN MM (FLOATING POINT) * * * MCUR DEC -1 MOVE CURSOR DEC 11 NEED TO CONVERT X,Y TO MBP ASC 1,p ABSOLUTE MOVE (LOWER CASE P) * * * * SG1G2 DEC -2 SET G1,G2 DEC +12 NEED TO CONVERT X,Y IN MBP ASC 1,~W SET GRAPHIC LIMITS (TILDE,W) * * * GETMU DEC +8 RETURN THE MU/MM DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 40. 40 MU/MM IN THE X DIRECTION DEC 40. 40 MU/MM IN THE Y DIRECTION * * * GETZE DEC +2 RETURN ZERO TO VARIOUS QUERIES. DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO OCT 0 RETURN VALUE OF ZERO(IMPLIES NO CAPABILITIES) * * * GET1 DEC 2 RETURN ONE TO VARIOUS QUERIES. Y$"DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 1 RETURN VALUE OF ONE(IMPLIES YES CAPABILITIES) * * * GETSL DEC +8 RETURN THE CHARACTER SLANT MAXIMUMS DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 1.5060 THE POSITIVE AMOUNT OF SLANT FROM VERTICAL DEC -1.5060 THE NEGATIVE AMOUNT OF SLANT FROM VERTICAL * * * GETFN DEC +10 RETURN THE FILE NAME (NOP) DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO OCT 0 OCT 0 OCT 0 OCT 0 OCT 0 * * * GETCS DEC 9 MIN/MAX CHARACTER SIZES IN MU DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 1.0 X MIN IN MACHINE UNITS DEC 1.0 Y MIN IN MACHINE UNITS DEC 16000.0 X MAXIMUM IN MACHINE UNITS DEC 16000.0 Y MAXIMUM IN MACHINE UNITS OCT 0 0=NO NEGATIVE PARAMETERS ALLOWED LIKE 7245A * * * GETLD DEC 4 LABEL DIRECTION RANGE DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO OCT 2 ALL ANGLES ARE ACCEPTED OCT 0 ALL ANGLES ARE ALLOW * * * GETLO DEC 4 LABEL ORIGIN RANGE DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO OCT 0 NO LORG RANGE OCT 0 ONLY TYPEWRITER MODE AVAILABLE * * * * END ֫$  92840-18094 1913 S C0122 &DCT08 7225A COMMAND TABLE SOURCE            H0101 @ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT08 -- 7225A DEVICE COMMAND TABLE * SOURCE: 92840-18094 * RELOC: 92840-16009 * * ************************************************************* * NAM DCT08,7 92840-16009 REV.1913 790123 * ENT DCT08 * EXT EXEC,TAN,COS,SIN,FLOAT,.IENT EXT ABS EXT FLTAS EXT CONVT EXT LNGTH,GIC,DCTAD EXT GCBIM,INTX,BYTE,INDCK EXT REIO * ************************************************************* * * THIS IS THE DEVICE COMMAND TABLE FOR THE 7225A PLOTTER. * * COMMAND LINK TABLE (CLTBL) * ************************************************************* * DCT08 NOP DEF EML08 DEF RESET 01 - RESET PLOTTER DEF DEFLT 02 - DEFAULT P1,P2 DEF CLEAR 03 - CLEAR SCREEN NOP 04 - FLUSH BUFFER DEF HOME 05 - HOME PEN DEC -19 06 - DEVICE ID NOP 07 - CLOSE FILES,FLUSH BUFFER (2608A) DEF PLTUN 08 - GET PLOT UNITS OCT -1 09 - GET CHARACTER INFORMATION DEF PNLOC 10 - GET PEN LOCATION DEF PNLOC 11 - CURSOR DEC -4 12 - DIGITIZE NOP 13 - LORG DEC -7 14 - LDIR DEC -8 15 - SLANT ON DEF SLOFF 16 - SLANT OFF DEC -9 17 - CHARACTER SIZE DEC -13 18 - SET RELATIVE ORIGIN NOP 19 - SET ANGLE NOP 20 - SET SCALING NOP 21 - SET ORIGIN = CURSOR NOP 22 - SET ORIGIN = PEN POSITION NOP ~l 23 - DRAW TO CURSOR NOP 24 - SELECT CHARACTER SET NOP 25 - SELECT PEN 0 (RETURN TO HOLDER) NOP 26 - ERASE PEN (PEN = -1) NOP 27 - COMPLEMENT PEN (PEN = -2) DEC -10 28 - SELECT PEN (PEN = 1 --> N) DEC -5 29 - GET NUMBER OF PENS NOP 30 - DEFINE LINE TYPE DEC -10 31 - LINE TYPE DEC -10 32 - LINE TYPE WITH LENGTH DEF PENUP 33 - PEN UP DEF PENDN 34 - PEN DOWN DEF PLTAB 35 - PLOT ABSOLUTE NOP 36 - PLOT RELOCATABLE DEF PLTIN 37 - PLOT INCREMENTAL DEF LGLAB 38 - SHORT LABEL DEF LGLAB 39 - LABEL MODE DEF STPLB 40 - LABEL MODE TERMINATOR DEC -3 41 - FLOAT TO ASCII CONVERSION DEC -11 42 - DISPLAY SURFACE SIZE IN MM NOP 43 - POSITION CURSOR ABSOLUTE NOP 44 - POSITION CURSOR RELATIVE DEC -24 45 - SET P1,P2 DEC -12 46 - GET MU/MM DEC -14 47 - GET DEVICE CLEARING CHARACTERISTICS DEC -15 48 - NUMBER OF PHYSICALLY DIFFERENT PENS DEC -20 49 - NUMBER OF CURSORS DEC -16 50 - LORGABILITY DEC -17 51 - MAX. CHARACTER SLANT DEC -18 52 - HARD CLIPPING CAPABILITY DEC -25 53 - INQUIRE CHARACTER PLACEMENT DEC -21 54 - GET CHARACTER SIZE DEC -22 55 - GET LABEL DIRECTION DEC -23 56 - GET LABEL ORIGIN RANGE SKP ************************************************************* * * ASCII COMMAND STRINGS * * FORMAT: FIRST WORD = NUMBER OF BYTES (NEG = WRITE * POS = READ) * * SECOND WORD = TERMINATOR * * NEXT N WORDS = DATA * ************************************************************* * RESET DEC -2 RESET (GIC 1) DEF SEMCL SEMICOLON ASC 1,DF  DF = DEFAULT VALUES * DEFLT DEC -5 DEFAULT P1, P2 (GIC 2) DEF SEMCL SEMICOLON ASC 3,IP;IW IP = INPUT P1 AND P2; IW = INPUT WINDOW * CLEAR DEC -18 CLEAR SCREEN (GIC 3) DEF SEMCL SEMICOLON ASC 9,PU;IW;PA10328,7479 PU=PNUP;IW=IPTWND;PA=PLTABS * HOME DEC -16 HOME PEN (GIC 5) DEF SEMCL SEMICOLON ASC 8,PU;PA10328,7479 PU=PEN UP; PA=PLOT ABSOLUTE * PLTUN DEC 2 PLOT UNITS (GIC 8) DEF SEMCL SEMICOLON ASC 1,OP OP = OUTPUT P1 AND P2 * PNLOC DEC 2 PEN LOCATION (GIC 10,11) DEF SEMCL SEMICOLON ASC 1,OC OC = OUTPUT CURSOR SKP PENDN DEC -2 PEN DOWN (GIC 34) DEF SEMCL SEMICOLON ASC 1,PD PD = PEN DOWN * PENUP DEC -2 PEN UP (GIC 33) DEF SEMCL SEMICOLON ASC 1,PU PU = PEN UP * PLTAB DEC -2 PLOT ABSOLUTE (GIC 35) DEF SEMCL SEMICOLON PA ASC 1,PA PA = PLOT ABSOLUTE * PLTIN DEC -2 PLOT INCREMENTAL (GIC 37) DEF SEMCL SEMICOLON ASC 1,PR PR = PLOT RELATIVE * LGLAB DEC -2 LABEL MODE (GIC 38,39) DEF HT HT = BACK ARROW LB ASC 1,LB LB = LABEL * STPLB DEC -1 STOP LABEL (GIC 40) DEF HT HT = BACK ARROW OCT 1400 DECIMAL 3 (ETX) * SLOFF DEC -2 SLANT OFF (GIC 16) DEF SEMCL SEMICOLON ASC 1,SL SL = ABSOLUTE CHARACTER SLANT * SEMCL OCT 73 SEMICOLON HT OCT 137 BACK ARROW .3 OCT 3 ETX (DECIMAL 3) SKP ************************************************************* * * UTILITY ROUTINES FOR EMULATORS * ************************************************************* * * SETUP -- SET UP IOBUF ADDRESS, GET LUN AND DEVICE * SUBROUTINE SAVE AREA IN GCB *------------------------------------------------------------ * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDR,O IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES, THREE WORDS DEF LUN START AT BUFFER NAME = LU NUMBER DEF .0 DEFAULT LENGTH DEF .1 READ CONT1 LDA IOBUF JSB INDCK PUT ABSOLUTE ADDR INTO A REGISTER STA IOBUF STA IOB VARIABLE CTR FOR I/O BUFFER STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL TERMINATOR (SEMICOLON) STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE TEMPORARY STORAGE FOR READ RTSUP JMP SETUP,I * *------------------------------------------------------------ * INTEG -- CONVERT INCOMING DATA FROM ASCII TO INTEGER *------------------------------------------------------------ * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST ARE WE RETRIEVING PLOT UNITS? CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE RTING JMP INTEG,I SKP *------------------------------------------------------------ * FIXIT *------------------------------------------------------------ * FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * *------------------------------------------------------------ * GB2 -- TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) * AND TRANSFER THIS DATA TO GICB. * * ON ENTRY: A = GCB CODE *------------------------------------------------------------ * GB2 NOP STA GCBCD GCB POINTER JSB GCBIM TRANSFER DATA TO AGL DEF RTGB2 DEF GCBCD GCB CODE (POINTER) DEF ).1 LENGTH OF CODE DEF INTX1 BUFFER NAME DEF LNGTH BUFFER LENGTH DEF .2 WRITE RTGB2 JMP GB2,I * *------------------------------------------------------------ * GB1 -- RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) * TO INTX1(LNTH) * * ON ENTRY: A = GCB CODE *------------------------------------------------------------ * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM GCB DEF RTGB1 DEF GCBCD GCB CODE (POINTER) DEF .1 LENGTH OF CODE DEF INTX1 BUFFER NAME DEF LNTH BUFFER LENGTH DEF .1 READ RTGB1 JMP GB1,I SKP *------------------------------------------------------------ * FINI: 1) CONVERTS INTEGERS TO ASCII * 2) TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT) * 3) RETURNS TO CALLER *------------------------------------------------------------ * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I/O BUFFER DEF NBYTE DEF LNGTH LENGTH OF # ITEMS IN GIC RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE NUMBER OF BYTES TO BE SENT LDB .2 WRITE JSB OUTPT OUTPUT RESULT VIA EXEC CALL RTFIN JMP FIN,I * *------------------------------------------------------------ * TRBYT -- INSERT TERMINATOR INTO THE I/O BUFFER *------------------------------------------------------------ * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM GET TERMINATOR CODE = SEMICOLON JSB PTBYT SEND IT TO OUTPUT BUFFER RTTBT JMP TRBYT,I * *------------------------------------------------------------ * PTBYT -- PUT A BYTE INTO THE I/O BUFFER * * ON ENTRY: A = BYTE TO BE SENT *------------------------------------------------------------ * PTBYT NOP STA BITE JSB UPDTE ε UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE PUT CURRENT BYTE INTO NEXT AVAILABLE DEF RTBYT SPACE DEF NBYTE NUMBER OF BYTES DEF BITE BYTE TO BE SENT DEF ADCNT,I I/O BUFFER RTBYT ISZ NBYTE JSB UPDTE RTPBT JMP PTBYT,I * BITE NOP PTBYT TEMPORARY SKP *------------------------------------------------------------ * UPDTE -- UPDATE BYTE COUNTER FOR I/O BUFFER *------------------------------------------------------------ * UPDTE NOP LDA NBYTE GET NUMBER OF BYTES CLE,ERA CLEAR E AND RIGHT SHIFT E, A ONE BIT ADA IOBUF ADD TO I/O BUFFER ADDRESS STA ADCNT STORE IT AS AN ADDRESS COUNT RTUDT JMP UPDTE,I * *------------------------------------------------------------ * OUTPT -- INPUT/OUTPUT OF DATA (EXEC READ/WRITE CALLS) * * ON ENTRY: A = NUMBER OF BYTES TO BE SENT *------------------------------------------------------------ * OUTPT NOP I/O TRANSFER ROUTINE CMA,INA CHANGE SIGN STA IOCNT BYTE COUNTER FOR OUTPUT STB RW JSB REIO DEF RTOUT DEF RW READ/WRITE CODE DEF LUN CONTROL INFO (ICNWD = LU #) IOB NOP BUFFER LOCATION DEF IOCNT BUFFER LENGTH RTOUT JMP OUTPT,I * *------------------------------------------------------------ * GB -- ON ENTRY: A = ADDRESS OF DATA (CONSTANTS) * B = ADDRESS OF NUMBER OF WORDS *------------------------------------------------------------ * GB NOP GRAPHICS BUFFER STA ADDR ADDRESS OF DATA STB NUM ADDRESS OF NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 GCB POINTER DEF .1 LENGTH OF POINTER ADDR NOP BUFFER NAME NUM NOP BUFFER LENGTH DEF .2 WRITE RTGB JMP GB,I SKP *------------------------------------------------------------ B * WRDST -- STORE A WORD INTO THE I/O BUFFER * * ON ENTRY: A = COMMAND TO BE SENT *------------------------------------------------------------ * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE RTWST JMP WRDST,I SKP ************************************************************* * * EMULATORS * ************************************************************* * EML08 NOP JSB SETUP INITIALIZE INTERNAL VARIABLES LDA GIC GET GRAPHICS INTERPRETIVE CODE CPA .177 DO WE NEED TO PERFORM ERRCK? JMP ERRCK YES LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA CHANGE SIGN TO POSITIVE STA B STORE NUMBER IN B LDA EM0 GET ADDRESS OF SUBROUTINE TABLE JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE THE POINTER LDB LNGTH NUMBER OF ITEMS IN GIC INB INCREMENT TO ACCOMODATE CONTROL WORD AND STB LNTH STORE IT AS TOTAL LENGTH LDA A,I GET ABSOLUTE ADDRESS OF EMULATOR JMP A,I JUMP TO EMULATOR TABLE * EM0 DEF * DEF EMUL1 GET CHARACTER INFORMATION NOP DEF EMUL3 FLOAT TO ASCII CONVERSION DEF EMUL4 DIGITIZE DEF EMUL5 GET NUMBER OF PENS NOP DEF EMUL7 LDIR DEF EMUL8 SLANT ON DEF EMUL9 CHARACTER SIZE DEF EML10 LINE TIME DEF EML11 DISPLAY SURFACE SIZE IN MM DEF EML12 GET MU/MM DEF EML13 SET RELATIVE ORIGIN DEF EML14 GET DEVICE CLEARING CHARACTERISTICS DEF EML15 NUMBER OF PHYSICALL DIFFERENT PENS DEF EML14 LORGABILITY DEF EML17 MAX. CHARACTER SLANT DEF EML18 HARD CLIPPING CAPABILITY DEF EML19 DEVICE ID DEF EML20 NUMBER OF CURSORS DEF EML21 GET CHARACTER SIZE DEF EML22 GET LABEL DIRECTION DEF EML23 GET LABEL ORIGIN RANGE DEF EML24 SET P1,P2 DEF EML25 CHARACTER PLACEMENT SKP *------------------------------------------------------------ * EMULATOR #1 (GIC 9) -- CHARACTER SPACING INFORMATION *------------------------------------------------------------ * EMUL1 LDA .7 JSB GB1 GET CURRENT CHARACTER SIZE LDA .16 JSB GB2 JMP EML08,I * * DEFAULT VALUES = WIDTH * 1.5 * 400 MU/MM * HEIGHT * 2. * 400 MU/MM * CHRW DEC 171. CHRH DEC 300. CHW DEC 2.4 .004 * 600 DEC 4.0 .005 * 800 DEC 10328. DEC 7479. OCT 0 D1.5 DEC 1.5 D2.0 DEC 2.0 * *------------------------------------------------------------ * EMULATOR #3 (GIC 41) -- FLOAT TO ASCII CONVERSION *------------------------------------------------------------ * EMUL3 LDA .3 ETX STA TERM LDA LB LB = LABEL JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML08,I SKP * * GLIDE -- FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DATA TO BE CONVERTED DEF IOBUF,I RESULT DEF NBYTE NUMBER OF BYTES DEF FXDN FORMAT F7.N DEF SKPBK RTGLD JMP GLIDE,I * *------------------------------------------------------------ * EMULATOR #4 (GIC 12) -- DIGITIZE *------------------------------------------------------------ * EMUL4 LDA DP DP = DIGITIZE POINT - TURN ON ENTER LIGHT JSB PROUT EM4LP LDA OS OS = OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF LDB .1 POINT HAS BEEN ENTERED JSB OUTPT LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER LDA INTX1 AND .4 SZA JMP GETPT BIT 2 IS SET GO GET POINT JMP EM4LP  CONTINUE LOOPING UNTIL POINT IS DIGITIZED GETPT LDA OD OD = OUTPUT DIGITIZED POINT JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG LDA .16 JSB GB2 JMP EML08,I SKP * * PROUT * PROUT NOP OUTPUT ASCII COMMAND IN THE A REGISTER JSB WRDST STORE WORD IN IOBUF JSB TRBYT LDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT RTPOT JMP PROUT,I * OD ASC 1,OD OD = OUTPUT DIGITIZED POINT OS ASC 1,OS OS = OUTPUT STATUS DP ASC 1,DP DP = DIGITIZE POINT * *------------------------------------------------------------ * EMULATOR #5 (GIC 15) -- NUMBER OF PENS (SIMULATED OR * OTHERWISE) *------------------------------------------------------------ * EMUL5 LDA .6 SIMULATED PENS (LINE TYPES) STA INTX1 LDA .16 JSB GB2 JMP EML08,I * *------------------------------------------------------------ * EMULATOR #7 (GIC 14) -- LABEL DIRECTION *------------------------------------------------------------ * GICB = DEGREES - 7225 WANTS RUN, RISE * EMUL7 LDA .3 STA FXDN SET UP FOR FLOAT TO ASCII CONVERSION LDA DI DI = ABSOLUTE DIRECTION JSB WRDST LDA .16 JSB GB1 GO GET THETA DLD INTX2 DST INTX4 SAVE FOR RISE COMPUTATION JSB COS COMPUTE RUN NOP DST INTX2 JSB CLGCK EML71 JSB GLIDE CONVERT TO FLOATING POINT LDA COMA JSB PTBYT SKP DLD INTX4 JSB SIN NOP COMPUTE RISE DST INTX2 JSB CLGCK EML72 JSB GLIDE JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP EML08,I * * CLGCK -- CLUGE BECAUSE OF PROBLEMS WITH 1.57 RADIANS (90 DEGREES) * CLGCK NOP JSB ABS FSB SMALL SSA,RSS JMP CLGCK,I DLD DBL0 DST INTX2 JMP CLGCK,I * SMALL DEC .0009 * *------------------------------------------------------------ * EMULATOR #8 (GIC 15) -- CHARACTER SLANT *------------------------------------------------------------ * EMUL8 LDA .3 STA FXDN SET UP FOR 3 CHARACTER TO RIGHT OF . LDA SL SL = ABSOLUTE CHARACTER SLANT JSB WRDST LDA .16 JSB GB1 GET ANGLE DLD INTX2 JSB TAN COMPUTE TAN(THETA) NOP DST INTX2 JSB GLIDE FLOAT TO ASCII JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML08,I * SL ASC 1,SL SL = ABSOLUTE CHARACTER SLANT SKP *------------------------------------------------------------ * EMULATOR #9 (GIC 17) -- CHARACTER SIZE * GICB = WIDTH/HEIGHT *------------------------------------------------------------ * EMUL9 LDA .3 STA FXDN LDA .16 JSB GB1 DLD INTX4 GET HEIGHT AND SAVE DST TEMP LDA SI SI = ABSOLUTE CHARACTER SIZE JSB WRDST DLD INTX2 WIDTH FDV CSIZW MU/CM/MU DST INTX2 JSB GLIDE LDA COMA JSB PTBYT DLD TEMP FDV CSIZH DST INTX2 JSB GLIDE JSB TRBYT LDB .2 LDA NBYTE JSB OUTPT JMP EML08,I * CSIZW DEC 600. MU/CM CSIZH DEC 800. SI ASC 1,SI SI = ABSOLUTE CHARACTER SIZE SKP * *------------------------------------------------------------ * EMULATOR #10 (GIC 28,31,32) -- LINE TYPES - GICB = LT#, *------------------------------------------------------------ * EML10 LDA .3 STA FXDN LDA .16 JSB GB1 GET DATA FROM GCB LDA LT LT = LINE TYPE JSB WRDST LDA INTX2 LT = 0 FOR SOLID SZA,RSS JMP FIN11 ADA LT0 GET LINE TYPE EQUI~oVALENCE FOR 9872 LDA A,I JSB PTBYT LDA LNGTH IS THERE A LENGTH SPECIFICATION CPA .1 JMP FIN12 FIN10 LDA INTX2 CPA .5 JMP FIN11 LDA INTX2 IOR .1 ADA PCLT0 STA TEMP ADDRESS OF PERCENT DIVIDER DLD INTX3 FDV TEMP,I DST INTX2 LDA COMA JSB PTBYT JSB GLIDE FLOAT TO ASCII FIN11 JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML08,I FIN12 LDA INTX2 IS LT = 1(DIM)? CPA .1 JMP *+2 YES JMP FIN14 DLD D22 DST INTX3 JMP FIN10 CONTINUE FIN14 LDA COMA JSB PTBYT SET DEFAULT LINE TYPE LENGTH BACK TO 4% LDA ASC4 JSB PTBYT JMP FIN11 SKP * * LINE TYPES AND PERCENT VALUES * LT ASC 1,LT LT = LINE TYPE DI ASC 1,DI DI = ABSOLUTE DIRECTION LT0 DEF * LT1 OCT 61 LT2 OCT 62 LT3 OCT 63 LT4 OCT 65 LT5 OCT 60 LT6 OCT 66 * * 1% VALUES OF LINE TYPE LENGTHS * PCLT0 DEF * PCLT1 DEC 45. DEC 60. DEC 135. DEC 180. BSS 2 DEC 180. * ASC4 OCT 64 D22 DEC 22.5 * *------------------------------------------------------------ * EMULATOR #11 (GIC 42)-- GET DISPLAY SIZE IN MM *------------------------------------------------------------ * EML11 LDA SIZMM LENGTH LDB DF8 JSB GB JMP EML08,I * SIZMM DEF SZMM * *------------------------------------------------------------ * EMULATOR #12 (GIC 46) -- GET MACHINE UNIT/MM VALUES *------------------------------------------------------------ * EML12 LDA DF40 LDB DF4 JSB GB JMP EML08,I SKP *------------------------------------------------------------ * EMULATOR #13 (GIC 18) -- SET RELATIVE ORIGIN *------------------------------------------------------------ * EML13 LDA .16 JSB GB1 LDA .32 IOSAV JSB GB2 gxJMP EML08,I *------------------------------------------------------------ * EMULATOR #14 (GIC 47) -- DEVICE CLEARING CAPABILITY * (GIC 50) -- LORGABILITY (NONE) *------------------------------------------------------------ * EML14 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EML08,I * *------------------------------------------------------------ * EMULATOR #15 (GIC 48) -- PHYSICAL PENS *------------------------------------------------------------ * EML15 LDA DF1 ONE PEN LDB DF1 JSB GB JMP EML08,I * *------------------------------------------------------------ * EMULATOR #17 (GIC 51) -- MAXIMUM CHARACTER SLANT *------------------------------------------------------------ * EML17 LDA CHSLT LDB DF4 JSB GB JMP EML08,I * *------------------------------------------------------------ * EMULATOR #18 (GIC 52) -- DEVICE HARD CLIPPING CAPABILITY *------------------------------------------------------------ * EML18 LDA DF1 LDB DF1 JSB GB JMP EML08,I DF40 DEF D40 * *------------------------------------------------------------ * EMULATOR #19 (GIC 6) -- DEVICE ID *------------------------------------------------------------ * EML19 LDA IDCD LDB DF3 JSB GB JMP EML08,I SKP *------------------------------------------------------------ * EMULATOR #21 (GIC 54) -- MIN/MAX CHARACTER SIZES *------------------------------------------------------------ * EML21 LDA DFCHR LDB DF9 JSB GB JMP EML08,I * DFCHR DEF CHW DF9 DEF .9 .9 DEC 9 *------------------------------------------------------------ * EMULATOR #22 (GIC 55) -- LABEL DIRECTION INFORMATION * FOR DSTAT OR WHOEVER *------------------------------------------------------------ * EML22 LDA LBLDR LDB DF3 JSB GB JMP EML08,I * LBLDR DEF *+1 OCT 2 DBL0 DEC 0. * IDCD DEF .725A ID CODE (7225A) .725A ASC 3,7225A * *------------------------------------------------------------ * EMULATOR #20 (GIC 49) -- SET SCALING *------------------------------------------------------------ * EML20 LDA DFL0 LDB DF1 JSB GB JMP EML08,I * *------------------------------------------------------------ * EMULATOR #23 (GIC 56) -- LORG RANGE *------------------------------------------------------------ * EML23 LDA DFL0 LDB DF2 JSB GB JMP EML08,I * DFL0 DEF DBL0 SKP *------------------------------------------------------------ * EMULATOR #24 (GIC 45) -- SET HARD CLIP LIMITS *------------------------------------------------------------ * EML24 LDA .16 JSB GB1 GET LIMITS G1,G2 LDA IP IP = INPUT P1 AND P2 JSB WRDST JSB FIN OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT LDA IW IW = INPUT WINDOW JSB WRDST JSB FIN JMP EML08,I * IP ASC 1,IP IP = INPUT P1 AND P2 IW ASC 1,IW IW = INPUT WINDOW * *------------------------------------------------------------ * EMULATOR #25 (GIC 53) -- INQUIRE CHARACTER PLACEMENT *------------------------------------------------------------ * EML25 LDA ACINF LDB DF8 JSB GB JMP EML08,I * ACINF DEF CINFO * CINFO DEC 0.00000 DEC 0.66667 DEC 0.00000 DEC 0.50000 SKP ************************************************************* * * ERROR CHECKING * ************************************************************* * ERRCK JSB EXEC DEF *+3 DEF .3 DEF LUN * * CLEAR ANY ERRORS THAT MAY BE AROUND WITH AN OE * LDA OE OE = OUTPUT ERROR JSB WRDST JSB TRBYT LDA NBYTE LDB .2 WRITE JSB OUTPT SEND THE OE TO THE DEVICE LDA .40 LDB .1 ^ READ JSB OUTPT READ BACK THE RESPONSE CLA STA NBYTE LDA IOBUF STA ADCNT * * * SEE IF DEVICE CHOKES ON AN OI -- IF SO ITS A 9872A * LDA OI OI = OUTPUT IDENTIFICATION JSB WRDST JSB TRBYT LDA NBYTE LDB .2 WRITE JSB OUTPT SEND THE OI TO THE DEVICE CLA STA NBYTE LDA IOBUF STA ADCNT * * CHECK TO SEE IF THE OI CAUSED AN ERROR * LDA OE OE = OUTPUT ERROR JSB WRDST JSB TRBYT LDA NBYTE LDB .2 WRITE JSB OUTPT SEND THE OE TO THE DEVICE LDA .40 LDB .1 READ JSB OUTPT READ THE RESPONSE LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER SKP LDA INTX1 IF BIT ONE IS SET AN ERROR HAS OCCURED AND .1 (THAT MAKES IT A 9872A NOT A 7225A) SZA,RSS JMP LAST1 DO ONE MORE OI -- THIS TIME TO GET THE DEVICE NAME LDA .3 JMP EML08,I WRONG DEVICE FOR SUBROUTINE -- RETURN * * SEND DEVICE OI AND GET DEVICE NAME BACK * LAST1 CLA STA NBYTE LDA IOBUF STA ADCNT LDA OI OI = OUTPUT IDENTIFICATION JSB WRDST JSB TRBYT LDA NBYTE LDB .2 WRITE JSB OUTPT SEND THE OI TO THE DEVICE LDA .40 LDB .1 READ JSB OUTPT READ BACK RESPONSE * * NOW CHECK TO SEE IF WE HAVE A 7225A * LDA IOB STA BUFAD DLD BUFAD,I CPA PART1 JMP CHEK2 JMP ERR3 CHEK2 CPB PART2 JMP OKAY ERR3 LDA .3 JMP EML08,I OKAY LDA .7225 JMP EML08,I * * PART1 ASC 1,72 PART2 ASC 1,25 * OE ASC 1,OE OE = OUTPUT ERROR OI ASC 1,OI OI = OUTPUT IDENTIFICATION .177 OCT 177 .7225 DEC 7225 M7 DEC -7 SKP ************************************************************* * * CONSTANTS AND TEMPORARY STOR"ZXTAGE * ************************************************************* A EQU 0 A REGISTER B EQU 1 B REGISTER * NBYTE NOP # OF BYTES TO BE STORED IN I/O BUFFER LUN NOP LU NUMBER IOBUF NOP I/O BUFFER ADDRESS IOBL NOP I/O BUFFER LENGTH FXDN NOP FORMAT F7.N WHERE N = FXDN FIRST NOP INTX1 NOP GCB INTERFACE TEMPORARIES INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP READ/WRITE CODE IOCNT NOP I/O COUNT TEMP BSS 2 BUFAD NOP TEMPORARY FOR IOB ADDRESS * * DO NO CHANGE POSITION OF THESE CONSTANTS * .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .32 DEC 32 .40 DEC 40 .5 OCT 5 INX DEF INTX1 .17 DEC 17 .21 DEC 21 .7 DEC 7 .137 OCT 137 TERM NOP TERMINATOR DF7 DEF .7 .600 OCT 6000 PR ASC 1,PR SKP SZMM DEC 0. DEC 0. .400 DEC 400. MACHINE LENGTH IN MM .285 DEC 285. MACHINE HEIGHT IN MM DF8 DEF .8 .8 DEC 8 DVCLR DEF .0 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 COMA OCT 54 COMMA GCBCD NOP GRAPHICS CONTROL BLOCK CODE DF4 DEF .4 DF1 DEF .1 DF3 DEF .3 DF2 DEF .2 ADCNT NOP ADDRESS COUNT IBYTE NOP SETUP TEMPORARY LNTH NOP SKPBK NOP .6 DEC 6 OP ASC 1,OP D40 DEC 40.0 DEC 40. END ^Z  92840-18095 1926 S C0122 &DVG04 2608A DEVICE SUBROUTINE             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DVG04 -- 2608A DEVICE SUBROUTINE * SOURCE: 92840-18095 * RELOC: 92840-16010 * * * ************************************************************** * NAM DVG04,7 92840-16010 REV.1926 790507 * * ENT DVG04 EXT .ENTR,EXEC,FLOAT,IFIX,RSTER EXT GCBIM,DCTIM,DCTAD,GIC,EMULX EXT $12LN,$12TP * A EQU 0 B EQU 1 * * * DVG04 NOP JSB DCTIM FILL UP GIC, LENGTH & DEVICE COMMAND LDA GIC CHECK FOR ERROR CHECKING GIC CPA B177 JMP ERRCK GO CHECK FOR ERROR LDA DCTAD SEE WHAT TYPE OF COMMAND THIS IS SSA,RSS EMULATOR ? JMP DVG04,I NO, MUST BE A NOP, DO NOTHING EMULT CMA,INA YES, FIND WHICH ONE ADA EM0 LDA A,I PICK UP EMULATOR ADDRESS JMP A,I GO TO EMULATOR EXIT4 NOP JMP DVG04,I * * ERRCK EQU * CLA STA $12TP JSB RSTER JMP EXIT4 * * * NOP * * RASTR JSB RSTER GO AWAY JMP EXIT4 XMIT CLA MAKE PICTURE VISIBLE JSB RSTER JMP EXIT4 * IDRT LDB DF6 RETURN ID STRING LDA IDSTR JMP RECRD IDSTR DEF *+1 ASC 3,2608A * PLTSP JSB GCBIM DEF *+6 DEF .8 DEF .1 DEF DMPSP DEF .8 DEF .1 LDB PDMSP LDA .8 CMA,INA STA CNT LP1 LDA B,I CPA .0 RSS JMP DFLT1 INB ISZ CNT JMP LP1 JMP DFLT DFLT1 LDA PDMSP JMP DFLT2 DFLT LDA $12LN CALCULATE Y LIMI*T MPY .72 JSB FLOAT DST DFDPS+7 LDA DFDPS DFLT2 LDB DF8 JMP RECRD DMPSP DEC 0.,0.,0.,0. PDMSP DEF DMPSP CNT NOP .72 DEC 72 * * * * NPEN LDA NPENS RETURN # OF PENS LDB DF1 JMP RECRD * SZMM LDA $12LN JSB FLOAT FMP .25.4 DST DSZMM+7 LDA DSZMM RETURN PLATEN SIZE IN MILLI-METERS LDB DF8 JMP RECRD .25.4 DEC 25.4 * * MUPMM LDA DMUMM RETURN MACHINE UNIT'S PER MILLIMETER LDB DF4 JMP RECRD * GB NOP SUBROUTINE TO RETURN VALUES TO AGL STA ADDR STB NUMB JSB GCBIM DEF *+6 DEF .16 DEF .1 ADDR NOP NUMB NOP DEF .2 JMP GB,I TCLR LDA DF2 LDB DF1 JMP RECRD NPEN# LDA DF1 LDB DF1 JMP RECRD NCURS LDA DF0 LDB DF1 JMP RECRD LORGC LDA DF0 LDB DF1 JMP RECRD CSLNT LDA SLNCH LDB DF4 JMP RECRD SLNCH DEF *+1 DEC 0.0,0.0 DFCLP LDA DF0 LDB DF1 JMP RECRD DCHAR LDA CHRDF LDB DF9 JMP RECRD CHRDF DEF *+1 DEC 5.0,7.0,125.0,175.0,0 DLDIR LDA DRLBL LDB DF3 JMP RECRD DRLBL DEF *+1 DEC 2,0.0 RECRD JSB GB JMP EXIT4 LORNG LDA PNT0. LDB DF2 JMP RECRD * * INQUIRE CHARACTER PLACEMENT * CPLMT LDA CINFO LDB DF8 JMP RECRD * CINFO DEF *+1 DEC 0.28000,0.84000,0.11000,0.71000 * B177 OCT 177 $12TY NOP PNT0. DEF *+1 DEC 0. .0 NOP .1 DEC 1 .2 DEC 2 .3 DEC 3 .4 DEC 4 .6 DEC 6 .25 DEC 25 .8 DEC 8 .9 DEC 9 .16 DEC 16 EM0 DEF * EMULATOR DEFINITIONS TABLE DEF RASTR RESET DEVICE DEF XMIT TRANSMIT DRAWING TO PRINTER DEF IDRT RETURN ID STRING DEF PLTSP GET PLOT SPACE HARD CLIP DEF NPEN RETURN NUMBER OF PENS DEF SZMM SIZE OF DEVICE IN mm. DEF MUPMM RETURN MACHINE UNITS/mm DEF TCLR TYPE OF CLEAR DEF NPEN# NUMBER OF PENS DEF NCURS # OF CURSORS DEF LORGC ABILITY TO SET LABEL ORIGIN DEF CSLNT MAXIMUM CHARACTER SLANT DEF DFCLP HARD CLIPPING CAPABILITY DEF DCHAR DEFAULT CHARACTER SIZE DEF DLDIR LABEL DIRECTION INQUIRY DEF LORNG LABEL ORIGIN RANGE REQUEST DEF CPLMT INQUIRE CHARACTER PLACEMENT * * DFDPS DEF *+1 DEC 0.,0.,920.,720. DF8 DEF .8 DF9 DEF .9 DF3 DEF .3 DF4 DEF .4 DF6 DEF .6 NPENS DEF *+1 DEC 25 DF0 DEF .0 DF1 DEF .1 DF2 DEF .2 DSZMM DEF *+1 DEC 0.,0.,324.555555,254. DMUMM DEF *+1 DEC 2.8346457,2.8346457 ENT DCT04 ********************************************************* * THIS IS THE DEVICE COMMAND TABLE FOR THE 2608A * * LINE PRINTER. * * * ********************************************************* SPC 3 DCT04 NOP DEF D2608 DEC 0 DEC 0 DEC -1 RASTER DEC -2 TRANSMIT DEC -1 DEC -3 RETURN ID STRING DEC -1 DEC -4 DEC -1 DEC -1 DEC -1 DEC -1 DEC 0 DEC -1 DEC 0 DEC 0 DEC -1 DEC 0 DEC -1 DEC -1 DEC -1 DEC 0 DEC 0 DEC 0 DEC -1 DEC -1 DEC -1 DEC -1 DEC -5 DEC 0 DEC -1 DEC 0 DEC -1 DEC -1 DEC -1 DEC 0 DEC 0 DEC -1 DEC -1 DEC 0 DEC -1 DEC -6 DEC 0 DEC 0 DEC 0 DEC -7 DEC -8 DEC -9 DEC -10 DEC -11 DEC -12 DEC -13 DEC -17 INQUIRE CHARACTER PLACEMENT DEC -14 DEC -15 DEC -16 * * * DEVICE ID CHEC K OUT * * D2608 NOP LDA .2608 JMP D2608,I .2608 DEC 2608 END   92840-18096 2040 S C0122 &RSTER SOURCE             H0101 $ASMB,R,L,C,X * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: RSTER -- 2608A DEVICE SUBROUTINE * SOURCE: 92840-18096 * RELOC: 92840-16010 * * * ************************************************************** * NAM RSTER,7 92840-16010 REV.2040 800807 * ************************************************************** * * MODIFIED BY PHIL P. AT BOISE TO CORRECT ABORT AND INFINITE * LOOP PROBLEM FOR THE 2040 PCO. * * MODIFIED BY DJS TO CORRECT LABELING PROBLEM WITH SESSION * FOR THE 2040 PCO. * *************************************************************** * ENT RSTER,WIDTH,$12TP,PICFL,PICMG,LNSET,LUSET,LGSET ENT FFRST * EXT .ENTR,EXEC,FLOAT,IFIX,PURGE,FLTAS EXT READF,WRITF,OPEN,CREAT,CLOSE,LOCF EXT $LIBR,$LIBX,GRSTS,LNGTH,$CVT3 EXT GCBIM,DCTIM,DCTAD,GIC,EMULX,LOGLU EXT $12B1,$12B2,$12BF,LURQ,$12LN,$12LU,$12LG * A EQU 0 B EQU 1 * * * *********** *** *** *** * * * * * HED WHERE ROUTINE ********** *** *** *** * * **** ** WHERE **** * * THE -WHERE- CALL ALLOWS THE USER TO DETERMINE THE * CURRENT PLOTTER PEN POSITION (RELATIVE TO ORIGIN * ESTABLISHED IN FACT). THE NUMBERS PROVIDED * TO THE USER WILL BE IN FLOATING POINT. * * - FORTRAN LINKAGE - * * CALL WHERE(X,Y) * * X SPECIFIES THE 2 WORD BUFFER FOR X. * Y SPECIFIES THE 2 WORD BUFFER FOR Y. * * * * * * * - CALLING SEQUENCE - * * JSB WHERE WHERE ROUTINE ORIGIN * DEF *+3 RETURN * DEF XC LOCATION OF USER X 2 WD BUFFER * DEF YC LOCATION OF USER Y 2 WD BUFFER * * ** ** ** ** ** * * WHERE NOP LDA XPEN FETCH CURRENT X POSITION LDB YPEN FETCH CURRENT Y POSITION DST CRNT LDA PENP STA CRNT+2 LDA PCRNT LDB DF3 JMP RECRD CRNT BSS 3 PCRNT DEF CRNT HED RSTER AGL INTERFACE SUBROUTINE * RSTER NOP JSB DCTIM FILL UP GIC, LENGTH & DEVICE COMMAND LDA GIC CHECK FOR ERROR CHECKING GIC CPA B177 JMP ERRCK GO CHECK FOR ERROR JSB RECVR GO RECOVER VARIABLES LDA LBLFL CHECK TO SEE IF LAST COMMAND WAS A LABEL SZA JSB NDLBL EMULT LDA GIC YES, FIND WHICH ONE ADA EM0 LDA A,I PICK UP EMULATOR ADDRESS SZA,RSS JMP RSTER,I JMP A,I GO TO EMULATOR RECVR NOP JSB GCBIM RETREIVE DATA FROM IDCB DEF RTN1X DEF .32 DEF .1 DEF SYLU DEF .66 DEF .1 RTN1X LDB P$BF3 LDA PIDC2 MVW D16 JMP RECVR,I EXIT4 JSB RCD JMP RSTER,I * * ERRCK EQU * LDA $12LU STA SYLU LDA $12LN LDB $12LN ADB MD1 SSB,RSS STA TSIZE CCA STA FLPSS LDA DUMNM RESET DUMMY NAME LDB QNAME MVW .3 CLA STA ISECU STA ICR JSB GCBIM GET INFO FROM GCB DEF ERR0 DEF RD2 DEF .2 DEF FWAM DEF .0 DEF .1 ERR0 JSB EMULX,I CHECK DCTID CPA .2608 IS IT A 2608 DEVICE TABLE? JMP ERR1 YES, GO CHECK DRIVER LDA .3 NO, FLAG ERROR JMP ERRPT ERR1 LDA PTS12 LOOK AT LOGICAL UNIT STA IOBFL LDA NWLM STA IOBUF LDA FWAM SET UP LU'S STA LUN LDA $12TP SZA JMP ERR4 LDA SYLU ADA MD1 ADA 1652B LOOK AT DRT LDA A,I AND B77 STRIP OUT EQT ENTRY ADA MD1 MPY D15 ADA 1650B FIND EQT ADDRESS ADA D4 LOOK AT WORD 5 LDA A,I ALF,ALF AND B77 CPA B12 IS IT A TYPE 12 JMP ERR4 YES, OK LDA .5 NO, FLAG ERROR JMP ERRPT FWAM NOP NWLM NOP PTS12 NOP P$BF1 DEF $12B1 P$BF2 DEF $12B2 P$BF3 DEF $12B3 ERR4 LDB P$BF3 JSB INDCK STB IOBUF LDA $12BL STA IOBFL ERR41 JSB INIT INITIALIZE PLOT FILE SZA,RSS JSB POSTI ERRPT STA INTX1 REPORT FINDINGS CCA SET CLEAR SKIP FLAG STA CSKPF LDA INX LDB DF1 JMP RECRD TELL AGL AND GO AWAY CSKPF NOP .2608 DEC 2608 B77 OCT 77 B100 OCT 100 B177 OCT 177 INX DEF INTX1 RD2 DEC 2 DEC 4 * NDLBL NOP STOP LABEL OUTPUT AND RETURN X & Y LDA $12BF CHECK TO SEE IF SYMBR IS THROUGH SLA JSB WAIT NO, WAIT FOR IT TO FINISH LDB P$BF1 RETRIEVE X AND Y JSB INDCK ADB .7 LDA B,I STA IX INB LDA B,I STA IY CLA,INA STA PENP JSB LBLND JSB LURQ UNLOCK LU DEF *+4 DEF .0 DEF LUN DEF .1 JSB INIT CLA STA LBLFL JMP NDLBL,I LBLND NOP JSB $LIBR NOP LDB P$BF JSB INDCK INB CLA STA B,I JSB $LIBX RETURN TO CALLING PROGRAM DEF LBLND P$BF DEF $12BF WAIT NOP WAIT FOR SYMBR TO FINISH LDA DWNCT TIME OUT IF IT NEVER HAPPENS PP2040 STA DEAD PP2040 WAIT1 JSB EXEC SEND DUMMY CONTROL CALL TO DRIVER PP2040 DEF *+6 DEF .12 DEF .0 DEF .1 DEF .0 DEF MD25 LDA $12BF SLA,RSS Pp2040 JMP WAIT,I PKP2040 ISZ DEAD CHECK FOR THE COUNT TO GO TO ZERO Pp2040 JMP WAIT1 Pp2040 CLA PP2040 JSB CLRFG PP2040 LDA .13 FLAG AN ERROR TO GPS PP2040 JMP ERRPT PP2040 CLRFG NOP CLEAR THE BUFFER FLAG PP2040 CLA Pp2040 JSB $LIBR GET INTO THE GAME PP2040 NOP PP2040 STA $12BF RESET THE BUSY FLAG PP2040 JSB $LIBX GO AWAY PP2040 DEF CLRFG PP2040 DEAD NOP PP2040 DWNCT DEC -60 PP2040 .12 DEC 12 MD25 DEC -25 CMDW OCT 2400 * STLBL NOP LOCK LU JSB LURQ DEF *+4 DEF .1 DEF LUN DEF .1 STLB1 JSB $LIBR NOP LDA PSYLU LDB P$BF1 JSB INDCK MVW .16 CLA,INA LDB P$BF JSB INDCK INB STA B,I JSB $LIBX DEF STLBL * SLBL NOP SHORT LABEL JSB SLBLT JMP EXIT4 SLBLT NOP LDA $12LG STA LANGC JSB STLBL CCA STA LBLFL SET LABEL FLAG JSB ICLOS JMP SLBLT,I * INDCK NOP STA INDTM LDA B SSA,RSS JMP INDEX AND M7777 LDA A,I JMP INDCK+3 INDEX STA B LDA INDTM JMP INDCK,I INDTM NOP RCD NOP INITIALIZE IDCB EXTENSION LDA P$BF3 LDB PIDC2 MVW .16 JSB GCBIM OPEN DRIVER DEF RTN2X DEF .32 DEF .1 DEF SYLU DEF .66 DEF .2 RTN2X JMP RCD,I .13 DEC 13 Pp2040 .32 DEC 32 .66 DEC 68 BIT15 OCT 100000 PIDC2 DEF IDCBB PSYLU DEF SYLU DUMNM DEF *+1 ASC 3,P@@@@@ .15 DEC 15 SYLU DEC 6 QNAM ASC 3,P@@@@@ FILE NAME ICR NOP CART REF # SCALE DEC 1.001 SCALE FACTOR IX NOP CURRENT PEN POSITION IY NOP " " " SANG DEC 0. LABELING ANGLE WIDT OCT 1 WIDTH OF LINE DMODE NOP LANGC DEC 0 LANGUAGE CODE ISECU NOP SECURITY CODE OF PLOT FILE TSIZE DEC 10 LENGTH OF PLOT WIDP OCT 1 WIDTH OF PERPENDICULAR WIDH OCT 0 WIDTH OF DIAGNAL XPEN BSS 2 LAST PEN POSITION YPEN EQU XPEN+1 " " " J NOP INDEX OF 0 RECORD - RD ON DISK WHERE 0,0 RESIDES MAPSZ BSS 2 MAP SIZE IN RECORDS IBUF NOP ADDRESS OF CURRENT BUFFER ARCMB NOP ADDRESS OF RECORD MAP BUFFER IDCBS NOP SIZE OF PLOT BUFFER - MAP SIZE + LENGTH OF IBUF ILG NOP LENGTH OF IBUF FDRN NOP ADDRESS OF FIRST DATA RECORD NUM NOP FIRST RECORD IN CORE LNUM NOP LAST RECORD IN BUFFER NRIC NOP # OF RECORDS IN CORE IOBUF NOP POINTER TO IDCB IDCB NOP POINTER TO DISC BUFFER IOBFL NOP LENGTH OF IOBUF LBLFL NOP LABEL FLAG LUN NOP LU OF DUMMY DRIVER PENP DEC 1 PEN POSITION TLINE NOP LINE TYPE FLPSS NOP REP1 NOP LINE TYPE REPETITION FACTORS REP2 NOP " " " " REP3 NOP " " " " REP4 NOP " " " " REP5 NOP " " " " REP6 NOP " " " " NOP NEXT DEF REP2 POINTER TO NEXT REP FACTOR ON LINE ON? DEC 1 LINE TYPE PEN STATUS - 1 MEANS DOT PLOT POINT CNT DEC -1 CURRENT LINE REP COUNT PEN DEC 1 CURRENT PEN NUMBER LINFL DEC 0 LINE FLAG FFFLG DEC 0 FOXRM FEED FLAG IDCBB BSS 16 BUFFER AREA TO SAVE FILE IDCB * RCDCT DEC 41 B12 OCT 12 D15 DEC 15 D4 DEC 4 * * * CLEAR NOP GO AWAY LDA CSKPF SSA JMP CLREX LDA FLPSS STA CLRTM CCA STA FLPSS JSB ICLOS LDA CLRTM STA FLPSS JSB INIT JSB POSTI CLREX CLA STA CSKPF JMP EXIT4 CLRTM NOP XMIT JSB DRAW MAKE PICTURE VISIBLE JMP EXIT4 * FINIT NOP JSB ICLOS CLEAN UP FILE JMP EXIT4 * HOME JSB LLEFT GO TO LOWER LEFT (HOME) DEF *+1 JMP EXIT4 * * * * CHSZE DLD SCALE FIND CHARACTER SCALE FMP ..7 CONVERT TO MU'S DST IRTN1 DLD SCALE FMP ..10 DST IRTN2 LDB DF4 LDA IRTN JMP RECRD IRTN DEF *+1 IRTN1 DEC 1. IRTN2 DEC 1. ..7 DEC 9.945 *** ..10 DEC 10.0 * * LDIR LDA .3 READ BACK LABEL ANGLE FROM AGL STA LNTH JSB GB1 DLD INTX1+1 SET ANGLE FOR SYMBR DST SANG JMP EXIT4 * * * SSIZE LDA .5 SELECT CHARACTER SIZE STA LNTH JSB GB1 READ CHARACTER HEIGTH DLD INTX1+3 FDV ..7 SOC JMP SZDFL IF DIVIDE FAILS SET SIZE DEFAULT DST SCALE SAVE SCALE JMP EXIT4 EXIT ROUTINE SZDFL DLD ..101 LOAD DEFAULT DST SCALE PUT IN SCALE JMP EXIT4 GET OUT ..101 DEC 1.001 * * FSVFL LDA .6 STA LNTH JSB GB1 LDA PNTX1 MOVE FILE NAME TO USE AREA LDB RNAME MVW .5 JSB DUPFL JMP EXIT5 * SPEN0 JSB MODE SELECT PEN 0 DEF *+2 DEF .0 CLA STA PEN JMP EXIT4 * SPEN1 JSB MODE SELECT ERASE PEN DEF *+2 DEF .1 JMP EXIT4 * SPEN2 JSB MODE SELECT COMPLEMENT PEN DEF *+2 DEF .2 JMP EXIT4 * SPENN LDA .2 STA LNTH JSB GB1 SELCT PEN N, SET WIDTH LDA INTX1+1 INA STA PEN SSA CLA,INA JSB MODE DEF *+2 DEF .0 LDA PEN LDB LINFL SZB JMP EXIT4 ADA MD1 CLB DIV .4 STB TLINE JMP PENSU * * LINTY LDA .2 READ LINE TYPE FROM AGL STA LNTH SAVE AS LENGTH JSB GB1 READ FROM AGL LDA INTX1+1 PICKUP LINE TYPE CLB DIV .7 TAKE MODULO 6 STB TLINE SAVE LINE TYPE STB LINFL JMP PENSU RETURN TO AGL * * PENUP CLA,INA SET PEN UP STA PENP PENSU LDA PREP2 REINITIALIZE THE LINE TYPE REP FACTORS STA NEXT JSB LINSU CLA,INA STA ON? LDA REP1 CMA,INA SZA,RSS LDA BIT15 STA CNT JMP EXIT4 * PENDN LDA PEN SZA,RSS JMP PENUP CLA PUT PEN DOWN STA PENP JMP EXIT4 * PLABS LDA LNGTH PLOT ABSOLUTE INA STA LNTH JSB GB1 LDA INX INA LDB LNGTH BRS CMB,INB STB PABCT STA PINDX PLABL DLD PINDX,I JSB PLOT JSB POSTI ISZ PINDX ISZ PINDX ISZ PABCT JMP PLABL JMP EXIT4 PINDX NOP PABCT NOP * * * * * GB NOP SUBROUTINE TO RETURN VALUES TO AGL STA ADDR STB NUMB JSB GCBIM DEF *+6 DEF .16 DEF .1 ADDR NOP NUMB NOP DEF .2 JMP GB,I GB1 NOP JSB GCBIM DEF RTGB DEF .16 DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGB JMP GB1,I RECRD JSB GB JMP EXIT4 FPASC LDA .3 STA LNTH JSB GB1 JSB GCBIM RETURN F7.N"VALUE DEF *+6 DEF .26 DEF .1 DEF N DEF D0 DEF .1 CLA STA BYTE LDA DSPC STA NUMBF STA NUMBF+1 STA NUMBF+2 STA NUMBF+3 JSB FLTAS CONVERT F.P. VALUE DEF *+5 DEF INTX1+1 DEF NUMBF DEF BYTE DEF N JSB SLBLT LDA BYTE CMA,INA STA BYTE JSB EXEC DEF *+5 DEF D2 DEF LUN DEF NUMBF DEF BYTE JSB NDLBL JMP EXIT4 DSPC OCT 20040 NUMBF BSS 4 N DEC 0 BYTE DEC 0 INTX1 BSS 11 LNTH NOP .0 NOP .1 DEC 1 .2 DEC 2 .3 DEC 3 .4 DEC 4 .5 DEC 5 .6 DEC 6 .25 DEC 25 .26 DEC 26 .7 DEC 7 .8 DEC 8 .9 DEC 9 .16 DEC 16 EM0 DEF * EMULATOR DEFINITIONS TABLE DEF 0 RESET DEVICE DEF 0 DEFAULT P1 & P2 DEF CLEAR CLEAR FILE DEF XMIT TRANSMIT DRAWING TO PRINTER DEF HOME HOME PEN DEF 0 RETURN ID STRING DEF FINIT FINISH PLOT AND CLEAN UP DEF 0 GET PLOT SPACE HARD CLIP DEF CHSZE GET CHARACTER SIZE DEF WHERE GET PEN LOACATION DEF WHERE NO FUNCTION, RETURN DEF WHERE NO FUNCTION, RETURN DEF 0 SET LABEL ORGIN DEF LDIR SET LABEL DIRECTION DEF 0 SET CHARACTER SLANT DEF 0 TURN OFF CHARACTER SLANT DEF SSIZE SET CHARACTER SIZE DEF 0 SET PLOT ORIGIN DEF PICF1 CREATE CURRENT PICTURE FILE WITH NAME DEF PICF2 REPLACE CURRENT PICTURE FILE DEF FSVFL DUPLICATE A PICTURE FILE INTO CURRENT FILE DEF 0 SET ORGIN AT PEN DEF 0 NO FUNCTION, RETURN DEF 0 NO FUNCTION, RETURN DEF SPEN0 SELECT PEN 0 DEF SPEN1 SELECT PEN -1 DEF SPEN2 SELECT PEN -2 DEF SPENN SLEECT PEN N DEF 0 RETURN # OF PENS DEF 0 NO FUNCTION, RETURN DEF LINTY SELECT LINE TYPE,DEFAULT LENGTH DEF 0 SELECT LINE TYPE AND LENGTH DEF PENUP SET PEN UP DEF PENDN SET PEN DOWN DEF PLABS PLOT ABSOLUTE DEF 0 PLOT RELATIVE DEF 0 PLOT INCREMENTAL DEF SLBL START SHORT LABEL DEF SLBL START LONG LABEL DEF 0 STOP LONG LABEL (NOT YET IMPLEMENTED) DEF FPASC CONVERT F.P. TO ASCII AND LABEL DEF 0 SIZE OF DEVICE IN mm. DEF 0 NO FUNCTION, RETURN DEF 0 NO FUNCTION, RETURN DEF 0 SET HARD CLIP LIMITS DEF 0 RETURN MACHINE UNITS/mm DEF 0 TYPE OF CLEAR DEF 0 NUMBER OF PENS DEF 0 # OF CURSORS DEF 0 ABILITY TO SET LABEL ORIGIN DEF 0 MAXIMUM CHARACTER SLANT DEF 0 HARD CLIPPING CAPABILITY DEF 0 NOT YET DEFINED DEF 0 DEFAULT CHARACTER SIZE DEF 0 LABEL DIRECTION INQUIRY DEF 0 LABEL ORIGIN RANGE REQUEST * * HCL1 DEC 0,0 HCL2 DEC 924,720 DF3 DEF .3 DF4 DEF .4 TEMPZ NOP NPENS DEF *+1 DEC 1 DF0 DEF .0 DF1 DEF .1 HED DRAW ROUTINE FOR 2608 * * DRAW ROUTINE FOR 2608 * * * * * $12TP NOP DRAW NOP JSB SETBF JSB POSTI LDA J ADA MD1 CLB DIV D16 SZB INA STA MPSZE JSB LURQ LOCK THE LIST DEVICE DEF *+4 DEF .1 DEF SYLU DEF .1 LDA $12TP SZA JMP RSTSD USE RASTER STANDARD PROTOCOL LDA FFFLG CHECK FORM FEED FLAG SSA JMP FFBR1 DO NOT ISSUE FORM FEED LDA SYLU COMMAND INTO GRAPHICS MODE IOR B1100 STA CMDWP JSB EXEC DEF *+4 DEF .3 DEF CMDWP DEF MD1 FFBR1 LDA SYLU COMMAND INTO GRAPHICS MODE IOR B3000 STA CMDWP JSB EXEC DEF *+4 DEF .3 DEF CMDWP DEF .2 JMP BCKCT RSTSD NOP LDA SYLU < IOR B100 STA TLU LDA FFFLG CHECK FORM FEED FLAG SSA JMP FFBR2 DO NOT ISSUE FORM FEED JSB EXEC DEF *+5 DEF .2 DEF SYLU DEF FFEED DEF MD1 FFBR2 JSB EXEC SEND OUT RASTER COMMAND TO GRAPHICS DEF *+5 DEF .2 DEF TLU DEF RSTRT DEF RSTRL BCKCT LDA ARCMB ADDR. OF START OF MAP ADA MD16 BIAS TO IDCB STA IDCB1 PACK POINTER TO DCB ADA D17 POINT BACK TO START+1 STA AR1MB ACTUAL START OF MAP LDA MPSZE NO. WORDS TO CHECKRDS CMA,INA STA IDX1 INITIALIZE INDEX CLA STA SRNUM STARTING RCD. NO. IN CORE STA LNUM1 LAST RCD. NO. IN CORE LDB AR1MB ADDR. RCD. MAP BUFFER NXTRO EQU * NEXT ROW STB ADMAP CURRENT POINTER TO MAP LDA MD16 16 BITS/WORD STA IDX2 INITIALIZE INDEX LDA B,I NEXT MAP WORD NXTBT EQU * NEXT BIT CLE,ELA STA CBITW CURRENT BIT WORD SEZ,RSS BIT SET? JMP NOBIT NO *CALCULATE DESIRED RECORD NO. LDA D16 ADA IDX2 SUBTRACT CURRENT PASS STA DR1DN SAVE DESIRED BIT NO. TEMPORARILY LDA AR1MB ADDR. OF RCD. MAP BUFFER LDB ADMAP CURRENT POINTER TO MAP CMA,INA ADA B CALC. NO. WORDS ALREADY PROCESSED MPY D16 16 BITS/WORD (RECORDS/WORD) ADA DR1DN INCLUDE PARTIAL WORD PROCESSED STA DR1DN SAVE DESIRED RECORD NO. CMA ADA SRNUM CURRENT RCD. NO. IN CORE SSA,RSS .LT. JMP GE1RN YES, GET DESIRED RCD. LDA DR1DN DESIRED RCD. NO. CMA,INA ADA LNUM1 LAST RCD. NO. IN CORE SSA,RSS .LE. JMP RC1OK YES, RECORD IN CORE GE1RN EQU * GET RECORD NO. LDA DR1DN DESIRED RCD. NO. STA B ADA NRIC CHECK FOR FILE OVERRUN CMA,INA ADA uISIZE SSA,RSS JMP GRDOK RECORD NUMBER IS OK LDB NRIC MAKE READ LEGAL CMB,INB ADB ISIZE INB GRDOK LDA B STA SRNUM MAKE IT THE 1ST RCD TO BE READ ADA NRIC LENGTH OF BUFFER (IN RECORDS) ADA MD1 STA LNUM1 LAST RCD. NO. IN CORE * READ THE DESIRED RECORD(S) INTO CORE JSB READF DEF *+7 DEF IDCB1,I DEF QERR DEF IBUF,I DEF ILG DEF QLEN DEF SRNUM CPA MD12 EOF? JMP DRAWR YES SSA ANY ERRORS? JMP ERRPR YES RC1OK EQU * * CALC. STARTING ADDR. OF DESIRED ROW LDA SRNUM 1ST RCD. NO. IN CORE CMA,INA ADA DR1DN DESIRED RCD. NO. ALF,ALF *256 ARS 12 = * 128 (128 WDS/RCD.) ADA IBUF START OF BUFFER STA A1ROW START OF "LEFT" ROW MAP SIZE LDA IFORM NO. OF COMPLETELY BLANK ROWS SZA SLEW LINES? JSB SLEWL YES *OUTPUT "LEFT" ROW OF BINARY INFO TO 2608 LDB A1ROW START OF LEFT ROW JSB RPACK REPACK "LEFT" BUFFER *OUTPUT "RIGHT" ROW OF BINARY DATA LDB A1ROW START OF LEFT ROW ADB D64 BIAS TO "RIGHT" ROW JSB RPACK REPACK "RIGHT" BUFFER CKNRO EQU * CHECK NEXT ROW LDA CBITW WORD FOR CURRENT BIT BEING PROC. ISZ IDX2 FINISHED WITH THIS WORD? JMP NXTBT NO LDB ADMAP CURRENT POINTER TO MAP INB BUMP POINTER TO MAP ISZ IDX1 FINISHED WITH ALL CHARACTERS? JMP NXTRO NO, CHECK NEXT ROW LDA IFORM NO. OF COMPLETELY BLANK ROWS SZA SLEW LINES? JSB SLEWL YES DRAWR LDA $12TP SET BACK TO CHARACTER MODE SZA JMP STPRS STOP RASTER OUTPUT JSB EXEC DEF *+4 DEF .3 DEF CMDWP DEF D0 JMP STPRT STPRS JSB EXEC DEF *+5 DEF .2 DEF SYLU DEF STORS DEF STPRL STPRT JSB LURQ DEF *+4 DEF .0 DEF SYLU DEF .1 JMP DRAW,I RETURN RSTRT ASC 2,*rA RSTRL DEC 2 FFEED ASC 1, TLU NOP STORS ASC 2,*rB STPRL DEC 2 * * CMDWP NOP NOBIT EQU * NO BIT SET LDA IFORM CURRENT NO. LINES TO SLEW ADA D2 2 ROWS/RCD. STA IFORM BUMP COUNT JMP CKNRO NO. CHECK NEXT RECORD * * * SLEWL NOP SLEW LINES ON 2608 STA TMPS LDA $12TP SZA JMP RSTSL LDA SYLU SET UP COMMAND WORD IOR B1100 STA BCNWD LP1 LDA TMPS ADA MD56 SEND OUT SLEW IN INCREMENTS OF 55 SSA JMP FSLEW FINISH SLEW INA SAVE NUMBER OF LINES LEFT TO SLEW STA TMPS LDA D55 SLEW 55 LINES JSB SLEWS JMP LP1 GO BACK FOR REST FSLEW LDA TMPS SLEW ALL THAT ARE LEFT SZA NONE TO SLEW JSB SLEWS YES, GO SLEW THEM JMP SLEWL,I RSTSL LDA TMPS CCE JSB $CVT3 RAL LDB RSCPT RBL JSB PCKNU LDA AY SBT LDA PSLST RAL CMA,INA ADA B CMA,INA STA RSCNT JSB EXEC DEF *+5 DEF .2 DEF TLU PSLST DEF RSLEW DEF RSCNT CLA STA IFORM JMP SLEWL,I RSLEW ASC 2,*r0 NOP NOP NOP AY ASC 1, Y AW ASC 1, W PCKNU NOP CBY STA B LDA MD6 STA RSCNT LPCK LBT CBX CYB CPA B40 RSS SBT CBY CXB ISZ RSCNT JMP LPCK CYB JMP PCKNU,I RSCNT NOP RSCPT DEF RSLEW+2 MD6 DEC -6 B40 OCT 40 TMPS NOP B1100 OCT 1100 BCNWD NOP MD56 DEC -56 SLEWS NOP STA IFORM RESTORE IT JSB EXEC DEF *+4 DEF D3 DEF BCNWD DEF IFORM SSA ANY ERRORS? JMP ERRPR YES CLA STA IFORM RESET NO. LINES TO SLEW JMP SLEWS,I RETURN * * CONVERT FROM 16 DOTS/WORD TO 14 DOTS/WORD * (8 DOTS/BYTE TO 7 DOTS/BYTE) * RPACK NOP REPACK BUFFER FOR 2608 LDA B,I GET BUFFER LENGTH (IN BITS) SZA,RSS ANY BITS TO PROCESS? CLA,INA NO, MAKE IT AT LEAST ONE STA BUFLG+1 SAVE BUFFER LENGTH (IN BITS) INB POINT TO ACTUAL DATA STB IBUFR SAVE POINTER TO INPUT BUFFER CLB DIV D16 16 BITS/WORD SZB REMAINDER? INA YES INCLUDE PARTIAL WORD SZA,RSS ANYTHING TO OUTPUT? INA NO,CANNOT ALLOW ZERO STA BUFLG PACK INDEX FOR NO. OF WORDS LDA $12TP SZA JMP RPRST * OUTPUT GRAPHICS DATA TO 2608 JSB EXEC DEF *+5 DEF D2 DEF SYLU IBUFR NOP DEF BUFLG SSA ANY ERRORS? JMP ERRPR YES, PROCESS THEM JMP RPACK,I RETURN RPRST LDA ESCWT LDB AJDCB RAL RBL MBT .3 STB TEMBT LDA BUFLG ALS STA MVCT CCE JSB $CVT3 RAL LDB TEMBT JSB PCKNU LDA AW SBT LDA IBUFR RAL MBT MVCT LDA AJDCB RAL CMA,INA ADA B CMA,INA STA OTPCT JSB EXEC DEF *+5 DEF .2 DEF TLU DEF JDCB DEF OTPCT JMP RPACK,I OTPCT NOP ESCWT DEF *+1 ASC 2,*b TEMBT NOP MVCT DEC 0 SKP D0 DEC 0 IDCB1 OCT 0 POINTER TO FILE CURRENTLY OPEN MPSZE OCT 0 MAP SIZE IN WORDS IDX1 OCT 0 TEMP INDEX IDX2 OCT 0 TEMP INDEX SRNUM OCT 0 STARTING RCD. NO. IN CORE LNUM1 OCT 0 LAST RCD. NO. IN CORE AR1MB NOP ADDRESS OF RECORD MAP BUFFER FOR DRAW ADMAP OCT 0 CURRENT MAP POINTER CBITW OCT 0 CURRENT BIT WORD DR1DN OCT tO0 DESIRED RCD. NO. QERR OCT 0 QLEN OCT 0 FMP RETURNS # WDS. XFERED A1ROW OCT 0 ADDR. OF DESIRED ROW AND ROW+1 BUFLG OCT 0,0 OUTPUT BUFFER LENGTH(WORDS,BITS) IFORM OCT 0 NO. OF LINES TO SLEW D17 DEC 17 B3000 OCT 3000 HED PLOT ROUTINE *********** ******** ****** * * ***** PLOT **** * * * THE -PLOT- ROUTINE CONVERTS THE DEFINED X,Y * PARAMETERS AND PLOTS THE "LINE". * * * - FORTRAN LINKAGE - * * CALL PLOT(X,Y,IC) * * -X,Y DEFINES THE NEW COORDINATE TO BE PLOTTED. * * -IC DEFINES THE PEN UP/DOWN COMMAND. * * * * * * - CALLING SEQUENCE - * * JSB PLOT PLOT ROUTINE ORIGIN * DEF *+4 * DEF X ADDRESS OF X COORDINATE. * DEF Y ADDRESS OF Y COORDINATE. * DEF IC ADDRESS OF PEN COMMAND. **** ****** * * * PLOT NOP CALLED FROM PLABS TO GENERATE LINE STA IX STB IY DOFST EQU * DO OFFSET CALCULATIONS DLD XPEN LOAD OLD X,Y PLOT DATA * * XPEN AND YPEN ARE IN 2 CONSECUTIVE * LOCATIONS FOR THIS DOUBLE LOAD. * * THE NEW DX,DY (IDX,IDY) WILL BE * CALCULATED AS FOLLOWS: * * IX - XPEN = IDX * IY - YPEN = IDY * * WHERE IX = NEW X * IY = NEW Y * XPEN = OLD X * YPEN = OLD Y * DIF CMA,INA 2'S COMPLEMENT XPEN CMB,INB 2'S COMPLEMENT YPEN ADA IX IX - XPEN ADB IY IY - YPEN DST IDX * CALC. ABSOLUTE VALUE OF NEW & OLD COORD. * DETERMINE PLOT MODE AND DRAW THE LINE.... * LDA TLINE CHECK LINE TYPE FOR JUST END POINTS CPA .5 JMP PU.5 PLOT JUST THE END POINTS LDA PENP GET PEN COMMAND SLA JMP PU.3 MOVE WITH PEN UP DLD IDX SZA JMP CONTC MOVE WITH PEN DOWN SZB,RSS JMP PU.1BK PLOT POINTS CONTC JMP PU.2 GO PLOT LINE PU.1 JSB SETBF PLOT POINT IF NO MOVEMENT *** LDA IX LDB IY JSB SETBT SET DESIRED BIT JMP PU.3 SETBF NOP LDA P$BF3 SETUP THE BUFFER POINTER IF MOVED STA IDCB SET UP FILE IDCB ADA D16 STA ARCMB SET UP POINTER TO RECORD MAP ADA MAPSZ+1 STA IBUF POINT TO RECORD MAP LDA $12BL STA IDCBS SET UP LENGTH PARAMETERS ADA MD16 LDB MAPSZ+1 CMB,INB ADA B STA ILG SET UP LENGTH OF SECTOR BUFFER LDA TSIZE SET UP ISIZE MPY D36 ADA MAPSZ STA ISIZE SAME JSB READF INITILIZE THE RECORD MAP BUFFER DEF *+7 DEF IDCB,I DEF IERR DEF ARCMB,I DEF MAPSZ+1 DEF LEN DEF D1 JMP SETBF,I PU.2 EQU * DRAW LINE JSB SETBF * DRAW THE LINE JSB PLTLN PLOT LINE DEF *+5 DEF XPEN DEF YPEN DEF IX DEF IY * UPDATE REQUIRED INDEXES PU.3 DLD IX MOVE - SET XPEN, YPEN = IX, IY DST XPEN JMP PLOT,I PU.5 CLA LINE STYLE 5 - SET MODE FOR HORIZONTAL STA MDE LDA PENP CHECK TO SEE IF PEN IS DOWN SZA JMP PU.3 JSB SETBF MM 1913 DLD XPEN SET COORDINATES JSB SETBT PLOT POINT DLD IX SET COORDINATES FOR END POINT JSB SETBT PLOT OTHER POINT JMP PU.3 EXIT PLOT HED LLEFT ROUTINE * * LLEFT CALLED FROM HOME GIC * * LLEFT MOVES "PEN" (IN UP POSITION) TO THE * "LOWER LEFT" CORNER OF THE PAPER (RELATIVE TO * ORIGIN ESTABLISHED IN FACT). * * LLEFT * LLEFT NOP JSB .ENTR DEF LLEFT CLA STA IX STA IY STA XPEN STA YPEN * JMP LLEFT,I HED POINT TO POINT DIGITAL PLOT SUBROUTINE * THIS PROGRAM IS AN IMPLEMENTATION OF BRESENHAM'S * LINE DRAWING ALGORITHM. INPUT IS TWO SETS OF * COORDINATES BETWEEN WHICH A SERIES OF DOTS ARE * TO BE INSERTED. OUTPUT IS A SERIES OF COORDINATES * FOR THOSE DOTS REPRESENTING THE STRAIGHT LINE * BETWEEN THE INPUT COORDINATES. * * THIS PROGRAM ALSO USES THE SAME BASIC FLOWCJART * AND STRUCTURE AS IMPLEMENTED BY * JIM LANGLEY ON EPOC. * PX1 OCT 0 PY1 OCT 0 PX2 OCT 0 PY2 OCT 0 PLTLN NOP PLOT INCREMENTAL LINE JSB .ENTR RESOLVE ARGUMENT ADDRESSES DEF PX1 LDA PX1,I X1 STA X1 CMA,INA -X1 ADA PX2,I X2 STA DELX X2 - X1 LDB PY1,I Y1 STB Y1 CMB,INB -Y1 ADB PY2,I Y2 STB DELY Y2 - Y1 STB RCDFL SET FLAG FOR SETBT SSA CHECK FOR ABSOLUTE VALUE CMA,INA FORM ABS(DEL.X) STA IA FORM A OR B W/ DELTA X STA IB FORM A OR B W/ DELTA X SSB CHECK FOR ABSOLUTE VALUE CMB,INB FORM ABS(DELTA Y) STB TEMP ABS(DELTA Y) CMB,INB -ABS(DELTA Y) ADA B ABS(DELTA X)-ABS(DELTA Y) STA DELXY FORM DELTA XY LDB TEMP ABS(DELTA Y) SSA OCTANT 1, 8, 4, 5 ? JMP *+3 NO STB IB FORM DELTA B W/ DELTA Y RSS STB IA FORM DELTA A W/ DELTA Y * CONCATENATE SIGNS OF DELX, DELY, DELXY * TO FORM AN INDEX OF 0-7. LDA DELX DELTA X LDB DELY DELTA Y ELB SAVE SIGN OF DELTA Y RAL,ELA PACK SIGNS OF DELTA X&Y LDB DELXY DELTA XY ELB SAVE SIGN OF DELTA XY ELA PACK ALL 3 SIGNS TOGETHER AND L3BT MAX VALUE OF 7 STA NO. SAVE INDEX NO. (X,Y,XY) * SET UP STEPX & STEPY VALUES FOR M1 & M2 ADA ATM1X ADDR. TABLE OF M1 INDEX LDA A,I PICK UP INDEX OF M1 ADA ASTEP FORM ADDR. TO STEP VALUES DLD A,I PICK UP STEP\S FOR X & Y DST M1 SAVE THEM FOR M1 LDA NO. INDEX NO. ADA ATM2X ADDR. TABLE OF M2 INDEX LDA A,I PICK UP INDEX OF M2 INDEX ADA ASTEP FORM ADDR. TO STEP VALUES DLD A,I PICK UP STEPS FOR X & Y DST M2 SAVE THEM FOR M2 * SET UP INITIAL VALUES FOR CALCULATIONS LDA IA ABSOLUTE VALUE OF "DELTA X" CMA STA COUNT NO. PASSES THRU LOOP ADA IB (B - A) ALS *2 STA TDEL 2*(B-A) = 2DEL LDA IB ABSOLUTE VALUE OF "DELTA Y" ALS *2 STA TDELB 2*B LDA IA A CMA,INA -A ADA TDELB 2*B STA DEL 2*B-A CCA INITIALIZE LAST DIRECTION STA DIRLS LDA X1 X-COORD FOR"POINT LDB Y1 Y-COORD FOR POINT DST SCCOR SET UP FIRST CO-ORDINATE JMP TRY PLTIT LDA ON? CHECK TO SEE IF PLOT IS ON SZA NO,SKIP PLOT JSB PLTWD SET THIS SEGMENT ON IN FILE ISZ CNT BUMP COUNT JMP TRY KEEP ON PLOTING LDA NEXT,I LOOK AT NEXT REP VALUE ISZ NEXT BUMP NEXT VALUE SZA FINISHED WITH CYCLE? JMP CYCLE NO, CONTINUE THIS CYCLE CLA STA ON? MAKE SURE PLOT A FIRST OF CYCLE LDA PREP2 SET NEXT BACK UP STA NEXT SAVE IT FOR LATER USE LDA REP1 SET UP INITIAL LENGTH SZA,RSS MAKE SURE IT'S NOT ZERO LDA M7777 MAKE IT AS LARGE AS POSIBLE CYCLE CMA,INA MAKE NEXT VALUE A NEGATIVE COUNT STA CNT SAVE COUNT LDA ON? CYCLE ON FLAG SZA CCA INA STA ON? TRY ISZ COUNT FINISHED? RSS NO JMP ERND RETURN * CALCULATE NEXT POSITION (POINT) TO PLOT LDA DEL SSA JMP CADEL CALC. NEW DEL LDA TDEL 2*(B-A) ADA DEL DEL + 2DELEb JMP CKDEL CADEL EQU * CALCULATE DEL LDA TDELB 2*DELB ADA DEL DEL + 2*DELB CKDEL EQU * CHECK DEL STA DEL SAVE APPROPRIATE VALUE SSA,RSS USE M1? JMP USEM2 NO CLA SELECT MODE STA MDE LDA M1 STEP X FOR M1 LDB M1+1 STEP Y FOR M1 JMP NEWPT USEM2 EQU * CLA,INA SELECT MODE 2 STA MDE LDA M2 STEP X FOR M2 LDB M2+1 STEP Y FOR M2 NEWPT EQU * CALC. NEXT NEW POINT ADA X1 X1 + XSTEP STA X1 SAVE FOR NEXT ITERATION ADB Y1 Y1 + YSTEP STB Y1 SAVE FOR NEXT ITERATION JMP PLTIT PLOT THIS POINT ATM1X DEF TM1X ADDR. OF TABLE M1 INDICIES TM1X EQU * TABLE OF M1 INDICIES DEC 0 OCTANT 1 DEC 3 OCTANT 2 DEC 0 OCTANT 8 DEC 1 OCTANT 7 DEC 2 OCTANT 4 DEC 3 OCTANT 3 DEC 2 OCTANT 5 DEC 1 OCTANT 6 ATM2X DEF TM2X ADDR. OF TABLE M2 INDICIES TM2X EQU * TABLE OF M2 INDICIES DEC 4 OCTANT 1 DEC 4 OCTANT 2 DEC 5 OCTANT 8 DEC 5 OCTANT 7 DEC 7 OCTANT 4 DEC 7 OCTANT 3 DEC 6 OCTANT 5 DEC 6 OCTANT 6 ASTEP DEF STEPV STEPV EQU * STEP VALUES FOR M1 & M2 DEC 1 1,0 DEC 0 0,-1 DEC -1 -1,0 DEC 0 0,1 DEC 1 1,1 DEC 1 1,-1 DEC -1 -1,-1 DEC -1 -1,1 DEC 1 DELX OCT 0 DELTA X DELY OCT 0 DELTA Y IA OCT 0 A = DELTA X OR Y IB OCT 0 B = DELTA X OR Y DELXY OCT 0 ABS(DEL X - DEL Y) L3BT OCT 7 MASK NO. OCT 0 NUMBER OF INDEX COUNT OCT 0 INDEX M1 OCT 0,0 X & Y FOR M1 M2 OCT 0,0 X & Y FOR M2 TDEL OCT 0 2DEL TDELB OCT 0 2DELB DEL OCT 0 DEL X1 OCT 0,0 X-Y COORDINATE PAIR Y1 EQU X1+1 PREP2 DEF REP2 .10 DEC 10 .20 DEC 20 .30 DEC 30 M7777 OCT 77777 LINSU NOP SET UP LINE LENGTH CLA INITIALIZE REP1 & REP2 STA REP1 STA REP2 LDA TLINE CHECK FOR LINE TYPE SZA,RSS JMP LINSU,I IF TYPE 0 WE'RE ALL READY SET UP SSA IF NEGATIVE,USE TYPE 0 JMP LINSU,I CPA .1 SET UP FOR SPECIFIC LINE TYPE JMP DDOT1 CPA .2 JMP DDOT2 CPA .3 JMP DDOT3 CPA .4 JMP DDOT4 CPA .6 JMP DDOT6 JMP LINSU,I IF NOT ONE OF THE ABOVE USE 0 DDOT1 CLA,INA SET FOR DIM LINE STA REP1 STA REP2 CLA STA REP3 JMP LINSU,I DDOT2 LDA .20 SET FOR LONG DASH STA REP1 STA REP2 CLA STA REP3 JMP LINSU,I DDOT3 LDA .30 SET FOR LONG DASH WITH SHORT SPACE STA REP1 LDA .10 STA REP2 CLA STA REP3 JMP LINSU,I DDOT4 LDA .25 SET UP FOR CENTER LINE STA REP1 LDA .5 STA REP2 STA REP4 STA REP3 CLA STA REP5 JMP LINSU,I DDOT6 LDA .15 STA REP1 LDA .5 STA REP2 STA REP3 STA REP4 STA REP5 STA REP6 JMP LINSU,I HED SET BIT IN FILE ROUTINE * * THIS ROUTINE ACCEPTS AN INPUT POINT ON A GRAPH * (X,Y) AND TURNS THE APPROPRIATE BIT "ON" IN THE * FILE. IT ALSO UPDATES THE REQUIRED STATUS BITS * IN THE BEGINNING OF THE FILE AND ALL NECESSARY * POINTERS. * SETBT NOP SET APPROPRIATE BIT IN FILE STA X1 SAVE X-COORD STB Y1 SAVE Y-COORD * CALCULATE DESIRED RECORD NO. BRS Y/2 CMB,INB ADB J J-(Y/2) STB IRCDN INITIAL RCD. NO. FOR ERR. CK. * DO BOUNDS CHECK FOR Y LDA B  PREPARE TO CHECK FOR RANGE CMA ADA FDRN FIRST DATA RECD. NO. SSA,RSS .LT.? LDB FDRN YES LDA B PICK UP DESIRED RCD. NO. CMA,INA ADA ISIZE FILE SIZE IN RECORDS SSA .GT.? LDB ISIZE YES, USE MAX FILE SIZE(RECORDS) STB DRCDN DESIRED RCD. NO. LDA B AND L4BT MASK OUT BIT NO. STA RCMBN RCD. MAP BIT NO. LDA B DESIRED RCD. NO. ARS,ARS /4 ARS,ARS /4 = 16 STA RCMWN RCD. MAP WORD NO. * DO BOUNDS CHECK ON X LDB X1 X-COORD. SSB .LT. 0 CLB YES, USE ZERO LDA B CURRENT X-COORD. CMA,INA ADA D1007 MAX. OF 63 WDS.*16 - 1 BIT SSA .GT.? LDB D1007 YES, USE MAX. X-COORD. STB DBITN SAVE DESIRED BIT NO. * CHECK IF DESIRED RCD. NO. ALREADY IN CORE LDA NUM STARTING RCD. NO. IN CORE SZA,RSS EMPTY? JMP NOTHI YES, NOTHING IN CORE LDA DRCDN DESIRED RCD. NO. CMA ADA NUM RCD. NO. IN CORE SSA,RSS .GE. JMP GETRN NO, GET DESIRED RCD. NO. LDA DRCDN DESIRED RCD. NO CMA,INA ADA LNUM LAST RCD. NO. IN CORE SSA,RSS .LE. JMP RCDOK YES, DESIRED RCD ALREADY IN CORE GETRN EQU * GET DESIRED RECORDS FROM DISC * WRITE PREVIOUS RECORD(S) FIRST JSB WRITF DEF *+6 DEF IDCB,I DESIRED FILE DEF IERR ERROR RETURN DEF IBUF,I BUFFR. ADDR. DEF ILG LENGTH IN WORDS DEF NUM RCD NO. SSA ERROR? JMP ERRPR YES NOTHI EQU * NOTHING IN CORE LDA DRCDN DESIRED RCD. NO. LDB RCDFL RECORD FLAG SZB,RSS USE MIDDLE? JMP USEMD YES SSB USE START? JMP USEST YES LDB NRIC NO. RECORDS IN CORE sCMB,INB ADA B CALC. LAST RCD. IS DESIRED RCD. INA JMP USEST * MAKE THE DESIRED RCD. THE MIDDLE RCD. TO BE READ * CALC. THE MIDDLE RCD. AND BACK OFF USEMD EQU * USE MIDDLE RECORD LDA NRIC NO. RCD'S IN CORE ARS /2, FIND MIDDLE CMA,INA ADA DRCDN DESIRED RCD. NO. * CAREFUL OF SOF USEST EQU * USE STARTING RCD. STA B CHECK FOR RANGE ADA NRIC CHECK TO SEE IF READ WILL OVER SHOOT FILE CMA,INA ADA ISIZE FILE SIZE IN RECORDS SSA,RSS JMP RDLST READ WOULD OVER SHOOT FILE LDA NRIC SET TO READ ONLY THE LAST RECORD CMA,INA ADA ISIZE INA STA B RDLST LDA B CMA ADA FDRN FIRST DATA REC. NO. SSA,RSS .LT.? LDB FDRN YES, USE FIRST DATA REC. NO. STB NUM SET STARTING RCD. NO. IN CORE ADB NRIC NO. RCD'S. IN CORE ADB MD1 STB LNUM SET LAST RCD. NO. IN CORE * READ THE DESIRED RECORD(S) INTO CORE JSB READF DEF *+7 DEF IDCB,I DEF IERR DEF IBUF,I DEF ILG DEF LEN DEF NUM SSA ERROR? JMP ERRPR YES LDA LEN READ STATUS CPA MD1 EOF? HLT 01 YES, ERROR. SHOULD NEVER OCCUR RCDOK EQU * RECORD(S) OK. IN CORE * CALC. STARTING ADDR. OF DESIRED ROW LDB NUM STARTING RCD. NO."IN CORE CMB,INB ADB DRCDN DESIRED RCD. NO. IN CORE BLF,BLF *256 BRS /2 = 128 WORDS/RECORD ADB IBUF START OF ROW BUFFER STB ADROW ADDR. OF DESIRED ROW NO. * UPDATE THE BIT MAP IN FIRST RECORD(S) LDB ARCMB ADDR. OF RCD. MAP BUFFER ADB RCMWN DESIRED RCD MAP WD NO. BIAS INB BIAS FOR 1ST WD. MAP SIZE LDA ABITB ADDR. OF BIT MASK TABLE ADA RCMBN DESIRED RCD MAP BIT NO. ADDR. STA TEMP ADDR. OF BIT IN BIT TABLE LDA A,I PICK UP WD. W/ DESIRED BIT AND B,I MASK BIT FROM DESIRED ADDR. SZA BIT ALREADY ON? JMP BITST YES LDA TEMP,I PICK UP DESIRED BIT IOR B,I TURN ON BIT IN BIT MAP STA B,I RESTORE IT * PREPARE TO CLEAR OUT ROW LDB ADROW ADDR. OF DESIRED ROW LDA MD128 WORDS/RECORD STA INDX1 LOOP INDEX CLA NXT0 EQU * NEXT ZERO STA B,I CLEAR OUT NEXT WORD INB BUMP POINTER TO NEXT WORD ISZ INDX1 FINISHED? JMP NXT0 NO * CALCULATE STARTING ADDR. OF DESIRED ROW NO. BITST EQU * BIT TO BE SET IN ROW LDA Y1 Y-COORD. OF DESIRED PT. (ROW) LDB IRCDN INITIAL DESIRED RECORDNO. CPB DRCDN SAME AS DESIRED RCD. IN CORE? RSS YES CLA,INA MAKE IT LAST RCD.(ODD R.N.) LDB ADROW ADDR. OF DESIRED ROW SLA,RSS 2ND PORTION OF RECORD? ADB D64 YES, BIAS OVER TO IT STB ADROW ADDR. OF DESIRED ROW INB BIAS FOR HIGHEST BIT ACCESSED LDA DBITN X-COORD. OF DESIRED PT. (COL) ARS,ARS /4 ARS,ARS /4 = 16 BIT/WORD ADB A WORD BIAS IN DESIRED ROW LDA X1 COL. NO. AND L4BT SAVE BIT NO. IN COL. ADA ABITB ADDR. OF BIT TABLE LDA A,I PICK UP DESIRED BIT STB TEMP STORE ADDRESS LDB DMODE SZB,RSS IS MODE SET BIT? IOR TEMP,I YES - SET DESIRED BIT CPB C01 IS MODE CLEAR BIT? CMA YES - CREATE MASK CPB C01 AND TEMP,I AND CLEAR DESIRED BIT CPB C02 IS MODE COMPLIMENT BIT? XOR TEMP,I YES - COMPLIMENT DESIRED BIT STA TEMP,I RESTORE DATA LDB DBITN CURRENT X-COORDINATE INB NEXT POSSIBLE HI COL. LDA B X-COORD. (COLUMN) CMA,INA  ADA ADROW,I COMRARE W/ NEXT COL. TO BE ACCESSED SSA .GT.?" STB ADROW,I YES, UPDATE HI COL ACCESSED LDA X1 RETURN WITH FIXED PT. X LDB Y1 RETURN WITH FIXED PT. Y JMP SETBT,I RETURN ABITB DEF BITAB BITAB EQU * BIT TABLE OCT 100000 OCT 40000 OCT 20000 OCT 10000 OCT 4000 OCT 2000 OCT 1000 OCT 400 OCT 200 D64 OCT 100 OCT 40 D16 OCT 20 OCT 10 OCT 4 OCT 2 OCT 1 RCDFL OCT 0 RECORD FLAG DRCDN OCT 0 DESIRED RCD. NO. IRCDN OCT 0 INIT. RCD. NO. FOR ERROR CK. DBITN OCT 0 DESIRED BIT NO. L4BT OCT 17 MASK RCMBN OCT 0 RCD. MAP BIT NO. RCMWN OCT 0 RCD. MAP WORD NO. D1 DEC 1 D1007 DEC 1007 63 * 16 - 1 MD128 DEC -128 INDX1 OCT 0 INDEX REG. ADROW OCT 0 ADDR. OF HIGHEST BIT ACCESSED PT * * * ERRPP LDA D55 ERRPR NOP ERROR PROCESSING STA IERR LDA PIERR LDB DF1 JSB GB SEND ERROR CODE BACK TO AGL JMP RSTER,I RETURN EXIT5 LDA DF0 LDB DF1 JSB GB JMP EXIT4 PIERR DEF IERR JERRP NOP JMP ERRPR JMP JERRP,I RETURN JER2 LDA D2 JSB JERRP JMP INITR JER3 LDA D3 JSB JERRP JMP INITR HED WIDTH AND ROUNDING ROUTINE ERND LDA WIDT MUST BE 3 WIDE TO ROUND ADA N6 SSA JMP EXRND CLA,INA SET WIDTH INCREMENT CMA STA INCWD INA INITIALIZE THE HALF WIDTH INCREMENT FLAG STA IDUM LDA WIDT SET UP ROUNDING WIDTH STA TWID ADA INCWD STA WIDT LDA WIDH STA TWIDH CPA WIDP MAKE SURE HALF WIDTH ADA MD1 IS 1 LESS THAN FULL WIDTH ADA MD1 STA WIDH LDA WIDP STA TWIDP ADA INCWD STA WIDP CLA SET UP INCREMENT FLA 'G STA INCFL LDB TWID CALCULATE THE ROUNDING LENGTH LDA MDE SZA LDB TWIDP BRS CMB,INB STB CNTRQ JSB RND OUTPUT ROUNDING LDA TWID RESTORE WIDTH PARAMETERS STA WIDT LDA TWIDP STA WIDP LDA TWIDH STA WIDH EXRND JMP PLTLN,I EXIT SUBROUTINE * * BRND NOP ROUND END OF LINE LDA WIDT NO ROUNDING FOR LINES LESS THAN 3 WIDE ADA N6 SSA JMP BXRND LDA X1 SAVE CURRENT PEN POSITION LDB Y1 DST SAVEC LDB PM1 DETERMINE THE DIRECTION LDA MDE SZA LDB PM2 LDA B,I FIND X INCREMENT CMA,INA NEGATE IT STA SMDE1 SAVE IT FOR LATER INB LDA B,I FIND Y INCREMENT CMA,INA NEGATE IT STA SMDE2 AND SAVE IT LDB WIDT DETERMINE DISTANCE LDA MDE SZA TO MOVE FOR ROUNDING LDB WIDP BRS CMB,INB STB CNTRQ CMB,INB ADB C02 STB TEMPE SAVE DISTANCE CLB LDA SMDE1 CALCULATE HOW FAR TO MOVE MPY TEMPE ADA X1 FIND LOCATION STA X1 AND SAVE IT LDA SMDE2 SAME FOR Y MPY TEMPE ADA Y1 STA Y1 LDA WIDH STA TWIDH SAVE WIDTH PARAMETERS LDA WIDP STA TWIDP LDA WIDT STA TWID LDB MDE CALCULATE DOT WIDTH SZB LDA WIDP ARS STA TEMPE SLA,RSS MAKE SURE IT IS EVEN JMP OK1 CCB INA RSS OK1 CLB STB INCFL CLB,INB INITIALIZE HALF WIDTH FLAG CMB STB IDUM STA TEMPE SAVE WIDTH DECREMENT CLA,INA SET UP WIDTH INCREMENT INA STA INCWD LDA TEMPE SET OUTER WIDTH CMA,INA STA TEMPE ADA WIDT STA WIDT LDA TEMPE H ADA WIDP STA WIDP ADA MD1 STA WIDH JSB RND ROUND END OF LINE DLD SAVEC RESTORE X1&Y1 STA X1 STB Y1 LDA TWID RESET WIDTH PARAMETERS STA WIDT LDA TWIDH STA WIDH LDA TWIDP STA WIDP BXRND DLD SCCOR DST SACOR CCA JMP BRND,I EXIT SUBROUTINE SMDE1 NOP SMDE2 NOP SAVEC BSS 2 SCCOR BSS 2 TEMPE NOP TWID NOP TWIDP NOP TWIDH NOP INCFL NOP INCWD NOP IDUM NOP * * RND NOP SUBROUTINE TO ROUND ENOOOF LINE LDA X1 SAVE CURRENT POSITION LDB Y1 DST SBCOR LPQTM LDB PM1 FIND DIRECTION LDA MDE SZA LDB PM2 LDA B,I CALCULATE X COORDINATE ADA X1 STA X1 INB LOOK AT Y INCREMENT LDA B,I ADA Y1 CALCULATE Y COORDINATE STA Y1 JSB PLWD1 PLOT THIS POINT" ISZ INCFL BUMP WIDTH? JMP INCHF NO,"INCREMENT HALF WIDTH LDA INCWD PICKUP INCREMENT VALUE ADA WIDP AND MODIFY WIDTH STA WIDP LDA INCWD MODIFY PERPENDICULAR WIDTH TOO. ADA WIDT STA WIDT JMP CHKQ GO ON INCHF CCA SET INCREMENT FLAG STA INCFL ISZ IDUM JMP CHKQ STA IDUM LDA INCWD MODIFY HALF WIDTH ADA WIDH STA WIDH CHKQ ISZ CNTRQ CHECK TO SEE IF WE ARE THROUGH JMP LPQTM NO, GO PLOT NEXT POINT DLD SBCOR PUT BACK CURRENT POINT STA X1 STB Y1 JMP RND,I ALL DONE CNTRQ NOP * * PLTWD NOP PLOT WIDTH LDA DIRLS LOOK AT LAST DIRECTION SSA IF SIGN = 1 FIRST TIME IN JSB BRND CPA MDE IS THE DIRECTION THE SAME AS LAST TIME? JMP FSTME YES NO SPECIAL HANDLING LDA X1 SAVE CURRENT POINT LDB Y1 DST SBCOR DLD SACOR PICK UP LAST POINT STA X1 PLOT WIDTH USING9 UURRENT DIRECTION STB Y1 JSB PLWD1 DLD SBCOR NOW"PLOT WIDTH USING STA X1 CURRENT POINT STB Y1 FSTME JSB PLWD1 JMP PLTWD,I EXIT SUBROUTINE PLWD1 NOP LDA X1 LDB Y1 DST SACOR SAVE CURRENT PLOT POINT LDA WIDT PULL UP LINE WIDTH IN DOTS ARS DIVIDE BY 2 LDB MDE STB DIRLS SZA,RSS IF 1 DOT ONLY THEN JMP EXIT. JUST PLOT THIS POINT STA MPYR SAVE DOT OFFSET FROM CENTER LDA PM1 TAKE CURRENT LINE DIRECTION SZB LINE SEGMENT JMP DIAG GO PROCESS DIAGONAL LDB A,I INA LDA A,I CMA,INA DST JNCRQ SAVE THE LINE MOVEMENT MPY MPYR CALCULATE OFFSET CMA,INA ADA X1 STA X1 LDA JNCRQ+1 MPY MPYR CMA,INA ADA Y1 STA Y1 LDA WIDT GENERATE POINT COUNT CMA,INA STA INCRP JSB PLTDG OUTPUT PERPENDICULAR LINE JMP EXIT. EXIT SUBROUTINE PLTDG NOP LDA X1 LDB Y1 PLQ JSB SETBT SET BT ON IN MAP ISZ INCRP ARE WE DONE RSS NO, DO REST JMP EXIT YES, GET OUT LDA X1 ADA JNCRQ SSA CHECK FOR OUT OF BOUNDS JMP EXIT OUT, GO EXIT STA X1 LDB Y1 SET UP TO PLOT NEXT POINT ADB JNCRQ+1 SSB CHECK FOR OUT OF BOUNDS JMP EXIT OUT, GO EXIT STB Y1 JMP PLQ EXIT EQU * JMP PLTDG,I ALL THROUGH GOODBYE EXIT. DLD SACOR RESTORE X1 AND Y1 STA X1 STB Y1 JSB SETBT JMP PLWD1,I EXIT DIAG LDA WIDP ARS STA MPYR LDA PM2 GO ON DIAGONAL LDB A,I CALCULATE PERPINDICULAR INA LDA A,I CMA,INA DST JNCRQ SAVE FOR PLOTING LINE MPY MPYR CALCULATE OFFSET CMA,INA ADA X1 STA X1 q POINT TO OFFSET POINT LDA JNCRQ+1 CALCULATE Y OFFSET MPY MPYR CMA,INA ADA Y1 STA Y1 POINT TO OFFSET POINT DLD X1 SAVE CURRENT OFFSET POINT DST KLU LDA JNCRQ FIND OUT DIRECTION OF ADA JNCRQ+1 HALF DOT OFFSET SZA,RSS JMP XMDE SIGNS ARE THE SAME LDA Y1 SIGNS ARE DIFFERENT ADA JNCRQ MODIFY IN Y DIRECTION STA Y1 SAVE FOR HALF DOT OUTPUT JMP GOOUT GO OUTPUT HALF DOT XMDE LDA JNCRQ+1 MODIFY IN X DIRECTION CMA,INA ADA X1 STA X1 SAVE FOR HALF DOT OUTPUT GOOUT LDA WIDH GET HALF DOT COUNT CMA,INA STA INCRP SET UP OUTPUT COUNT JSB PLTDG GO OUTPUT HALF DOT LINE DLD KLU REINITIALIZE OFFSET LOCATION DST X1 LDA WIDP SET UP DOT COUNT CMA,INA STA INCRP SAVE FOR OUTPUT JSB PLTDG GO OUTPUT FULL DOT JMP EXIT. GO AWAY SACOR BSS 2 MPYR BSS 1 PM1 DEF M1 PM2 DEF M2 JNCRQ BSS 2 MDE BSS 1 INCRP BSS 1 DIRLS BSS 1 SBCOR BSS 2 * * WGCB NOP CNTP NOP WIDTH NOP JSB .ENTR DEF WGCB LDA WGCB JSB INGCB JMP WIDTH,I LDA CNTP,I ALS INA SSA CLA,INA STA WIDT ADA M75 MAKE SURE WIDTH IS BETWEEN SSA 1 AND 75 JMP WIDHC THEY ARE, CALL OK LDA M75 NOT SO CMA,INA SET TO 75 STA WIDT WIDHC CLA,INA MAKE WIDTH ODD IOR WIDT STA WIDT JSB FLOAT CALCULATE DIAGONAL WIDTH FMP .707 CALCULATE .707 TIME WIDTH DST KLU SAVE VALUE TEMPORARILY JSB IFIX MAKE IT AN INTEGER STA WIDP SAVE DIAGNOL WIDTH JSB FLOAT FIND ROUND OFF DST JERR SAVE TEMPORARILY DLD KLU PICK UP FULL VALUE FSB JERR SUBTRACT INTEGER PORTION FMP D100 PULL OUT FIRST 2 DECIM5AL PLACES JSB IFIX ADA M25 >.25? LDB WIDP HALF DOT WIDTH ADB MD1 SSA,RSS LET'S SEE INB YES, ADD ANOTHER HALF DOT STB WIDH SAVE FOR LINE DRAWING SUBROUTINE ADA M25 ADA M25 >.75? SSA,RSS ISZ WIDP YES, ADD ANOTHER FULL DOT. LDA WIDTH STA RSTER JMP EXIT4 M25 DEC -25 M75 DEC -75 .707 DEC .707 D100 DEC 100. FFGCB NOP FFCTL NOP FFRST NOP JSB .ENTR DEF FFGCB LDA FFGCB JSB INGCB JMP FFRST,I LDA FFCTL,I CLB SLA CCB STB FFFLG LDA FFRST STA RSTER JMP EXIT4 * * * LULUT NOP LUSET NOP SET GRAPHICS LU JSB .ENTR DEF LULUT LDA LULUT,I STA $12LU JMP LUSET,I LNLNT NOP LNSET NOP SET GRAPHICS LENGTH JSB .ENTR DEF LNLNT LDA LNLNT,I STA $12LN JMP LNSET,I LGLGT NOP LGSET NOP JSB .ENTR DEF LGLGT LDA LGLGT,I STA $12LG JMP LGSET,I HED INIT ROUTINE * ******************************************************* * * ******INIT****** * * * * KLU OCT 0 KEYF OCT 0 JERR NOP NOP INIT NOP INITIALIZATION ROUTINE LDA P$BF3 PACK LOCAL BUFFER STA IDCB ADA D16 STA IBUF LDA $12BL ADA MD16 MAKE BUFFER LENGTH LEGAL CLB DIV D128 SOC JMP JER5 MPY D128 ADA D16 STA IDCBS LDA LBLFL ARE WE REOPENING AFTER LABEL SSA JMP OPFIL YES, GO OPEN THE FILE JMP CKFIL JER5 LDA .5 BUFFER LENGTH ERROR JMP INIT,I CKFIL EQU * OPFIL JSB OPEN TRY TO OPEN FILE DEF *+7 DEF IDCB,I DEF IERR DEF QNAM DEF IOPTN DEF ISECU DEF ICR SSA,RSS WAS THERE AN ERROR JMP CHKOT NO, MAKE SURE IF THERE SHOULD HAVE BEEN CMA,INA SEE WHAT ERROR IS CPA .6 IF FILE DOES NOT EXIST CREATE IT JMP NEWFL GO CREATE NEW FILE LDA FLPSS IS THIS A DEFAULT FILE SSA,RSS JMP ERRPR NO, FLAG AEEERROR ISZ QNAM+2 IF DEFAULT TRY TO OPEN ANOTHER ONE JMP CKFIL CHKOT LDA LBLFL ARE WE REOPENING AFTER LABEL SSA JMP OLDFL YES,ASSUME OLD FILE LDA FLPSS IS THIS A DEFAULT FILE SSA,RSS JMP OLDFL NO, USE AS AN UPDATE JSB CLOSE CLOSE DEFAULT FILE DEF *+3 DEF IDCB,I DEF IERR ISZ QNAM+2 SET TO NEXT DEFAULT NAME JMP CKFIL GO TRY AGAIN FLCPY NOP * CALCULATE DESIRED FILE SIZE FOR NEW FILE NEWFL EQU * NEW FILE LDA TSIZE CLB PREPARE FOR DIVIDE STB KEYF CLEAR KEYF DIV D55 INCHES / BIT-MAP-RECORDS SZB REMAINDER? INA YES, USE ONLY WHOLE RECORDS STA MAPSZ MAP SIZE (IN RECORDS) LDA TSIZE RELOAD TOTAL # INCHES MPY D36 BLOCKS/INCH SZB TOO MANY (>64K)? JMP JER2 YES ADA MAPSZ BIT MAP SIZE (IN RECORDS) STA ISIZE FILE SIZE IN RECORDS JSB CNFIL CREATE NEW FILE JMP INIVA INITIALIZE VARIABLES * CREATE NEW FILE * CNFIL NOP CREATE NEW FILE JSB CREAT DEF *+8 DEF IDCB,I DEF IERR DEF QNAM DEF ISIZE DEF ITYPE DEF ISECU DEF ICR SSA ERROR? JMP ERRPR YES, PROCESS IT * DS2040 JSB LOCF GET THE CRN OF THE FILE CREATED Ds2040 DEF RETLC DS2040 DEF IDCB,I DS2040 DEF IERR p DS2040 DEF TEMP DUMMY WORDS DS2040 DEF TEMP+1 FOR THE DS2040 DEF TEMP+2 DON'T CARE PARAMETERS DS2040 DEF TEMP+3 DS2040 DEF ICR CR# OF THE FILE CREATED DS2040 * DS2040 RETLC LDA IERR PROCEES THE ERROR IF ONE DS2040 SSA OCCURED DURING DS2040 JMP ERRPR THE LOCF CALL DS2040 * DS2040 LDA ICR GET THE CR# RETURNED AND DS2040 CMA,INA MAKE IT NEGATIVE DS2040 STA ICR AND STUFF IT BACK DS2040 JMP CNFIL,I RETURN DS2040 * * OLDFL EQU * OLD FILE JSB SETBF JMP INITR * * DUPFL NOP SUBROUTINE TO DUPLICATE A FILE LDA .2 STA KEYF SET DUPLICATE FILE FLAG * OPEN EXISTING FILE JSB OPEN DEF *+7 DEF JDCB DEF IERR DEF RNAM DEF IOPTN DEF JSECU DEF JCR SSA ANY ERRORS? JMP ERRPR YES GSIZE EQU * GET SIZE OF FILE * GET FILE SIZE FROM OLD FILE JSB LOCF DEF *+7 DEF JDCB DEF IERR DEF TEMP DEF TEMP+1 DEF TEMP+2 DEF JSEC SSA ANY ERRORS JMP ERRPR YES LDA JSEC OLD FILE SIZE (IN SECTORS) ARS /2 CPA ISIZE MAKE SURE THE SIZES ARE THE SAME RSS JMP ERRPP CLA NXRCD EQU * XFER NEXT RECORD INA BUMP RCD. NO. STA NU?M SAVE IT FOR R/W * READ FROM OLD FILE JSB READF DEF *+7 DEF JDCB DEF IERR DEF IBUF,I DEF IL DEF LEN DEF NUM SSA ANY OTHER ERRORS? JMP ERRPR YES * WRITE TO NEW FILE JSB WRITF DEF *+6 DEF IDCB,I DEF IERR DEF IBUF,I DEF IL DEF NUM CPA MD12 EOF DETECTED JMP EOFDE YES SSA ANY ERRORS? JMP ERRPR YES LDA NUM RECORD NO. CPA ISIZE EOF? RSS YES JMP NXRCD XFER NEXT RECORD * CLOSE ORIGINAL FILE EOFDE EQU * JSB CLOSE DEF *+3 DEF JDCB DEF IERR SSA JMP ERRPR CLA STA NUM JMP DUPFL,I REMAP EQU * READ MAP LDA IDCBS TOTAL LENGTH OF BUFFER (IN WORDS) ADA MD16 REMOVE FMP REQUIREMENTS STA ILG SAVE LENGTH OF USER BUFFER *READ MAP AND 1ST ROWS OF DATA JSB READF DEF *+7 DEF IDCB,I DEF IERR DEF IBUF,I DEF ILG DEF LEN DEF D1 SSA ANY ERRORS? JMP ERRPR YES LDA IBUF,I PICK UP MAP SIZE STA MAPSZ SAVE IT SKP * INITIALIZE VARIOUS PARAMETERS INIVA EQU * INITIALIZE VALUES LDA ISIZE * MPY NOPGS NO. OF PAGES STA J RCD. NO. FOR Y0 = 0 LDA MAPSZ MAP SIZE IN RECORDS MPY D128 WORDS/RECORD STA MAPSZ+1 MAP SIZE IN WORDS LDB IBUF CURRENT START OF MAP BUFFER STB ARCMB ADDR. RCD. MAP BUFFER ADA B BIAS FOR BIT MAP STA IBUF START OF ROW DATA LDA MAPSZ+1 MAP SIZE IN WORDS CMA,INA ADA IDCBS TOTAL WORFS IN BUFFER ADA MD16 FMP CONTROL WORDS STA ILG LENGTH OF DATA BUFFER SSA ENOUGH SPACE? JSB JER3 NO LDA MAPSZ MAP SIZE IN WORDS INA g: NEXT STARTING RECD. STA FDRN FIRST DATA RECORD NO. STA NUM STARTING RCD. NO. IN CORE * CLEAR OUT BIT MAP IF REQUIRED LDA KEYF FILE INFO SZA NEW FILE? JMP CONTI NO, CONTINUE INITIALIZATION LDA MAPSZ+1 MAP SIZE (IN WORDS) CMA,INA STA INDX1 PACK INDEX FOR LOOP CLA PREPARE TO CLEAR LDB ARCMB ADDR. OF RCD. MAP BUFFER CNBW EQU * CLEAR NEXT BIT-WORD STA B,I CLEAR RECORD MAP WORD INB BUMP POINTER ISZ INDX1 FINISHED? JMP CNBW NO LDA MAPSZ MAP SIZE (IN BLOCKS) STA ARCMB,I SAVE MAP SIZE IN FILE CONTI EQU * CONTINUE INITIALIZATION LDA LBLFL REOPEN FILE? SZA JMP INIT0 YES, SKIP THIS PART CLA CLEAR STA IX X-COORDINATE STA IY Y-COORDINATE STA DMODE PLOT DRAWING MODE STA SANG ZERO PLOT ANGLE STA SANG+1 INIT0 LDA IDCBS SIZE OF USER BUFFER (IN WORDS) CLB DIV D128 STA LNUM SAVE LAST RCD. NO. IN CORE LDB MAPSZ MAP SIZE (IN RECORDS) CMB,INB ADA B CALC. NO. RCDS. IN CORE STA NRIC SAVE NO. RECD'S IN CORE INITR CLA JMP INIT,I RETURN IOPTN OCT 0 OPEN OPTION (0=EXCLUSIVE,1=NON-EXCLUSIVE) TEMP OCT 0,0,0 POSSIBLE FLOATING PT. VALUE JSEC OCT 0 OLD FILE SIZE (IN SECTORS) D55 DEC 55 D36 DEC 36 BLOCKS/INCH IL DEC 128 RCD. LENGTH FOR TYPE 1 FILE ISIZE OCT 12 FILE SIZE (IN RECORDS) ITYPE OCT 1 TYPE 1 FILE IERR OCT 0 ERROR RETURN LOC D2 DEC 2 D3 DEC 3 MD16 DEC -16 LEN OCT 0 NO. OF WORDS READ BY FMGR MD12 DEC -12 D128 DEC 128 * * CREATE PICTURE FILE * PICF1 JSB ICLOS SET UP FILE TYPE CLA STA FLPSS PICC LDA .6 READ DOWN THE FILE NAME STA LNTH m JSB GB1 LDA PNTX1 MOVE NAME INTO STORAGE LDB QNAME MVW .3 LDA INTX1+5 STA ICR LDA INTX1+4 STA ISECU JSB FSET JMP EXIT5 PICF2 JSB ICLOS CLA,INA STA FLPSS JMP PICC FSET NOP CLA STA KEYF LDA FSET STA INIT LDA FLPSS SZA,RSS JMP TYPE1 JSB PURGE PURGE OLD FILE DEF *+6 DEF IDCB,I DEF IERR DEF QNAM DEF ISECU DEF ICR SSA JMP ERRPR TYPE1 JSB CNFIL JMP INIVA PNTX1 DEF INTX1+1 RNAME DEF RNAM RNAM OCT 0,0,0 JSECU NOP JCR NOP QNAME DEF QNAM INGCB NOP STA P3LLU JSB GCBIM DEF *+5 DEF .99 DEF .1 P3LLU NOP DEF IFLG LDA IFLG SZA,RSS ISZ INGCB JMP INGCB,I IFLG NOP .99 DEC 99 HED PICTURE FILE ALTERNATE QDCB NOP PICNM NOP PICLU NOP PICSC NOP PICFL NOP JSB .ENTR DEF QDCB JSB RECVR SET UP EQT ENTRY LDA PICFL MAKE SURE OF CLEAN ERROR EXIT STA RSTER LDA QDCB VERIFY THAT GCB HAS BEEN OPENED JSB INGCB JMP PICFL,I JSB ICLOS CLOSE CURRENT PICTURE FILE LDA PICNM SET UP FOR CREATION OF NEW PICTURE FILE LDB QNAME MVW .3 LDA PICLU,I STA ICR LDA PICSC,I STA ISECU CLA SET UP FILE FLAG STA FLPSS JSB FSET GO CREATE PICTURE FILE JSB POSTI POST THE STUFF IN THE FILE ?? PP2040 ?? JSB RCD SAVE FILE DATA JMP PICFL,I * * * MERGE SPECIFIED FILE INTO CURRENT PICTURE FILE * * QGCB NOP PCFL1 NOP PCLI1 NOP PCSC1 NOP PICMG NOP JSB .ENTR DEF QGCB LDA PCFL1 LDB RNAME MVW .3 LDA PCLI1,I STA RNAM+3 LDA PCSC1,I STA RNAM+4 LDA PICMG STA RSTER JSB DUPFL JMP PICMG,I HED "POSTING" ROUTINE * * * POSTI NOP "POST ALL BUFFERS" LDA NUM STARTING RCD. NO. SZA,RSS ANYTHING IN CORE? JMP POSTE NO, RETURN *WRITE MAP TO DISC JSB WRITF DEF *+6 DEF IDCB,I DEF IERR DEF ARCMB,I DEF MAPSZ+1 DEF D1 SSA ANY ERRORS? JMP ERRPR YES PROCESS THEM * "POST" CURRENT BUFFERS JSB WRITF DEF *+6 DEF IDCB,I DEF IERR DEF IBUF,I DEF ILG DEF NUM SSA ANY ERRORS? JMP ERRPR YES CLA STA NUM CLEAR STARTING RCD. NO. STA LNUM CLEAR LAST RCD. NO. POSTE CLA RETURN JMP POSTI,I * * * * CLOSE THE FILE ICLOS NOP CLOSE ALL FILES JSB POSTI "POST" FIRST JSB CLOSE DEF *+3 DEF IDCB,I DEF IERR LDA LBLFL IS THIS A LABEL CLOSE SSA IF SO, DON'T PURGE FILE JMP ICLOS,I WE NEED IT YET LDA FLPSS IS THIS A DEFAULT FILE SSA,RSS JMP ICLOS,I RETURN JSB PURGE DEF *+6 DEF IDCB,I DEF IERR DEF QNAM DEF ISECU DEF ICR JMP ICLOS,I * * * * DEFINE THE PLOT DRAWING MODE * * 0 => SET BIT IN FILE * 1 => CLEAR BIT IN FILE * 2 => COMPLIMENT BIT IN FILE * CMODE NOP MODE NOP JSB .ENTR DEF CMODE LDA CMODE,I MODE CONTROL ADA N2 MODE - 2 SSA,RSS IS MODE .GE. 2 CLA YES - DEFAULT TO 2 ADA D2 RECONSTRUCT MODE CONTROL STA DMODE JMP MODE,I N2 OCT -2 SKP * * ****** ****** ****** * * * ****** ****** ****** * ***** WORKING STORAGE *** * * * THE FOLLOWING GROUPS OF TWO WORDS MUST BE * IN 2 CONSECUTIVE MEMORY LOCATIONS. * IDX BSS 1 DELTA BET. PREVIOUS & CURRENT IDY BSS 1 * * * * * * * C01 OCT 1 C02 OCT 2 MD1 DEC -1 N6 DEC -6 * AJDCB DEF JDCB * THE FOLLOWING ORDER MUST BE PRESERRVED ILANG OCT 0 JDCB BSS 144 IDCB FOR 2ND FILE * $12BL DEC 784 $12B3 BSS 784 END ʋ ' 92840-18097 1913 S C0122 &$12LG 2608A ADD. DEVICE SUBR.             H0101 œASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: $12LG -- SET 2608A LANGUAGE SET * SOURCE: 92840-18097 * RELOC: 92840-16010 * * * ************************************************************* * NAM $12LG,7 92840-16010 REV.1913 790110 ENT $12LG $12LG DEC 0 END   92840-18098 1913 S C0122 &$12LN 2608A ADD. DEVICE SUBR.             H0101 ƚASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: $12LN -- SET 2608A Y DIRECTION LENGTH * SOURCE: 92840-18098 * RELOC: 92840-16010 * * * ************************************************************* * NAM $12LN,7 92840-16010 REV.1913 790110 ENT $12LN $12LN DEC 10 END   92840-18099 1913 S C0122 &$12LU 2608A ADD. DEVICE SUBR.             H0101 ǡASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: $12LU -- SET 2608A LIST DEVICE * SOURCE: 92840-18099 * RELOC: 92840-16010 * * * ************************************************************* * NAM $12LU,7 92840-16010 REV.1913 790110 ENT $12LU $12LU DEC 6 END END$ q  92840-18100 1819 S C0122 XMIT INTFC MOD              H0101 @ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: XMIT INTFC MOD * SOURCE: 92840 - 18100 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM XMIT,7 92840-16001 REV 1819 780515 EXT .OPTN,PLTER,XXMIT ENT XMIT * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND XMIT * * XMIT NOP LDA XMIT JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XXMIT DEF END PARM BSS 2 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .84 RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .84 DEC 84 .1 OCT 1 .0 OCT 0 END dT  92840-18101 1913 S C0122 &XGDST GDSTT INTERFACE MOD             H0101 3ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GDSTT * SOURCE: 92840 - 18101 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GDSTT,7 92840-16001 REV.1913 790122 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * GDSTT. * EXT XDSTT,.OPTN,PLTER ENT GDSTT * * GDSTT NOP LDA GDSTT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .4 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XDSTT DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 85 CODE NOP * END A  92840-18102 1819 S C0122 GSTAT INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GSTAT * SOURCE: 92840 - 18102 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GSTAT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * GSTAT. * EXT XGSTT,.OPTN,PLTER ENT GSTAT * * GSTAT NOP LDA GSTAT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .4 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XGSTT DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 86 CODE NOP * END <  92840-18103 1819 S C0122 GPMM INTFC MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GPMM INTFC MOD * SOURCE: 92840 - 18103 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GPMM,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XPMM ENT GPMM * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND GPMM * * GPMM NOP LDA GPMM JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .2 TWO REQUIRED PARAMETERS DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XPMM DEF END PARM BSS 3 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .87 RTNER JMP RETRN,I * M3 OCT -3 RETRN NOP .87 DEC 87 .2 OCT 2 .1 OCT 1 .0 OCT 0 END 'H  92840-18104 1819 S C0122 FRAME INTFC MOD              H0101 ^ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: FRAME INTFC MOD * SOURCE: 92840 - 18104 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM FRAME,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XFRME ENT FRAME * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND FRAME * * FRAME NOP LDA FRAME JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XFRME DEF END PARM BSS 2 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .88 RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .88 DEC 88 .1 OCT 1 .0 OCT 0 END   92840-18105 1819 S C0122 SET G U INT MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SETUU\SETGU INTFC MOD * SOURCE: 92840 - 18105 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM SETUU,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XSETU ENT SETUU,SETGU * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND SETUU * * SETUU NOP LDA .1 STA CODE LDA .89 STA ERCOD LDA SETUU SET JSB .OPTN DEF RTN DEF PARM DEF M2 DEF CODE DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XSETU DEF END PARM BSS 2 END JMP RETRN,I * SETGU NOP LDA .2 STA CODE LDA .90 STA ERCOD LDA SETGU JMP SET * ERROR JSB PLTER DEF RTNER DEF ERCOD RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .89 DEC 89 .90 DEC 90 .2 OCT 2 ERCOD NOP CODE NOP .1 OCT 1 .0 OCT 0 END %  92840-18106 1819 S C0122 IGERR INTFC MOD              H0101 tASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: IGERR INTFC MOD * SOURCE: 92840 - 18106 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM IGERR,7 92840-16001 REV.1819 780515 ENT IGERR EXT .OPTN,XIGER,PLTER EXT PLTER * * THIS IS THE INTERFACE MODULE FOR THE ERROR HANDLING COMMAND * IGERR(LU). * IGERR NOP LDA IGERR LG1 JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 IGCB REQUIRED PARAMETER DEF .0 DEF RETRN RTN JMP ERROR JSB XIGER DEF END PARM NOP ERMSG NOP END JMP RETRN,I * RETRN NOP M2 DEC -2 .1 DEC 1 .2 OCT 2 .0 OCT 0 DF1 DEF .1 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .91 IGCB NOP RTNER LDA .6 JMP RETRN,I .91 DEC 91 .6 OCT 6 END c  92840-18107 1913 S C0122 &DVZ12 GRAPHICS DRIVER             H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DVZ12 -- 2608A GRAPHICS DRIVER * SOURCE: 92840-18107 * RELOC: 92840-16012 * * * ************************************************************* * NAM DVZ12 92840-16012 REV.1913 790110 ENT IZ12,CZ12 EXT $LIST,$12BF,$12CT,$12B1,$12B2 A EQU 0 B EQU 1 * * * THIS IS THE 2608A GRAPHICS DUMMY DRIVER * IT'S PURPOSE IS TO PASS THE REQUIRED DATA * FROM THE AGL DEVICE DEPENDANT DRIVER TO THE * SYMBOL PLOTING PROGRAM. THIS IS DONE THROUGH * A EXTENDED EQT AND THE SCHEDULEING OF A * LABELING PROGRAM. * IZ12 NOP LDA EQT6,I AND B3777 CPA B2203 NOP NOP JMP OK DOWN LDA D3 PUT DEVICE DOWN JMP IZ12,I EXTENDED EQT NO LARGE ENOUGH OK LDA TIMEO SET TIME OUT STA EQT15,I LDA EQT4,I TELL SYSTEM THAT DRIVER WILL IOR BIT12 HANDLE IT'S OWN TIME OUT'S STA EQT4,I LDA EQT6,I CHECK TO SEE WHAT THE COMMAND AND B3777 MASK OUT BUFFER FLAG STA EQT6,I SAVE THE MASK AND B77 IS AND PROCESS IT CPA D2 IS IT A WRITE REQUEST JMP WRITE YES, GO DO YOUR THING CPA D3 IS IT A CONTROL REQUEST? JMP CNTL YES, GO CHECK IT. BADCL CLA,INA NEITHER, TELL SYSTEM BAD CALL JSB IZ12,I CNTL LDA EQT6,I LET'S SEE IF THIS IS A CONTROL CPA B2403 CHECK FOR CONTROL REQUEST'S JMP IMEDT DUMMY CONTROL REQUEST , CPA B3003 SET LANGUAGE COMMAND? JMP LANGE YES, SET LANGUAGE CPA D3 RESET COMMAND? JMP RSTFL GO RESET FLAGS LDA D2 TELL SYSTEM NO SUCH CALL JMP IZ12,I LANGE LDA EQT7,I PICK UP LANGUAGE CODE STA EQT14,I SAVE FOR FUTURE REFERENCE JMP IMEDT RSTFL LDB PNT1 RESET THE BUFFER FLAGS CLA STA B,I INB STA B,I STA EQT14,I JMP IMEDT WRITE LDA $12BF LOOK AT READY FLAG SSA JMP INITW JSB SETBF SET UP BUFFER JMP IMEDT FLAG COMPLETION SETBF NOP ENTRY FOR BUFFER SETUP LDA BUFP MAKE SURE POINTER IS DIRECT WTLP SSA,RSS JMP OKLP AND B7777 LDA A,I JMP WTLP OKLP STA BUFP LDA PNTR WTLP2 SSA,RSS JMP OKLP2 AND B7777 LDA A,I JMP WTLP2 OKLP2 STA PNTR LDA EQT6,I LOOK AT WRITE COMMAND AND M1077 ALL WRITE EXCEPT WITH BIT 9 THE SAME CPA D2 CHECK FOR VALID WRITE JMP GOOD1 GO WRITE NORMAL CLA,INA FLAG BAD WRITE REQUEST JMP IZ12,I GOOD1 LDA EQT8,I PICK UP LENGTH SSA,RSS CHECK FOR BYTE COUNT JMP WORD THIS IS A WORD COUNT CMA,INA MAKE BYTE COUNT POSITIVE SLA AND EVEN INA ARS MAKE INTO A WORD COUNT WORD ADA MD66 CHECK FOR REQUEST TO LONG SSA,RSS CLA MAKE COUNT 132 ADA D66 STA CNT LDA EQT7,I LDB BUFP MVW CNT LDA CNT ALS STA $12CT LDB BUFP SET LANGUAGE CODE ADB D13 LDA EQT14,I STA EQT14,I LDA BIT15 IOR $12BF STA $12BF SLA JMP RTN INA STA $12BF TRANS JSB $LIST SCHEDULE THE SYMBOL PROGRAM OCT 701 DEF RTN DEF SYMBR DEF PNTR DEF EQTAD DEF PNT1 DEF D0 DEF D0 RTN LDU B CNT JMP SETBF,I EXIT SUBROUTINE INITW LDA BIT15 STA EQT12,I CLA JMP IZ12,I IMEDT LDA D4 SEND BACK IMMEDIATE COMPLETION JMP IZ12,I SKP CZ12 NOP LDA TIMEO RESET TIME OUT VALUE STA EQT15,I LDA EQT12,I CHECK TO SEE IF SSA,RSS THERE IS MORE DATA TO GO TO SYMBR JMP C1 NO MORE DATA WAITING LDA $12BF DATA WAITING SEE IF IT CAN BE OUTPUT SSA JMP CKCOM BUFFER STILL BUSY JSB SETBF SET UP BUFFER CLA CLEAR BUFFER FLAG STA EQT12,I JMP CXIT+1 FLAG COMPLETION C1 LDA EQT12,I SLA CHECK FOR COMPLETION WAIT JMP CKCOM CHECK FOR STILL SCHEDULED CLA STA EQT12,I CLEAR CHECK FLAG JMP CXIT+1 FLAG COMPLETION CXIT ISZ CZ12 LDB CNT JMP CZ12,I RETURN FROM TIME-OUT ENTRY CKCOM NOP JMP CXIT CONTINUE SKP MD1 DEC -1 B2203 OCT 2203 B7777 OCT 77777 RDFLG DEC -1 BIT12 OCT 10000 BIT15 OCT 100000 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D6 DEC 6 D13 DEC 13 B2303 OCT 2303 B2403 OCT 2403 B3003 OCT 3003 B3777 OCT 37777 B703 OCT 703 B1002 OCT 1002 CNT NOP MD15 DEC -15 D15 DEC 15 B77 OCT 77 TIMEO DEC -50 MD66 DEC -66 D66 DEC 66 M1077 OCT 1077 BUFP DEF $12B2 SYMBR ASC 3,SYMBR D0 DEC 0 PNTR DEF $12CT PNT1 DEF $12BF EQTAD NOP CNT3 NOP SKP EQT1 EQU 1660B EQT2 EQU EQT1+1 EQT3 EQU EQT2+1 EQT4 EQU EQT3+1 EQT5 EQU EQT4+1 EQT6 EQU EQT5+1 EQT7 EQU EQT6+1 EQT8 EQU EQT7+1 EQT9 EQU EQT8+1 EQT10 EQU EQT9+1 EQT11 EQU EQT10+1 EQT12 EQU 1771B EQT13 EQU EQT12+1 EQT14 EQU EQT13+1 EQT15 EQU EQT14+1 END A  92840-18108 1913 S C0122 &$12BF 2608A ADD. GRAPHICS DVR             H0101 nASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: $12BF -- DVB12 GRAPHICS BUFFER * SOURCE: 92840-18108 * RELOC: 92840-16012 * * * ************************************************************* * NAM $12BF,15 92840-16012 REV.1913 790110 ENT $12BF,$12B1,$12CT,$12B2 $12BF BSS 3 $12B1 BSS 20 $12CT NOP $12B2 BSS 64 END 0  92840-18109 2040 S C0122 &SYMBR SOURCE             H0101 FTN4,L C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS C C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- C C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- C C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C NAME: SYMBR -- DVZ12 CHECKOUT C SOURCE: 92840-18109 C RELOC: 92840-16012 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PROGRAM SYMBR(,51), 92840-16012 REV.2040 800807 C C****************************************************************** C C MODIFIED BY PHIL P. OF BOISE TO CORRECT ABORT PROBLEM C WHEN LABELS EXTEND BEYOND LOGICAL LIMITS FOR THE 2040 PCO C C******************************************************************* C DIMENSION IPRAM(5),IEQT(20),IBUFR(133),IPLTB(1040) 1 ,ITEMP(50) INTEGER FNAME DIMENSION LU(3),FNAME(3) EQUIVALENCE (IPRAM,IBUFF),(IEQTP,IPRAM(2)),(IEQT(10),EANG) EQUIVALENCE (IPRAM(3),IPNT1),(IEQT(6),SCALE) CALL RMPAR(IPRAM) IF (IPRAM.EQ.0)STOP CALL Z12RV(IEQTP,IEQT,IBUFF,IBUFR) LU(1)=-IEQT(1) LU(2)=IEQT(5) LU(3)=IEQT(15) DO 5 I=1,3 5 FNAME(I)=IEQT(I+1) X=IEQT(8) Y=IEQT(9) IF (X.LT.0.) GO TO 211 PP2040 IF (Y.LT.0.) GO TO 211 PP2040 IF (X.GT.920.)GO TO 211 PP2040 YMAX=72*IEQT(16) PP2040 IF (Y.GT.YMAX)GO TO 211 PP2040 XMAX=920. PP2040 THETA=EANG ILEN=IEQT(16) CALL Z12IN(LU,1,IERR,Fz4NAME,ILEN,IPLTB,1040,0) CALL Z12WD(IEQT(12)) CALL Z12MD(IEQT(13)) N=IBUFR(1)/2 IT1=IBUFR(N+1)/400B IT2=IBUFR(N+1)-IT1*400B IF(IT2.EQ.40B)IBUFR(1)=IBUFR(1)-1 ILF=0 IF((IT2.EQ.137B).OR.((IT2.EQ.40B).AND.(IT1.EQ.137B)))ILF=1 IF (ILF.EQ.1)IBUFR(1)=IBUFR(1)-1 IF(IEQT(14).EQ.-1)GO TO 200 SINT=SIN(THETA) COST=COS(THETA) PORX=X-7*SCALE*SINT PORY=Y+7*SCALE*COST DO 100 I=1,IBUFR J=(I-1)/2 IT1=IBUFR(J+2)/256 IT2=IBUFR(J+2)-IT1*256 DO 80 J=1,50 80 ITEMP(K)=0 IF (2*(I/2).EQ.I)IT1=IT2 NUM=1 CALL Z12FN(IEQT(1),IRBLU) CALL Z12CV(IEQT(14),ITEMP,IT1,NUM,IRBLU) IF(ITEMP(1).EQ.10000)GO TO 103 K=1 L=K DO 90 J=2,NUM IF((ITEMP(J).GT.10000).OR.(ITEMP(J).EQ.0))GO TO 92 L=L+1 90 CONTINUE 92 CONTINUE DO 93 J=K,L IVL=ITEMP(J) IF (IVL.GT.10000)IVL=IVL-10000 IF (IVL.EQ.0)GO TO 103 IX1=IVL/100 IX2=IVL-IX1*100 IPX1=IX1/10 IPY1=IX1-IPX1*10 IPX2=IX2/10 IPY2=IX2-IPX2*10 PX1=FLOAT(IPX1-1)*SCALE PY1=FLOAT(IPY1-1)*SCALE PX2=FLOAT(IPX2-1)*SCALE PY2=FLOAT(IPY2-1)*SCALE PX=PORX+PX1*COST+PY1*SINT+.5 PY=PORY+PX1*SINT-PY1*COST+.5 IF(PX.GT.XMAX.OR.PX.LT.0)GO TO 93 PP2040 IF(PY.GT.YMAX.OR.PY.LT.0)GO TO 93 PP2040 CALL Z12PT(PX,PY,3) PX=PORX+PX2*COST+PY2*SINT+.5 PY=PORY+PX2*SINT-PY2*COST+.5 IF(PX.GT.XMAX.OR.PX.LT.0)GO TO 93 PP2040 IF(PY.GT.YMAX.OR.PY.LT.0)GO TO 93 PP2040 CALL Z12PT (PX,PY,2) 93 CONTINUE 103 PORX=PORX+7*COST*SCALE 100 PORY=PORY+7*SINT*SCALE GO TO 210 211 IDX=200. PP2040 IDY=200. 3 PP2040 GO TO 212 PP2040 200 CONTINUE CALL Z12SB(X,Y,SCALE,IBUFR,THETA,0) 210 CALL Z12CL ANGLE=THETA-1.570796327 IF (ANGLE.LT.0.0)ANGLE=ANGLE+6.283185308 DX=COS(ANGLE)*SCALE*10.0 DY=SIN(ANGLE)*SCALE*10.0 IF(ILF.EQ.1)DX=COS(THETA)*SCALE*7.*IBUFR(1) IF(ILF.EQ.1)DY=SIN(THETA)*SCALE*7.*IBUFR(1) IDX=DX IDY=DY 212 CALL Z12RL(IEQTP,IPNT1,IDX,IDY) PP2040 END C C C SUBROUTINE Z12CV (ICHST,IBFF,ICHR,NUM,LU) DIMENSION IBFF(100),ITEMP(63),IVEC(40),IMSK(7),IDOT(7,9) 1,ITP(16) DATA ITP/0,10000B,20000B,30000B,40000B,50000B,60000B,70000B 1,100000B,110000B,120000B,130000B,140000B,150000B,160000B,170000B/ IF ((ICHST.GT.15).OR.(ICHST.LT.0))ICHST=0 ICHT=ITP(ICHST+1)+ICHR INUM=NUM*9+1 CALL EXEC(1,LU,IBFF,INUM,ICHT) JCNT=0 5 DO 100 K=1,NUM DO 6 I=1,7 6 IMSK(I)=2**(7-I) DO 11 J=1,9 L=(K-1)*9+J+1 DO 10 I=1,7 IDOT(I,J)=0 L1=(J-1)*7+I IF (IAND(IBFF(L),IMSK(I)).EQ.0) GO TO 10 IDOT(I,J)=1 10 ITEMP(L1)=IDOT(I,J) 11 CONTINUE L=0 DO 30 J=1,9 DO 25 I=1,7 IF (IDOT(I,J).EQ.0)GO TO 25 DO 22 M=I,7 IF (IDOT(M,J).EQ.0)GO TO 23 IDOT(M,J)=0 22 M1=M 23 IF(M1.EQ.I)GO TO 25 L=L+1 IVEC(L)=I*1000+J*100+M1*10+J 25 CONTINUE DO 30 M1=1,7 L1=(J-1)*7+M1 30 IDOT(M1,J)=ITEMP(L1) DO 40 I=1,7 DO 35 J=1,9 IF (IDOT(I,J).EQ.0)GO TO 35 DO 32 M=J,9 IF (IDOT(I,M).EQ.0)GO TO 33 IDOT(I,M)=0 32 M1=M 33 IF(J.EQ.M1)GO TO 35 L=L+1 IVEC(L)=I*1000+J*100+I*10+M1 35 CONTINUE DO 40 M1=1,9 L1=(M1-1)*7+I 40 IDOT(I,M1)=ITEMP(L1) DO 50 J=1,8 DO 50 I=1,6 IF (IDOT(I,J).EQ.0)GO TO 50 IF (IDOT(I+1,J+1).EQ.0)GO TO 50 S\ IF (IDOT(I,J+1).EQ.1)GO TO 50 IF (IDOT(I+1,J).EQ.1)GO TO 50 L=L+1 IVEC(L)=I*1000+J*100+(I+1)*10+(J+1) 50 CONTINUE DO 60 J=1,8 DO 60 I=2,7 IF (IDOT(I,J).EQ.0)GO TO 60 IF(IDOT(I-1,J+1).EQ.0)GO TO 60 IF(IDOT(I-1,J).EQ.1)GO TO 60 IF(IDOT(I,J+1).EQ.1)GO TO 60 L=L+1 IVEC(L)=I*1000+J*100+(I-1)*10+(J+1) 60 CONTINUE DO 70 I=1,L-1 M=I+1 DO 70 J=M,L IF(IVEC(J).NE.IVEC(I))GO TO 70 L=L-1 DO 65 M1=J,L 65 IVEC(M1)=IVEC(M1+1) 70 CONTINUE DO 280 I=1,L-1 IX1=IVEC(I)/100 IX2=IVEC(I)-IX1*100 IX3=IX1/10 IY3=IX1-10*IX3 IX4=IX2/10 IY4=IX2-IX4*10 IF (IX2.EQ.IX1+1)GO TO 150 IF (IX2.EQ.IX1+10)GO TO 140 GO TO 280 140 DO 145 M1=I+1,L IY1=IVEC(M1)/100 IY2=IVEC(M1)-IY1*100 IF (IY4.EQ.1)GO TO 141 IF((IX1.EQ.IY1).AND.(IY2.EQ.IY1-9).AND.(IDOT(IX4,IY4-1).EQ.1)) 1 IX2=IX2-1 141 IF (IY3.EQ.1)GO TO 142 IF ((IX2.EQ.IY1).AND.(IY2.EQ.IY1+11).AND.(IDOT(IX3,IY3-1).EQ.1)) 1 IX1=IX1-1 142 IF (IY4.EQ.9)GO TO 143 IF ((IX1.EQ.IY2).AND.(IY1.EQ.IY2-11).AND.(IDOT(IX4,IY4+1).EQ.1)) 1 IX2=IX2+1 143 IF (IY3.EQ.9)GO TO 145 IF ((IX2.EQ.IY2).AND.(IY1.EQ.IY2+9).AND.(IDOT(IX3,IY3+1).EQ.1)) 1 IX1=IX1+1 145 CONTINUE GO TO 280 150 DO 155 M1=I+1,L IY1=IVEC(M1)/100 IY2=IVEC(M1)-IY1*100 IF (IX3.EQ.1)GO TO 151 IF((IX2.EQ.IY1).AND.(IY2.EQ.IY1+11).AND.(IDOT(IX3-1,IY3).EQ.1)) 1 IX1=IX1-10 151 IF (IX3.EQ.7)GO TO 152 IF((IX2.EQ.IY1).AND.(IY2.EQ.IY1-9).AND.(IDOT(IX3+1,IY3).EQ.1)) 1 IX1=IX1+10 152 IF (IX4.EQ.1)GO TO 153 IF((IX1.EQ.IY2).AND.(IY1.EQ.IY2+9).AND.(IDOT(IX4-1,IY4).EQ.1)) 1 IX2=IX2-10 153 IF (IX4.EQ.7)GO TO 155 IF ((IX1.EQ.IY2).AND.(IY1.EQ.IY2-11).AND.(IDOT(IX4+1,IY4).EQ.1)) 1 IX2=IX2+10 155 CONTINUE 280 IVEC(I)=IX1*100+IX2 DO 180 I=1,L-1 PM=I+1 IX1=IVEC(I)/100 IX2=IVEC(I)-IX1*100 IF((IX2.NE.IX1+11).AND.(IX2.NE.IX1-9))GO TO 180 DO 175 M1=M,L 69 IY1=IVEC(M1)/100 IY2=IVEC(M1)-IY1*100 IF (IX2.NE.IY1)GO TO 175 IF((IY2.NE.IY1+11).AND.(IY2.NE.IY1-9))GO TO 175 IF((IX2.GT.IX1).AND.(IY2.GT.IY1))GO TO 171 IF((IX2.LT.IX1).AND.(IY2.LT.IY1))GO TO 173 GO TO 175 171 IX2=IY2 L=L-1 IF (M1.GT.L)GO TO 180 DO 172 M2=M1,L 172 IVEC(M2)=IVEC(M2+1) GO TO 69 173 IX2=IY2 L=L-1 IF (L.LT.M1)GO TO 180 DO 174 M2=M1,L 174 IVEC(M2)=IVEC(M2+1) GO TO 69 175 CONTINUE 180 IVEC(I)=IX1*100+IX2 IF (L.EQ.0) GO TO 91 DO 90 I=1,L IX1=IVEC(I)/1000 IY1=IVEC(I)/100-IX1*10 IX2=IVEC(I)/10-(IX1*100+IY1*10) IY2=IVEC(I)-(IX1*1000+IY1*100+IX2*10) IF (IX1.EQ.IX2)GO TO 75 IF (IY1.EQ.IY2)GO TO 80 IT=IX1 DO 71 JT=IY1,IY2 IDOT(IT,JT)=0 IT=IT+1 IF (IX1.GT.IX2)IT=IT-2 71 CONTINUE GO TO 85 75 DO 76 M1=IY1,IY2 76 IDOT(IX1,M1)=0 GO TO 85 80 DO 81 M1=IX1,IX2 81 IDOT(M1,IY1)=0 85 CONTINUE 90 CONTINUE 91 DO 95 I=1,7 DO 95 J=1,9 IF (IDOT(I,J).EQ.0)GO TO 95 L=L+1 IVEC(L)=I*1000+J*100+I*10+J 95 CONTINUE IF (L.GT.0)GO TO 96 JCNT=JCNT+1 IBFF(JCNT)=10000 GO TO 100 96 IVEC(1)=IVEC(1)+10000 DO 99 I=1,L JCNT=JCNT+1 99 IBFF(JCNT)=IVEC(I) 100 CONTINUE NUM=JCNT RETURN END C C C SUBROUTINE Z12FN(LU,RBACK) INTEGER RBACK RBACK=6 IF (LU.NE.0) GO TO 30 RETURN 30 IDRT=IGET(1652B) LUMAX=IGET(1653B) IF (LUMAX .GT. 63) LUMAX = 63 DS2040 IF (LU.GT.LUMAX)RETURN IPNT=IDRT+(LU-1) IEQT=IAND(IGET(IPNT),77B) DO 100 I=1,LUMAX RBACK=I IPNT=IDRT+(I-1) JEQT=IAND(IGET(IPN}_$"T),77B) IF(IEQT.NE.JEQT)GO TO 100 JSC=IAND(IGET(IPNT),174000B)/2048 IF(JSC.EQ.3)RETURN 100 CONTINUE RBACK=LU RETURN END END$ $  92840-18110 1913 S C0122 &SYMBT 2608A ADD. GRAPHICS DVR             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SYMB * SOURCE: 92840-18110 * RELOC: 92840-16012 * * * ************************************************************* * NAM SYMB,8 92840-16012 REV.1913 790110 * * * **************************************************************** * * * * **************************************************************** * ENT Z12SB * EXT Z12PT,SIN,COS,.ENTR,ERR0,IFIX,FLOAT * **************************************************** * * ROUTINE: SYMB (SYMBOL) * * -FORTRAN LINKAGE- * CALL SYMB(X,Y,SIZE,BCD,THETA,N) * * -CALLING SEQUENCE- * JSB SYMB * DEF *+7 * DEF X * DEF Y * DEF SIZE * DEF BCD * DEF THETA * DEF N * * WHERE X AND Y ARE THE PAGE COORDINATES * OF THE LOWER LEFT CORNER OF THE FIRST * CHARACTER. SIZE IS THE DESIRED LETTER * HEIGHT. BCD IS THE LOCATION OF THE * ASCII ARRAY. THETA IS THE ANGLE OF * LETTERING WITH RESPECT TO THE X-AXIS. * * - X,Y,SIZE AND THETA ARE FLOATING POINT * NUMBERS. (THETA IS IN DEGREES). * * N=1 PLOT THE ASCII STRING DEFINED BY BCD * N=-1 PLOT THE SPECIAL CHARACTER GIVEN AND LEAVE THE * PEN DOWN * N=-2 PLOT THE SPECIAL CHARACTER GIVEN AND LEAVE THE * PEN UP * * BCD CAN BE AN INTEGER ARRAY OF THE ACTUAL CHARACTERS * TO BE PLOTTED (ASCII STRING CONVENTION IS USED *  WHICH MEANS THAT THE FIRST WORD INDICATES THE * NUMBER OF CHARCTERS THAT FOLLOWS) OR AN INTEGER * THAT SPECIFIES THE SPECIAL CHARACTER TO BE PLOTTED. * ******************************************************* * X DEF FL999 PARAMETER AREA Y DEF FL999 (SET BY .ENTR AFTER CALL) SIZE DEF OFCT (INITIALIZED TO FIXED VALUES BCD DEF C.02 TO PROTECT ROUTINE FROM SHORT THETA DEF OTHET PARAMETER LIST). N DEF CM.8 * * Z12SB NOP JSB .ENTR SET UP PARAMETER DEF Z12SB-6 LINKAGE AREA * LDA C.03 INITIALIZE PEN TO STA PEN UP POSITION. LDA N,I CHECK -N- SSA,RSS IF N >= 0, GO TO JMP S1 SET FOR ARRAY PLOT. * * SPECIAL CHARACTER ( N < 0 ) * LDB C.02 CMA,SZA IF N<=-1 THEN SET PEN=2 STB PEN FOR PEN DOWN CONDITION. CCA SET CHCNT = -1 FOR ONE CHAR STA CHCNT TO BE DRAWN. LDA TAB2A SET TABA TO REFERENCE TAB2 - STA TABA SPECIAL CHARACTER TABLE. DLD BCD,I GET CHAR VALU, SAVE A JSB IFIX STA CHAR INDEX TO TAB2. JMP S2 -NORMAL OFFSET- (GT 14(8)) * * ASCII CHARACTER PLOT (ARRAY OR SINGLE CHARACTER) * S1 LDA BCD,I GET CHAR COUNT ISZ BCD INCREMENT ADDRESS TO CHARACTERS AND M377 MASK OUT HIGH ORDER BITS CMA,INA SET N NEGATIVE - STA B (SAVE TEMPORARILY) SZA,RSS IF N = 0 (SINGLE CHAR PLOT), CCA SET N = -1. STA CHCNT SET N AS INDEX FOR CHAR. COUNT. * LDA BCD GET ARRAY ADDRESS - CONVERT TO RAL CHAR. ADDRESS (UPPER CHAR) SZB,RSS IF SINGLE CHAR. OUTPUT, SET ADDR. INA TO LOWER (BIT 0 =1) STA ARRAD SAVE ADDRESS. LDA N,I CHECK FOR TYPE OF PLOT SZA USE VECTORS? JMP DOTPA NO,USE DOT PATTERNS LDA TAB1A SET TABLE ADDnRESS = TAB1A TO STA TABA REFERENCE ASCII SET TABLE. * S2 DLD SIZE,I GET SIZE PARAMETER, DIVIDE BY * (ADDR OF F7 OR F4 - SET AT S2+1) DST FCT SET FACTOR (SIZE/DIV). * * CHECK FOR NEW THETA (ROTATIONAL) PARAMETER * DLD THETA,I CHECK NEW THETA CPA OTHET AGAINST OLD THETA VALUE RSS (INITIALIZED TO 0-DEGREES.) JMP S3 -NEW- CPB OTHET+1 JMP S4 -SAME AS OLD VALUE- * * CONVERT THETA TO RADIANS, COMPUTE SIN, COS * S3 DST OTHET SAVE AS NEW OLD-THETA JSB SICOS CALC. SIN AND COS JMP S5 * * * SICOS NOP CONV. THETA TO SIN AND COS DST TEMP1 JSB SIN CALCULATE SINE JSB ERR0 DST INCS DLD TEMP1 JSB COS CALCULATE COSINE JSB ERR0 DST INCC DLD FCT JMP SICOS,I RETURN * * CHECK FOR NEW FACTOR PARAMETER (SIZE/DIV) * S4 DLD FCT CHECK FOR CHANGE IN CPA OFCT FACTOR RSS JMP S5 -NEW- CPB OFCT+1 JMP S8 -SAME AS OLD VALUE * * CALCULATE POINT FACTORS FOR POINT (X1,Y1) * S5 DST OFCT SET NEW VALUE AS OLD FACTOR FMP INCC CALCULATE XA1 = FCT * INCC DST XA1 DLD OFCT FMP INCS CALCULATE YA1 = FCT * INCS DST YA1 * * CALCULATE POINT FACTORS FOR 10X10 MATRIX (2 TO 9) * LDA XA2A SET ADDR. FOR STA TEMP1 XA(2) LDA CM.8 SET INDEX FOR RANGE STA TEMP2 XA(2) TO XA(9) DLD XA1 XA(I) = XA(1) + XA(I-1) S6 FAD XA1 DST TEMP1,I SET XA(I) FOR I = 2-9 ISZ TEMP1 -SET ADDR. ISZ TEMP1 FOR NEXT FLPT NUMBER. ISZ TEMP2 INDEX FOR 2 TO 9 JMP S6 -CONTINUE * LDA YA2A REPEAT STA TEMP1 ABOVE LDA CM.8 PROCESSING STA TEMP2 FOR DLD YA1 YA(2) TO YA(9) S7 ] FAD YA1 ACCORDING TO: DST TEMP1,I ISZ TEMP1 YA(I) = YA(1) + YA(I-1) ISZ TEMP1 ISZ TEMP2 JMP S7 * * PROCESS X,Y COORDINATES IN CALL * S8 DLD X,I IF -X- IS GT OR = TO * FSB XA2 FAD YA2 XORG = X - XA(2) + YA(2) DST XORG * S9 DLD Y,I IF -Y- IS GT OR = TO * FSB XA2 FSB YA2 YORG = Y - XA(2) - YA(2) DST YORG * S10 LDB N,I IF N < 0, THEN SET LDA CHAR (A) = CHAR INDEX SSB AND GO TO JMP S12 GET CHAR. OFFSETS. * * EXTRACT CHAR FROM BCD ARRAY AND INDEX TO TABLES * S11 LDB ARRAD GET CURRENT CHARACTER ADDRESS LBT STB ARRAD - SET FOR NEXT CHARACTER ADDR.- AND M77 IN A. (USE ONLY LOW 6-BITS) * S12 ADA TABA SET APPROPRIATE TABLE STA TEMP1 ADDRESS - LDA A,I GET TABLE VALUE FOR -CHAR- AND M377 GET ADDR OF FIRST OFFSET WORD ADA TABLA IN OFFSET TABLE - CONVERT TO RAL UPPER POSITION STA OFFST CHARACTER ADDRESS. LDA TEMP1,I GET TABLE WORD AGAIN. SSA IF BIT 15 = 1, SET OFFSET ADDRESS ISZ OFFST TO LOWER POSITION. ALF,ALF ROTATE OFFSET COUNT TO AND M177 LOW A (7-BITS) AND SET CMA,INA NEGATIVE FOR STA OFFCT INDEX FOR INDEX FACTORS * * EXTRACT AND PROCESS EACH OFFSET PAIR FOR CHARACTER * S13 LDB OFFST GET CURRENT OFFSET-PAIR CHARACTER LBT STB OFFST ADDRESS, SET FOR NEXT ADDRESS. ALF,ALF (X,Y) OF 8-BITS. STA B SAVE X,Y. ALF PUT X AND M17 IN LOW A, ALS MULTIPLY BY 2 STA TEMP1 AND SAVE FOR INDEX TO XA-ARRAY LDA B PUT ALF,ALF Y IN LOW A, AND M17 MULTIPLY ALS BY 2 STA TEMP2 AND SAVE FOR INDEX TO YA. LDA M36 IF X OFFSET = 17(8) FOR LDB C.03 PEN-UP, THEN CPA TEMP1 GO TO SET IC AND GET JMP S14 NEXT OFFSET PAIR. * LDA XAD COMPUTE ADDRESS OF ADA TEMP1 XA-ARRAY FOR X-OFFSET STA TEMP3 LDA YAD COMPUTE ADDRESS OF ADA TEMP2 YA-ARRAY FOR Y-OFFSET STA TEMP4 DLD XORG COMPUTE: FAD TEMP3,I FSB TEMP4,I XT = XORG + XA(KX) - YA(KY) DST XT * LDA YAD COMPUTE ADDRESS OF ADA TEMP1 YA-ARRAY FOR X-OFFSET STA TEMP3 LDA XAD COMPUTE ADDRESS OF ADA TEMP2 XA-ARRAY FOR Y-OFFSET STA TEMP4 DLD YORG COMPUTE FAD TEMP3,I FAD TEMP4,I YT = YORG + YA(KX) + XA(KY) DST YT * * CALL FOR PLOT FOR CURRENT XT,YT * JSB Z12PT DEF *+4 DEF XT DEF YT DEF PEN * * LDB C.02 SET FOR PEN DOWN S14 STB PEN * ISZ OFFCT INDEX CHARACTER OFFSET COUNT JMP S13 - MORE TO PROCESS - * * SET X-ORIGIN AND Y-ORIGIN FOR NEXT CHARACTER. * DLD XORG FAD XA7 X-ORIGIN = X-ORIGIN + XA(7) DST XORG * DLD YORG FAD YA7 Y-ORIGIN = Y-ORIGIN + YA(7) DST YORG LDA C.03 STA PEN * ISZ CHCNT INDEX CHARACTER COUNTER JMP S11 - MORE TO PLOT - * * CALL TO SYMB COMPLETED * SYMBR JMP Z12SB,I HED USE ACTUAL DOT PATTERNS DOTPA EQU * USE DOT PATTERNS DLD SIZE,I SIZE OF CHAR. JSB IFIX SSA CMA,INA FORM ABSOLUTE VALUE SZA,RSS INVALID 0? CLA,INA YES, SET IT TO 1 STA SIZEF SAVE ABSOL. SIZE (FIXED PT.) DLD THETA,I ANGLE FAD D45.0 "ROUND" JSB SICOS CALC. SINE AND COS * DETERMINE IF HORIZ. OR VERTICAL AXIS CLB FLAG FOR VERTICAL LDA INCS SINE OF THETA XOR INCC COS OF THETA SSA HORIZ? _ INB NO STB HVFLG HORIZ/VERT. FLAG * DETERMINE ACTUAL QUADRANTS CLB,INB LDA INCS SIN OF THETA SSA QUAD. 1 OR 2? CMB,INB NO. 3 OR 4 LDA HVFLG HORIZ/VERT FLAG SZA HORIZ.? CMB,INB NO STB MY + OR - 1 CLB,INB LDA INCC COS OF THETA SSA QUAD. 1 OR 4? CMB,INB NO, 2 OR 3 LDA HVFLG HORIZ/VERT FLAG SZA HORIZ.? CMB,INB NO STB MX + OR - 1 * PICK UP ADDRESS TO DOT PATTERNS CLB ADDR. ONLY FLAG FOR GPARA * SET UP VALUES & CONVERT TO INTEGER CLA,INA BOTTOMS UP READ JSB Z12PT DEF *+4 DEF X,I DEF Y,I DEF D3 PEN UP STA IX SAVE INTEGER VALUE OF X-COORD. STB IY SAVE INTEGER VALUE OF Y-COORD. STA IIX ESTABLISH RESET VALUE FOR X-COORD. STB IIY ESTABLISH RESET VALUE FOR Y-COORD. * EXTRACT CHAR. FROM BCD ARRAY NXCHR EQU * NEXT CHARACTER LDA ARRAD CHAR. POINTER TO USER'S BUFFER ISZ ARRAD POINT TO NEXT CHAR. IN BCD STRING CLE,ERA SHIFT RIGHT/LEFT BIT & /2 LDA A,I PICK UP DESIRED WORD SEZ,RSS RIGHT-HAND CHAR.? ALF,ALF NO AND B177 * DETERMINE RIGHT OR LEFT PORTION OF BIT-PAT.-WORD CLE,ERA SHIFT RIGHT/LEFT BIT & /2 CLB FLAG FOR LEFT SEZ USE RIGHT HALF OF BIT-PATTERNS? CCB YES STB RORL 0=LEFT, NOT 0=RIGHT ADA CHBIS CHAR. BIAS/2 MPY D9 9 WORDS/CHAR. ADA D9 POINT TO BOTTOM OF LIST ADA ACBUF START OF BIT-PATTERNS STA ABITP SAVE POINTER TO BIT-PATTERNS LDA MD9 ROWS/CHAR. STA IDX1 INDEX FOR LOOP NXROW EQU * NEXT ROW LDB RORL RIGHT OR LEFT BIT-PAT. FLAG LDA ABITP POINTER TO BIT PATTExRNS ADA MD1 BUMP POINTER TO NEXT ROW STA ABITP RESTORE IT LDA A,I PICK UP CURRENT BIT PATTERN CLE,ERB SHIFT RIGHT/LEFT FLAG SEZ LEFT HALF? ALF,ALF NO CLE,ELA IGNORE 1ST COL. STA BITP NEXT ROW OF BIT PATTERNS LDA NOCOL NO. COLUMNS (7 OR 5) STA IDX2 INITIALIZE INDEX FOR COLUMNS NXBIT EQU * NEXT BIT LDA BITP CURRENT BIT PATTERN FOR THIS ROW CLE,ELA SHIFT BIT INTO POSITION STA BITP SAVE REMAINING BITS SEZ,RSS BIT SET? JMP NOTST NO DLD IX X,Y JSB TBITO TURN THIS BIT ON IN DISC LDA SIZEF POSSIBLE SIZE OF CHAR. CPA D1 *2? JMP NOTX2 NO CLA LDB MY Y = Y + MY JSB HVCK HORIZ/VERT CHECK FOR SWAP X&Y JSB TBITO SET THIS BIT ON IN DISC LDA MX X = X + MX CLB JSB HVCK CHECK FOR SWAP JSB TBITO SET BIT ON CLA LDB MY Y = Y - MY CMB,INB JSB HVCK CHECK FOR SWAP JSB TBITO SET BIT ON JMP NOTX2 INC. X BY ONLY 1 FOR X2 NOW NOTST EQU * BIT NOT SET LDA SIZEF POSSIBLE SIZE OF CHAR. CPA D1 *2? JMP NOTX2 NO LDA MX X = X + MX CLB JSB HVCK CHECK FOR SWAP NOTX2 EQU * NOT TWICE AS BIG LDA MX X = X + MX CLB JSB HVCK CHECK FOR SWAP CKROW EQU * CHECK IF ROW COMPLETE ISZ IDX2 FINISHED W/ ALL COL. IN ROW? JMP NXBIT NO,CHECK NEXT BIT IN ROW LDB AIIX ADDR. OF RESET VALUES ADB HVFLG BIAS TO APPROPIATE VALUE LDA B,I PICK UP X OR Y COORD. ADB D2 BIAS TO PROPER COORD. STA B,I SAVE APPROPIATE COORD. CLA LDB MY Y = Y + MY JSB HVCK CHECK FOR SWAP LDA SIZEF POSSIBLE SIZE OF CHA:R. CPA D1 *2? JMP CKR NO CLA LDB MY Y = Y + MY JSB HVCK CHECK FOR SWAP CKR ISZ IDX1 FINISHED WITH CHAR.? JMP NXROW NO, START ON NEXT ROW LDA IIX RESET VALUE FOR X-COORD. LDB IIY RESET VALUE FOR Y-COORD. STA IX RESET X-COORD. STB IY RESET Y-COORD. LDA SIZE,I POSSIBLE SIZE & ORIENTATION SSA "LEFT-TO-RIGHT"? JMP TTB NO, "TOP-TO-BOTTOM" LDA MX STEP-DIRECTION FOR X-COORD. MPY D7 ASSUME 5X9 STA TEMP1 SAVE X FOR POSSIBLE *2 CLB X = X + (7*MX) JSB HVCK CHECK FOR SWAP LDA SIZEF POSSIBLE SIZE OF CHAR. CPA D1 *2? JMP RSTA NO, RESTORE LDA TEMP1 PICK UP X VALUE CLB JSB HVCK CHECK FOR SWAP RSTA LDA IX RESTORE X-COORD. JMP CKCHR CHECK FOR NEXT CHAR. IN STRING TTB EQU * "TOP-TO-BOTTOM" LDA MY MPY D11 ASSUME 5X9 STA B Y = Y - (11*MY) CMB,INB STB TEMP1 TEMP. SAVE FOR POSSIBLE *2 CLA JSB HVCK CHECK FOR H/V SWAP LDA SIZEF POSSIBLE SIZE OF CHAR. CPA D1 *2? JMP RSTB NO LDB TEMP1 RESTORE Y VALUE CLA JSB HVCK CHECK FOR H/V SWAP RSTB LDA IX RESTORE X-COORD CKCHR EQU * CHECK CHAR. DST IIX SAVE NEW RESET COORD. VALUES ISZ CHCNT FINISHED W/ USER'S CHAR. STRING? JMP NXCHR NO,START ON NEXT CHAR. JSB FLOAT FLOAT VALUE OF X-COORD. DST TEMP1 AND SAVE IT LDA IIY RESET VALUE JSB FLOAT FLOAT VALUE OF Y-COORD. DST TEMP3 AND SAVE IT JSB Z12PT INITIALIZE ALL REQ'D. FLAGS DEF *+4 DEF TEMP1 DEF TEMP3 DEF D3 PEN UP JMP SYMBR RETURN TO USER * * ROUTINE TO CHECK AND SWAP HORIZ/VERT. VALUES IF REQ'D. * HVCK NOP HORIZ/VERT. CHECK STA RX SAVE TEMP RELATIVE VALUES STB RY LDA HVFLG HORIZ/VERT. FLAG SZA HORIZ. AXIS? JMP VERT NO LDA RX JMP VERT+2 VERT LDA RY SWAP HORIZ. & VERT. VALUES LDB RX ADA IX STEP IN PROPER DIRECTION ADB IY DST IX RESTORE VALUES JMP HVCK,I RETURN * * ROUTINE TO PLOT DESIRED POINT * TBITO NOP TURN BIT ON LDA AXY ADDR. OF X-Y COORD. LDB APENC ADDR. OF PEN CONTROL JMP TBITO,I RETURN * * * AXY DEF IX APENC DEF D1 ADDR. OF PEN CONTROL D45.0 DEC 45.0 D11 DEC 11 D7 DEC 7 NOCOL DEC -7 NO. COLUMNS (7 OR 5) MD1 DEC -1 MD9 DEC -9 D9 DEC 9 D3 DEC 3 D2 DEC 2 D1 DEC 1 CHBIS OCT -20 CHAR. BIAS/2 B177 OCT 177 HVFLG OCT 0 HORIZ./VERT. FLAG MX OCT 0 MOVEMENT IN "X" DIRECTION MY OCT 0 MOVEMENT IN "Y" DIRECTION ACBUF OCT 0 ADDR. OF CHAR DOT PAT. BUFFER AIIX DEF IIX * PRESERVE THE FOLLOWING 4-WORD SEQUENCE IIX OCT 0 RESET VALUE FOR X-COORD. IIY OCT 0 RESET VALUE FOR Y-COORD. IX OCT 0 X-COORDINATE IY OCT 0 Y-COORDINATE RORL OCT 0 RIGHT OR LEFT IDX1 OCT 0 INDEX REGISTER 1 IDX2 OCT 0 INDEX REGISTER 2 ABITP OCT 0 ADDR. OF CURRENT BIT PATTERN BITP OCT 0 CURRENT ROW OF BITS FOR PATTERN RX OCT 0 RELATIVE X-COORD. RY OCT 0 RELATIVE Y-COORD. SIZEF OCT 0 ABSOL. VALUE OF FIXED PT. SIZE * * * CONSTANT, FLAG AND STORAGE SECTION * A EQU 0 A, B B EQU 1 REGISTERS * C.02 DEC 2 C.03 DEC 3 CM.8 DEC -8 CM15 DEC -15 * M17 OCT 17 M36 OCT 36 M77 OCT 77 M177 OCT 177 M377 OCT 377 M1774 OCT 177400 * FL999 DEC 999.0 * F4A DEF F4 F4 DEC 4.0 F7A DEF F7 F7 DEC 7.0 * PEN NOP * CHCNT NOP CHAR NOP OFFST NOP OFFCT NOP ARRAD NOP * TEMP1 NOP TEMPORARY TEMP2 NOP TEMP3 NOP STORAGE TEMP4 NOP * INCS DEC 0. INCC DEC 1.0 * FCT DEC 0. OFCT DEC .02 FOR .14 INCH INCREMENTS (.01 FOR .07) * OTHET DEC 0. INITIALIZE TO ZERO DEGREES ROTATION * RADN DEC .0174533 FACTOR FOR DEGREES TO RADIANS * * * XAD DEF XA0 XA2A DEF XA2 * XA0 DEC .00 INITIAL XA1 DEC .02 VALUES XA2 DEC .04 SET XA3 DEC .06 FOR XA4 DEC .08 .14 INCH XA5 DEC .10 INCREMENTS XA6 DEC .12 XA7 DEC .14 (FOR .07 INCH INCREMENTS, XA8 DEC .16 HALVE VALUES) XA9 DEC .18 * * * YAD DEF YA0 YA2A DEF YA2 * YA0 DEC 0. YA1 DEC 0. YA2 DEC 0. YA3 DEC 0. YA4 DEC 0. YA5 DEC 0. YA6 DEC 0. YA7 DEC 0. YA8 DEC 0. YA9 DEC 0. * * * XORG DEC 0. YORG DEC 0. * XT DEC 0. YT DEC 0. * * TABA NOP * TAB1A DEF TAB1 * TAB2A DEF TAB2 * * * CHARACTER REFERENCE TABLES - * * THE FOLLOWING TABLES (TAB1 AND TAB2) CONTAIN * THE INFORMATION TO ACCESS THE OFFSET TABLE * FOR EACH AVAILABLE CHARACTER. * * EACH CHARACTER OR SPECIAL SYMBOL AVAILABLE * FOR PLOTTING IS ASSOCIATED WITH ONE UNIQUE * WORD IN ONE OF THE FOLLOWING TABLES. * * EACH REFERENCE WORD CONTAINS THE FOLLOWING * INFORMATION: * 1. RELATIVE ADDRESS OF WORD IN OFFSET TABLE * FOR START OF OFFSET STRING * (BITS 07-00) * 2. NUMBER OF OFFSET PAIRS (8-BITS) IN STRING * (BITS 14-08) * 3. STARTING POSITION OF STRING IN WORD, * 0 MEANS UPPER, 1 MEANS LOWER. * (BIT 15) * * TAB1 COMPRISES THE STANDARD CHARACTER SET * TAB2 COMPRISES SPECIAL CHARACTERS AND * CENTERED SYMBOLS WHICH CAN BE ACCESSED * BY POSITION WHEN PARAMETER N < 0, IN CALL. * * TAB1 IS ORDERED BY POSITION DESIGNATED BY LOWER * 6-BITS OF ASCII CODE (E.G. A = 101 = 01) * - THIS *WTABLE IS LIMITED TO 64 ENTRIES - 00 * TO 77. * * * POS CNT ADDR CODE CHARACTER * --- --- ---- ---- --------- * TAB2 OCT 103641 1 7 241 00 OCT 106244 1 14 244 01 OCT 003252 0 6 252 02 OCT 003660 0 7 260 03 OCT 103663 1 7 263 04 OCT 003666 0 7 266 05 OCT 003671 0 7 271 06 OCT 004274 0 10 274 07 OCT 005700 0 13 300 08 OCT 003705 0 7 305 09 OCT 007310 0 16 310 10 OCT 006660 0 15 260 11 OCT 103316 1 6 316 12 OCT 002260 0 4 260 13 OCT 006252 0 14 252 14 OCT 101321 1 2 321 15 OCT 101325 1 2 325 16 OCT 102726 1 5 326 17 OCT 103233 1 6 233 18 OCT 104321 1 10 321 19 OCT 002731 0 5 331 20 OCT 102733 1 5 333 21 OCT 103236 1 6 236 22 OCT 001746 0 3 346 23 OCT 004336 0 10 336 24 OCT 004342 0 10 342 25 * * * TAB1 OCT 110347 1 20 347 00 @ OCT 004400 0 11 0 01 A OCT 106005 1 14 5 02 B OCT 104014 1 10 14 03 C OCT 103404 1 7 4 04 D OCT 003422 0 7 22 05 E OCT 003022 0 6 22 06 F OCT 006036 0 14 36 07 G OCT 103025 1 6 25 10 H OCT 003044 0 6 44 11 1 OCT 103047 1 6 47 12 J OCT 003033 0 6 33 13 K OCT 001425 0 3 25 14 L OCT 102431 1 5 31 15 M OCT 102030 1 4 30 16 N OCT 004414 0 11 14 17 O OCT 103453 1 7 53 20 P OCT 006014.H 0 14 14 21 Q OCT 104453 1 11 53 22 R OCT 006460 0 15 60 23 S OCT 102066 1 4 66 24 T OCT 003447 0 7 47 25 U OCT 001473 0 3 73 26 V OCT 002452 0 5 52 27 W OCT 102474 1 5 74 30 X OCT 002477 0 5 77 31 Y OCT 103467 1 7 67 32 Z OCT 002156 0 4 156 33 OCT 001076 0 2 76 34 OCT 002160 0 4 160 35 OCT 002562 0 5 162 36 OCT 102564 1 5 164 37 _ OCT 100471 1 1 71 40 OCT 003574 0 7 174 41 ! OCT 004577 0 11 177 42 " OCT 105603 1 13 203 43 # OCT 006611 0 15 211 44 $ OCT 106217 1 14 217 45 % OCT 105357 0 12 357 46 & OCT 002177 0 4 177 47 ' OCT 002152 0 4 152 50 ( OCT 002154 0 4 154 51 ) OCT 005542 0 13 142 52 * OCT 002542 0 5 142 53 + OCT 103230 1 6 230 54 , OCT 101143 1 2 143 55 - OCT 102630 1 5 230 56 . OCT 101074 1 2 74 57 / OCT 105013 1 12 13 60 0 OCT 102501 1 5 101 61 1 OCT 004504 0 11 104 62 2 OCT 006524 0 15 124 63 3 OCT 102110 1 4 110 64 4 OCT 105112 1 12 112 65 5 OCT 106113 1 14 113 66 6 OCT 102521 1 5 121 67 7 OCT 010524 0 21 124 70 8 OCT 105534 1 13 134 71 9 OCT 105625 1 13 225 72 : OCT 106225 1 14 225 73 ; OCT 001635 0 3 235 74 <  OCT 102547 1 5 147 75 = OCT 001640 0 3 240 76 > OCT 007167 0 16 167 77 ? * * * * * CHARACTER - OFFSET - TABLE * -EACH WORD CONTAINS 2 PAIRS OF X,Y OFFSETS, * "X1Y1X2Y2", EACH PAIR IS 8-BITS AND 4 * BITS IN EACH PAIR SPECIFY THE X AND Y POINT * FOR THE OFFSET. * * THE STRING OF OFFSET PAIRS FOR A CHARACTER MAY * START IN THE UPPER OR LOWER POSITION OF A * WORD. THE STARTING LOCATION, POSITION INDICATOR * AND OFFSET COUNT FOR EACH CHARACTER IS CONTAINED * IN THE REFERENCE TABLES. * * * PORTIONS OF OFFSET STRINGS MAY OVERLAP OTHER * STRINGS WHEN LINE SEGMENTS AMONG CHARACTERS * ARE IDENTICAL. * * TABLA DEF TABLE DEFINE STARTING ADDRESS OF TABLE * * OCTAL PAIRS ADDRESS SYMBOL * TABLE OCT 021045 2-2 2-5 00 +A OCT 062445 6-5 2-5 OCT 024071 2-10 3-11 OCT 054550 5-11 6-10 OCT 061131 6-2 5-11 -D OCT 064143 6-10 6-3 -B OCT 051042 5-2 2-2 OCT 024531 2-11 5-11 OCT 064147 6-10 6-7 10 OCT 053046 5-6 2-6 OCT 053145 5-6 6-5 OCT 061527 6-3 5-7 -0 OCT 064143 6-10 6-3 +Q,+0,-C OCT 051062 5-2 3-2 OCT 021450 2-3 2-10 OCT 034531 3-11 5-11 OCT 064360 6-10 17-0 20 OCT 042142 4-4 6-2 OCT 064451 6-11 2-11 +E,+F OCT 023126 2-6 5-6 OCT 023042 2-6 2-2 OCT 061042 6-2 2-2 +L,-H OCT 024446 2-11 2-6 OCT 063151 6-6 6-11 OCT 061042 6-2 2-2 30 -N OCT 024542 2-11 6-2 -M OCT 064506 6-11 4-6 OCT 024442 2-11 2-2 +K OCT 022551 2-5 6-11 OCT 043542 4-7 6-2 OCT 072525 7-5 5-5 +G OCT 062543 6-5 6-3 OCT 051062 5-2 3-2 40 OCT 021450 2-3 2-10 OCT 034531 3-11 5-11 OCT 064147 6-10 6-7 OCT 051062 5-2 3-2 +I OCT 041111 4-2 4-11 OCT 034531 3-11 5-11 OCT 024444 2-11 2-4 +U,-J OCT 021462 2-3 3-2 50 OCT 051143 5-2 6-3 OCT 064542 6-11 6-2 +W OCT 043042 4-6 2-2 -P,-R OCT 024531 2-11 5-11 OCT 064147 6-10 6-7 OCT 053046 5-6 2-6 OCT 043142 4-6 6-2 OCT 022043 2-4 2-3 60 +S OCT 031122 3-2 5-2 OCT 061545 6-3 6-5 OCT 053066 5-6 3-6 OCT 023450 2-7 2-10 OCT 034531 3-11 5-11 OCT 064102 6-10 4-2 -T OCT 044451 4-11 2-11 -Z OCT 064442 6-11 2-2 70 OCT 061360 6-2 17-0 -(PEN UP) OCT 033126 3-6 5-6 OCT 024502 2-11 4-2 +V OCT 064442 6-11 2-2 -X,-/ OCT 064760 6-11 17-0 OCT 024542 2-11 6-2 +\ OCT 024506 2-11 4-6 +Y OCT 041106 4-2 4-6 100 OCT 064522 6-11 5-2 -1 OCT 031102 3-2 4-2 OCT 044470 4-11 3-10 OCT 023450 2-7 2-10 +2 OCT 034531 3-11 5-11 OCT 064147 6-10 6-7 OCT 021442 2-3 2-2 OCT 061122 6-2 5-2 110 -4 OCT 054444 5-11 2-4 OCT 062151 6-4 6-11 -5 OCT 024446 2-11 2-6 -6 OCT 053145 5-6 6-5 OCT 061522 6-3 5-2 OCT 031043 3-2 2-3 OCT 022050 2-4 2-10 OCT 034531 3-11 5-11 120 OCT 064050 6-10 2-10 -7 OCT 024551 2-11 6-11 OCT 064102 6-10 4-2 OCT 024071 2-10 3-11 +8,+3 OCT 054550 5-11 6-10 OCT 063526 6-7 5-6 OCT 033126 3-6 5-6 OCT 062543 6-5 6-3 130 OCT 051062 5-2 3-2 OCT 021445 2-3 2-5 OCT 033047 3-6 2-7 OCT 024043 2-10 2-3 +9 OCT 031122 3-2 5-2 OCT 061550 6-3 6-10 OCT 054471 5-11 3-11 OCT 024046 2-10 2-6 140 OCT 032545 3-5 6-5 END OF BASIC OCT 041507 4-3 4-7 ++,+* OCT 042445 4-5 2-5 -- OCT 062505 6-5 4-5 OCT 021547 2-3 6-7 OCT 042447 4-5 2-7 OCT 061446 6-3 2-6 -= OCT 063360 6-6 17-0 150 OCT 021543 2-3 6-3 OCT 041063 4-2 3-3 +( OCT 034111 3-10 4-11 OCT 041123 4-2 5-3 +) OCT 054111 5-10 4-11 OCT 051062 5-2 3-2 +[ OCT 034531 3-11 5-11 OCT 031122 3-2 5-2 160 +] OCT 054471 5-11 3-11 OCT 041111 4-2 4-11 +^ OCT 034130 3-10 5-10 OCT 044545 4-11 6-5 -_. OCT 022466 2-5 3-6 OCT 032045 3-4 2-5 OCT 023450 2-7 2-10 +? OCT 034531 3-11 5-11 170 OCT 064147 6-10 6-7 OCT 053106 5-6 4-6 OCT 042360 4-4 17-0 OCT 031122 3-2 5-2 +! OCT 041462 4-3 3-2 OCT 170104 17-0 4-4 OCT 044507 4-11 4-7 +',+" OCT 054511 5-11 4-11 200 OCT 170051 17-0 2-11 OCT 023471 2-7 3-11 OCT 024463 2-11 3-3 -# OCT 033466 3-7 3-6 OCT 023146 2-6 6-6 OCT 053127 5-6 5-7 OCT 051524 5-3 5-4 OCT 062044 6-4 2-4 210 OCT 022063 2-4 3-3 +$ OCT 051544 5-3 6-4 OCT 062446 6-5 2-6 OCT 023470 2-7 3-10 OCT 054147 5-10 6-7 OCT 170111 17-0 4-11 OCT 041050 4-2 2-10 -% OCT 034071 3-10 3-11 220 a< OCT 024360 2-10 17-0 OCT 021151 2-2 6-11 OCT 170142 17-0 6-2 OCT 061522 6-3 5-2 OCT 061107 6-2 4-7 OCT 043126 4-6 5-6 OCT 053507 5-7 4-7 OCT 170123 17-0 5-3 OCT 041504 4-3 4-4 OCT 052123 5-4 5-3 OCT 041043 4-2 2-3 OCT 061760 6-3 17-0 OCT 062046 6-4 2-6 +> OCT 064043 6-10 2-3 - OCT 061760 6-3 17-0 OCT 022146 2-4 6-6 240 +> OCT 024042 2-10 2-2 OCT 042004 4-4 0-4 OCT 000100 0-0 4-0 OCT 042042 4-4 2-2 OCT 022024 2-4 1-4 OCT 001401 0-3 0-1 OCT 010060 1-0 3-0 OCT 040503 4-1 4-3 250 OCT 032044 3-4 2-4 OCT 021044 2-2 2-4 OCT 000501 0-1 4-1 OCT 022042 2-4 2-2 OCT 021403 2-3 0-3 OCT 020103 2-0 4-3 OCT 021442 2-3 2-2 OCT 021044 2-2 2-4 260 OCT 020042 2-0 2-2 OCT 001102 0-2 4-2 OCT 021004 2-2 0-4 OCT 040042 4-0 2-2 OCT 000104 0-0 4-4 OCT 021044 2-2 2-4 OCT 001040 0-2 2-0 OCT 041044 4-2 2-4 270 OCT 021002 2-2 0-2 OCT 022040 2-4 2-0 OCT 022102 2-4 4-2 OCT 021004 2-2 0-4 OCT 042042 4-4 2-2 OCT 000042 0-0 2-2 OCT 040042 4-0 2-2 OCT 021022 2-2 1-2 300 OCT 031042 3-2 2-2 OCT 042004 4-4 0-4 OCT 042000 4-4 0-0 OCT 040000 4-0 0-0 OCT 021004 2-2 0-4 OCT 021104 2-2 4-4 OCT 021040 2-2 2-0 OCT 021104 2-2 4-4 310 OCT 031423 3-3 1-3 OCT 002023 0-4 1-3 OCT 010400 1-1 0-0 OCT 010461 1-1 3-1 OCT 040061 4-0 3-1 OCT 031442 3-3 2-2 OCT 002104 0-4 4-4 OCT 000100 0-0 4-0 320 OCT 021042 2-Jfd`2 2-2 OCT 061360 6-2 17-0 OCT 022545 2-5 6-5 OCT 170050 17-0 2-10 OCT 064051 6-10 2-11 -1,#16 OCT 021111 2-2 4-11 - OCT 041063 4-2 3-3 OCT 051502 5-3 4-2 330 OCT 022545 2-5 6-5 + OCT 053124 5-6 5-4 OCT 062562 6-5 7-2 OCT 021126 2-2 5-6 OCT 024571 2-11 7-11 OCT 023146 2-6 6-6 + OCT 170043 17-0 2-3 OCT 061760 6-3 17-0 340 OCT 053462 5-7 3-2 OCT 021543 2-3 6-3 + OCT 170046 17-0 2-6 OCT 063106 6-6 4-6 OCT 044104 4-10 4-4 345 OCT 021507 2-3 4-7 + OCT 061544 6-3 6-4 -@ OCT 051463 5-3 3-3 350 OCT 022047 2-4 2-7 OCT 034130 3-10 5-10 OCT 063545 6-7 6-5 OCT 052104 5-4 4-4 OCT 032466 3-5 3-6 OCT 043527 4-7 5-7 OCT 063142 6-6 6-2 OCT 033470 3-73-10 OCT 044530 4-11 5-10 OCT 022444 2-5 2-4 OCT 031503 3-3 3-4 OCT 062000 6-4 * * END f  92840-18111 1913 S C0122 &RLSE 2608A ADD. GRAPHICS DVR             H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: Z12RL -- DVZ12 RELEASE SUBROUTINE * SOURCE: 92840-18111 * RELOC: 92840-16012 * * * ************************************************************* * NAM Z12RL,8 92840-16012 REV.1913 790110 ENT Z12RL A EQU 0 B EQU 1 EXT .ENTR,$LIBR,$LIBX,$12B1,$12BF PNTR NOP PNT1 NOP DX NOP DY NOP Z12RL NOP JSB .ENTR DEF PNTR LDA P$BF1 SSA,RSS JMP OK1 AND B7777 LDA 0,I JMP *-4 OK1 CAX LDA DX,I STA IX LDA DY,I STA IY JSB $LIBR NOP TURN OFF INTERRUPT SYSTEM CLA STA $12BF LAX 7 ADA IX SAX 7 LAX 10B ADA IY SAX 10B JSB $LIBX TURN ON INTERRUPT SYSTEM DEF Z12RL AND EXIT IX DEC 0 IY DEC 0 B7777 OCT 77777 P$BF1 DEF $12B1 END   92840-18112 1913 S C0122 &RTRV 2608A ADD. GRAPHICS DVR             H0101 ,ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: Z12RV -- SYMBR RETRIEVE SUBROUTINE * SOURCE: 92840-18112 * RELOC: 92840-16012 * * * ************************************************************* * NAM Z12RV,8 92840-16012 REV.1913 790110 ENT Z12RV EXT .ENTR,$12CT,$12B1 A EQU 0 IEQTP NOP IEQTB NOP IBUFF NOP IBUFR NOP Z12RV NOP JSB .ENTR DEF IEQTP LDA P$BF1 JSB INDCK CHECK FOR INDIRECT REFERENCE LDB IEQTB MVW CNT LDA P$BF2 JSB INDCK CHECK FOR INDIRECT REFERENCE CAX LAX 0 LDB IBUFR STA 1,I ARS STA CNTR CXA INB INA MVW CNTR JMP Z12RV,I CNT DEC 16 CNTR NOP P$BF1 DEF $12B1 P$BF2 DEF $12CT INDCK NOP SSA,RSS JMP INDCK,I AND B7777 LDA A,I JMP INDCK+1 B7777 OCT 77777 END   92840-18113 2040 S C0122 &SMPLT SOURCE             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SMPLT -- 2608A PLOTTER UTILITY * SOURCE: 92840-18113 * RELOC: 92840-16012 * * * ************************************************************* * HED * 2608 PLOTTER SYMBOL "PLOT" ROUTINE NAM SMPLT,8 98240-16012 REV.2040 800807 * **************************************************************** * * 2608 PLOTTER UTILITY * *********************************************************************** * * MODIFIED BY DJS TO CORRECT LABELING PROBLEM WHEN * OPERATING IN A SESSION SYSTEM. THE MODIFICATION ALLOWS * SMPLT TO ACCESS THE RASTER FILE (P@@@@@) ANYWHERE ON THE SYSTEM. * THE MODIFICATION WAS COMPLETED FOR THE 2040 PCO. * *********************************************************************** * * * ENT Z12PT,Z12IN,Z12PL ENT Z12WD ENT Z12CL,Z12MD * * EXT .ENTR,EXEC,FLOAT,IFIX EXT READF,WRITF,OPEN,CREAT,CLOSE,LOCF EXT OVRD.,REIO,$CVT3 DS2040 * A EQU 0 B EQU 1 * * THIS IS THE CENTRAL PROGRAM IN THE * HP REAL-TIME/DISC OPERATING SYSTEM * PLOTTER PACKAGE. * * *********** *** *** *** * * * THERE ARE 5 SECTIONS TO THE PLOT PROGRAM * * 1-FACT ESTABLISHES SCALING FACTOR OF PLOT * 2-PLOT CONVERTS THE X,Y AND PEN DATA TO PLOT * COMMANDS. * 3-WHERE ESTABLISHES WHERE PEN IS CURRENTLY. * 4-INIT INITIALIZES REQUIRED PARAMETERS * 5-LLEFT MOVES THE "PEN" TO LOWER LEFT CORNER AND *  ESTABLISHES ORIGIN AT 0,0 * * * HRESL DEC 70.0 H-RESOL.(DOTS/"INCH") 2608 VRESL DEC 72.0 V-RESOL.(DOTS/"INCH") 2608 * HED PLOT ROUTINE *********** ******** ****** * * ***** PLOT **** * * * THE -PLOT- ROUTINE CONVERTS THE DEFINED X,Y * PARAMETERS AND PLOTS THE "LINE". * * * - FORTRAN LINKAGE - * * CALL PLOT(X,Y,IC) * * -X,Y DEFINES THE NEW COORDINATE TO BE PLOTTED. * * -IC DEFINES THE PEN UP/DOWN COMMAND. * * * * * * - CALLING SEQUENCE - * * JSB PLOT PLOT ROUTINE ORIGIN * DEF *+4 * DEF X ADDRESS OF X COORDINATE. * DEF Y ADDRESS OF Y COORDINATE. * DEF IC ADDRESS OF PEN COMMAND. ****** ****** * * XTMP OCT 0 YTMP OCT 0 ICTMP OCT 0 Z12PL NOP JSB .ENTR DEF XTMP LDA XTMP,I STA IX LDA YTMP,I STA IY LDA ICTMP STA IC LDA Z12PL STA Z12PT JMP DOFST * * X OCT 0 ADDRESS OF X PLOT DATA. Y OCT 0 ADDRESS OF Y PLOT DATA. IC OCT 0 ADDRESS OF PEN COMMAND. Z12PT NOP JSB .ENTR DEF Z12PT-3 * * DLD X,I LOAD X PLOT DATA JSB IFIX STA IX STORE FIXED X #. * DLD Y,I LOAD Y PLOT DATA JSB IFIX STA IY STORE FIXED Y #. * DOFST EQU * DO OFFSET CALCULATIONS DLD XPEN LOAD OLD X,Y PLOT DATA DST IAX1 LAST ABSOLUTE POSITION DLD IX DST IAX2 ABSOLUTE POSITION OF NEW POINT * * DETERMINE PLOT MODE AND DRAW THE LINE.... * LDA IC,I GET PEN COMMAND SSA CMA,INA ABSOLUTIZE PEN COMMAND LDB IX CHECK FOR SAME POINT CPB XPEN RSS JMP DIF LDB IY CPB XPEN+1 RSS JMP DIF CLA,INA DIF CPA C01 PLOT POINTS? JMP PU.1 YES! CPA C02 MOVE WITH PEN DOWN?  JMP PU.2 YES JMP PU.3 .GE. 3 PU.1 LDA IAX2 LDB IAY2 JSB SETBT SET DESIRED BIT JMP PU.3 PU.2 EQU * * DRAW THE LINE JSB PLTLN PLOT LINE DEF *+5 DEF IAX1 DEF IAY1 DEF IAX2 DEF IAY2 * UPDATE REQUIRED INDEXES PU.3 DLD IX SET XPEN, YPEN = IX, IY DST XPEN LDA IC,I PEN CONTROL SSA,RSS NEW ORIGIN? JMP PU.4 NO LDA IX RESTORE A REG. DST IXR SAVE PREVIOUS REF CLB STB XPEN NEW ORGIN COORD. FOR CALC. STB YPEN PU.4 DLD IX RETURN JMP Z12PT,I * * ENTRY POINT TO SET A SINGLE BIT AND AVOID SCALING * A = POINTER TO X-Y COORD.(MUST BE CONSECUTIVE) * B = POINTER TO PEN COMMAND VALUE * SBIT NOP ENTRY POINT TO SET A BIT STA X SAVE ADDRESS OF X-COORD. STB IC SAVE ADDRESS OF PEN COMMAND LDB A,I PICK UP VALUE OF X STB IX SAVE IT INA POINT TO Y STA Y SAVE ADDRESS OF Y-COORD. LDB A,I PICK UP VALUE OF Y STB IY SAVE IT LDB SBIT RETURN ADDRESS STB Z12PT SAVE IT FOR GENERAL RETURN JMP DOFST DO OFFSET CALC. HED POINT TO POINT DIGITAL PLOT SUBROUTINE * THIS PROGRAM IS AN IMPLEMENTATION OF BRESENHAM'S * LINE DRAWING ALGORITHM. INPUT IS TWO SETS OF * COORDINATES BETWEEN WHICH A SERIES OF DOTS ARE * TO BE INSERTED. OUTPUT IS A SERIES OF COORDINATES * FOR THOSE DOTS REPRESENTING THE STRAIGHT LINE * BETWEEN THE INPUT COORDINATES. * * THIS PROGRAM ALSO USES THE SAME BASIC FLOWCHART * AND STRUCTURE AS IMPLEMENTED BY * JIM LANGLEY ON EPOC. * PX1 OCT 0 PY1 OCT 0 PX2 OCT 0 PY2 OCT 0 PLTLN NOP PLOT INCREMENTAL LINE JSB .ENTR RESOLVE ARGUMENT ADDRESSES DEF PX1 LDA PX1,I X1 STA X1 CMA,INA -X1 ADA PX2,I X2 STA DELX X2 - X1 LDB ;PY1,I Y1 STB Y1 CMB,INB -Y1 ADB PY2,I Y2 STB DELY Y2 - Y1 STB RCDFL SET FLAG FOR SETBT SSA CHECK FOR ABSOLUTE VALUE CMA,INA FORM ABS(DEL.X) STA IA FORM A OR B W/ DELTA X STA IB FORM A OR B W/ DELTA X SSB CHECK FOR ABSOLUTE VALUE CMB,INB FORM ABS(DELTA Y) STB TEMP ABS(DELTA Y) CMB,INB -ABS(DELTA Y) ADA B ABS(DELTA X)-ABS(DELTA Y) STA DELXY FORM DELTA XY LDB TEMP ABS(DELTA Y) SSA OCTANT 1, 8, 4, 5 ? JMP *+3 NO STB IB FORM DELTA B W/ DELTA Y RSS STB IA FORM DELTA A W/ DELTA Y * CONCATENATE SIGNS OF DELX, DELY, DELXY * TO FORM AN INDEX OF 0-7. LDA DELX DELTA X LDB DELY DELTA Y ELB SAVE SIGN OF DELTA Y RAL,ELA PACK SIGNS OF DELTA X&Y LDB DELXY DELTA XY ELB SAVE SIGN OF DELTA XY ELA PACK ALL 3 SIGNS TOGETHER AND L3BT MAX VALUE OF 7 STA NO. SAVE INDEX NO. (X,Y,XY) * SET UP STEPX & STEPY VALUES FOR M1 & M2 ADA ATM1X ADDR. TABLE OF M1 INDEX LDA A,I PICK UP INDEX OF M1 ADA ASTEP FORM ADDR. TO STEP VALUES DLD A,I PICK UP STEPS FOR X & Y DST M1 SAVE THEM FOR M1 LDA NO. INDEX NO. ADA ATM2X ADDR. TABLE OF M2 INDEX LDA A,I PICK UP INDEX OF M2 INDEX ADA ASTEP FORM ADDR. TO STEP VALUES DLD A,I PICK UP STEPS FOR X & Y DST M2 SAVE THEM FOR M2 * SET UP INITIAL VALUES FOR CALCULATIONS LDA IA ABSOLUTE VALUE OF "DELTA X" CMA STA COUNT NO. PASSES THRU LOOP ADA IB (B - A) ALS *2 STA TDEL 2*(B-A) = 2DEL LDA IB ABSOLUTE VALUE OF "DELTA Y" ALS *2 STA TDELB 2*B u LDA IA A CMA,INA -A ADA TDELB 2*B STA DEL 2*B-A CCA INITIALIZE LAST DIRECTION STA DIRLS LDA X1 X-COORD FOR POINT LDB Y1 Y-COORD FOR POINT DST SCCOR SET UP FIRST CO-ORDINATE RSS FIND DIRECTION OF PLOT BEFORE OUTPUTING PLTIT JSB PLTWD SET THIS SEGMENT ON IN FILE ISZ COUNT FINISHED? RSS NO JMP ERND RETURN * CALCULATE NEXT POSITION (POINT) TO PLOT LDA DEL SSA JMP CADEL CALC. NEW DEL LDA TDEL 2*(B-A) ADA DEL DEL + 2DEL JMP CKDEL CADEL EQU * CALCULATE DEL LDA TDELB 2*DELB ADA DEL DEL + 2*DELB CKDEL EQU * CHECK DEL STA DEL SAVE APPROPRIATE VALUE SSA,RSS USE M1? JMP USEM2 NO CLA SELECT MODE STA MDE LDA M1 STEP X FOR M1 LDB M1+1 STEP Y FOR M1 JMP NEWPT USEM2 EQU * CLA,INA SELECT MODE 2 STA MDE LDA M2 STEP X FOR M2 LDB M2+1 STEP Y FOR M2 NEWPT EQU * CALC. NEXT NEW POINT ADA X1 X1 + XSTEP STA X1 SAVE FOR NEXT ITERATION ADB Y1 Y1 + YSTEP STB Y1 SAVE FOR NEXT ITERATION JMP PLTIT PLOT THIS POINT ATM1X DEF TM1X ADDR. OF TABLE M1 INDICIES TM1X EQU * TABLE OF M1 INDICIES DEC 0 OCTANT 1 DEC 3 OCTANT 2 DEC 0 OCTANT 8 DEC 1 OCTANT 7 DEC 2 OCTANT 4 DEC 3 OCTANT 3 DEC 2 OCTANT 5 DEC 1 OCTANT 6 ATM2X DEF TM2X ADDR. OF TABLE M2 INDICIES TM2X EQU * TABLE OF M2 INDICIES DEC 4 OCTANT 1 DEC 4 OCTANT 2 DEC 5 OCTANT 8 DEC 5 OCTANT 7 DEC 7 OCTANT 4 DEC 7 OCTANT 3 DEC 6 y|OCTANT 5 DEC 6 OCTANT 6 ASTEP DEF STEPV STEPV EQU * STEP VALUES FOR M1 & M2 DEC 1 1,0 DEC 0 0,-1 DEC -1 -1,0 DEC 0 0,1 DEC 1 1,1 DEC 1 1,-1 DEC -1 -1,-1 DEC -1 -1,1 DEC 1 DELX OCT 0 DELTA X DELY OCT 0 DELTA Y IA OCT 0 A = DELTA X OR Y IB OCT 0 B = DELTA X OR Y DELXY OCT 0 ABS(DEL X - DEL Y) L3BT OCT 7 MASK NO. OCT 0 NUMBER OF INDEX COUNT OCT 0 INDEX M1 OCT 0,0 X & Y FOR M1 M2 OCT 0,0 X & Y FOR M2 TDEL OCT 0 2DEL TDELB OCT 0 2DELB DEL OCT 0 DEL X1 OCT 0,0 X-Y COORDINATE PAIR Y1 EQU X1+1 HED SET BIT IN FILE ROUTINE * * THIS ROUTINE ACCEPTS AN INPUT POINT ON A GRAPH * (X,Y) AND TURNS THE APPROPRIATE BIT "ON" IN THE * FILE. IT ALSO UPDATES THE REQUIRED STATUS BITS * IN THE BEGINNING OF THE FILE AND ALL NECESSARY * POINTERS. * SETBT NOP SET APPROPRIATE BIT IN FILE STA X1 SAVE X-COORD STB Y1 SAVE Y-COORD * CALCULATE DESIRED RECORD NO. BRS Y/2 CMB,INB ADB J J-(Y/2) STB IRCDN INITIAL RCD. NO. FOR ERR. CK. * DO BOUNDS CHECK FOR Y LDA B PREPARE TO CHECK FOR RANGE CMA ADA FDRN FIRST DATA RECD. NO. SSA,RSS .LT.? LDB FDRN YES LDA B PICK UP DESIRED RCD. NO. CMA,INA ADA ISIZE FILE SIZE IN RECORDS SSA .GT.? LDB ISIZE YES, USE MAX FILE SIZE(RECORDS) STB DRCDN DESIRED RCD. NO. LDA B AND L4BT MASK OUT BIT NO. STA RCMBN RCD. MAP BIT NO. LDA B DESIRED RCD. NO. ARS,ARS /4 ARS,ARS /4 = 16 STA RCMWN RCD. MAP WORD NO. * DO BOUNDS CHECK ON X LDB X1 X-COORD. SSB .LT. 0 CLB YES, USE ZERO LDA B CURRENT X-COORD. CMA,INA ADA D1007 MAX. OF 63 WDS.*16 - 1 BIT SSA .GT.? LDB D1007 YES, USE MAX. X-COORD. STB DBITN SAVE DESIRED BIT NO. * CHECK IF DESIRED RCD. NO. ALREADY IN CORE LDA NUM STARTING RCD. NO. IN CORE SZA,RSS EMPTY? JMP NOTHI YES, NOTHING IN CORE LDA DRCDN DESIRED RCD. NO. CMA ADA NUM RCD. NO. IN CORE SSA,RSS .GE. JMP GETRN NO, GET DESIRED RCD. NO. LDA DRCDN DESIRED RCD. NO CMA,INA ADA LNUM LAST RCD. NO. IN CORE SSA,RSS .LE. JMP RCDOK YES, DESIRED RCD ALREADY IN CORE GETRN EQU * GET DESIRED RECORDS FROM DISC * WRITE PREVIOUS RECORD(S) FIRST JSB WRITF DEF *+6 DEF IDCB,I DESIRED FILE DEF IERR ERROR RETURN DEF IBUF,I BUFFR. ADDR. DEF ILG LENGTH IN WORDS DEF NUM RCD NO. SSA ERROR? JSB ERRPR YES NOTHI EQU * NOTHING IN CORE LDA DRCDN DESIRED RCD. NO. LDB RCDFL RECORD FLAG SZB,RSS USE MIDDLE? JMP USEMD YES SSB USE START? JMP USEST YES LDB NRIC NO. RECORDS IN CORE CMB,INB ADA B CALC. LAST RCD. IS DESIRED RCD. INA JMP USEST * MAKE THE DESIRED RCD. THE MIDDLE RCD. TO BE READ * CALC. THE MIDDLE RCD. AND BACK OFF USEMD EQU * USE MIDDLE RECORD LDA NRIC NO. RCD'S IN CORE ARS /2, FIND MIDDLE CMA,INA ADA DRCDN DESIRED RCD. NO. * CAREFUL OF SOF USEST EQU * USE STARTING RCD. STA B CHECK FOR RANGE ADA NRIC CHECK TO SEE IF READ WILL OVERSHOUT FILE CMA,INA ADA ISIZE SSA,RSS JMP RDLST LDA NRIC CMA,INA ADA ISIZE INA STA B RDLST jLDA B CMA ADA FDRN FIRST DATA REC. NO. SSA,RSS .LT.? LDB FDRN YES, USE FIRST DATA REC. NO. STB NUM SET STARTING RCD. NO. IN CORE ADB NRIC NO. RCD'S. IN CORE ADB MD1 STB LNUM SET LAST RCD. NO. IN CORE * READ THE DESIRED RECORD(S) INTO CORE JSB READF DEF *+7 DEF IDCB,I DEF IERR DEF IBUF,I DEF ILG DEF LEN DEF NUM SSA ERROR? JSB ERRPR YES LDA LEN READ STATUS CPA MD1 EOF? HLT 01 YES, ERROR. SHOULD NEVER OCCUR RCDOK EQU * RECORD(S) OK. IN CORE * CALC. STARTING ADDR. OF DESIRED ROW LDB NUM STARTING RCD. NO. IN CORE CMB,INB ADB DRCDN DESIRED RCD. NO. IN CORE BLF,BLF *256 BRS /2 = 128 WORDS/RECORD ADB IBUF START OF ROW BUFFER STB ADROW ADDR. OF DESIRED ROW NO. * UPDATE THE BIT MAP IN FIRST RECORD(S) LDB ARCMB ADDR. OF RCD. MAP BUFFER ADB RCMWN DESIRED RCD MAP WD NO. BIAS INB BIAS FOR 1ST WD. MAP SIZE LDA ABITB ADDR. OF BIT MASK TABLE ADA RCMBN DESIRED RCD MAP BIT NO. ADDR. STA TEMP ADDR. OF BIT IN BIT TABLE LDA A,I PICK UP WD. W/ DESIRED BIT AND B,I MASK BIT FROM DESIRED ADDR. SZA BIT ALREADY ON? JMP BITST YES LDA TEMP,I PICK UP DESIRED BIT IOR B,I TURN ON BIT IN BIT MAP STA B,I RESTORE IT * PREPARE TO CLEAR OUT ROW LDB ADROW ADDR. OF DESIRED ROW LDA MD128 WORDS/RECORD STA INDX1 LOOP INDEX CLA NXT0 EQU * NEXT ZERO STA B,I CLEAR OUT NEXT WORD INB BUMP POINTER TO NEXT WORD ISZ INDX1 FINISHED? JMP NXT0 NO * CALCULATE STARTING ADDR. OF DESIRED ROW NO. BITST EQU * BIT TO BE SET IN ROW LDA Y1 Y-COORD.: OF DESIRED PT. (ROW) LDB IRCDN INITIAL DESIRED RECORDNO. CPB DRCDN SAME AS DESIRED RCD. IN CORE? RSS YES CLA,INA MAKE IT LAST RCD.(ODD R.N.) LDB ADROW ADDR. OF DESIRED ROW SLA,RSS 2ND PORTION OF RECORD? ADB D64 YES, BIAS OVER TO IT STB ADROW ADDR. OF DESIRED ROW INB BIAS FOR HIGHEST BIT ACCESSED LDA DBITN X-COORD. OF DESIRED PT. (COL) ARS,ARS /4 ARS,ARS /4 = 16 BIT/WORD ADB A WORD BIAS IN DESIRED ROW LDA X1 COL. NO. AND L4BT SAVE BIT NO. IN COL. ADA ABITB ADDR. OF BIT TABLE LDA A,I PICK UP DESIRED BIT STB TEMP STORE ADDRESS LDB DMODE SZB,RSS IS MODE SET BIT? IOR TEMP,I YES - SET DESIRED BIT CPB C01 IS MODE CLEAR BIT? CMA YES - CREATE MASK CPB C01 AND TEMP,I AND CLEAR DESIRED BIT CPB C02 IS MODE COMPLIMENT BIT? XOR TEMP,I YES - COMPLIMENT DESIRED BIT STA TEMP,I RESTORE DATA LDB DBITN CURRENT X-COORDINATE INB NEXT POSSIBLE HI COL. LDA B X-COORD. (COLUMN) CMA,INA ADA ADROW,I COMPARE W/ NEXT COL. TO BE ACCESSED SSA .GT.? STB ADROW,I YES, UPDATE HI COL ACCESSED LDA X1 RETURN WITH FIXED PT. X LDB Y1 RETURN WITH FIXED PT. Y JMP SETBT,I RETURN ABITB DEF BITAB BITAB EQU * BIT TABLE OCT 100000 OCT 40000 OCT 20000 OCT 10000 OCT 4000 OCT 2000 OCT 1000 OCT 400 OCT 200 D64 OCT 100 OCT 40 D16 OCT 20 OCT 10 OCT 4 OCT 2 OCT 1 FDRN OCT 0 FIRST DATA RECD. NO. RCDFL OCT 0 RECORD FLAG DRCDN OCT 0 DESIRED RCD. NO. IRCDN OCT 0 INIT. RCD. NO. FOR ERROR CK. DBITN OCT 0 DESIRED BIT NO. L4BT OCT 17 MASK RCMBN OCT 0 RCD. MAP BIT NO. RCMWN OCT 0 RCD. MAP WORD NO. LNUM OCT 0 LAST RCD. NO. IN CORE IDCB OCT 0 FMP BUFFER FOR FILE IDCBS OCT 0 NO. OF WORDS IN IDCB IBUF OCT 0 ADDR. OF PLOT DATA NUM OCT 0 STARTING RCD. NO. IN CORE D1 DEC 1 D1007 DEC 1007 63 * 16 - 1 ARCMB OCT 0 ADDR. OF RCD. MAP BUFFER MD128 DEC -128 INDX1 OCT 0 INDEX REG. SROIC OCT 0 STARTING ROW NO. IN CORE ADROW OCT 0 ADDR. OF HIGHEST BIT ACCESSED PT * * * ERRPR NOP ERROR PROCESSING DS2040 SSA,RSS CHECK FOR FMGR ERROR (-ERROR) DS2040 JMP EPOS DS2040 * DS2040 LDB ENEG A NEGATIVE FMGR ERROR OCCURRED DS2040 STB ESIGN PUT A '-' INTO THE ERROR BUFFER DS2040 CMA,INA AND MAKE THE ERROR POSITIVE DS2040 * DS2040 EPOS CCE CONVERT THE ERROR DS2040 JSB $CVT3 NUMBER TO ASCII DS2040 INA GET PAST THE 4 DS2040 INA LEADING BLANKS FROM CONVERSION DS2040 LDB A,I PUT THE ERROR INTO DS2040 STB ERRN THE ERROR BUFFER DS2040 * DS2040 JSB EXEC OUTPUT THE ERROR STRING TO THE DS2040 DEF ERET SYSTEM CONSOLE DS2040 DEF .2 DS2040 DEF .1 DS2040 DEF EBUF DS+2040 DEF ECNT DS2040 * DS2040 ERET LDA EBLNK BLANK OUT THE SIGN DS2040 STA ESIGN DS2040 JMP ERRPR,I RETURN DS2040 * DS2040 EBUF ASC 6,SYMBR ERROR> DS2040 ESIGN NOP SIGN OF ERROR DS2040 ERRN NOP ERROR NUMBER DS2040 ECNT DEC 8 LENGTH OF ERROR BUFFER DS2040 EBLNK OCT 20040 ' ' DS2040 ENEG OCT 20055 ' -' DS2040 .1 OCT 1 DS2040 .2 OCT 2 DS2040 * DS2040 JERRP NOP JSB ERRPR JMP JERRP,I RETURN JER1 CLA,INA JSB JERRP JMP INITR JER2 LDA D2 JSB JERRP JMP INITR JER3 LDA D3 JSB JERRP JMP INITR HED WIDTH AND ROUNDING ROUTINE ERND LDA WIDT MUST BE 3 WIDE TO ROUND ADA N6 SSA JMP EXRND CLA,INA SET WIDTH INCREMENT CMA STA INCWD INA INITIALIZE THE HALF WIDTH INCREMENT FLAG STA IDUM LDA WIDT SET UP ROUNDING WIDTH STA TWID ADA INCWD STA WIDT LDA WIDH STA TWIDH CPA WIDP MAKE SURE HALF WIDTH ADA MD1 IS 1 LESS THAN FULL WIDTH ADA MD1 STA WIDH LDA WIDP STA TWIDP ADA INCWD STA WIDP CLA SET UP INCREMENT FLAG STA INCFL LDB TWID CALCULATE THE ROUNDING LENGTH LDA MDE SZA LDB TWIDP BRS CMB,INB STB CNTRQ JSB RND OUTPUT ROUNDING LDA TWID RESTORE WIDTH PARAMETERS STA WIDT LDA TWIDP STA WIDP LDA TWIDH STA WIDH EXRND JMP PLTLN,I EXIT SUBROUTINE * * BRND NOP ROUND END OF LINE LDA WIDT NO ROUNDING FOR LINES LESS THAN 3 WIDE ADA N6 SSA JMP BXRND LDA X1 SAVE CURRENT PEN POSITION LDB Y1 DST SAVEC LDB PM1 DETERMINE THE DIRECTION LDA MDE SZA LDB PM2 LDA B,I FIND X INCREMENT CMA,INA NEGATE IT STA SMDE1 SAVE IT FOR LATER INB LDA B,I FIND Y INCREMENT CMA,INA NEGATE IT STA SMDE2 AND SAVE IT LDB WIDT DETERMINE DISTANCE LDA MDE SZA TO MOVE FOR ROUNDING LDB WIDP BRS CMB,INB STB CNTRQ CMB,INB ADB C02 STB TEMPE SAVE DISTANCE CLB LDA SMDE1 CALCULATE HOW FAR TO MOVE MPY TEMPE ADA X1 FIND LOCATION STA X1 AND SAVE IT LDA SMDE2 SAME FOR Y MPY TEMPE ADA Y1 STA Y1 LDA WIDH STA TWIDH SAVE WIDTH PARAMETERS LDA WIDP STA TWIDP LDA WIDT STA TWID LDB MDE CALCULATE DOT WIDTH SZB LDA WIDP ARS STA TEMPE SLA,RSS MAKE SURE IT IS EVEN JMP OK1 CCB INA RSS OK1 CLB STB INCFL CLB,INB INITIALIZE HALF WIDTH FLAG CMB STB IDUM STA TEMPE SAVE WIDTH DECREMENT CLA,INA SET UP WIDTH INCREMENT INA STA INCWD LDA TEMPE SET OUTER WIDTH CMA,INA STA TEMPE ADA WIDT STA WIDT LDA TEMPE ADA WIDP STA WIDP ADA MD1 STA WIDH JSB RND ROUND END OF LINE DLD SAVEC RESTORE X1&Y1 STA X1 STB Y1 LDA TWID RESET WIDTH PARAMETERS STA WIDT LDA TWIDH STA WIDH LDA TWIDP STA WIDP BXRND DLD SCCOR DST SACOR CCA JMP BRND,I EXIT SUBROUTINE SMDE1 NOP SMDE2 NOP SAVEC BSS 2 SCCOR BSS 2 TEMPE NOP TWID NOP TWIDP NOP TWIDH NOP INCFL NOP INCWD NOP IDUM NOP * * RND NOP SUBROUTINE TO ROUND END OF LINE LDA X1 SAVE CURRENT POSITION LDB Y1 DST SBCOR LPQTM LDB PM1 FIND DIRECTION LDA MDE SZA LDB PM2 LDA B,I CALCULATE X COORDINATE ADA X1 STA X1 INB LOOK AT Y INCREMENT LDA B,I ADA Y1 CALCULATE Y COORDINATE STA Y1 JSB PLWD1 PLOT THIS POINT ISZ INCFL BUMP WIDTH? JMP INCHF NO, INCREMENT HALF WIDTH LDA INCWD PICKUP INCREMENT VALUE ADA WIDP AND MODIFY WIDTH STA WIDP LDA INCWD MODIFY PERPENDICULAR WIDTH TOO. ADA WIDT STA WIDT JMP CHKQ GO ON INCHF CCA SET INCREMENT FLAG STA INCFL ISZ IDUM JMP CHKQ STA IDUM LDA INCWD MODIFY HALF WIDTH ADA WIDH STA WIDH CHKQ ISZ CNTRQ CHECK TO SEE IF WE ARE THROUGH JMP LPQTM NO, GO PLOT NEXT POINT DLD SBCOR PUT BACK CURRENT POINT STA X1 STB Y1 JMP RND,I ALL DONE CNTRQ NOP * * PLTWD NOP LDA DIRLS LOOK AT LAST DIRECTION SSA IF SIGN = 1 FIRST TIME IN JSB BRND CPA MDE IS THE DIRECTION THE SAME AS LAST TIME? JMP FSTME YES NO SPECIAL HANDLING LDA X1 SAVE CURRENT PlOINT LDB Y1 DST SBCOR DLD SACOR PICK UP LAST POINT STA X1 PLOT WIDTH USING CURRENT DIRECTION STB Y1 JSB PLWD1 DLD SBCOR NOW PLOT WIDTH USING STA X1 CURRENT POINT STB Y1 FSTME JSB PLWD1 JMP PLTWD,I EXIT SUBROUTINE PLWD1 NOP LDA X1 LDB Y1 DST SACOR SAVE CURRENT PLOT POINT LDA WIDT PULL UP LINE WIDTH IN DOTS ARS DIVIDE BY 2 LDB MDE STB DIRLS SZA,RSS IF 1 DOT ONLY THEN JMP EXIT. JUST PLOT THIS POINT STA MPYR SAVE DOT OFFSET FROM CENTER LDA PM1 TAKE CURRENT LINE DIRECTION SZB LINE SEGMENT JMP DIAG GO PROCESS DIAGONAL LDB A,I INA LDA A,I CMA,INA DST JNCRQ SAVE THE LINE MOVEMENT MPY MPYR CALCULATE OFFSET CMA,INA ADA X1 STA X1 LDA JNCRQ+1 MPY MPYR CMA,INA ADA Y1 STA Y1 LDA WIDT GENERATE POINT COUNT CMA,INA STA INCRP JSB PLTDG OUTPUT PERPENDICULAR LINE JMP EXIT. EXIT SUBROUTINE PLTDG NOP LDA X1 LDB Y1 PLQ JSB SETBT SET BT ON IN MAP ISZ INCRP ARE WE DONE RSS NO, DO REST JMP EXIT YES, GET OUT LDA X1 ADA JNCRQ SSA CHECK FOR OUT OF BOUNDS JMP EXIT OUT, GO EXIT STA X1 LDB Y1 SET UP TO PLOT NEXT POINT ADB JNCRQ+1 SSB CHECK FOR OUT OF BOUNDS JMP EXIT OUT, GO EXIT STB Y1 JMP PLQ EXIT EQU * JMP PLTDG,I ALL THROUGH GOODBYE EXIT. DLD SACOR RESTORE X1 AND Y1 STA X1 STB Y1 JSB SETBT JMP PLWD1,I EXIT DIAG LDA WIDP ARS STA MPYR LDA PM2 GO ON DIAGONAL LDB A,I CALCULATE PERPINDICULAR INA LDA A,I CMA,INA DST JNCRQ  SAVE FOR PLOTING LINE MPY MPYR CALCULATE OFFSET CMA,INA ADA X1 STA X1 POINT TO OFFSET POINT LDA JNCRQ+1 CALCULATE Y OFFSET MPY MPYR CMA,INA ADA Y1 STA Y1 POINT TO OFFSET POINT DLD X1 SAVE CURRENT OFFSET POINT DST KLU LDA JNCRQ FIND OUT DIRECTION OF ADA JNCRQ+1 HALF DOT OFFSET SZA,RSS JMP XMDE SIGNS ARE THE SAME LDA Y1 SIGNS ARE DIFFERENT ADA JNCRQ MODIFY IN Y DIRECTION STA Y1 SAVE FOR HALF DOT OUTPUT JMP GOOUT GO OUTPUT HALF DOT XMDE LDA JNCRQ+1 MODIFY IN X DIRECTION CMA,INA ADA X1 STA X1 SAVE FOR HALF DOT OUTPUT GOOUT LDA WIDH GET HALF DOT COUNT CMA,INA STA INCRP SET UP OUTPUT COUNT JSB PLTDG GO OUTPUT HALF DOT LINE DLD KLU REINITIALIZE OFFSET LOCATION DST X1 LDA WIDP SET UP DOT COUNT CMA,INA STA INCRP SAVE FOR OUTPUT JSB PLTDG GO OUTPUT FULL DOT JMP EXIT. GO AWAY SACOR BSS 2 MPYR BSS 1 PM1 DEF M1 PM2 DEF M2 WIDT OCT 1 WIDP OCT 1 WIDH OCT 0 JNCRQ BSS 2 MDE BSS 1 INCRP BSS 1 DIRLS BSS 1 SBCOR BSS 2 * * CNTP NOP Z12WD NOP JSB .ENTR DEF CNTP LDA CNTP,I SSA CLA,INA SZA,RSS INA STA WIDT ADA M25 MAKE SURE WIDTH IS BETWEEN SSA 1 AND 25 JMP WIDHC THEY ARE, CALL OK LDA M25 NOT SO CMA,INA SET TO 25 STA WIDT WIDHC CLA,INA MAKE WIDTH ODD IOR WIDT STA WIDT JSB FLOAT CALCULATE DIAGONAL WIDTH FMP .707 CALCULATE .707 TIME WIDTH DST KLU SAVE VALUE TEMPORARILY JSB IFIX MAKE IT AN INTEGER STA WIDP SAVE DIAGNOL WIDTH JSB FLOAT FIND ROUND OFF DST JERR SAVE TEMPORARILY DLD KLU PICK UP FULL VYALUE FSB JERR SUBTRACT INTEGER PORTION FMP D100 PULL OUT FIRST 2 DECIMAL PLACES JSB IFIX ADA M25 >.25? LDB WIDP HALF DOT WIDTH ADB MD1 SSA,RSS LET'S SEE INB YES, ADD ANOTHER HALF DOT STB WIDH SAVE FOR LINE DRAWING SUBROUTINE ADA M25 ADA M25 >.75? SSA,RSS ISZ WIDP YES, ADD ANOTHER FULL DOT. JMP Z12WD,I GO AWAY M25 DEC -25 .707 DEC .707 D100 DEC 100. HED INIT ROUTINE * ******************************************************* * * ******INIT****** * * * CALL INIT(ILU,KEYF,IERR,FNAME,METRC,IDCB,IDCBS,LANG) * * KLU OCT 0 KEYF OCT 0 JERR OCT 0 FNAME OCT 0 METRC OCT 0 KDCB OCT 0 JDCBL OCT 0 LANG OCT 0 Z12IN NOP INITIALIZATION ROUTINE JSB .ENTR PACK ADDR. OF PARAMETERS DEF KLU LDA KLU,I PICK UP LU NO. LDB KLU PICK UP POINTER TO LU# INB POINT TO POSSIBLE CR# SSA,RSS ANY CR#? JMP NCR# NO LDA B,I PICK UP CR# STA ICR SAVE CR# INB LDA B,I SAVE SECURITY CODE STA ISECU LDA KLU,I GET LU AGAIN CMA,INA MAKE IT (+) NCR# EQU * NOT CR# STA ILU SAVE LU# LDA KDCB ADDR. OF BUFFER STA IDCB PACK LOCAL POINTER LDA JDCBL,I LENGTH OF IDCB ADA MD16 MAKE SURE LENGTH IS DEFINED PROPERLY CLB DIV D128 SOC JSB ERRPR MPY D128 ADA D16 STA IDCBS SAVE LENGTH IN LOCAL BUFFER LDA IDCB START OF FMG BUFFER ADA D16 CALC. START OF DATA PORTION STA IBUF SAVE GEN. I/O BUFF INITIALLY LDA LANG,I LANGUAGE TO BE USED STA ILANG SAVE FOR DRAW * DETERMINE THE TYPE OF INPUT FILE TO BE USED LDA KEYF,I b KEY TO FILE TYPE CPA D1 OLD FILE? JMP OLDFL YES CPA D2 DUPLICATE? JMP DUPFL YES SZA NEW? JMP JER1 NO * CALCULATE DESIRED FILE SIZE FOR NEW FILE NEWFL EQU * NEW FILE LDB KEYF POINTER TO KEYF INB POINT TO KEYF(2) LDA B,I GET NO. PAGES TO PLOT SZA,RSS INVALID? CLA,INA ZERO DEFAULTS TO +1 STA NOPGS NO. PAGES TO PLOT LDA METRC,I PAGE SIZE SSA,RSS ENGLISH? JMP DFLT? YES CMA,INA CM / PAGE JSB FLOAT FDV CMPIN CM / INCH FAD D.99 ROUND JSB IFIX UP DFLT? SZA,RSS VALUE PRESENT? LDA D11 NO, USE STD PAGE MPY NOPGS A = TOTAL # INCHES STA ISIZE STORE TEMPORARILY CLB PREPARE FOR DIVIDE DIV D55 INCHES / BIT-MAP-RECORDS SZB REMAINDER? INA YES, USE ONLY WHOLE RECORDS STA MAPSZ MAP SIZE (IN RECORDS) LDA ISIZE RELOAD TOTAL # INCHES MPY D36 BLOCKS/INCH SZB TOO MANY (>64K)? JMP JER2 YES ADA MAPSZ BIT MAP SIZE (IN RECORDS) STA ISIZE FILE SIZE IN RECORDS JSB CNFIL CREATE NEW FILE JMP INIVA INITIALIZE VARIABLES * CREATE NEW FILE * CNFIL NOP CREATE NEW FILE JSB CREAT DEF *+8 DEF IDCB,I DEF IERR DEF FNAME,I DEF ISIZE DEF ITYPE DEF ISECU DEF ICR SSA ERROR? JSB ERRPR YES, PROCESS IT JMP CNFIL,I RETURN * * OLDFL EQU * OLD FILE * OPEN EXISTING COPY FOR UPDATING JSB SOVRD ALLOW ACCESS TO ANY CRN ON SYSTEM DS2040 JSB OPEN DEF *+7 DEF IDCB,I DEF IERR DEF FNAME,I DEF IOPTN DEF ISECU DEF ICR SSA ANY ERRORS? JSB ERRPR YES JSB ROVRD REVOKE ACCESS TO ANY CRN ON SYSTEM DS2040 LDA IDCB DCB FOR THIS FILE STA ADCB PACK STATUS CALL JMP GSIZE GET SIZE OF FILE * DS2040 * ALLOW ACCESS TO ANY FILE ON THE SYSTEM DS2040 * DS2040 SOVRD EQU * DS2040 NOP DS2040 LDA OVRD. GET FILE ACCESS WORD DS2040 IOR ALLCR SET BIT 15 TO ALLOW ACCESS DS2040 STA OVRD. TO ALL CRN'S ON SYSTEM DS2040 JMP SOVRD,I DS2040 * DS2040 ALLCR OCT 100000 DS2040 * DS2040 * REVOKE ACCESS TO ANY FILE ON THE SYSTEM DS2040 * DS2040 ROVRD EQU * DS2040 NOP DS2040 LDA OVRD. GET FILE ACCESS WORD DS2040 AND LOW15 CLEAR BIT 15 TO REVOKE ACCESS DS2040 STA OVRD. TO ALL CRN'S ON SYSTEM DS2040 JMP ROVRD,I DS2040 * DS2040 LOW15 OCT 077777 DS2040 * DS2040  * DS2040 DUPFL EQU * DUPLICATE FILE FROM OLD COPY LDA FNAME ADDR. OF 1ST FILE NAME ADA D3 POINT TO 2ND NAME IN STRING STA ENAME PACK ADDR. TO EXISTING NAME * OPEN EXISTING FILE JSB OPEN DEF *+7 DEF JDCB DEF IERR ENAME OCT 0 DEF IOPTN DEF ISECU DEF ICR SSA ANY ERRORS? JSB ERRPR YES LDA AJDCB DCB POINTER FOR THIS FILE STA ADCB PACK STATUS CALL GSIZE EQU * GET SIZE OF FILE * GET FILE SIZE FROM OLD FILE JSB LOCF DEF *+7 ADCB DEF JDCB DEF IERR DEF TEMP DEF TEMP+1 DEF TEMP+2 DEF JSEC SSA ANY ERRORS JSB ERRPR YES LDA JSEC OLD FILE SIZE (IN SECTORS) ARS /2 STA ISIZE NEW SIZE (IN BLOCKS) LDA KEYF,I FILE TYPE CPA D1 EXISTING FILE? JMP REMAP YES, GO READ MAP * CREATE NEW FILE JSB CNFIL CREATE NEW FILE CLA NXRCD EQU * XFER NEXT RECORD INA BUMP RCD. NO. STA NUM SAVE IT FOR R/W * READ FROM OLD FILE JSB READF DEF *+7 DEF JDCB DEF IERR DEF IBUF,I DEF IL DEF LEN DEF NUM SSA ANY OTHER ERRORS? JSB ERRPR YES * WRITE TO NEW FILE JSB WRITF DEF *+6 DEF IDCB,I DEF IERR DEF IBUF,I DEF IL DEF NUM CPA MD12 EOF DETECTED JMP EOFDE YES SSA ANY ERRORS? JSB ERRPR YES LDA NUM RECORD NO. CPA ISIZE EOF? RSS YES JMP NXRCD XFER NEXT RECORD * CLOSE ORIGINAL FILE EOFDE EQU * JSB CLOSE DEF *+3 DEF JDCB DEF IERR SSA JSB ERRPR REMAP EQU * READ MAP LDA IDCBS TOTAL LENGTH OF /BUFFER (IN WORDS) ADA MD16 REMOVE FMP REQUIREMENTS STA ILG SAVE LENGTH OF USER BUFFER *READ MAP AND 1ST ROWS OF DATA JSB READF DEF *+7 DEF IDCB,I DEF IERR DEF IBUF,I DEF ILG DEF LEN DEF D1 SSA ANY ERRORS? JSB ERRPR YES LDA IBUF,I PICK UP MAP SIZE STA MAPSZ SAVE IT SKP * INITIALIZE VARIOUS PARAMETERS INIVA EQU * INITIALIZE VALUES LDA ILU GET LU NO. LDB ACONS POINTER TO CONSTANT AREA LDB METRC,I ENGLISH/METRIC FLAG SSB METRIC? JMP *+4 YES DLD D1.0 INCHES/INCH JMP *+3 DLD CMPIN CM./IN. DST TEMP CONV. FACTOR DLD VRES DOTS/INCH FDV TEMP INCH/"INCH" DST VRESL DOTS/"INCH" DLD HRES DOTS/INCH FDV TEMP INCH/"INCH" DST HRESL DOTS/"INCH" LDA METRC,I PICK UP PAGE SIZE SSA CMA,INA ABSOLUTE VALUE SZA,RSS VALUE PRESENT? LDA D11 NO, USE SINGLE PAGE * MPY NOPGS NO. OF PAGES JSB FLOAT TOTAL SIZE ("INCHES") FMP VRESL (ROWS/"INCH") JSB IFIX K INA K+1 ARS /2 (RECORDS OR BLOCKS) ADA MAPSZ INT((K+1)/2)+MAP SIZE STA J RCD. NO. FOR Y0 = 0 LDA MAPSZ MAP SIZE IN RECORDS MPY D128 WORDS/RECORD STA MAPSZ+1 MAP SIZE IN WORDS LDB IBUF CURRENT START OF MAP BUFFER STB ARCMB ADDR. RCD. MAP BUFFER ADA B BIAS FOR BIT MAP STA IBUF START OF ROW DATA LDA MAPSZ+1 MAP SIZE IN WORDS CMA,INA ADA IDCBS TOTAL WORDS IN BUFFER ADA MD16 FMP CONTROL WORDS STA ILG LENGTH OF DATA BUFFER SSA ENOUGH SPACE? JSB JER3 NO LDA MAPSZ MAP SIZE IN WORDS INA NEXT STARTING RECD. STA FDRN FIRST DATA RECORD NO. STA NUM STARTING RCD. NO. IN CORE * CLEAR OUT BIT MAP IF REQUIRED LDA KEYF,I FILE INFO SZA NEW FILE? JMP CONTI NO, CONTINUE INITIALIZATION LDA MAPSZ+1 MAP SIZE (IN WORDS) CMA,INA STA INDX1 PACK INDEX FOR LOOP CLA PREPARE TO CLEAR LDB ARCMB ADDR. OF RCD. MAP BUFFER CNBW EQU * CLEAR NEXT BIT-WORD STA B,I CLEAR RECORD MAP WORD INB BUMP POINTER ISZ INDX1 FINISHED? JMP CNBW NO LDA MAPSZ MAP SIZE (IN BLOCKS) STA ARCMB,I SAVE MAP SIZE IN FILE CONTI EQU * CONTINUE INITIALIZATION CLA CLEAR STA IX0 X-COORDINATE STA IY0 Y-COORDINATE STA DMODE PLOT DRAWING MODE LDA IDCBS SIZE OF USER BUFFER (IN WORDS) CLB DIV D128 WORDS/RECORD STA LNUM SAVE LAST RCD. NO. IN CORE LDB MAPSZ MAP SIZE (IN RECORDS) CMB,INB ADA B CALC. NO. RCDS. IN CORE STA NRIC SAVE NO. RECD'S IN CORE INITR JMP Z12IN,I RETURN IOPTN OCT 0 OPEN OPTION ICR DEC 0 CARTRIDGE REF. NO. DS2040 ILU OCT 0 DEV. LU # TEMP OCT 0,0,0 POSSIBLE FLOATING PT. VALUE JSEC OCT 0 OLD FILE SIZE (IN SECTORS) D55 DEC 55 D.99 DEC .99 MAPSZ OCT 0,0 MAP SIZE (IN RECORDS), (WORDS) NRIC OCT 0 NO. RECORDS IN CORE D36 DEC 36 BLOCKS/INCH IL DEC 128 RCD. LENGTH FOR TYPE 1 FILE ISIZE OCT 0 FILE SIZE (IN RECORDS) ITYPE OCT 1 TYPE 1 FILE ISECU OCT 0 SECURITY CODE ILG OCT 0 LENGTH OF BUFFER TO BE READ IERR OCT 0 ERROR RETURN LOC NOPGS OCT 0 NO. PAGES TO PLOT D2 DEC 2 D3 DEC 3 MD16 DEC -16 LEN OCT 0 NO. OF WORDS READ BY FMGR MD12 DEC -12 D1.0 DEC 1.0 D11 DEC 11 D128 DEC 128 CMPI9MN DEC 2.54 CM./INCH HED "POSTING" ROUTINE ARCM% OCT 0 IBUF% OCT 0 MAPS% OCT 0 ILG% OCT 0 NRIC% OCT 0 GIDCB NOP GET DCB INFORMATION JSB .ENTR DEF ARCM% JSB POSTI POST CURRENT BUFFERS * SET UP VALUES FOR DRAW LDA ARCMB ADDR. OF RECD. MAP BUFFER STA ARCM%,I STORE FOR DRAW LDA IBUF ADDR. OF DATA BUFFER STA IBUF%,I LDA J MAP SIZE IN RECORDS ADA MD1 EXCLUDE MAP SIZE WORD CLB DIV D16 16 RCDS./WORD SZB REMAINDER? INA YES, ADD FULL WORD STA MAPS%,I LDA ILG LENGTH OF DATA BUFFER IN WORDS STA ILG%,I LDA NRIC NO. RECORDS IN CORE STA NRIC%,I JMP GIDCB,I RETURN * * * POSTI NOP "POST ALL BUFFERS" LDA NUM STARTING RCD. NO. SZA,RSS ANYTHING IN CORE? JMP POSTE NO, RETURN *WRITE MAP TO DISC JSB WRITF DEF *+6 DEF IDCB,I DEF IERR DEF ARCMB,I DEF MAPSZ+1 DEF D1 SSA ANY ERRORS? JSB ERRPR YES PROCESS THEM * "POST" CURRENT BUFFERS JSB WRITF DEF *+6 DEF IDCB,I DEF IERR DEF IBUF,I DEF ILG DEF NUM SSA ANY ERRORS? JSB ERRPR YES CLA STA NUM CLEAR STARTING RCD. NO. STA LNUM CLEAR LAST RCD. NO. POSTE JMP POSTI,I RETURN * * * * CLOSE THE FILE Z12CL NOP CLOSE ALL FILES JSB .ENTR DEF Z12CL JSB POSTI "POST" FIRST JSB CLOSE DEF *+3 DEF IDCB,I DEF IERR SSA ANY ERRORS? JSB ERRPR YES JMP Z12CL,I RETURN * * * * DEFINE THE PLOT DRAWING MODE * * 0 => SET BIT IN FILE * 1 => CLEAR BIT IN FILE * 2 => COMPLIMENT BIT IN FILE * CMODE NOP Z12MD NOP JSB .ENTR DEF CMODE LDA CMODE,I MODE CONTROL  ADA N2 MODE - 2 SSA,RSS IS MODE .GE. 2 CLA YES - DEFAULT TO 2 ADA D2 RECONSTRUCT MODE CONTROL STA DMODE JMP Z12MD,I N2 OCT -2 DMODE OCT 0 SKP * * ****** ****** ****** * * * ****** ****** ****** * ***** WORKING STORAGE *** * * * THE FOLLOWING GROUPS OF TWO WORDS MUST BE * IN 2 CONSECUTIVE MEMORY LOCATIONS. * BUFR NOP PENC BSS 1 DEC -1 * XPEN OCT 0 PREVIOUS IX AND IY YPEN OCT 0 * IX OCT 0 X PLOT DATA FOR CURRENT CALL IY OCT 0 Y PLOT DATA FOR CURRENT CALL * J OCT 0 INT((K+1)/2)+1 (RCD. NO. FOR Y0) * * * * C01 OCT 1 C02 OCT 2 MD1 DEC -1 N3 DEC -3 N6 DEC -6 X2 BSS 2 Y2 BSS 2 * IX0 OCT 0 ORIGIN FROM FACT IY0 OCT 0 IXR OCT 0 ORIGIN RELATIVE TO IX0(FACT) IYR OCT 0 IAX1 OCT 0 ABSOLUTE POSITION OF PREVIOUS POINT IAY1 OCT 0 IAX2 OCT 0 ABSOLUTE POSITION OF CURRENT POINT IAY2 OCT 0 AJDCB DEF JDCB ADOTP OCT 0 ADDR. OF DOT PATTERNS ACONS DEF ILANG * THE FOLLOWING ORDER MUST BE PRESERRVED ILANG OCT 0 VRES DEC 72.0 DOTS/INCH (2608) HRES DEC 70.0 DOTS/INCH (2608) JDCB BSS 144 IDCB FOR 2ND FILE * END D  92840-18114 2040 S C0122 A92840 SOURCE             H0101 A92840 SOF NUM CAT REV 2040 92840-18114 MODULE DESCRIPTION DATE CODE PART NUMBER MEDIUM P/N %DCT02 9872 COMMAND TABLE 1940 92840-16005 92840-13302 %DCT03 7245A/B COMMAND TABLE 1926 92840-16006 92480-13302 %DCT08 7225A COMMAND TABLE 1913 92840-16009 92840-13302 %DCT23 7245A/B ROTATED CMND TBL 1940 92840-16020 92840-13303 %DVG01 2648A/2647A D SUB & C TBL 2013 92840-16003 92840-13302 %DVG02 7225A/7245A/9872 DEV SUB 1940 92840-16004 92840-13302 %DVG04 2608A DEV SUB & COMND TBL 2040 92840-16010 92840-13302 %DVG05 7221 DEV SUB & COMND TBL 1940 92840-16011 92840-13303 %DVG06 1350A DEV SUB & COMND TBL 2013 92840-16008 92840-13303 %DVG07 9874A DEV SUB & COMND TBL 1913 92840-16007 92840-13303 %DVZ12 2608 GRAPHICS DRIVER 2040 92840-16012 92840-13303 %GCBIM GPS CNTL BLK INTFC MOD 2013 92840-16002 92840-13302 %GPSC1 GPS COMMAND MODULES #1 2040 92840-16001 92840-13301 %GPSC2 GPS COMMAND MODULES #2 2013 92840-16021 92840-13302 &DLTBL DEV LINK TABLE SOURCE 2001 92840-18136 92840-13302 &GPSBM GPS BRANCH/MNEMONIC TBL 2013 92840-18137 92840-13302 FONT1 EUROSTYLE FONT FILE 2013 92840-16013 92840-13303 FONT2 SIMPLEX ROMAN FONT FILE 2013 92840-16014 92840-13304 FONT3 TRIPLEX ROMAN FONT FILE 2013 92840-16015 92840-13304 FONT4 SCRIPT FONT FILE 2013 92840-16016 92840-13304 FONT5 MATH SET FONT FILE 2013 92840-16017 92840-13305 FONT6 GOTHIC FONT FILE 2013 92840-16018 92840-13305   92840-18136 2001 S C0122 &DLTBL SOURCE             H0101  ASMB,R,L * * * SAMPLE DEVICE LINK TABLE * * NAME: DLTBL * SOURCE: 92840-18136 * RELOC: 92840-18136 (THERE IS NONE) * PGMR: DJS * NAM DLTBL 92840-18136 REV.2001 791101 EXT DVG01,DCT01 EXT DVG02,DCT02 EXT DVG03,DCT03 EXT DVG23,DCT23 EXT DVG04,DCT04 EXT DVG05,DCT05 EXT DVG06,DVG16,DVG26,DVG36,DCT06 EXT DVG07,DCT07 EXT DVG08,DCT08 * * DEVICE LINK TABLE FOR THE 2648A / 2647A, 9872, 7245A NORMAL, 7245A * ROTATED 90 DEGREES, 2608A, 7221, 1350A & 1310 CRT, * 1350A & 1311 CRT, 1350A & 1317 CRT, 1350A & 1321 CRT, 7225A, * AND THE 9874A. * ENT DPTR * DPTR DEC 24 NUMBER OF ENTRIES IN TABLE DEF DVG01 DEVICE SUBROUTINE FOR THE 2648A / 2647A DEF DCT01 DEVICE COMMAND TABLE FOR THE 2648A / 2647A DEF DVG02 DEVICE SUBROUTINE FOR THE 9872, 7245A, 7225A DEF DCT02 DEVICE COMMAND TABLE FOR THE 9872 DEF DVG03 DEVICE SUBROUTINE FOR THE 7245A DEF DCT03 DEVICE COMMAND TABLE FOR THE 7245A DEF DVG23 DEVICE SUBROUTINE (90 DEGREE ROTATION) FOR THE 7245A DEF DCT23 DEVICE COMMAND TABLE (90 DEGREE ROTATION) FOR THE 7245A DEF DVG04 DEVICE SUBROUTINE FOR THE 2608A DEF DCT04 DEVICE COMMAND TABLE FOR THE 2608A DEF DVG05 DEVICE SUBROUTINE FOR THE 7221 DEF DCT05 DEVICE COMMAND TABLE FOR THE 7221 DEF DVG06 DEVICE SUBROUTINE FOR THE 1350A WITH THE 1310 CRT DEF DCT06 DEVICE COMMAND TABLE FOR THE 1350A DEF DVG16 DEVICE SUBROUTINE FOR THE 1350A WITH THE 1311 CRT DEF DCT06 DEVICE COMMAND TABLE FOR THE 1350A DEF DVG26 DEVICE SUBROUTINE FOR THE 1350A WITH THE 1317 CRT DEF DCT06 DEVICE COMMAND TABLE FOR THE 1350A DEF DVG36 DEVICE SUBROUTINE FOR THE 1350A WITH THE 1321 CRT DEF DCT06 DEVICE COMMAND TABLE FOR THE 1350A DEF DVG07 DEVICE SUBROUTINE FOR THE 9874A DEF DCT07 DEVICE COMMAND TABLE FOR THE 9874A DEF DVG0B  8 DEVICE SUBROUTINE FOR THE 7225A DEF DCT08 DEVICE COMMAND TABLE FOR THE 7225A END   92840-18137 2013 S C0122 &GPSBM              H0101 } SAMPLE BRANCH AND MNEUMONIC TABLE 92840-18137 REV. 2013 800124 BTBL,MTBL,TRFL,ID=A PLOTR(IVA,I,I,I), VL, OV=0, ENT=PLOTR, FIL=%GPS78 GPON(IVA,I), VL, OV=0, ENT=GPON, FIL=%GPS78 PLOT(IVA,R,R,I), VL, OV=0, ENT=PLOT, FIL=%GPS78 MOVE(IVA,R,R), OV=0, ENT=MOVE, FIL=%GPS78 DRAW(IVA ,R,R), OV=0, ENT=DRAW, FIL=%GPS78 LIMIT(IVA,R,R,R,R), VL, OV=0, ENT=LIMIT, FIL=%GPS78 SETAR(IVA,R), VL, OV=0, ENT=SETAR, FIL=%GPS78 MARGN(IVA,R,R,R,R,I), VL, OV=0, ENT=MARGN, FIL=%GPS78 MSCAL(IVA,R,R), OV=0, ENT=MSCAL, FIL=%GPS78 SHOW(IVA,R,R,R,R), OV=0, ENT=SHOW, FIL=%GPS78 VIEWP(IVA,R,R,R,R), VL, OV=0, ENT=VIEWP, FIL=%GPS78 WINDW(IVA,R,R,R,R), OV=0, ENT=WINDW, FIL=%GPS78 CLIP(IVA,R,R,R,R), VL, OV=0, ENT=CLIP, FIL=%GPS78 AXES(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=AXES, FIL=%GPS78 LAXES(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=LAXES, FIL=%GPS78 GRID(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=GRID, FIL=%GPS78 LGRID(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=LGRID, FIL=%GPS78 LINE(IVA,I), VL, OV=0, ENT=LINE, FIL=%GPS78 LDIR(IVA,R,R), VL, OV=0, ENT=LDIR, FIL=%GPS78 LORG(IVA,I), OV=0, ENT=LORG, FIL=%GPS78 PENUP(IVA), OV=0, ENT=PENUP, FIL=%GPS78 PEN(IVA,I), OV=0, ENT=PEN, FIL=%GPS78 CPLOT(IVA,R,R,I), VL, OV=1, ENT=CPLOT, FIL=%GPS78 GCLR(IVA,I), VL, OV=1, ENT=GCLR, FIL=%GPS78 IPLOT(IVA,R,R,I), VL, OV=1, ENT=IPLOT, FIL=%GPS78 DRAWI(IVA,R,R), OV=1, ENT=DRAWI, FIL=%GPS78 MOVEI(IVA,R,R),  OV=1, ENT=MOVEI, FIL=%GPS78 FXD(IVA,I), OV=1, ENT=FXD, FIL=%GPS78 RPLOT(IVA,R,R,I), VL, OV=1, ENT=RPLOT, FIL=%GPS78 MOVER(IVA,R,R), OV=1, ENT=MOVER, FIL=%GPS78 DRAWR(IVA,R,R), OV=1, ENT=DRAWR, FIL=%GPS78 PENDN(IVA), OV=1, ENT=PENDN, FIL=%GPS78 PORG(IVA,R,R), OV=1, ENT=PORG, FIL=%GPS78 XMIT(IVA), OV=1, ENT=XMIT, FIL=%GPS78 CSIZE(IVA,R,R,R,I), VL, OV=1, ENT=CSIZE, FIL=%GPS78 GDSTT(IVA,IA,I,IVA), OV=1, ENT=GDSTT, FIL=%GPS78 GSTAT(IVA,IA,I,IVA), OV=1, ENT=GSTAT, FIL=%GPS78 GPMM(IVA,R), OV=1,REAL, ENT=GPMM, FIL=%GPS78 FRAME(IVA), OV=1, ENT=FRAME, FIL=%GPS78 LABEL(IVA,I), VL, OV=1, ENT=LABEL, FIL=%GPS78 LABON(IVA), OV=1, ENT=LABON, FIL=%GPS78 LABOF(IVA), OV=1, ENT=LABOF, FIL=%GPS78 SETUU(IVA), OV=1, ENT=SETUU, FIL=%GPS78 SETGU(IVA), OV=1, ENT=SETGU, FIL=%GPS78 CLPON(IVA), OV=1, ENT=CLPON, FIL=%GPS78 CLPOF(IVA), OV=1, ENT=CLPOF, FIL=%GPS78 WHERE(IVA,RV,RV,IV), VL, OV=1, ENT=WHERE, FIL=%GPS78 POINT(IVA,R,R,I), VL, OV=1, ENT=POINT, FIL=%GPS78 CURSR(IVA,RV,RV,IV), VL, OV=1, ENT=CURSR, FIL=%GPS78 DIGTZ(IVA,RV,RV,IV), VL, OV=1, ENT=DIGTZ, FIL=%GPS78 LGERR(IVA,I), VL, OV=1, ENT=LGERR, FIL=%GPS78 IGERR(IVA), OV=1, INTG, ENT=IGERR, FIL=%GPS78 HDERR(IVA,I), OV=1, ENT=HDERR, FIL=%GPS78 GFONT(IVA,IVA,I,I,IVA), OV=2, ENT=GFONT, FIL=%GPSŲ 78 GTEXT(IVA,IVA,I,I,IVA), VL, OV=2, ENT=GTEXT, FIL=%GPS78 GLEN(IVA,IVA,I,I,RV,RV,IVA) VL, OV=2, ENT=GLEN, FIL=%GPS78 z  92840-18138 1940 S C0122 &DCT23              H0101 ctASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT23 -- 7245A DEVICE COMMAND TABLE (VERTICAL) * SOURCE: 92840-18138 * RELOC: 92840-16020 * * * ************************************************************** * NAM DCT23,7 92840-16020 REV.1940 790726 ENT DCT23 * * EXT EXEC,TAN,COS,SIN,FLOAT EXT INDCK,INTX,GCBIM,BYTE EXT CONVT,FLTAS EXT LNGTH,GIC,DCTAD EXT .IENT EXT REIO * * * THIS IS THE DEVICE COMMAND AND EMULATOR MODULE FOR THE * HP 7245A PLOTTER/PRINTER WITH A ROTATED SURFACE AREA. * * NOTE: THIS DEVICE COMMAND TABLE IS A VARIATION ON DCT03. ALL * CHANGES DUE TO THE ROTATION OR THE INCREASED DEFAULT * SURFACE AREA ARE DULY NOTED WITH COMMENTS. * DCT23 NOP DEF EMU23 DEF RESET 1 - RESET DEVICE DEC -31 2 - SET DEFAULTS DEF PAGE 3 - FORM FEED NOP 4 DEF HOME 5 - HOME PEN DEC -23 6 - GET DEVICE ID NOP 7 - GET CAPABILITIES (NOT USED) DEC -25 8 - GET PLOT UNITS P1 AND P2 OCT -1 9 - GET CHARACTER SPACE SIZE INFORMATION DEC -29 10 - GET PEN LOCATION DEC -30 11 - GET CURSOR LOCATION OCT -2 12 - DIGITIZE DEF LORG 13 - SET LABEL ORIGIN OCT -3 14 - LABEL DIRECTION OCT -4 15 - SLANT ON DEF SLOFF 16 - SLANT OFF OCT -5 17 - SET CHARACTER SIZE OCT -6 18 - SET RELATIVE ORIGIN(PORG) NOP 19 - SET PLOT DIRECTION NOP  20 - SET SCALE NOP 21 - SET ORIGIN = CURSOR NOP 22 - SET ORIGIN = PEN NOP 23 - DRAW TO CURSOR NOP 24 - SELECT CHARACTER SET NOP 25 - SELECT PEN 0 NOP 26 - SELECT PEN -1 (ERASE) NOP 27 - SELECT PEN -2(COMPLEMENT) DEC -9 28 DEC -8 29 - GET NUMBER OF PENS NOP 30 - DEFINE LINE TYPE(NOT USED) DEC -9 31 - SELECT DEFAULT LINE TYPE DEC -9 32 - DEFAULT LINE TYPE WITH LENGTH DEF PENUP 33 - PEN UP DEF PENDN 34 - PEN DOWN DEC -26 35 - PLOT ABSOLUTE DEC -10 36 - PLOT RELATIVE DEC -27 37 - PLOT INCREMENTAL DEF SHTLB 38 - SHORT LABEL DEF STLAB 39 - START LONG LABEL DEF STPLB 40 - STOP LONG LABEL MODE DEC -11 41 - FLOAT TO ASCII DEC -12 42 - SURFACE SIZE IN MM DEC -28 43 - POSITION CURSOR NOP 44 - POSITION CURSOR RELATIVE DEC -22 45 - SET P1,P2 DEF GTMUM 46 - GET MU/MM DEC -13 47 - GET DEVICE CLEARING CHARACTERISTICS DEC -14 48 - NUMBER OF PHYSICALLY DIFFERENT PENS DEC -18 49 - NUMBER OF CURSORS DEC -15 50 - LORG-ABILITY DEC -16 51 - MAXIMUM CHARACTER SLANT DEC -17 52 - DEVICE HARD CLIPPING CAPABILITY DEC -24 53 - INQUIRE CHARACTER PLACEMENT DEC -19 54 - MIN/MAX CHARACTER CELL DEC -20 55 - LABEL DIRECTION CAPABILITY DEC -21 56 - GET LORG RANGE SKP * * ASCII COMMAND STRINGS: FIRST WORD = NUMBER OF BYTES * SECOND WORD = TERMINATOR * THIRD WORD = COMMAND STRING * * POSITIVE NUMBER OF BYTES = READ * NEGATIVE NUMBER OF BYTES = WRITE * * * NOTE: THE UPPER LEVELS OF GPS MUST BE TOLD THAT THE DEVICE HAS AN * V X AXIS OF 5.0,270.0 (200,11000 MU) AND A Y AXIS OF 5.0,180.0 * (0,7400 MU). HOWEVER, THE DEVICE MUST BE TOLD THAT IT HAS * AN X AXIS OF 180.0,5.0 (7400,200 MU) AND A Y AXIS OF 5.0,270.0 * (200,11000 MU). * * * AFTER SETTING DEFAULT VALUES RESET WINDOW FOR NEW SURFACE * AREA AND SET LABEL DIRECTION FOR ROTATION. * RESET DEC -32 DEF SEMCL ASC 17,DF;IW7400,-38800,200,51000;DI0,1 * PAGE DEC -2 DEF SEMCL PG ASC 1,PG * * THIS IS THE UPPER LEFT CORNER OF THE ROTATED SURFACE. * HOME DEC -15 DEF SEMCL ASC 8,PU;PA7400,11000 * ID DEC 2 DEF SEMCL OI ASC 1,OI * LORG DEC -2 DEF SEMCL ASC 1,LO * LNTYP DEC -2 DEF SEMCL ASC 1,LT * PENDN DEC -2 DEF SEMCL ASC 1,PD * PENUP DEC -2 DEF SEMCL ASC 1,PU * SELPN DEC -2 DEF SEMCL ASC 1,LT * STLAB DEC -2 DEF HT ASC 1,LB * STPLB DEC -1 DEF HT OCT 1400 DECIMAL 3 * SLOFF DEC -2 DEF SEMCL ASC 1,SL * STP12 DEC -2 DEF SEMCL IW ASC 1,IW * SHTLB DEC -2 DEF HT LB ASC 1,LB * GTMUM DEC 2 DEF SEMCL ASC 1,OF * HT OCT 137 SKP **************************************************************** * * UTILITY SUBROUTINES * **************************************************************** * * SETUP -- SET UP IOBUF ADDRESS, GET LUN AND DEVICE * SUBROUTINE SAVE AREA IN GCB * *--------------------------------------------------------------- * SETUP NOP JSB GCBIM RETRIEVE INFORMATION DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL ` TERMINATOR STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE JMP SETUP,I * *--------------------------------------------------------------- * INTEG -- CONVERT INCOMING DATA FROM ASCII TO INTEGER *--------------------------------------------------------------- * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I * OP ASC 1,OP * *--------------------------------------------------------------- * FIXIT *--------------------------------------------------------------- * FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * *--------------------------------------------------------------- * GB2 -- TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) * AND TRANSFER THIS DATA TO GICB * * ON ENTRY: A = GCB CODE *--------------------------------------------------------------- * GB2 NOP STA GCBCD JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF GCBCD DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * *--------------------------------------------------------------- * GB1 -- RETREIVE DATA FROM GICB AND PLACE IT IN INTX1(1) * TO INTX1(LNTH) * * ON ENTRY: A = GCB CODE *--------------------------------------------------------------- * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF GCBCD DEF .1 DEF INTX1 DEF LNTH 9 DEF .1 RTGB1 JMP GB1,I * *-------------------------------------------------------------- * FINI: 1) CONVERTS INTEGERS TO ASCII * 2) TRANSFERS THIS ASCII TO THE DEVICE * 3) RETURNS TO CALLER *-------------------------------------------------------------- * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I/O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP FIN,I * *-------------------------------------------------------------- * TRBYT -- INSERT TERMINATOR INTO THE I/O BUFFER *-------------------------------------------------------------- * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * *-------------------------------------------------------------- * PTBYT -- PUT A BYTE INTO THE I/O BUFFER * * ON ENTRY: A = BYTE TO BE SENT *-------------------------------------------------------------- * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * BITE NOP * *-------------------------------------------------------------- * UPDTE -- UPDATE BYTE COUNTER FOR I/O BUFFER *-------------------------------------------------------------- * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * *-------------------------------------------------------------- * OUTPT -- INPUT/OUTPUT OF DATA (EXEC READ/WRITE CALLS) * * ON ENTRY: A = NUMBER OF BYTES TO BE SENT *-------------------------------------------------------------- * OUTPT NOP I/O TRANSFER ROUTINE CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUYT STB RW JSB REIO DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I SKP * *************************************************************** * * EMULATORS * *************************************************************** * EMU23 NOP JSB SETUP GO GET IOBUF,IOBL,LUN AND FXD N LDA GIC CPA .177 JMP ERRCK LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA STA B LDA EM0 TOP OF LIST OF EMULATORS AND OTHER THINGS. JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE POINTER LDB LNGTH INB STB LNTH LDA A,I JMP A,I * EM0 DEF * DEF EMUL1 DEF EMUL2 DEF EMUL3 DEF EMUL4 DEF EMUL5 DEF EMUL6 DEF EMUL7 DEF EMUL8 DEF EMUL9 DEF EML10 DEF EML11 DEF EML12 DEF EML13 DEF EML14 DEF EML15 DEF EML16 DEF EML17 DEF EML18 DEF EML19 DEF EML20 DEF EML21 DEF EML22 DEF EML23 DEF EML24 DEF EML25 DEF EML26 DEF EML27 DEF EML28 DEF EML29 DEF EML30 DEF EML31 SKP * *-------------------------------------------------------------- * EMULATOR #1 (GIC 9) -- CHARACTER SPACING INFORMATION *-------------------------------------------------------------- * EMUL1 LDA .7 JSB GB1 GET CURRENT CHARACTER SIZE LDA .16 JSB GB2 JMP EMU23,I * * DEFAULT VALUES = WIDTH * 1.5 * 400 MU MM * HEIGHT * 2. * 400MU/MM * * CHRW DEC 81. CHRH DEC 324. CHW DEC -7400. DEC -11000. DEC 7400. DEC 11000. OCT 1 D1.5 DEC 1.5 D2.0 DEC 2.0 * *-------------------------------------------------------------- * EMULATOR #10 (GIC 36) -- RELATIVE PLOTTING (RPLOT(X,Y)) *-------------------------------------------------------------- * EML10 LDA .32 GET PORGX,PORGY * JSB GB1 * LDA INTX1 * STA PORGX * LDA INTX2 * STA PORGY * LDA .16 NOW GET NEW POINTS * JSB GB1 * LDA PORGX COMPUTE PORG(X,Y) + NEWPOINTS * ADA INTX2 * STA INTX2 * LDA PORGY * ADA INTX3 * IF THIS CODE IS EVER IMPLEMENTED THE SWAP * * STA INTX3 * FOR THE ROTATION HAS TO BE ADDED HERE * * LDA PA * JSB WRDST INSERT PLOT ABSOLUTE COMMAND INTO IOBUF * JSB FIN CONVERT VALUES TO ASCII AND OUTPUT JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #11 (GIC 41) -- FLOAT TO ASCII CONVERSION *--------------------------------------------------------------- * EML11 LDA .3 ETX STA TERM LDA LB JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EMU23,I * * GLIDE -- FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN F7.N DEF SKPBK RTGLD JMP GLIDE,I * *--------------------------------------------------------------- * EMULATOR #2 (GIC 12) -- DIGITIZE *--------------------------------------------------------------- * EMUL2 LDA DP DIGITIZE POINT - TURN ON ENTER LIGHT JSB PROUT EM4LP LDA OS OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF LDB .1 POINT HAS BEEN ENTERED JSB OUTPT LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER LDA INTX1 AND .4 SZA JMP GETPT BIT 2 IS SET GO GET POINT JMP EM4LP CONTINUE LOOPING UNTIL POINT IS ENTERED GETPT LDA OD OUTPUT DIGITIZED POINT JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG JSB SWAP1 * X',Y'-->Y',X'-->Y',X'(a) GIVING X,Y * LDA .16 (NEEDED FOR THE ROTATION TO WORK) JSB GB2 JMP EMU23,I * * PROUT * PROUT NOP OUTPUT ASCII COMMAND IN THE A REGISTER JSB WRDST STORE WORD IN IOBUF JSB TRBYT LDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT JMP PROUT,I * OD ASC 1,OD OS ASC 1,OS DP ASC 1,DP * * SWAP1: X',Y' --> Y',X' --> Y',(MAX X) - X' + (MIN X) * GIVING X,Y * SWAP1 NOP DLD INTX1 A = X', B = Y' SWP A = Y', B = X' * CMB,INB NEGATE X' ADB MAXX SUBTRACT X' FROM MAXIMUM X ADB MINX ADD MINIMUM X TO X' * DST INTX1 A = X = Y', B = Y = (MAX X) - X' + (MIN X) JMP SWAP1,I * *--------------------------------------------------------------- * EMULATOR #8 (GIC 29) -- NUMBER OF PENS (SIMULATED OR * OTHERWISE) *--------------------------------------------------------------- * EMUL8 LDA .6 SIMULATED PENS (LINE TYPES) STA INTX1 LDA .16 JSB GB2 JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #3 (GIC 14) -- LABEL DIRECTION * * GICB = DEGREES - 9872 WANTS RUN, RISE *--------------------------------------------------------------- * EMUL3 LDA .3 STA FXDN SET UP FOR FLOAT TO ASCII CONVERSION LDA DI ABSOLUTE DIRECTION JSB WRDST LDA .16 JSB GB1 GO GET THETA DLD INTX2 * * SINCE WE ROTATED THE SURFACE, AN OFFSET OF 1.5708 HAS TO BE * ADDED TO THE REQUESTED ANGLE. THEN A CHECK HAS TO BE DONE TO * ENSURE THE NEW VALUE IS LESS THAN 6.2832 RADIANS. * * NOTE: NO CHECK IS DONE TO DETERMINE WHETHER THE ANGLE RECEIVED * FROM THsE UPPER LEVELS OF GPS IS A MULTIPLE OF PI/2. * FAD =F1.5708 ADD THE OFFSET (1.5708) TO LDIR DST TMPVR STORE NEW VALUE IN CASE ITS < 6.2832 FSB =F6.2832 SUBTRACT NEW ANGLE FROM MAX (6.2832) SSA,RSS IF RESULT IS POSITIVE JMP CNTNU THEN CONTINUE DLD TMPVR ELSE GET THE FIRST CALCULATED VALUE * * CONTINUE LABEL DIRECTION CALCULATION AS USUAL * CNTNU DST INTX4 SAVE FOR RISE COMPUTATION JSB COS COMPUTE RUN NOP DST INTX2 EML71 JSB GLIDE CONVERT TO FLOATING POINT LDA COMA JSB PTBYT DLD INTX4 JSB SIN NOP COMPUTE RISE DST INTX2 EML72 JSB GLIDE JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP EMU23,I * TMPVR BSS 2 TEMPORARY VARIABLE FOR ROTATED LDIR * *--------------------------------------------------------------- * EMULATOR #4 (GIC 15) -- CHARACTER SLANT *--------------------------------------------------------------- * EMUL4 LDA .3 STA FXDN SET UP FOR 3 CHARACTER TO RIGHT OF . LDA SL SLANT MNEMONIC JSB WRDST LDA .16 JSB GB1 GET ANGLE DLD INTX2 JSB TAN COMPUTE TAN(THETA) NOP DST INTX2 JSB GLIDE FLOAT TO ASCII JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EMU23,I * SL ASC 1,SL * *--------------------------------------------------------------- * EMULATOR #5 (GIC 17) -- CHARACTER SIZE * * GICB = WIDTH/HEIGHT *--------------------------------------------------------------- * EMUL5 LDA .3 STA FXDN LDA .16 JSB GB1 DLD INTX4 GET HEIGHT AND SAVE DST TEMP LDA SI JSB WRDST DLD INTX2 WIDTH FDV CSIZW MU/CM/MU DST INTX2 JSB GLIDE LDA COMA JSB PTBYT DLD TEMP FDV CSIZH DST INTX2 JSB GLIDE JSB TRBYT LDB .2 LDA NBYTE JSB OUTPT JMP EMU23,I * CSIZW DEC 600. MU/CM CSIZH DEC 800. SI ASC 1,SI * *--------------------------------------------------------------- * EMULATOR #9 (GIC 28,31,32) -- LINE TYPES * * GICB = LT#, *--------------------------------------------------------------- * EMUL9 LDA .3 STA FXDN LDA .16 JSB GB1 GET DATA FROM GCB LDA LT LINE TYPE COMMAND JSB WRDST LDA INTX2 LT = 0 FOR SOLID SZA,RSS JMP FIN11 ADA LT0 GET LINE TYPE EQUIVALENCE FOR 9872 LDA A,I JSB PTBYT LDA LNGTH IS THERE A LENGTH SPECIFICATION CPA .1 JMP FIN12 FIN10 LDA INTX2 CPA .5 JMP FIN11 LDA INTX2 IOR .1 ADA PCLT0 STA TEMP ADDRESS OF PERCENT DIVIDER DLD INTX3 FDV TEMP,I DST INTX2 LDA COMA JSB PTBYT JSB GLIDE FLOAT TO ASCII FIN11 JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EMU23,I FIN12 LDA INTX2 IS LT = 1(DIM) CPA .1 JMP *+2 YES JMP FIN14 DLD D22 DST INTX3 JMP FIN10 CONTINUE FIN14 LDA COMA JSB PTBYT SET DEFAULT LINE TYPE LENGTH BACK TO 4% LDA ASC4 JSB PTBYT JMP FIN11 * * LINE TYPES AND PERCENT VALUES * LT ASC 1,LT DI ASC 1,DI LT0 DEF * LT1 OCT 61 LT2 OCT 62 LT3 OCT 63 LT4 OCT 65 LT5 OCT 60 LT6 OCT 66 * * 1% VALUES OF LINE TYPE LENGTHS * PCLT0 DEF * PCLT1 DEC 45. DEC 60. DEC 135. DEC 180. BSS 2 DEC 180. * ASC4 OCT 64 D22 DEC 22.5 * *--------------------------------------------------------------- * EMULATOR #12 (GIC 42) -- SURFACE SIZE IN MILLIMETERS *--------------------------------------------------------------- * EML12 LDA SIZMM LENGTH 1 LDB DF8 JSB GB JMP EMU23,I * SIZMM DEF SZMM * RETURN THE DESIRED SURFACE SIZE * * SZMM DEC 5.0 NOTE: X = 5.0,270.0, Y = 5.0,180.0 DEC 5.0 DEC 270.0 .819 DEC 180.0 +/- 32727 * .025 * *--------------------------------------------------------------- * EMULATOR #6 (GIC 18) -- SET RELATIVE ORIGIN *--------------------------------------------------------------- * EMUL6 LDA .16 * JSB GB1 * LDA .32 IOSAV * JSB GB2 JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #7 (GIC 26) -- ERASE = PAGE ADVANCE *--------------------------------------------------------------- * EMUL7 LDA PG JSB WRDST LDA ONE JSB WRDST LDB .2 LDA .4 JSB OUTPT JMP EMU23,I * ONE OCT 30473 * *--------------------------------------------------------------- * EMULATOR #13 (GIC 47) -- DEVICE CLEARING CAPABILITIES *--------------------------------------------------------------- * EML13 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #14 (GIC 48) -- NUMBER OF PHYSICAL PENS *--------------------------------------------------------------- * EML14 LDA DF1 LDB DF1 JSB GB JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #15 (GIC 50) -- LORGABILITY *--------------------------------------------------------------- * EML15 JMP EML14 * *--------------------------------------------------------------- * EMULATOR #16 (GIC 51) -- MAXIMUM CHARACTER SLANT *--------------------------------------------------------------- * EML16 LDA CHSLT LDB DF4 JSB GB JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #17 (GIC 52) -- DEVICE HARD CLIPPING CAPABILITY *-------------------l-------------------------------------------- * EML17 JMP EML14 * *--------------------------------------------------------------- * EMULATOR #18 (GIC 49) -- NUMBER OF CURSORS *--------------------------------------------------------------- * EML18 LDA DF0 LDB DF1 JSB GB JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #19 (GIC 54) -- MIN/MAX CHAARACTER CELL *--------------------------------------------------------------- * EML19 LDA DFCHR LDB DF9 JSB GB JMP EMU23,I * .9 DEC 9 DF9 DEF .9 DFCHR DEF CHW * *--------------------------------------------------------------- * EMULATOR #20 (GIC 55) -- LABEL DIRECTION CAPABILITY *--------------------------------------------------------------- * EML20 LDA LBLDR LDB DF3 JSB GB JMP EMU23,I * LBLDR DEF *+1 OCT 2 DEC 0. * *--------------------------------------------------------------- * EMULATOR #21 (GIC 56) -- GET LORG RANGE *--------------------------------------------------------------- * EML21 LDA DFL1 LDB DF2 JSB GB JMP EMU23,I * DFL1 DEF *+1 OCT 1 DEC 9 * *--------------------------------------------------------------- * EMULATOR #22 (GIC 45) -- SET P1 AND P2 *--------------------------------------------------------------- * EML22 LDA .16 JSB GB1 GET G1,G2 JSB SHIFT * SHIFT: X1->Y1, Y1->X2, X2->Y2, Y2->X1 * LDA IP (NEEDED FOR THE ROTATION TO WORK) JSB WRDST JSB FIN CLA STA NBYTE LDA IOBUF STA ADCNT LDA IW JSB WRDST JSB FIN JMP EMU23,I * IP ASC 1,IP * * SHIFT: X1,Y1,X2,Y2 ---> Y2,X1,Y1,X2 * SHIFT NOP DLD INTX1+1 A = X1, B = Y1 STA INTX1+2 X1 --> Y1 LDA INTX1+3 A = X2, B = Y1 * CMB,INB ADJUST X2 TO NEW ORIGIN ADB MINX ADB MAXX * STB INTX1+3 Y1 --> X2 LDB INTX1+4 A = X2, B = Y2 STA INTX1+4 X2 --> Y2 * CMB,INB ADJUST X1 TO NEW ORIGIN ADB MINX ADB MAXX * STB INTX1+1 Y2 --> X1 * JMP SHIFT,I * *--------------------------------------------------------------- * EMULATOR #23 (GIC 6) -- GET DEVICE ID *--------------------------------------------------------------- * EML23 LDA IDCD LDB DF3 JSB GB JMP EMU23,I * IDCD DEF .724A .724A ASC 3,7245A * *--------------------------------------------------------------- * EMULATOR #24 (GIC 53) -- INQUIRE CHARACTER PLACEMENT *--------------------------------------------------------------- * EML24 LDA ACINF LDB DF8 JSB GB JMP EMU23,I * ACINF DEF CINFO * CINFO DEC 0.00000 DEC 0.66667 DEC 0.00000 DEC 0.50000 * *--------------------------------------------------------------- * EMULATOR #25 (GIC 8) -- GET PLOT UNITS P1 AND P2 *--------------------------------------------------------------- * EML25 LDA .8 JSB GB1 * LDA .16 JSB GB2 * JMP EMU23,I * *--------------------------------------------------------------- * EMULATOR #26 (GIC 35) -- PLOT ABSOLUTE *--------------------------------------------------------------- * EML26 LDA .16 JSB GB1 JSB SWAP * X,Y -> Y,X -> Y(a),X GIVING X',Y' * LDA PA (NEEDED FOR THE ROTATION TO WORK) JSB WRDST JSB FIN JMP EMU23,I * PA ASC 1,PA * *--------------------------------------------------------------- * EMULATOR #27 (GIC 37) -- PLOT INCREMENTAL *--------------------------------------------------------------- * EML27 LDA .16 JSB GB1 JSB SWAP * X,Y -> Y,X -> Y(a),X GIVING X',Y' * LDA PR (NEEDED FOR THE ROTATION TO WORK) JSB WRDST JSB FIN JMP EMU23,I * PR ASC 1,PR * *-U-------------------------------------------------------------- * EMULATOR #28 (GIC 43) -- POSITION CURSOR *--------------------------------------------------------------- * EML28 LDA .16 JSB GB1 JSB SWAP * X,Y -> Y,X -> Y(a),X GIVING X',Y' * LDA PC (NEEDED FOR THE ROTATION TO WORK) JSB WRDST JSB FIN JMP EMU23,I * PC ASC 1,PC * * SWAP: X,Y --> Y,X --> (MIN X) - Y + (MAX X),X GIVING X',Y' * SWAP NOP DLD INTX1+1 A = X, B =Y SWP A = Y, B =X * CMA,INA NEGATE Y ADA MINX SUBTRACT Y FROM MINIMUM X ADA MAXX ADD MAXIMUM X TO Y * DST INTX1+1 A = X' = (MIN X) - Y + (MAX X), B = Y' JMP SWAP,I * MINX OCT 0 VALUE OF MINIMUM X MAXX OCT 16570 VALUE OF MAXIMUM X (DEC = 7544) * *--------------------------------------------------------------- * EMULATOR #29 (GIC 10) -- GET PEN LOCATION *--------------------------------------------------------------- * EML29 LDA OA JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG JSB SWAP1 * X',Y' -> Y',X' -> Y',X'(a) GIVING X,Y * LDA .16 (NEEDED FOR THE ROTATION TO WORK) JSB GB2 JMP EMU23,I * OA ASC 1,OA * *--------------------------------------------------------------- * EMULATOR #30 (GIC 11) -- GET CURSOR LOCATION *--------------------------------------------------------------- * EML30 LDA RC JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG JSB SWAP1 * X',Y' -> Y',X' -> Y',X'(a) GIVING X,Y * LDA .16 (NEEDED FOR THE ROTATION TO WORK) JSB GB2 JMP EMU23,I * RC ASC 1,RC * *--------------------------------------------------------------- * EMULATOR #31 (GIC 2) -- SET DEFAULTS *---------------------------------------------------------&------ * EML31 DLD FX1 DST INTX1 DLD FY1 DST INTX1+2 DLD FX2 DST INTX1+4 DLD FY2 DST INTX1+6 LDA .8 JSB GB2 * LDA .4 STA LNGTH *STORE NUMBER TO CONVERT DLD IX1Y1 DST INTX1+1 *PASS TO CONVERT PROC (2WORD IN) DLD IX2Y2 DST INTX1+3 LDA IP JSB WRDST JSB FIN CLA STA LNGTH JMP EMU23,I * FX1 DEC 200.0 FY1 DEC 200.0 FX2 DEC 11000.0 FY2 DEC 7400.0 * IX1Y1 DEC 7400,200 IX2Y2 DEC 200,11000 SKP * **************************************************************** * * ERROR CHECKING * **************************************************************** * ERRCK JSB EXEC SELECT DEVICE CLEAR DEF *+3 DEF .3 DEF LUN * LDA OE JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OI SEND OUT ID AND SEE IF IT FLIES JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OE JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 NOW EXAMINE STATUS WORD LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER LDA INTX1 CHECK BIT 1 AND .1 SZA,RSS JMP LAST1 LAST CHECK FOR DEVICE ERRPT LDA .3 JMP EMU23,I * LAST1 CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OI JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT * LDA IOB STA BUFAD DLD BUFAD,I CPA PART1 JMP CHEK2 JMP ERR3 CHEK2 CPB PART2 JMP OKAY ERR3 LDA .3 JMP EMU23,I OKAY LDA .7245 JMP EMU23,I * PART1 ASC 1,72 PART2 ASC 1,45 BUFAD NOP * OE ASC 1,OE .7245 DEC 7245 SKP * *--------------------------------------------------------------- * GB -- ON ENTRY: A = ADDRESS OF DATA (CONSTANTS) * B = ADDRESS OF NUMBER OF WORDS *--------------------------------------------------------------- * GB NOP STA ADDR ADDRESS OF DATA STB NUM NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 DEF .1 ADDR NOP NUM NOP DEF .2 JMP GB,I * *--------------------------------------------------------------- * WRDST -- STORE A WORD INTO THE I/O BUFFER * * ON ENTRY: A = COMMAND TO BE SENT *--------------------------------------------------------------- * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE JMP WRDST,I SKP * **************************************************************** * * CONSTANTS AND TEMPORARY STORAGE * **************************************************************** * A EQU 0 B EQU 1 NBYTE NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP IOCNT NOP TEMP BSS 2 * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .32 DEC 32 .3 OCT 3 SEMCL OCT 73 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX1 DEF INTX4 INX DEF INTX1 .7 DEC 7 TERM NOP DF3 DEF .3 .600 OCT 6000 DVCLR DEF .2 DF8 DEF .8 .8 DEC 8 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 .03 OCT 1400 COMA OCT 54 M7 OCT -7 .177 OCT 177 GCBCD NOP DF4 DEF .4 DF2 DEF .2 DF1 DEF .1 DF0 DEF .0 ADCNT NOP IBYTE NOP LNTH NOP SKPBK NOP M1 OCT -1 .6 DEC 6 .13 DEfd`C 13 END xf  92840-18139 2013 S C0122 &GFONT              H0101 ASMB,L * * * * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GFONT * SOURCE: 92840 - 18139 * RELOC: 92840 - 16021 * * * ************************************************************* NAM GFONT,7 92840-16021 REV.2013 790904 ********************************************************************* * GFONT IS THE ASMB INTERFACE FOR THE SOFTWARE TEXT * GENERATION SUBROUTINE GFONT. * *********************************************************************** ENT GFONT EXT PLTER,.OPTN,GFON1 EXT GASC1,GCHK EXT GFON3 * EXT GJUST NOT CURRENTLY IMPLEMENTED. ********************************************************************* * ENTRY POINT FOR GFONT. * CALL GFONT(IGCB,NAME,ISECU,ICR,IDCB) * CALL GFONT(IGCB,0,0,0,IDCB) ********************************************************************** IAC NOP IGCB NOP NAME NOP ISECU NOP ICR NOP IDCB NOP GFONT NOP LDA GFONT JSB .OPTN .OPTN TRANSFERS PARAMETER ADDRESSES TO BUFFER IAC DEF RTN0 DEF IAC START OF PARAMETER STORAGE AREA DEF M6 NEGATIVE NUMBER OF PARAMETERS DEF IDUMY DONT NEED AN ACTION CODE DEF D5 NUMBER OF PARAMETERS .OPTN WILL TRANSFER DEF D0 NUMBER OF OPTIONAL PARAMETERS DEF IDUMY DUMMY ADDRESS OF OPTIONAL PARAMETERS DEF RETRN .OPTN STUFFS RETURN ADDRESS INTO HERE RTN0 JMP GERR1 .OPTN'S ERROR RETURN POINT ******************************************************************** * .OPTN'S NORMAL RETURN POINT. ************************************************************** * GRAPHI  CS LINK AND CHECK FOR SUSPENDED GCB. * JSB GCHK DEF RTNA DEF IGCB,I DEF ISUSP RTNA LDA ISUSP SZA JMP RETRN,I **************************************************************** * CALL GASC1 TO TEST IF NAME IS A TEXT STRING FROM BASIC. * IF SO, BUMP THE PARAMETER ADDRESS BY 1. * JSB GASC1 DEF RTN01 DEF NAME,I DEF IBASC * RTN01 LDA IBASC SSA ISZ NAME BUMP THE ADDRESS IF THE STRING CAME FROM BASIC ***************************************************************** * CALL GFON1 TO PROCESS THE CALL. * JSB GFON1 CALL GFON1 TO PROCESS DEF RTN1 THE GFONT CALL. DEF IAC,I DEF IGCB,I DEF NAME,I DEF ISECU,I DEF ICR,I DEF IDCB,I RTN1 NOP JMP RETRN,I *************************************************************** * NOT ENOUGH PARAMETERS * GERR1 NOP NOT ENOUGH PARAMETERS. JSB PLTER DEF RTN11 DEF D95 TRANSLATES TO GPS 99 GFONT DEF IGCB * RTN11 LDA NAME,I IF NAME = 0, TURN SZA OFF SOFTWARE TEXT. JMP RETRN,I ELSE RETURN IMMEDIATELY JSB GFON3 DEF RTN21 DEF IGCB DEF IZERO RTN21 JMP RETRN,I * D95 DEC 95 IZERO DEC 0 ISUSP DEC 0 IBASC DEC 0 M6 DEC -6 IDUMY NOP D5 DEC 5 D0 DEC 0 RETRN NOP RETURN ADDRESS FOR JMP RETRN,I END GFONT H   92840-18140 2013 S C0122 &GFON1              H0101 xkFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GFON1 C SOURCE: 92840 - 18140 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GFON1(IAC,IGCB,NAME,ISECU,ICR,IDCB) +,92840-16021 REV.2013 790904 C************************************************************** C GFON1 OPENS AND VERIFIES A FONT FILE. IF IT IS A VALID FONT C FILE, GFON1 RETRIEVES THE INFORMATION ABOUT THE CHARACTER C SET FROMTHE FIRST RECORD OF THE FONT FILE AND PLACES IT INTO C THE GCB. C C NAME = NAME OF THE FONT FILE. C ISECU= SECURITY CODE OF FONT FILE. C ICR = CARTRIDGE NUMBER OF FONT FILE. C IDCB = 144-WORD DCB THAT CAN BE USED TOOPEN AND READ THE FONT FILE. C*************************************************************** INTEGER IDCB(1),IERR,INFO(1),NAME(1),ISECU,ICR C*********************************************************** C IF NAME .EQ. 0, USER IS TURNING OFF SOFTWARE TEXT. C IF (NAME .EQ. 0) GO TO 1000 C*************************************************************** C OPEN THE FONT FILE AS A TYPE 1 FILE, SHARED ACCESS. C IOPTN=5B CALL OPEN(IDCB,IERR,NAME,IOPTN,ISECU,ICR) IF (IERR .GT. 0) IERR=0 IF (IERR .LT. 0) GO TO 9000 C*************************************************************** C READ THE FIRST RECORD IN THE FILE. C CALL READF(IDCB,IERR,IDCB(17),128,LEN,1) IF (IERR .LT. 0) GO TO 9000 C*************************************************************** C VERIFY THAT ITS A FONT FILE. C IF (IDCB(144) .EQ. 177777B) GO TO 800 CALL PLTER(7,IDUMY) -  CALL GFON3(IGCB,0) RETURN C*************************************************************** C GOOD FONT FILE, TURN ON THE SOFTWARE TEXT BIT. C 800 CALL GFON3(IGCB,1) RETURN C************************************************************** C USER WANTS TO TURN OFF SOFTWARE TEXT. C 1000 CONTINUE CALL GFON3(IGCB,0) CALL CLOSE(IDCB,IERR) IF (IERR .GE. 0) RETURN C************************************************************** C ERROR POINTS. C************************************************************** C FMP ERRORS. C 9000 CONTINUE CALL PLTER(IERR-300,IDUMY) CALL GFON3(IGCB,0) RETURN END   92840-18141 2013 S C0122 &GFON3              H0101 ymFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GFON3 C SOURCE: 92840 - 18141 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GFON3(IGCB,NUMB) +,92840-16021 REV.2013 790904 C*************************************************************** C IF NUMB = 0, GFON3 SETS THE SOFTWARE TEXT BIT IN THE STATUS WORD TO 0. C IF NUMB = ANYTHING ELSE, GFON3 SETS THE SOFTWARE TEXT BIT TO 1. C*************************************************************** INTEGER IGCB(1),NUMB C*************************************************************** C SET UP THE VALUE TO IOR INTO THE STATUS WORD. C IOR=40B IF (NUMB .EQ. 0) IOR=0 C**************************************************************** C 177737B EFFECTIVELY TURNS OFF BIT 5 OF THE STATUS WORD. C THE 2 INDICATES TO WRITE INTO THE STATUS WORD. C CALL GRSTS(2,177737B,IOR) RETURN END wl  92840-18142 2013 S C0122 >EXT              H0101 ASMB,L * * * * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GTEXT * SOURCE: 92840 - 18142 * RELOC: 92840 - 16021 * * * ************************************************************* NAM GTEXT,7 92840-16021 REV.2013 790904 ********************************************************************* * GTEXT IS THE ASMB INTERFACE FOR THE SOFTWARE TEXT * GENERATION SUBROUTINE GTEXT. * * GTEXT BRANCHES ACCORDING TO WHETHER SOFTWARE OR HARDWARE TEXT IS * ENABLED. ALSO, IF SOFTWARE TEXT IS ENABLED, BUT THE USER FAILED * TO PASS IN A DCB, A FIRM ERROR IS REPORTED AND THE USER WILL STILL * GET HARDWARE TEXT. * * NOTE THAT THE CALL TO GTEX1 EXPANDS THE DCB INTO THE 16-WORD FMP PORTION * AND THE 128-WORD BUFFER PORTION STARTING AT GCB(17). * IN THIS WAY, GTEX1 ONLY KNOWS THAT IT'S GETTING A UTILITY BUFFER * THAT IT CAN USE IN ANY WAY IT CHOOSES, AND DOESN'T NEED TO KNOW * THAT IT'S PART OF THE DCB. * ********************************************************************** * ENT GTEXT EXT PLTER,.OPTN,GTEX1,GTEX2,GSOFT EXT GASC1,GCHK ******************************************************************* * ENTRY POINT FOR CALL TO GTEXT. ******************************************************************* IAC NOP ACTION PARAMETER THAT NEVER GETS USED IGCB NOP ITEXT NOP ISTRT NOP ITEXL NOP IDCB NOP DCB17 NOP DEF TO THE 128 WORD BUFFER AFTER THE DCB GTEXT NOP LDA GTEXT JSB .OPTN .OPTN TRANSFERS PARAMETER ADDRESSES TO IAC DEF RTN00 DEF IAC DEF M6 DEF IDUMY NO ACTION CODE DEF D4 NU.MBER OF REQUIRED PARAMETERS DEF D1 NUMBER OF OPTIONAL PARAMETERS DEF OPARM ADDRESS OF OPTIONAL PARAMETERS DEF RETRN .OPTN STUFFS RETURN ADDRESS INTO RETRN RTN00 JMP GERR1 ERROR RETURN POINT ************************************************************** * GRAPHICS LINK AND CHECK FOR SUSPENDED GCB. * JSB GCHK DEF RTNA DEF IGCB,I DEF ISUSP RTNA LDA ISUSP SZA JMP RETRN,I ************************************************************* * NORMAL RETURN POINT *TEST IF SOFTWARE TEXT IS CURRENTLY ENABLED. *************************************************************** * CALL GASC1 TO TEST IF ITEXT IS A BASIC STRING. IF SO, BUMP * THE ADDRESS BY 1. * JSB GASC1 DEF RTN01 DEF ITEXT,I DEF IBASC * RTN01 LDA IBASC SSA ISZ ITEXT ******************************************************************** * CALL GSOFT TO SEE IF SOFTWARE TEXT IS ENABLED. JUMP TO HARD IF NOT. * JSB GSOFT DEF RTN0 DEF IGCB,I * RTN0 SSA,RSS JMP HARD EXECUTE THIS IF A=.FALSE. ***************************************************************** * SOFTWARE TEXT GETS IMPLEMENTED HERE. * CHECK FOR THE ERROR CONDITION IN WHICH .OPTN STUFFED THE * DEFAULT VALUE IN AS THE ADDRESS FOR THE DCB (I.E. THE DCB * IS A REQUIRED PARAMETER FOR SOFTWARE TEXT.) * LDA IDCB SZA,RSS JMP GERR1 ****************************************************************** * THE DCB WAS PASSED IN BY THE USER. * DEVELOP A DEF TO IDCB(17) * LDA IDCB ADA D16 STA DCB17 * JSB GTEX1 CALL GTEX1 TO DEF RTN2 PROCESS THE CALL. DEF IGCB,I DEF ITEXT,I DEF ISTRT,I DEF ITEXL,I DEF IDCB,I DEF DCB17,I * RTN2 JMP FINIS ******************************************************************** * SOFTWARE TEXT IS ENABLED, BUT THE USER FAILED TO PASS IN A DCB. * PRINT OUT FIRM EL RROR AND GIVE HIM HARDWARE TEXT INSTEAD. * GERR1 NOP JSB PLTER DEF RTN1 DEF D96 DEF IDUMY RTN1 JMP RETRN,I ***************************************************************** * HARDWARE TEXT GETS IMPLEMENTED HERE. * HARD JSB GTEX2 DEF RTN3 DEF IGCB,I DEF ITEXT,I DEF ISTRT,I DEF ITEXL,I * RTN3 JMP FINIS ****************************************************************** * FINISH UP AND RETURN. * FINIS NOP JMP RETRN,I ******************************************************************* * ERROR HANDLER. * GERR2 NOP JSB PLTER DEF RTN22 DEF D96 DEF IGCB,I RTN22 NOP JMP RETRN,I ******************************************************************* * CONSTANTS * D16 DEC 16 M6 DEC -6 D4 DEC 4 D1 DEC 1 D96 DEC 96 TRANSLATES TO GPS 99 GTEXT IDUMY NOP OPARM NOP IBASC NOP RETRN NOP FOR THE JMP RETRN,I ISUSP NOP EQUALS 0 IF GCB NOT SUSPENDED END v  92840-18143 2013 S C0122 >EX1              H0101 aFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GTEX1 C SOURCE: 92840 - 18143 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GTEX1(IGCB,ITEXT,ISTRT,ITEXL,IDCB,IBUFR) +,92840-16021 REV.2013 791129 C**************************************************************** C GTEX1 WRITES CHARACTERS FROM ITEXT TO THE C GRAPHICS LU USING SOFTWARE GENERATED TEXT. IT OUTPUTS THE C CHARACTERS ACCORDING TO THE TRANSFORMATION IN XMTRX. C THE ONLY CONTROL CHARACTERS RECOGNIZED ARE CR AND CR-LF. C ALL ILLEGAL CHARACTERS ARE PRINTED AS @. C C IGCB = GCB TO THE GRAPHICS DEVICE. C ITEXT= BUFFER CONTAINING THE CHARS TO BE OUTPUT. C ISTRT= INDEX TO FIRST CHARACTER IN ITEXT TO BE OUTPUT. C ITEXL= + NUMBER OF CHARACTERS TO BE OUTPUT. C IDCB = A DCB OPEN TO THE FONT FILE. C IBUFR = A 128-WORD UTILITY BUFFER THAT GTEX1 CAN USE. C C XMTRX= THE TRANSFORMATION MATRIX USED TO TRANSFORM EACH CHARACTER C FROM THE FONT FILE. C C X1 AND Y1 = THE START COORDINATES OF THE CURRENT LINE. C HELD CONSTANT EXCEPT FOR CR AND CR-LF. C C INFO = LOCAL 8-WORD ARRAY HOLDING INFORMATION ABOUT THE CHARACTERS C IN THE FONT FILE. C C LEN = + CHARACTER COUNT OF NUMBER OF CHARACTERS IN ITEXT. C ISTRC= LOCAL VARIABLE THAT EQUALS ISTRT. C ITEXL2= LOCAL VARIABLE THAT EQUALS ITEXL (OR ITEXL-1 IF THERE'S C A CR-LF SUPPRESSION.) C IEND = INDEX OF THE LAST CHARACTER OF THE STRING OF INTEREST. C C NOCARR= TRUE IF THE USER REQUESTED A CR-LF SUPPRESSION. C DONE = TRUE WHEN YOU'RE DONE WITH ONE CHARACTER. C C X1 AND Y1 = CURRENT POSITION UPON ENTRY. THIS POSITION IS USED TO C ORIENT THE STRING FOR LORG PURPOSES. (X1,Y1) C IS UPDATED ONLY TO IMPLEMENT A CR-LF. C**************************************************************** INTEGER IGCB(1),ITEXT(1),ITEXL,IDCB(1),IBUFR(1) INTEGER IBUFS,INFO(9) REAL XMTRX(2,2) LOGICAL DONE,NOCARR LOGICAL GWC DATA IBUFS/128/ C************************************************************** C CHECK FOR ERROR CONDITIONS. C C IF ((ITEXL .LE. 0) .OR. (ISTRT .LE. 0)) GO TO 8500 ISTRC=ISTRT C************************************************************** C GET THE GRAPHICS LU OUT OF THE IGCB. C CALL GCBIM(2,1,LUG,0,1) C*********************************************************** C GET THE IMPORTANT INFO ABOUT THE CHARACTERS FROM THE FONT FILE C HEADER RECORD. C CALL READF(IDCB,IERR,INFO,9,LENGTH,1) IF (IERR .LT. 0) GO TO 9000 C***************************************************************** C CHECK FOR CR-LF SUPPRESSION. C CALL SGET(ITEXT,ISTRC+ITEXL-1,ICHAR) NOCARR=.FALSE. IF (ICHAR .EQ. 137B) NOCARR = .TRUE. ITEXL2=ITEXL IF (NOCARR) ITEXL2=ITEXL-1 C*************************************************************** C CHECK AND SAVE WHETHER YOU'RE IN WC SPACE OR NDC SPACE. THEN C ENABLE THE PROPER SPACE FOR ALL THE REST OF THE CALCULATIONS. C CALL GSTAT(IGCB,11,1,ICU) D WRITE(1,55) ICU D55 FORMAT(/"GTEX1: ICU = 1 FOR WC ENABLED : ",I2) IF (GWC(IGCB)) GO TO 100 C************************************************************* C SET UP EVERYTHING FOR NDC CHARACTER PLOTTING. C IUNIT=0 CALL SETGU(IGCB) GO TO 1000 C********************************************************* C SET UP EVERYTHING FOR WC PLOTTING C 100 IUNIT=1 CALL SETUU(IGCB) GO TO 1000 C*************************************************************** C SAVE THE CP TO USE LATER FOR PLACEMEHNT PURPOSES. C 1000 CALL WHERE(IGCB,X1,Y1) C************************************************************** C GET THE LENGTH OF THE LINE. GET THE LORG VALUE. C THEN ADJUST THE CP FOR THE PROPER LORG PLACEMENT. C IDCB(17) IS SET TO 100000B TO TELL GLEN1 NOT TO PRINT OUT A GPS 13 C ERROR. C IDCB(17)=100000B CALL GLEN1(IGCB,ITEXT,ISTRC,ITEXL2,DELTX,DELTY,IDCB,IDCB(17)) CALL GCBIM(21,1,LORG,0,1) CALL GPLC1(IGCB,ITEXT,X1,Y1,DELTX,DELTY,LORG) C************************************************************* C OUTPUT THE CHARACTERS ONE AT A TIME. ICHAR HOLDS THE JTH CHAR. C IEND=ISTRT+ITEXL2-1 DO 10 J=ISTRC,IEND CALL SGET(ITEXT,J,ICHAR) C*********************************************************** C GET THE CP (NDC COORDS) ABOUT WHICH TO ORIENT THIS CHARACTER. C GET A NEW XMTRX TO USE TO TRANSFORM THE CHARACTERS FROM THE C CHARACTER COORDINATE SPACE INTO THE NDC SPACE. C GET THE STROKES FOR THE CHARACTER INTO IBUFR. THEN OUTPUT C THE STROKES. YOU MAY HAVE TO GET SEVERAL BUNCHES OF STROKES C TO FINISH ONE CHARACTER. C 8 CALL WHERE(IGCB,CPX,CPY) CALL GCALC(IGCB,XMTRX,INFO,IBUFR,IUNIT) C DO 15 IREPET=1,INFO(2)/128 CALL GGET(ICHAR,IREPET,INFO,IDCB,IBUFR,IBUFS,INDEX) CALL GCHR1(IGCB,LUG,IBUFR,IBUFS,INDEX,XMTRX,CPX,CPY,DONE) IF (DONE) GO TO 30 15 CONTINUE C********************************************************* C DONE WITH THIS CHARACTER. CAN ADD CODE HERE TO PAD A C BLANK CHARACTER IF YOU WANT TO JUSTIFY THE STRING. C 30 CONTINUE 10 CONTINUE C************************************************************* C FINISHED WITH THE WHOLE STRING. REENABLE THE PROPER UNITS C AND MOVE THE CP TO THE PROPER SPOT. C CALL GPLC2(IGCB,INFO,XMTRX,X1,Y1,DELTX,DELTY,LORG,NOCARR,IBUFR) IF (ICU .EQ. 1) CALL SETUU(IGCB) RETURN C************************************************************* C ITEXL OR ISTRC .LE. 0 C 8500 CONTINUE CALL PLTER(9,IDUMY) RETURN C************************************************************* C SOME SORT OF FMP ERROR OCCURRED. C 9000 CONTINUE CALL PLTER(IERR-300,IDUMY) RETURN END b  92840-18144 2013 S C0122 >EX2              H0101 bFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GTEX2 C SOURCE: 92840 - 18144 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GTEX2(IGCB,ITEXT,ISTRT,ITEXL) +,92840-16021 REV.2013 790904 C************************************************************* C GTEX2 OUTPUTS HARDWARE CHARACTERS TO THE GRAPHICS LU OPEN C TO IGCB. C C NOTE: IF THE ISTRT CHARACTER IS NOT ON A WORD BOUNDARY, GTEX2 C SAVES THE FIRST CHARACTER AND THEN C DOES A LEFT SHIFT ON ALL THE CHARACTERS IN ITEXT TO ALIGN THEM C AT A WORD BOUNDARY. THEN THE LABON CALL IS MADE AND AN EXEC C CALL IS MADE TO OUTPUT THE CHARACTERS. (EXEC ONLY OUTPUTS C CHARACTERS ON A WORD BOUNDARY). AFTER ALL OF THIS, THE CHARACTER C STRING IS THEN RIGHT-SHIFTED BACK TO ITS ORIGINAL POSITION. C C C ITEXT = THE CHARACTERS TO BE OUTPUT. C ISTRT = INDEX OF THE FIRST CHARACTER TO BE OUTPUT. C ISTRT = LOCAL VARIABLE THAT STARTS OUT = ISTRT, THEN GETS C BUMPED AS YOU OUTPUT THE CHARACTERS IN THE SUBSRING. C ITEXL = NUMBER OF CHARACTERS TO BE OUTPUT. C FLAG = .TRUE. IF STRING STARTS ON A WORD BOUNDARY, ELSE FALSE. C************************************************************* INTEGER IGCB(1),ITEXT(1),ITEXL LOGICAL FLAG C************************************************************* C IMPLEMENT A STUB. C D LU=LOGLU(IDUMY) D WRITE(LU,1000) D1000 FORMAT("GTEX2 HIT A STUB.") C**************************************************************** C GET THE GRAPHICS LU OUT OF THE GCB. C CALL GCBIM(2,1,LUG,0,1) C***********************  ***************************************** C GET THE POSITIVE NUMBER OF CHARACTERS INTO NUMB. C IF ((ISTRT .LE. 0) .OR. (ITEXL .LE. 0)) GO TO 8500 NUMB=ITEXL ISTRC=ISTRT C*************************************************************** C BRANCH TO BELOW IF ISTRC IS ON A WORD BOUNDARY. C NOTE: FLAG IS .TRUE. IFF FIRST CHARACTER IS ON A WORD BOUNDARY. C FLAG=.TRUE. IF (MOD(ISTRC,2) .EQ. 1) GO TO 100 C************************************************************** C ISTRC IS NOT ON A WORD BOUNDARY. SAVE THE CHARACTER AT C POSITION (ISTRC-1) THEN LEFT SHIFT THE CHARACTER STRING C TO BE AT A WORD BOUNDARY. SET ISTRC TO POINT TO THE NEW C FIRST CHARACTER. C FLAG=.FALSE. CALL SGET(ITEXT,ISTRC-1,ITEMP) C DO 10 J=0,NUMB-1 CALL SGET(ITEXT,ISTRC+J,ICHAR) CALL SPUT(ITEXT,ISTRC+J-1,ICHAR) 10 CONTINUE ISTRC=ISTRC-1 C**************************************************************** C CALCULATE THE WORD BOUNDARY. C 100 IWORD=(ISTRC+1)/2 C******************************************************************* C JUST LET LABON AND LABOF HANDLE THE WHOLE TRANSACTION. C CALL LABON(IGCB) CALL REIO(2,LUG,ITEXT(IWORD),-NUMB) CALL LABOF(IGCB) C***************************************************************** C RIGHT SHIFT IT BACK IF NECESSARY. C IF (FLAG) RETURN C DO 20 J=NUMB-1,0,-1 CALL SGET(ITEXT,ISTRC+J,ICHAR) CALL SPUT(ITEXT,ISTRC+J+1,ICHAR) 20 CONTINUE CALL SPUT(ITEXT,ISTRC,ITEMP) RETURN C****************************************************************** C ITEXL OR ISTRC .LE. 0 C 8500 CONTINUE CALL PLTER(31,IDUMY) RETURN END   92840-18145 2013 S C0122 &GCALC              H0101 xoFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GCALC C SOURCE: 92840 - 18145 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GCALC(IGCB,XMTRX,INFO,BUFR,IUNIT) +,92840-16021 REV.2013 791109 C************************************************************* C GCALC CALCULATES THE TRANSFORMATION MATRIX BY WHICH TO C MULTIPLY X-Y PAIRS TO GET THE PROPER HEIGHT,WIDTH,SLANT, C AND DIRECTION OF TEXT. C C BASICALLY, GCALC CALCULATES AND RETURNS XMTRX, WHICH IS A C TRANSFORMATION MATRIX TO TRANSFORM THE CHARACTERS FROM C THE CHARACTER COORDINATE SPACE INTO CURRENT UNITS (EITHER C WC OR NDC SPACE). C C IUNIT = 1 TO RETURN XMTRX AS A WC TRANSFORM. C ELSE XMTRX IS RETURNED AS AN NDC TRANSFORM. C C C H =DESIRED CHARACTER HEIGHT. C H0 = NORMALIZED CHARACTER HEIGHT. C HMU = DESIRED CHARACTER HEIGHT IN MACHINE UNITS. C C W = DESIRED CHARACTER WIDTH. C W0 = NORMALIZED CHARACTER WIDTH. C WMU =DESIRED CHARACTER WIDTH IN MACHINE UNITS. C C BUFR= UTILITY BUFR AT LEAST 8 WORDS LONG. C C SLANT= CHARACTER SLANT IN RADIANS (POSITIVE SLANT SLANTS C CHARACTERS TO THE RIGHT.) C XLDIR = LABEL DIRECTION (POSITIVE XLDIR MOVES LINE ON WHICH C CHARACTERS ARE DRAWN COUNTERCLOCKWISE.) C C**************************************************************** C INTEGER IGCB(1),INFO(1),ICODE(2) REAL XMTRX(2,2),H0,W0,BUFR(1) REAL H,W,SLANT,XLDIR INTEGER IREAD LOGICAL GWC DATA IREAD/1/ C************************************************************** C GET THE LOGLU FOR DEBUG PURPOSES. C D LU=LOGLU(IDUMY) C************************************************************** C GET NORMALIZED WIDTH AND HEIGHT OF ENTIRE CHARACTER CELL FROM INFO. C H0=FLOAT(INFO(5)) W0=FLOAT(INFO(4)) C*************************************************************** C GET SOFTWARE HEIGHT, WIDTH, AND SLANT. (IN WC OR NDC SPACE C ACCORDING TO HOW THE USER SPECIFIED THEM IN HIS CSIZE CALL) C ICODE(1)=33 ICODE(2)=34 CALL GCBIM(ICODE,2,BUFR,0,IREAD) WMU=BUFR(1) HMU=BUFR(2) ASLANT=BUFR(3) SLANT=ASLANT C************************************************************ C TRANSFORM W AND H INTO MU'S. C IADP=11 IF (GWC(IGCB)) IADP = 12 CALL GCBIM(IADP,1,BUFR,0,IREAD) WMU=WMU*BUFR(1) HMU=HMU*BUFR(3) C********************************************************* C GET THE SOFTWARE LABEL DIRECTION(ALWAYS IN WC). C CALL GCBIM(35,1,XLDIRW,0,IREAD) C********************************************************* C TRANSFORM W AND H INTO THE REQUESTED UNITS. C IADP=11 IF (IUNIT .EQ. 1) IADP = 12 CALL GCBIM(IADP,1,BUFR,0,IREAD) W=WMU/BUFR(1) H=HMU/BUFR(3) D WRITE(LU,1305) H,W D1305 FORMAT(/"GCALC: H AND W IN NDC = ",2F13.5) C************************************************************* C BRANCH TO THE PLACE TO CONVERT THE SLANT AND THE LDIR TO C THE PROPER COORDINATE SPACE. C IF (IUNIT .EQ. 1) GO TO 2000 C************************************************************* C CONVERT THE ANGLES INTO NDC SPACE. C CONVERT LDIR FROM WC TO NDC. C CALL GANG3(IGCB,XLDIRW,XLDIR,BUFR) C C DONT TRANSFORM THE SLANT IF ITS ALREADY IN NDC. C IF (.NOT. GWC(IGCB)) GO TO 3000 CALL GANG3(IGCB,ASLANT,SLANT,BUFR) GO TO 3000 C************************************************************** C RETURN XMTRX IN WC SPACE. CONVERT THE SLANT IF NECESSARY. C 2000 CONTINUE XLDIR=XLDIRW IF (GWC(i IGCB)) GO TO 3000 CALL GANG2(IGCB,ASLANT,SLANT,BUFR) GO TO 3000 C************************************************************ C SET UP SOME CONSTANTS. C 3000 COSPHI=COS(XLDIR) SINPHI=SIN(XLDIR) TANSLA=TAN(SLANT) Q=W/W0 P=H/H0 C C************************************************************** C BUILD UP XMTRX (SEE THE IMS FOR THESE CALCULATIONS) C MULTIPLY THE Y-MULTIPLIERS IN THE MATRIX BY AR TO CORRECT C FOR DISTORTIONS INTRODUCED BY DIFFERENT ASPECT RATIOS IN NDC C SPACE. C C XMTRX(1,1)=Q*COSPHI XMTRX(2,1)=Q*SINPHI XMTRX(1,2)=P*(TANSLA*COSPHI-SINPHI) XMTRX(2,2)=P*(TANSLA*SINPHI+COSPHI) C RETURN END X  92840-18148 2013 S C0122 &GGET              H0101 PFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GGET C SOURCE: 92840 - 18148 C RELOC: 92840 - 16021 C C C CC*********************************************************** C C NOTE: ERROR 31 MUST BE DELETED FROM USE BY THE LABEL MODULE. C NOTE: 8-17-79 GGET NOW CHECKS TO MAKE SURE ICHAR IS A LEGITIMATE C CHARACTER. C SUBROUTINE GGET(ICHAR,IREPET,INFO,IDCB,IBUFR, +IBUFS,INDEX) +,92840-16021 REV.2013 791107 C************************************************************** C GGET RETURNS THE STROKES FOR CHARACTER ICHAR IN BUFFER IBUFR. C IREPET DETERMINES WHETHER GGET RETURNS THE FIRST,SECOND, THIRD C ETC SET OF STROKES FOR CHARACTERS THAT NEED MORE THAN ONE SET C OF STROKES TO WRITE. C C ICHAR = THE CHARACTER FOR WHICH YOU WANT THE STROKES(ZERO-FILLED, C RIGHT-JUSTIFIED, SAME FORMAT AS SGET PRESCRIBES). C IREPET= WHICH SET OF STROKES YOU WANT (FIRST BUNCH, SECOND BUNCH..) C C INFO = INFO ON THE CHARACTERS IN THE FONT FILE. C INDEX = RETURNED INDEX INTO IBUFR AT WHICH STROKES FOR ICHAR START. C IBUFS= SIZE OF IBUFR, INTEGRAL MULTIPLE OF 128. C C IREC1 =RECORD NUMBER AT WHICH STROKES FOR THE SPACE CHARACTER C ARE STORED. C NUMBER= NUMBER OF RECORDS USED FOR EACH CHARACTER. C C IOFF = INDEX OF ICHAR IN ASCII COLLATING SEQUENCE. C IREAD = FINAL NUMBER OF RECORD ON DISC TO READ. C C******************************************************************* C INTEGER IDCB(1),ICHAR,IREPET,INFO(1),IBUFR(1) INTEGER IBUFS,INDEX INTEGER IREC1,NUMBER INTEGER IOFF,IREAD C***************************************,  *************************** C MAKE SURE ICHAR HOLDS A LEGITIMATE CHARACTER. IF NOT, CHANGE C ICHAR TO AN @ SIGN. C IF ((ICHAR .GE. INFO(7)) .AND. +(ICHAR .LE. INFO(8))) GO TO 100 CALL PLTER(13,IDUMY) ICHAR=INFO(9) C*************************************************************** C GET THE RECORD NUMBER OF THE SPACE CHARACTER, AND THE NUMBER C OF WORDS USED TO STORE ONE SET OF CHARACTER STROKES. C 100 IREC1=INFO(1) NUMBER=INFO(2) C*************************************************************** C GET THE INDEX OF ICHAR INTO IOFF. C IOFF=ICHAR-INFO(7) C************************************************************** C CALCULATE THE RECORD NUMBER ON THE DISC TO READ. C IREAD=IREC1+IOFF*(NUMBER/128)+(IREPET-1)*(IBUFS/128) C************************************************************** C READ THE RECORD AND RETURN C CALL READF(IDCB,IERR,IBUFR,IBUFS,LEN,IREAD) IF (IERR .LT. 0) GO TO 9000 INDEX=1 RETURN C************************************************************* C HAD A BAD READ OFF THE DISC FILE. C 9000 CONTINUE CALL PLTER(IERR-300,IRTN) RETURN END x   92840-18149 2013 S C0122 &GCHR1              H0101 dFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GCHR1 C SOURCE: 92840 - 18149 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GCHR1(IGCB,LUG,IBUFR,IBUFS,INDEX,XMTRX, +CPX,CPY,DONE) +,92840-16021 REV.2013 791210 C************************************************************** C GCHR1 DRAWS ONE CHARACTER ONTO LUG ACCORDING TO THE CHARACTER C STROKES STORED IN BUFFER IBUFR STARTING AT WORD INDEX. C C IBUFR = BUFFER THAT HOLDS THE STROKES TO BE MADE. C INDEX= FIRST WORD IN IBUFR TO START DRAWING THE STROKES AT. C IBUFS= TOTAL WORD-LENGTH OF IBUFR. C C XMTRX= TRANSFORMATION XMTRX FOR THIS CHARACTER TO DO SLANTS, C CHANGE ASPECT RATIO, ETC. C C CPX AND CPY = THE CURRENT POINTER IN WC USED TO ORIENT THIS CHAR. C C DONE = LOGICAL FLAG SET TO TRUE WHEN THE LAST STROKE OF A CHARACTER C HAS BEEN DRAWN (ALLOWS STROKES FOR A CHARACTER TO CROSS OVER C MULTIPLE BUFFERS.) C*************************************************************** C INTEGER IGCB(1),LUG,IBUFR(1),IBUFS,INDEX REAL XMTRX(2,2),CPX,CPY LOGICAL DONE C*************************************************************** C CHECK THAT THE INDEX IS VALID. C C************************************************************ C DRAW THE CHARACTER STROKES. C IF IX=64, ITS A CONTROL PAIR WHERE IY DETERMINES THE TYPE OF CONTROL. C OTHERWISE, ITS AN X-Y PAIR TO WHICH TO MOVE. C C THE FORMAT FOR AN X-Y PAIR FOLLOWS: (BIT 15 = SIGN(X), BIT 6=SIGN(Y) C ------------------------------------------------- C 15 14 13 112 11 10 09 08 07 06 05 04 03 02 01 00 C +- X X X X X X +- Y Y Y Y Y Y C-------------------------------------------------- DO 20 J=INDEX,IBUFS,1 IX=IBUFR(J)/256 IY=IAND(IBUFR(J),177B) IF (IY .GE. 64) IY=64-IY C D WRITE(13,1374) J,IX,IY D1374 FORMAT("GCHR1: J,IX,IY = ",3I6) C IF (IX .EQ. 64) GO TO 10 IF ((IABS(IX) .GT. 63) .OR. + (IABS(IY) .GT. 63)) GO TO 9200 X=FLOAT(IX) Y=FLOAT(IY) C C****************************************************************** C TRANSFORM THE X-Y PAIR BY XMTRX, ADD IN THE CURRENT POINTER. C X1=XMTRX(1,1)*X+XMTRX(1,2)*Y+CPX Y1=XMTRX(2,1)*X+XMTRX(2,2)*Y+CPY C D WRITE(13,3456) X1,Y1 D3456 FORMAT("GCHR1: X1 AND Y1 = ",2F13.6,//) C CALL PLOT(IGCB,X1,Y1,IPEN) GO TO 20 C***************************************************************** C HAVE A CONTROL PAIR. Y HAS THE FOLLOWING MEANINGS: C IY < 0 IMPLIES HAVE A BAD X-Y PAIR OFF THE DISC. C = 0 IMPLIES LIFT THE PEN. C = 1 IMPLIES LOWER THE PEN. C = 2 IMPLIES DONE WITH THIS CHARACTER. C > 2 IMPLIES BAD X-Y PAIR OFF THE DISC. C 10 IF (IY) 9200,100,15 15 GO TO (200,300,9200) IY C*************************************************************** C IY=0 SIGNIFIES LIFT PEN. C 100 IPEN=-2 GO TO 20 C*************************************************************** C IY=1 SIGNIFIES LOWER PEN. C 200 IPEN=-1 GO TO 20 C*************************************************************** C IY=2 SIGNIFIES DONE. C 300 CONTINUE DONE=.TRUE. RETURN C************************************************************** C END OF PROCESSING CURRENT X-Y PAIR. CONTINUE THE DO LOOP. C 20 CONTINUE C********************************************************** C PROCESSED ALL THE STROKES IN THE CURRENT BUFFER. SET THE C DONE FLAG TO FALSE AND RETURN. C DONE=.FALSE. RETURN C********************************* **************************** C ERROR PROCESSING. C C************************************************************** C ERROR ON READF CALL. C 9100 CALL PLTER(IERR-300,IDUMMY) RETURN C************************************************************ C FAULTY X-Y PAIR FROM THE DISC. C 9200 CALL PLTER(38,IDUMMY) RETURN END /  92840-18151 2013 S C0122 &GANG2              H0101 mlFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GANG2 C SOURCE: 92840 - 18151 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GANG2(IGCB,AMU,AWC,BUFR) +,92840-16021 REV.2013 791128 C************************************************************** C GANG2 CONVERTS AN MU ANGLE INTO A WC ANGLE. C C AMU = ANGLE IN MACHINE UNIT RADIANS. C AWC = ANGLE IN WORLD COORDINATE RADIANS. (RETURNED) C BUFR = MINIMUM 8-WORD UTILITY BUFFER. C************************************************************** INTEGER IGCB(1) REAL AMU,AWC,BUFR(1) REAL PI INTEGER IREAD DATA PI/3.14159/ DATA IREAD/1/ C*********************************************************** C GET THE LENGTHS IN MU UNITS. C XMU=COS(AMU) YMU=SIN(AMU) C********************************************************** C GET THE CONVERSION FACTORS. C 20 CONTINUE CALL GCBIM(12,1,BUFR,0,IREAD) C**************************************************************** C CONVERT TO WC UNITS. C YWC=YMU/BUFR(3) XWC=XMU/BUFR(1) C**************************************************************** C TAKE THE ARCTAN TO GET THE WC ANGLE. C AWC=ATAN2(YWC,XWC) RETURN END E  92840-18152 2013 S C0122 &GANG3              H0101 nmFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GANG3 C SOURCE: 92840 - 18152 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GANG3(IGCB,AWC,AMU,BUFR) +,92840-16021 REV.2013 791129 C************************************************************** C GANG3 CONVERTS A WC ANGLE INTO AN MU ANGLE. C C AMU = ANGLE IN MACHINE UNIT RADIANS. C AWC = ANGLE IN WORLD COORDINATE RADIANS. (RETURNED) C BUFR = MINIMUM 8-WORD UTILITY BUFFER. C************************************************************** INTEGER IGCB(1) REAL AWC,AMU,BUFR(1) REAL PI INTEGER IREAD DATA PI/3.14159/ DATA IREAD/1/ C************************************************************ C CALCULATE THE ANGLE IN WORLD COORDINATES. THE ALGORITHM C IS AS FOLLOWS: C XWC=COS(AWC) YWC=SIN(AWC) C********************************************************* C GET THE CONVERSION FACTORS. C 20 CONTINUE CALL GCBIM(12,1,BUFR,0,IREAD) C**************************************************************** C CONVERT TO MU UNITS. C XMU=XWC*BUFR(1) YMU=YWC*BUFR(3) C**************************************************************** C TAKE THE ARCTAN TO GET THE MU ANGLE. C AMU=ATAN2(YMU,XMU) D WRITE(1,1005) XMU,YMU,AWC,AMU D1005 FORMAT(/"GANG3: XMU,YMU = ",2F9.5," AWC AND AMU = ",2F13.5) RETURN END -    92840-18153 2013 S C0122 &GLEN              H0101 QASMB,L * * * * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GLEN * SOURCE: 92840 - 18153 * RELOC: 92840 - 16021 * * * ************************************************************* NAM GLEN,7 92840-16021 REV.2013 790904 ******************************************************* * GLEN IS THE ASMB INTERFACE FOR THE GLEN SUBROUTINE OF * THE STROKE GENERATED CHARACTER PACKAGE. * GLEN VERIFIES THE PROPER NUMBER OF PARAMETERS HAS BEEN * PASSED IN, THEN CALLS GTEXM TO PROCESS THE ACTUAL CALL. ********************************************************** ENT GLEN EXT .OPTN,PLTER,GSOFT,GLEN1,GLEN2 EXT GASC1,GCHK ********************************************************* IAC NOP IGCB NOP ITEXT NOP ISTRT NOP ITEXL NOP DELTX NOP DELTY NOP IDCB NOP DCB17 NOP POINTER INTO IDCB(17) GETS STUFFED HERE GLEN NOP LDA GLEN JSB .OPTN DEF RTN00 DEF IAC DEF M8 DEF IDUMY NO ACTION CODE DEF D6 NUMBER OF REQUIRED PARAMETERS DEF D1 NUMBER OF OPTIONAL PARAMETERS DEF OPARM ADDRESS OF OPTIONAL PARAMETER DEF RETRN .OPTN STUFFS RETURN ADDRESS HERE RTN00 JMP GERR3 ******************************************************************** * NORMAL RETURN FROM .OPTN ************************************************************** * GRAPHICS LINK AND CHECK FOR SUSPENDED GCB. * JSB GCHK DEF RTNA DEF IGCB,I DEF ISUSP RTNA LDA ISUSP SZA JMP RETRN,I ****************************************************************** * SEE IF ITEXT CAME wFROM BASIC. * JSB GASC1 DEF RTN01 DEF ITEXT,I DEF IBASC * RTN01 LDA IBASC SSA ISZ ITEXT BUMP THE ADDRESS IF THE STRING IS FROM BASIC ********************************************************************* * CALL GSOFT TO SEE IF SOFTWARE TEXT IS ENABLED. * BRANCH TO HARD IF HARDWARE TEXT IS ENABLED. * JSB GSOFT DEF RTN0 DEF IGCB,I * RTN0 SSA,RSS JMP HARD EXECUTE THIS IF SIGN A=0 ********************************************************************** * RETURN THE SOFTWARE LENGTH OF THE TEXT STRING. MAKE SURE THE USER * PASSED IN A DCB. * LDA IDCB SZA,RSS JMP GERR3 EXECUTE THIS IF A=0 *************************************************************** * DEVELOP A DEF TO DCB(17) SO YOU CAN USE THE END OF THE DCB * AS A UTILITY BUFFER. * LDA IDCB ADA D16 STA DCB17 * JSB GLEN1 DEF RTN1 DEF IGCB,I DEF ITEXT,I DEF ISTRT,I DEF ITEXL,I DEF DELTX,I DEF DELTY,I DEF IDCB,I DEF DCB17,I * RTN1 NOP JMP FINIS ******************************************************************* * HARDWARE TEXT LENGTH GETS RETURNED HERE. ******************************************************************** HARD NOP JSB GLEN2 DEF RTN2 DEF IGCB,I DEF ITEXT,I DEF ISTRT,I DEF ITEXL,I DEF DELTX,I DEF DELTY,I RTN2 NOP JMP FINIS *********************************************************************** * RESET ALL THE PARAMETERS TO 0 *********************************************************************** FINIS NOP JMP RETRN,I ******************************************************************* * NOT ENOUGH PARAMETERS. ******************************************************************* GERR3 NOP JSB PLTER DEF RTN22 DEF D97 DEF IDUMY RTN22 NOP JMP RETRN,I ************e[ ************************************************ * CONSTANTS * D16 DEC 16 D97 DEC 97 IDUMY NOP IBASC NOP M8 DEC -8 D6 DEC 6 D1 DEC 1 RETRN NOP OPARM NOP ISUSP NOP EQUALS 0 IF GCB NOT SUSPENDED END .,  92840-18154 2013 S C0122 &GLEN1              H0101 bFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GLEN1 C SOURCE: 92840 - 18154 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GLEN1(IGCB,ITEXT,ISTRT,ITEXL,DELTX,DELTY,IDCB,IBUFR) +,92840-16021 REV.2013 791107 C************************************************************ C GLEN1 RETURNS THE SOFTWARE LENGTH OF THE TEXT STRING C IN ITEXT. C C ITEXT = BUFFER CONTAINING THE CHARACTER STRING. C ISTRT = INDEX OF FIRST CHARACTER IN THE SUBSTRING WHOSE C LENGTH IS DESIRED. C ITEXL = CHARACTER COUNT OF THE ENTIRE STRING THAT CONTAINS C THAT CONTAINS THE SUBSTRING. C DELTX = RETURNED DELTA X THAT WOULD OCCUR IF ITEXT WERE OUTPUT C ACCORDING TO THE CURRENT CHARACTER SIZE, LDIR, ETC. C DELTY = RETURNED DELTA Y THAT WOULD OCCUR IF ITEXT WERE OUTPUT C IDCB = DCB THAT'S OPEN TO THE FONT FILE. C IBUFR = MINIMUM 128 WORD UTILITY BUFFER. C C 11-07-79 THIS SUBR NOW CHECKS TO SEE WHETHER IT SHOULD PRINT OUT C A GPS 13 ERROR WHEN AN ILLEGAL CHARACTER IS ENCOUNTERED. C C IF IBUFR(1) .EQ. 100000B GLEN1 DOESNT PRINT OUT A GPS 13 ERROR C************************************************************** INTEGER IGCB(1),ITEXT(1),ITEXL,IDCB(1),IBUFR(1) REAL DELTX,DELTY LOGICAL SKIP C REAL XMTRX(2,2) INTEGER INFO(9) C************************************************************* C 4-26-79 IMPLEMENT A STUB. C D LU=LOGLU(IDUMY) D WRITE(LU,1000) D1000 FORMAT(/"GLEN1: ENTERING GLEN1.") C*********************************************************** C SET THE SKIPے FLAG ACCORDING TO THE VALUE IN IBUFR(1) C SKIP=.FALSE. IF (IBUFR(1) .EQ. 100000B) SKIP = .TRUE. C************************************************************* C GET THE POSITIVE CHARACTER COUNT OF THE CHARACTERS IN ITEXT. C IF ((ISTRT .LE. 0) .OR. (ITEXL .LE. 0)) GO TO 8500 ISTRC=ISTRT C************************************************************ C READ IN INFO FROM THE FONT FILE. C CALL READF(IDCB,IERR,INFO,9,LEN,1) IF (IERR .LT. 0) GO TO 8000 C********************************************************* C CALL GCALC TO CALCULATE THE TRANSFORMATION MATRIX. C (NOTE: GCALC DESTROYS THE DATA IN IBUFR.) C (NOTE: IUNIT = 0 TO GET AN NDC XMTRX, C = 1 TO GET A WC XMTRX) C IUNIT=IADCD(IDUMY)-11 CALL GCALC(IGCB,XMTRX,INFO,IBUFR,IUNIT) C**************************************************************** C SEE IF THERE'S AN UNDERSCORE AS THE LAST CHARACTER. IF SO, IGNORE IT. C CALL SGET(ITEXT,ISTRT+ITEXL-1,ICHAR) ITEXL2=ITEXL IF (ICHAR .EQ. 137B) ITEXL2=ITEXL2-1 C******************************************************** C IF YOU DON'T HAVE A WIDTH TABLE, JUMP DOWN BELOW AND JUST C USE THE STANDARD WIDTH. IF YOU DO HAVE A WIDTH TABLE, ADD C UP THE INDIVIDUAL WIDTHS FOR EACH CHARACTER. C ITBL=INFO(6) IF (ITBL .EQ. 0) GO TO 2000 C********************************************************* C ADD UP THE WIDTHS OF EACH INDIVIDUAL CHARACTER. C IWIDE=0 IEND=ISTRC+ITEXL2-1 DO 1500 J=ISTRC,IEND CALL SGET(ITEXT,J,ICHAR) IF ((ICHAR .GE. INFO(7)) .AND. +(ICHAR .LE. INFO(8))) GO TO 1550 ICHAR=INFO(9) IF (SKIP) GO TO 1550 CALL PLTER(13,IDUMY) C************************************************************** C READ IN THE APPROPRIATE PART OF THE WIDTH TABLE. C 1550 CONTINUE IOFF=ICHAR-INFO(7)+1 IREC1=IOFF/128 INDEX=MOD(IOFF,128) C CALL READF(IDCB,IERR,IBUFR,128,LEN,ITBL+IREC1) IF (IERR . LT. 0) GO TO 8000 C IWIDE=IWIDE+IBUFR(INDEX) 1500 CONTINUE GO TO 3000 C********************************************************** C NO WIDTH TABLE. USE STANDARD VALUES. C 2000 CONTINUE IWIDE=ITEXL2*INFO(4) GO TO 3000 C******************************************************** C IWIDE NOW CONTAINS THE TOTAL LENGTH OF THE CHARACTERS IN C CHARACTER COORDINATES. C MULTIPLY BY THE XMTRX VALUES TO C GET THE CURRENT UNIT VALUES TO RETURN TO THE USER. C 3000 CONTINUE XWIDE=FLOAT(IWIDE) DELTX=XMTRX(1,1)*XWIDE DELTY=XMTRX(2,1)*XWIDE D WRITE(LU,3005) DELTX,DELTY D3005 FORMAT(/"GLEN1: DELTX AND DELTY = ",2F9.5) RETURN C********************************************************* C FMP ERROR POINT. C 8000 CONTINUE CALL PLTER(IERR-300,IDUMY) RETURN C********************************************************* C ITEXL OR ISTRT .LE. 0 C 8500 CONTINUE CALL PLTER(9,IDUMY) RETURN END   92840-18155 2013 S C0122 &GLEN2              H0101 cFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GLEN2 C SOURCE: 92840 - 18155 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GLEN2(IGCB,ITEXT,ISTRT,ITEXL,DELTX,DELTY) +,92840-16021 REV.2013 790904 C************************************************************ C GLEN2 RETURNS THE HARDWARE LENGTH OF THE TEXT STRING C IN ITEXT. THE LENGTH OF THE STRING IS DEFINED TO BE THE C LENGTH OF ALL CHARACTERS UP TO BUT NOT INCLUDING THE FIRST C CARRIAGE RETURN. C C ITEXT = BUFFER CONTAINING THE CHARACTER STRING. C ITEXL = + WORD COUNT OR - CHARACTER COUNT OF ITEXT. C DELTX = RETURNED DELTA X THAT WOULD OCCUR IF ITEXT WERE OUTPUT C ACCORDING TO THE CURRENT CHARACTER SIZE, LDIR, ETC. C DELTY = RETURNED DELTA Y THAT WOULD OCCUR IF ITEXT WERE OUTPUT C************************************************************** INTEGER IGCB(1),ITEXT(1),ITEXL REAL DELTX,DELTY C REAL BUFR(4) C************************************************************* C 4-26-79 IMPLEMENT A STUB. C D LU=LOGLU(IDUMY) D WRITE(LU,1000) D1000 FORMAT(/"GLEN2: ENTERING GLEN2.") C************************************************************ C GET THE POSITIVE CHARACTER COUNT INTO NUMB. C IF ((ITEXL .LE. 0) .OR. (ISTRT .LE. 0)) GO TO 8500 C************************************************************* C CNUMB HOLDS THE REAL NUMBER OF CHARACTERS IN THE STRING. C CNUMB=FLOAT(ITEXL) C************************************************************* C GET THE MU WIDTH OF AN INDIVIDUAL CHARACTER C CALLj   GCBIM(7,1,BUFR,0,1) WIDTH=BUFR(1) C************************************************************* C GET THE LENGTH OF THE SUBSTRING. C CLEN=CNUMB*WIDTH C************************************************************ C TRANSFORM IT BY THE CURRENT LDIR. C GET THE CURRENT LDIR (IN WC) C CALL GCBIM(22,1,BUFR,0,1) THETA=BUFR(1) C*************************************************************** C CONVERT THETA TO MU'S. C AMU GETS RETURNED AS LDIR IN MACHINE UNITS. C CALL GANG3(IGCB,THETA,AMU,BUFR) C************************************************************ C FIGURE DELTX AND DELTY BASED ON THE LENGTH OF THE STRING C AND THE LDIR. C XMU=CLEN*COS(AMU) YMU=CLEN*SIN(AMU) C********************************************************* C CONVERT TO CURRENT UNITS. C CALL GCBIM(IADCD(DUMY),1,BUFR,0,1) C DELTX=XMU/BUFR(1) DELTY=YMU/BUFR(3) RETURN C************************************************************** C FIRST CHARACTER IN ITEXT IS A CR. C 7000 DELTX=0.0 DELTY=0.0 RETURN C************************************************************* C ITEXL OR ISTRT .LE. 0 C 8500 CALL PLTER(9,IDUMY) RETURN END F   92840-18156 2013 S C0122 &GSOFT              H0101 FTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GSOFT C SOURCE: 92840 - 18156 C RELOC: 92840 - 16021 C C C CC*********************************************************** LOGICAL FUNCTION GSOFT(IGCB) +,92840-16021 REV.2013 790904 C*************************************************************** C GSOFT IS SET TO .TRUE. IF SOFTWARE TEXT IS CURRENTLY ENABLED, C OTHERWISE GSOFT IS SET TO .FALSE. C*************************************************************** INTEGER IGCB(1) C*************************************************************** C ESTABLISH A LINK TO THE GRAPHICS PACKAGE. C (THIS STORES THE ADDRESS OF THE GCB INTO AN INTERNAL LOCATION C INSIDE ABSAD.) C ISUSP=0 CALL GCBIM(99,1,IGCB,ISUSP) IF (ISUSP .NE. 0) RETURN C*************************************************************** C CALL GRSTS TO LOOK AT BIT 5 IN THE GCB. C NMASK RETURNS WITH BIT 5=0 IF SOFTWARE TEXT IS OFF, C =1 IF SOFTWARE TEXT IS ON. C CALL GRSTS(1,40B,NMASK) GSOFT=.TRUE. IF (NMASK .EQ. 0) GSOFT=.FALSE. RETURN END ]4  92840-18157 2013 S C0122 &GPLC1              H0101 ~iFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GPLC1 C SOURCE: 92840 - 18157 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GPLC1(IGCB,ITEXT,X1,Y1,DELTX,DELTY,LORG) +,92840-16021 REV.2013 790904 C************************************************************** C GPLC1 ADJUSTS THE CP AT (X1,Y1) IN ORDER TO IMPLEMENT C THE LORG CAPABILITY. BASICALLY, IT MOVES THE CP THE PROPER C AMOUNT SO THAT THE STRING IS PLACED PROPERLY FOR LEFT OR C RIGHT JUSTIFICATION, AND ALSO BOTTOM, CENTER, OR TOP C JUSTIFICATION. C C THE ALGORITHM WORKS LIKE THIS. FIRST OF ALL, THE CHARACTER HEIGHT C IS FOUND. THEN WE CALCULATE THE FOLLOWING VALUES: C C CX = DISTANCE THE CP MUST BE MOVED IN THE X DIRECTION TO ACCOUNT C FOR THE CURRENT CHARACTER HEIGHT (REMEMBERING LORG AND LDIR) C CY = DISTANCE THE CP MUST BE MOVED IN THE Y DIRECTION TO ACCOUNT C FOR THE CURRENT CHARACTER HEIGHT (REMEMBERING LORG AND LDIR) C C DX = DISTANCE THE CP MUST BE MOVED IN THE X DIRECTION TO ACCOUNT C FOR THE CURRENT LINE LENGTH (BASED ON LORG ONLY, THE LDIR C WAS ALREADY TAKEN INTO ACCOUNT BEFORE IT WAS PASSED IN). C DY = DISTANCE THE CP MUST BE MOVED IN THE Y DIRECTION TO ACCOUNT C FOR THE CURRENT LINE LENGTH (BASED ON LORG ONLY). C C C (X1,Y1) = CURRENT POSITION C DELTX = AMOUNT THE CURRENT STRING WOULD MOVE THE CP IN THE C X-DIRECTION. C DELTY = AMOUNT THE CURRENT STRING WOULD MOVE THE CP IN THE C Y-DIRECTION. C LORG = CURRENT LORG VALUE (1 THROUGH 9). C C CHIGH = CHAR0ACTER HEIGHT (IN CURRENT UNITS). C C HOW TO CALCULATE CX,CY,DX, AND DY. C C CX = CFACT*CHIGH*SIN(THETA) C CY = -CFACT*CHIGH*COS(THETA) C C WHERE: C C CFACT= 0.0 IF LORG=1,4, OR 7 C = 0.5 IF LORG=2,5, OR 8 C = 1.0 IF LORG=3,6, OR 9 C CHIGH= CHARACTER HEIGHT C THETA= CURRENT LDIR ANGLE. C C C DX = -DFACT*DELTX C DY = -DFACT*DELTY C C WHERE: C C DFACT= 0.0 IF LORG=1,2, OR 3 C = 0.5 IF LORG=4,5, OR 6 C = 1.0 IF LORG=7,8, OR 9 C DELTX= TEXT LENGTH IN X DIRECTION (PASSED IN) C DELTY= TEXT LENGTH IN Y DIRECTION (PASSED IN) C C*************************************************************** INTEGER IGCB,ITEXT(1),LORG REAL X1,Y1,DELTX,DELTY C C**************************************************************** C IMPLEMENT A STUB. C D LU=LOGLU(IDUMY) D WRITE(LU,1005) D1005 FORMAT(/"GPLC1: ENTERING A STUB.") C********************************************************** C GET THE LORG AND LDIR VALUES. C CALL GCBIM(21,1,LORG,0,1) CALL GCBIM(22,1,THETA,0,1) C**************************************************************** C GET THE SOFTWARE OR HARDWARE CELL SIZE IN CURRENT UNITS. C CALL GKAR(IGCB,CWIDE,CHIGH) C**************************************************************** C SET THE CFACT VALUE. C CFACT=FLOAT(MOD(LORG-1,3))/2.0 DFACT=FLOAT((LORG-1)/3)/2.0 C**************************************************************** C CALCULATE HOW FAR TO MOVE THE VALUES. C CX=CFACT*CHIGH*SIN(THETA) CY=-CFACT*CHIGH*COS(THETA) C DX=-DFACT*DELTX DY=-DFACT*DELTY C***************************************************************** C MOVE THE CP THE CALCULATED AMOUNTS. C CALL MOVE(IGCB,X1+DX+CX,Y1+DY+CY) RETURN END ~    92840-18158 2013 S C0122 &GPLC2              H0101 jFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GPLC2 C SOURCE: 92840 - 18158 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GPLC2(IGCB,INFO,XMTRX,X1,Y1,DELTX,DELTY,LORG,NOCARR, +IBUFR),92840-16021 REV.2013 791129 C************************************************************** C GPLC2 ADJUSTS THE CP AT (X1,Y1) IN ORDER TO IMPLEMENT C THE LORG CAPABILITY. BASICALLY, IT MOVES THE CP THE PROPER C AMOUNT SO THAT THE STRING IS PLACED PROPERLY FOR LEFT OR C RIGHT JUSTIFICATION, AND ALSO BOTTOM, CENTER, OR TOP C JUSTIFICATION. C C THE ALGORITHM WORKS LIKE THIS. FIRST OF ALL, THE CHARACTER HEIGHT C IS FOUND. THEN WE CALCULATE THE FOLLOWING VALUES: C C CX = DISTANCE THE CP MUST BE MOVED IN THE X DIRECTION TO ACCOUNT C FOR THE CURRENT CHARACTER HEIGHT (REMEMBERING LORG AND LDIR) C CY = DISTANCE THE CP MUST BE MOVED IN THE Y DIRECTION TO ACCOUNT C FOR THE CURRENT CHARACTER HEIGHT (REMEMBERING LORG AND LDIR) C C C (X1,Y1) = CURRENT POSITION C DELTX = AMOUNT THE CURRENT STRING WOULD MOVE THE CP IN THE C X-DIRECTION. C DELTY = AMOUNT THE CURRENT STRING WOULD MOVE THE CP IN THE C Y-DIRECTION. C LORG = CURRENT LORG VALUE (1 THROUGH 9). C NOCARR = .TRUE. IFF THE CR-LF SHOULD BE SUPPRESSED. C*************************************************************** INTEGER IGCB,INFO(1),ITEXT(1),LORG,IBUFR(1) LOGICAL NOCARR,GWC REAL XMTRX(2,2),X1,Y1,DELTX,DELTY C C**************************************************************** C IMPLEMENT A STUB. C D U   LU=LOGLU(IDUMY) D WRITE(LU,1005) D1005 FORMAT(/"GPLC2: ENTERING A STUB.") C************************************************************* C BRANCH TO BELOW IF THERE'S NO CR-LF. C OTHERWISE, BRING THE CP BACK AND SPACE DOWN ONE CHARACTER CELL C FOR THE CR-LF. C GET THE LDIR, AND DON'T CONVERT IT IF YOURE DOING WC CHARACTERS. C IF (NOCARR) GO TO 1000 C CALL GCBIM(35,1,XLDIR,0,1) IF (GWC(IGCB)) GO TO 500 CALL GANG3(IGCB,XLDIR,XLDIRM,IBUFR) CALL GANG4(IGCB,XLDIRM,XLDIR,IBUFR) C 500 CALL GKAR(IGCB,WIDTH,HEIGHT) X=X1+HEIGHT*SIN(XLDIR) Y=Y1-HEIGHT*COS(XLDIR) CALL MOVE(IGCB,X,Y) RETURN C**************************************************************** C NO CR-LF. CALCULATE THE NEW POSITION FOR THE CP, AND MOVE THERE. C C IF LORG=1,2, OR 3, NEW POSITION IS TO RIGHT OF (X1,Y1). FACTR=1.0 C =4,5, OR 6, NEW POSITION IS ON TOP OF (X1,Y1). FACTR=0.0 C =7,8, OR 9, NEW POSITION IS TO LEFT OF (X1,Y1). FACTR=-1.0 C 1000 CONTINUE NUMB=(LORG-1)/3 FACTR=FLOAT(1-NUMB) X=X1+FACTR*DELTX Y=Y1+FACTR*DELTY CALL MOVE(IGCB,X,Y) RETURN END   92840-18159 2013 S C0122 &GKAR              H0101 MFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GKAR C SOURCE: 92840 - 18159 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GKAR(IGCB,WIDTH,HEIGHT) +,92840-16021 REV.2013 790904 C*************************************************************** C GKAR RETURNS THE WIDTH AND HEIGHT IN CURRENT UNITS OF A C STANDARD SOFTWARE OR HARDWARE CHARACTER CELL, ACCORDING C TO WHETHER HARDWARE OR SOFTWARE TEXT IS CURRENTLY ENABLED. C************************************************************** INTEGER IGCB(1) REAL WIDTH,HEIGHT C REAL TEMP(4) LOGICAL GSOFT,GWC C************************************************************** C BRANCH ACCORDING TO WHETHER SOFTWARE OR HARDWARE TEXT IS ENABLED C IF (GSOFT(IGCB)) GO TO 1000 C*************************************************************** C HARDWARE TEXT IS ENABLED. GET THE HARDWARE CELL SIZE (MU'S) C CALL GCBIM(7,1,TEMP,0,1) CWIDE=TEMP(1) CHIGH=TEMP(2) GO TO 2000 C************************************************************** C SOFTWARE TEXT IS ENABLED. GET THE SOFTWARE CELL SIZE(WC OR NDC C UNITS ACCORDING TO HOW THE USER SPECIFIED THEM). C CONVERT THE UNITS TO MU'S C 1000 CALL GCBIM(33,1,TEMP,0,1) CWIDE=TEMP(1) CHIGH=TEMP(2) C IADP=11 IF (GWC(IGCB)) IADP=12 CALL GCBIM(IADP,1,TEMP,0,1) CWIDE=CWIDE*TEMP(1) CHIGH=CHIGH*TEMP(3) GO TO 2000 C************************************************************ C CONVERT MU'S TO CURRENT UNITS. C 2000   CALL GCBIM(IADCD(IDUMY),1,TEMP,0,1) WIDTH=CWIDE/TEMP(1) HEIGHT=CHIGH/TEMP(3) RETURN END   92840-18160 2013 S C0122 &GCHK              H0101 rUFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GCHK C SOURCE: 92840 - 18160 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GCHK(IGCB,ISUSP) +,92840-16021 REV.2013 790904 C*************************************************************** C GCHK CALL GCBIM TO VERIFY THAT THE GCB PASSED IN IS A VALID ONE, C AND THEN RETURNS THE ISUSP VALUE BACK TO THE CALLER. C ISUSP .EQ. 0 IMPLIES TO CONTINUE C ISUSP .NE. 0 IMPLIES THE GCB IS SUSPENDED. C**************************************************************** INTEGER IGCB(1),ISUSP C************************************************************** C CALL GCBIM TO CHECK THE GCB, THEN STORE THE GCB ADDRESS INTO C ITS OWN INTERNAL MEMORY LOCATION. C ISUSP=0 CALL GCBIM(99,1,IGCB,ISUSP) RETURN END ~  92840-18161 2013 S C0122 &GASC1              H0101 iqFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GASC1 C SOURCE: 92840 - 18161 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GASC1(ICHAR,IA) +,92840-16021 REV.2013 790904 C***************************************************************** C GASC1 RETURNS THE FOLLOWING VALUE IN IA AS A FUNCTION OF ICHAR: C C ICHAR IA C C 0 0 C 1-255 -1 C >255 +1 C C GASC1 CAN BE USED TO TELL IF A STRING VARIABLE CAME FROM C A FORTRAN CALL OR A BASIC CALL, SINCE A BASIC STRING C VARIABLE WILL HAVE A LENGTH WORD IN FRONT OF IT, SO THAT C IA WILL BE SET NEGATIVE IF THE STRING CAME FROM BASIC. C***************************************************************** INTEGER ICHAR,IA C IA=0 IF (ICHAR .EQ. 0) RETURN C IA=-1 IF (ICHAR .GT. 255) IA=1 RETURN END Q@  92840-18163 2013 S C0122 &GANG4              H0101 ooFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GANG4 C SOURCE: 92840 - 18163 C RELOC: 92840 - 16021 C C C CC*********************************************************** SUBROUTINE GANG4(IGCB,AMU,ANDC,BUFR) +,92840-16021 REV.2013 791129 C************************************************************** C GANG4 CONVERTS AN MU ANGLE INTO AN NDC ANGLE. C C AMU = ANGLE IN MACHINE UNIT RADIANS. C ANDC= ANGLE IN NDC COORDINATE RADIANS. (RETURNED) C BUFR = MINIMUM 8-WORD UTILITY BUFFER. C************************************************************** INTEGER IGCB(1) REAL AMU,AMU,BUFR(1) REAL PI INTEGER IREAD DATA PI/3.14159/ DATA IREAD/1/ C************************************************************* C CALCULATE THE ANGLE IN NDC COORDINATES. THE ALGORITHM C IS AS FOLLOWS: C XMU=COS(AMU) YMU=SIN(AMU) C*********************************************************** C GET THE CONVERSION FACTORS. C 20 CONTINUE CALL GCBIM(11,1,BUFR,0,IREAD) C**************************************************************** C CONVERT TO NDC UNITS. C XNDC=XMU/BUFR(1) YNDC=YMU/BUFR(3) C**************************************************************** C TAKE THE ARCTAN TO GET THE MU ANGLE. C CORRECT THE NDC ANGLE TO BE IN THE SAME QUADRANT AS THE MU ANGLE. C ANDC=ATAN2(YNDC,XNDC) RETURN END y    92840-18164 2013 S C0122 &GWC              H0101 _PFTN4,L C C C C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GWC C SOURCE: 92840 - XXXXX C RELOC: 92840 - 16021 C C C CC*********************************************************** LOGICAL FUNCTION GWC(IGCB) +,92840-16021 REV.2013 790926 C*************************************************************** C GWC IS SET TO .TRUE. IF WC CHARACTERS ARE TO BE PLOTTED, C OTHERWISE GWC IS SET TO .FALSE. C*************************************************************** INTEGER IGCB(1) C*************************************************************** C ESTABLISH A LINK TO THE GRAPHICS PACKAGE. C (THIS STORES THE ADDRESS OF THE GCB INTO AN INTERNAL LOCATION C INSIDE ABSAD.) C ISUSP=0 CALL GCBIM(99,1,IGCB,ISUSP) IF (ISUSP .NE. 0) RETURN C*************************************************************** C CALL GRSTS TO LOOK AT BIT 14 IN THE GCB. C NMASK RETURNS WITH BIT 15=0 IF CHARACTERS ARE PLOTTED IN WC, C =1 IF CHARACTERS ARE PLOTTED IN NDC. C CALL GRSTS(1,40000B,NMASK) GWC=.TRUE. IF (NMASK .EQ. 0) GWC=.FALSE. RETURN END <  92900-18001 1814 S 0563 92900A DIAGNOSTIC              H0105 ASMB,A,B,L HP92900 SUBSYST. DIAG. (Y.L.HPG) 15\03\78 HED GENERAL OPERATING PROCEDURE ORG 0 SUP * GENERAL OPERATING PROCEDURE * * A. LOAD DIAGNOSTIC CONFIGURATOR AND SET IT UP. * B. LOAD DIAGNOSTIC MAIN PROGRAM * C. LOAD P-REG. WITH ADDRESS 100B. * D. LOAD S-REG. WITH SELECT CODE AND TRANSFER CLOCK * RATE IF NECESSARY. * E. PRESS RUN AND WAIT FOR HALT 102074. * F. LOAD SWITCH REGISTER * IF SET =: * 15 = HALT AT END OF EACH TEST * 14 = SUPRESS ERROR HALTS * 13 = LOOP ON LAST TEST * 12 = LOOP ON DIAGNOSTIC * (SUPPRESS ALL OPERATOR INTERVENTION) * 11 = SUPRESS ERROR MESSAGES * 10 = SUPRESS NON-ERROR MESSAGES * 9 = GO TO USER CONTROL SECTION AT END OF TEST * 8 = SUPPRESS OPERATOR INTERVENTION TESTS * 7 = ABORT CURRENT RUNNING TEST * 6 = RESERVED * 5 HP40280 SELECT CODE WITH P=100 * = HP03070 HPIB ADDRESS WITH P=2000 & NOT TEST16 * 0 HP03070 MAX LINK ADDRESS WITH P=2000 & TEST16 * * NOTE: STANDARD RUN SHOULD BE WITH SW. REG. = 0 * USER CONTROL WILL ASK FOR A 32 BIT WORD. * EACH BIT WILL = 1 TEST * * G. PRESS RUN. * H. RESTART - LOAD P-REG. WITH ADDRESS 2000B * I. RECONFIGURE IF TESTING I/O INTERFACE - LOAD ADDRESS 100B * * GENERAL COMPUTER HALTS * * 1020XX E OR H 000 TO 067 * 1060XX E OR H 100 TO 167 * 1030XX E OR H 200 TO 267 * 1070XX E OR H 300 TO 367 * * CONTROL PROGRAM HALT MESSAGES * * 102077 END OF DIAG (A = PASS COUNT) * 102076 END OF TEST (A = TEST #) * 102075 USER SELECTION REQUEST * u&102074 SELECT CODE INPUT COMPLETE * 102073 USER SELECT CODE ERROR * 102072 BAD HPIB ADDRESS ( 1< BIT 5-0 <36 ) * 102071 RESERVED * 102070 RESERVED * 106077 TRAP CELL HALT * HED PROGRAM ORGANIZATION CHART * ******************************************* * * CONFIGURATOR 100B * * * LINKAGE TABLE * * ******************************************* * * EXECUTIVE 130B * * * LINKAGE * * ******************************************* * * CONSTANTS 150B * * * AND * * * STORAGE * * ******************************************* * * 2000B * * * EXECUTIVE CONTROL * * * * * ******************************************* * * IF USED * * * BASIC I/O TESTS (TEST 00) * * * ZCEND * * ******************************************* * * TABLE OF TEST POINTERS * * * TABLE OF I/O INSTR POINTERS * * ******************************************* * * * * * * * * * * * * * * * * * MAIN DIAGNOSTICS (1-31) * * * * * * * * * * * * 3  * * * * * ******************************************* * * * * * * * * * * * * * * * * * * * * HED CONFIGURATOR LINKAGE TABLE A EQU 0 A REGISTER REFERENCE B EQU 1 B REGISTER REFERENCE SW EQU 1 SWITCH REGISTER REFERENCE INTP EQU 0 INTERRUPT CHANNEL REFERENCE * * ORG 100B * JMP CFIG,I GO TO CONFIGURATION SECTION FAIN BSS 1 FAST INPUT (PHOTO READER) SLOP BSS 1 SLOW OUTPUT (LIST) FAOP BSS 1 FAST OUTPUT (DUMP OR PUNCH) SLIN BSS 1 SLOW INPUT (KEYBOARD) FWAM DEF FWAA FIRST WORD OF AVBL. MEMORY LWAM BSS 1 LAST WORD OF AVBL. MEMORY BSS 1 NOT USED (MAG TAPE) OTMC BSS 1 1 MILL SEC TIME OUT COUNT BSS 4 SELECT CODES FOR I/O CPTO BSS 1 COMPUTER TYPE/OPTIONS USSC BSS 1 USER CARD TYPE AND SELECT CODE MEMO BSS 1 MEMORY SIZE AND TYPE ISWR BSS 1 INTERNAL SWITCH REGISTER TMRR BSS 1 1 MILL SEC TIMER SWRC BSS 1 CONFIGURATOR SWITCH CK PTR I2AS BSS 1 INTEGER TO ASCII CONVERSION O2AS BSS 1 OCTAL TO ASCII CONVERSION AS2N BSS 1 ASCII CONVERSION DSNL BSS 1 DIAGNOSTIC SERIAL NUMBER FMTR BSS 1 FORMATTER * * * CONTROL LINKAGE AND DATA REFERENCES * CFIG DEF ZCONF CONFIGURATION SECTION MSGC DEF ZMSGC MESSAGE WITH NO HALT MSGH DEF ZMSGH MESSAGE WITH HALT ERMS DEF ZERMS ERROR MESSAGE SWRT DEF ZSWRT SWITCH REGISTER CHECK ROUTINE TSTN OCT 0 CURRENT TEST NUMBER EXRT DEF ZEXRT RETURN TO CONTROL PROGRAM NOP RESERVED * * * * * * * * * * * * * HED EXECUTIVE CONTROL ORG 2000B ZSTEX CLC INTP,C TURN I/O SYSTEM OFF JSB MSGC,I DO CRLF DEF ZRTLF LDA HDMP GET INTRODUCTORY MESSAGE +( STA *+2 JSB MSGC,I OUT PUT IT NOP CLA CLEAR PASS STA ZEOLC COUNT LDB ZSW9 CHECK FOR USER SELECTION REQ JSB SWRT,I JMP ZUSR IT'S USERS CHOICE ZNUSR LDA STDA GET STANDARD TEST RUN LDB STDB * JMP ZEXC * ZUSR LDA ZSINA RETRIEVE PREVIOUS RUN LDB ZSINB HLT 75B WAIT FOR USER INPUT NOP NOP NOP ZEXC STA ZUINA SAVE STB ZUINB USER STA ZSINA INPUT STB ZSINB PROGRAM LDB ZSW9 CHECK IF SW9 IS DOWN JSB SWRT,I JMP ZUSR NO GO AND WAIT CCA SET TEST NUMBER STA TSTN =-1 CLA STA ZTSTA CLEAR TEST RUN FLAG * * * * * * * * * * * * * * * * SKP ZEXCL LDA ZUINA RESTORE A REG. LDB ZUINB RESTORE B REG. ERA,RAL ROTATE ERB FIRST ERA TEST BIT STA ZUINA SAVE POSITIONS STB ZUINB ISZ TSTN MOVE TEST UP ONE NOP ZXCL1 LDA TSTN ADA TSTP GET IT'S LDA A,I ADDRESS CPA Z.M1 IS IT END OF LIST JMP ZEOL YES LDB ZUINB SSB,RSS SHOULD IT BE RUN? JMP ZEXCL NO STA ZTSTA YES - SAVE TEST ADDRESS JSB ZITCH INITIALIZE TRAP CELL HALTS JSB ZTSTA,I GO DO TEST ZEXRT LDA TSTN DISPLAY TEST NUMBER IF HALTED LDB ZSW15 CHECK FOR HALT AT END OF TEST JSB SWRT,I HLT 76B YES WAIT FOR OPERATOR LDB ZSW9 CHECK FOR ABORT JSB SWRT,I JMP ZUSR YES LDB ZSW13 CHECK FOR LOOP ON ROUTINE JSB SWRT,I JMP ZXCL1 YES - LOOP JMP ZEXCL CONTINUE * ZEOL LDA ZTSTA CHECK IF ANY TESTS WERE RUN SZA,RSS ? JMP ZNUSR NO SO PICK UP STANDARD RUN LDA ZEOLC UP DATE PASS COUNT INdA STA ZEOLC CCE LDB ZPSCA GET PASS COUNT ADB Z.2 ADDRESS JSB O2AS,I CONVERT IT JSB MSGC,I CALL PRINT ROUTINE ZPSCA DEF ZPSC LDB ZSW12 CHECK FOR LOOP ON DIAG. JSB SWRT,I JMP *+3 YES LDA ZEOLC HLT 77B NO WAIT AND DISPLAY PASS COUNT LDA ZSINA RESTORE ORIGINAL LDB ZSINB PROGRAM JMP ZEXC DO IT ALL AGAIN * SKP * MESSAGE OUTPUT WITH OUT HALT * ZMSGC NOP ENTRY JSB ZMSG OUTPUT MESSAGE OCT 2000 SWITCH 10 CHECK JMP ZMSGC,I RETURN TO CALLER * * MESSAGE OUTPUT WITH HALT * ZMSGH NOP ENTRY JSB ZMSG OUTPUT MESSAGE OCT 2000 SWITCH 10 CHECK LDA ZHLT GET HALT CODE STA *+2 PUT IT IN PLACE LDA ZSAVA RESTORE A REGISTER NOP HALT FOR DISPLAY JMP ZMSGH,I RETURN TO CALLER * * ERROR MESSAGE WITH HALT * ZERMS NOP ENTRY JSB ZMSG OUTPUT MESSAGE OCT 4000 SWITCH 11 CHECK CLA LDB ZSW14 CHECK SWR BIT 14 TO SUPPRESS JSB SWRT,I HALT STA *+3 PUT HALT IN PLACE LDA ZSAVA RESTORE A & B LDB ZSAVB ZHLT NOP WAIT FOR OPERATOR JSB SHRTN EXAMINE S-REG BIT 7 LDA ZSAVA RESTORE A & B LDB ZSAVB JMP ZERMS,I RETURN TO CALLER * * * * * * * * * * * * * SKP * OUTPUT MESSAGE * ZMSG NOP STA ZSAVA SAVE A AND B REGISTERS STB ZSAVB LDB ZMSG,I GET SWITCH REGISTER BIT LDA ZMSG ADA Z.M2 DECREMENT RETURN ADDRESS STA ZMSG JSB SWRT,I CHECK TO SUPPRESS MESSAGE JMP ZMSG0 YES LDA ZMSG,I CHECK IF ERROR LDA A,I LDA A,I IF SO ALF,ALF AND Z.177 CPA ZA.E JSB ZCFTN CHECK TO OUTPUT TEST NUMBER sp LDA ZMSG,I NO RETRIEVE FORMAT LDB A,I ADDRESS CLA,CLE JSB FMTR,I ZMSG0 LDA ZMSG,I CONVERT HALT CODE LDB A,I FROM ASCII STRING CCA,CCE JSB AS2N,I STA ZN2AO SAVE RESULT AND Z.300 DECODE LDB ZH2 HALT CODE CPA Z.100 LDB ZH6 CPA Z.200 LDB ZH3 CPA Z.300 LDB ZH7 LDA ZN2AO GET HALT NUMBER AND Z.77 IOR B STA ZHLT SAVE IT ISZ ZMSG,I ADJUST RETURN POINTERS ISZ ZMSG ISZ ZMSG ISZ ZMSG LDA ZSAVA RESTORE A AND B REGISTERS LDB ZSAVB JMP ZMSG,I * * * * * * SKP ZCFTN NOP LDA TSTN GET TEST NUMBER CPA ZCFTT IS IT THE SAME ONE? JMP ZCFTN,I YES SKIP OUTPUT STA ZCFTT NO - THEN UPDATE IT JSB ZN2AO CONVERT IT STA ZTSTN PUT IT IN STRING CLA DO A CRLF JSB SLOP,I CLA,CLE INDICATE START OF FORMAT LDB ZTSTF JSB FMTR,I JMP ZCFTN,I RETURN * * ZSAVA NOP ZSAVB NOP ZEOLC NOP ZTSTA NOP ZSINA NOP ZSINB NOP ZUINA NOP ZUINB NOP ZBTMP NOP Z.2 OCT 2 Z.7 OCT 7 Z.10 OCT 10 Z.60 OCT 60 Z.77 OCT 77 Z.177 OCT 177 Z.M1 DEC -1 Z.M2 DEC -2 ZD100 DEC -100 ZIOM OCT 177700 ZSW15 OCT 100000 ZSW14 OCT 40000 ZSW13 OCT 20000 ZSW12 OCT 10000 ZS812 OCT 010400 ZSW9 OCT 1000 Z.100 OCT 100 Z.200 OCT 200 Z.300 OCT 300 ZH2 OCT 102000 ZH6 OCT 106000 ZH3 OCT 103000 ZH7 OCT 107000 ZCFTT DEC -1 ZTSTF DEF *+1 ASC 3,TEST ZTSTN ASC 2,XX// ZRTLF ASC 1,// ZPSC ASC 6,PASS XXXXXX/ ZA.E OCT 105 HED GENERAL ROUTINES * * ZN2AO NOP STA ZIOAD SAVE NUMBER AND Z.7 CONVERT FIRST IOR Z.60 NUMBER STA B SAVE IT LDA ZIOAD GET RAR,RAR SECOND RAR NUMBER AND Z.7 CONVERT )  IOR Z.60 IT ALF,ALF MOVE TO UPPER HALF IOR B ADD LOWER JMP ZN2AO,I AND RETURN * * * * SWITCH REGISTER CHECK * ZSWRT NOP STA ZN2AO SAVE A REGISTER LIA SW GET SWITCH REG. AND B MASK OUT BIT SZA,RSS IS IT UP? ISZ ZSWRT NO LDA ZN2AO RESTORE A REGISTER LIB SW LET B = SWITCH REGISTER JMP ZSWRT,I RETURN TO CALLER * * * * INITIALIZE TRAP CELL HALTS * ZITCH NOP LDA ZTSH GET STARTING TRAP CELL HALT LDB Z.2 GET FIRST TRAP CELL LOCATION ZTSHL STA B,I PUT IT IN PLACE CPB Z.77 AM I FINISHED JMP ZITCH,I YES INB NEXT ADDRESS JMP ZTSHL * ZTSH OCT 106077 * * * SKP * PUT JSB INSTRUCTION IN TRAP CELL * ZTCJI NOP LDB ZJSBI GET INSTRUCTION STB ZIOSC,I PUT IT IN TRAP CELL LDA ZTCJI,I GET LOCATION STA 3B SAVE IT FOR JSB INSTRUCTION ISZ ZTCJI ADJUST RETURN JMP ZTCJI,I RETURN TO CALLER * ZJSBI JSB 3B,I JSB INSTRUCTION * * * INITIALIZE SELECT CODE I/O INSTRUCTIONS * ZISC NOP STA ZIOSC SAVE SELECT CODE STB ZIOAD SAVE TABLE ADDRESS ZIOL LDB ZIOAD,I GET ADDRESS OF LOCATION CPB Z.M1 IS IT THE TERMINATOR JMP ZISC,I YES RETURN TO CALLER LDA B,I NO - GET CONTENTS AND ZIOM MASK OFF OLD SELECT CODE IOR ZIOSC ADD IN NEW SELECT CODE STA B,I RESTORE IT ISZ ZIOAD MOVE TO NEXT ADDRESS JMP ZIOL DO IT * ZIOSC NOP ZIOAD NOP * * * * SKP * CONFIGURATION SECTION * ZCONF CLC INTP,C TURN I/O SYSTEM OFF LIA SW GET SELECT CODE AND OPTIONS STA USSC SAVE THEM AND B0700 GET TRANSFER RATE CLOCK SZA,RSS IF 0, FORCE TO 200 KHZ LDA Z.200 LDB pKSTDTM GET STD TIMING CPA Z.100 IS IT 100 KHZ ? JMP ZMUL2 CPA Z.200 IS IT 200 KHZ ? JMP ZLETB CPA Z.300 IS IT 400 KHZ ? RSS JMP ZHL73 ZDIV2 BRS HALF TIMING ADB M2 LITTLE OVERHEAD COMP. RSS ZMUL2 BLS DOUBLE TIMING ZLETB STB TLTMG LDA USSC AND Z.77 ELIMINATE OPTIONS LDB A CMB,INB CHECK THAT SC > 7 ADB Z.7 SSB ? JMP *+3 OK GO ON ZHL73 HLT 73B NO JMP ZCONF TRY AGAIN LDB IOIP INITIALIZE TEST I/O JSB ZISC INSTRUCTIONS HLT 74B ALLOW OPERATOR TO CHANGE SWIT JMP ZSTEX GO TO EXEC CONTROL SECTION * * * * * * * * * * * * * * * * * * * * HED BASIC I/O TESTS CH EQU 10B * TST00 EQU * BASIO NOP LDB UTCMD BITS 8 & 12 OPTIONS ? JSB SWRT,I JMP BASIO,I LDA USSC GET CELL LOCATION AND Z.77 JSB ZBIO DO BASIC I/O JMP TST00,I * ZBIO NOP CLC INTP,C TURN OFF ALL I/O LDB ZBIOD INITIALIZE BASIC I/O JSB ZISC INSTRUCTIONS * * INTERRUPT FLAG CHECK * ZBIO1 STF INTP CLF INTP SFC INTP RSS JMP *+3 E000 JSB ERMS,I E000 CLF 0-SFC 0 ERROR DEF ZBE00 SFS INTP JMP *+3 E001 JSB ERMS,I E001 CLF 0-SFS 0 ERROR DEF ZBE01 STF INTP SFC INTP JMP *+4 CLF INTP TURN OFF INTS E002 JSB ERMS,I E002 STF 0-SFC 0 ERROR DEF ZBE02 SFS INTP JMP *+3 CLF INTP TURN OFF INTERRUPTS JMP ZBIO2 CLF INTP TURN OFF INTS E003 JSB ERMS,I E003 STF 0-SFS 0 ERROR DEF ZBE03 JMP ZBIO2 * ZBE00 ASC 12,E000 CLF 0-SFC 0 ERROR/ ZBE01 ASC 12,E001 CLF 0-SFS 0 ERROR/ ZBE02 ASC 12,E002 STF 0-SFC 0 ERROR/ ZBE03 ASC 12,E003 STF 0-SFS 0 ERROR/ * * SKP ; * CARD FLAG CHECK * ZBIO2 EQU * ZBS21 STF CH ZBS22 CLF CH ZBS23 SFC CH RSS JMP *+3 E005 JSB ERMS,I E005 CLF CH-SFC CH ERROR DEF ZBE05 ZBS24 SFS CH JMP *+3 E006 JSB ERMS,I E006 CLF CH-SFS CH ERROR DEF ZBE06 ZBS25 STF CH ZBS26 SFC CH JMP *+3 E007 JSB ERMS,I E007 STF CH-SFC CH ERROR DEF ZBE07 ZBS27 SFS CH RSS JMP ZBIO3 E010 JSB ERMS,I E010 STF CH-SFS CH ERROR DEF ZBE10 JMP ZBIO3 * ZBE05 ASC 13,E005 CLF CH-SFC CH ERROR/ ZBE06 ASC 13,E006 CLF CH-SFS CH ERROR/ ZBE07 ASC 13,E007 STF CH-SFC CH ERROR/ ZBE10 ASC 13,E010 STF CH-SFS CH ERROR/ * * * * * * * * * * * * * * * * * * * SKP * INTERRUPT CONTROL * ZBIO3 JSB ZTCJI SET JSB INSTRUCTION DEF ZB3E ZBS31 STF CH SET THE FLAG ZBS32 STC CH SET THE CONTROL STF INTP TURN I/O SYSTEM ON THEN CLF INTP TURN I/O SYSTEM OFF NOP GIVE IT A CHANCE TI INTERRUPT NOP ZBS33 CLF CH RESET CH FLAG JMP ZBIO4 * ZBE04 ASC 16,E004 CLF 0 DID NOT INHIBIT INT/ * ZB3E NOP CLF INTP TURN OFF INTS E004 JSB ERMS,I E004 DEF ZBE04 * * * * * * * * * * * * * * * * * * * * * * * * SKP * SELECT CODE SCREEN TEST * ZBIO4 LDB Z.10 START WITH LOWEST ADDRESS ZB40 LDA USSC GET SELECT CODE AND Z.77 CPB A IS IT THE CH? JMP Z.CLF+1 YES - SKIP TEST LDA Z.STF SET UP AND ZIOM IOR B STF INSTRUCTION STA Z.STF PUT IT IN PLACE LDA Z.CLF SET UP AND ZIOM IOR B CLF INSTRUCTION STA Z.CLF PUT IT IN LINE ZBS41 CLF CH CLEAR CHANNEL FLAG Z.STF STF CH EXECUTE STF CH INSTRUCTION ZBS42 SFC CH TEST CHANNEL FLAG JMP ZB41 Z.CLF CLF CH CLEAR TEST FLAG CPB Z.77 :<:6 IS TEST FINISHED? JMP ZBIO5 YES INB NO JMP ZB40 DO NEXT CHANNEL * ZBE11 ASC 14,E011 STF XX SET CARD FLAG// * ZB41 STB ZBTMP SAVE NUMBER LDA B CONVERT CH FOR MESSAGE JSB ZN2AO STA ZBE11+5 LDA ZBTMP RETRIEVE NUMBER E011 JSB ERMS,I E011 DEF ZBE11 * * * * * SKP ! <* CHECK INTERRUPT & HOLD OFF * ZBIO5 JSB ZTCJI DEF ZBI5 CLA SET UP STA ZBF5 FLAGS STA ZBI5 FOR TEST STA ZBTMP ZBS51 STC CH TURN ON ZBS52 STF CH CARD STF INTP AND INTERRUPTS STC 1 * STF 1 * CLC 1 * CLF 1 * NO INTERRUPT JMP *+1,I * SHOULD OCCURR DEF *+1 * HERE JSB *+1,I * DEF *+1 * ZBF5 NOP * ISZ ZBTMP INT. SHOULD BE HERE ISZ ZBTMP CLF INTP TURN I/O SYSTEM OFF LDA ZBI5 DID IT INTERRUPT? SZA JMP *+4 E014 JSB ERMS,I E014 NO INT DEF ZBE14 JMP ZBIO6 ABORT REST OF SECTION LDA ZBTMP CHECK FOR CORRECT INTERRUPT CPA Z.2 ? JMP *+3 E026 JSB ERMS,I E026 INT EXECUTION ERROR DEF ZBE26 ZBS53 CLF CH TURN OFF CH FLAG JMP ZBIO6 GO TO NEXT SECTION * ZBD5 DEF ZBF5-1 ZBD5A DEF ZBF5+1 * ZBE12 ASC 16,E012 INT DURING HOLD OFF INSTR/ ZBE13 ASC 12,E013 SECOND INT OCURRED/ ZBE14 ASC 06,E014 NO INT/ ZBE15 ASC 12,E015 INT RTN ADDR ERROR/ ZBE26 ASC 13,E026 INT EXECUTION ERROR/ * * * * SKP ZBI5 NOP CLF INTP TURN I/O SYSTEM OFF LDA ZBD5 CHECK TO SEE IF ALL CPA ZBF5 INSTRUCTION COMPLETED JMP *+3 YES E012 JSB ERMS,I E012 INT DURING HOLD OFF DEF ZBE12 LDA ZBD5A CHECK RETURN ADDRESS LDB CPTO IF 210X SSB ADD ONE INA CPA ZBI5 JMP ZBI5A E015 JSB ERMS,I E015 INT RTN ADDR ERROR DEF ZBE15 JMP ZBIO6 ZBI5A JSB ZTCJI SET SECOND INT TRAP DEF ZBT5 STF INTP TURN I/O SYSTEM ON JMP ZBI5,I CONTINUE TEST * * ZBT5 NOP CLF INTP TURN I/O SYSTEM OFF E013 JSB ERMS,I E013 SECOND INT OCURRED DEF ZBE13 * * * * * vSKP * CLC CH AND CLC 0 * ZBIO6 JSB ZTCJI SET JSB INSTRUCTION DEF ZBI61 ZBS61 STC CH SET CH CONTROL ZBS62 STF CH SET CH FLAG STF INTP TURN ON INTERRUPTS ZBS63 CLC CH CLEAR CH CONTROL NOP GIVE IT A CHANCE NOP CLF INTP TURN INTS OFF ZB60 JSB ZTCJI SET JSB INSTRUCTION DEF ZBI62 ZBS64 CLF CH CLEAR CH FLAG ZBS65 STC CH SET CH CONTROL ZBS66 STF CH SET CH FLAG STF INTP TURN ON INTS CLC INTP CLEAR I/O SYSTEM NOP GIVE IT A CHANCE NOP CLF INTP TURN OFF INTS JMP ZBIO7 * * ZBI61 NOP CLF INTP TURN OFF INTS E016 JSB ERMS,I E016 CLC CH ERROR DEF ZBE16 JMP ZB60 * ZBI62 NOP CLF INTP TURN OFF INTS E017 JSB ERMS,I E017 CLC 0 ERROR DEF ZBE17 JMP ZBIO7 * ZBE16 ASC 9,E016 CLC CH ERROR/ ZBE17 ASC 9,E017 CLC 0 ERROR/ * * * * * SKP * EXTERNAL & INTERNAL PRESET TEST * ZBIO7 LDB ZS812 CHECK TO SUPPRESS JSB SWRT,I ? JMP H025 YES - SKIP PRESET TEST H024 JSB MSGC,I TELL OPERATOR DEF ZBM24 PRESS PRESET * ZBS71 CLF CH CLEAR CH FLAG STF INTP TURN ON INTS JSB ZTCJI SET TRAP CELL JSB INSTRUCTION DEF ZBI70 HLT 24B WAIT FOR OPERATOR CLA,INA SET UP FLAGS FOR TESTS SFS INTP CHECK INTP FLAG CLA NOT SET SO CLEAR FLAG RAL MOVE TO NEXT FLAG CLF INTP TURN OFF ONTPS ZBS72 SFS CH CHECK CHANNEL FLAG INA NOT SET SO FLAG IT RAL MOVE TO NEXT FLAG LIB 0 CHECK I/O BUSS SZB SHOULD BE ZERO INA NOT SO FLAG IT RAL MOVE TO NEXT FLAG STF INTP CHECK CONTROL ON CARD NOP GIVE IT A CHANCE NOP CLF INTP TURN OFF INTPS Q* * SKP ZB70 SLA,RSS CHECK FOR ERRORS JMP *+3 E022 JSB ERMS,I E022 DID NOT CLEAR CONTROL DEF ZBE22 RAR SLA,RSS JMP *+3 E023 JSB ERMS,I E023 I/O LINES NOT CLEAR DEF ZBE23 RAR SLA,RSS JMP *+3 E020 JSB ERMS,I E020 FLAG NOT SET DEF ZBE20 RAR SLA,RSS JMP *+3 E021 JSB ERMS,I E021 DID NOT DIABLE INTS DEF ZBE21 H025 JSB MSGC,I TELL OPERATOR DEF ZBM25 BASIC I/O IS COMPLETE JMP ZBIO,I RETURN TO CALLER * ZBI70 NOP CONTROL FAILED CLF INTP TURN OFF INTPS INA JMP ZB70 * ZBE20 ASC 17,E020 PRESET(EXT) DID NOT SET FLAG/ ZBE21 ASC 19,E021 PRESET(INT) DID NOT DISABLE INTS/ ZBE22 ASC 20,E022 PRESET(EXT) DID NOT CLEAR CONTROL/ ZBE23 ASC 21,E023 PRESET(EXT) DID NOT CLEAR I-O LINES/ ZBM24 ASC 17,H024 PRESS PRESET (EXT&INT),RUN/ ZBM25 ASC 08,H025 BI-O COMP/ SKP ZBIOD DEF *+1 DEF ZBS21 DEF ZBS22 DEF ZBS23 DEF ZBS24 DEF ZBS25 DEF ZBS26 DEF ZBS27 DEF ZBS31 DEF ZBS32 DEF ZBS33 DEF ZBS41 DEF ZBS42 DEF ZBS51 DEF ZBS52 DEF ZBS53 DEF ZBS61 DEF ZBS62 DEF ZBS63 DEF ZBS64 DEF ZBS65 DEF ZBS66 DEF ZBS71 DEF ZBS72 DEC -1 * ZCEND EQU * * HED ***** DIAGNOSTIC DEFINITION ***** * * ORG 126B DSN OCT 104117 DIAGNOSTIC SERIAL NUMBER * * ORG 140B IOIP DEF IODP TSTP DEF TSTD HDMP DEF HDMS STDA OCT 007777 STD TESTS 0 TO 13 STDB OCT 000000 * * ORG 150B * LIGNA DEF LIGNE BGINA DEF BGINN BGYNA DEF BEGIN CONFA DEF CONFG SNDEA DEF SNDER INDXA DEF INDXT SNDNA DEF SNDNG TESTA DEF TESTR VERFA DEF VERFY BUZZA DEF BUZZZ TSTEA DEF TSTER DXTAD DEF DXTAB RETAD DEF RETAB BFBAS DEF BFTAB CODAD DEF CDTAB KBTAD DEF KBTAB FKTAD DEF FKTAB ORDRA DEF ORDRT ABORT DEF ZEXRT ADAT1 DEF DATA1 PRMSA DEF PRMES SFKAD DEF SFKTB DCFAD DEF DCFTB SRQAD DEF SRQTB SRTB1 DEF UNLSN SRTB2 DEF UNLSN+7 SRTB3 DEF RDSTB+1 RDSEQ DEF RDATA PRSEQ DEF PRATA * * HED ***** DATA ***** * * OCT07 OCT 000007 OCT35 OCT 000035 OC140 OCT 000140 OC160 OCT 000160 NOC37 OCT 177740 TILDA OCT 010176 CDGEN OCT 010131 BIT15 OCT 100000 BIT14 OCT 040000 BIT13 OCT 020000 BIT12 OCT 010000 BIT11 OCT 004000 BIT10 OCT 002000 BIT09 OCT 001000 BIT08 OCT 000400 BIT07 OCT 000200 BIT05 OCT 000040 BIT03 OCT 000010 NBT15 OCT 077777 BT154 OCT 140000 BT110 OCT 006000 NBIT7 OCT 177577 NB154 OCT 037777 BT910 OCT 003000 B3210 OCT 000017 B0346 OCT 000131 B5432 OCT 170000 B0777 OCT 000777 B7000 OCT 007000 B0700 OCT 000700 B6520 OCT 000145 BT520 OCT 000045 * MSA00 OCT 010573 RJE,CAD,HOLES,ASCII MSA01 OCT 010567 RJE,CAD,HOLES+MARKS,IMAGE MSA02 OCT 010572 RJE,NCL,HOLES,80 COL,ASCII MSA07 OCT 010552 RJD,NCL,HOLES,80 COL,ASCII MLAC2 OCT 010576 KEYBOARD MODE (2) SEC CMND SFTST OCT 010577 REMOTE SELF-TEST TRIGGER COMMAND * RBYTE OCT 000377 UTCMD OCT 010400 LSN34 OCT 010474 DCL OCT 010424 * @@ ASC 1,@@ @Q ASC 1,@Q H@ ASC 1,H@ * SKP * * P1000 DEC 1000 P250 DEC 250 P90 DEC 90 P63 DEC 63 P62 DEC 62 P40 DEC 40 P20 DEC 20 P18 DEC 18 P17 DEC 17 P14 DEC 14 P13 DEC 13 P11 DEC 11 P10 DEC 10 P9 DEC 9 P5 DEC 5 P4 DEC 4 P3 DEC 3 P2 DEC 2 M1000 DEC -1000 M121 DEC -121 M63 DEC -63 M62 DEC -62 M41 DEC -41 M40 DEC -40 M38 DEC -38 M28 DEC -28 M20 DEC -20 M16 DEC -16 M15 DEC -15 M14 DEC -14 M10 DEC -10 M2 DEC -2 TM15S DEC -3000 TLTMG DEC -16 CONTROLLER TIME OUT X 5 MS = STDTM DEC -16 STD TIME OUT FOR 200 KHZ CLOCK CAPA. OCT 000101 CAPB. OCT 000102 STDMK OCT 013000 SRPMK OCT 042100 SRQEX OCT 041000 * * SKP * DCFTB OCT 010537 UNTALK OCT 010477 UNLISTEN OCT 000000 INPUT TO WAIT SRQ IFC OCT 014000 IFC UTDAT OCT 010000 IFC BAR LSNXX OCT 010475 LISTEN DISPLAY OCT 010141 LIT FIRST LIGHT OCT 010143 AND SO ON ... OCT 010145 OCT 010147 OCT 010151 OCT 010153 SFKTB OCT 010155 OCT 010157 OCT 010161 OCT 010163 OCT 010165 OCT 010167 OCT 010171 OCT 010173 OCT 010175 UNLSN OCT 010477 UNLISTEN LSN36 OCT 010476 LISTEN ISP SPE OCT 010430 SERIAL POLL ENABLE TLK35 OCT 010535 TALKER KEYBOARD RDSTB OCT 000000 INPUT => TEST STATUS (BIT 6) UNTLK OCT 010537 UNTALK SPD OCT 010431 SERIAL POLL DISABLE OCT 014000 IFC TO CLEAR LEDS OCT 010000 NOT IFC OCT 010476 ISP LISTENER AGAIN LSN35 OCT 010475 LISTEN DISPLAY MSBYT NOP TERMINAL ADDR MS DIGIT LSBYT NOP " " LS DIGIT OCT 010012 LF TO RESET DISPLAY TLKXX OCT 010535 TALKER KEYBOARD DEC -1 * SRQTB EQU IFC * PRATA OCT 010537,010477 LSN33 OCT 010473 ASC 20,PRESS SRQ TO RESTART ASC 20,   ( NO  READER )   OCT 010012 DEC -1 * RDATA OCT 010537,010477,010473 ASC 20,  INPUT YOUR CARD   OCT 010012,010476 TLK34 OCT 010534,000000,010537,010012 DEC -1 * SKP * * CDTAB OCT 010060 0 OCT 010061 1 OCT 010062 2 OCT 010063 3 OCT 010064 4 OCT 010065 5 OCT 010066 6 OCT 010067 7 OCT 010070 8 OCT 010071 9 SPACE OCT 010040 SP OCT 010055 - D.PNT OCT 010056 . CAP.E OCT 010105 E DEL OCT 010177 DELETE CAP.A OCT 010101 A CAP.B OCT 010102 B CAP.C OCT 010103 C CAP.D OCT 010104 D LFCOD OCT 010012 LINE FEED M.1 DEC -1 KBTAB OCT 000060 0 KEY OCT 000061 1 " OCT 000062 2 " OCT 000063 3 " OCT 000064 4 "  OCT 000065 5 " OCT 000066 6 " OCT 000067 7 " OCT70 OCT 000070 8 " OCT 000071 9 " OCT 000056 . " OCT 000055 - " OCT 000177 DELETE KEY LF OCT 000012 ENTER KEY FKTAB OCT 000020 SFK CODES TABLE OCT21 OCT 000021 OCT 000022 OCT 000023 OCT 000024 OCT 000025 OCT 000026 OCT 000027 OCT30 OCT 000030 OCT31 OCT 000031 * * SKP * * ORDRT OCT 010141 OCT 010152 OCT 010143 OCT 010140 OCT 010145 OCT 010142 RL4ON OCT 010147 OCT 010144 OCT 010151 RL4OF OCT 010146 OCT 010163 OCT 010150 OCT 010161 OCT 010162 OCT 010157 OCT 010160 OCT 010155 OCT 010156 OCT 010153 OCT 010154 OCT 010165 OCT 010152 OCT 010167 OCT 010164 OCT 010171 OCT 010166 OCT 010173 OCT 010170 OCT 010175 OCT 010172 OCT 010163 NPL15 OCT 010174 OCT 010161 OCT 010162 OCT 010157 OCT 010160 OCT 010155 OCT 010156 OCT 010153 OCT 010154 * * SKP * * DATAD DEF DATAB DATAB REP 63 DATABASE FOR TST1 OCT 117777 OCT 137776 OCT 137775 OCT 137773 OCT 137767 OCT 137757 OCT 137737 OCT 137677 OCT 137577 OCT 137377 OCT 136777 OCT 135777 OCT 133777 OCT 117777 OCT 130000 OCT 114000 OCT 112000 OCT 111000 OCT 110400 OCT 110200 OCT 110100 OCT 110040 OCT 110020 OCT 110010 OCT 110004 OCT 110002 OCT 110001 OCT 110000 M1 DEC -1 NB750 OCT 177500 BIT50 OCT 000077 SC EQU 10B * / PAD CHAR IS "DLE" TO GIVE 010 FOR LEFT BYTE PRMES ASC 5,ERROR DEC -1 * * IMAGE CONTENT OF DIAGNOSTIC CARD #1 * DATA1 AS.C 14,??@@@ @P@H@D@B@A @P@H@D@B@A@ ASC 14,?_?/?7?;?=?>_?/?7?;?=?>?**UU ASC 12,**UU**UU**UU**UU**UU**UU * * HED ***** TABLES ***** * * TEMP0 BSS 1 TEMP1 BSS 1 TEMP2 BSS 1 TEMP3 BSS 1 TEMP4 BSS 1 COBAS BSS 1 SCPAD BSS 1 FOKAD BSS 1 WITNS BSS 1 * STBYT BSS 1 CNTR BSS 1 TIME BSS 1 DEBUT BSS 1 VARIA BSS 1 SCUTY BSS 1 BLINK BSS 1 * DXTAP BSS 1 DXTOK BSS 1 DXTAR BSS 1 RETAR BSS 1 RETAP BSS 1 RETOK BSS 1 * TRDXA EQU TEMP0 TERPT EQU TEMP1 BFPNT EQU TEMP2 CTBFA EQU TEMP3 CINAD EQU TEMP4 TRDXT EQU COBAS SQCER EQU SCPAD EOIND EQU FOKAD RDFLG EQU WITNS * LIGNE BSS 20 DXTAB BSS 64 RETAB BSS 64 ADDR3 EQU * * * ORG 10000B BFTAB BSS 1300 ADDR4 EQU * * ORG ADDR3 * * HED ***** SUBROUTINES FOR TESTS ***** * * INITIALIZATION SUBROUTINE * INITZ NOP LDA INITZ SAVE RTN ADDR STA INITS JMP STD35 FORCE HPIB ADDR TO 35 INITS NOP LIA SW GET S-REG AND BIT50 GET HPIB ADDRESS STA B SAVE SZB,RSS IF ZERO, FORCE TO 35 STD35 LDB OCT35 JSB HPIBC AND CONF ALL COMMAND BYTES LDA DXTAD CALCULATE TABLE POINTERS ADA P62 STA DXTAR ADDR OF LAST WORD IN DXTAB STA DXTOK INA STA DXTAP LIMIT INDEX FOR TABLE SCANNING LDA RETAD ADA P62 STA RETAR ADDR OF LAST WORD IN RETAB STA RETOK INA STA RETAP LIMIT INDEX FOR TABLE SCANNING LDB DXTAD CLEAR DXT SET BIT15 EXCEP ON LAST LDA BIT15 STDXT STA B,I STORE 100000 IN DXTAB INB CPB DXTAR RSS LAST WORD : BIT15 MUST BE CLEAR JMP STDXT NOT LAST WORD WRITE AGAIN CLA STA B,I LDB RETAD CLEAR RETAB CLA STRXT STA B,I STORE 0'S EVERY RETAB WORD INB CPB RETAP FINISHED ? JMP INITS,I YES END INITS SBR JMP STRXT NOD! * *SBR SEND IFC ALL ADDR * AIFCL NOP LDA IFC IFC = 014000 JSB SNDEA,I LDA BIT12 BIT12 = 010000 JSB SNDEA,I JMP AIFCL,I * * SKP * * *SBR SEND IFC TO ONE ADDR * OIFCL NOP LDA IFC IFC = 014000 JSB SNDNA,I LDA BIT12 BIT12 = 010000 JSB SNDNA,I JMP OIFCL,I * *SBR TO EXEC POLLING+OK BIT CHECK * INOUT NOP POLL ALL ADDRESS JSB SNDEA,I LDA BIT14 JSB TESTA,I JMP INOUT,I E0144 JSB ERMS,I ERROR: NO OK DEF MS144 JMP INOUT,I * *SBR TO CONFIGURE HPIB COMMANDS % S-REG 4-0 * HPIBC NOP CONFIGURE HPIB COMMAND BYTES LDA M2 VERIFY 1 < ADDRESS < 36 ADA B SSA JMP HPIBF ADDR NOT > 1 ADA M28 SSA,RSS JMP HPIBF ADDR NOT < 36 LDA TLK35 AND NOC37 IOR B STA TLK35 CONFIGURE TLK N STA TLKXX ADA M1 STA TLK34 CONFIGURE TLK N-1 LDA LSN35 AND NOC37 IOR B STA LSN35 CONFIGURE LSN N STA LSNXX ADA M1 STA LSN34 CONFIGURE LSN N-1 ADA M1 STA LSN33 CONFIGURE LSN N-2 JMP HPIBC,I HPIBF HLT 72B ADDRESS NOT LEGAL JMP INITS+1 CORRECT BIT 5-0 * * * SKP * *SBR CONF DISPLAY ALL ADDRS * ADSCF NOP LDA LSN35 LSN35 = 010475 JSB SNDEA,I JMP ADSCF,I * *SBR CONF ONE DISPLAY * ODSCF NOP LDA LSN35 LSN35 = 010475 JSB SNDNA,I JMP ODSCF,I * *SBR CONF ALL ISP S * AMCCF NOP LDA LSN36 LSN36 = 010476 JSB SNDEA,I JMP AMCCF,I * *SBR CONF ONE ISP * OMCCF NOP LDA LSN36 LSN36 = 010476 JSB SNDNA,I JMP OMCCF,I * *SBR CONF ONE KEYBOARD * OKBCF NOP LDA TLK35 TLK35 = 010535 JSB SNDNA,I JMP OKBCF,I * *SBR UNLISTEN ONE ADDR * OULSN NOP LDA UNWm640LSN UNLSN = 010477 JSB SNDNA,I JMP OULSN,I * *SBR UNTALK ONE ADDR * UNTAK NOP LDA UNTLK UNTLK=010537 JSB SNDNA,I JMP UNTAK,I * SKP #6* *SBR SEND LF ONE ADDR * OLFED NOP LDA LFCOD JSB SNDNA,I JMP OLFED,I * *SBR TIMING STD * WATNG NOP LDA P250 JSB TMRR,I JMP WATNG,I * *SBR WAIT FOR FLAG * WTFLG NOP STB SCPAD SAVE TIME COUNT LDA M40 PRESET BLINK FOR OVERFLOW STA BLINK WTF2 SFC SC TEST CONTROLLER FLAG JMP WTFLG,I SET, THEN RETURN LDA P5 .005 SEC WAIT JSB TMRR,I MAX LINK FLAG IS 70 MS ISZ BLINK JMP *+5 SOS C OVERFLOW GADJET STO LDA M40 STA BLINK JSB SHRTN MUST WE ABORT ?? ISZ SCPAD DID IT TIMED OUT ?? JMP WTF2 NO, NOT YET ISZ WTFLG YES, BUMP RTN ADDR JMP WTFLG,I MS142 ASC 16,E142 HARDWARE FAILURE OR NO KEY ASC 16,PRESSED WITHIN DELAY,PRESS RUN/ * CLRS7 NOP SBR TO CLEAR SW-REG BIT 7 LIA SW AND NBIT7 OTA SW JMP CLRS7,I * SHRTN NOP SBR TEST SW BIT7 ABORT OPTION LDB BIT07 JSB SWRT,I RSS JMP SHRTN,I IOD44 CLC SC,C JMP ABORT,I * SKP * *SBR PROGRAMM. WAIT * WAITR NOP STA TIME SAVE TIME COUNT LDA P1000 JSB TMRR,I SOS C STO ISZ TIME JMP *-5 JMP WAITR,I * *SBR DETECT IF LAST INPUT IS TERMINATOR * TSTLF NOP LDA RETOK,I AND RBYTE MASK ONLY DATA RBYTE CPA LF LF = 000012 JMP *+3 LF PRESENT JSB + 1 ISZ TSTLF JMP TSTLF,I LF ABSENT JSB + 2 LDA STBYT LF, THEN TEST EOI IF 3070B SLA,RSS JMP TSTLF,I NO, 3070A RETURN LDA RETOK,I AND BT910 CPA BT910 JMP TSTLF,I OK, RETURN E0155 JSB ERMS,I NO EOI WITH TERMINATOR DEF MS155 JMP TSTLF,I * MS155 ASC 20,E155 NO EOI SENT ALONG WITH TERMINATOR/ * *SBR TAKE COUNT OF FIRST OK * TACNT NOP LDA FOKAD FIRST OKq ADDR SZA,RSS STB FOKAD STORE IN FOKAD ONLY FIRST TIME CPB FOKAD IS IT SAME ADDRESS ?? JMP *+3 E0153 JSB ERMS,I NOT THE SAME !! DEF MS153 ISZ WITNS BUMP OK NUMBER NOP JMP TACNT,I * * SKP * ********************************* **** SBR SEND TEST TITLE **** ********************************* * MESGC NOP STANDARD FOR EACH TEST LDA MESGC,I GET MESSAGE ADDRESS STA *+5 ISZ MESGC BUMP RETURN ADDRESS JSB MSGC,I SEND CR-LF DEF ZRTLF JSB MSGC,I SEND TITLE NOP JSB MSGC,I SEND CR-LF DEF ZRTLF JSB CLRS7 CLEAR ABORT BIT IN S-REG. JMP MESGC,I * *************************************************** **** SRQ CLEAR FOR ALL TERMINALS ON LOOP **** *************************************************** * ADSRQ NOP SERIAL POLL SUBROUTINE IOD36 CLC SC LDB SRTB1 STB SCPAD LDA B,I JSB SNDEA,I ALF,SLA,ALF IF STATUS BYTE, SAVE IT JMP DDSR1 NO, SKIP ALF,ALF RESTORE GOOD PLACE STA TEMP2 TEMP. SAVE AND BT910 VERIFY VALDA FOR STBYT CPA BIT10 JMP DDSR2 OK, SKIP LDA TSTN IF TST 13,15,16 DON'T WORRY CPA P11 IF NO VALDA ON LINK ADDR 77 JMP DDSR2 CPA P13 JMP DDSR2 CPA P14 JMP DDSR2 E0135 JSB ERMS,I NO VALDA IN SERIAL POLL DEF MS135 ANSWER FROM 3070 DDSR2 LDA TEMP2 RESTORE DATA AND RBYTE STA STBYT SAVE STATUS BYTE DDSR1 LDB SCPAD INB CPB SRTB2 IS IT FINISHED ?? JMP ADSRQ,I JMP IOD36+2 * SKP * HCYES NOP RTN JSB+2 IF NOT 30HC LDA STBYT RTN JSB+1 IF 30HC SLA,RAR RSS SLA,RSS ISZ HCYES JMP HCYES,I * HCREL NOP RTN JSB+2 IF 30HC+RELAY JSB HCYES RTN JSB+1 IF NOT 30HC - RSS JMP HCREL,I RAR,SLA ISZ HCREL JMP HCREL,I * HED ***** 3070 DIAGN IO & TESTS TABLES ***** * * ORG ZCEND * * IODP EQU * DEF WTF2 DEF IOD14 DEF IOD15 DEF IOD16 DEF IOD17 DEF IOD18 DEF IOD19 DEF IOD20 DEF IOD21 DEF IOD22 DEF RECVE DEF IOD24 DEF IOD25 DEF IOD26 DEF PHINP DEF IOD29 DEF IOD30 DEF IOD31 DEF INP DEF IOD33 DEF IOD34 DEF IOD35 DEF IOD36 DEF IOD43 DEF IOD44 DEC -1 * SKP TSTD EQU * A-REG BIT DEF TST00 BASIC I\O TEST 0 DEF TST01 CONTROLLER TEST 1 DEF TST02 COMMUNICATION MODULE TEST 2 DEF TST03 SELF-TEST TEST 3 DEF TST04 GENERAL FUNCTIONS TEST 4 DEF TST05 ANNUNCIATOR LIGHTS TEST 5 DEF TST06 NUMERIC DISPLAY TEST 6 DEF TST07 NUMERIC KEYBOARD TEST 7 DEF TST10 SPECIAL FUNCTION KEYS TEST 8 DEF TST11 PRINTER TEST 9 DEF TST12 MULTIFONCTION READER TEST 10 DEF TST13 ADDRESS TEST 11 DEF TST14 CABLE QUALITY TEST 12 DEF TST15 EXTENDED CABLE/CONTROLLER TEST 13 DEF TST16 TOTAL INSTALLATION TEST 14 DEF TST17 SIGNATURE STIMULI GENERATION 15 DEC -1 HDMS EQU * ASC 18, START 92900B SUBSYSTEM DIAGNOSTIC// * * * * HED ***** CONTROLLER TEST ***** ORG 4000B * ************************************* **** CONTROLLER TEST (ALONE) **** ************************************* * TST01 EQU * CONTROLLER TEST CNTLR NOP ***************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP kCNTLR,I H0027 JSB MESGC DEF MS027 H0030 JSB MSGH,I DEF MS030 WARNING ALL TERMINALS OFF IOD35 CLC SC STOPS EVENTUALLY THE CONTROLLER JSB INITS INIT SBR FOR TABLES & POINTERS CLA,INA NETAB STA TEMP1 SAVE ABS TABLE REF STA TEMP0 SAVE VAR TABLE REF CMA,INA MAKE NEGATIVE ADA DATAD CALCULATE POINTER ADA P90 IN DATA TABLE STA TEMP2 LDA M63 SET LIMIT FOR DATA TRANSFER STA CNTR LDB DXTAD BOUGL LDA TEMP2,I GET DATA CPA M1 TEST IF END JMP ENVO1 YES, END OF PATTERN STA B,I STORE IN DXTAB INB BUMP DEST ADDR ISZ TEMP2 BUMP SRCE ADDR ISZ CNTR DXTAB FULL(63 WORDS) ? JMP BOUGL NO, CONTINUE LDA P63 SET TEMP0 TO 63 STA TEMP0 LIMIT VAR TABLE REF IS 63 ENVO1 CCB ADB DXTAD PREPARE SENDING ADB TEMP0 FOR N TERMINALS LDA B,I REMOVE BIT15 IN LAST DXT WD AND NBT15 STA B,I ADB CAPA. SET LIMIT IN RETAB STB RETAP CLA IN ORDER TO USE ONLY DXTAB JSB SNDEA,I CALL IN\OUT ROUTINE LDA DXTAD STA TEMP3 LDB RETAD COMPARE NOW LOAD LDA B,I XOR TEMP3,I SZA SHOULD BE EQUAL JSB ERRO5 ALMOST ONE BIT CHANGED INB CPB RETAP EQUAL, IS IT LAST ? JMP CUITE YES ISZ TEMP3 JMP LOAD GO TO NEXT COMPARISON CUITE LDA TEMP1 ADJUST COUNTERS CPA P90 FOR NEW TABLE JMP NDT01 = INA # THEN INCREMENT JMP NETAB CONTINUE TEST ERRO5 NOP RAM CONTENT ERROR TREATMENT STB SCPAD LDB RETAD CMB,INB INB ADB SCPAD E0036 JSB ERMS,I DIFFERENCE INTO RAM CONTENT DEF MS036 LDB TEMP3,I LDA SCPAD,I E0037 JSB ERMS,I A- & B-REG CONTENTS OUTPUT DEF MS037 LDB SCPAD JMP ERRO5,I E0035 JSB ERMS,I BIT 15 SET ON LAST DXT WORD DEF MS035 JMP NDT01 E0034 JSB ERMS,I FLAG SH'D BE SET (OUTPUT) DEF MS034 JMP NDT01 E0032 JSB ERMS,I FLAG NOT SET AFTER DELAY DEF MS032 JMP NDT01 E0033 JSB ERMS,I FLAG SH'D BE SET (INPUT) DEF MS033 NDT01 NOP H0031 JSB MSGH,I DEF MS031 WARNING ONE TERMINAL ON NOW JMP CNTLR,I * MS027 ASC 12,TEST01 CONTROLLER TEST/ MS035 ASC 22,E035 BIT15 SET IN LAST TRANSFER TABLE WORD/ MS034 ASC 21,E034 FLAG NOT SET.SHOULD BE SET (OUTPUT)/ MS032 ASC 20,E032 FLAG NOT SET WITHIN REQUIRED TIME/ MS033 ASC 20,E033 FLAG NOT SET.SHOULD BE SET (INPUT)/ MS036 ASC 17,E036 DATA RECEIVED DIFFERENT FROM ASC 16,DATA SENT(B=RAM ADDR),PRESS RUN/ MS037 ASC 17,E037 DATA RECEIVED DIFFERENT FROM ASC 19,DATA SENT A=RECEIVED,B=SENT,PRESS RUN/ MS030 ASC 23,H030 TERMINALS ON LINK MUST BE OFF,PRESS RUN/ MS031 ASC 17,H031 END TEST 01:SET ONE TERMINAL ASC 17,ON WITH ADDR 77 OCTAL, PRESS RUN/ * * HED ***** ISP CHIP TEST ***** * ************************************* **** ISP CHIP TEST **** ************************************* * TST02 EQU * ISP CHIP TEST MOCOM NOP *************** H0040 JSB MESGC PRINT TEST TITLE DEF MS040 JSB INITS INIT SBR FOR TABLES & POINTERS JSB AIFCL IFC FOR ALL ADDRESSES JSB ADSRQ SERIAL POOL JSB ADSCF CONF DISPLAY ON ALL ADDRS LDA UTDAT INIT CURRENT INSTRUCTION REPET STA TEMP0 JSB SNDEA,I OUTPUT INSTRUCTION LDB M62 STB CNTR LDB RETAD LDA TEMP0 IOR BIT15 GO020 CPA B,I RSS JSB REPRT ERROR: REPORT TO OPERATOR INB ISZ CNTR JMP GO020 LDA TEMP0 IOR BIT14 CPA B,I RSS JSB REPRT ERROR: REPORT TO OPERATOR JSB SHRTN BIT07 OPTION TO END TEST ?? SOS C OViERFLOW GADJET STO CLA,CME EXECUTE AN INPUT JSB INOUT LDA TEMP0 PREPARE NEXT INSTRUCTION INA CPA IFC IS IT LAST INSTRUCTION ? RSS YES JMP REPET NO CLA LAST INPUT JSB INOUT NDT02 JMP MOCOM,I MS040 ASC 17,TEST02 COMMUNICATION MODULE TEST/ * * SKP * * * REPRT NOP STB TEMP2 SAVE DXTAB POINTER CMB,INB CALCULATE TERMINAL ADDR ADB RETAD INB E0140 JSB ERMS,I TELL ERROR ORIGIN DEF MS140 LDB TEMP2,I GET EXPECTED DATA E0141 JSB ERMS,I TELL ERROR DATA DEF MS141 A-REG RECEIVED DATA LDB TEMP2 RESTORE POINTER JMP REPRT,I * * * * HED ***** TERMINAL FUNCTIONS TEST ***** ******************************************* **** TERMINAL FUNCTIONS TEST **** ******************************************* * TST04 EQU * TERMINAL FUNCTIONS TEST TRMTS NOP ************************* LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP TRMTS,I H0041 JSB MESGC PRINT TEST TITLE DEF MS041 LDA RSTAD SET RETURN POINT STA DEBUT FOR SNDNG SBR JSB INITS INIT SBR FOR TABLES & POINTERS JSB OIFCL IFC FOR ADDRESS 63 JSB ADSRQ JSB HCYES IF 30HC, JMP TO SRQ KEY TEST JMP H0047 JSB OKBCF CONF KEY BOARD ON ADDR63 H0042 JSB MSGH,I KB MUSTBE CONF & DISPLAY CLEAR DEF MS042 JSB OIFCL SEND IFC ON ADDR 63 H0043 JSB MSGH,I KB MUST BE DECONFIGURED DEF MS043 LDA CAP.E TRY TO WRITE JSB SNDNA,I ON DECONFIGURED DISPLAY JSB SNDNA,I JSB OLFED SEND A LINE FEED ON ADDR 63 H0044 JSB MSGH,I DISPLAY MUSTBE ALWAYS CLEAR DEF MS044 RSTAR JSB OMCCF CONF MOCOM ON ADDR 63 JSB OKBCF CONF KEY BOARD ONADDR 63 LDA LIGNA INIT LINE BUFFER POINTERS STA TEMP0 FOR CHARIACTERS INPUTTING ADA P17 STA TEMP1 NEWIN CLA READ A CHARACTER JSB SNDNA,I JSB TSTLF IS IT A LINE FEED ? JMP LFOCC OUI LDA RETOK,I STA TEMP0,I STORE THE CHARACTER LDA TEMP0 INCR LINE POINTER INA CPA TEMP1 IS IT LAST ? JMP LFOCC YES STA TEMP0 NO, THEN STORE POINTER JMP NEWIN LFOCC JSB UNTAK DECONF. KEYBOARD LDA LFCOD STA TEMP0,I STORE LINE TERMINATOR LDA TEMP0 ACTUALISE LINE LIMIT INA STA TEMP1 H0045 JSB MSGH,I DISPLAY MUSTBE ALWAYS CLEAR SKP * DEF MS045 JSB ODSCF CONF DISPLAY ON ADDR 63 LDA LIGNA INIT LINE POINTER IN ORDER STA TEMP0 TO OUTPUT LINE NOW NEWUT LDA TEMP0,I AND RBYTE IOR BIT12 JSB SNDNA,I LDA TEMP0 INC LINE POINTER INA CPA TEMP1 IS IT LAST TO BE OUTPUT JMP H0046 JMP NEWUT-1 H0046 JSB MSGH,I ORDER TO TYPE IN DEF MS046 CHARACTERS JSB AIFCL SEND IFC TO ALL ADDR JSB ODSCF CONF DISPLAY JSB OKBCF CONF KEYBOARD CLA JSB INDXA,I JSB SPEXC INPUT CHARACT WITH RSS DECONFIG COMMUN MODULE JMP *+3 SHD NOT RECEIVE ANYTHING E0051 JSB ERMS,I DEF MS051 ERROR CHARACT RECEIVED IOD34 CLC SC STOPS CONTROLLER'S WAIT JSB AIFCL SEND IFC H0047 JSB MSGH,I DEF MS047 ORDER TO PRESS SRQ CLA SET INPUT PHASE JSB INDXA,I JSB SPEXC JMP *+4 SRQ OK H0052 JSB ERMS,I DEF MS052 NO SRQ JMP IOD34 LDA DXTOK,I VERIFY BIT SRQ CPA SRQEX SRQEX = 041000 JMP H1052+2 OK FOR SRQ H1052 JSB ERMS,I DEF MS052 NO SRQ MESSAGE JSB ADSRQ GO & CLEAR SRQ ON TERMINAL LDA CAP.E IOR BIT13 INSERT IDLE BIT JSB INDXA,I JSB SPEXC JMP E0053 AERROR : OK WITH IDLE ON IOD33 CLC SC STOPS CONTROLLER'S WAIT H0050 JSB MSGC,I DEF MS050 END TERMINAL FUNCTIONS TEST JMP TRMTS,I E0053 JSB ERMS,I DEF MS053 IDLE STATE FAILURE * SKP * JMP H1052+3 * RSTAD DEF RSTAR * SPEXC NOP SPEC EXCHG SBR FOR FLG IOD25 STC SC,C WAITING LDB DXTAD PHOUT LDA B,I OUTPUT DXTAB ON CONTROLLER IOD26 OTA SC,C SSA,RSS JMP *+3 END OF TABLE INB JMP PHOUT LDB TM15S START 15 SEC WAIT JSB WTFLG JMP *+3 ISZ SPEXC JMP SPEXC,I TIME OUT RTN JSB+2 LDB DXTAD PHINP LIA SC,C GET DXTAB FROM CONTROLLER STA B,I SSA,RSS JMP *+3 END OF TABLE INB JMP PHINP JMP SPEXC,I NORMAL EXIT RTN JSB+1 * MS041 ASC 16,TEST04 TERMINAL FUNCTIONS TEST/ MS042 ASC 16,H042 ENSURE KEYBOARD IS ENABLED, ASC 15, & DISPLAY CLEARED, PRESS RUN/ MS043 ASC 22,H043 ENSURE KEYBOARD IS DISABLED, PRESS RUN/ MS044 ASC 18,H044 PRESS RUN, ENSURE DISPLAY STAYS ASC 18, CLEAR WHILE TYPING CHARACT.+ENTER/ MS045 ASC 18,H045 ENSURE DISPLAY IS CLEAR & PRESS ASC 17, RUN TO DISPLAY CHARACT. TYPED IN/ MS046 ASC 22,H046 PRESS RUN, PRESS ANY KEY WITHIN 15 SEC/ MS051 ASC 18,E051 SRQ OR CHARACTER RECEIVED WITH ASC 9,ISP DECONFIGURED/ MS047 ASC 19,H047 PRESS RUN, PRESS SERVICE REQUEST ASC 16,KEY (GOLDEN KEY) WITHIN 15 SEC/ MS052 ASC 19,E052 NO SERVICE REQUEST DURING DELAY/ MS050 ASC 19,H050 TERMINAL FUNCTIONS TEST COMPLETE/ MS053 ASC 18,E053 ACK RECEIVED WHEN NOT ALLOWED/ * HED ***** ANNUNCIATOR LIGHTS TEST ***** * ****************************************** **** ANNUNCIATOR LIGHTS TEST **** ****************************************** * TST05 EQU * ANNUNCIATOR LIGHTS TEST ANLIT NOP ************************* JSB INITS STD INIT JSB AIFCL IFC FOR ADDR 77 JSB ADSRQ SERIAL POLL . JSB HCYES IF 30HC, TEST IF RELAY OPTION RSS JMP *+3 JSB HCREL JMP ANLIT,I H0054 JSB MESGC PRINT TEST TITLE DEF MS054 LDB UTCMD IF NO HLT OPTION, SKIP THIS JSB SWRT,I JMP *+3 H0055 JSB MSGH,I HLT TO PROMPT OPERATOR DEF MS055 JSB ODSCF CONF DISPLAY ON ADDR 63 LDA ORDRT LOAD FIRST CODE SNDLP JSB SNDNA,I LIT AN ANNUNC LIGHT JSB WATNG CCA PREPARE NEXT CODE ADA COBAS STA COBAS JSB SNDNA,I SPENT SAME ANNUNC LIGHT JSB WATNG JSB HCREL IF 30HC, STOP AFTER 4 FIRST JMP *+4 LDA COBAS CPA RL4OF JMP ENDLP YES, EXIT LOOP LDA COBAS GET INSTR CODE CPA TILDA COMPARE WITH LAST CODE JMP ENDLP YES CONTINUE ADA P3 PREPARE NEXT CODE STA COBAS JMP SNDLP ENDLP LDA ORDRT LIT ALL ANNUNC LIGHTS ALLIT STA COBAS JSB SNDNA,I LIT ONE LDA COBAS PREPARE NEXT CODE ADA P2 CPA DEL COMPARE WITH LAST CODE RSS JMP ALLIT JSB WATNG CCA SPENT AN ANNUNC LIGHT ADA ORDRT AND LIT IT AGAIN STA COBAS SENDG JSB SNDNA,I JSB WATNG JSB HCREL IF 30HC, STOP AFTER 4 FIRST JMP *+4 LDA COBAS CPA RL4ON JMP GO4XX YES, CLEAR NOW LDA COBAS PREPARE INA NEXT STA COBAS CODE CPA TILDA COMPARE WITH LAST CODE RSS JMP SENDG LDA STBYT IF 3070B USE TILDA SLA TO CLEAR ALL PROMPTING LIGTHS JMP GO4XX CCA NOW CLEAR ALL LIGHTS ADA ORDRT ALSPT STA COBAS JSB SNDNA,I CLEAR ONE LDA COBAS PREPARE ADA P2 NEXT CPA TILDA LAST ? CODE JMP ANLIT,I JMP ALSPT GO4XX LDA TILDA JSB SNDNA,I JMP ANLIT,I MS054 ASC 15:,TEST05 PROMPTING LIGHTS TEST/ MS055 ASC 21,H055 PRESS RUN, CHECK ACCORDING TO MANUAL/ * * * * HED ***** SUBROUTINES FOR TEST (FOLLOWING) ***** * ************************************ **** SBR TEST BYTE PRESENT **** ************************************ * TSTER NOP STA SCPAD LDB RETAD NEWTR LDA B,I AND RBYTE XOR SCPAD INB CPB RETAP JMP NEWT1 SZA JMP NEWTR E0154 JSB ERMS,I ERROR ON BYTE ORIGIN NT LST TERMINAL DEF MS154 JMP NEWTR NEWT1 SZA,RSS JMP TSTER,I JSB UNTAK UNTALK KEYBOARD ISZ TSTER LDA DEL PRINT OUT " EE " PATTERN JSB SNDNA,I LDA CAP.E JSB SNDNA,I JSB SNDNA,I CCA JSB WAITR LDA DEL JSB SNDNA,I JMP TSTER,I * * * * MS154 ASC 22,E154 DATA RECEIVED FROM UNEXPECTED ADDRESS/ * * * * HED STIMULI GENERATION TEST ****************************** **** SIG. ANAL. TEST **** ****************************** * * * * TST17 EQU * NOP JSB INITS STD INIT JSB CLRS7 CLEAR ABORT BIT LDA IFC OUTPUT IFC JSB SNDEA,I SIG01 LDA BIT12 OUTPUT 0 JSB SNDEA,I LDA LSN36 OUTPUT ATN 76 JSB SNDEA,I CLA INPUT FROM HPIB JSB SNDEA,I LDA IFC OUTPUT IFC JSB SNDEA,I JSB SHRTN MUST WE STOP ?? JMP SIG01 NO, CONTINUE * * HED ***** DISPLAY TEST ***** * *********************************** **** DISPLAY TEST **** *********************************** * ORG 6000B * TST06 EQU * DISPLAY TEST DPLAY NOP ************** JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP DPLAY,I H0056 JSB MESGC DEF MS056 LDB UTCMD JSB SWRT,I JMP *+3 H0057 JSB 9MSGH,I DEF MS057 JSB ODSCF CONF DISPLAY ON ADDR 63 LDA CODAD INIT POINTERS ADA P14 FOR STA TEMP0 CODES AND LDA M16 STA TEMP1 DIGITS LDA CDTAB+8 FULL 8 LINE OUTPUT JSB SNDNA,I ISZ TEMP1 JMP *-2 LDA M15 VARIABLE LENGTH LINE OUTPUT STA TEMP1 JSB WATNG JSB OLFED BUCL1 LDA TEMP1 STA TEMP2 LDA CDTAB+11 OUTPUT "-" N TIMES JSB SNDNA,I ISZ TEMP2 JMP *-2 LDA CDTAB+8 THEN OUTPUT 8 JSB SNDNA,I JSB WATNG LDA DEL CLEAR DISPLAY JSB SNDNA,I ISZ TEMP1 SHORTEN LINE LENGTH JMP BUCL1 LDA CDTAB+8 OUTPUT LAST 8 JSB SNDNA,I JSB WATNG JSB WATNG LDA DEL CLEAR DISPLAY AGAIN JSB SNDNA,I LDA M15 OUTPUT FULL "." LINE STA TEMP2 BUCL2 LDA D.PNT JSB SNDNA,I LDA SPACE JSB SNDNA,I ISZ TEMP2 JMP BUCL2 CCA JSB WAITR JSB OLFED SEND LINE FEED LDA CODAD BUCL3 STA TEMP1 OUTPUT ALL DISPLAYABLE CHARACTERS LDA TEMP1,I JSB SNDNA,I LDA TEMP1 INA CPA TEMP0 IS IT THE LAST ?? RSS JMP BUCL3 CCA JSB WAITR JSB OIFCL SEND IFC JSB ODSCF CONFIG DISPLAY JSB OULSN UNLISTEN DISPLAY LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP NDT05 H0060 JSB MSGH,I DISPL MUSTBE CLEAR & REMAIN NOW DEF MS060 LDA CAP.E SEND A CHARACTER JSB SNDNA,I JSB OLFED AND A LINE FEED H0061 JSB MSGH,I DISPLAY MUST BE CLEAR END TEST DEF MS061 NDT05 JMP DPLAY,I MS056 ASC 11,TEST06 DISPLAY TEST/ MS057 ASC 21,H057 PRESS RUN, CHECK ACCORDING TO MANUAL/ MS060 ASC 15,H060 ENSURE DISPLAY IS CLEARED ASC 13, & STAYS CLEAR, PRESS RUN/ MS061 ASC 23,H061 IF DISPLAY NOT CLEAR: ERROR; PHFBRESS RUN/ * * * "H HED ***** KEYBOARD KEYS TEST ***** * ******************************** **** KEYBOARD TEST **** ******************************** * TST07 EQU * KEYBOARD TEST KBORD NOP *************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP KBORD,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP KBORD,I H0062 JSB MESGC DEF MS062 H0063 JSB MSGH,I DEF MS063 LDA KBTAD INIT KB LIMIT POINTRS STA TEMP0 INIT KEY CODE POINTER ADA P14 STA TEMP1 RSS JSB UNTAK JSB ODSCF CONF DISPLAY ON ADDR 63 JSB OMCCF CONF COMM MODULE ON ADDR 63 TRYAG JSB INDIC PRINT OUT CHARACTER TO BE TYPED IN JSB OKBCF CONF KEYBOARD ON ADDR 63 CLA READ JSB SNDNA,I IT LDA TEMP0,I TEST THIS JSB TSTEA,I CHARACTER RSS GOOD JMP TRYAG-3 BAD => TRY AGAIN JSB BOUNC TEST ANTI-BOUNCING JSB UNTAK UNTALK KEYBOARD LDA TEMP0,I IOR BIT12 CPA CDTAB+12 IF "." SEND ONE MORE SPACE RSS JMP *+3 LDA SPACE JSB SNDNA,I LDA SPACE JSB SNDNA,I SEND TWO SPACES JSB SNDNA,I LDA TEMP0,I OUTPUT CHARACTER IOR BIT12 JUST RECEIVED JSB SNDNA,I JSB PNTSP JSB SNDNA,I JSB OLFED AND A LINE FEED LDA TEMP0 INC POINTER INA FOR KEY BOARD CODE INPUT CPA TEMP1 IS IT LAST ? JMP GO6XX YES GO TO END TEST STA TEMP0 CCA PREPARE LITTLE TIMING JSB WAITR JMP TRYAG GO6XX LDA STBYT IF 3070B, TEST MODE 2 SLA,RSS JMP KBORD,I LDA M2 SET PASS COUNTER TO STA TEMP2 TEST TWO TIMES MODE #2 GO163 JSB UNTAK OUTPUT UNTALK JSB ODSCF DISPLAY LISTENER U LDA DEL JSB SNDNA,I CLEAR DISPLAY JSB BUZZA,I PROMPT OPERATOR LDA MLAC2 CONN(2) SECONDARY CMD JSB SNDNA,I JSB OULSN OUTPUT UNLISTEN LDA M10 SET 10 SEC WAIT JSB WAITR TO ALLOW KEYBOARD INPUT LDA KBTAD SET TABLE POINTER STA TEMP0 JSB OMCCF CONF ISP BECAUSE OF UNL JSB OKBCF CONFIGURE KEYBOARD TO GET BUFFER RSS SKIP FIRST TIME GO165 ISZ TEMP0 BUMP POINTER CLA JSB SNDNA,I READ ONE CHARACTER AND RBYTE GET BYTE ONLY LDB TEMP0,I GET GOOD CHAR CPA B IS IT EXPECTED CHAR. ?? JMP GO165 YES, CONTINUE CPA LF NO,IS IT TERMINATOR THEN ?? JMP *+4 YES, GO FOR 2ND PASS OR END E0161 JSB ERMS,I NO, SEQUENCE ERROR OR ELSE DEF MS161 JMP GO163 RESTART ISZ TEMP2 BUMP PASS COUNTER JMP GO163 CONTINUE JSB AIFCL CLEAR JMP KBORD,I MS062 ASC 11,TEST07 KEYBOARD TEST/ MS063 ASC 21,H063 PRESS RUN, CHECK ACCORDING TO MANUAL/ * * HED ***** SPECIAL FUNCTION KEYS TEST ***** * ********************************************* **** SPECIAL FUNCTIONS KEYS TEST **** ********************************************* * TST10 EQU * SPECIAL FUNC KEYS TEST SFKEY NOP ************************ LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP SFKEY,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP SFKEY,I H0064 JSB MESGC DEF MS064 H0065 JSB MSGH,I DEF MS065 LDA M2 SET PASS COUNTER STA CNTR GO07Y LDA CDGEN INIT CODE STA TEMP2 GENERATOR LDA FKTAD INIT POINTER FOR STA TEMP0 FUNCT KEY CODES ADA P9 LDB STBYT BUMP CODE ACCORDING TO A\B SLB INA STA TEMP1 RSS )JSB UNTAK JSB OMCCF CONF COMM MODULE JSB ODSCF CONF DISPLAY ON ADDR 63 TRYGN JSB SHOW LIT ANNUNC LIGHT=>SFK TO PRESS JSB OKBCF CONF KEYBOARD CLA READ FUNC KEY CODE TYPED JSB SNDNA,I LDA TEMP0,I COMPARE WITH JSB TSTEA,I CODE ORDER RSS OK JMP TRYGN-3 NOT OK LDA STBYT IF NOT 3070B & 2ND PASS SLA,RSS DON'T TEST TERMINATOR + EOI JMP GO07X LDA M2 CPA CNTR JMP GO07X CLA READ TERMINATOR JSB SNDNA,I JSB TSTLF TEST IF OK (LF+EOI) JMP *+3 YES, CONTINUE E0066 JSB ERMS,I NOT TERMINATOR TRANSMITTED DEF MS066 AFTER SKF CODE GO07X JSB BOUNC TEST ANTI-BOUNCING JSB UNTAK UNTALK KEYBOARD ISZ TEMP2 INC CODE GENERATOR LDA TEMP0 INC INA CODE CPA TEMP1 INDEX JMP *+3 LAST FUNC KEY STA TEMP0 NEXT FUNC KEY JMP TRYGN LDA STBYT IF 3070B TEST FOR 2ND PASS SLA,RSS JMP END07 LDA TILDA CLEAR LED JSB SNDNA,I WITH GENERAL CLEAR CODE ISZ CNTR 2ND PASS ?? JMP GO07Y JMP SFKEY,I RETURN NOW END07 LDA NPL15 CLEAR LED 15 JSB SNDNA,I JMP SFKEY,I MS064 ASC 18,TEST10 SPECIAL FUNCTION KEYS TEST/ MS065 ASC 21,H065 PRESS RUN, CHECK ACCORDING TO MANUAL/ MS066 ASC 20,E066 NOT TERMINATOR CODE SENT AFTER SFK/ * BOUNC NOP TEST KEYBOARD ANTI-BOUNCING CLA EXEC READ WITH COMPLETION JSB SNDEA,I AND BT910 GET VALDA+SRQ SZA,RSS SOMETHING GOOD ?? JMP BOUNC,I NO, RETURN E0067 JSB ERMS,I YES, TELL OPERATOR DEF MS067 JMP BOUNC,I RETURN NOW * MS067 ASC 16,E067 KEYBOARD ANTIBOUNCING FAIL/ * * HED ***** ADDRESS TEST ***** * ******************************* **** ADDRESS TEST **** ****************C0*************** * TST13 EQU * ADDRESS TEST ADRTS NOP ************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP ADRTS,I H0120 JSB MESGC DEF MS120 JSB INITS INIT SBR FOR TABLES & POINTERS JSB AIFCL IFC FOR ALL JSB ADSRQ LDA ORDRA ADA P40 AND STA TEMP1 POINTER LIMIT JSB ADSCF CONF ALL DISPLAYS LDA BGINA SPECIFY RETURN ADDR STA DEBUT FOR VRIFY SBR H0121 JSB MSGH,I DEF MS121 SET HA YOU WANT TO TEST PRESS RUN JMP BGINN H0122 JSB SHRTN BIT7 OPTION TO END TEST ? JSB MSGH,I 1 OK : ADDR IN AREG SET HA YOU WANT DEF MS122 TO TEST PRESS RUN OR SET SREG BIT7 BGINN LDA ORDRA RESET POINTER STA TEMP0 LDA M121 STA TEMP2 INIT TDL COUNTER WITH -121 JSB INIWF INIT PROPER COUNTERS LDA LFCOD JSB SNDEA,I SEND A CHARACTER JSB VRIFY VERIFY OK NUMBER STA VARIA STORE OK ORIGIN JSB PRINT PRINT IT OUT BCLAG JSB INIWF INIT PROPER COUNTERS LDA TEMP0,I SEND A VARIABLE CHARACTER JSB SNDEA,I JSB VRIFY VERIFY OK NUMBER CPA VARIA COMPARE WITH FIRST ORIGIN JMP *+5 LDB VARIA E0123 JSB ERMS,I OK ADDR VART'N:A ACTUAL,B PREVIOUS DEF MS123 JMP BGINN PRESS RUN ISZ TEMP2 SAME ADDR THEN INCR TDL COUNTER JMP NWORD LDA M121 STA TEMP2 INIT TDL COUNTER LDA VARIA A REG = OK ADDR JMP H0122 GO & ASK FOR NEW ADDR TEST NWORD LDA TEMP0 INCR CHARACTER POINTER INA CPA TEMP1 IS IT LAST ? LDA ORDRA YES THEN RESET STA TEMP0 NO, THEN STORE BOTH CASES JMP BCLAG NDT13 JMP ADRTS,I MS120 ASC 11,TEST13 ADDRESS TEST/ MS121 ASC 13,H121 SET TERMINAL ADDRESS ASC 14,YOU WANT TO TEST,PRESS RUN/ MS122 ASC 12,H122 TEST OK(AREG=ADDR). ASC 16, CHANGE TERMINAL ADDR,PRESS RUN/ MS123 ASC 15,E123 TERMINAL ADDR VARIATION: ASC 16,A ACTUAL, B EXPECTED; PRESS RUN/ * HED ****** CABLE QUALITY TEST ****** * ************************************ **** CABLE QUALITY TEST **** ************************************ * TST14 EQU * CABLE QUALITY TEST TOTRS NOP ******************** LDB BIT12 JSB SWRT,I BIT12 OPTION ? JMP TOTRS,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP TOTRS,I H0124 JSB MESGC DEF MS124 LDA ORDRA INIT PHASE FOR THIS TEST STA TEMP0 ADA P40 STA TEMP1 CLA STA TEMP2 COUNTER FOR "NOT OK" STA TEMP3 COUNTER FOR TOTAL ERROR NUMBER LDA M1000 STA TEMP4 INIT RATE COUNTER LDA P63 STA VARIA OK ADDR MUST BE 63 (77 OCTAL) RESET JSB AIFCL SEND IFC TO ALL ADDRS JSB ADSCF CONF DISPLAY ON ALL ADDRS JSB CALCU PRINT OUT RETRANS RATE & CUMULATED ERROR LDB BIT08 JSB SWRT,I BIT8 OPTION ? JMP BEGIN H0125 JSB MSGH,I DEF MS125 SET HA 63 (77OCTAL) PRESS RUN * * BEGIN JSB INIWF INIT PROPER COUNTERS JSB SHRTN BIT7 OPTION TO END TEST ? ISZ TEMP4 INCR TDL COUNTER JMP *+5 LDA M1000 PRESET TDL COUNTER STA TEMP4 WITH -1000 JSB ADSCF CONF DISPLAY (IF TERM OFF) JSB CALCU PRINT OUT LAST RESULTS LDA TEMP0,I JSB SNDEA,I SEND NEW CHARACTER JSB VERFA,I VERIFY OK NUMBER CPA VARIA AND OK ORIGIN JMP *+5 LDB VARIA E0126 JSB ERMS,I OK ADDR VARIATION SHD BE 63 (77OCT) DEF MS126 ACTUAL IS IN AREG JMP RESET PRESS RUN LDA TEMP0 NO VARIATION PREPARE NEXT CODE CME,INA CPA TEMP1 IS IT LAST ? LDA ORDRA YES RESET NEEDED STA TEMP0 NO, STORE IN BOTH CAGSES JMP BEGIN NDT14 JMP TOTRS,I MS124 ASC 14,TEST14 CABLE QUALITY TEST/ MS125 ASC 13,H125 SET TERMINAL ADDRESS ASC 12,TO 77 OCTAL, PRESS RUN/ MS126 ASC 15,E126 TERMINAL ADDR VARIATION: ASC 16,A ACTUAL, B EXPECTED; PRESS RUN/ * * * * * HED ***** EXTENDED CABLE/CONTROLLER TEST ***** * ******************************************* **** CONTROLLER RESYNCHRO TEST **** ******************************************* * TST15 EQU * EXTEND CABLE\CONTROLLER TEST CINST NOP ****************************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP CINST,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP CINST,I H0127 JSB MESGC DEF MS127 JSB ADSCF CONF DISPLAY ON ALL ADDRSS LDA CONFA SPECIFY RETURN ADDR STA DEBUT FOR VRIFY SBR H0130 JSB MSGH,I SET HA YOU WANT TO TEST PRESS RUN DEF MS130 CONFG JSB SHRTN BIT7 OPTION TO END TEST ? JSB AIFCL RESET ALL LINK TERMINALS JSB ADSCF CONF DISPLAY ON ALL ADDRSS JSB AMCCF CONF COMM MODULE ON ALL ADDRSS JSB INIWF INIT PROPER COUNTERS LDA LFCOD SEND A CHARACTER JSB SNDEA,I TO IDENTIFY OK ORIGIN JSB VRIFY VERIFY OK NUMBER & ORIGIN STA VARIA STORE OK ORIGIN STA TEMP0 STORE IT AGAIN CCA CALCULATE ADA TEMP0 OK ADDR ADA DXTAD IN STA DXTOK DXTAB CCA CALCULATE ADA TEMP0 OK ADDR ADA RETAD IN STA RETOK RETAB JSB PRINT PRINT OUT OK ORIGIN FOUNDED * * BCLAJ JSB INIWF INIT PROPER COUNTERS LDA LIGNA INIT LINE POINTERS STA TEMP0 ADA P17 STA TEMP1 JSB OKBCF CONF KBOARD ON ADDR. NWINP CLA READ A CHARACTER JSB SNDNA,I JSB TSTLF IS IT A LINE F >EED ? JMP LFDOC YES LDA RETOK,I NO STORE IT STA TEMP0,I LDA TEMP0 INCR INA LINE CPA TEMP1 LIMIT? POINTER JMP ENBUF YES TREAT IT STA TEMP0 NO STORE IT JMP NWINP ENBUF JSB UNTAK UNTALK KEYBOARD LDA LFCOD JSB SNDNA,I RSS LFDOC JSB UNTAK DECONF KEYBOARD LDA LFCOD STORE A LF STA TEMP0,I LDA TEMP0 INA ACTUALISE LINE LIMIT STA TEMP1 LDA LIGNA STA TEMP0 INIT LINE POINTER FOR NEW SEQUENCE NWOUT LDA TEMP0,I AND RBYTE TAKE ONLY DATA RBYTE IOR BIT12 CONF FOR OUTPUT JSB SNDNA,I & SEND IT LDA TEMP0 INCR INA LINE CPA TEMP1 LIMIT? POINTER JMP FOLOW YES STA TEMP0 NO, STORE IT JMP NWOUT FOLOW CCA LITTLE WAITING JSB WAITR JMP CONFG NEXT EXCHANGE NDT15 JMP CINST,I MS127 ASC 19,TEST15 EXTENDED CABLE\CONTROLLER TEST/ MS130 ASC 13,H130 SET TERMINAL ADDRESS ASC 12,(SEE MANUAL), PRESS RUN/ * * * * HED ***** SUBROUTINES FOR TEST (FOLLOWING) ***** * ********************************************** **** SBR SEND PATTERN ON ALL ADRESSES **** ********************************************** * SNDER NOP AND NB154 PURGE BITS 15 & 14 STA COBAS SAVE PATTERN IOD14 STC SC,C LDB DXTAD PREPARE OUTPUT BUCLA LDA B,I IOR COBAS MERGE PATTERN WITH BIT15 IOD15 SFC SC JMP *+3 E0136 JSB ERMS,I FLAG NOT SET DEF MS136 IOD16 OTA SC,C SSA,RSS IS IT LAST ? JMP *+3 INB JMP BUCLA IOD17 STC SC FORCE COMPLETION RESVE LDA TLTMG SET 70 MS TIME OUT FOR POLLING STA SCUTY SECUR LDA P5 START 5 MS TIMING JSB TMRR,I ISZ SCUTY JMP IOD18 E0137 JSB ERMS,I FLAG SLOW TO BE SET DEF MS137 JMP RESVE RESTART 70$ MS TIME OUT IOD18 SFS SC JMP SECUR LDB RETAD PREPARE INPUT BUFFER POINTER IOD19 LIA SC,C INPUT PHASE STA B,I INB CPB RETAP LAST INPUT ? RSS JMP CRL15 SSA,RSS LAST INPUT BIT15 MUST BE CLEAR JMP SNDER,I E0145 JSB ERMS,I BIT15 SET ON LAST WORD DEF MS145 JMP SNDER,I BIT 15 GOOD CRL15 SSA NOT LAST EXCHANGE BIT15 MUST BE SET JMP IOD19 E0146 JSB ERMS,I BIT15 CLEAR & NOT LAST EXCHANGE DEF MS146 JMP IOD19 SKP *SBR PRINT CHARACT TO PRESS * INDIC NOP LDA TEMP0,I IOR BIT12 CONF FOR OUTPUT JSB SNDNA,I CPA CDTAB+12 RSS JMP *+3 LDA SPACE JSB SNDNA,I LDA SPACE SPACE = 010040 JSB SNDNA,I JSB SNDNA,I JMP INDIC,I * *SBR SPEC FOR POINT * PNTSP NOP STA TEMP2 CPA CDTAB+12 RSS JMP PNTSP,I LDA SPACE JSB SNDNA,I LDA TEMP2 JMP PNTSP,I * *SBR OK COUNT * VRIFY NOP LDB RETAD CONTR LDA B,I AND BIT14 ISOLATE BIT14 CPA BIT14 IS IT PRESENT ? JSB TACNT INB CPB RETAP LAST WORD ? RSS JMP CONTR LDA RETAD CMA ADA FOKAD ADA P2 LDB WITNS SSB JMP NO.OK SZB,RSS JMP *+3 E0143 JSB ERMS,I 2 OR MORE OK ON TDL,1ST IN AREG(ADDR) DEF MS143 JMP VRIFY,I NO.OK CLA E1144 JSB ERMS,I NO OK ON TDLOOP DEF MS144 JMP DEBUT,I DEBUT FIXED IN CONCERNED TEST * *SBR RESET WITNS & FOKAD * INIWF NOP CCA STA WITNS CLA STA FOKAD JMP INIWF,I * *SBR PRINT TERMINAL ADDR * PRINT NOP LDA VARIA ARS,ARS ARS JSB CNVRN LDA VARIA JSB CNVRN LDA LFCOD JSB SNDEA,I JMP PRINT,I * *SBR CONVERSION + OUTPUT * CNVRN NOP AND OCT07 a OCT07 = 000007 IOR CDTAB CDTAB = 010060 JSB SNDEA,I JMP CNVRN,I * * *SBR PRINT RATE & CUMULATED RETRANSMISSION * CALCU NOP LDA TEMP2 ALF,ALF PLACE CORRECT BITS ARS JSB CNVRN LDA TEMP2 ALF,ALF RAL,RAL JSB CNVRN LDA TEMP2 RAR,RAR RAR JSB CNVRN LDA TEMP2 JSB CNVRN LDA SPACE LET SPACE BTWN TWO NUMBERS JSB SNDEA,I JSB SNDEA,I LDA TEMP3 ALF,ALF SAME AS FOR TEMP2 ARS JSB CNVRN LDA TEMP3 ALF,ALF RAL,RAL JSB CNVRN LDA TEMP3 RAR,RAR RAR JSB CNVRN LDA TEMP3 JSB CNVRN LDA LFCOD LFCOD = 010012 JSB SNDEA,I SEND LF TO END LINE CLA STA TEMP2 CLEAR TEMP2 TO CALC NEXT RATE JMP CALCU,I * *SBR LIT SFK TO PRESS * SHOW NOP LDB STBYT IF NOT 3070B & 2ND PASS SLB,RSS DON'T CONFIGURE SFK JMP GOX00 LDA M2 CPA CNTR JMP GOX00 LDA TEMP0,I CONFIGURE SFK TERMINATOR AND B3210 IOR OC160 IOR UTCMD JSB SNDNA,I GOX00 CLA,INA LDB STBYT ADJUST CODE FOR B\A VERSION SLB CCA ADA TEMP0,I ADA TEMP2 JSB SNDNA,I ADA P3 JSB SNDNA,I JMP SHOW,I SKP * ORG ADDR4 * *************************************************** **** SBR SEND ON ONE ADDRESS (DXTOK,RETOK) **** *************************************************** * SNDNG NOP AND NB154 STA COBAS SAVE PATTERN & STORE IT IOD20 STC SC,C INIT TDL LDB DXTAD INIT OUTPUT PHASE BOUCL LDA B,I CPB DXTOK IF ADDRESS, INCLUDE PATTERN IOR COBAS YES, DO IT IOD21 SFC SC JMP IOD22 E1136 JSB ERMS,I FLAG NOT SET DEF MS136 IOD22 OTA SC,C SSA,RSS LAST OUTPUT ? JMP WT1SC 3 INB JMP BOUCL WT1SC LDA COBAS AND BIT12 LAST I\O WAS INPUT OR OUTPUT ORDER ? LDB TM15S INPUT ORDER WAIT FLAG FOR 15 SEC CPA BIT12 LDB TLTMG OUTPUT ORDER: WAIT FLAG FOR .08 SEC JSB WTFLG JMP RECEP E0142 JSB ERMS,I FLAG NOT SET DEF MS142 JMP WT1SC RECEP LDB RETAD INIT INPUT PHASE RECVE SFC SC JMP IOD24 E1137 JSB ERMS,I FLAG SLOW TBE SET DEF MS137 * * IOD24 LIA SC,C STA B,I INB CPB RETAP LAST INPUT ? JMP NTB15 CTL15 SSA NOT LAST:BIT15 MUST BE SET JMP RECVE E1146 JSB ERMS,I BIT15 CLEAR & NOT LAST WORD DEF MS146 JMP RECVE NTB15 SSA,RSS LAST, BIT15 MUST BE CLEAR JMP ESCAP E1145 JSB ERMS,I BIT15 SET ON LAST WORD DEF MS145 ESCAP LDA BIT14 TEST PRESENCE OF OK BIT JSB TESTA,I JMP *+4 E0147 JSB ERMS,I OK ORIGIN CHANGED DEF MS147 JMP RETUR LDA COBAS AND BIT12 INPUT OR OUTPUT CPA BIT12 JMP NDSND OUTPUT, THEN RETURN FROM SBR LDA BIT10 INPUT THEN TEST IF VALDA JSB TESTA,I JMP NDSBR LDA BIT09 TEST IF SRQ (NO VALDA) JSB TESTA,I JMP E0150 JMP E0151 E0150 JSB ERMS,I SRQ OCCURED DEF MS150 JMP RETUR-1 E0151 JSB ERMS,I NEITHER VALDA NOR SRQ NOR STC SC DEF MS151 AND INTERRUPT OCCURED NDSBR LDA RETOK,I JMP SNDNG,I JSB ADSRQ RETUR LDA TSTN CPA P3 JMP DEBUT,I DEBUT FIXED IN TST04 CPA P11 JMP DEBUT,I DEBUT FIXED IN TST13 CPA P13 JMP DEBUT,I DEBUT FIXED IN TST15 NDSND LDA COBAS JMP SNDNG,I MS147 ASC 22,E147 TERMINAL ADDRESS VARIATION, PRESS RUN/ MS150 ASC 18,E150 SRQ DETECTED WHEN NOT EXPECTED/ MS151 ASC 12,E151 INVALID INTERRUPT/ MS152 ASC 14,E152 DATA & SERVICE REQUEST ASC 12,SIMULTANEOUSLY RECEIVED/ * * SKP * *SBR TEST 1 BIT * TESTR NOP STA SCPAD SAVE MASK OF TEST BIT LDB RETAD INIT RETAB READING NWTER LDA B,I AND SCPAD CPB RETOK ARE WE ON CONCERNED ADDRS JMP NWT1 YES WE ARE CPA SCPAD RSS JMP NWT2 E1153 JSB ERMS,I BIT PRESENT & NOT CONCERN ADDRESS DEF MS153 NWT2 INB CPB RETAP END OF READING ?? JMP TESTR,I JMP NWTER NO,CONTINUE NWT1 CPA SCPAD JMP NWT2 IF BIT PRESENT, RTN JSB +1 ISZ TESTR IF BIT ABSENT, RTN JSB +2 JMP NWT2 MS153 ASC 13,E153 ACK RECEIVED BUT NOT ASC 14,FROM PROPER ADDR, PRESS RUN/ * *SBR CONTROL # VRIFY * VERFY NOP LDB RETAD INIT READING OF RETAB RBCLG LDA B,I AND BIT14 ISOLATE BIT14 CPA BIT14 JSB TACNT BIT14 PRESENT INB CPB RETAP LAST WORD OF RETAB ? RSS YES JMP RBCLG NO LDA RETAD CALCULATE CMA ADDR OF ADA FOKAD TERMINAL ADA P2 RETURNING OK BIT LDB WITNS NUMBER OF OK ON TDL SSB JMP SPCHL NO OK ON TDL SZB,RSS ONE OK ? JMP VERFY,I E1143 JSB ERMS,I 2 OR MORE OK ON TDL 1ST IN AREG DEF MS143 JMP VERFY,I SPCHL CLA ISZ TEMP2 INCR FOR THE RATE ISZ TEMP3 INCR FOR TEMP3 JMP BGYNA,I * SKP * MS136 ASC 9,E136 FLAG NOT SET/ MS137 ASC 22,E137 FLAG NOT SET WITHIN THE REQUIRED TIME/ MS140 ASC 17,E140 DATA RECEIVED DIFFERENT FROM ASC 16,DATA SENT(B=ADDRESS),PRESS RUN/ MS141 ASC 17,E141 DATA RECEIVED DIFFERENT FROM ASC 17,DATA SENT:A=RCVD,B=SENT,PRESS RUN/ * TSEOI NOP SBR TO RECEIVE & TEST LF\EOI CLB TEST FIRST NO EOI YET CPB EOIND JMP *+3 OK, GET LAST BYTE NOW E0156 JSB ERMS,I ERROR: EOI YET RECEIVED DEF MS156 JSB READ CPA LF IS IT LF ?? JMP *+3 JSB ERMS,I HFB NOT LF RECEIVED DEF MS156 CLB,INB TEST EOI FLAG NOW CPB EOIND JMP TSEOI,I OK, RETURN JSB ERMS,I NO EOI WITH LF TERMINATOR DEF MS155 JMP TSEOI,I RETURN NOW * MS156 ASC 20,E156 EOI YET RECEIVED OR NO TERMINATOR/ * INPUT NOP CLA JSB SNDEA,I READ WITH FORCED COMPL JMP INPUT,I * READ NOP SBR TO READ ONE CHAR ON RDR JSB INPUT READ REQUEST STA TEMP0 SAVE DATA LDA BIT10 TEST IF VALID DATA JSB TESTA,I RSS GOOD, PROCESS JMP NOYET NO VALDA, OPERATOR WAIT ?? LDA TEMP0 GET DATA AGAIN AND BIT09 IS THERE EOI ?? SZA ISZ EOIND YES, BUMP FLAG ISZ RDFLG BUMP READER FLAG LDA TEMP0 GET DATA AGAIN AND RBYTE KEEP BYTE ONLY JMP READ,I NOYET CLA IF RDFLG=0, NO ERROR CPA RDFLG ONLY SLOW TO ACT OPERATOR!!! JMP READ+1 RESTART INPUT REQUEST E0157 JSB ERMS,I RDR SHOULD TALK MORE QUIKLY DEF MS157 JMP READ+1 TRY READ AGAIN * MS157 ASC 19,E157 READER SHOULD TALK MORE QUICKLY/ * DBLE NOP SBR TO READ TWO CHAR ON RDR JSB READ READ FIRST ALF,ALF SHIFT LBYTE STA TEMP2 SAVE TEMPORARY JSB READ READ SECOND IOR TEMP2 MERGE WITH FIRST JMP DBLE,I RETURN NOW * * SKP 8\H* * CFRDR NOP SBR TO CONF RDR TALKER CLA WITH MSA DEF AT JSB *+1 STA EOIND RESET EOI INDICATOR STA RDFLG RESET READER FLAG LDA LSN34 CONF READER LISTNER FIRST JSB SNDNA,I TO SEND READER MSA OPTION LDA CFRDR,I GET CODE ADDRESS LDA A,I GET CODE JSB SNDNA,I SEND IT JSB OMCCF AND CONFIGURE ISP !!! LDA TLK34 CONF RDR TALKER NOW JSB SNDNA,I ISZ CFRDR BUMP RETURN ADDRESS JMP CFRDR,I AND RETURN NOW * CFPRI NOP SBR TO CONF PRINTER LISTENER JSB INPUT READ TO TEST SRQ AND BT910 ISOLATE VALDA+SRQ SZA,RSS IS THERE SOMETHING GOOD ?? JMP *+3 E0160 JSB ERMS,I YES, SRQ ON !! (OR VALDA) DEF MS160 JSB ADSRQ EXEC SERIAL POLL LDA STBYT GET STATUS BYTE AND B6520 ISOLATE E-O-P PATTERN CPA BT520 IS IT ?? JMP CFPRN YES, NO PAPER LDA LSN33 CONF PRINTER NOW JSB SNDNA,I RSS CFPRN ISZ CFPRI BUMP RTN ADR JMP CFPRI,I AND RETURN * MS160 ASC 20,E160 SRQ OR VALDA SET WHEN NOT EXPECTED/ * BUZZZ NOP SBR TO MAKE BUZZ BUZZ BUZZ LDA OCT07 IOR UTDAT JSB SNDNA,I JMP BUZZZ,I * WRTDI NOP SBR TO TLK36,LSN35,DATA,UNLSN STA TEMP1 JSB UNTAK JSB ODSCF SET DISPLAY LISTENER LDA TEMP1 JSB SNDNA,I JSB OULSN JMP WRTDI,I * * HED **** PRINTER TEST **** * ****************************** **** PRINTER TEST **** ****************************** * TST11 EQU * PRINTER TEST PRNTR NOP ************** LDB UTCMD BITS 8 & 12 OPTIONS ? JSB SWRT,I JMP PRNTR,I YES, RETURN JSB INITS STANDARD INITIALIZATION JSB AIFCL JSB ADSRQ JSB HCYES IF 30HC, REJECT JMP PRNTR,I LDA STBYT GET STATUS BYTE RA\R,RAR IF NO PRINTER, REJECT !!! SLA,RSS JMP PRNTR,I NO PRINTER H0100 JSB MESGC SEND MESSAGE DEF MS100 LDA PRMSA PRINT ON DECONF PRINTER STA TEMP2 SAVE POINTER GO210 LDA TEMP2,I GET CHARACTER CPA M1 IS IT THE LAST ?? JMP GO211 YES, CONTINUE JSB SNDNA,I SEND IT ISZ TEMP2 BUMP POINTER JMP GO210 GO211 JSB MSGH,I REMOVE PAPER !!! DEF MS101 JSB CFPRI VERIFY E-O-P DETECTION RSS JMP *+3 OK, CONTINUE E0110 JSB ERMS,I NO E-O-P DEF MS110 H0102 JSB MSGH,I INSERT PAPER !!! DEF MS102 JSB CFPRI CONF PRINTER NOW JMP *+3 GOOD, CONTINUE E0111 JSB ERMS,I ALWAYS E-O-P PRESENT DEF MS111 LDA M20 START 20 CHAR DUMP STA CNTR LDA BIT05 GET FIRST PRINTABLE CHAR. GO212 STA TEMP1 SAVE CHARACTER IOR UTDAT INCLUDE UTPUT CODE JSB SNDNA,I SEND IT GO213 LDA TEMP1 GET CODE AGAIN INA SET NEW CPA OC140 TEST 64 CHAR HALT JMP GO214 YES ISZ CNTR BUMP 20\60 CHAR. HALT JMP GO212 CPA KBTAB+4 TEST FOR 1ST\3RD LINE MESSAGE JMP *+4 1ST LINE H0104 JSB MSGH,I DEF MS104 JMP *+3 H0103 JSB MSGH,I DEF MS103 LDA M41 SET COUNTER FOR 60 CHAR HALT STA CNTR JMP GO213 CONTINUE GO214 LDA LFCOD SEND TERMINATOR TO PRINT THE JSB SNDNA,I FOUR LAST CHARACTERS H0105 JSB MSGH,I >>> PRINTER : FOURTH LINE NOW <<< DEF MS105 LDA LFCOD TERMINATOR AGAIN JSB SNDNA,I TO SKIP A LINE H0106 JSB MSGH,I >>> PRINTER : FEED A LINE <<< DEF MS106 LDA CODAD SET POINTER TO SEND "DELETE" STA TEMP0 MERGED WITH DATA GO215 LDA TEMP0,I GET DATA CPA M1 IS IT TERMINATOR ?? JMP GO216 YES, EXIT LOOP JSB SNDNA,I SEND DATA ISZ TEMP0 BUMP POINTER M JMP GO215 CONTINUE GO216 JSB MSGH,I >>> PRINTER : ONLY "ABCD" <<< DEF MS107 LDA CAP.A TEST IF DCL ERASE BUFFER JSB SNDNA,I SEND CAP.A TO PRINTER JSB ADSRQ GET STBYT FOR BUSY BIT CHECK LDA STBYT AND BIT03 PRINTER BUSY ?? SZA JMP *+3 E1110 JSB ERMS,I NO BUSY BIT DEF MS110 JSB CFPRI CONF PRINTER AGAIN JMP *+3 E2111 JSB ERMS,I E-O-P DETECTED DEF MS111 LDA DCL CLEAR BUFFERS JSB SNDNA,I JSB ADSRQ GET STBYT AGAIN LDA STBYT AND BIT03 SZA,RSS BUFFER EMPTY==> NOT BUSY JMP *+3 E1111 JSB ERMS,I BUSY BIT SET DEF MS111 JSB CFPRI CONF PRINTER AGAIN JMP *+3 E3111 JSB ERMS,I E-O-P DETECTED DEF MS111 LDA LFCOD SEND TERMINATOR TO PRINT OUT JSB SNDNA,I THE BUFFER CONTENT ( EMPTY ) JSB ADSRQ GET STBYT AGAIN LDA STBYT AND BIT03 IS PRINTER BUSY ?? SZA JMP *+3 E2110 JSB ERMS,I PRINTER NOT BUSY DEF MS110 H1106 JSB MSGH,I >>> PRINTER : ONLY FEED A LINE <<< DEF MS106 JMP PRNTR,I RETURN NOW * HED **** READER TEST **** * ****************************** **** READER TEST **** ****************************** * TST12 EQU * READER TEST READR NOP ************* LDB UTCMD BITS 8 & 12 OPTIONS ? JSB SWRT,I JMP READR,I JSB INITS STANDARD INITIALIZATION JSB AIFCL JSB ADSRQ JSB HCYES IF 30HC, REJECT JMP READR,I LDA STBYT IF NO READER, REJECT !!! RAR SLA,RSS JMP READR,I H0112 JSB MESGC DEF MS112 * * READ CARD (#1) ****** ( TWO SUCCESSIVE READS ) ********************* * LDA M2 SET SEQUENCE COUNTER STA TEMP3 GO22E LDA CDTAB+1 WRITE CARD NBR TO READ JSB WRTDI JSB CFRDR CONFIGURE RDR TALKER WITH  DEF MSA01 CAD,HOLES+MARKS,IMAGE LDA M40 SET CHAR COUNT CARD (#1) STA CNTR LDA ADAT1 SET POINTER FOR ROM TO COMPARE STA TEMP1 CHARACTERS ON CARD (#1) GO220 JSB DBLE READ TWO CHARACTERS LDB TEMP1,I CPA B ARE THEY THE GOOD ONES ?? JMP *+2 YES, CONTINUE JSB RPORT NO, ERROR ISZ TEMP1 BUMP POINTER ISZ CNTR BUMP COUNTER JMP GO220 CONTINUE CCA TEST IF SECOND PASS CPA TEMP3 JMP GO22A YES GOTO TEST DCL LDA M38 PREPARE 76 @ READ STA CNTR GO221 JSB DBLE GET TWO CHAR LDB @@ CPA B ARE THEY THE EXPECTED ONES JMP *+2 JSB RPORT NO,ERROR ISZ CNTR IS IT FINISHED ?? JMP GO221 NO ! JSB DBLE GET THE # LAST CHAR LDB @Q CPA B ARE THEY EXPECTED ?? JMP *+2 YES JSB RPORT NO,ERROR JSB DBLE GET THE TWO LAST CHAR LDB H@ CPA B QH IS LF EQUIVALENT JMP *+2 SKIP IF OK JSB RPORT NO,ERROR JSB TSEOI IS THERE EOI NOW ?? ISZ TEMP3 BUMP SEQ COUNTER JMP GO22E * GO22A JSB UNTAK UNTALK READER LDA DCL SEND DEVICE CLEAR JSB SNDNA,I LDA TLK34 SET READER TALKER AGAIN JSB SNDNA,I JSB INPUT READ DATA TO TEST BUFFER CLEAR AND BT910 ISOLATE VALDA+EOI\SRQ SZA,RSS JMP *+3 E0114 JSB ERMS,I DCL DOESN'T CLEAR TERMINAL DEF MS114 * * READ CARD (#2) NOW !!!!!!! ( 2 SUCCESSIVE READS ) !!!!!!!!!!!!!!!! * GO22F LDA CDTAB+2 CARD NBR TO READ JSB WRTDI JSB CFRDR CONF RDR TALKER WITH DEF MSA02 NCL,HOLES,80 COL,ASCII LDA M1 SET SECOND PASS FLAG STA TEMP3 FOR CHAR SET CHANGE CLA SET FIRST CHAR TO GO222 STA TEMP1 RECOGNIZE ON CARD (#2) JSB READ GET THE CHARACTER 1 LDB TEMP1 CPA B IS IT GOOD ONE ?? JMP *+2 YES, CONTINUE JSB RPORT NO,ERROR LDA TEMP1 SET NEW CHAR AND INA TEST IF FINISHED CPA CAPB. "B" IS LAST CHAR RSS YES, SKIP JMP GO222 CONTINUE READ SEQU. JSB TSEOI IS THERE EOI NOW ?? ISZ TEMP3 TEST FINISHED ON CARD #2 ?? JMP GO22J YES LDA CDTAB+2 CARD NBR TO READ JSB WRTDI JSB CFRDR CONF RDR TALKER WITH DEF MSA02 CAD,HOLES ONLY,ASCII JMP GO222-1 * * TEST CARD REJECT DISABLE ***** ( ONE READ ) ************ * GO22J LDA CDTAB+11 PRINT CARD# TO INPUT JSB WRTDI LDA CDTAB+2 JSB WRTDI JSB CFRDR CONF RDR TALKER WITH DEF MSA07 RJD,NCL,80 COL,HOLES,ASCII LDA M14 SET SPACE COUNTER STA CNTR GO22C JSB READ GET DATA LDB BIT05 CPA B IS IT A SPACE JMP *+2 JSB RPORT NO,ERROR ISZ CNTR MORE SPACE ?? JMP GO22C YES LDA CAPA. SET FIRST CHAR GO22D STA TEMP1 JSB READ GET NEXT ON RDR LDB TEMP1 CPA B IS IT GOOD ONE ?? JMP *+2 JSB RPORT NO,ERROR CCA DECREMENT CODE ADA TEMP1 SSA,RSS EXIT IF NEG JMP GO22D LAST CHAR = 0B JSB TSEOI JMP READR,I * RPORT NOP READER ERROR REPORT E0113 JSB ERMS,I DEF MS113 A=RECEIVED, B=EXPECTED JMP RPORT,I * * HED **** SELF TEST TEST **** * ORG 14000B * ********************************* **** SELF-TEST TEST **** ********************************* * TST03 EQU * SELF-TEST TEST SELFT NOP **************** JSB INITS STD INIT JSB AIFCL JSB ADSRQ LDA STBYT IF NOT 3070B REJECT SLA,RSS JMP SELFT,I H0115 JSB MESGC PRINT TITLE DEF MS115 JS B ODSCF SET DISPLAY LISTENER LDA SFTST TRIGGER SELF-TEST REMOTE JSB SNDNA,I LDA M28 SET SELF-TEST TIME OUT STA TIME LDA TLK35 OUTPUT COMMAND IN ORDER TO JSB SNDEA,I BLOCK HPIB HANDSHAKE GO260 LDA TLK35 TRY TO OUTPUT COMMAND AGAIN JSB SNDEA,I IN ORDER TO KNOW SFTST END RAL TEST IF OK OR NOT OK SSA JMP GO261 OK, CONTINUE ISZ TIME DID 3070B TIMED OUT ?? JMP GO260 NO, NOT YET !! E0116 JSB ERMS,I YES, TIME OUT ON SELF-TEST DEF MS116 GO261 JSB ADSRQ EXEC SERIAL POLL LDA STBYT TEST GOOD STATUS AND B0346 GET BITS LDB OCT21 THIS IS STATUS FOR CONCERN BITS CPA B IS IT GOOD PATTERN JMP SELFT,I RETURN E0117 JSB ERMS,I NOT GOOD BITS IN STBYT DEF MS117 JMP SELFT,I * * HED ***** TOTAL INSTALLATION TEST ***** * ****************************************** **** TOTAL INSTALLATION TEST **** ****************************************** * TST16 EQU * GLOBAL INSTALLATION TEST WINST NOP ************************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP WINST,I H0131 JSB MESGC DEF MS131 H0132 JSB MSGH,I X INPUT REQUEST DEF MS132 X FOR POLLING LIA SW X CYCLE LENGTH AND BIT50 X SZA,RSS X LDA P63 X CCB X ADA B X STA TEMP1 X JSB INITZ INITIATE DXTAB AND HPIB COMMANDS JSB AIFCL IFC FOR ALL JSB ADSRQ RUB OUT ANY SRQ PRESENT NOW JSB CAPTR FIX NEW POLLING LENGTH CLA START INPUT PHASE FOR SRQ JSB INDXT INIT ALL DXT WITH INPUT CODE CLA INITILIZE BUFFER LOCATION STA TERPT RESET TERMINAL POINTER IBFAD MPY P20 CALCULATE CURRENT ADA BFBAS BUFFER ADDRESS CLB RESET SQCER+STBYT+CINAD \ STB A,I INA STA B INA STORE CTBFA+2 = BFPNT STA B,I INTO CTBFA+1 (BFPNT ADDR) ADB P18 CCA STA B,I STORE TERMINATOR AT EACH BUFF END ISZ TERPT INCR TERMINAL POINTER LDA TERPT CPA P63 IS IT THE LAST ? RSS JMP IBFAD NO CONTINUE RSETT CLA YES STA TERPT RESET TERMINAL POINTER LDA DXTAD STA TRDXA RESET DXT POINTER JSB EXCHG EXEC TOUR DE LOOP * SKP ************************************ *** LOOP FOR DXT MANAGEMENT *** ************************************ * LKDXT LDA TERPT CALCULATE CURRENT BUFFER ADDRESS MPY P20 BASED ON TERMINAL # X 20 WORDS BUFFER ADA BFBAS PLUS BASE BUFFER ADDRESS OFFSET STA CTBFA SAVE IT IN CURRENT BUFF ADDRESS STA B SAVE FOR IMMEDIATE USE LDA B,I GET CINAD+SQCER+STBYT AND B5432 ISOLATE SQCER (BIT15-12) 0 INPUT STA SQCER 1 RDR, 2 SFK, 4 BFR, 8 SRQ LDA B,I GET CINAD+SQCER+STBYT AND B0777 ISOLATE CINAD (BIT 8-0) STA CINAD CURRENT INSTR. TABLE ADDR (MAX=777) LDA B,I GET CINAD+SQCER+STBYT AND B7000 ISOLATE STBYT (BIT 11-9) STA STBYT BIT9 A\B, BIT10 RDR, BIT11 TPR INB LDB B,I STB BFPNT SET BUFFER POINTER FOR DATA FROM TERMINAL LDA TRDXA,I STA TRDXT SET CURRENT DXT WORD AND BIT14 CPA BIT14 IS OK PRESENT ? RSS JMP NOMOD NO => NEW TOUR DE LOOP LDA TRDXT YES => GET STATUS AND STDMK GET BITS 12,10,9 CPA BIT09 SRQ ? JMP SRQCN YES PROCESS CPA BIT10 VALID INPUT ? JMP VLDIN YES PROCESS CPA BT910 VALID INPUT + EOI ? JMP VLDIN AND BIT12 OUTPUT PHASE ? SZA JMP UTBUF YES PROCESS NVINP LDA TRDXT SET DXT WORD IN INPUT CONFIG AN D BIT15 SAVE BIT 15 STA TRDXA,I RESTORE DXT WORD NOMOD LDB CTBFA LDA CINAD RESTORE CINAD+SQCER+STBYT IOR SQCER IOR STBYT STA B,I INB LDA BFPNT STA B,I RESTORE BFPNT LDA TRDXT LAST TERMINAL TO PROCESS ?? SSA,RSS JMP RSETT YES ISZ TERPT NO => INCR TERMINAL # ISZ TRDXA ACTUALISE TRDXA JMP LKDXT LOOP NEXT TERMINAL SKP * ********************************** **** GENERAL SUB-ROUTINES **** ********************************** * * EXCHG NOP IOD29 STC SC,C START LINK CONTROLLER LDB DXTAD OUT LDA B,I OUTPUT DXTAB ON CONTROLLER IOD30 OTA SC,C SSA,RSS LAST WORD ? JMP *+3 INB JMP OUT IOD31 SFC SC WAIT FLAG FROM CONTROLLER JMP INP-1 MAY BE LONG: NO STC SC LIA SW TEST BIT 7 TO ABORT TEST AND BIT07 SZA,RSS JMP IOD31 IOD43 CLC SC ABORT REQUESTED JMP NDT16 LDB DXTAD INP LIA SC,C INPUT DXTAB FROM CONTROLLER STA B,I SSA,RSS LAST WORD ? JMP EXCHG,I INB JMP INP * * CAPTR NOP CALCULATE POINTERS IN DXTAB LDA DXTAD BECAUSE VARIABLE POLLING ADA TEMP1 LENGTH STA DXTAR INA STA DXTAP JMP CAPTR,I * INDXT NOP SET DXT WITH CODE LDB DXTAD CPB DXTAR IS IT ALREADY THE LAST ? JMP LST YES IOR BIT15 SET BIT15 EXCEPTED ON LAST STAUR STA B,I INB CPB DXTAR IS IT THE LAST ? RSS JMP STAUR NO KEEP BIT15 SET LST AND NBT15 YES CLEAR BIT15 STA B,I JMP INDXT,I * SKP * ************************************* **** S R Q TREATMENT **** ************************************* * SRQCN LDA CINAD EXECUTE NEW INPUT IF SRQ IS SENT CPA SRTB3 WHEN STS BYT EXPECTED (SLOW O JMP NVINP LISTENERS ON HPIB) LDA BIT15 CHECK SQCER IS SET CPA SQCER IN SRQ PHASE JMP SRQTR YES STA SQCER NO, FORCE TO THIS PHASE LDA SRQAD NEED TO SET CINAD STA CINAD AT SRQ TABLE JMP SRQTR CONTINUE NORMAL WAY SRPTR LDA TRDXT SERIAL POLL TREATMENT AND OCT07 GET A\B TYPE+RDR\TPR OPTION ALF,ALF RAL STA STBYT AND SAVE IT LDA TRDXT GET DATA AGAIN AND SRPMK INPUT TO TEST BIT6 HERE CPA SRPMK JMP SRQTR CONTINUE WITH SRQTR E0134 JSB ERMS,I DON'T FIND OUT DEF MS134 SERIAL POLL RESPONSE SRQTR LDA TERPT CONFIGURE SRQ TABLE WITH INA TERMINAL LINK ADDRESS ARS,ARS IN ORDER TO OUTPUT IT ARS ON DISPLAY AND OCT07 IOR CDTAB STA MSBYT LDA TERPT INA AND OCT07 IOR CDTAB STA LSBYT LDA CINAD,I CPA M1 SRQ TREATMENT SEARCH TERMINATOR RSS PRESENT => RESET SRQ PHASE JMP UTAB1 CONTINUE OUTPUT RSRQP CLA SET INPUT PHASE STA SQCER RESET SEQUENCE POINTER STA CINAD RESET CURRENT INST ADDR LDA CTBFA RESET BUFFER POINTER ADA P2 STA BFPNT JMP NVINP GO TO INPUT PHASE * SKP * *************************************** **** VALID INPUT TREATMENT **** *************************************** * * VLDIN LDA SQCER VALID INPUT SEQUENCE CPA BIT15 SRQ SEQUENCE ? JMP SRPTR YES GO TO CPA BIT12 READER INPUT ? JMP REDER YES, PROCESS LDA TRDXT AND KBTAB DETECT SFK CODE CPA FKTAB JMP TRSFK GO & TREAT IT LDA TRDXT AND RBYTE ISOLATE ASCII FROM KEYBOARD IOR BIT12 CONFIG IT FOR BIT12 CPA DEL IF DEL\LF 2 FIRST CHAR JMP DELTR EXEC READER\PRINTER SEQU CPA LFnCOD DETECT LF CHARACTER JMP RSBFP HERE => RESET BFPNT ISZ CINAD BUMP DEL\LF DETECTOR DELRT LDB BFPNT INB GO & SEE AHEAD IF END OF BUFFER LDB B,I CPB M1 LIMIT ? JMP NVINP LIMIT NEW INPUT TO WAIT LF STA BFPNT,I SAVE DATA ISZ BFPNT JMP NVINP RSBFP LDB B0777 DETECT LF AFTER DEL CPB CINAD JMP SETRD STA BFPNT,I SAVE TERMINATOR LDA CTBFA RESET BUFFER POINTER INA ON LINE FEED ARRIVAL STA BFPNT LDA DCFAD SET CINAD TO DECONF AND SRQ TABLE STA CINAD LDA BIT14 SET OUTPUT BUFFER PHASE STA SQCER JMP UTBF1 * DELTR CLB IF DEL FIRST CHAR,SET CPB CINAD CINAD TO -1 RSS JMP DELRT LDB B0777 STB CINAD JMP DELRT * SKP * ******************************************************* **** OUTPUT BUFFER & DECONF ORDERS **** ******************************************************* * * * UTBUF LDA SQCER OUTPUT PHASE CPA BIT13 SFK OUTPUT ? JMP SFKPR YES GOTO CPA BIT15 SRQ OUTPUT ? JMP SRQTR YES GOTO CPA BIT12 IF RDR\TPR SEQ, CONTINUE JMP UTABL CPA BIT14 OUTPUT BUFFER ?? RSS JMP UNCNF >>> SHOULD NEVER OCCUR <<<<<<<<<<<<< UTBF1 LDB UNTLK PREPARE UNTALK KEYBOARD LDA CTBFA FOR FIRST OUTPUT INA CPA BFPNT FIRST OUTPUT ? RSS YES LDB BFPNT,I NO NORMAL OUTPUT UTBF2 LDA TRDXT AND BIT15 SAVE BIT15 IN DXT & ADD IOR B B CONTENT STA TRDXA,I STORE IN DXT FOR NEXT OUTPUT ISZ BFPNT INCR BUFFER POINTER CPB LFCOD IS IT TERMINBATOR ?? RSS JMP NOMOD LDA BIT15 STA SQCER JMP NOMOD * UNCNF LDA DCFAD SET DECONF TABLE AND SRQ WAIT STA CINAD LDA BIT15 SET TO SRQ PROCESS PHASE STA SQCER * UTABL LDA CINAD,I GET NEXT TABLE WORD CPA M1 SEARCH TERMINATOR JMP UNCNF REACHED => SET DECONF+SRQ WAIT UTAB1 LDA TRDXT PREPARE NEXT DXT WORD AND BIT15 IOR CINAD,I UTAB2 STA TRDXA,I ISZ CINAD INCR POINTER JMP NOMOD * * SKP * * * * **************************************** **** S F K CODE TREATMENT **** **************************************** * * * * * TRSFK CLB CONF CODE ACCORDING A\B LDA STBYT GET TYPE AND BIT09 SZA SKIP FOR A-VERSION CCB LDA TRDXT CONVERT SFK CODE AND B3210 TO ANNUNC LIGHTS ADA SFKAD CODE & SEND IT ADA B ADJUST WITH OPTION LDB A,I DIRECTLY TO THE LDA TRDXT TERMINAL AND BIT15 IOR B STA BFPNT,I LDA TRDXT AND BIT15 IOR UNTLK STA TRDXA,I LDA BIT13 SET SQCER TO SFK OUTPUT STA SQCER LDA OCT30 SET CINAD TO 30 STA CINAD JMP NOMOD SFK OUTPUT & CAUSES SFKPR LDA CINAD CPA OCT30 JMP SFDAT CPA OCT31 JMP SFTLK CLA PROGRAM TO EXECUTE STA SQCER INPUT AFTER BY SETTING JMP NVINP SQCER TO 0 * SFTLK LDA TRDXT AND BIT15 IOR TLK35 JMP UTAB2 SFDAT LDA BFPNT,I JMP UTAB2 * * SKP * ************************************** **** READER\PRINTER PROCESS **** ************************************** * * SETRD LDA BIT12 SET SEQU TO RDR\TPR STA SQCER LDA STBYT TEST IF: - 3070A AND BT110 - 3070B SZA,RSS - " + TPR JMP UNCNF - " + RDR\TPR LDB RDSEQ PRESET TO RDR\TPR CPA BIT11 LDB PRSEQ FORCE TO TPR ONLY STB CINAD JMP UTABL AND EXECUTE TABLE OUTPUT * * REDER LDA TR rDXT TEST IF EOI TO AND BIT09 TERMINATE RDR INPUT SZA,RSS JMP NVINP NOT YET, INPUT AGAIN ISZ CINAD YES, BUMP TO CONTINUE JMP UTABL TABLE OUTPUT * ***************************** **** END OF TEST **** ***************************** * NDT16 LIA SW AND NB750 OTA SW JSB INITZ JSB AIFCL H0133 JSB MSGC,I DEF MS133 JMP WINST,I MS131 ASC 17,TEST 16 GLOBAL INSTALLATION TEST/ MS133 ASC 17,GLOBAL INSTALLATION TEST COMPLETE/ MS132 ASC 16,H132 ENTER MAX TERMINAL ADDRESS( ASC 14,SREG BIT 5-0) OR PRESS RUN/ MS134 ASC 11,E134 INVALID RESPONSE ASC 15,DURING SERIAL POLL, PRESS RUN/ * * SKP * * * MS100 ASC 11,TEST 11 PRINTER TEST/ MS101 ASC 15,H101 REMOVE PAPER, PRESS RUN/ MS102 ASC 15,H102 INSERT PAPER, PRESS RUN/ MS103 ASC 14,H103 FIRST LINE PRINTED NOW/ MS104 ASC 18,H104 SEC & THIRD LINES PRINTED NOW/ MS105 ASC 15,H105 FOURTH LINE PRINTED NOW/ MS106 ASC 10,H106 LINE FEED NOW/ MS107 ASC 12,H107 "ABCD" PRINTED NOW/ MS110 ASC 23,E110 NO E-O-P BIT OR BUSY BIT IN STATUS BYTE/ MS111 ASC 24,E111 E-O-P BIT OR BUSY BIT STILL IN STATUS BYTE/ MS112 ASC 17,TEST 12 MULTIFUNCTION READER TEST/ MS113 ASC 24,E113 READ FAIL: A-REG RECEIVED, B-REG EXPECTED/ MS114 ASC 14,E114 DEVICE CLEAR INACTIVE/ MS115 ASC 13,TEST 03 "SELF-TEST" TEST/ MS116 ASC 13,E116 SELF-TEST TIMED OUT/ MS117 ASC 19,E117 BAD STATUS BYTE AFTER SELF-TEST/ MS135 ASC 21,E135 NO VALDA FOR STATUS BYTE SERIAL POLL/ MS143 ASC 21,E143 MORE THAN ONE ACK RECEIVED,PRESS RUN/ MS144 ASC 23,E144 NO ACK RECEIVED FOR THIS POLL, PRESS RUN/ MS145 ASC 22,E145 BIT15 SET IN LAST TRANSFER TABLE WORD/ MS146 ASC 24,E146 BIT15 CLEAR & NOT LAST TRANSFER TABLE WORD/ MS161 ASC 24,E161 MODE II KEYBOARD FAILURE OR SEQUENCE ERROR/ * * * * FWAA EQU * * * END ;NLHHN @ 92900-18002 1913 S 0422 &DVA47 92900B SUBSYSTEM DRIVER             H0104 ASMB,R,L,Z USE 'Z' FOR RTE-III *ASMB,R,L,N USE 'N' FOR RTE-II * IFN BEGIN RTE-II CODE NAM DVA47,0 92900-16002 REV.1913 781122 RTE-II XIF * **** * IFZ BEGIN RTE-III CODE NAM DVA47,0 92900-16003 REV.1913 781122 RTE-IV XIF SPC 2 ENT IA47,CA47 EXT $ETEQ,$OPSY SUP PRESS EXTRA LISTING * SETEQ EQU $ETEQ SPC 3 * NAME: DVA47 HP 92900B SUBSYSTEM DRIVER * SOURCE TAPE: 92900-18002 781122 (RTE-II/III/IV/M) * BINARY TAPE: 92900-16002 (RTE-II) / 92900-16003 (RTE-III/IV) * LISTING: 92900-19002 781122 / 92900-19003 781122 * PGMR: F.G. - ( D.P. DVA47 REV-A ---> DVA47 REV-B ) * DATE: NOVB 22 1978 - GRENOBLE - * MANUAL: 92900-90005 * SPC 4 **************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * **************************************************************** HED INITIATION SECTION. ******************************************************************** * INITIATION SECTION * ******************************************************************** SPC 1 IA47 NOP STA SELEC SAVE SELECT CODE OF CONTROLLER JSB SETIO CONFIGURE I/O INSTRUCTIONS LDB EQT13,I GET ADDRESS OF EQT16 STB EQT16 STORE IN TEMPORARY BUFFER INB COMPUTES ADDRESS OF EQT17 STB EQT17 STORE IN TEMPORARY BUFFER INB COMPUTES ADDRESS OF EQT18 STB EQT18 STORE IN TEMPORARY BUFFER SPC 1 LDB EQT12,I GET ADDRESS OF DUMMY EQT13 SZB,RSS IS IT EQUAL TO ZERO ? JMP SETP0 YES: IT COULD BE DUMMY EQT CPB D3 HAS THIS CONTROLLER ALREADY BEEN USED ? JMP SETP2 NO: GO TO INITIALIZE THIS LINK SETP0 ADB DM7 YES: COMPUTE PROBABLE DUMMY EQT6 ADDRESS LDA B,I GET DUMMY EQT6 CONTENT CPA M1 HAS THIS CONTROLLER ALREADY BEEN USED ? JMP SETP1 YES: SET UP LOCAL POINTERS SZA,RSS NO: IS EQT6 CONTENT UNALTERED ? JMP SETP2 YES: CONTROLLER HAS NOT BEEN USED JMP ILRQT DUMMY EQT WAS DESTROYED !!!!!!!!! SETP1 ADB D7 COMPUTE DUMMY EQT13 ADDRESS JSB SETP. SET UP LOCAL POINTERS JMP IA472 CONTINUE * SETP2 JSB INIT0 INITIALIZE THE CONTROLLER * IA472 LDA EQT17,I CLEAR OP-CODE/STEP-NUM/START BIT AND B277 STA EQT17,I AND B77 SZA,RSS IS TERM # 0 ? JMP POWF YES, MUST BE A POWER FAIL RECOVERY CALL. SPC 1 CLA CLEAR TLOG STA EQT10,I LDA EQT11 JSB SETTQ SET TEMPORARY TEQXX POINTER LDA EQT5,I RESET STATUS IN EQT5 AND LHALF STA EQT5,I SPC 1 * LDA .WSRQ CHECK IF THE TERMINAL IS ALREADY IA4.1 LDB A,I IN USE (I.E. LINKED IN ONE SZB,RSS QUEUE OF THE DRIVER) JMP IA4.2 IT IS THE END OF WAITING SRQ QUEUE CPB EQT11 IS IT THIS TERMINAL ? JMP IA4.6 YES, REMOVE IT FROM THE QUEUE LDA B NO: CONTINUE SCANNING JMP IA4.1 THIS QUEUE UNTIL END OF QUEUE SPC 1 IA4.2 LDA .COMQ NOW SEARCH IN COMPLETION QUEUE IA4.3 LDB A,I SZB,RSS JMP IA4.4 IT IS THE END OF COMPLETION QUEUE CPB EQT11 IS IT THIS TERMINAL ? JMP IA4.6 YES, REMOVE IT FROM THE QUEUE LDA B NO, CONTINUE SCANNING JMP IA4.3 THIS QUEUE UNTIL END OF QUEUE. * IA4.4 LDA .ACTQ NOW SEARCH IN ACTIVE QUEUE IA4.5 LDB A,I SZB,RSS END OF QUEUE ? JMP IA4.7 YES, END OF ACTIVE QUEUE CPB EQT11 NO, IS IT THIS TERMINAL ? JMP IA4.6 YES, REMOVE IT FROM THE QUEUE LDA B NO, CONTINUE SCANNIN@|G JMP IA4.5 THIS QUEUE UNTIL END OF QUEUE. * IA4.6 LDB B,I GET NEXT LINK IN THE LIST, STB A,I PUT IT IN PREVIOUS ONE TO CLA DEQUEUE THIS TERMINAL AND STA EQT11,I CLEAR THIS LINK WORD. SPC 1 IA4.7 LDA EQT6,I GET REQUEST WORD RAR SSA,SLA CONTROL REQUEST ? JMP I.CO YES, PROCESS CONTROL REQUEST SLA READ/WRITE 0/1 JMP I.WR PROCESS WRITE REQUEST JMP I.RD PROCESS READ REQUEST * SKP IA475 IOR EQT17,I MERGE OP-COD & STEP-NUM. IA476 STA EQT17,I IN BIT 15-8 OF EQT17. * * PUT THE NEW TERMINAL IN THE ACTIVE QUEUE. * LDA .ACTQ,I GET ACTIVE QUEUE HEAD LDB EQT11 AND INSERT THIS TERMINAL STA B,I AT THE BEGINING OF THE QUEUE STB .ACTQ,I ADA .COMQ,I IN THE COMPLETION QUEUE ? SZA,RSS IS SERIAL LINK ACTIVE ? JMP STRLO NO, START CONTROLLER * STCH1 STC 0 YES, INTERRUPT AFTER NEXT POLLING CYCLE IA479 CLA JMP IA47,I RETURN WITH A=0 CONTINUE SPC 2 IMMC LDA D4 IMMEDIATE COMPLETION CLB TRANSMISSION LOG = 0 JMP IA47,I EXIT. SKP ******************************************************************** * ERROR RETURN IN INITIATION SECTION * ******************************************************************** SPC 1 ILRQ LDB D5 ILLEGAL REQUEST, ERR CODE=5 ILRQ5 LDA EQT5,I SET ERR. CODE IN THE STATUS AND LHALF WORD, EQT5 BIT 7:0 IOR B AND SET BIT 15 OF TLOG WORD STA EQT5,I AS AN ERROR INDICATOR. LDA D3 SET COMPLETION CODE FOR SYSTEM CPB D5 IF IT WAS ILLEGAL REQUEST THEN LDA D4 SET COMPL. CODE TO ILL. REQ. LDB BIT15 JMP IA47,I * ILRQT LDB D4 BAD EQT CONFIGURATION JMP ILRQ5 EXIT WITH ERR. CODE=4 * ILRQ7 CLA THE CONTROLLER SEEMS TO BE DEAD STA .ACTQ,I OR NOT THERE, CLEAR ACTIVE QUEUE, STA .WSRQ,I CLEAR WAITING QUEUE LDB D3 AND EXIT WITH ERR. CODE=3 JMP ILRQ5 AND EQUIP. MALFUNCTION/NOT READY TO THE SYSTEM * D2 DEC 2 D3 DEC 3 D4 DEC 4 D5 DEC 5 SPC 2 ******************************************************************** * POWER FAIL RECOVERY ROUTINE. * ******************************************************************** SPC 1 POWF LDA .ACTQ POWER FAIL HAS OCCURED CLB CLEAR ALL QUEUES. POWF3 STA COUNT LDA A,I STB COUNT,I SZA JMP POWF3 LDA .COMQ POWF5 STA COUNT LDA A,I STB COUNT,I SZA JMP POWF5 LDA .WSRQ CLEAR WAITING QUEUE POWF7 STA COUNT LDA A,I STB COUNT,I SZA JMP POWF7 CLC.5 CLC 0 STOP THE CONTROLLER JMP IMMC IMMEDIATE COMPLETION EXIT. SKP ******************************************************************** * * * THIS SERIAL LINK IS NOT IN OPERATION * * INITIALIZE DXT AND RESTART THE CONTROLLER * * * ******************************************************************** SPC 1 STRLO LDA EQT17,I AND B77 MASK OUT TERMINAL # CMA,INA AND STA COUNT INITIALIZE THE DXTAB (DATA TRANSFERT LDB DXTAD TABLE.) RSS INB BUMP POINTER LDA IDLCD IDLE COMMAND FOR ALL THE UNUSED STA B,I TERMINAL IS PUT IN ISZ COUNT THE TABLE JMP *-4 LOOP UNTIL LAST TERMINAL STB CULAT UPDATE LAST ACTIVE TERM. INDICATOR STB CURWD * CLA CLEAR STA STCFL INTERRUPT NEXT POLLING CYCLE FLAG JSB GETNW GET NEXT WORD TO OUTPUT RSS JMP ILRQ7 IT IS NOT POSSIBLE !! JSB SEND OUTPUT TABLE TO THE CONTROLLER. JMP ILRQ7 CONTROLLER DOESN'T ANSWER: ERROR ! JMP IA479 OK, GOOD TRANSFER, EXIT. SPC 2 COUNT NOP IDLCD OCT 120000 BIT STOP & BIT IDLE ARE SET. * TEQ4 NOP EQT 4 ADDRESS TEQ5 NOP TEQ6 NOP TEQ7 NOP TEQ8 NOP TEQ9 NOP TEQ10 NOP TEQ11 NOP TEQ12 NOP TEQ14 NOP TEQ15 NOP TEQ16 NOP TEQ17 NOP TEQ18 NOP * DM4 DEC -4 DECIMAL -4 DM6 DEC -6 DECIMAL -6 DM7 DEC -7 DECIMAL -7 DM10 DEC -10 DECIMAL -10 M6 DEC -6 D7 DEC 7 D8 DEC 8 DECIMAL 8: OCTAL 10 D10 DEC 10 DECIMAL 10 D12 DEC 12 SKP TEMP2 NOP TEMPORARY BUFFER TEMP3 NOP TEMPORARY BUFFER * INIT0 NOP FIRST TIME INITIALIZATION LDA EQT# CMA,INA PREPARE FOR SCANNING STA COUNT OF ALL THE EQUIPMENT TABLE CLA STA TEMP1 LDB EQTA INIT2 ADB D3 GET SELECT CODE FROM EQT4 STB TEMP2 SAVE CURRENT EQT4 ADDRESS TEMPORARILY LDA 1,I AND B77 DOES THIS EQT REFERS TO THIS CPA SELEC CONTROLLER ? JMP INIT4 YES, INIT EQT INIT3 LDB TEMP2 GET CURRENT EQT4 ADDRESS ADB D12 INCREMENT POINTER ISZ COUNT END OF EQT ? JMP INIT2 NO, GET NEXT EQT ENTRY * LDB TEMP3 GET DUMMY EQT13 ADDRESS JSB SETP. SET UP LOCAL POINTERS CLA CLEAR STA .ACTQ,I ACTIVE QUEUE & STA .WSRQ,I WAITING SRQ QUEUE & STA .COMQ,I COMPLETION QUEUE FOR THIS CONTROLLER. JMP INIT0,I SPC 1 INIT4 LDA TEMP1 GET TERMINAL NUMBER SZA,RSS DUMMY EQT ENTRY ? JMP INIT5 YES, INITIALIZE LDA B,I SET THE "DRIVER WILL PROCESS IOR BIT12 TIME-OUT" BIT IN EQT4 STA B,I TO WILL BE SUPPORTED * ADB D7 COMPUTES EQT11 ADDRESS CLA AND STA B,I CLEAR QUEUE LINK WORD INB COMPUTES EQT12 ADDRESS JSB INIT7 VERIFY EQT EXTENSION LENGTH LDA TEMP3 GET DUMMY EQT13 ADDRESS STA B,I AND STORE IT; IN EQT12 OF TERMINAL INB COMPUTE EQT13 ADDRESS LDB B,I GET EQT16 ADDRESS LDA DTLKA GET DEFAULT TALKER ADDRESS STA B,I AND SET EQT16 INB COMPUTES EQT17 ADDRESS LDA TEMP1 GET TERMINAL NUMBER STA B,I AND PUT IT IN EQT17 INB COMPUTES EQT18 ADDRESS LDA B32 INITIALIZE EQT18 READER CTRL. WORD STA B,I AND STORE IN EQT18 INIT6 ISZ TEMP1 COMPUTE NEXT TERMINAL NUMBER JMP INIT3 GET NEXT EQT SPC 1 INIT5 LDA BIT13 SET THE "I WILL HANDLE POWER IOR B,I FAIL" BIT IN THE DUMMY EQT. IOR BIT12 SET "I WILL PROCESS T.O." BIT STA B,I IN EQT4 INB SET THE BUSY BIT IN THE LDA BIT15 DUMMY EQT5 TO PROCESS POWER IOR B,I FAIL FOR THE WHOLE LINK STA B,I SET EQT5 WORD FOR POWER FAIL * INB COMPUTE DUMMY EQT6 ADDRESS CCA SET THE "LINK ALREADY INITIALIZED" FLAG STA B,I IN THE EQT6 OF THE DUMMY EQT INB COMPUTE DUMMY EQT7 ADDRESS LDA DEFOT GET DEFAULT: 4 SECONDS WSRQ TIME OUT STA B,I AND PRESET DUMMY EQT7 ADB D5 COMPUTE DUMMY EQT12 ADDRESS JSB INIT7 VERIFY EQT EXTENSION LENGTH INB COMPUTE DUMMY EQT13 ADDRESS STB TEMP3 SAVE IT TO COPY IT IN TERMINAL EQT12 LDB B,I GET EQT16 ADDRESS INB COMPUTE EQT17 ADDRESS CLA A=0 STA B,I INITIALIZE TERMINAL NUMBER TO 0 * LDA INTAB VERIFY THAT THIS EQT ADA M6 IS REFERENCED BY THE INTERRUPT TABLE ADA SELEC LDA A,I ADA D12 POINT ON EQT13 CPA TEMP3 IS CONFIGURATION ALL RIGHT ? JMP INIT6 YES, GO AHEAD JMP ILRQT NO, MUST RECONFIGURE * DEFOT DEC -400 DEFAULT VALUE FOR TIME OUT SPC 3 INIT7 NOP SUBROUTINE TO CHECK EXTENSION LENGTH LDA B,I GET EQT12 WORD CONTENT CPA D3 IS IT A 3 WORD LENGTH EXTENSION ? RSS YES: RETURN JMP ILRQT NO: MUST RECONFIGURE JMP INIT7,I EVERYTHING IS O.K. SPC 3 *-------> DUMMY EQT12: ACTIVE QUEUE HEAD SPC 3 *-------> DUMMY EQT16: COMPLETION QUEUE HEAD SPC 3 *-------> DUMMY EQT18: WAITING QUEUE HEAD SKP ******************************************************************** * READ REQUEST INITIATION * ******************************************************************** SPC 1 I.RD JSB BFSET SET BUFF ADDR AND LENGTH TO EQT NOP ZERO LENGTH (ONLY LF ACCEPTED) JSB STREN SET REN BIT IN STATUS * JSB CLBT7 CLEAR BIT 7 AND KEEP IT STATUS * LDA EQT6,I GET REQUEST CODE AND BIT10 MASK OUT BIT 10 CPA BIT10 IS IT SET ? JMP I.WD YES: INITIALIZE A WRITE/READ * LDB EQT16,I NO: GET TRANSPARENT MODE FLAG IN BIT 15 LDA OPRDX TRANSPARENT MODE READ OP-CODE SSB TRANSPARENT MODE ? JMP IA475 YES: SET OP-CODE INTO EQT17 * JSB BADG? IS IT A CARD READER READ ? JMP I.RD2 NO, OR READER ABSENT: CONTINUE LDA OPCAR YES: GET OP-CODE/STEP NUMBER FOR O.M.R. JMP IA475 AND SET OP-CODE INTO EQT17 * I.RD2 LDA EQT6,I GET OPERATION CODE IOR TEMP1 RESTORE BIT 7 STATUS AND NBT9 ELIMINATE BIT 9 (NO CARD READER) STA EQT6,I FORCE EQT6 WORD: READ FROM KEYBOARD LDB EQT6,I GET REQUEST CONTROL WORD BLF,BLF AND ROTATE BIT:K INTO B0 LDA OPRD NORMAL MODE READ OP-CODE SLB BIT: K = 1 ? LDA OPRDK NORMAL MODE READ OP-CODE JMP IA475 AND SET OP-CODE INTO EQT SPC 2 STREN NOP GET STATE OF THE REN BIT LDA EQT17,I FROM EQT17 AND BIT7 AND PUT IT IN RAR STATUS WORD BIT6 LDB EQT5,I IOR B STA EQT5,I JMP STREN,I SPC 1 CLBT7 NOP CLEAR AND SAVE STATUS BIT 7 LDA EQT6,I GET REQUEST CODE a AND BIT7 MASK OUT BIT 7 STA TEMP1 SAVE IT TEMPORARILY LDA EQT6,I GET EQT6 REQUEST CODE AND NBT7 CLEAR BIT 7 STA EQT6,I RESTORE EQT6 REQUEST CODE JMP CLBT7,I RETURN SPC 2 SKP ******************************************************************** * WRITE/READ REQUEST INITIATION * ******************************************************************** SPC 1 I.WD LDA EQT8,I GET TOTAL BUFFER LENGTH JSB NGTIF COMPUTE TOTAL BYTE LENGTH (NEGATIVE) CMA,INA MAKE IT POSITIVE ADA DM4 SUBSTRACT FIRST TWO WORDS STA TEMP1 SAVE IT TEMPORARILY LDB EQT7,I GET ADDRESS OF FIRST WORD OF BUFFER LDA B,I GET OUTPUT BUFFER LENGTH SZA,RSS IS IT EQUAL TO ZERO ? JMP I.WD0 YES: REJECT THE CALL JSB NGTIF COMPUTE OUTPUT BYTE LENGTH (NEGATIVE) STA EQT10,I USE EQT10 AS AN OUTPUT BYTE COUNTER AND NBT0 MAKE IT ODD !!!! (MAY BE +1) ADA TEMP1 A=[TOTAL-4-ODD OUTPUT LGTH.] STA TEMP1 SAVE IT TEMPORARILY INB COMPUTE ADDRESS OF SECOND WORD OF BUFFER LDA B,I GET INPUT BUFFER LENGTH JSB NGTIF COMPUTE INPUT BYTE LENGTH (NEGATIVE) ADA TEMP1 A=[TOTAL-4-ODD OUTPUT LGTH.-INPUT LGTH.] LDB D1 PREPARE AN EVENTUAL ERROR CODE SSA IS IT POSITIVE ? I.WD0 JMP ILRQ REJECT THE CALL !!!!!!!! LDB EQT7,I GET FIRST WORD BUFFER ADDRESS LDA B GET FIRST WORD BUFFER ADDRESS ADA D2 COMPUTE FIRST WORD OUTPUT BUFFER ADDRESS CLE,ELA COMPUTE FIRST OUTPUT BYTE BUFFER ADDRESS STA EQT9,I USE EQT9 AS OUTPUT BUFFER BYTE POINTER JSB STREN SET REN BIT IN STATUS * LDA OPWCN GET OP-CODE/STEP # STARTING WORD LDB EQT16,I GET TRANSPARENT/NORMAL MODE OF READING SSB NORMAL OR TRANSPARENT ? LDA OPWCB TRANSPARENT: SKIP TWO FIRST STEPS JMP IA475 CONTINUE SPC 3 * OP-mCODE/STEP NUMBER INITIALIZATION TABLE SPC 1 * BIT 6 ALWAYS SET. (INDICATES COMING FROM INITIATOR) * OPRDK OCT 010100 OP-COD=1, STEP=0. OPRD OCT 010500 OP-COD=1, STEP=1. OPWR OCT 020100 OP-COD=2, STEP=0. OPPRI OCT 020500 OP-COD=2, STEP=1. (WRITE ON PRINTER) OPSP OCT 030100 OP-COD=3, STEP=0. OPREN OCT 040300 OP-COD=4, STEP=0, BIT REN. OPWSR OCT 050100 OP-COD=5, STEP=0. OPEOR OCT 070100 OP-COD=7, STEP=0. OPCAR OCT 100100 OP-COD=8, STEP=0. (BADGE CARD READER) OPRDX OCT 102500 OP-COD=8, STEP=5. (TRANSPARENT MODE READ) OPWRX OCT 110100 OP-COD=9, STEP=0. OPRDI OCT 120100 OP-COD=10, STEP=0. OPGSB OCT 130100 OP-COD=11, STEP=0. OPCSR OCT 140100 OP-COD=12, STEP=0. OPTSK OCT 150100 OP-COD=13,STEP=0. (SFK TERMINATOR) OPWCN OCT 160100 OP-COD=14,STEP=0. (WRITE COMMAND/READ NORMAL) OPWCB OCT 161100 OP-CODE=14,STEP=2. (WRITE COMMAND/READ TRANSPARENT) OPWTQ OCT 170100 OP-CODE=15,STEP=0. (CHECK SRQ PERIODICALLY) SKP ******************************************************************** * WRITE REQUEST INITIATION * ******************************************************************** SPC 1 I.WR JSB STREN SET REN BIT INTO STATUS WORD * JSB CLBT7 GET BIT 7 STATUS & CLEAR IT * LDB EQT6,I BLF,RBL ELB,BLF BIT:X -->E, BIT:M --> B0 SEZ STANDARD WRITE ? JMP I.WR4 NO, SPECIAL WRITE LDB EQT16,I GET TRANSPARENT MODE FLAG SSB TRANSPARENT MODE ? JMP I.WR6 YES LDA EQT6,I NO: NORMAL MODE IOR TEMP1 RESTORE BIT 7 STA EQT6,I IN CONTROL REQUEST WORD LDA OPWR GET OP-CODE/STEP NUMBER LDB TEQ18,I GET HARDWARE STATUS WORD SSB,RSS IS THERE A PRINTER ? JMP IA475 NO: WRITE ON DISPLAY LDB EQT6,I GET REQUEST CODE BLF MOVE BIT 9 IN BIT 13 RBL,RBL MOVE BIT 9 IN BIT 15 SSB IS IT A WRITE ON PRINTER ? LDA OPPRI YES: SKIP FIRST STEP JMP IA475 NORMAL MODE * I.WR4 SLB,RSS SERIAL POLL REQUEST ? JMP I.SP YES I.WR6 LDA OPWRX NO, WRITE COMMAND BYTE REQUEST JMP IA475 * SPC 2 ******************************************************************** * SERVICE REQUEST ANALYSIS INITIATION (SERIAL POLL) * ******************************************************************** SPC 1 I.SP LDA EQT8,I GET BUFFER LENGTH SSA POSITIVE VALUE ? JMP ILRQ NO, ERROR ILLEGAL RQ. CMA,INA STA EQT10,I USE EQT10 AS A WORD COUNT LDA EQT7,I GET BUFFER ADDR. STA EQT9,I USE EQT9 AS A WORD POINTER LDA OPSP GET OPCOD JMP IA475 SKP ******************************************************************** * CONTROL REQUEST INITIATION * ******************************************************************** SPC 1 I.CO LDA TEQ6,I GET CONTROL WORD ALF,ALF RAL,RAL AND B37 ADA COFAD CHECK IF LDB COFED FUNCTION CODE CMB,INB IS ADB A WITHIN SSB TABLE JMP ILRQ NO, ERROR JMP A,I YES, JUMP TO PROPER ROUTINE SPC 1 ******************************************************************** * CLEAR REQUEST INITIATION * ******************************************************************** SPC 1 CL LDA M6 USE EQT9 AS A COUNTER FOR STA TEQ9,I BAD OK BIT LDA TEQ16,I PRESET NEXT AND BIT15 TALKER ADDRESS AND READ COMPLETION IOR DTLKA FLAG BUT KEEP CURRENT MODE. STA TEQ16,I LDA TEQ18,I GET EQT18 AND BT012 SAVE BITS 15, 14, & 13 IOR B32 INITIALIZE READER CONTROL WORD STA TEQ18,I CLEAR READER CONTROL WORD LDA TEQ17,I CLEAR OP-COD, STEP-NUM & REN BIT AND B77 IN EQT17 IOR BIT6 MERGE START BIT JMP IA476 * DTLKA OCT 35 DE;:B@ [B] ADB DM31 COMPARE TO 310 M.S. SSB TIME OUT < 310 M.S. ? LDA D31 YES: FORCE TIME OUT = 310 M.S. CMA,INA MAKE IT NEGATIVE JSB LOEQT GET DUMMY EQT7 ADDRESS STA B,I UPDATE DUMMY EQT7 VALUE * WTSR1 LDA OPWTQ OP-CODE FOR A WAIT FOR SRQ PERIODICALLY JMP IA475 INITIALIZE THE REQUEST SPC 2 ******************************************************************** * WAIT UNTIL SRQ RECEIVED * ******************************************************************** SPC 1 WSRQ LDA OPWSR GET OP CODE JMP IA475 SPC 2 ******************************************************************** * SET CARD/BADGE READER CONTROL WORD * ******************************************************************** SPC 1 CARSP LDA EQT7,I GET BADGE READER CONTROL WORD AND B37 MASK OUT SIGNIFICANT BITS SZA,RSS IS IT UNDEFINED ? JMP IMMC YES: DO NOT MODIFY CTRL. WORD STA TEMP1 SAVE CONTROL WORD TEMPORARILY LDA TEQ18,I GET EQT18 WORD AND OC37 CLEAR READER CONTROL WORD IOR TEMP1 MERGE WITH NEW ONE STA EQT18,I STORE THIS CONTROL WORD IN EQT18 JMP IMMC IMMEDIATE COMPLETION SPC 2 ******************************************************************** * SET TIME OUT VALUE * ******************************************************************** SPC 1 STO LDB EQT7,I GET NEW TIME OUT VALUE SSB,RSS IS IT POSITIVE ? CMB,INB YES: MAKE IT NEGATIVE STB EQT14,I UPDATE TIME OUT. JMP IMMC SPC 2 ******************************************************************** * SET IFC LINE TRUE THEN FALSE * ******************************************************************** SPC 1 IFC LDA OPIFC GET OP-CODE/STEP-NUMBER FOR IFC CONTROL JMP IA475 PROCESS THE REQUEST AFTER MERGING A IN EQT17 * OPIFC OCT 002100 OP-CODE=0, STEP=4. (SET/CLEAR IFC) SKP ******************************************************************** * ENABLE/DISABLE READ TERMINATION ON A SPECIAL FUNCTION KEY * ******************************************************************** SPC 1 TSFK LDB EQT7,I GET SFK CODE SSB MAKE IT POSITIVE CMB,INB CPB D1 TERMINATION ON SRQ ? JMP TSFK5 YES, GOTO PROCESS * ADB M2 NO, CHECK SOFT KEY NUMBER SSB SFK # > OR = TO 2 ? JMP ILRQ ILLEGAL REQUEST ADB M#SFK SSB,RSS SFK # < OR = TO 11 JMP ILRQ NO: ILLEGAL REQUEST CPB M1 IS IT SFK# 11 ? RSS YES: CHECK TERMINAL TYPE JMP TSFK4 NO: PROCESS IT * JSB AORB? IS IT A 3070B TERMINAL ? JMP ILRQ NO: ILLEGAL REQUEST JMP TSFK4 3070B: PROCESS SFK # 11. * TSFK5 LDA BIT11 SET BIT 11 IN A REGISTER LDB EQT7,I PROCESS THE KEY SSB ENABLE OR DISABLE ? JMP TSFK2 DISABLE IOR TEQ18,I MERGE BIT 11 TSFK1 STA TEQ18,I AND SAVE NEW EQT18 JMP IMMC IMMEDIATE COMPLETION TSFK2 LDA NBT11 KEEP ALL BITS EXCEPT BIT 11 AND TEQ18,I CLEAR BIT 11 OF EQT18 JMP TSFK1 DISABLE SFK # 11 * TSFK4 ADB TSFKT LDA B,I GET THE BIT AND LDB EQT7,I PROCESS SSB ENABLE OR DISABLE ? JMP TSFK8 DISABLE IOR TEQ16,I ޾ENABLE, SET THE BIT TSFK7 STA TEQ16,I AND SAVE NEW EQT16 JMP LSFK LOCAL PROGRAMMATION * TSFK8 CMA DISABLE, CLEAR THE BIT AND TEQ16,I JMP TSFK7 * LSFK JSB AORB? IS IT A MODEL 3070B ? JMP IMMC NO: IMMEDIATE COMPLETION LDA EQT7,I GET SOFT KEY NUMBER SSA POSITIVE ? CMA,INA NO: MAKE IT POSITIVE ADA M2 TRANSLATE TO THE RIGHT KEY LDB EQT7,I GET SFK FUNCTION SSB,RSS IS IT POSITIVE ? IOR BIT4 YES: MEANS SOFT KEY TERMINATOR STA EQT8,I SAVE THIS SECONDARY ADDRESS IN EQT8 LDA EQT8 GET EQT8 ADDRESS STA EQT9,I AND SAVE IT IN EQT9 FOR MERGING. LDA OPTSK GET OP-CODE/STEP NUMBER WORD JMP IA475 START A CONTINUATION SPC 2 ******************************************************************** * SET NORMAL OR TRANSPARENT MODE * ******************************************************************** SPC 1 NM CCB SET NORMAL MODE NM2 LDA BIT15 SSB,RSS NORMAL/TRANSPARENT MODE ? JMP NM3 TRANSPARENT MODE * CMA SET NORMAL MODE AND TEQ16,I IN EQT16 WORD NM4 STA TEQ16,I STORE NEW EQT16 JMP IMMC IMMEDIATE COMPLETION * NM3 IOR TEQ16,I SET TRANSPARENT MODE BIT JMP NM4 IN EQT16 WORD SPC 1 TM CLB SET TRANSPARENT MODE JMP NM2 HED CONTINUATION SECTION. ******************************************************************** * CONTINUATION SECTION * ******************************************************************** SPC 1 CA47 NOP JSB SETIO SPC 1 LDA EQT4,I IS IT A TIME OUT INTERRUPT ? ALF SSA DID THE DEVICE TIMED OUT ? JMP TO YES, PROCESS SPC 1 LDA EQT6,I GET EQT6 CONTENT CPA M1 IS IT THE CONTROLLER ONE ? RSS YES: PROCESS THE INTERRUPT JMP CY47] NO: IGNORE THIS INTERRUPT !!! LDB EQT13 GET ADDRESS OF DUMMY EQT13 JSB SETP. SET UP LOCAL POINTERS LDB DXTAD USE B AS POINTER INTO DXT LIAC1 LIA 0,C READ DATA FROM CONTROLLER STA B,I STORE INFORMATION INTO DXT SSA,RSS WAS IT LAST WORD FROM CONTROLLER ? JMP GET.2 YES, PROCESS DATA SFS.1 SFS 0 IS FLAG SET ? JMP ERR0 NO - ABNORMAL, IGNORE THIS INTERRUPT. INB INCREMENT POINTER INTO DXT CPB DXT.D IS IT INSIDE THE DXT TABLE ? JMP ERR0 NO - ABNORMAL, ERROR RETURN !!!!!!! JMP LIAC1 LOOP IN DXT SPC 1 GET.2 IOR BIT15 MERGE BIT 15 TO BE ABLE TO ADD STA B,I NEW TERMINALS WITH GREATER ADDR. STB OLLAT SAVE PREVIOUS LAST TERMINAL # CLA CLEAR STA CULAT PREVIOUS CURRENT TERMINAL STA STCFL INTERRUPT AFTER NEXT POLLING CYCLE FLAG SPC 1 ******************************************************************** * * * GO ALONG THE QUEUE OF ACTIVE TERMINAL, * * AND TREAT DATA FROM DXT. * * * ******************************************************************** SPC 1 IFZ RSA GET MEM STATUS RAL,RAL AND STA DMSST SAVE IT LDA MAPUS SAVE ALSO CURRENT USER MAP IOR BIT15 TO MEMORY USA GET USER MAP CLA SET FLAG STA MAPFL TO NOT RESTORE USER MAP SJP TRD00 ENABLE SYSTEM MAP TRD00 EQU * XIF SKP LDA .ACTQ LDB A,I GET ACTIVE QUEUE HEAD SZB,RSS ACTIVE QUEUE EMPTY ? JMP CMPL0 ACTIVE QUEUE EMPTY: COMPLETION STA PTAQU SPC 1 TRD02 ADB D2 COMPUTES EQT13 ADDRESS LDB B,I GET EQT16 ADDRESS INB COMPUTES EQT17 ADDRESS (OP-CODE/STEPp #) STB TOFL SET UP "NO LONGER T.O." (EQT17 ADDRESS) LDA B,I GET EQT17 CONTENT AND B77 MASK OUT TERMINAL # ADA M1 OFFSET IT IN DXTAB ADA DXTAD STA CURWD SAVE CURRENT POINTER INTO DXT LDA A,I GET DATA FOR THAT TERMINAL STA DXTWD SAVE CURRENT DATA WORD FROM DXT SPC 1 LDA B,I CHECK IF COMING FROM INITIATOR SECTION AND B100 SZA JMP TRD09 YES SPC 1 LDA DXTWD IS THIS TERMINAL IN AND BIT13 IDLE STATE SZA ? JMP TRD04 YES,GOTO NEXT ONE. SPC 1 LDA B,I RECALL EQT17 AND LHALF ISOLATE OP-COD & STEP-NUM. CPA Y.CS# CHECK FOR SRQ PROCESSING ? JMP TRD03 YES, IGNORE DXT DATA CPA Y.SP# CHECK FOR SRQ (GENERAL CASE) ? JMP TRD03 YES, IGNORE DXT DATA CPA Y.WS# IS IT THE STEP # 2 OF A WTSRQ ? JMP TRD03 YES, IGNORE DXT DATA AND B170K ISOLATE OP-CODE. SZA,RSS CLEAR REQUEST IN PROGRESS ? JMP TRD03 YES, GO PROCESS IT. SPC 1 LDA DXTWD AND B13K CHECK IF SOMETHING TO DO : SZA COMPUTE BOOLEAN LDA BIT14 EQUATION: LDB A OK . ( INT + VALDA + CO1 ) LDA DXTWD AND BIT14 ISOLATE BIT OK AND B SZA,RSS ANY PROCESSING TO DO ? JMP TRD04 NO: GET NEXT TERMINAL DATA WORD. * LDA TOFL,I YES: GET OP-CODE/STEP NUMBER WORD AND B170K MASK OUT OP-CODE FIELD CPA B170K IS IT A WAIT FOR SRQ PERIODICALLY ? CCA,RSS YES: DO NOT RE-INIT TIME OUT CLOCK ! CLA NO: SET UP TIME OUT FLAG TO STA TOFL RE-INIT THE TIME OUT CLOCK. SKP TRD03 LDA PTAQU,I PROCESS THIS TERMINAL JSB SETTQ SET LOCAL TEMPORARY EQT SPC 1 IFZ LDB TEQ5 RTE-III CODE ONLY ADB DM4 LDB B,I GET DRIVER LINK WORD FROM EQT1 SSB,RSS IF SIGN BIT SET, LEAVE SYSTEM MAP SZB,RSS !F IF NUL, LEAVE SYSTEM MAP JMP TRD37 LEAVE SYSTEM MAP * LDA B CHECK T FIELD IN CONTROL WORD INA LDA A,I GET CONTROL WORD RAL SSA T=1 OR 3 IF BIT15=1 JMP TRD37 T=1 OR 3, LEAVE SYSTEM MAP SLA,RSS JMP TRD32 T=0, GO SET USER MAP * LDA B T=2, GET ID WORD ADA D4 IN SYSTEM CALL LDA A,I SZA,RSS IS IT 0 JMP TRD37 YES, LEAVE SYSTEM MAP * TRD32 LDA B SET USER MAP ADA D2 LDA A,I GET USER BUFFER ADDR. FROM ID TMP WORD CCE,SSA WAS BUFFER MOVED IN SAM ? JMP TRD37 YES, LEAVE SYSTEM MAP * ISZ MAPFL NOW ACTUALLY SET USER MAP ! LDA B GET ID SEGMENT ADDR. JSB $XDMP CALL SYSTEM PROGRAM TO SET USER MAP SZA,RSS IS USER STILL IN PARTITION ? JMP TRD37 NO, USER MAP IS NOT NEEDED UJP TRD37 YES, ENABLE USER MAP TRD37 EQU * XIF SKP JSB GETNW GET NEW WORD TO OUTPUT RSS REQUEST COMPLETED FOR THIS TERMINAL ? JMP TRD05 YES TRD04 LDA CURWD NO, GET CURRENT TERMINAL POINTER LDB CULAT CMB,INB SUBTRACT LAST TERMINAL POINTER ADB A SSB,RSS IS THE CURRENT ONE GREATER ? STA CULAT YES, UPDATE CULAT. LDB PTAQU,I GET NEXT ENTRY IN ACTIVE QUEUE RSS TRD05 LDB PTAQU STB PTAQU SAVE NEW QUEUE POINTER VALUE * LDA CURWD,I SET BIT 15 TO INDICATE NOT IOR BIT15 THE LAST WORD OF DXT STA CURWD,I SPC 1 IFZ SJP TRD51 RE-ENABLE SYSTEM MAP TRD51 EQU * XIF SPC 1 LDA PTAQU RECALL QUEUE POINTER LDB A,I GET NEXT LINK SZB END OF QUEUE ? JMP TRD02 LOOP UNTIL END OF QUEUE. SPC 1 IFZ LDA MAPFL WAS USER MAP CHANGED SZA,RSS DURING THIS PROCESS ? JMP TRD54 NO, RESTORE DMS STATUS ONLY LDA MAPUS  YES, RESTORE USER MAP USA TRD54 JRS DMSST TRD56 RESTORE DMS STATUS AND CONTINUE TRD56 EQU * XIF SPC 1 LDA .ACTQ,I IS THE ACTIVE SZA,RSS QUEUE EMPTY ? JMP CMPL3 YES, GO CHECK FOR COMPLETION JSB CMPQ1 NO, IS COMPLETION QUEUE LENGTH > 1 ? TRD07 ISZ STCFL YES, FORCE AN INTERRUPT NEXT POLLING CYCLE JSB SEND AND SEND DATA TO THE CONTROLLER JMP ERR3 CONTROLLER DOESN'T ANSWER, ERROR CONDITION * LDA .COMQ,I BEFORE EXIT CHECK COMPLETION QUEUE SZA ANY COMPLETION PENDING ? JMP CMPLP YES COMPLETE ONE REQUEST. * CY47 ISZ CA47 EXECUTE CONTINUATION EXIT JMP CA47,I RETURN AT (P+2) SKP PTAQU NOP B13K OCT 13000 BIT INT/VALDA/CO1 B170K OCT 170000 OLLAT NOP TOFL NOP SPC 1 IFZ DMSST NOP MAPUS DEF *+1 BSS 32 MAPFL NOP TO KNOW IF USER MAP HAS TO BE RESTORED EXT $XDMP XIF SPC 2 ******************************************************************** * * * COMING FROM THE INITIATOR VIA AN INTERRUPT. * * COMPLETE THE DXT IF NECESSARY AND GET THE WORD * * TO OUTPUT TO THE CONTROLLER. * * * ******************************************************************** SPC 1 TRD09 LDA OLLAT CHECK IF NEW TERMINAL ADDRESS LDB CURWD GREATER CMB,INB THAN CURRENT LAST ACTIVE TERMINAL ADB A ADDRESS SSB,RSS IS THE PREVIOUS ONE GREATER ? JMP TRD03 YES, PROCESS THE REQUEST. LDB IDLCD NO, SET INTERMEDIATE TERMINALS TRD11 INA IN IDLE SATE STA OLLAT UPDATE CURRENT LAST ACTIVE TERMINAL ADDRESS STB A,I CPA CURWD JMP TRD03 THEN PROCESS THE REQUEST JMP TRD11 SKP ******************************************************E:************** * * * ONE COMPLETION IS PENDING, * * DEQUEUE THE REQUEST AND EXIT THROUGH COMPLETION * * RETURN (P+1). * * * ******************************************************************** SPC 2 CMPL0 EQU * CMPL3 LDB DXTAD SET UP FOR A DUMMY STB CULAT POLLING CYCLE I.E. : LDA IDLCD ONLY ONE TERMINAL (ADDR=1), AND STA B,I THIS TERMINAL IS IN IDLE STATE. JSB CMPQ1 IS COMPLETION QUEUE LENGTH > 1 ? JMP TRD07 YES, START THE DUMMY POLLING CYCLE * LDA .COMQ,I COMPLETION QUEUE LENGTH = 0 OR 1 SZA = 0: COMMING FROM WAITING PROCESS JMP CMPLP = 1: DEQUEUE THIS TERMINAL CLC.6 CLC 0 STOP THE CONTROLLER JMP CY47 EXECUTE CONTINUATION EXIT * CMPLP LDB A,I TO GET THE FIRST TERMINAL STB .COMQ,I IN THE COMPLETION QUEUE CLB EXTRACT IT AND CLEAR STB A,I LINK WORD. ADA DM10 COMPUTE CURRENT EQT1 ADDRESS JSB SETEQ SET SYSTEM EQT TO THE COMPL. RETURN * LDB .ACTQ,I GET ACTIVE QUEUE HEAD LDA .COMQ,I GET COMPL. QUEUE HEAD ADB A SZB,RSS ARE BOTH A&C QUEUES EMPTY ? CLC.2 CLC 0 YES, STOP CONTROLLER * LDB EQT10,I GET TLOG / ERROR INDICATOR LDA EQT9,I GET COMPLETION CODE AND JMP CA47,I EXIT AT (P+1) COMPLETION. SKP ******************************************************************** * ERROR PROCESSING IN THE CONTINUATION SECTION * ******************************************************************** SPC 2 ERR0 EQU * ERROR IN LIA'S SEQUENCE: CLC.3 CLC 0 RESET THE CONTROLLER AND EXIT JMP CY47 IGNORING THE INTERRUPT. SPC 2 ERR3 EQU * ERROR IN OTA'S SEQUENCE: CLC.4 CLC 0 RESET THE CONTFROLLER LDA .ACTQ,I SET EQUIP. MALFUNCTION COMPL. CODE AND SZA,RSS EXIT USING ONE OF THE CURRENT REQUEST, LDA .COMQ,I IF THE ACTIVE QUEUE IS EMPTY USE COMPLETION SZA,RSS THE CONTROLLER IS FAULTY, SO ANY LDA .WSRQ,I IF THE COMPLETION IS EMPTY USE WAITING SZA,RSS ALL QUEUES ARE EMPTY ???? JMP CY47 IT IS NOT POSSIBLE !! ADA DM10 COMPUTE CURRENT EQT1 ADDRESS JSB SETEQ LDA EQT5,I SET ERR. CODE=3 IN THE STATUS AND AND LHALF IN THE IOR D3 STATUS STA EQT5,I WORDS, CLA,INA EQUIPMENT MALFUNCTION CODE IN A LDB BIT15 BIT 15 OF TLOG TO INDICATE ERROR JMP CA47,I SPC 2 CMPQ1 NOP TO CHECK IF THE COMPLETION QUEUE LDB .COMQ,I HAS MORE THAN ONE ELEMENT. SZB,RSS RETURN IS DONE AS FOLLOW: JMP CMPQ2 MORE THAN 1 ELEMENT --> P+1 LDB B,I OTHERWISE --> P+2 SZB,RSS CMPQ2 ISZ CMPQ1 RETURN (P+2) 0 OR 1 ELEMENT. JMP CMPQ1,I RETURN (P+1) MORE THAN ONE ELEMENT. SKP ******************************************************************** * * * S/P: GETNW PUT THE NEW WORD INTO THE DXT * * USING THE OP-COD & STEP-NUM * * * ******************************************************************** SPC 2 GETNW NOP GETN1 LDA TEQ17,I GET OP-COD & TERM# GETN2 ALF AND B17 ISOLATE OP-CODE SZA,RSS CLEAR REQUEST ? JSB C.CL0 YES, VERIFY OK BIT & INTERR. NEXT TIME ADA .OPCT OFFSET INTO OP-COD TABLE LDB A,I SAVE CONTENT IN B LDB B,I GET TABLE ADDR. LDA TEQ17,I AND NBT6 CLEAR COMING FROM INITIATOR FLAG STA TEQ17,I ALF,ALF AND B17 ISOLATE STEP-NUM ADB A OFFSET INTO STEP# TABLE LDA B,I GEB@ E CPB BIT7 IS SRQ LINE TRUE ? JMP C.RD6 YES, COMPLETE IF ASCII & READR & SRQ ENBL. * LDA DXTWD NO SRQ, EXAMINE DATA AND B377 ISOLATE DATA PART SEZ ASCII READ REQUEST ? JMP C.RD3 NO, DON'T CHECK LF & RUB-OUT CODE. AND B177 ASCII REQUEST: CLEAR BIT 7 CPA LINF IS IT LINE-FEED ? JMP C.RDS YES CPA RUBUT IS IT DELETE CODE ? JMP C.RD9 YES, PROCESS IT LDB TEQ10,I IS BYTE COUNT SZB,RSS EXHAUSTED ? JMP SAMST YES, WAIT FOR THE LF SPC 1 C.RD3 EQU * LDB TEQ9,I STORE CHARAC. IN THE USER BUFFER. ISZ TEQ9,I BUMP BYTE POINTER CLE,ERB GET CHARACTER POINTER IN BUFFER SEZ,RSS SHIFT TO UPPER POSITION ALF,ALF STA TEMP1 SAVE CHARACTER LDA RHALF SEZ ADJUST MASK ACCORDING TO PARITY ALF,ALF AND B,I MASK WORD TO GET CHARACTER IOR TEMP1 MERGE WITH THE OTHER BYTE STA TEMP1 SAVE THE DATA WORD TEMPORARILY SEZ,CLE IS THERE TWO BYTES IN THE WORD ? * P *-----IF READ A CARD IN IMAGE MODE, PROCESS DATA * JSB IMAGE IT IS A CARD READING OPERATION * *-----STANDARD READING PROCESS * STA B,I SAVE WORD IN USER BUFFER ISZ TEQ10,I BUMP BYTE COUNTER NOP 0 & NOT 0 ARE BOTH OK * LDB TEQ6,I GET REQUEST CONTROL WORD BLF,BLF RBL ASCII/BINARY --> B15 SSB,RSS ASCII REQUEST ? JMP C.RD7 YES, ASCII REQUEST CHECK SFK LDA DXTWD NO, BINARY REQUEST CHECK EOI AND EOI SZA,RSS IS EOI LINE TRUE ? JMP C.RD4 NO: CONTINUE LDA BIT4 YES: SET EOI BIT IN EQT5 JMP C.RDL EOI IS TRUE, COMPLETE. C.RD4 LDA TEQ16,I NOW CHECK TRANSPARENT MODE ELA TRANSPARENT MODE FLAG --> E LDA DXTWD ALF,ALF BIT ATN --> A0 SEZ,RSS TRANSPARENT MODE ENABLED ? JMP C.RD5 NO, NORMAL MODE OF OPERATION SLA,RSS YES, TRANSPARENT MODE, ATN LINE ? JMP C.RD5 ATN LINE NOT TRUE, CHECK FOR BUFFER FULL LDA BIT5 ATN LINE TRUE, COMPLETE THE REQUEST WITH JMP C.RDL STATUS BIT 5 = 1 * C.RD5 LDA TEQ10,I GET BYTE COUNTER SZA IS BUFFER FULL ? JMP SAMST NO, GET NEXT INPUT CHARACTER SSB YES, BUFFER IS FULL, BINARY REQUEST ? JMP C.RDS YES, BINARY RQ & BUFF. FULL --> COMPLETE SEZ,RSS NO, ASCII REQUEST, WHICH MODE ? JMP SAMST ASCII NORMAL MODE --> WAIT FOR LF LDA B17 ASCII TRANSPARENT MODE --> COMPLETE WITH JMP C.RDL STATUS EOR=15(10) * C.RD6 CLA,INA THE TIME OUT MUST NOT BE RESTARTED STA TOFL SET "NO RESTART T.O." FLAG JSB BADG? IS IT A CARD READ OPERATION ? RSS NO: CONTINUE AS USUAL CLE YES: SIMULATES ASCII READ MODE LDA TEQ18,I GET COMPLETION-ON-SRQ FLAG ALF SRQ SFK ----> BIT 15 SEZ,RSS ASCII REQUEST ? SSA,RSS YES, COMPLETION ON SRQ ENABLED ? JMP SAMST NO, GET NEXT INPUT CHAR. LDA D1 ASCII REQUEST WITH COMPLETION ON SRQ JMP C.RDL ENABLED, COMPLETE WITH STATUS EOR=1 * C.RD7 LDA TEQ16,I AND SFKM SZA,RSS TERMINATION ON SFK ENABLED ? JMP C.RD4 NO LDA DXTWD YES, RECALL DXT WORD AND B177 ISOLATE CHARACTER ADA MSFK1 AND CHECK IF IT IS A SFK SSA OCTAL CODE < 20B ? JMP C.RD4 YES: NOT AN SFK ADA M#SFK OCTAL CODE > 31B ? SSA,RSS JMP C.RD4 YES: NOT AN SFK * ADA TSFKT INDEX IN BIT TABLE LDA A,I AND GET PROPER BIT AND TEQ16,I MASK OUT IN EQT16 SZA,RSS SET ? JMP C.RD4 NO, CONTINUE * LDA DXTWD YES: SET END-OF-RECORD INDICATOR IN STATUS AND B177 THE EOR BEING THE SFK NUMBER ADA MSFK1 ADA D2 CCB REMOVE SFK CODE ADB TEQ9,I FROM THE USER BUFFER STB TEQ9,I DECREMENT BYTE POINTER CCB ADB TEQ10,I STB TEQ10,I DECREMENT BYTE COUNTER SPC 1 C.RDL IOR TEQ5,I MERGE EOR INDICATOR IN STATUS WORD STA TEQ5,I AND STORE IT BACK. C.RDS LDB TEQ9,I GET BUFFER POINTER CLE,ERB COMPUTE WORD ADDRESS LDA B,I GET LAST CHARACTER * *-----PROCESS END OF READING OPERATION * AND LHALF KEEP UPPER HALF ONLY IOR B40 COMPLETE WITH SPACE IN LOWER SEZ IF NEEDED ? STA B,I YES JSB T.LOG COMPUTES THE T.LOG JMP NEWST SET TERMINAL IN NEXT STATE. SPC 1 C.RD9 JSB BFSET PROCESS CANCEL LINE NOP RESET POINTER & BYTE COUNT JMP SAMST LEAVE TERMINAL IN THE SAME STATE SPC 1 C.TES LDA TEQ6,I MODE OF READING AND BIT7 MASK OUT BIT 7 LDB TEQ17,I GET OP-CODE/STEP NUMBER SZA --- GET --- ? JMP C.TE1 YES: IS IT A 3070B ? C.TE0 ADB BIT10 NO: SKIP GET COMMAND STB TEQ17,I PREPARE THE FOLLOWING STEP JMP GETN1 GO TO NEXT STEP * C.TE1 JSB AORB? IS IT A 3070B ? JM?P C.TE0 CONTINUE JMP NEWST PROCESS NEXT STEP SPC 2 #SFK EQU 10 10 SPECIAL FUNCTION KEYS SFK1 EQU 20B M#SFK ABS -#SFK MSFK1 ABS -SFK1 * SFKM OCT 77740 MSLF OCT 10012 INT,LF ARROW OCT 10137 INT,'_' LINF OCT 12 LHALF OCT 177400 RHALF OCT 000377 SPC 2 ******************************************************************** * CONTINUATION OF A WRITE/READ REQUEST * ******************************************************************** SPC 1 C.HB0 LDB TEQ7,I GET USER BUFFER ADDRESS INB COMPUTE INPUT BUFFER LENGTH ADDRESS LDA B,I GET INPUT BUFFER LENGTH STA TEQ8,I UPDATE SYSTEM BUFFER LENGTH EQT JSB NGTIF COMPUTE BYTE LENGTH SZA IS IT ZERO ? JMP C.HB1 NO: CONTINUE PROCESSING LDA TEQ16,I YES: GET TERMINAL MODE OF OPERATION SSA NORMAL OR TRANSPARENT MODE ? JMP ENDST TRANSPARENT: COMPLETE JMP C.SP5 NORMAL: COMPLETE AFTER GETTING SRQ STATE. * C.HB1 STA TEQ10,I RESTORE BYTE COUNTER LDA TEQ9,I GET INPUT BYTE POINTER SLA POINTS AT UPPER BYTE ? ISZ TEQ9,I NO: INCREMENT IT LDA TEQ9,I GET INPUT BYTE POINTER RAR COMPUTE INPUT BUFFER ADDRESS STA TEQ7,I UPDATE SYSTEM BUFFER ADDRESS EQT LDA TEQ16,I YES: GET MODE OF OPERATION OF TERMINAL LDB OPRDX GET TRANSPARENT OP-CODE/STEP NUMBER SSA NORMAL OR TRANSPARENT ? JMP C.HB2 TRANSPARENT: PREPARE TRANSPARENT OP-CODE LDB OPRD NORMAL: GET NORMAL MODE READ OP-CODE JSB BADG? BADGE CARD READER OPERATION ? JMP C.HB2 NO: PREPARE NORMAL READ ON KEYBOARD LDB OPCAR YES: GET CARD READER OP-CODE * C.HB2 LDA TEQ17,I GET OP-CODE STEP NUMBER EQT17 AND RHALF CLEAR OP-CODE/STEP NUMBER IOR B MERGE WITH NEW OP-CODE/STEP NUMBER AND NBT6 CLEAR COMMING FROM INITIATOR BIT STA TEQ17,I START THE READ OPERATION ITSELF JMP 6GETN2 CONTINUE WRITE/READ PROCESSING SKP ******************************************************************** * CONTINUATION OF A WRITE REQUEST * ******************************************************************** SPC 1 C.WR4 LDA TEQ17,I INCREMENT STEP NUMBER ADA B400 STA TEQ17,I JSB BFSET SET BUFFER POINTER JMP C.W55 ISSUE LF ONLY (LENGTH = 0) SPC 1 * C.WR5 CLA IS BYTE COUNT CPA TEQ10,I EXHAUSTED ? JMP C.W55 YES, NO MORE CHAR. TO OUTPUT IFN LDB TEQ9,I GET BYTE ADDRESS ISZ TEQ9,I BUMP BYTE ADDRESS CLE,ERB CONVERT TO WORD (E=L/U POSITION) LDA B,I EXTRACT WORD SEZ,RSS LOWER OR UPPER POSITION ? ALF,ALF SHIFT TO LOWER HALF, IF UPPER AND RHALF ISOLATE THE CHAR. XIF IFZ LDB TEQ9,I GET CHARACTER FROM USER BUFFER LBT USE 21MX INSTRUCTION STB TEQ9,I UPDATE BYTE POINTER XIF IOR INT MERGE INT BIT TO OUTPUT ON LINK * *-----PROCESS A WRITE COMMAND/READ * STA TEMP1 SAVE A REGISTER TEMPORARILY LDA TEQ17,I GET OP-CODE/STEP NUMBER AND B170K MASK OUT OP-CODE FIELD STA B A REGISTER ---> B REGISTER LDA TEMP1 RESTORE A REGISTER CPB OWRAK IS IT A WRITE/READ PROCESS ? RSS YES: PROCESS IT JMP C.W51 NO: CONTINUE AS FOR STANDARD WRITE * LDB TEQ16,I GET MODE OPERATION OF TERMINAL SSB,RSS NORMAL OR TRANSPARENT ? AND NBT7 NORMAL MODE, OUTPUT IS A DATA * STA B SAVE CHARACTER TO OUTPUT AND BIT7 GET BIT 7 STATUS SZA IS IT SET ? JMP C.W50 OUTPUT IS A COMMAND LDA B RESTORE CHARACTER TO OUTPUT LDB TEQ6,I GET REQUEST CODE BLF,RBL ELB,BLF JMP C.W52 OUTPUT IT AS A DATA C.W50 LDA B RESTORE COMMAND TO OUTPUT AND NBT7 CLEAR BIT 7 JMP C.W6W0 MERGE WITH ATN HP-IB LINE * *-----CONTINUE STANDARD PROCESS * C.W51 LDB TEQ6,I CHECK BIT:X & BIT:M BLF,RBL ELB,BLF SEZ,RSS CHECK BIT:X ? JMP C.W52 BIT:X=0, NORMAL WRITE C.W60 IOR ATN BIT:X=1, COMMAND MODE, MERGE ATN ISZ TEQ10,I BUMP BYTE COUNTER JMP HOLST NOT THE LAST CHAR. JMP INCST LAST CHAR., EXIT NEXT TIME * * C.W52 ISZ TEQ10,I BUMP BYTE COUNT JMP HOLST NOT THE LAST CHAR. OUTPUT IT SLB LAST CHAR., CHECK ASCII/BINARY MODE JMP C.W53 BINARY RECORD CPA ARROW ASCII RECORD, TEST THE LAST CHAR. JMP NEWST EXIT NOW WITHOUT SENDING THIS CHAR. JMP HOLST OUTPUT THE LAST CHAR. C.W53 IOR EOI BINARY RECORD, MERGE EOI WITH JMP INCST THE LAST CHAR., AND EXIT NEXT TIME. * C.W55 LDB TEQ6,I MUST BE NORMAL ASCII MODE. BLF,RBL ELB,BLF SLB BINARY RECORD ? JMP NEWST YES: DO NOT SEND A SEZ COMMAND MODE OR WRITE/READ ? JMP C.W57 YES: CHECK FOR WRITE/READ C.W56 LDA MSLF NO: ASCII WRITE JMP INCST OUTPUT LINE-FEED * C.W57 LDA TEQ17,I GET OP-CODE/STEP NUMBER AND B170K MASK OUT OP-CODE CPA OWRAK IS IT A WRITE/READ ? JMP C.W56 YES: ASCII, SEND A LINE-FEED JMP NEWST NO: COMMAND MODE. * * OWRAK OCT 160000 IDENTIFIER FOR WRITE/READ OP-CODE SPC 3 ******************************************************************** * CONTINUATION OF A CLEAR REQUEST * ******************************************************************** SPC 1 C.CL0 NOP ISZ STCFL SET TO INTERRUPT NEXT POLLING CYCLE LDB TEQ17,I CHECK IF COMMING FROM INITIATOR BLF,BLF ROTATE TO TEST RBL BIT 6 SSB COME FROM INITIATOR ? JMP C.CL0,I YES, RETURN LDA DXTWD NO, RECALL DXT WORD AND BIT14 MASK OUT TERMINAL ACKNOWLEDGMENT SZA GOOD ANSWER ? CLA,RSS YES, EXIT WITH A=0 RSS BAD ANSWER, RETRY JMP C.CL0,I ISZ TEQ9,I MORE RETRIES ? JMP SAMST YES, RETRANSMIT SAME DATA LDA D3 NO, RETURN WITH LDB D2 A=3 AND STATUS ERR=2 SPC 1 C.ER0 STA TEQ9,I SET COMPLETION CODE LDA BIT15 SET BIT15 IN TLOG TO SIGNAL ERROR STA TEQ10,I C.ER1 LDA TEQ5,I MERGE IN STATUS THE STATUS ERR. CODE AND LHALF IOR B STA TEQ5,I LDB TEQ16,I GET THE TRANSPARENT MODE FLAG SSB IS TRANSPARENT MODE ENABLED ? JMP ENDST YES, DON'T SET THE SYSTEM ERROR JMP ENDSA NO, LET SYSTEM HANDLE THE ERROR. SKP ********************************************************************** * CONTINUATION OF SERIAL POLL. * ********************************************************************** SPC 1 C.SP LDA DXTWD RECALL DXT WORD ALF,RAL CHECK IF IT IS DATA SSA,RSS IS VALDA BIT SET ? JMP SAMST NO, IGNORE THIS WORD ALF ROTATE AGAIN TO POSITION BIT 6 SSA IS BIT 6 (DIO-7) SET ? JMP C.SP6 YES, THIS TERMINAL HAD AN SRQ PENDING * ISZ TEQ10,I END OF ADDR. TABLE ? JMP C.SP4 NO, CONTINUE. LDA B37 YES, GET ADDR=37B (MEANS NO ANSWER JMP C.SP7 TO THIS SERIAL POLL) AND COMPLETE. * C.SP4 ISZ TEQ9,I BUMP WORD POINTER LDA TEQ17,I CONTINUE ADA MST3 DECREMENT THE STEP-NUM. STA TEQ17,I TO LOOP ON LAST 2 STEPS JMP NEWST AND GO TO OUTPUT THE NEXT WORD. * C.SP6 LDA TEQ9,I THIS IS THE ADDR. OF THE STATION LDA A,I AND B37 C.SP7 IOR TEQ5,I MERGE IN STATUS STA TEQ5,I CLA CLEAR TLOG WORD STA TEQ10,I JMP NEWST COMPLETE AFTER SENDING SPD SPC 1 C.SP5 LDB Y.SP# GET SPECIAL OP-COD & STEP-NUM C.SP8 ISZ STCFL SET TO INTERRUPT NEXT POLLING CYCLE LDA TEQ17,I SET SPECIAL OP-COD & STEP-NUM TO q AND RHALF BYPASS CHECKING OF THE BOOLEAN IOR B EXPRESSION AND DO ONE MORE STA TEQ17,I POLLING CYCLE TO CHECK THE JMP INPST SRQ LINE. * C.SP9 LDA DXTWD SINCE THE INTERRUPT HAS BEEN FORCED AND BIT14 CHECK THE TERMINAL ACKNOWLEDGEMENT SZA,RSS IS IT ALL RIGHT JMP NOCST NO, DON'T CHANGE DXT WORD, RETRANSMIT JSB SRQ? YES, CHECK SRQ, UPDATE STATUS BIT 7 JMP NEWST AND COMPLETE. * MST3 DEC -768 MINUS 3 STEP (3 * 256) STCFL NOP TEMP1 NOP SKP ******************************************************************** * CONTINUATION OF GET STATUS BYTE * ******************************************************************** SPC 1 C.GSB LDA DXTWD RECALL DXT WORD ALF,RAL IS IT DATA SSA,RSS BIT VALDA SET ? JMP SAMST NO, IGNORE THIS WORD LDA DXTWD RECALL DXT WORD AND RHALF ISOLATE STATUS BYTE IOR TEQ5,I AND PUT IT INTO THE SATUS STA TEQ5,I LDA TEQ9,I GET HP-IB STATION ADDRESS OF ADDRESS LDA A,I GET HP-IB STATION ADDRESS CPA DTLKA IS IT THE TERMINAL 3070 ? JSB HARDW YES: UPDATE HARDWARE TERMINAL STATUS EQT18 JMP NEWST AND COMPLETE. SPC 2 ******************************************************************** * CONTINUATION OF CHECK SRQ * ******************************************************************** SPC 1 C.CSR LDB Y.CS# GET SPECIAL OP-COD & STEP-NUM JMP C.SP8 AND SET IT INTO EQT17 SPC 1 C.CSS JSB SRQ? UPDATE STATUS WORD AND JMP NEWST EXIT. SPC 2 ******************************************************************** * CONTINUATION OF CHECK SRQ PERIODICALLY * ******************************************************************** SPC 1 C.WSQ LDB Y.WS# INTERRUPT AFTER NEXT POLLING CYCLE JMP C.SP8 IN ORDER TO GET THE TERMINAL STATUS SPC] 1 C.WS0 JSB SRQ? CHECK SRQ LINE & UPDATE STATUS BIT 7 CPB BIT7 SRQ PRESENT ? RSS YES: GET STATUS BYTE JMP C.WS4 NO: PUT TERMINAL IN WAITING QUEUE LDA TEQ17,I GET OP-CODE/STEP NUMBER WORD AND B277 MASK OUT TERMINAL NUMBER AND REN BIT IOR OPGSB MERGE WITH GET STATUS BYTE OP-CODE AND NBT6 CLEAR COMMING FROM INITIATOR BIT STA TEQ17,I RESET OP-CODE/STEP NUMBER WORD LDA D.LKA GET DEFAULT TALKER ADDRESS STA TEQ9,I SET UP STATION TO BE POLLED JMP NEWST PROCESS THE GET STATUS BYTE * C.WS4 JSB LOEQT B = ADDRESS OF DUMMY EQT7 CLA A = 0 ADB D7 COMPUTE DUMMY EQT14 ADDRESS STA B,I CLEAR THIS TIME OUT !!!!!!! ADB DM7 COMPUTE ADDRESS OF DUMMY EQT7 LDA B,I GET TIME OUT VALUE ADB D8 COMPUTE EQT15 ADDRESS OF DUMMY EQT STA B,I RESTART THE DUMMY EQT TIME CLOCK * LDA TEQ17,I GET OP-CODE/STEP NUMBER WORD AND B277 MASK OUT TERMINAL NUMBER AND IOR OPWTQ MERGE OP-CODE WITH "COMMING FROM INIT." BIT STA TEQ17,I TO START AT THE BEGENNING LDA .WSRQ GET WAITING QUEUE HEAD ADDRESS JMP ENDSB RE-INSERT TERMINAL IN WAITING QUEUE SPC 2 ******************************************************************** * CONTINUATION OF WAIT UNTIL SRQ * ******************************************************************** SPC 1 C.WSR JSB SRQ? CHECK SRQ LINE & UPDATE STATUS BIT 7 CPB BIT7 SRQ PRESENT ? JMP NEWST YES, COMPLETE JMP SAMST NO, CONTINUE LOOPING. SPC 2 SRQ? NOP LDA DXTWD RECALL DXT WORD AND B13K ISOLATE CONTROL BIT CLB B WILL HOLD SRQ STATE CPA SRQ IS SRQ SET (VALDA=0 IF SRQ) ? LDB BIT7 YES, SET B REG. BIT 7 = 1 CPA B3000 IS EOI SET ? LDB BIT4 YES, SET B REG. BIT 4 = 1 LDA TEQ5,I SET BIT 7 OF STATUS IOR B IFB@< SRQ LINE WAS SET. STA TEQ5,I JMP SRQ?,I * B3000 OCT 3000 BIT4 OCT 20 SKP ******************************************************************** * TIME OUT PROCESSING (DEVICE HAS TIMED OUT) * ******************************************************************** SPC 1 TO LDA EQT4,I CLEAR THE BIT T AND NBT11 (DEVICE TIMED OUT) IN THE mB STA EQT4,I EQT CLB CLEAR DEVICE CLOCK STB EQT15,I * *-----IS IT A TIME OUT FOR AN SRQ CHECK ? * LDA EQT6,I GET EQT6 ADDRESS CPA M1 IS IT THE DUMMY EQT ? RSS YES: THIS IS A WAIT FOR SRQ JMP TO40 NO: THIS IS A TRUE TIME OUT * *-----PROCESS WAIT SRQ PERIODICALLY * LDB EQT13 GET DUMMY EQT13 ADDRESS JSB SETP. SET UP LOCAL POINTERS LDA .WSRQ,I GET WAITING QUEUE HEAD SZA,RSS IS IT EMPTY ? JMP CY47 YES: IGNORE THIS INTERRUPT LDA .ACTQ SEARCH END OF ACTIVE QUEUE LDB A,I SAVE ACTIVE QUEUE STB TEMP1 HEAD TEMPORARILY TO10 LDB A,I SZB,RSS END OF ACTIVE QUEUE JMP TO20 YES LDA B NO JMP TO10 CONTINUE SCANNING TO20 LDB .WSRQ,I GET WAITING QUEUE HEAD STB A,I APPEND ACTIVE QUEUE WITH WAITING QUEUE CLA STA .WSRQ,I CLEAR TEMPORARILY WAITING QUEUE * LDA TEMP1 GET PREVIOUS ACTIVE QUEUE HEAD ADA .COMQ,I GET COMPLETION QUEUE STATUS SZA WERE BOTH ACTIVE & COMPLETION EMPTY ? JMP STCH3 NO: CONTINUE AT NEXT POLLING CYCLE LDB DXTAD YES: SET UP FOR A DUMMY STB CULAT POLLING CYCLE I.E. : LDA IDLCD ONLY ONE TERMINAL (ADDR.=1) AND STA B,I THIS TERMINAL IN IDLE STATE JMP TRD07 GO TO OUTPUT DXT TABLE * *-----THIS IS A TRUE TIME OUT * TO40 LDB EQT12,I GET DUMMY EQT13 ADDRESS JSB SETP. SET UP LOCAL POINTERS LDB EQT13,I GET EQT16 ADDRESS INB COMPUTE EQT17 ADDRESS LDA B,I SET THE OP-CODE/ STEP-NUM AND B277 TO PROCESS THE TIME OUT IOR B601I WITH NEXT INTERRUPT STA B,I OF THE CONTROLLER * *-----IF TERMINAL IN WAITING QUEUE: DEQUEUE IT * LDA .WSRQ GET WAITING QUEUE HEAD ADDRESS TO70 LDB A,I GET WAITING QUEUE HEAD SZB,RSS END OF QUEUE ? JMP STCH3 YES: NOTHING TO DO CPB EQT11 IS IQT THIS TERMINAL ? JMP TO80 YES: PROCESS IT LDA B A = ADDRESS OF NEXT TERMINAL QUEUED JMP TO70 CONTINUE LOOKING FOR TERMINAL * TO80 LDB B,I GET NEXT LINK IN THE LIST STB A,I PUT IT IN PREVIOUS ONE TO CLA DEQUEUE THIS TERMINAL AND STA EQT11,I CLEAR THIS LINK WORD LDA EQT11 GET ADDRESS OF TERMINAL EQT11 JSB SETTQ SET UP TEQXX LOCAL TABLE LDA TEQ5,I GET EQT5 WORD AND LHALF CLEAR STATUS PART IOR D1 MERGE ERROR CODE STA TEQ5,I UPDATE STATUS EQT5 LDA D4 GET SYSTEM ERROR CODE: 4 LDB TEQ16,I GET EQT16 WORD SSB NORMAL OR TRANSPARENT ? CLA TRANSPARENT: DO NOT RETURN SYSTEM ERROR LDB BIT15 SIGNAL ERROR IN T.LOG WORD JMP CA47,I EXIT * STCH3 STC 0 FORCE AN INTERRUPT AT THE END OF NEXT JMP CY47 POLLING CYCLE AND EXIT (CONTINUATION) SPC 2 TO50 LDA D4 SYSTEM ERR.=4 (TO ERROR.) STA TEQ9,I SET THE COMPLETION CODE T.O. JSB T.LOG COMPUTES THE NEW T.LOG LDB D1 SET THE STATUS ERROR CODE JMP C.ER1 COMPLETE IN ERROR * B277 OCT 277 M3 DEC -3 B601I OCT 060100 TIME OUT OP-CODE/COMMING INITIATOR SKP HED UTILITY SUBROUTINES. ******************************************************************** * MISCELLANEOUS SUB-ROUTINES * ******************************************************************** SPC 1 SEND NOP END PREVIOUS CYCLE & START NEW ONE LDA CULAT,I MODIFY BIT15 FOR THE LAST TERMINAL AND NBT15 STA CULAT,I * LDA M3 3 RETRIES ALLOWED FOR DXT-TABLE STA TEMP1 USE COUNTER SPC 1 CLC.1 CLC 0 END PREVIOUS CYCLE STC.1 STC 0,C START NEXT ONE LDB DXTAD B=POINTER IN DXT * SEND0 LDA B,I A=DATA SFS.2 SFS 0 READY TO ACCEPT DATA ? JMP SENDE NO INB BUMP POINTER OTA.1 OTA 0,C YES G- SEND DATA WORD SSA IS IT LAST DATA ? JMP SEND0 NO, LOOP UNTIL END OF DXT SPC 1 LDA STCFL NEED AN INTERRUPT NEXT SZA POLLING CYCLE ? STCH2 STC 0 YES ISZ SEND SET NORMAL RETURN (P+2) JMP SEND,I RETURN. SPC 1 SENDE ISZ TEMP1 INCREMENT RETRIES COUNTER JMP CLC.1 NOT 0 YET JMP SEND,I RETURN (P+1). CONTROLLER PROBLEMS !!! SPC 2 BFSET NOP SET INITIAL CONDITIONS FOR BUFFER LDA TEQ7,I USE TEQXX LOCAL POINTER CLE,ELA GET BUFFER ADDRESS AND STA TEQ9,I USE EQT9 AS BUFFER BYTE POINTER LDA TEQ8,I GET BUFFER LENGTH JSB NGTIF CONVERT TO NEGATIVE FORM STA TEQ10,I USE EQT10 AS BYTE COUNT. SZA IS BUFFER LENGTH 0 ? ISZ BFSET NO - RETURN ADDRESS IS (P+2) JMP BFSET,I IF BUF. LENGTH = 0 RETURN AT (P+1) SKP SETIO NOP CONFIGURE I/O INSTRUCTION. IOR STF.0 ADA B200 STA SFS.1 1023XX STA SFS.2 ADA B400 STA STCH1 1027XX STA STCH2 STA STCH3 IOR B1000 STA STC.1 1037XX XOR B200 STA LIAC1 1035XX ADA B100 STA OTA.1 1036XX XOR B5100 STA CLC.1 1067XX STA CLC.2 STA CLC.3 STA CLC.4 STA CLC.5 STA CLC.6 STOP THE CONTROLLER FOR WAITING QUEUE JMP SETIO,I * STF.0 STF 0 B5100 OCT 5100 SPC 2 SETTQ NOP SET TEMPORARY EQT TEQXX CPA TEQ11 IF ALREADY SET JMP SETTQ,I DON'T SET THEM AGAIN ADA =D-7 COMPUTES EQT4 ADDRESS STA TEQ4 COPY EQT4 ADDRESS INA STA TEQ5 COPY EQT5 ADDRESS INA STA TEQ6 COPY EQT6 ADDRESS INA STA TEQ7 COPY EQT7 ADDRESS INA STA TEQ8 COPY EQT8 ADDRESS INA STA TEQ9 COPY EQT9 ADDRESS INA STA TEQ10 COPY EQT10 ADDRESS  INA STA TEQ11 COPY EQT11 ADDRESS INA STA TEQ12 COPY EQT12 ADDRESS ADA D2 STA TEQ14 COPY EQT14 ADDRESS INA STA TEQ15 COPY EQT15 ADDRESS ADA M2 COMPUTE EQT13 ADDRESS LDB A,I GET EQT16 ADDRESS STB TEQ16 COPY EQT16 ADDRESS INB STB TEQ17 COPY EQT17 ADDRESS INB STB TEQ18 COPY EQT18 ADDRESS JMP SETTQ,I SPC 3 AORB? NOP SUBROUTINE TO CHECK TERMINAL REVISION LDA TEQ18,I GET EQT18 WORD AND BIT13 MASK OUT TERMINAL TYPE SZA IS IT A 3070A TERMINAL: ---> P+1 ISZ AORB? NO: RETURN IN ---> P+2 JMP AORB?,I RETURN SPC 3 HARDW NOP SUBROUTINE TO UPDATE HARDWARE TERMINAL STATUS LDA DXTWD RECALL DXT WORD ALF,RAL IS IT DATA SSA,RSS BIT VALDA SET ? JMP HARDW,I NO: IGNORE THIS WORD LDA DXTWD YES: RECALL DXT WORD AND D7 MASK OUT HARDWARE BITS RAR,RAR MOVE THESE BITS IN BITS RAR 15=PRINTER, 14=READER, 13=3070B STA B SAVE A REGISTER TEMPORARILLY LDA TEQ18,I GET EQT18 WORD AND STATU CLEAR HARDWARE STATUS BYTE IOR B MERGE WITH NEW STATUS STA TEQ18,I AND UPDATE HARDWARE STATUS WORD JMP HARDW,I RETURN * STATU OCT 17777 MASK TO CLEAR BITS 15, 14 & 13 SPC 3 NGTIF NOP SUBROUTINE TO COMPUTE BYTE LENGTH CMA,SSA,INA CONVERT TO NEGATIVE FORM ALS,SLA IF IT IS NOT CMA,INA ALREADY DONE JMP NGTIF,I RETURN SPC 1 T.LOG NOP COMPUTES THE T.LOG LDB TEQ8,I GET REQUESTED BUFFER LENGTH LDA TEQ10,I GET BYTE COUNT INA TO COMPUTE T.LOG SSB,RSS ARS CONVERT IT INTO WORD OR SSB CHARACTERS AS IT WAS REQUESTED, CMB AND SET IT POSITIVE. ADB A B=T.LOG STB TEQ10,I SAVE THIS T.LOG IN EQT10 JMP T.LOG,I RETURN SKP LOEQT NOP  GET EQT7 ADDRESS OF DUMMY EQT LDB TEQ12,I GET DUMMY EQT13 ADDRESS ADB DM6 COMPUTE DUMMY EQT7 ADDRESS JMP LOEQT,I RETURN SPC 2 SETP. NOP SET UP LOCAL POINTERS ADB M1 COMPUTE DUMMY EQT12 ADDRESS STB .ACTQ SET ADDRESS OF FIRST WORD OF ACTIVE QUEUE. INB COMPUTE DUMMY EQT13 ADDRESS LDB B,I COMPUTE DUMMY EQT16 ADDRESS STB .COMQ SET ADDRESS OF FIRST WORD OF COMPLETION QUEUE. ADB D2 COMPUTE DUMMY EQT18 ADDRESS STB .WSRQ SET ADDRESS OF FIRST WORD OF WAITING QUEUE. JMP SETP.,I RETURN SPC 1 SELEC NOP TEMPORARY BUFFER FOR SELECT CODE .ACTQ NOP .COMQ NOP .WSRQ NOP ADDRESS OF FIRST WORD OF WAITING QUEUE SKP ******************************************************************** * SPECIAL SUBROUTINE FOR BADGE CARD READER * ******************************************************************** SPC 2 BACA0 LDA TEQ18,I GET EQT18 WORD AND BIT3 MASK OUT BIT 3 SZA IMAGE MODE ? JMP BAC.0 NO: ASCII MODE LDA TEQ10,I YES: GET NUMBER OF BYTES TO READ SLA IS IT EVEN ? INA NO: DECREMENT IT !!!!!! STA TEQ10,I UPDATE BYTE COUNTER LDB TEQ8,I GET BUFFER LENGTH SSB IS IT BYTE LENGTH ? STA TEQ8,I YES: UPDATE PASSED LENGTH BAC.0 LDA TEQ18,I GET EQT18 WORD CONTENT AND B37 MASK OUT READER CONTROL WORD IOR COMD SET -/1/0/INT/ATN/SECONDARY COMMAND./ JMP INCST INCREMENT STEP-NUMBER FOR NEXT TIME. * COMD OCT 110540 1/0/INT/ATN/SECONDARY COMMAND./ SPC 1 BACA1 LDA TEQ16,I GET TRANSPARENT MODE FLAG IN BIT 15 SSA TRANSPARENT MODE ? JMP ENDST YES: COMPLETE IMMEDIATLY JMP NEWST NO: PROCESS NEXT STEP SPC 2 IMAGE NOP SUBROUTINE IMAGE/DEPACK JSB BADG? IS IT A CARD READING OPERATION ? RSS NO: RETURN IMMEDIATLY JMP IMAG1 YES: CHEiCK FOR IMAGE MODE IMAG0 LDA TEMP1 NO: RESTORE A REGISTER JMP IMAGE,I RETURN * IMAG1 LDA TEQ18,I GET IMAGE/ASCII MODE AND BIT3 OF READING SZA IMAGE MODE ? JMP IMAG0 NO: ASCII MODE * LDA TEMP1 GET THE DATA WORD ALF,ALF LOWER BYTE <---> UPPER BYTE AND B77 MASK OUT ROWS 3 ---> X R STA TEMP2 SAVE IT TEMPORARILY LDA TEMP1 GET THE DATA WORD AND B77 MASK OUT UPPER BYTE ALF,ALF LOWER BYTE <---> UPPER BYTE RAR,RAR MOVE BYTE IN RIGHT POSITION IOR TEMP2 BUILD THE IMAGE OF THE COLUMN JMP IMAGE,I RETURN SPC 2 BADG? NOP SUBROUTINE: IS IT A CARD READ ? LDA TEQ6,I GET OPERATION CODE AND BIT9 MASK OUT READER BIT 9 SZA,RSS IS IT A READ CARD OPERATION ? JMP BADG?,I NO: RETURN IN P+1 JSB CARD? YES: IS THERE A READER ? JMP BADG?,I NO: RETURN IN P+1 ISZ BADG? YES: INCREMENT RETURN ADDRESS JMP BADG?,I READER OPERATION ---> P+2 SPC 3 CARD? NOP SUBROUTINE TO CHECK READER/EQT STATUS LDA TEQ18,I GET EQT18 WORD RAL PUT READER BIT IN A REG. BIT 15 SSA READER HERE ? ISZ CARD? YES: RETURN IN P+2 JMP CARD?,I RETURN SPC 3 ******************************************************************* * SPECIAL SUBROUTINE FOR PRINTER * ******************************************************************* SPC 2 PRITR LDB TEQ17,I GET OP-CODE/STEP NUMBER ADB B400 INCREMENT STEP NUMBER LDA TEQ6,I GET REQUEST CODE AND BIT9 MASK OUT BIT 9 SZA,RSS WRITE ON PRINTER ? JMP PRIT0 NO: SKIP NEXT STEP * LDA TEQ18,I YES: GET HARDWARE STATUS SSA,RSS IS THERE A PRINTER PRIT0 ADB B400 NO: SKIP NEXT STEPS STB TEQ17,I PREPARE NEXT TASK JMP GETN1 CONTINUE HED TABLE, CONSTANTS & VARIABLE AREA. ******************************************************************** * DATA DEFINITIONS (TABLES DEFINITION) * ******************************************************************** SPC 2 A EQU 0 B EQU 1 SPC 1 EQTA EQU 1650B EQT# EQU EQTA+1 INTAB EQU 1654B SPC 2 COFAD DEF *+1,I DEF CL 0 DEF EOR 1 DEF RENB 2 DEF RDI 3 DEF TC 4 DEF WTSRQ 5 CHECK SRQ PERIODICALLY DEF CARSP 6 SET EQT 19 WITH CARD READER CTRL. WORD DEF CKSRQ 7 DEF WSRQ 10 DEF GSB 11 DEF TSFK 12 DEF TM 13 DEF NM 14 DEF IFC 15 SET IFC LINE TRUE THEN FALSE DEF ILRQ 16 DEF ILRQ 17 DEF ILRQ 20 DEF ILRQ 21 DEF STO 22 COFED DEF * SPC 1 .OPCT DEF *+1 DEF X.CL (0) CLEAR REQUEST DEF X.RD (1) READ DEF X.WR (2) WRITE DEF X.SP (3) SERIAL POLL DEF X.REN (4) REMOTE ENABLE DEF X.WSR (5) WAIT UNTIL SRQ RECEIVED DEF X.TO (6) DEVICE HAS TIMED OUT DEF X.EOR (7) ISSUE END OF RECORD DEF X.RDX (8) TRANSPARENT MODE READ DEF X.WRX (9) TRANSPARENT MODE BINARY WRITE DEF X.RDS (10) REMOTE DISABLE DEF X.GSB (11) GET STATUS BYTE DEF X.CSR (12) CHECK ON SRQ DEF X.TSK (13) SFK TERMINATOR FOR 3070B DEF X.WCR (14) WRITE COMMAND/READ BINARY DEF X.WSQ (15) CHECK SRQ PERIODICALLY SKP * BIT15 = 0 S/P ADDR. * BIT15 = 1 DATA WORD, CHECK BIT 14-13 * BIT14-13=0 DON'T MERGE. * BIT14-13=1 MERGE TALK ADDR. (TEQ12[4:0]) * BIT14-13=2 MERGE WITH CONTENT OF TEQ9,I SPC 1 X.CL DEF *+1 CLEAR REQUEST CONTROL TABLE OCT 114000 0 -/1/0/INT/IFC/ OCT 110000 1 -/1/0/INT/ OCT 110424 2 -/0/0/INT/ATN/DCL/ DEF ENDST 3 -/0/END...  OCT 114000 4 -/1/0/INT/IFC/ OCT 110000 5 -/1/0/INT/ DEF ENDST 6 -/0/END... * X.RD DEF *+1 OCT 110475 0 -/1/0/INT/ATN/CONF-LST.DISPLAY./ OCT 110476 1 -/1/0/INT/ATN/CONF-LST.MOD-COM./ OCT 130500 2 -/1/1/INT/ATN/CONF-TAK./ DEF PUIST 3 -/0/PUT TERMINAL IN INPUT STATE./ DEF C.RD0 4 -/0/READ PROCESS./ OCT 110537 5 - /1/0/INT/ATN/UNCONF-TALK./ DEF C.TES 6 - /0/GET COMMAND ?./ OCT 110475 7 - /1/0/INT/ATN/CONF-LST.DISPLAY./ OCT 110576 8 - /1/0/INT/ATN/SECONDARY COMMAND GET./ OCT 110477 9 - /1/0/INT/ATN/UNLISTEN./ DEF C.SP5 10 -/0/GO TO CHECK SRQ ... * X.RDX DEF *+1 TRANSPARENT MODE READ OCT 110537 0 -/1/0/INT/ATN/UNTALK./ OCT 110474 1 -/0/1/INT/ATN/CONF-LST.READER./ DEF BACA0 2 -/0/CONFIGURE BADGE CARD READER./ OCT 110476 3 -/1/0/INT/CONF-LST.MOD-COM./ OCT 110534 4 -/1/0/INT/CONF-TLK.READER./ DEF PUIST 5 -/0/PUT TERMINAL IN INPUT STATE./ DEF C.RD0 6 -/0/READ PROCESS./ DEF BACA1 7 -/0/END... OR COMPLETE CARD READING. OCT 110537 8 -/1/0/INT/ATN/UNCONF-TALK./ DEF C.SP5 9 -/0/GO TO CHECK SRQ .../ * X.WR DEF *+1 WRITE CONTROL TABLE OCT 110475 0 -/1/0/INT/ATN/CONF-DISPLAY-LST./ OCT 110537 1 -/1/0/INT/ATN/UNCONF-TAK./ DEF PRITR 2 -/0/WRITE ON PRINTER OR DISPLAY ?./ OCT 110473 3 -/1/0/INT/ATN/LST-PRINTER./ DEF C.WR4 4 -/0/WRITE INITIALIZE/ DEF C.WR5 5 -/0/WRITE PROCESS./ DEF C.TES 6 -/0/GET COMMAND ?./ OCT 110475 7 -/1/0/INT/ATN/LST-DISPLAY./ OCT 110576 8 -/1/0/INT/ATN/SECONDARY COMMAND GET./ OCT 110477 9 -/1/0/INT/ATN/UNLISTEN./ DEF C.SP5 10 -/0/GO TO CHECK SRQ ... * X.WRX DEF *+1 TRANSPARENT/COMMAND MODE WRITE DEF C.WR4 0 -/0/WRITE INITIALIZE/ DEF C.WR5 1 -/0/WRITE PROCESS./ DEF ENDST 2 - 0/END .../ * X.SP DEF *+1 SERIAL POLL CONTROL TABLE OCT 1104U77 0 -/1/0/INT/ATN/UNLISTEN/ OCT 110537 1 -/1/0/INT/ATN/UNCONF-TAK./ OCT 110476 2 -/1/0/INT/ATN/CONF-LST.MOD-COM./ OCT 110430 3 -/1/0/INT/ATN/SPE/ OCT 150500 4 -/1/2/INT/ATN/CONF.TALK/ DEF PUIST 5 -/0/PUT TERMINAL IN INPUT/ DEF C.SP 6 -/0/SERIAL POLL LOOP PROCESS./ OCT 110537 7 -/1/0/INT/ATN/UNCONF-TAK./ OCT 110431 10-/1/0/INT/ATN/SPD/ DEF C.SP5 11-/0/PUT IN INPUT STATE, INTR NEXT TIME./ DEF C.SP9 12-/0/CHECK IF SRQ STILL THERE/ DEF ENDST 13-/0/END... * X.REN DEF *+1 ENABLE REMOTE CONTROL TABLE. OCT 112400 0 -/1/0/INT/REN/ATN/ DEF ENDST 1 -/0/END... * X.CSR DEF *+1 CHECK FOR SRQ OCT 110537 0 -/1/0/INT/ATN/UNCONF-TAK./ DEF C.CSR 1 -/0/PUT IN INPUT STATE, INTR. NEXT TIME./ DEF C.CSS 2 -/0/CHECK ON SRQ PROCESS./ DEF ENDST 3 -/0/END... * X.WSR DEF *+1 WAIT UNTIL SRQ CONTROL TABLE OCT 110537 0 -/1/0/INT/ATN/UNCONF-TAK./ DEF PUIST 1 -/0/PUT TERMINAL IN INPUT STATE./ DEF C.WSR 2 -/0/WAIT UNTIL SRQ PROCESS./ DEF ENDST 3 -/0/END... * X.EOR DEF *+1 ISSUE END OF RECORD OCT 111000 0 -/1/0/INT/EOI/ OCT 110000 1 -/1/0/INT/ DEF ENDST 2 -/0/END... * X.RDS DEF *+1 DISABLE REMOTE CONTROL TABLE OCT 110400 0 -/1/0/INT/ATN/ DEF ENDST 1 -/0/END... * X.TO DEF *+1 DEVICE HAS TIMED OUT DEF TO50 0 -/0/TIME OUT PROCESS./ DEF ENDST 1 -/0/END... * X.GSB DEF *+1 GET STATUS BYTE OCT 110477 0 -/1/0/INT/ATN/UNLISTEN/ OCT 110537 1 -/1/0/INT/ATN/UNCONF-TALK./ OCT 110476 2 -/1/0/INT/ATN/CONF-LST.MOD-COM./ OCT 110430 3 -/1/0/INT/ATN/SPE/ OCT 150500 4 -/1/2/INT/ATN/CONF.TALK/ DEF PUIST 5 -/0/PUT TERMINAL IN INPUT/ DEF C.GSB 6 -/0/GET STATUS BYTE PROCESS./ OCT 110537 7 -/1/0/INT/ATN/UNCONF-TAK./ OCT 110431 10-/1/0/INT/ATN/SPD/ DEF ENDST 13-/0/END... * X.TSK DEF *+t1 SET OR CLEAR SFK AS TERMINATOR (3070B) OCT 110475 0 -/1/0/INT/ATN/CONF-LST.DISPLAY./ OCT 150540 1 -/1/2/INT/ATN/SECONDARY COMMAND/. DEF ENDST 2 -/0/END... * X.WCR DEF *+1 WRITE/READ OCT 110537 0 -/1/0/INT/ATN/UNCONF-TALK./ OCT 110475 1 -/1/0/INT/ATN/CONF-LST.DISPLAY./ DEF C.WR5 2 - /0/WRITE PROCESS./ DEF C.HB0 3 - /0/PREPARE READ PROCESS./ DEF ENDST 4 - /0/END... * X.WSQ DEF *+1 WAIT SRQ PERIODICALLY OCT 110537 0 -/1/0/INT/ATN/UNCONF-TAK./ DEF C.WSQ 1 -/0/PROCESS THE REQUEST./ DEF C.WS0 2 -/0/CHECK TERMINAL ACK.& IDLE STATE./ DEF ENDST 3 -/0/END... * SKP DXTAD DEF *+1 DATA TRANSFERT TABLE. BSS 63 FOR 63 TERMINALS ON THE LINK DXT.D DEF * LIMIT POINTER FOR DXT TABLE SPC 1 * BIT TABLE FOR SFK TERMINATE A READ. * BIT5 OCT 40 BIT6 OCT 100 BIT7 OCT 200 BIT8 OCT 400 BIT9 OCT 1000 BIT10 OCT 2000 BIT11 OCT 4000 BIT12 OCT 10000 BIT13 OCT 20000 BIT14 OCT 40000 FOF SFK # 11 TSFKT DEF * INDEX IS NEGATIVE !!!! SPC 1 BIT15 OCT 100000 NBT7 OCT 177577 MASK TO CLEAR BIT 7 NBT9 OCT 176777 MASK TO CLEAR BIT 9 NBT11 OCT 173777 NBT15 OCT 77777 SPC 3 *---------------HP-IB CONTROL LINES SPC 1 INT EQU BIT12 ATN EQU BIT8 EOI EQU BIT9 SRQ EQU BIT9 REN EQU BIT10 SPC 3 Y.SP# OCT 035000 (OP-COD=3, STEP-NUM=12) Y.CS# OCT 141000 (OP-COD=12,STEP-NUM=2) Y.WS# OCT 171000 (OP-CODE=15,STEP-NUM=2) SPC 2 D1 DEC 1 M1 DEC -1 M2 DEC -2 B32 OCT 32 INITIALIZED CTRL. WORD FOR READER B37 EQU D31 B77 OCT 77 B100 EQU BIT6 B177 OCT 177 B377 OCT 377 MASK FOR BINARY READ OPERATIONS B200 EQU BIT7 B400 EQU BIT8 B1000 EQU BIT9 B40 EQU BIT5 SPACE CODE BIT3 EQU D8 MASK FOR BIT 3 RUBUT EQU B177 NBT0 EQU M2 MASK TO CLEAR BIT 0 SKP * SPC 2 * DEFINE EQT WORDS POINTERS * EQT1 EQU 1660B (EQT1) EQT4 EQU EQH<B@ 1 = GET BYTE * => 2 = PUT BYTE * IBUF => BUFFER START ADDRESS. * INDEX => ITEM NUMBER TO BE ACCESSED (FIRST=1) * IVAL => INTEGER VALUE (RETURNED IF GET, * SUPPLIED IF PUT) * LENGRP => BYTE LENGTH (RANGES FROM 1 TO 16) * * * * * THIS ROUTINE STORES OR GETS A 'BYTE' IN OR OUT A BUFFER. * THE BYTE-LENGTH CAN BE FIXED TO ANY LENGTH BETWEEN * 1 AND 16.(LIMITS INCLUDED) * EXECUTION TIME IS LESS THAN 260 MICRO SECS (21MX) * * * PROGRAMMED: VAN DEN BOSSCHE MARC DEC 6-1-1977 * * HP BRUSSELS * * A EQU 0 B EQU 1 ARW DEF LOCAT MASK NOP NMASK NOP LOCAT NOP * * * RW NOP ABUF NOP INDEX NOP IVAL NOP GRPL NOP BITS NOP LDB ARW LDA =D-6 STA R1 L. LDA BITS,I ISZ BITS SSA,RSS JMP *+4 ELA,CLE,ERA LDA A,I JMP *-4 STA B,I INB ISZ R1 JMP L. LDA LOCAT STA BITS LDA GRPL,I AND =B17 IOR RRL STA *+3 CLA CCB DATA NOP STA MASK CMA STA NMASK CMA AND IVAL,I STA DATA LDA INDEX,I MPY GRPL,I DIV =D16 ADA =D-1    ADA ABUF STA LOCAT RRL RRL 16 SZA IOR RRL STA R1 STA R3 SZA XOR =B1000 STA R2 LDA RW,I CPA =D2 JMP WRITE DLD LOCAT,I R3 NOP AND MASK STA IVAL,I JMP BITS,I * WRITE DLD LOCAT,I R1 NOP AND NMASK IOR DATA R2 NOP DST LOCAT,I JMP BITS,I END $   92903-18005 1805 S C0122 &BLAN              H0101 IASMB HED S/P BLAN (21MX ONLY) 24AUG77 P. SENANT NAM BLAN,7 . 92903-16001 REV.1805 770824 * * SOURCE 92903-18005 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT BLAN SUP * * THIS PROGRAM FILLS A STRING WITH BLANKS * IBUF NOP IT NOP N NOP * BLAN NOP JSB .ENTR DEF IBUF CCA ADA N,I SSA JMP BLAN,I STA N LDB IBUF CLE,ELB ADB DM1 ADB IT,I LDA BL SBT INIT. FIRST CHARACTER LDA N SZA,RSS JMP BLAN,I CCA ADA 1 MBT N JMP BLAN,I * DM1 DEC -1 BL OCT 40 END e  92903-18006 1805 S C0122 &BLANC              H0101 lASMB HED S/P BLANC (21MX ONLY) PS 24/08/77 NAM BLANC,7 . 92903-16001 REV.1805 770824 * * SOURCE 92903-18006 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT BLANC * * THIS ROUTINE BLANKS A BUFFER * BUF NOP NMOT NOP * BLANC NOP JSB .ENTR DEF BUF CCA ADA NMOT,I SSA JMP BLANC,I STA NMOT LDB BL STB BUF,I INIT. FIRST WORD SZA,RSS JMP BLANC,I LDA BUF STA 1 INB MVW NMOT JMP BLANC,I * BL OCT 20040 END O  92903-18007 1805 S C0122 &BRCKS              H0101 ~FTN4 LOGICAL FUNCTION BRCKS(IBUF .,L),. 92903-16001 REV.1805 780112 C C SOURCE 92903-18007 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ************************************************************* C * * C * THIS FUNCTION CALCULATES THE CHECKSUM C * (FORMAT IS BINARY RELOCATBLE) * C * THE CHECKSUM IS STORED IN WORD 3 OF THE BUFFER AND * C * IS THE ARITHMETIC SUM OF WORD 2,4,5,6,7 ... L * C * * C ************************************************************* C C CALLING SEQUENCE: C C IF( BRCKS(IBUF,L)) GOTO .. [CHECKSUM WAS BAD] C C IN ANY RETURN (.FALSE. OR .TRUE.) THE GOOD CHECKSUM C IS STORED IN WORD 3 C DIMENSION IBUF(1) C BRCKS=.TRUE. IF(L.LE.3) RETURN ICK=IBUF(3) IBUF(3)=IBUF(2) DO 100 I=4,L 100 IBUF(3)=IBUF(3)+IBUF(I) BRCKS = .NOT. ICK.EQ.IBUF(3) RETURN END END$ v  92903-18008 1805 S C0122 &CMPB              H0101 |YASMB HED S/P CMPB P. SENANT (21MX ONLY) 25JUN77 NAM CMPB,7 . 92903-16001 REV.1805 770625 * * SOURCE 92903-18008 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT CMPB SUP * BUF1 NOP IOF1 NOP BUF2 NOP IOF2 NOP LEN NOP * CMPB NOP JSB .ENTR DEF BUF1 LDA BUF1 CLE,ELA ADA DM1 ADA IOF1,I /FIRST STRING LDB BUF2 CLE,ELB ADB DM1 ADB IOF2,I /2ND STRING CBT LEN,I JMP *+4 CLA,RSS CLA JMP CMPB,I CCA JMP CMPB,I * DM1 DEC -1 END   92903-18009 1805 S C0122 &CMPW              H0101 YASMB HED S/P CMPW 21MX ONLY 4SEPT76 P. SENANT NAM CMPW,7 . 92903-16001 REV.1805 760904 * * SOURCE 92903-18009 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT CMPW SUP * * THIS S/P COMPARES TWO BUFFERS * * IF BUF1 = BUF2 THEN CMPW IS TRUE * IF BUF1 # BUF2 THEN CMPW IS FALSE * IB1 NOP IB2 NOP NN NOP * CMPW NOP JSB .ENTR DEF IB1 LDA IB1 LDB IB2 CMW NN,I JMP *+4 CLA,RSS CLA JMP CMPW,I CCA JMP CMPW,I END   92903-18010 1805 S C0122 &CRC16              H0101 hcASMB NAM CRC16,7 . 92903-16001 REV.1805 770718 * * SOURCE 92903-18010 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * ********************************************************************** * * * THIS SUBROUTINE IS USED TO COMPUTE THE CRC-16 * * CHECKSUM OF A BUFFER * * * * CALLING PARAMETERS : * * * * IBUF : BUFFER * * IL : BUFFER LENGTH IN BYTES * * IWD : CHECKSUM WORD * * * ********************************************************************** * * ENT CRC16 EXT .ENTR * * GET CALLING PARAMETER ADDRESS * IBUF NOP BUFFER ADDRESS IL NOP BUFER LENGTH IN BYTES IWD NOP CHECKSUM WORD CRC16 NOP ENTRY POINT JSB .ENTR DEF IBUF * LDA IL,I GET # OF BYTES CMA,INA MAKE IT NEGATIVE SSA,RSS IS POSITIVE JMP CRC16,I YES ERROR ! STA COUNT OK STORE IN COUNTER LDB IBUF GET BUFFER ADDRESS CLE,ELB MULTIPLY BY TWO TO HAVE BYTE ADDRESS * LP1 LBT GET NEXT BYTE IN BUFFER STB IBUF SAVE ADDRESS OF NEXT BYTE LDB A <'   SWAP A AND B REGISTER LDA IWD,I GET OLD CHECKSUM WORD JSB EBCLC COMPUTE NEW CHECSUM STA IWD,I STORE IT LDB IBUF RESTORE B REGISTER ISZ COUNT INCREMENT COUNTER JMP LP1 NOT FINISHED GO TO NEXT BYTE JMP CRC16,I FINISHED RETURN * * SUBROUTINE TO COMPUTE CRC-16 CHECKSUM * EBCLC NOP ENTRY POINT XOR B SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY JMP EBCLC,I RETURN * * DATA,CONSTANTS,STORAGE... * A EQU 0 B EQU 1 COUNT NOP POLY OCT 20001 * END CRC16   92903-18011 1805 S C0122 &DORMT              H0101 ASMB HED PROGRAM STATUS: DORMANT ? (RTE-III/IV) F. GAULLIER 18/JUL/77 NAM DORMT,7 . 92903-16001 REV.1805 780112 * * SOURCE 92903-18011 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * ********************************************************* * * THIS LOGICAL FUNCTION WILL BE ".TRUE." IF THE PROGRAM * * * IS ACTUALLY DORMANT [ CALL EXEC(6,0,0) ], OR UNLOADED * * * IF IT IS SCHEDULED, IN ANY WAITING LIST, OR HAS BEEN * * * COMPLETED WITH THE "SAVE SUSPENSION POINT" OPTION : * * * [ CALL EXEC(6,0,1) ], THE LOGICAL FUNCTION WILL BE : * * * ".FALSE". * * ********************************************************* SPC 2 * * CALLING SEQUENCE: * * IF ( DORMT(PNAME) ) GOTO .. [PROG. IS DORMANT] * * (.TRUE. = 100000B AND .FALSE. = 0) * SPC 2 ENT DORMT EXT .ENTR,IDGET * A EQU 0 B EQU 1 * *-----ENTRY POINT * ANAME BSS 1 DORMT NOP JSB .ENTR DEF ANAME ADDRESS OF BUFFER CONTAINING PRG. NAME * *-----GET I.D. SEGMENT ADDRESS * JSB IDGET DEF *+2 DEF ANAME,I PROGRAM NAME SZA,RSS IS PROGRAM LOADED ? JMP .TRUE NO * *-----VERIFY THAT PROGRAM IS FULLY DORMANT * LDB A GET PROGRAM I.D. SEGMEMT ADDRESS ADB P12 COMPUTE PROGRAM NAME ADDRESS IN I.D. STB IDBDR SAVE IT ADB P2 (B)=NAM5 ADDR OF MATCHED I.D. XLA B,I GET NAM5 AND AND P7 MASK IN PROGRAM TYPE. CPA P5 IS THIS A SEGMENT ? JMP .TRUE YE  S IT IS : EQUIVALENT TO DORMANT ADB N6 (B)=ADDR OF SUSPEND WORD XLA B,I POINT OF SUSPENSION ? SZA ZERO-CONTINUE JMP .FALS PROGRAM HAS A SUSPENSION POINT ADB P7 COMPUTE STATUS WORD ADDRESS XLA B,I GET STATUS WORD SZA DORMANT ? JMP .FALS PROGRAM IS NOT DORMANT ADB P2 COMPUTE TIME LIST WORD ADDRESS XLA B,I GET TIME LIST WORD AND BIT12 GET BIT 12 OF (TIME LIST ENTRY BIT) SZA PROGRAM IS IN THE TIME LIST ? JMP .FALS YES * *-----PROGRAM IS FULLY DORMANT * .TRUE CCA LOGICAL FUNCTION ".TRUE." JMP DORMT,I RETURN * *-----PROGRAM IS NOT FULLY DORMANT * .FALS CLA LOGICAL FUNCTION ".FALSE." JMP DORMT,I RETURN * *-----CONSTANTS * IDBDR BSS 1 NAM5 ADDRESS P2 DEC 2 P5 DEC 5 P7 DEC 7 P12 DEC 12 N6 DEC -6 BIT12 OCT 010000 * * * END `   92903-18012 1805 S C0122 &EBCD              H0101 mOASMB HED S/P EBCAS,ASEBC (15/10/75) P. SENANT NAM EBCD,7 . 92903-16001 REV.1805 751015 * * SOURCE 92903-18012 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT EBCAS,ASEBC EXT .ENTR * * * CALL EBCAS (IA,LEN) * * WILL CONVERT BUFFER IA FROM IBM 8-LEVEL CODE TO ASCII, WHERE * LEN IS THE NUMBER OF WORDS TO BE CONVERTED. * * * CALL ASEBC (IA,LEN) * * WILL CONVERT BUFFER IA FROM ASCII TO IBM 8-LEVEL, WHERE * LEN IS THE NUMBER OF WORDS TO BE CONVERTED * * HED ASCII TO IBM 8-LEVEL CONVERSION IA NOP LEN NOP ASTOI NOP JSB .ENTR DEF IA * LDA BASE1 ADDRESS OF CONVERSION TABLE STA BASE WORKING POINTER DLD IA PARAMETER PICK-UP FOR GOGO * GOGO STA PTR WORKING BUFFER ADDRESS LDB 1,I ACTUAL PARAMETER CMB,INB NEGATIVE WORD COUNT STB CTR WORKING COUNTER * CLOOP LDA PTR,I PICK UP WORD JSB CCHAR CONVERT UPPER CHARACTER JSB CCHAR CONVERT LOWER CHARACTER STA PTR,I RETURN WORD TO BUFFER ISZ PTR NEXT WORD ISZ CTR DONE? JMP CLOOP NO, CONTINUE CONVERSION JMP ASTOI,I YES, RETURN * * CHARACTER CONVERSION * CCHAR NOP ALF,ALF POSITION NEXT CHARACTER STA TEMP SAVE OTHER HALF AND M77 LOOK AT SIX BITS ONLY ADA BASE BASE ADDRESS OF CONVERSION TABLE LDB 0,I CONVERTED CHARACTER LDA MLEFT MASK FOR OTHER CHARACTER AND TEMP SALVAGE OTHER CHARACTER INTACT IOR 1 INSERT NEW CHARAC[  TER JMP CCHAR,I RETURN * MLEFT OCT 177400 M77 OCT 77 TEMP BSS 1 * BASE DEF TAB1 BASE1 DEF TAB1 BASE2 DEF TAB2 CTR BSS 1 PTR BSS 1 HED IBM 8-LEVEL TO ASCII CONVERSION .IA NOP .LEN NOP ITOAS NOP JSB .ENTR DEF .IA * LDA BASE2 POINTER TO WORKING TABLE STA BASE WORKING POINTER LDA ITOAS RETURN ADDRESS STA ASTOI EXIT POINT * DLD .IA PARAMETER TRANSFER JMP GOGO SPC 3 SUP TAB1 OCT 174,301,302,303,304,305,306,307 OCT 310,311,321,322,323,324,325,326 OCT 327,330,331,342,343,344,345,346 OCT 347,350,351,132,101,112,156,114 OCT 100,117,177,173,133,154,320,175 OCT 115,135,134,116,153,140,113,141 OCT 360,361,362,363,364,365,366,367 OCT 370,371,172,136,114,176,156,157 SPC 2 TAB2 OCT 040,101,102,103,104,105,106,107 OCT 110,111,135,056,074,050,053,041 OCT 046,112,113,114,115,116,117,120 OCT 121,122,133,044,052,051,073,101 OCT 055,057,123,124,125,126,127,130 OCT 131,132,101,054,045,101,076,077 OCT 060,061,062,063,064,065,066,067 OCT 070,071,072,043,100,047,075,042 EBCAS EQU ITOAS ASEBC EQU ASTOI END BK   92903-18013 1805 S C0122 &IALF2              H0101 onASMB HED S/P IALF2 (15/10/75) F. GAULLIER NAM IALF2,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18013 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT IALF2 EXT .ENTR IADR NOP SWAP NOP JSB .ENTR DEF IADR LDA IADR,I ALF,ALF JMP SWAP,I IALF2 EQU SWAP END u  92903-18014 1805 S C0122 &IASC              H0101 mcASMB HED S/P IASC . 15/10/75 P. SENANT NAM IASC,7 . 92903-16001 REV.1805 751015 * * SOURCE 92903-18014 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IASC * * INTEGER --> ASCII CONVERSION (2 DIGITS) * D10 DEC 10 O60 OCT 60 .N NOP IASC NOP JSB .ENTR DEF .N LDA .N,I CLB DIV D10 ADA O60 ADB O60 ALF,ALF ADA 1 JMP IASC,I END ge  92903-18015 1913 S C0122 &ICRLU              H0101 zFTN4 INTEGER FUNCTION ICRLU(NUMB),. 92903-16001 REV.1913 781009 C C SOURCE 92903-18015 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ************************************************************** C * * C * THIS FUNCTION RETURNS THE FOLLOWING VALUES: * C * * C * IF NUMB = -(DISC LU) -----> ICRLU = CARTRIDGE # * C * IF NUMB = CARTRIDGE # -----> ICRLU = DISC LU * C * IF NUMB = 0 -----> ICRLU = 1ST CARTRIDGE # * C * IF ANY ERROR (UNDEF..) -----> ICRLU = -1 (IF NOT MOUNTED) * C * ICRLU = -2 (IF CR LOCKED, * C * LOCK NOT 0 OR 77777B)* C * * C ************************************************************** C C DIMENSION IDCB(128),IREG(2) INTEGER AREG,BREG EQUIVALENCE (REG,IREG,AREG),(IREG(2),BREG) LOGICAL ISBTW C C-----IF NUMB NEGATIVE #, 1 < -(NUMB) < 64 ? C IF(NUMB.GE.0) GOTO 100 IF(ISBTW(-NUMB,2,63)) GOTO 300 C C-----READ CARTRIDGES DIRECTORY TABLE C 100 CALL FSTAT(IDCB) IF(NUMB.GT.0) GOTO 400 IF(NUMB.NE.0) GOTO 150 I=1 GOTO 160 C C-----SEARCH A CARTRIDGE NUMBER FROM A LU NUMBER C 150 DO 200 I=1,121,4 IF(IDCB(I).EQ.0) GOTO 300 IF(IDCB(I).NE.-NUMB) GOTO 200 160 ICRLU=IDCB(I+2) 180 IF( IDCB(I+3).NE.0 .AND. IDCB(I+3).NE.77777B ) GOTQ{  O 350 RETURN 200 CONTINUE C-----ERROR = -1, CARTRIDGE NOT MOUNTED 300 ICRLU=-1 RETURN C-----ERROR = -2, CARTRIDGE LOCKED 350 ICRLU=-2 RETURN C C-----SEARCH AN LU NUMBER FROM A CR NUMBER C 400 DO 500 I=1,121,4 IF(IDCB(I).EQ.0) GOTO 300 IF(IDCB(I+2).EQ.NUMB) GOTO 600 500 CONTINUE GOTO 300 600 ICRLU=IDCB(I) GOTO 180 END END$ X   92903-18016 1805 S C0122 &IDCLR              H0101 {ASMB HED CLEAR ID SEGMENT (RTE-IV ONLY) F. GAULLIER 06/JUL/77 NAM IDCLR,7 . 92903-16001 REV.1805 780228 * * SOURCE 92903-18016 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * ******************************************************************** * * * * * THIS ROUTINE CHECKS THE STATUS OF THE PROGRAM, AND IF IT IS * * * DORMANT, DISC RESIDENT AND LOADED TEMPORARILY, THIS SUBROUTINE * * * DO A 'OF,PNAME,8' TO REMOVE IT FROM THE SYSTEM. * * * IF THE CONDITION ARE NOT OK, A STATUS IS RETURNED TO THE USER. * * * * * * ------------- FORTRAN CALL ------------------------------------- * * * * * * IF( IDCLR(NAME[,IERR]) ) GOTO [ NON-SUCCESSFULL OPERATION ] * * * * * * IERR IS AN ERROR FLAG RETURNED BY IDCLR SUBROUTINE. * * * * * * IERR VALUE DEFINED ERROR * * * ---------- ------------- * * * 0 EVERYTHING IS O.K. * * * -1 PROGRAM NOT LOADED * * * -2 PROGRAM NOT FULLY DORMANT * * * -3 PROGRAM IS RTE-IV SYSTEM * * * -4 PROGRAM IS LOADED PERMANENTLY  * * * -5 PROGRAM IS CORE RESIDENT * * * * * ******************************************************************** SPC 1 ENT IDCLR EXT .ENTR,DORMT,IDGET,MESSS * A EQU 0 B EQU 1 SUP * *-----ENTRY POINT * ANAME BSS 1 AIERR OCT 0 IDCLR NOP JSB .ENTR DEF ANAME ADDRESS OF BUFFER CONTAINING PRG. NAME * *-----GET I.D. SEGMENT ADDRESS * JSB IDGET DEF *+2 DEF ANAME,I PROGRAM NAME STA OFBUF+2 SAVE ID SEG ADDR TEMPORARILY * *-----VERIFY THAT PROGRAM IS LOADED * SZA IDGET RETURNED NUL I.D. SEGMENT ADDRESS ! JMP IDCL3 CONTINUE PROCESS CCA ERROR: IERR=-1 PROGRAM IS NOT LOADED ! RETUN STA AIERR,I RETURN ERROR CODE IF REQUIRED CLB CLEAR ADDRESS OF ERROR PARAMETER STB AIERR FOR THE NEXT TIME JMP IDCLR,I RETURN LOGICAL VALUE SPC 3 * *-----CHECK THAT PROGRAM IS FULLY DORMANT * IDCL3 JSB DORMT CHECK IF PROGRAM IS DORMANT DEF *+2 DEF ANAME,I PROGRAM NAME SZA,RSS FULLY DORMANT ? JMP ERR02 NO, ERROR -2 * *-----VERIFY PROGRAM IS NOT A SYSTEM ONE (LOADED AT GEN.) * LDA OFBUF+2 RECALL ID SEG ADDR ADA P14 (A)=NAM5 ADDRESS, "SS" BIT & PROG. TYPE STA B XLA B,I GET PROGRAM TYPE AND B17 ISOLATE TYPE SZA,RSS CORE RESIDENT ? JMP ERR05 YES, ERROR -5 CPA P1 CORE RESIDENT ? JMP ERR05 YES, ERROR -5 XLA B,I NO, GET NAM5 WORD AND "SS" BIT AND M20 ISOLATE "SS" BIT INB SZA,RSS SHORT OR LONG I.D. SEG ? ADB P7 LONG I.D. SEGMENT ADB P4 (B)=ADDRESS OF DISC WORD XLA B,I GET DISC WORD SSA TRACK ON AUXILIARY LU # 3 JMP IDCL5 YES: NOT SYSTEM PROGRAM \ CMA,INA SUBSTRACT FROM DISC LIB ADDRESS ADA DSCLB SSA SYSTEM AREA ? JMP IDCL5 NOT SYSTEM PROGRAM LDA N3 YES, ERROR: IERR=-3 JMP RETUN RTE-III PROGRAM * *-----TRY TO PURGE IT WITH OF,NAME,8 * IDCL5 LDA ANAME MOVE NAME INTO OF,... LDB .OF2 BUFFER MVW P3 LDA =A,8 STA OFBUF+5 * JSB MESSS CALL SYSTEM PROCESSOR MESSAGE DEF *+3 .OF DEF OFBUF DEF P12 MESSAGE LENGTH IN CHAR. * JSB IDGET PROGRAM REMOVED ? DEF *+2 DEF ANAME,I SZA,RSS REMOVED ? JMP RETUN YES, RETURN OK (.FALSE. VALUE) LDA N4 NO, ERROR: IERR=-4, PROGRAM IS LOADED JMP RETUN PERMANENTLY. * *-----ERROR -2, PROGRAM IS NOT DORMANT * ERR02 LDA N2 JMP RETUN * *-----ERROR -5, PROGRAM IS CORE RESIDENT * ERR05 LDA N5 JMP RETUN * *-----CONSTANTS * . EQU 1650B * M20 OCT 20 MASK TO GET "SS" BIT OF WORD NAM5 OF I.D. B17 OCT 17 OFBUF ASC 2, OF, BSS 4 .OF2 DEF OFBUF+2 * *-----SYSTEM CONSTANTS * DSCLB EQU .+73 DISC ADDRESS OF RES LIB ENTRY POINTS SPC 2 P1 DEC 1 P3 DEC 3 P4 DEC 4 P7 DEC 7 P12 DEC 12 P14 DEC 14 N2 DEC -2 N3 DEC -3 N4 DEC -4 N5 DEC -5 END b  92903-18018 1805 S C0122 &IGET1              H0101 fASMB HED ** S/P IGET1 (21MX ONLY) P. SENANT 10/10/75 NAM IGET1,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18018 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IGET1 * * THIS PROGRAM GETS A BYTE IN A STRING * THE RETURNED WORD : - LEFT : THIS BYTE * - RIGHT : ONE BLANK * DM1 DEC -1 * .BUFF NOP BUFFER ADDRESS .N NOP REL. ADDR. OF BYTE * IGET1 NOP JSB .ENTR DEF .BUFF LDB .BUFF CLE,ELB ADB DM1 ADB .N,I LBT ALF,ALF IOR O40 JMP IGET1,I * O40 OCT 40 END !  92903-18019 1805 S C0122 &IGET2              H0101 gASMB HED S/P IGET2 (15/10/75) F. GAULLIER NAM IGET2,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18019 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IGET2 * * THIS PROGRAM GETS 2 BYTES IN A STRING * .BUFF NOP BUFFER ADDRESS .N NOP REL. ADDRESS OF FIRST BYTE * IGET2 NOP JSB .ENTR DEF .BUFF CCB ADB .N,I CLE,ERB ADB .BUFF DLD 1,I SEZ RRL 8 JMP IGET2,I END 7  92903-18020 1805 S C0122 &IGETB              H0101 xASMB HED ** S/P IGETB (21MX ONLY) F. GAULLIER 07/SEP/77 NAM IGETB,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18020 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IGETB * * THIS PROGRAM GETS A BYTE IN A STRING, RIGHT JUSTIFIED * THE RETURNED WORD : - RIGHT : THIS BYTE * - LEFT : ALL ZERO * DM1 DEC -1 * .BUFF NOP BUFFER ADDRESS .N NOP REL. ADDR. OF BYTE * IGETB NOP JSB .ENTR DEF .BUFF LDB .BUFF CLE,ELB ADB DM1 ADB .N,I LBT JMP IGETB,I * END %  92903-18021 1805 S C0122 &IMBED              H0101 xwFTN4 LOGICAL FUNCTION IMBED(IBUF,IBYT,LNBYT),. 92903-16001 REV.1805 78 .0517 C C C NAME: IMBED C SOURCE: &IMBED 92903-18021 C BINARY: %IMBED 92903-16001 PART OF %GPLB4 C C PMGR: FRANCOIS GAULLIER C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C **************************************************************** C * * C * THIS FUNCTION FAIL, (RETURN FALSE VALUE) IF NO BLANK * C * CHARACTER IS IMBEDED IN THE STRING STARTING AT BYTE: IBYT * C * INTO BUFFER: IBUF, THE STRING LENGTH BEING: LNBYT. * C * THE LEADING AND TRAILING BLANKS ARE IGNORED. * C * * C **************************************************************** C C DIMENSION IBUF(1) LOGICAL TEXT C TEXT=.FALSE. IMBED=.TRUE. C-----SET UP THE LOOP FOR (LN-1) BECAUSE INSIDE THE LOOP C I+1 IS USED !!! DO 100 I=IBYT,IBYT+LNBYT-2 K=IGET1(IBUF,I) IF(K .NE. 1H ) TEXT=.TRUE. IF(K.EQ.1H .AND. IGET1(IBUF,I+1).NE.1H .AND. TEXT) RETURN 100 CONTINUE IMBED=.FALSE. RETURN END END$   92903-18022 1805 S C0122 &INUM              H0101 fFTN4 LOGICAL FUNCTION INUM(IB,NCAR,NBCAR .,I),. 92903-16001 REV.1805 770114 C C SOURCE 92903-18022 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ************************************************************* C * * C * INUM IS A LOGICAL FUNCTION TO CONVERT AN ASCII * C * BUFFER INTO AN INTEGER NUMBER. CHECKS ARE MADE AND * C * FUNCTION SUCCEED IF THE INPUT BUFFER IS NOT CORRECT. * C * * C * IF( INUM(IBUF,NCAR,NBCAR,I) ) GOTO ERROR * C * * C * WHERE: * C * IBUF BUFFER * C * NCAR NUMBER OF FIRST CHARACTER TO USE IN * C * THE BUFFER ( 1ST = 1) * C * NBCAR NUMBER OF CHARACTER TO BE USED * C * I INTEGER VARIABLE WHERE THE INTEGER * C * VALUE IS RETURNED. * C * * C ************************************************************* C IF(NBCAR .LE. 0) GOTO 600 INUM=.FALSE. I=0 ISIG=1 L=NBCAR JE=NCAR+NBCAR-1 DO 100 J=NCAR,JE K=IGET1(IB,J) IF(K .EQ. 1H-) GOTO 400 IF(K.EQ.1H+) GO TO 450 IF(K.NE.1H ) GO TO 500 L=L-1 100 CONTINUE RETURN C 400 ISIG=-1 450 J=J+1 L=L-1 50w   0 I=NUMD(IB,J,L) IF(I .LT. 0) GOTO 550 I=I*ISIG RETURN C 550 IF(ISIG .EQ. 1) GOTO 600 C SPECIAL CHECK FOR -32768 IF(IGET2(IB,J) .NE. 2H32) GOTO 600 IF(IGET2(IB,J+2) .NE. 2H76) GOTO 600 IF(IGET1(IB,J+4) .NE. 1H8) GOTO 600 I=-32768 RETURN C C ERROR RETURN ! C 600 INUM=.TRUE. I=0 RETURN END END$ O   92903-18023 1805 S C0122 &IRANG              H0101 yASMB HED S/P IRANG (21MX ONLY) 8/7/76 P. SENANT NAM IRANG,7 . 92903-16001 REV.1805 760708 * * SOURCE 92903-18023 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IRANG * * THIS SUBPROGRAM COMPARES TWO BUFFERS * BUF1=BUF2 : 0 * BUF1BUF2 : 1 * * BUF1 NOP BUF2 NOP NN NOP * IRANG NOP JSB .ENTR DEF BUF1 LDA BUF1 LDB BUF2 CMW NN,I JMP *+4 CCA,RSS CLA,INA JMP IRANG,I CLA JMP IRANG,I END O  92903-18024 1805 S C0122 &ISBIT              H0101 ASMB HED S/P ISBIT (15/10/75) F. GAULLIER NAM ISBIT,7 . 92903-16001 REV.1805 770708 * * SOURCE 92903-18024 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT ISBIT * * "ISBIT" IS A LOGICAL FUNCTION * .FALSE. = THE BIT IS NOT SET * .TRUE. = THE BIT IS SET * J NOP WORD IB NOP BIT # (0 TO 15) * ISBIT NOP JSB .ENTR DEF J LDA J,I LDB IB,I ADB DM16 STB IB ELA ISZ IB JMP *-2 CLA ERA JMP ISBIT,I * DM16 DEC -16 END h  92903-18025 1805 S C0122 &ISBTW              H0101 ASMB HED S/P ISBTW (15/10/75) F. GAULLIER NAM ISBTW,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18025 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT ISBTW EXT .ENTR SPC 1 * LOGICAL FUNCTION ISBTW(I,MIN,MAX) * * ISBTW = 0 / .FALSE. (E=1) IF I IS INSIDE THE LIMITS. * (LIMITS INCLUDED.) * * THE SAME AS FTN4 STATEMENT: * * ISBTW = I.LT.MIN .OR. I.GT.MAX SPC 2 I NOP MIN NOP MAX NOP ISBTW NOP JSB .ENTR DEF I * LDA MIN,I CMA,INA ADA I,I STA 1 LDA I,I CMA,INA ADA MAX,I IOR 1 SSA CCA,CLE,RSS OUTSIDE LIMIT ---> .TRUE. E=0 CLA,CCE INSIDE LIMIT ---> .FALSE. / 0 E=1 JMP ISBTW,I END h  92903-18026 1805 S C0122 &ISCAN              H0101 ASMB HED S/P ISCAN 3/6/77 P. SENANT NAM ISCAN,7 . 92903-16001 REV.1805 770603 * * SOURCE 92903-18026 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT ISCAN * * THIS ROUTINE IS ABLE TO SCAN A STRING UNTIL/WHILE A TEST BYTE * OCCURS. * * CALLING SEQUENCE: * * I = ISCAN (IBUF,IBEG,IBYTES,IFLAG) * * IBUF : BUFFER TO BE SCANNED * IBEG : STARTING BYTE OF SCANNING/ LAST POSITION SCANNED * IBYTES : LEFT = TERMINATOR * RIGHT = TEST BYTE * FLAG : 0 = UNTIL * 1 = WHILE * * THE A-REGISTER RETURNS A FLAG : 0 = TEST BYTE IS DETECTED * 1 = TERMINATOR IS DETECTED * BUF NOP IBEG NOP BYTES NOP FLAG NOP * ISCAN NOP JSB .ENTR DEF BUF * LDB BUF COMPUTE CLE,ELB STARTING ADB DM1 BYTE ADDRESS ADB IBEG,I OF STRING STB BUF AND SAVE IT * LDA FLAG,I KIND OF SCAN? SZA JMP WHILE SCAN WHILE * LDA BYTES,I SCAN UNTIL SFB JMP .TES1 TEST BYTE DETECTED .TERM EQU * TERMINATOR DETECTED LDA BUF CMA,INA ADB 0 STB IBEG,I RETURN LAST POSITION CCA I=-1/.TRUE. JMP ISCAN,I * .TES1 EQU * INB .TEST EQU * TEST BYTE FOUND LDA BUF CMA,INA ADB 0 STB IBEG,I RETURN LAST POSITION CLA JMP ISCAN,I I=0/.FALSE. * * WHILE EQU * SCAN WHILE LDA BYTES,I CLB RRL 8 SPL5  IT TEST & TERM. ALF,ALF STA TEST STB TERM LDB BUF LOOP LBT CPA TERM TERMINATOR ? JMP .TERM YES CPA TEST TEST BYTE ? JMP LOOP YES . CONTINUE JMP .TEST * * DM1 DEC -1 TERM NOP TEST NOP END ~   92903-18027 1805 S C0122 &ISNUL              H0101 ASMB HED S/P ISNUL (15/10/75) F. GAULLIER NAM ISNUL,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18027 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT ISNUL EXT .ENTR SPC 2 * IF(ISNUL(IBUF,# OF WORDS) ) GARBAGE IN BUFFER * ONLY NUL CHARACTERS FOUND IN THE BUFFER SPC 1 .B NOP .N NOP ISNUL NOP JSB .ENTR DEF .B * LDA .N,I CMA,INA CCE,SSA,RSS JMP ISNUL,I OK ! ---> .FALSE. E=1 STA .N LDB .B LOOP LDA 1,I INB CCE,SZA JMP NO ISZ .N JMP LOOP JMP ISNUL,I OK ! ---> .FALSE. / 0 E=1 * NO CCA,CLE ERROR ! ---> .TRUE. E=0 JMP ISNUL,I END [  92903-18029 1805 S C0122 &ISSPA              H0101 ASMB HED S/P ISSPA (21MX ONLY) 15/10/75 P. SENANT NAM ISSPA,7 . 92903-16001 REV.1805 760929 * * SOURCE 92903-18029 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT ISSPA SPC 1 * IF(ISSPA(IBUF,1ST CHAR.,# OF BYTE) ) GARBAGE IN BUFFER * ONLY SPACES FOUND IN THE BUFFER SPC 1 DM1 DEC -1 * IBUF NOP IN NOP N NOP * ISSPA NOP JSB .ENTR DEF IBUF LDA N,I CMA,INA CCE,SSA,RSS JMP ISSPA,I OK ---> .FALSE. E=1 STA N LDB IBUF CLE,ELB ADB DM1 ADB IN,I LOOP LBT CPA O40 CLA,CCE,RSS JMP NON ISZ N JMP LOOP JMP ISSPA,I OK ! ---> .FALSE. / 0 E=1 NON ADB DM1 B=BYTE POINTER TO 1ST BAD CHAR. CCA,CLE ERROR ! ---> .TRUE. E=0 JMP ISSPA,I * O40 OCT 40 END D  92903-18030 1805 S C0122 &ISUPB              H0101 FTN4 INTEGER FUNCTION ISUPB(IBUF,LEN),. 92903-16001 REV.1805 770123 C C SOURCE 92903-18030 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ********************************************** C * THIS FUNCTION CONTRACTS A CHARACTER STRING * C * CONTAINED IN A BUFFER WHOSE NAME IS GIVEN * C * IN FIRST PARAMETER. LENGTH OF THIS STRING * C * IS GIVEN IN THE SECOND PARAMETER. FUNCTION * C * RETURNS THE NEW LENGTH OF THE CONTRACTED * C * STRING. (ALL LENGTH ARE IN WORDS) * C ********************************************** C C REV. 770123 CORRECT A BUG ! FG C DIMENSION IBUF(1) C C LENC=2*LEN K=0 I=1 10 IF(IGET1(IBUF,I).EQ.1H ) GOTO 30 15 I=I+1 IF(I.LE.LENC) GOTO 10 CALL BLAN(IBUF,LENC+1,K) ISUPB=(LENC+1)/2 RETURN 30 J=I 40 K=K+1 J=J+1 IF(J.GT.LENC) GOTO 60 IF(IGET1(IBUF,J).EQ.1H ) GOTO 40 CALL MOVCA(IBUF,J,IBUF,I,LENC-J+1) 60 LENC=LENC+I-J GOTO 15 END END$ -  92903-18031 1805 S C0122 &JASC              H0101 jfFTN4 SUBROUTINE JASC(IVAL,IBUF,JBYT .,NBYTE),. 92903-16001 REV.1805 770721 C C SOURCE 92903-18031 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO CONVERT ANY INTEGER * C* NUMBER (POSITIVE OR NEGATIVE) IN AN ASCII STRING . * C* * C* PARAMETERS : * C* * C* IVAL : INTEGER VALUE * C* IBUF : BUFFER TO STORE ASCII STRING * C* IBYT : FIRST BYTE # TO STORE STRING * C* IF IBYT IS NEGATIVE LEADING BLANKS IN * C* STRING ARE CHANGED TO ZEROS * C* NBYTE : # OF BYTES OF THE STRING * C* * C********************************************************************* C C DIMENSION IBUF(1),ITEMP(3) C IBYT=JBYT IF(JBYT.LT.0) IBYT=-JBYT IF((IBYT.LT.1).OR.(NBYTE.LT.1)) RETURN CALL BLAN(IBUF,IBYT,NBYTE) JVAL=IVAL IF(IVAL.LT.0) JVAL=-IVAL CALL CNUMD(JVAL,ITEMP) DO 100 I=1,6 IF(IGET1(ITEMP,I).NE.1H ) GO TO 200 100 CONTINUE 200 IF(IVAL.GE.0) GO TO 300 I=I-1 CALL PUTCA(ITE}u  MP,1H-,I) 300 IF(7-I.GT.NBYTE) RETURN CALL MOVCA(ITEMP,I,IBUF,IBYT+NBYTE-7+I,7-I) IF(JBYT.GT.0) RETURN DO 350 K=IBYT,IBYT+NBYTE-1 IF(IGET1(IBUF,K).EQ.1H ) CALL PUTCA(IBUF,1H0,K) 350 CONTINUE RETURN END END$ Y   92903-18032 1805 S C0122 &JULIA              H0101 ASMB NAM JULIA,7 . 92903-16001 REV.1805 761222 * * SOURCE 92903-18032 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT JULIA EXT .ENTR A EQU 0 B EQU 1 * * * * FORTRAN CALLABLE FUNCTION: * * I=JULIA(ID,MO,IY) * * ON RETURN I = JULIAN DAY,OR * = -1 IF ERROR! * * ID NOP MO NOP IY NOP JULIA NOP JSB .ENTR DEF ID LDA IY,I ADA MIN SSA JMP ERROR LDA IY,I ADA MAX SSA,RSS JMP ERROR LDA IY,I CPA D1900 INA CPA D2000 INA AND D3 LDB D28 SZA,RSS INB STB FEBR LDA ID,I CMA,INA SSA,RSS JMP ERROR LDA MO,I CMA,INA STA POINT SSA,RSS JMP ERROR ADA D12 SSA JMP ERROR LDA AMT ADA MO,I LDB ID,I CMB,INB ADB A,I SSB JMP ERROR LDA ID,I LDB AMT LOOP ADA B,I INB ISZ POINT JMP LOOP JMP JULIA,I ERROR CCA JMP JULIA,I POINT NOP AMT DEF *+1 DEC 0,31 FEBR DEC 0,31,30,31,30,31 DEC 31,30,31,30,31 D3 DEC 3 D12 DEC 12 D28 DEC 28 MIN DEC -1801 MAX DEC -2100 D1900 DEC 1900 D2000 DEC 2000 END #   92903-18033 1805 S C0122 &JULIB              H0101 FTN4 LOGICAL FUNCTION JULIB(JUDAY,IAN,JOUR .,MOIS),. 92903-16001 REV.1805 771104 C C SOURCE 92903-18033 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C GIVE THE DAY AND MONTH NUMBER FROM THE DAY OF YEAR C C CALLING SEQUENCE: C C IF ( JULIB(JULDAY,YEAR,DAY,MONTH) ) GOTO .. ERROR C C JULDAY - DAY OF THE YEAR 1 TO 366 (JULIAN DAY) C YEAR - YEAR 0 TO 2999 C DAY - THE DAY OF THE MONTH WILL BE RETRUNED HERE C MONTH - THE MONTH WILL BE RETUNED YEAR C C DIMENSION IBUF(12) DATA IBUF/31,28,31,30,31,30,31,31,30,31,30,31/ JULIB=.TRUE. IBUF(2)=28 IF(IAN.LE.0) RETURN IF (IAN.EQ.1900.OR.IAN.EQ.2000) GO TO 50 K=(IAN/4)*4 IF(K.EQ.IAN)IBUF(2)=29 50 CONTINUE JDAY = JUDAY DO 20 I=1,12 IF (JDAY.LE.IBUF(I)) GO TO 30 JDAY = JDAY - IBUF(I) 20 CONTINUE RETURN C C DAY OF YEAR WAS OK, RETURN RESULT C 30 CONTINUE JULIB=.FALSE. JOUR = JDAY MOIS = I RETURN END END$ 0  92903-18034 1805 S C0122 &JUSTF              H0101 ASMB HED S/P JUSTF (21MX ONLY) F. GAULLIER 22/JUL/77 NAM JUSTF,7 . 92903-16001 REV.1805 770722 * * SOURCE 92903-18034 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT JUSTF EXT .ENTR SUP * * THIS SUBROUTINE MAKES A STRING RIGHT OR LEFT-JUSTIFIED * * CALLING SEQUENCE: * * CALL JUSTF(IBUF,IBYT,NBYTE,ICNW) * * IBUF - BUFFER CONTAINING THE STRING TO BE JUSTIFIED * IBYT - STARTING BYTE NUMBER (1ST IS 1) * NBYTE - NUMBER OF BYTES TO BE SCANNED * ICNW - LEFT OR RIGHT JUSTIFY * = 0 ---> RIGHT JUSTIFY * NOT 0 ---> LEFT JUSTIFY * .IBUF NOP .IBEG NOP .ILEN NOP .FLAG NOP * JUSTF NOP JSB .ENTR DEF .IBUF LDA .ILEN,I CMA,INA STA COUNT /SAVE LENGTH OF STRING LDB .IBUF CLE,ELB ADB .IBEG,I ADB DM1 STB .IBUF /SAVE STARTING POSITION LDA 1 ADA DM1 ADA .ILEN,I STA LAST /SAVE END POSITION * LOOP1 EQU * LBT CPA BLANC RSS JMP SUIT ISZ COUNT JMP LOOP1 JMP JUSTF,I /ONLY BLANKS.. EXIT * SUIT EQU * ADB DM1 STB P1 /SAVE STARTING BYTE OF STRING LDB LAST * LOOP2 EQU * LBT CPA BLANC RSS JMP FIN /LAST SIGNIFICANT CHAR IS FOUND ADB DM2 ISZ COUNT JMP LOOP2 JMP JUSTF,I * FIN EQU * STB P2 /SAVE LAST SIGNIFICANT CHAR. + 1 * LDA .FLAG,I SZA,RSS JMP RIGHT /MUST BE   RIGHT JUSTIFIED * LDB .IBUF CPB P1 SOMETHING TO DO ? JMP JUSTF,I NO, RETURN LDA COUNT CMA,INA STA COUNT LDA P1 MBT COUNT /LEFT-JUSTIFIED LDA BLANC LOOP3 CPB P2 JMP JUSTF,I /DONE SBT /FILL WITH BLANKS JMP LOOP3 * * * RIGHT ADB DM1 CPB LAST SOMETHING TO DO ? JMP JUSTF,I NO, RETURN RSS YES, SWAP CHARACTERS RIGH1 LDB P2 LBT STA CHAR /SAVE CHARACTER ADB DM2 STB P2 INB LDA BLANC SBT /REPLACE WITH BLANK LDA CHAR LDB LAST SBT ADB DM2 STB LAST ISZ COUNT JMP RIGH1 JMP JUSTF,I * * RESERVATIONS * DM1 DEC -1 DM2 DEC -2 COUNT NOP CHAR NOP BLANC OCT 40 LAST NOP P1 NOP P2 NOP END h   92903-18035 1805 S C0122 &JPAR              H0101 TFTN4 LOGICAL FUNCTION JPAR(IBUFI,LNBYI,NOF,IBUFO,LNBYO,IFLG .,JVAL),. 92903-16001 REV.1805 780221 C C SOURCE 92903-18035 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C REV: 12/MAY/77 JCM C REV: 11/JAN/77 FG OR FOR MULTIPOINT TERMINAL C C C********************************************************************* C* * C* THIS IS A LOGICAL FUNCTION USED TO PARSE STRINGS. * C* MEANING OF PARAMETERS : * C* IBUFI = INPUT BUFFER * C* LNBYI = LENGTH OF INPUT BUFFER IN BYTES * C* NOF = SEQUENTIAL # OF FIELD TO FIND (FIRST IS 1) * C* IBUFO = OUTPUT BUFFER * C* LNBYO = LENGTH OF OUTPUT BUFFER IN BYTES * C* IFLG = RETURN FLAG * C* JVAL = INTEGER OR REAL VALUE OF IBUFI * C* * C* FIELD SEPARATOR IS = OCT 37 OR = OCT 36 * C* * C* THIS FUNCTION IS .FALSE. IF ALL IS O.K. - THE FIELD # NOF * C* HAS BEEN FOUND AND MOVED IN OUTPUT BUFFER AND : * C* * C* IFLG = 0 FIELD IS ONLY BLANKS * C* IFLG = 1 FIELD IS INTEGER POS OR NE JVAL=IN}TEGER * C* IFLG = 3 FIELD IS ASCII (FROM SPACE TO _) * C* * C* THIS FUNCTION IS .TRUE. IF : * C* * C* * C* -AN ILLEGAL CHARACTER (NON PRINTABLE OR LOWER CASE) * C* HAS BEEN FOUND (IFLG=5) * C* * C* -THERE IS AN ERROR : * C* NOF IS NEGATIVE OR NOT IN THE BUFFER RANGE * C* IN THIS CASE IFLG = 6 * C* * C* -A SPECIAL STRING HAS BEEN FOUND : * C* -INSERT IFLG=4 * C* -HELP IFLG=7 * C* -LAST SCREEN IFLG=8 * C* -ABORT PROGRAM IFLG=9 * C* * C********************************************************************* C C DECLARATIONS : C LOGICAL ISSPA,INUM DIMENSION IBUFI(1),IBUFO(1),JVAL(2) DATA IUS/17440B/,IRS/17040B/ C C INITIALISE BUFFER AND PARAMETERS C JPAR=.FALSE. IE=(LNBYO+1)/2 DO 3 I=1,IE 3 IBUFO(I)=2H C C FIND BEGINING OF FIELD # NOF C J=0 IFLG=6 IF(NOF.LE.0) GO TO 140 IF(NOF.EQ.1) GO TO 30 DO 20 I=1,NOF-1 10 IF(J.EQ.LNBYI) GO TO 140 J=J+1 N=IGET1(IBUFI,J) IF(N.NE.IUS .AND. N.NE.IRS) GOTO 10 20 CONTINUE C C MOVE CHARACTERS IN OUPUT BUFFER AND CHECK FOR NON PRINTABLE ASCII C 30 IFLG=3 DO 50 I=1,LNBYO 9@ J=J+1 M=IGET1(IBUFI,J) L=IAND(IALF2(M),377B) IF((L.LE.36B).OR.(L.GT.137B)) GO TO 130 50 CALL PUTCA(IBUFO,M,I) C C NORMAL RETURN . ONLY BLANKS ? C IF(ISSPA(IBUFO,1,LNBYO)) GO TO 60 IFLG=0 RETURN C C NORMAL RETURN . INTEGER ? C 60 IF(INUM(IBUFO,1,LNBYO,JVAL)) GO TO 120 IFLG=1 120 RETURN C C MISSING INTEGER NEGATIVE AND REAL CHECKS !!!!! C C C ERROR RETURN C 130 IFLG=5 IF(L.EQ.151B) IFLG=4 IF(L.EQ.150B) IFLG=7 IF(L.EQ.163B) IFLG=8 IF(L.EQ.141B) IFLG=9 140 JPAR=.TRUE. 145 RETURN END END$ C |  92903-18036 1805 S C0122 &KLCLS              H0101 ASMB HED FLUSH A CLASS I/O (RTE-III/IV) F. GAULLIER 15/APR/77 NAM KLCLS,7 . 92903-16001 REV.1805 780112 * * SOURCE 92903-18036 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * * THIS ROUTINE DO A COMPLETE CLEAN UP OF A CLASS I/O * AND TERMINATE BY RELEASING THE CLASS. * WHEN SOME I/O DEVICE HAVE NOT COMPLETED THEIR OPERATIONS * A TIMEOUT OF 10 MSEC IS FORCED TO THESE PERIPHERALS IN * ORDER TO GET THE CLASS BUFFER AND RELEASE THE SAM. * * CALLING SEQUENCE: * * IF ( KLCLS(ICLAS) ) GOTO ERROR * ICLAS IS THE CLASS NUMBER * SPC 2 A EQU 0 B EQU 1 SUP PRESS EXTENDED LISTING SPC 1 EXT EXEC,$LIBR,$LIBX,.ENTR ENT KLCLS SPC 2 $OFF NOP JSB $LIBR OCT 0 PRIVILEDGE ROUTINE JMP $OFF,I SPC 1 $ON NOP JSB $LIBX EXIT FROM PRIVILEDGE ROUTINE DEF $ON SPC 2 .CL# NOP CLASS I/O WORD KLCLS NOP JSB .ENTR DEF .CL# * LDA .CL#,I AND MSK CLEAR BITS 15-14-13 SZA,RSS JMP OKRTN STA CLASW SAVE CLASS I/O WORD JSB EXEC DO A WRITE/READ CLASS I/O DEF *+8 DEF NAB20 WRITE/READ - NO ABORT DEF D0 DEF * DUMMY BUF DEF D1 DUMMY LEN DEF * DUMMY PARAMETERS DEF * DUMMY PARAMETERS DEF CLASW CLASS WORD JMP REL50 ERROR ! CHECK IT IS "IO 00" * LDA CLASW RECALL CLASS WORD IOR BIT15 SET "NO WAIT BIT" STA CLASS SPC 1 RELC3 JSB EXEC GET TO DE-ALLOCATE DEF *+5 DEF NAB21 GET CLASS - NO ABORT DEF CLASS CLASS WORD DEF TEMP DUMMY BUFFER DEF D1 JMP REL50 ERROR RETURN CHECK CODE SSA,RSS JMP RELC3 LOOP UNTIL END OF CLASS SPC 1 STA #RQ SAVE -(N-1) REQUEST IN QUEUE CMA,SZA,RSS # OF REQUEST IN QUEUE JMP OKRTN CLASS IS EMPTY, EXIT. SPC 1 LDA EQTA GO THROUGH ALL EQT TO FORCE A TO STA EQTPT ON ALL DEVICES WAITTING ON THIS CLASS LDA EQT# CMA,INA STA EQTCT SPC 1 REL20 XLA EQTPT,I GET EQT1 SZA,RSS EQT BUSY ? JMP REL24 NO, GOTO NEXT ONE SSA HLT INA GET 2ND WORD OF SAM BUFFER STA TEMP SPC 1 ********************************** PRIVILEDGE MODE JSB $OFF XLA TEMP,I GET WORD 2 RAL SSA,SLA,RSS T FIEL = 3 ? JMP REL22 NO, FORGET IT LDA TEMP YES, IT IS A CLASS REQUEST ADA D3 GO CHECK CLASS WORD XLA A,I GET CLASS WORD FROM SAM BUFFER AND MSK CPA CLASW BELONG TO THIS CLASS ? RSS YES, GO SET A TIME OUT JMP REL22 NO, SKIP SET TIME OUT CODE LDA EQTPT RECALL EQT1 ADA D14 CCB SET A TIMEOUT OF STB A,I 10 MSEC INTO EQT15 ISZ #RQ UPDATE # OF PENDING RQ (NEVER SKIP !!) REL22 JSB $ON ********************************** PRIVILEDGE MODE $END SPC 1 REL24 LDA #RQ RECALL -(N-1) REQUEST LEFT IN THE QUEUE CMA,SZA,RSS ALL PENDING REQUEST FOUNDED ? JMP REL30 YES, GO GET THEM * LDA EQTPT GOTO NEXT EQT ADA D15 STA EQTPT ISZ EQTCT MORE EQT ? JMP REL20 YES, CONTINUE * REL30 LDA =D-12000 NO, WAIT ABOUT ISZ A 30 MS ON XE JMP *-1 BEFORE JMP RELC3 GETTING CLASS REQUESTS SPC 2 REL50 CPA ASCIO CHECK THAT IT IS "IO 00" RSS JMP ERRTN v ERROR RETURN CPB ASC00 JMP OKRTN OK, RETURN TO USER ERRTN CCA ERROR RETURN JMP KLCLS,I SPC 1 OKRTN CLA EXIT WITH A = 0 JMP KLCLS,I SPC 3 NAB20 OCT 100024 NAB21 OCT 100025 ASCIO ASC 1,IO ASC00 ASC 1,00 EQTA EQU 1650B EQT# EQU EQTA+1 SPC 1 D0 DEC 0 D1 DEC 1 D3 DEC 3 D14 DEC 14 D15 DEC 15 BIT15 OCT 100000 MSK OCT 17777 CLASS EQU .CL# CLASW NOP TEMP EQU $ON #RQ NOP EQTPT NOP EQTCT NOP END   92903-18037 1805 S C0122 &LNCAR              H0101 {FTN4 FUNCTION LNCAR(IBUF,NCAR .,NBCAR),. 92903-16001 REV.1805 770712 C C SOURCE 92903-180037 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* THIS FUNCTION IS USED TO TO COMPUTE THE REAL LENGTH * C* OF A STRING EXCLUDING TRAILING BLANKS. * C* * C* PARAMETERS : * C* IBUF : INPUT BUFFER * STRING * C* NCAR : # OF THE FIRST CHAR TO USE IN * C* IBUF * C* NBCAR : # OF CHARACTERS TO BE USED IN * C* IBUF * C* * C********************************************************************* C C DIMENSION IBUF(1) LNCAR=NBCAR DO 100 I=1,NBCAR IF(IGET1(IBUF,NCAR+NBCAR-I).NE.1H ) GO TO 200 100 LNCAR=LNCAR-1 200 RETURN END END$   92903-18038 1805 S C0122 &LNGT              H0101 \ASMB HED S/P LNGT (LIKE LNGTH IN TCS B) P. SENANT NAM LNGT,7 . 92903-16001 REV.1805 740910 * * SOURCE 92903-18038 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT LNGT EXT .ENTR ADDR NOP SIZE NOP LNGT NOP JSB .ENTR DEF ADDR CCB ADB ADDR ADB SIZE,I /CALCULATE LAST WORD OF ARRAY LDA SIZE,I CMA,INA /FORM NEG. COUNT STA SIZE LNGT1 LDA B,I CPA =B20040 /BLANKS? JMP LNGT2 /YES LDB SIZE /NO CMB,INB /CONVERT TO POSITIVE COUNT RBL /X2 FOR CHARACTERS AND =B377 CPA =B40 /LAST ONE A BLANK ADB =D-1 YES-DECREMENT COUNT STB A JMP LNGT,I /RETURN WITH ANSWER IN A LNGT2 EQU * ADB =D-1 BACK UP POINTER ISZ SIZE DONE? JMP LNGT1 /NO CLA /YES JMP LNGT,I A EQU 0 B EQU 1 END   92903-18039 1913 S C0122 &MADSP              H0101 ASMB HED RTE-IV LARGEST PARTITION EVER NAM MADSP,7 . 92903-16001 REV.1913 781219 SPC 3 ********************************************************************** * * * NAME: MADSP MAXIMUM ADDR SPACE * * SOURCE: &MADSP 92903-18039 * * BINARY: %MADSP ----NONE--- PART OF %GPLB4 92903-16001 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 EXT .ENTR,$DLP,$SDA,$PLP,$OPSY ENT MADSP SUP SPC 2 * THIS SUBROUTINE RETURN THE 3 MAXIMUM ADDRESS SPACE * RETURN THE # OF PAGES, INCLUDED BASE PAGE. * * CALLING SEQUENCE: * CALL MADSP(IBUF) * IBUF(1) = MAXIMUM PROGRAM ADDRESS SPACE WITHOUT SYST. COMMMON * IBUF(2) = MAXIMUM PROGRAM ADDRESS SPACE WITH SYST. COMMON * IBUF(3) = MAXIMUM PROGRAM ADDRESS SPACE WITH TABLE AREA II * .BUF NOP MADSP NOP JSB .ENTR DEF .BUF * CLA SET ERROR INDICATOR STA .BUF,I * LDA $OPSY GET SYSTEM TYPE CPA DM9 RTE-IV ? RSS JMP MADSP,I NO, RETURN SPC 1 XLA $DLP GET TYPE IV WITHOUT SSGA ALF,ALF SET IT INTO NUMBER RAR,RAR OF PAGES CMA,INA !   AND COMPUTE PARTITION ADA D32 SIZE INA FOR BASE PAGE STA .BUF,I AND RETURN IT TO THE USER ISZ .BUF * XLA $SDA GET TYPE IV WITH SSGA CMA,INA COMPUTE NUMBER OF PAGE ADA D32 INA FOR BASE PAGE STA .BUF,I ISZ .BUF * XLA $PLP GET TYPE III ALF,ALF SET IT IN NUMBER OF PAGES RAR,RAR CMA,INA COMPUTE NUMBER OF PAGES ADA D32 INA FOR BASE PAGE STA .BUF,I JMP MADSP,I SPC 2 DM9 DEC -9 D32 DEC 32 END z   92903-18040 1805 S C0122 &MOVCA              H0101 wASMB HED ** S/P MOVCA (21MX ONLY) F. GAULLIER 07/SEP/77 NAM MOVCA,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18040 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT MOVCA SUP * * THIS PROGRAM MOVES A STRING * 21MX INSTRUCTIONS ARE USED * DM1 DEC -1 * .BUF1 NOP .N1 NOP .BUF2 NOP .N2 NOP .NC NOP * MOVCA NOP JSB .ENTR DEF .BUF1 * LDA .BUF1 CLE,ELA ADA DM1 ADA .N1,I LDB .BUF2 CLE,ELB ADB DM1 ADB .N2,I MBT .NC,I JMP MOVCA,I END   92903-18041 1805 S C0122 &MOVCX              H0101 xASMB NAM MOVCX,7 . 92903-16001 REV.1805 770512 * * SOURCE 92903-18041 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ********************************************************************** * * * THIS SUBROUTINE MOVES CHARACTERS FROM A * * SOURCE BUFFER TO A DESTINATION BUFFER . SEVERAL FIELDS MAY BE * * MOVED IN ONE CALL . THESE FIELDS MUST BE CONTIGUOUS IN THE * * SOURCE BUFFER . * * * * THE CALLING SEQUENCE IS : * * * * JSB MOVCX * * DEF *+6 * * DEF BUFS SOURCE BUFFER ADDRESS * * DEF SOF SOURCE CHARACTER OFFSET ADDRESS (TABLE)* * DEF BUFD DEST. BUFFER ADDRESS (TABLE)* * DEF OFSET OFFSET IN BYTE ADDED TO SOURCE OFFSET * * DEF DBLEN DEST. BUFFER LENGTH (IN BYTE) * * (USED ONLY FOR CONVERSION) * * * * THREE TABLES ARE NECESSARY IN THE CALLING PROGRAM : * * * * 1)- TABLE OF THE OFFSETS IN THE SOURCE BUFFER : IF N FIELDS * * ARE TO BE MOVED :  * * SOF DEC SOF1 SOURCE OFFSET OF FIELD # 1 * * DEC SOF2 SOURCE OFFSET OF FIELD # 2 * * . * * . * * DEC SOFN SOURCE OFFSET OF FIELD # N * * DEC SOF(N+1)SOURCE OFFSET OF FIELD # N+1 * * DEC -1 END OF TABLE * * * * 2)- TABLE OF THE DESTINATIONS BUFFERS ADDRESSES : * * BUFD DEF BUFD1 DEST. BUFFER ADDRESS FOR FIELD # 1 * * DEF BUFD2,I DEST. BUFFER ADDRESS FOR FIELD # 2 * * . * * . * * DEF BUFDP,I DEST. BUFFER ADDRESS FOR FIELD # P * * DEF BUFDQ,I DEST. BUFFER ADDRESS FOR FIELD # Q * * . * * . * * DEF BUFDN DEST. BUFFER ADDRESS FOR FIELD # N * * * * 3)- TABLE OF THE DESTINATIONS BUFFERS LENGTH : * * THIS TABLE IS USED ONLY WHEN INTEGER CONVERSION ARE * * REQUIRED, THIS IS INDICATED BY AN INDIRECT ADDRESS IN * * THE TABLE 2 : DESTINATIONS BUFFERS ADDRESSES. * * THIS TABLE HAS NOT THE SAME LENGTH THAN TABLE 1 AND 2, * * THIS TABLE SHOULD HAVE AN ENTRY ONLY WHEN IT IS NECESSARY. * * * * DBLEN DEC DBL2 DEST. BUFFER LENGTH FOR FIELD # 2 * * . | * * DEC DBLP DEST. BUFFER LENGTH FOR FIELD # P * * DEC DBLQ DEST. BUFFER LENGTH FOR FIELD # Q * * * ********************************************************************** * * ENT MOVCX EXT .ENTR,MOVCA,JASC * * GET ADDRESSES OF CALLING PARAMETERS : * .P1 NOP SOURCE BUFF. .P2 NOP SOURCE CHAR. OFFSET .P3 NOP DEST. BUFFER .P4 NOP DEST. OFFSET .P5 NOP QUESTION # MOVCX NOP ENTRY POINT JSB .ENTR DEF .P1 * * COMPUTE # OF CHARACTERS TO MOVE FOR THIS FIELD * L1 LDA .P2 SOURCE CHAR. OFFSET ADDRESS INA INCREMENT ADDRESS LDB A,I GET NEXT SOURCE CHAR. OFFSET CPB .D1 -1 ? END OF TABLE ? JMP MOVCX,I YES RETURN ! LDA .P2,I NO COMPUTE CMA,INA FIELD LENGTH ADB A TO MOVE. STB LNGTH STORE IT * * COMPUTE SOURCE CHAR. OFFSET . * LDB .P2,I GET OFFSET ADB .P4,I TRUE CHAR. OFFSET FOR THIS FIELD STB SOF STORE IT * * CHECK FOR INTEGER CONVERSION * LDA .P3,I GET DEST. BUFF ADD STA DEBAD SET IT TO MOVCA CALL SSA,RSS INTEGER CONVERSION REQUIRED ? JMP L4 NO, DO THE MOVE * ELA,CLE,ERA YES, CLEAR BIT15 STA DEBA. LDA LNGTH ERA DLD D1 SEZ SWP DST BUF+1 CLA INIT BINARY WORD TO NUL STA TEMP JSB MOVCA TRANSFERT BINARY DATA DEF *+6 INTO A WORD TO DO DEF .P1,I THE CONVERSION DEF SOF DEF TEMP OUTPUT BUFFER (I HOPE THAT DEF BUF+1 SOURCE LENGTH IS NOT MORE THAN 2 CHAR.) DEF BUF+2 FORCE LENGTH IN BYTE * JSB JASC DO THE CONVERSION DEF *+5 DEF TEMP DEF BUF INTO A TEMPORARY BUFFEXR DEF D1 DEF D6 * LDA BUF+2 LDB ASC. SET SPACE IF IT IS ZERO CPA ASC.0 STB BUF+2 * LDA .P5,I GET DESTINATION LENGTH IN BYTE CMA,INA COMPUTE OFSET IN THE TEMPORARY BUFFER ADA D7 STA TEMP * JSB MOVCA MOVE BYTE IN DESTINATION BUFFER DEF *+6 DEF BUF DEF TEMP OFFSET IN TEMPORARY BUFFER DEBA. NOP DESTINATION ADDR DEF D1 DEF .P5,I # OF CHAR. TO MOVE ISZ .P5 BUMP POINTER IN DEST. LEN TABLE JMP L6 * * MOVE CHARACTERS ! * L4 JSB MOVCA DEF *+6 DEF .P1,I SOURCE BUFF ADDRESS DEF SOF SOURCE OFFSET DEBAD NOP DEST BUFF ADDRESS DEF D1 DEST OFFSET DEF LNGTH # OF CHAR. TO MOVE * * INCREMENT ADDRESSES FOR NEXT MOVE * L6 ISZ .P2 SOURCE OFFSET ISZ .P3 DEST BUFFER JMP L1 GO TO NEXT MOVE * * DATA AND STORAGE * A EQU 0 D1 DEC 1 D2 DEC 2 D6 DEC 6 D7 DEC 7 .D1 DEC -1 ASC. ASC 1, ASC.0 ASC 1, 0 LNGTH NOP # OF CHARS TO MOVE BUF BSS 3 TEMP EQU DEBAD SOF EQU BUF END .  92903-18042 1805 S C0122 &MOVEW              H0101 {ASMB HED S/P MOVEW (15/10/75) F. GAULLIER NAM MOVEW,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18042 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR,&MVW ENT MOVEW * * THIS PROGRAM MOVES AN ARRAY * * CALL MOVEW(IBUFS,IBUFD,# WORDS) * AINI NOP AFINI NOP NMO NOP MOVEW NOP JSB .ENTR DEF AINI * LDA NMO,I STA NM * LDA AINI LDB AFINI JSB &MVW NM NOP * JMP MOVEW,I END !  92903-18043 1805 S C0122 &NAMCK              H0101 lASMB NAM NAMCK,7 . 92903-16001 REV.1805 770712 * * SOURCE 92903-18043 * * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * * SUBROUTINE USED TO CALL NAM.. ROUTINE FROM A * FORTRAN PROGRAM * * ENT NAMCK EXT NAM..,.ENTR * NAME NOP NAMCK NOP JSB .ENTR DEF NAME JSB NAM.. DEF *+2 DEF NAME,I SZA CCA JMP NAMCK,I END   92903-18044 1805 S C0122 &NUL              H0101 ^dASMB HED S/P NUL (15/10/75) F. GAULLIER NAM NUL,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18044 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT NUL EXT .ENTR,&REMP SPC 2 P BSS 2 NUL NOP JSB .ENTR DEF P * LDB P+1,I CMB,INB STB N LDA P CLB JSB REMPL N NOP JMP NUL,I * REMPL EQU &REMP END t  92903-18045 1805 S C0122 &NUMD              H0101 eASMB HED NUMD/ISNUM (21MX ONLY) F. GAULLIER 07/SEP/77 NAM NUMD,7 . 92903-16001 REV.1805 770907 * * SOURCE 92903-18045 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT NUMD,ISNUM SUP * * "NUMD" CONVERTS A NUMERIC STRING IN BINARY (INTEGER ONLY) * IF THE STRING IS NOT NUMERIC , -1 IS RETURNED * IF AN OVERFLOW (32767) IS DETECTED, * THEN "-1" IS RETURNED * * "ISNUM" IS A LOGICAL FUNCTION WHICH IS ABLE TO TEST * IF A STRING IS NUMERIC. * .FALSE. / 0 (E=0) : NUMERIC * .TRUE. (E=1) : NOT NUMERIC * BLAN OCT 40 MASK OCT 377 DM10 DEC -10 OM12 EQU DM10 TEMP NOP MEM NOP SPFL NOP OM60 OCT -60 D10 DEC 10 DM1 DEC -1 SPC 2 NUMD NOP LDA NUMD CCB SP. STA SP STB SPFL JMP SP+1 * ISNUM NOP LDA ISNUM CLB,INB JMP SP. SPC 1 .BUFF NOP ADRESSE BUFFER .N1 NOP NUMERO 1ER CARACTERE .NC NOP NOMBRE DE CARACTERES SP NOP JSB .ENTR DEF .BUFF * LDA .NC,I CMA,INA CCE,SSA,RSS JMP SP,I OK ! ---> .FALSE. E=1 STA .NC CLA STA TEMP LDB .BUFF CLE,ELB ADB DM1 ADB .N1,I * LOOP1 LBT CPA BLAN RSS JMP TEST2 ISZ .NC JMP LOOP1 CLA,CCE OK ! ---> .FALSE. / 0 E=1 JMP SP,I * LOOP2 LDB .N1 LBT TEST2 STA MEM STB .N1 ADA OM60 SSA JMP TE3 LDB OM12 ADB 0 SS  B NUMERIQUE ? JMP TE4 OUI TE3 LDA MEM JMP TEST3 NON , TEST SI BLANC TE4 STA MEM LDA TEMP MPY D10 SSA OVERFLOW ? JSB ER. YES CCE,SZB OVERFLOW ? JSB ER. ADA MEM SOC MPY HAS CLEARED THE O JSB ER. STA TEMP NON , OK ISZ .NC JMP LOOP2 JMP SP,I OK ! ---> .FALSE. E=1 * TEST3 LDB .N1 RSS LOOP3 LBT CPA BLAN CCE,RSS JMP ERR NI NUMERIQUE NI BLANC, ERREUR ! ISZ .NC JMP LOOP3 LDA TEMP JMP SP,I OK! ---> .FALSE. E=1 SPC 1 ER. NOP LDA SPFL SSA,RSS IS NUMD ROUTINE ? JMP ER.,I NO, CONTINUE. LDB .N1 ERR ADB DM1 B=BYTE POINTER TO FIRST BAD CHAR. CCA,CLE ERROR ! ---> .TRUE. E=0 JMP SP,I END V   92903-18046 1805 S C0122 &PRTSZ              H0101 ASMB HED RTE-III/IV PARTITION SIZE RETREIVE SUBROUTINE NAM PRTSZ,7 . 92903-16001 REV.1805 780112 * * SOURCE 92903-18046 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * DATE: 22/APR/77 * NAME: PRTSZ * SOURCE: &PRTSZ * RELOC: %PRTSZ * PGMR: DANIEL POT HPG * REV: 12/JAN/78 MOD FOR RTE-IV FG SPC 2 * ************************************** * * THIS SUBROUTINE RETURNS THE SIZES * * * OF THE TEN BIGGEST PARTITIONS USED * * * BY THE CURRENTLY RUNNING SYSTEM. * * * IT RETURN ALSO THE NUMBER OF PART. * * ************************************** SPC 2 * CALLING SEQUENCE: * * DIMENSION IBUF(10) * INTEGER PRTSZ * .. * * NBPART = PRTSZ(IBUF) * * IBUF(10) = THE LARGEST PARTITION SIZE OF THE SYSTEM. * * IF NOT RET-III OR RTE-IV RETURN ZERO FOR # OF PRT * AND PRT SIZE. SPC 2 ENT PRTSZ EXT .ENTR SUP EXT $MATA,$OPSY,$MNP SPC 2 TEMP NOP NBPRT NOP TOTAL NUMBER OF PARTITION LASTD NOP NINTH ADRESS OF OUTPUT BUFFER LLSTD NOP TENTH ADRESS OF OUTPUT BUFFER PONTR NOP POINTER OF THE OUTPUT BUFFER CONT NOP LOOP COUNTER MATPT NOP $MATA POINTER SPC 1 ADBUF NOP PRTSZ NOP JSB .ENTR DEF ADBUF RETURN BUFFER ADRESS * LDA ADBUF ADA =D8 STA LASTD INITIALISES LASTD INA STA LLSTD IMNITIALISES LLSTD LDA =D-10 STA CONT CLA STA NBPRT INIT NUMBER OF PARTITION LDB ADBUF STvDA 1,I INB ISZ CONT JMP *-3 CLEARS OUTPUT BUFFER * * * LDB $OPSY GET SYSTEM NUMBER CPB =D-9 RTE-IV ? JMP RTE4 YES. CPB =D-1 RTE-III ? RSS YES JMP EXIT RETURN, ERROR !! * LDB $MATA RTE-III, GET THE MAT ADDRESS ADB =D-1 LDA 1,I GET THE NUMBER OF MAT ENTRY LDB =D6 RTE-III MAT ENTRY LENGTH JMP PRTS3 * RTE4 LDA $MNP RTE-IV, GET THE NUMBER OF MAT ENTRY LDB =D7 RTE-IV MAT ENTRY LENGTH * PRTS3 STA NBPRT STB TEMP SAVE MAT ENTRY LENGTH CMA,INA STA CONT NUMBER OF PARTITIONS * LDB $MATA LOOP STB MATPT XLA 1,I SSA JMP NEXT ADB =D4 XLA 1,I AND =B1777 INA STA ADBUF,I JSB TRI LDB MATPT NEXT ADB TEMP GO TO NEXT ENTRY ISZ CONT JMP LOOP EXIT LDA NBPRT RECALL NUMBER OF PARTITION JMP PRTSZ,I SPC 2 TRI NOP LDA ADBUF GET FIRST OUTPUT BUFFER ADRESS STA PONTR INITIALISES POINTER TRI1 DLD PONTR,I GET FIRST AND SECOND PARTITION SIZE CMA,INA CALCULATES: -(PARTITION SIZE) ADA 1 CALCULATES PRT#2-PRT#1 SZA,RSS JMP TRI2 SSA,RSS PARTITIONS SIZES MUST BE REVERSED JMP TRI2 RIGHT ORDER: CONTINUE SWP LDB PONTR,I DST PONTR,I LDA PONTR CPA ADBUF JMP TRI2 CCA ADA PONTR STA PONTR RESTORE PREVIOUS OUTPUT BUFFER ADRESS WORD JMP TRI1 RE-BEGIN THE CLASSING OPERATION TRI2 ISZ PONTR LDA PONTR GET OUTPUT BUFFER ADRESS CPA LLSTD COMPARE TO LAST OUTPUT BUFFER ADRESS WORD JMP TRI,I CLASSING OPERATION IS FINISHED JMP TRI1 CONTINUE CLASSING OPEARTION END PRTSZ F   92903-18047 1805 S C0122 &PUTCA              H0101 ASMB HED S/P PUTCA (21MX ONLY) 15/10/75 P. SENANT NAM PUTCA,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18047 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT PUTCA * * THIS PROGRAM PUTS ONE BYTE IN A STRING * 21MX INSTRUCTIONS ARE USED * * DM1 DEC -1 * .BUFF NOP .CAR NOP CARACTERE A INTRODUIRE .N NOP NUM REL. DU CARAC. DS .BUFF * PUTCA NOP JSB .ENTR DEF .BUFF LDA .CAR,I ALF,ALF LDB .BUFF CLE,ELB ADB DM1 ADB .N,I SBT JMP PUTCA,I END   92903-18048 1805 S C0122 &RASC              H0101 qoASMB HED . "RASC" REAL --> ASCII TOM HIRATA 5/JUN/78 NAM RASC,7 . 92903-16001 REV.1805 780605 * * SOURCE 92903-18048 * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * EXT .FLUN,.CFER,.XPAK,IFIX,FLOAT,.ENTR ENT RASC SUP * ** ** THIS FORTRAN CALLABLE ROUTINE DOES THE CONVERSION FROM ** FLOATING POINT TO ASCII. ** CALLING SEQUENCE : ** CALL RASC(VAL,IBUF,ICH,NFLD,ID) ** VAL = FLOATING POINT NUMBER ** IBUF = BUFFER WHERE ASCII HAS TO BE STORED ** ICH = STARTING CHARACTER IN IBUF ** NFLD = FIELD LENGTH (W FIELD) ** ID = FRACTION LENGTH (D FIELD) ** (IF D = -1 : NO DECIMAL POINT IS PRINTED) ** THE CONVERSION IS DONE IN FW.D FORMAT. ** ** ** NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY WIM ROELANDTS (HP ** BRUSSELS, AUG'76). IN ORDER TO INCREASE THE ACCURACY OF ** THE CONVERSION FROM REAL TO ASCII, THE MAJORITY OF THE CODE ** WAS REPLACED BY THE FORMATTER CONVERSION ROUTINES OBTAINED ** FROM BILL GIBBONS, DATA SYSTEMS. THESE MODIFICATIONS WERE ** DONE BY TOM HIRATA (DATA SYSTEMS, JUN'78). * * ADX NOP BUF NOP ICH NOP W NOP D NOP RASC NOP JSB .ENTR DEF ADX * ** SET POINTER AND COUNTERS * LDA BUF MAKE POINTER CLE,ELA ADA ICH,I ADD OFFSET ADA MIN1 STA PIOB SAVE POINTER STA PIOB$ SAVE IT FOR ERROR RETURN. LDA W,I SET FIELD LENGTH SZA ZERO OR SSA NEGATIF ? JMP ERR YES, ERROR CMA,INA NEGA'TIF STA WS STA WS$ SAVE IT FOR ERROR RETURN. LDA D,I GET D LENGTH STA SAVED SAVE D LENGTH CMA SET TO -D-1 SSA,RSS POS ? SZA,RSS BUT NOT ZERO ? RSS JMP ERR YES, ERROR STA DS LDA MIN5 INIT CONSTANTS FOR FMTR STA TEMP7 ROUTINES. LDA ....2 STA TYPE STA LENTH CLA STA ALL9S CLEAR ALL 9'S FLAG & STA RNFLG ROUND-OFF FLAG. STA ZERO CLEAR ZERO FLAG. LDA MIN9 SET WHICH DIGIT STA DGCTR TO USE FOR ROUNDING OFF. STA SGCNT SIGNIFICANT DIGITS CTR. * ** TEST FOR ZERO * DLD ADX,I GET THE NUMBER SZA 1ST WORD ZERO? JMP CON0 NO, IT ISN'T ZERO. SZB,RSS 2ND WORD ZERO? ISZ ZERO YES, SET ZERO FLAG. * ** SET BLANK COUNTER * CON0 LDA DS MAKE : CMA ADA WS W-D-1 CMA STA BCNT AS INITIAL BLANK COUNTER * JSB OUTPT GO CONVERT THE REAL NO. WITH FMT ROUTINE. LDA EXPON SUBTRACT EXPONENT FROM THE BLANK STA SAVEX (SAVE IT) SSA COUNTER (BCNT) ONLY IF IT IS POSITIVE. JMP CON1 CMA,INA NEGATE IT ADA BCNT STA BCNT CON1 LDB BCNT LDA SIGN -1 IF NEGATIV STA SAVES SAVE THE SIGN. ADB A SSB NEG ? JMP BUCKS YES, FIELD OVERFLOW CMB,INB NEGATE IT STB BCNT SAVE NEG BLANK CTR * STB BCNTX SAVE THESE CONSTANTS FOR LDA WS THE ROUND-OFF ROUTINE. STA WSX SZB,RSS ANY BLANKS? JMP CON4 NO BLANKS, GO OUTPUT THE NUMBER. * CON5 LDA B40 GET A BLANK JSB STOCH SAVE IN OUTPUT BUFFER ISZ BCNT BUMP COUNTER JMP CON5 LOOP CON4 ISZ SIGN OUTPUT A MINUS ? JMP CON4A NO, CONTINUE LDA B55 YES, DO IT >U JSB STOCH CON4A LDB WS GET FIELD LENGTH LDA B56 GET PERIOD READY CPB DS EQUAL ? JMP CON7 YES, OUTPUT THE PERIOD JSB GETDG LDB RNFLG HAS THE ROUND-OFF SZB DIGIT BEEN REACHED YET? JMP CON4B YES, OUTPUT ONLY ZEROES. CPA ....9 IS IT A 9? RSS YES ISZ ALL9S NO, SET THE NO 9 FLAG. ISZ DGCTR INCREMENT THE ROUND-OFF CTR UNTIL JMP CON4C THE ROUND-OFF DIGIT IS REACHED. STA RNDSV THE ROUND-OFF DIGIT HAS BEEN REACHED, ISZ RNFLG SAVE IT & SET THE ROUND-OFF FLAG. LDA PIOB GET THE ROUND-OFF NO.'S ADDRESS STA PIOBX & SAVE IT. LDA WS ADJUST THE NEG FIELD CMA,INA WIDTH CTR TO IGNORE THE ADA WSX ZEROES THAT WILL STA WSX BE PUT OUT. CON4B CLA OUTPUT A ZERO. CON4C ADA B60 MAKE ASCII CON6 JSB STOCH AND STORE JMP CON4A * CON7 LDB EXPON NEG EXPONENT MEANS THE SSB,RSS NO. IS IN (0,1) JMP CON6 NO. IS NOT IN (0,1) JSB STOCH STORE DECIMAL PT. CON8 LDA B60 GET "0" READY JSB STOCH STORE THE "0" ISZ EXPON DONE? JMP CON8 NO, STORE ANOTHER "0" JMP CON4A YES, GO TO MAIN LOOP. BUCKS LDA B44 GET $ JSB STOCH TO OUTPUT BUFFER JMP BUCKS UNTIL IT IS FULL * ** ERROR SERVICE * ERR LDA A$$ STA BUF,I JMP RASC,I TERMINATE A$$ ASC 1,$$ * ERR$ LDA B44 GET $ LDB PIOB$ GET FIELD ADDRS. ERR$$ SBT STORE $ ISZ WS$ DONE? JMP ERR$$ NO. JMP RASC,I YES, EXIT RASC. * ** SUBROUTINES * * ** SUBROUTINE TO STORE A CHARACTER IN THE BUFFER * STOCH NOP LDB PIOB GET POINTER SBT STORE THE BYTE ISZ PIOB BUMP POINTER ISZ WS BUMP FIELD LENGTH COUNTER JMP STOCH,I AND RETURNۖ * LDA SAVED GET ORIGINAL D FIELD LENGTH. INA,SZA WAS IT -1? JMP STCH5 NO, CONTINUE TO ROUND-OFF ROUTINE. LDA ZERO GET ZERO FLAG. SZA ORIG NO. ZERO? JMP STCH3 YES,GO RETURN "0". CCA DETERMINE IF ORIG NO .GE. 1 ADA SAVEX BY TESTING ITS EXPON SSA,RSS FOR > 0? JMP STCH5 YES, GO TO ROUND-OFF RTN. ISZ SAVES ORIG NO POSITIVE? JMP STCH3 YES, GO RETURN "0". STB HOLDB NO, SAVE B-REG(ADDRS PTR) DLD ADX,I GET ORIG NO SZB,RSS 2ND WORD 0? JMP STCH1 YES, CHECK 1ST WORD. LDB HOLDB NO, RESTORE ADDRS TO B JMP STCH3 & GO STORE "0". STCH1 LDB HOLDB RESTORE ADDRS TO B. CPA B100K 1ST WORD=100000B? JMP STCH2 YES, RETURN "-1". JMP STCH3 NO, RETURN "0". STCH2 LDA B61 GET "1" READY. RSS STCH3 LDA B60 GET "0" READY. ADB MIN1 STORE "0" OR "1" INTO OUTPUT SBT BUFFER. CPA B60 WAS "0" STORED? JMP RASC,I YES, EXIT. ADB MIN2 NO, MUST BACK UP PTR LDA B55 & STORE MINUS SBT SIGN BEFORE JMP RASC,I EXITING. * STCH5 LDA RNFLG GET THE ROUND-OFF FLAG. SZA WAS ROUND-OFF NUMBER REACHED? JMP RND0 YES, ROUND-OFF VALUES ARE ALREADY SET. * STB PIOBX NO, SET UP VALUES SO THAT JSB GETDG ROUND-OFF WILL BE DONE STA RNDSV TO THE LAST DIGIT. RND0 LDA RNDSV GET THE ROUND-OFF DIGIT. ADA MIN5 DIGIT TO CHECK FOR ROUND-OFF. SSA EXIT IF IT IS < 5 OTHERWISE GO JMP RASC,I INTO THE ROUND-OFF ROUTINE. * LDA BCNTX SZA WAS THE BLANK COUNTER 0? JMP RND1 NO. LDA ALL9S YES. ERROR EXIT IF ALL DIGITS WERE SZA,RSS 9'S BECAUSE IT ISN'T POSSIBLE JMP ERR$ TO ROUND OFF. * RND1 CCB N BACK UP THE OUTPUT BYTE PTR. ADB PIOBX STB PIOBX ISZ WSX BUMP FIELD LENGTH COUNTER. RSS JMP ERR SOMETHING'S WRONG. LBT GET LAST BYTE(DIGIT). LDB PIOBX RESTORE B TO CORRECT ADDRESS. CPA B56 DECIMAL PT? JMP RND1 YES, SKIP IT. CPA B40 SPACE? JMP RND3 MUST INSERT A "1". CPA B55 MINUS SIGN? JMP RND3 MUST INSERT A "1". WRONG. INA ROUND DIGIT UP BY ADDING 1 TO IT. CPA B72 WAS IT A 9? JMP RND4 YES. RND2 SBT NO, STORE IT BACK & JMP RASC,I WE'RE DONE. * RND3 STA HOLDA SAVE THE CHARACTER. LDA B61 SBT STORE A "1" LDA MIN2 ADB A LDA HOLDA RESTORE THE CHARACTER & JMP RND2 GO STORE IT. * RND4 LDA B60 MAKE IT 0 & SBT STORE IT BACK. JMP RND1 GOT BACK 1 MORE DIGIT. * ** DATA * A EQU 0 B EQU 1 * PIOB NOP DS NOP BCNT NOP * * * B40 OCT 40 B44 OCT 44 B55 OCT 55 B56 OCT 56 B60 OCT 60 B61 OCT 61 B72 OCT 72 B100K OCT 100000 ALL9S BSS 1 FLG, WILL BE NON-ZERO IF ANY NON-9 ENCOUNTERED WSX BSS 1 HOLD FIELD WIDTH CTR FOR ROUND-OFF ROUTINE BCNTX BSS 1 HOLD BLANK CTR FOR ROUND-OFF ROUTINE RNFLG BSS 1 ROUND-OFF FLAG(1=ROUND-OFF MAY BE NECESSARY) RNDSV BSS 1 SAVE NINTH DIGIT FOR ROUND-OFF ROUTINE. DGCTR BSS 1 COUNTS NO. OF DIGITS PIOBX BSS 1 SAVES ADDRS+1 OF LAST SIGNIFICANT DIGIT. HOLDA BSS 1 TEMP HOLD OF A-REG. HOLDB BSS 1 TEMP HOLD OF B-REG. PIOB$ BSS 1 SAVES INITIAL FIELD PTR ADDRS FOR ERR$ WS$ BSS 1 SAVES INITIAL FIELD LENGTH FOR ERR$ ZERO BSS 1 =1 IF INPUT NO. IS ZERO. SAVED BSS 1 SAVES THE FRACTION LENGTH (D FIELD) SAVES BSS 1 SAVES SIGN OF ORIG NO. SAVEX BSS 1 SAVES THE EXPONENT RETURNED FROM OUTPT. WS BSS 1 FIELD WIDTH. * SPC 4 * CONSTANTS. * ....1 DEC 1 ....2 DEC 2 ....4 DEC 4 ....5 DEC 5 ....9 DEC 9 MIN9 DEC -9 MIN5 DEC -5 MIN4 DEC -4 MIN2 DEC -2 MIN1 DEC -1 * * ADDRESS CONSTANTS AND SHIFT INSTRUCTIONS. * AMANT DEF MANT MULTZ DEF MULT DIVDZ DEF DIVD RRR16 RRR 16 RRL16 RRL 16 * * TEMPS. * MULTA BSS 1 MULTB BSS 1 MULTC BSS 1 MULTD BSS 1 DIVDA EQU MULTA DIVDB EQU MULTB DIVDC EQU MULTC DIVDD EQU MULTD DIVDE BSS 1 DIVDF BSS 1 PTENA BSS 1 PTENB BSS 1 TEMP2 BSS 1 TEMP3 BSS 1 TEMP7 BSS 1 TEMP8 BSS 1 * * LOCALS. * TYPE BSS 1 TYPE. LENTH BSS 1 LENGTH. EXPON BSS 1 DECIMAL EXPONENT. MANT BSS 5 MANTISSA EXP BSS 1 BINARY EXPONENT. MANTP BSS 1 POINTER FWA USED MANTISSA. MANTL BSS 1 POINTER LWA USED MANTISSA RND BSS 1 ROUNDING DIGIT. SGCNT BSS 1 SIGNIFICANT DIGIT COUNT. SIGN BSS 1 SIGN * * ROUTINE TO EXECUTE SHIFT INSTRUCTIONS. * XEQ NOP NOP JMP XEQ,I SKP * NORML - MANTISSA NORMALIZATION. * THE MANTISSA AND EXPONENT ARE ADJUSTED SO THAT THEY * CONTAIN A NORMALIZED VALUE. IT IS ASSUMED THAT THE * INITIAL STATE IS NOT UNNORMLIZED BY MORE THAN 31 BITS. NORML NOP LDB MANT SEE IF NORMALIZED. LDA MANT+1 ASL 1 SOC JMP NORML,I YES, DONE. ASL 15 NO, SEE IF WORD SHIFT. SOC JMP NORM1 NO. SZB,RSS YES, IS SECOND WORD ZERO TOO ? JMP NORM2 YES, IS ZERO. STB MANT NO, DO WORD SHIFT. LDB MANT+2 STB MANT+1 LDB MANT+3 STB MANT+2 LDB MANT+4 STB MANT+3 LDA EXP ADJUST EXPONENT ADA =D-16 STA EXP NORM1 LDA MANT DETERMINE BIT SHIFT. JSB FLOAT B = 30 - 2*SHIFT BRS B = 15-SHIFT ADB =D-15 B = -SHIFT LDA B SAVE SHIFT COUNT CMA,INA,SZA,RSS A = SHIFT. IS IT ZERO ? JMP NORML,I YES, DONE. ADB EXP ADJUST EXPONENT. STB EXP IOR RRL16 SET UP SHIFT. STA XEQ+1 LDA MANT BIT NORMALIZE. LDB MANT+1 JSB XEQ STA MANT LDA MANT+1 LDB MANT+2 JSB XEQ STA MANT+1 LDA MANT+2 LDB MANT+3 JSB XEQ STA MANT+2 LDA MANT+3 CLB JSB XEQ STA MANT+3 JMP NORML,I EXIT. NORM2 STB EXP ZERO, SET EXPONENT ZERO TOO. JMP NORML,I SKP * PTEN - SCALE NUMBER BY A POWER OF TEN. * * PTEN MULTIPLIES THE VALUE IN (MANT...MANT2) AND (EXP) * BY 10**(A). NO CHECK IS MADE FOR OVERFLOW/UNDERFLOW. * * CALLING SEQUENCE: * LDA POWER * JSB PTEN SPC 2 PTEN NOP LDB AMANT SET UP MANTISSA POINTERS. STB MANTP LDB TYPE SZB CPB ....1 ADB ....2 IF TYPE<2, USE EXTRA WORD. ADB MIN1 # WORDS PRECISION TO USE - 1 ADB MANTP LWA USED MANTISSA STB MANTL SZA,RSS IF N=0, LEAVE ALONE. JMP PTEN,I SSA,RSS N>0 ? JMP PTEN1 YES. CMA,INA NO, TAKE IABS(N) STA PTENA LDA ....2 RIGHT SHIFT MANTISSA TWO BITS. JSB RSN LDB DIVDZ SET "DIVIDE" JMP PTEN2 PTEN1 LDB MULTZ SET "MULTIPLY" STA PTENA PTENA = IABS(N) PTEN2 STB PTENB PTENB = ADDR MULT OR DIVD PTEN3 LDA PTENA A=N ADA =D-6 N-6 CLE,SSA N<6 ? (E=0 FOR MULT) JMP PTEN4 YES, GO DO LAST ONE. STA PTENA NO, MULT/DIV BY 10**6 LDA PWR1A+10 LDB PWR1A+11 JSB PTENB,I JMP PTEN3 TRY AGAIN. PTEN4 ADA ....5 A = N-1 RAL,CLE,SLA N=0 ? JMP PTEN5 YES, GO NORMALIZE. ADA PWR10 GET POWER OF TEN. (E=0 FOR MULT.) DLD A,I JSB PTENB,I GO MPY DIV USING IT. PTEN5 LDB MANT NORMALIZE. ASL 1 SOC THERE ? JMP PTEN,I YES. JSB LSONE NO, LEFT SHIFT. JMP PTEN5 AND TRY AGAIN. SKP * POWER OF TEN TABLE. FIRST PART IS (10**I)/2 * FOR I=1,2,3. SECOND SECTION IS IDENTICAL TO 2-WORD * FLOATING EXCEPT THE SECOND WORD HAS BEEN RIGHT * SHIFTED ONE BIT. VALUES ARE 1O**I FOR I=1,6. SPC 2 PWR10 DEF PWR1A BASE ADDRESS. DEC 5 DEC 50 DEC 500 PWR1A DEC 20480,4 10**1 DEC 25600,7 10**2 DEC 32000,10 10**3 DEC 20000,14 10**4 DEC 25000,17 10**5 DEC 31250,20 10**6 SPC 3 * INDIG - ADD INPUT DIGITS TO NUMBER. * * INDIG TAKES 1-4 INPUT DIGITS AND COMBINES THEM WITH THE * RUNNING MANTISSA TO FORM A NEW MANTISSA. THE NEW * MANTISSA IS NOT NORMALIZED AND THE EXPONENT IS INCREASED * BY 16. * * CALLING SEQUENCE: * * * LDA <(10**I)/2, I = # DIGITS> * JSB INDIG SPC 2 INDIG NOP LDB =D-16 MAKE ROOM. CMB,CCE,INB B=16. JSB MULT LDB MANTL ADD DIGIT(S) ISZ MANTL LDA B,I CLE ADA TEMP2 STA B,I CCA,SEZ,RSS CARRY ? JMP INDIG,I NO, DONE. INDI1 ADB A PROPOGATE IT. ISZ B,I JMP INDIG,I JMP INDI1 SKP * GETDG - EXTRACT DIGITS FOR OUTPUT. * * GETDG EXTRACTS DIGITS FROM THE MANTISSA AND RETURNS THEM * FOR OUTPUT PURPOSES. ONLY (SGCNT) DIGITS WILL BE RETURNED, * ANY AFTER THAT ARE 0 OR 9 AS REQUIRED TO PRODUCE THE CORRECT * ROUNDING. LESS PRECISION IS USED AS DIGITS ARE GENERATED. SPC 2 GETDG NOP CLA LDB ZERO GET THE ZERO FLAG. SZB EXIT IF THE NO. OhIS ZERO. JMP GETDG,I LDA SGCNT TOO MANY DIGITS ? CLE,SSA,RSS JMP NOSIG YES, SEND ROUNDING DIGIT. ISZ TEMP7 ANY DIGITS LEFT ? JMP GETD1 YES, GET ONE. LDA =D5000 NO, GENERATE 4 MORE. JSB MULT ISZ MANTP THEY'RE IN THE NEXT WORD. LDA MIN4 STA TEMP7 GETD1 LDA TEMP7 A = - # DIGITS IN WORD. ADA GETDA GET POWER OF TEN FOR EXTRACTING DIGIT. STA TEMP8 LDA MANTP,I DIGITS. CLB DIV TEMP8,I A = NEW DIGIT, B = REST. STB MANTP,I ISZ SGCNT IS THIS FIRST AFTER LAST VALID DIGIT ? JMP GETDG,I NO. LDB ....9 YES. IF .GE. 5, RETURN NINES NOW. ADA MIN5 SSA CLB ELSE RETURN ZEROES. STB RND NOSIG LDA RND RETURN ROUNDING DIGIT (0 OR 9) JMP GETDG,I SPC 2 DEC 1000 DEC 100 DEC 10 DEC 1 GETDA DEF * SKP * RSN - RIGHT SHIFT MANTISSA BY N BITS, N IN [1,15]. * * RSN RIGHT SHIFTS THE MANTISSA BY (A) BITS AND * ADJUSTS THE EXPONENT ACCORDINGLY. BITS SHIFTED * OFF ARE LOST. ZERO BITS ARE SHIFTED IN. * * CALLING SEQUENCE: * LDA N A = SHIFT COUNT. * JSB RSN SPC 1 RSN NOP LDB A ADJUST EXPONENT. ADB EXP STB EXP IOR RRR16 SET UP SHIFT INSTRUCTION. STA XEQ+1 LDA MANT+2 SHIFT. LDB MANT+3 JSB XEQ STB MANT+3 LDA MANT+1 LDB MANT+2 JSB XEQ STB MANT+2 LDA MANT LDB MANT+1 JSB XEQ STB MANT+1 CLA LDB MANT JSB XEQ STB MANT JMP RSN,I EXIT SKP * LSONE - LEFT SHIFT MANTISSA ONE BIT. * * LSONE LEFT SHIFTS THE MANTISSA BY ONE BIT AND ADJUSTS * THE EXPONENT ACCORDINGLY. THE LAST BIT BECOMES ZERO. * * CALLING SEQUENCE: * * JSB LSONE SPC 1 ) LSONE NOP LDA MANT+3 SHIFT. CLE,ELA STA MANT+3 LDA MANT+2 ELA STA MANT+2 LDA MANT+1 ELA STA MANT+1 LDA MANT ELA STA MANT CCA ADJUST EXP ADA EXP STA EXP JMP LSONE,I SPC 4 * .XCOM - COMPLEMENT MANTISSA. SINCE WE HAVE MORE PRECISION * THAN WE NEED, IT IS ONLY A COMPLEMENT, NOT A NEGATE. SPC 2 .XCOM NOP LDA MANT COMPLEMENT MANTISSA. CMA STA MANT LDA MANT+1 CMA STA MANT+1 LDA MANT+2 CMA STA MANT+2 LDA MANT+3 CMA STA MANT+3 JMP .XCOM,I SKP * MULT - MULTIPLY THE MANTISSA BY A SCALAR. * * MULT MULTIPLIES THE MANTISSA BY A 15-BIT SCALAR AND ADJUSTS THE * EXPONENT. THE RESULT IS AS IF AN INTEGER MULTIPLY OF THE MANTISSA * AND SCALAR WERE DONE FOLLOWED BY A RIGHT SHIFT 15. THE RESULT * WILL NOT OVERFLOW BUT IT MAY BECOME UNNORMALIZED. * * CALLING SEQUENCE: * * CLE/CCE LAST WORD FLAG. * LDA SCALAR MULTIPLIER. * LDB N EXPONENT ADJUSTMENT. * JSB MULT * * WHERE E=1 INDICATES THAT THE LAST WORD OF THE CURRENT * MANTISSA IS ZERO. (INPUT CONVERSION). FOR THIS * CASE, THE EXPONENT ADJUSTMENT MUST NOT CARRY OUT. SPC 2 MULT NOP STA MULTA SAVE MULTIPLIER. RAL AND 2*MULTIPLIER. STA MULTD CME E=0 IFF INPUT ADB EXP ADJUST EXPONENT STB EXP LDB MANTL CURRENT WORD ADDR SEZ,RSS INPUT ? JMP MULT3 YES, SKIP FIRST MPY STB MULTB RAR RESTORE MULTIPLIER. MPY B,I ASL 1 JMP MULT2 MULT1 LDA MULTA MULTIPLIER. MPY B,I * CURRENT WORD. CLE,ELA ALIGN. ELB,CLE ADA MULTC,I ADD LOWER TO CURRENT + 1 STA MUILTC,I SEZ PROPOGATE CARRY. INB MULT2 LDA MULTB,I CORRECT FOR BIT 15. SSA ADB MULTD STB MULTB,I LDB MULTB SEE IF DONE. MULT3 CPB MANTP I.E., IS CURRENT WORD THE START ? JMP MULT,I YES, DONE. STB MULTC NO, UPDATE POINTERS. ADB MIN1 STB MULTB JMP MULT1 AND LOOP. SKP * DIVD - DIVIDE MANTISSA BY A SCALAR. * * DIVD DIVIDES THE MANTISSA BY A SCALAR AND ADJUSTS THE * EXPONENT ACCORDINGLY. THE EFFECT IS AS IF THE TWO WERE * INTEGERS AND THE DIVIDE WERE DONE, KEEPING 15 FRACTION * BITS, FOLLOWED BY A LEFT SHIFT 15. * OVERFLOW CAN OCCUR ONLY IF THE MANTISSA IS NORMALIZED * OR THE DIVISOR IS LESS THAN 2**14. * * CALLING SEQUENCE: * * LDA SCALAR 15-BIT DIVISOR. * LDB N EXPONENT ADJUSTMENT. * JSB DIVD SPC 4 DIVD NOP STA DIVDA SAVE DIVISOR. ARS SAVE DIVISOR/2. STA DIVDD CMB,INB CORRECT EXPONENT. ADB EXP STB EXP LDA MANTP SET UP POINTERS. STA DIVDB STA DIVDC LDB A,I B = FIRST WORD. CMA,INA -MANTP ADA MANTL MANTL-MANTP = # WDS - 1 CMA - # WDS STA DIVDE CLA BITS 15,14 FIRST WORD = 0 JMP DIVD2 DIVD1 ISZ DIVDB CLA SAVE BIT 15 (IN E). ELA,ELA CMB FORM REM - DIVISOR/2 ADB DIVDD CMB,CLE,SSB POS ? ADB DIVDD NO, RESTORE REM & SET E. CME SAVE BIT 14 (IN E). ERA,RAR DIVD2 STA DIVDF SAVE BITS 15,14. ISZ DIVDC LDA DIVDC,I A = NEXT WORD (LOW) DIV DIVDA DIVIDE. CLE,ERA SHIFT RIGHT, SAVE BIT 0 AS BIT 15. IOR DIVDF ADD PREV BITS 15,14. STA DIVDB,I ISZ DIVDE DONE ? JMP DIVD1 NO, LOOP. JMP DIVD,I YES, EXI9T. SKP * OUTPT - SCALE NUMBER FOR OUTPUT. * * OUTPT COPIES A VARIABLE TO BE NUMERICALLY OUTPUT, PUTTING * IT IN A STANDARD FORMAT (4 WORD MANTISSA, SEPARATE EXPONENT). * THEN IT MULTIPLIES OR DIVIDES THE NUMBER BY A POWER OF TEN * TO THAT IT IS IN [1000,10000). THE BINARY POINT IS PLACED * AFTER THE FIRST WORD SO THE FIRST 4 DIGITS ARE IN THAT WORD. * THE VALUE OF N S.T. (ORIGINAL #) * (10**(-N)) IS IN [.1,1) * IS STORED IN EXPON, I.E. NUMBER * 10**EXPON = ORIG NUMBER. * THE FOLLOWING APPROXIMATION IS USED: * * LOG10(X*(2**N)) = [((N*19729)/128)+((X*(2**15))*617)/(2**16)-290]/512 * * WHERE X IS IN [0.5,1). THE ERROR IS ALWAYS POSITIVE. SPC 2 * SET W & D, COPY NUMBER AND CONVERT IT. * OUTPT NOP JSB .CFER COPY 4 WORDS. DEF MANT DEF ADX,I LDA TYPE WHAT TYPE IS IT ? ADA MIN2 SSA,INA,RSS JMP OUTPB FLOATING. * * INTEGER. * SZA,RSS INTEGER. 1 OR 2-WORD. JMP OUTPC 2-WORD. LDA MANT 1-WORD. FLOAT IT. JSB FLOAT STA MANT SET UP AS IF 2-WORD FLOATING. STB MANT+1 CLA JMP OUTPB OUTPC STA MANT+2 2-WORD. FLOAT TO 3-WD FLOATING. LDA =D31 JSB .XPAK DEF MANT CLA,INA SET UP AS IF 3-WORD FLOATING. * * FLOATING. * OUTPB ADA AMANT FORM ADDR LAST WORD STA TEMP3 LDB A,I UNPACK THAT WORD. JSB .FLUN STB TEMP3,I STA EXP SKP * REMEMBER SIGN, TAKE ABS VALUE, CHECK FOR ZERO. * LDA MANT SET SIGN. SSA CCB,RSS CLB STB SIGN SZA,RSS ZERO ? JMP OUTPT,I YES, DON'T SCALE. SSA NEGATIVE ? JSB .XCOM YES, TAKE ABS VALUE. JSB NORML NORMALIZE. * * SCALE TO [1000,10000). * LDA EXP FORM N*19729 v(NLHMPY =D19729 ASR 7 (N*19729)/128 STA TEMP3 LDA MANT X*(2**15) MPY =D617 B = ((X*(2**15))*617)/(2**16) ADB TEMP3 + (N*19729)/128 ADB =D222 -290+512 ASR 9 B = FLOOR(LOG10(NUMBER))+1 STB EXPON = N. CMB,INB DIVIDE NUMBER BY 10**(N-4) ADB ....4 LDA B JSB PTEN LDA MANT GET INTEGER PART. LDB EXP RBL JSB IFIX ADA =D-1000 IS IT < 1000 ? SSA,RSS JMP OUTPA NO, O.K. LDA PWR1A YES, MULTIPLY BY TEN. LDB PWR1A+1 CLE SET NON-INPUT MODE. JSB MULT CCA DECREMENT EXPONENT. ADA EXPON STA EXPON OUTPA LDA EXP ADJUST EXP TO +15 ADA =D-15 CMA,INA JSB RSN LDA AMANT RESET TO HIGHER ACCURACY. ADA LENTH FOR DIGIT PRODUCTION. STA MANTL JMP OUTPT,I EXIT. END !-N  92903-18049 1805 S C0122 &RNUM              H0101 qFTN4 LOGICAL FUNCTION RNUM(IBUF,NCAR,NBCAR .,RESUT),. 92903-16001 REV.1805 780522 C C SOURCE 92903-18049 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* RNUM IS A LOGICAL FUNCTION USED TO CONVERT AN ASCII * C* BUFFER INTO A REAL NUMBER. CHECKS ARE PERFORMED AND FUNCTION * C* SUCCEEDS IF THE INPUT BUFFER IS NOT CORRECT . * C* * C* IF(RNUM(IBUF,NCAR,NBCAR,RESUT)) GO TO ERROR * C* * C* WHERE : * C* IBUF : INPUT BUFFER * C* NCAR : NUMBER OF THE FIRST CHARACTER TO USE IN * C* THE INPUT BUFFER (FIRST IS 1) * C* NBCAR : NUMBER OF CHARACTERS TO BE USED * C* RESUT : REAL VARIABLE WHERE REAL VALUE IS * C* RETURNED * C* * C********************************************************************* C C LOGICAL FLAGF,FLAGE,ISSPA,ISBTW,INUM DOUBLE PRECISION RESU C C FLAGF TO INDIC IF FIRST PART OF NUMBER ANALYZED C FLAGE " " IF SIGN ANALYZED C RNUM=.FALSE. RESU=0. IBL=0 IBL1=0 C C  BLANKS ONLY ? C IF(ISSPA(IBUF,NCAR,NBCAR)) GOTO 2 RETURN C C ANALYSE BUFFER C 2 CONTINUE FLAGF=.FALSE. FLAGE=.FALSE. NB2=NBCAR+NCAR-1 ISIGN=1 K=1 DO 1 I=NCAR,NB2 JNUM=-1 ICOM=IGET1(IBUF,I) IF(ICOM.NE.1H ) GO TO 6 IF(FLAGF) GO TO 35 IF(IBL.EQ.1) IBL1=1 GO TO 1 35 IBL=1 GO TO 1 6 IF(FLAGE) GOTO 7 FLAGE=.TRUE. IF(ICOM.EQ.1H+) GOTO 1 IF(ICOM.NE.1H-) GOTO 7 ISIGN=-1 GOTO 1 7 CONTINUE IF(.NOT.ISBTW(ICOM,1H0,1H9))JNUM=ICOM/256-60B IF(FLAGF) GOTO 10 IF(ICOM.EQ.1H.) GOTO 4 IF(ICOM.EQ.1HE) GOTO 30 IF(JNUM.EQ.-1) GO TO 50 IBL=1 RESU=RESU*10+JNUM GOTO 1 4 CONTINUE FLAGF=.TRUE. IF(IBL1.EQ.1) GO TO 50 IBL=0 GOTO 1 10 CONTINUE IF((JNUM.EQ.-1).AND.(ICOM.NE.1HE)) GO TO 50 IF(ICOM.EQ.1HE) GOTO 30 IF(IBL.EQ.1) GO TO 50 RESU=RESU+DBLE(FLOAT(JNUM))/(10.**K) K=K+1 GOTO 1 30 CONTINUE J=I+1 IJ=NB2-I IF(IJ.LE.0) GO TO 50 IF(INUM(IBUF,J,IJ,IRESU)) GO TO 50 C-----NORMALIZE BEFORE CHECKING EXPONENT. 40 IF(RESU.EQ.0) GO TO 49 IF(RESU.EQ.1.) GO TO 46 IF(RESU.GT.1.) GO TO 44 C-----MOVE DECIMAL PT TO RIGHT 42 IF(RESU.GE.1) GO TO 46 RESU=RESU*10. IRESU=IRESU-1 GO TO 42 C-----MOVE DECIMAL PT TO LEFT 44 IF((RESU.GE.1.).AND.(RESU.LT.10.)) GO TO 46 RESU=RESU/10. IRESU=IRESU+1 GO TO 44 C-----MANITSSA NORMALIZED TO DECIMAL FRACTION BETWEEN 1 & 10 46 IF(IRESU.NE.38) GO TO 48 IF(RESU.GT.1.) GO TO 50 GO TO 49 48 IF(IRESU.NE.-38) GO TO 49 IF(RESU.LT.1.) GO TO 50 49 IF((IRESU.LT.-38).OR.(IRESU.GT.38)) GO TO 50 IF(RESU.EQ.0) RESU=1 IF(IRESU.LT.0) GOTO 20 RESU=ISIGN*RESU*10.**IRESU GOTO 21 20 CONTINUE RESU=ISIGN*RESU/10.**(-IRESU) GOTO 21 1 CONTINUE 21 RESU=RESU*ISIGN RESUT=RESU RETURN C C ERROR RETURN C 50 RNUM=.TRUE. RETURN END END$   92903-18050 1805 S C0122 &SETBT              H0101 lASMB HED S/P SETBT (08/JUL/77) F. GAULLIER NAM SETBT,7 . 92903-16001 REV.1805 770708 * * SOURCE 92903-18050 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT SETBT * * SET OR CLEAR ONE BIT IN A WORD * I NOP WORD N NOP BIT # (MODULO 16) K NOP BIT VALUE (ODD OR EVEN) * SETBT NOP JSB .ENTR DEF I CCA,CLE LDB N,I CMB STB N SAVE MINUS BIT # (-17 TO -1) ELA SET UP MASK INTO A REG. ISZ N JMP *-2 AND I,I CLEAR BIT N STA N LDA K,I AND DEC1 CLE,RSS ELA ISZ 1 JMP *-2 IOR N STA I,I JMP SETBT,I * DEC1 DEC 1 END 6  92903-18051 1913 S C0122 &BITSR GPLB4 SUBROUTINE             H0101 FTN4 FUNCTION BITSR(IBUF,ISTBT,IENBT,NBIT),. 92903-16001 REV.1913 7808 .29 C C C ******************************************************************** C * * C * NAME: BITSR BITS SEARCH, STOP WHEN END OF TABLE IS FOUND * C * SOURCE: &BITSR 92903-18051 * C * BINARY: %BITSR ----NONE--- PART OF %GPLB4 92903-16001 * C * * C * PGMR: FRANCOIS GAULLIER * C * * C ******************************************************************** C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C THIS FUNCTION SEARCH INTO A BITS STRING FOR A GIVEN NUMBER C OF SUCCESIVE BITS VALUE EQUAL TO ZERO. C BITS ARE NUMBERED FROM 1 TO N, BIT 1 BEING THE BIT15 OF THE C FIRST WORD OF THE BUFFER, BIT 2 THE BIT14 OF 1ST WORD, BIT 16 C THE BIT0 OF 1ST WORD, BIT17 THE BIT15 OF 2ND WORD .. AND SO ON. C C ABREG = BITSR ( IBUF, ISTBIT, LSTBIT, NBIT ) C WHERE: C IBUF IS THE BUFFER C ISTBIT STARTING BIT BEING CHECKED C LSTBIT LAST BIT BEING CHECKED C NBIT NUMBER OF CONSECUTIVE BIT THAT C HAS TO BE CLEARED. C RETURN: C OK NOT NOW NEVER C C A REG. BIT # -1 -1 C B REG. 0    0 -1 C C C NOTE: C ------- C THIS SUBROUTINE USES THE SUBROUTINE: BITSH C C DIMENSION IBUF(1),IREG(2) INTEGER AREG,BREG EQUIVALENCE (ABREG,IREG(1),AREG),(IREG(2),BREG) C-----PRESET ERROR RETURN VALUE AREG=-1 BREG=-1 C-----CHECK IF ARGUMENT ARE OK IF ( NBIT .LE. 0 ) GOTO 900 IF ( ISTBT+NBIT-1 .GT. IENBT ) GOTO 900 C-----SEARCH IN THE TABLE ISTBIT=ISTBT 100 ABREG=BITSH(IBUF,ISTBIT,IENBT,NBIT) IF ( BREG .EQ. -1 ) GOTO 200 IF ( AREG .EQ. -1 ) GOTO 100 200 BREG=0 C-----RETURN THE VALUE 900 BITSR=ABREG RETURN END END$ v   92903-18052 1913 S C0122 &BITSH GPLB4 SUBROUTINE             H0101 FTN4 FUNCTION BITSH(IBUF,ISTBT,IENBT,NBIT),. 92903-16001 REV.1913 7808 .29 C C C ******************************************************************** C * * C * NAME: BITSH BITS SEARCH, STOP IF FIRST HOLE IS TOO SMALL * C * SOURCE: &BITSH 92903-18052 * C * BINARY: %BITSH ----NONE--- PART OF %GPLB4 92903-16001 * C * * C * PGMR: FRANCOIS GAULLIER * C * * C ******************************************************************** C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C THIS FUNCTION SEARCH INTO A BITS STRING FOR A GIVEN NUMBER C OF SUCCESIVE BITS VALUE EQUAL TO ZERO. C BITS ARE NUMBERED FROM 1 TO N, BIT 1 BEING THE BIT15 OF THE C FIRST WORD OF THE BUFFER, BIT 2 THE BIT14 OF 1ST WORD, BIT 16 C THE BIT0 OF 1ST WORD, BIT17 THE BIT15 OF 2ND WORD .. AND SO ON. C C ABREG = BITSH ( IBUF, ISTBIT, LSTBIT, NBIT ) C WHERE: C IBUF IS THE BUFFER C ISTBIT STARTING BIT BEING CHECKED C LSTBIT LAST BIT BEING CHECKED C NBIT NUMBER OF CONSECUTIVE BIT THAT C HAS TO BE CLEARED. C RETURN: C OK NOT FOUND TABLE FULL C C A REG. BIT # -1 -1 C B REG. 0 k   0 -1 C C N BITS = 0 HAVE < N BITS = 0 IS END OF TABLE HAVE C BEEN FOUND. FOUND. ISTBIT IS BEEN REACHED,NO BIT C SETUP AS A NEW WITH VALUE=0 HAVE C START BIT VALUE. BEEN FOUND. C BAD PARAM. VALUE ! C DIMENSION IBUF(1),IREG(2) INTEGER AREG,BREG LOGICAL ISBIT EQUIVALENCE (ABREG,IREG(1),AREG),(IREG(2),BREG) C-----PRESET ERROR RETURN VALUE AREG=-1 BREG=-1 C-----CHECK IF ARGUMENT ARE OK IF ( NBIT .LE. 0 ) GOTO 900 IE = IENBT-NBIT-ISTBT+2 IF ( IE .LE. 0 ) GOTO 900 C K=ISTBT-1 DO 150 I=1,IE NW=K/16 IF ( .NOT. ISBIT(IBUF(NW+1),15-(K-16*NW)) ) GOTO 180 150 K=K+1 C-----NOT FOUND BIT=0 SOON ENOUGH, ERROR RETURN GOTO 900 C-----BEGINING OF A HOLE IS FOUND, SET UP RETURN VALUE 180 BREG=0 AREG=K+1 IF ( NBIT .EQ. 1 ) GOTO 900 C-----VERIFY THAT THE HOLE IS BIG ENOUGH DO 200 I=1,NBIT-1 K=K+1 NW=K/16 IF ( ISBIT(IBUF(NW+1),15-(K-16*NW)) ) GOTO 300 200 CONTINUE C-----OK, THE HOLE IS BIG ENOUGH, RETURN GOOD NEWS GOTO 900 C-----THE HOLE IS TOO SMALL, RETURN A NEW START BIT 300 ISTBT=K+2 AREG=-1 C-----RETURN THE VALUE 900 BITSH=ABREG RETURN END END$   92903-18053 1913 S C0122 &BITST GPLB4 SUBROUTINE             H0101 FTN4 SUBROUTINE BITST(IBUF,ISTBT,NBIT,IVAL),. 92903-16001 REV.1913 78 .0829 C C C ******************************************************************** C * * C * NAME: BITST BIT SET ROUTINE * C * SOURCE: &BITST 92903-18053 * C * BINARY: %BITST ----NONE--- PART OF %GPLB4 92903-16001 * C * * C * PGMR: FRANCOIS GAULLIER * C * * C ******************************************************************** C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C THIS SUBROUTINE SET A BIT STRING TO 0 OR 1 AS SPECIFIED IN THE C CALLING SEQUENCE. C BITS ARE NUMBERED FROM 1 TO N, BIT 1 BEING THE BIT15 OF THE C FIRST WORD OF THE BUFFER, BIT 2 THE BIT14 OF 1ST WORD, BIT 16 C THE BIT0 OF 1ST WORD, BIT17 THE BIT15 OF 2ND WORD .. AND SO ON. C C CALL BITST ( IBUF, ISTBIT, NBIT, IVAL ) C WHERE: C IBUF IS THE BUFFER C ISTBIT STARTING BIT BEING SET C NBIT NUMBER OF CONSECUTIVE BIT THAT C WILL BE SET. C IVAL DEFINE THE VALUE THAT WILL BE USE TO SET C THE BITS. (ONLY BIT0 OF IVAL IS USED) DIMENSION IBUF(1) K=ISTBT-1 DO 100 I=1,NBIT NW=K/16 CALL SETBT(IBUF(NW+1),15-(K-16*NW),IVAL)z   100 K=K+1 RETURN END END$    92903-18054 1913 S C0122 &NRCLS GPLB4 SUBROUTINE             H0101 ASMB HED . NUMBER OF COMPLETED I/O IN A CLASS I/O QUEUE NAM NRCLS,7 . 92903-16001 REV.1913 781101 SPC 3 ********************************************************************** * * * NAME: NRCLS NUMBER OF RQ IN THE COMPL. QUEUE OF A CLASS * * SOURCE: XNRCLS 92903-18054 * * BINARY: ZNRCLS ----NONE--- PART OF %GPLB4 92903-16001 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT NRCLS EXT .ENTR,.DRCT,$CLAS SPC 1 A EQU 0 B EQU 1 SUP SKP .CLAS NOP NRCLS NOP JSB .ENTR DEF .CLAS SPC 1 JSB .DRCT GET DIRECT ADDR DEF $CLAS OF THE CLASS TABLE STA DCLAS * CCB NUMBER OF COMPLETED RQ LDA .CLAS,I GET CLASS I/O WORD AND B377 ISOLATE CLASS # ADA DCLAS INDEX INTO CLASS TABLE * NRCL2 XLA A,I GET CLASS HEADER/NEXT ELEMENT INB INCREMENT # OF PENDING RQ SZA,RSS CLASS NOT ALLOCATED ? JMP NRCL8 YES, RETURN 0 RQ PENDING SSA,RSS END OF LIST ? JMP NRCL2 NO, CONTINUE SPC 1 NRCL8 STB A EXIT WITH A=NUMBER OF PENDIND RQ JMP NRCLS,I SPC 2 DCLAS NOP B377 OCT   377 END o?   92903-18100 1913 S C0122 &TMSLB              H0101 ASMB NAM TMSLB,0 92903-16100 REV.1913 790130 SPC 3 ********************************************************************** * * * NAME: TMSLB TMS LIBRARY HEADER * * SOURCE: &TMSLB 92903-18100 * * BINARY: %TMSLB ----NONE--- HEADER OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 END %  92903-18102 1913 S C0522 &TMSYS              H0105 ASMB HED . T M S H E A R T NAM $MTMS,7 92903-16100 REV.1913 781215 SPC 3 ********************************************************************** * * * NAME: $MTMS HEART OF TMS * * SOURCE: &$MTMS 92903-18102 * * BINARY: %$MTMS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT $MTMS,.MGT0 EXT $TMSA,.EMAP,.EMIO,BITSR,BITST,ERR0 EXT .MGTG,.MGTR,#REQU EXT EXEC,LURQ,$CVT3,$LIBR,$LIBX EXT .ENTR,$TIME,IDGET,KLCLS,NRCLS,PNAME,RMPAR EXT DORMT,.UPIO,MESSS,.LURQ SPC 1 A EQU 0 B EQU 1 SUP SKP .PARA NOP PRG PARAMETERS ADDR PNX00 NOP DEFINE THE STARTING PROCESS PNXXX NOP DEFINE THE INITIAL PROCESS LUXXX NOP DEFINE THE LU FOR THE INITIAL PROCESS .TMLU NOP .TMTP NOP .TMSB NOP .TMPR NOP .TMSL NOP ADDR OF TMS LINK NAME .TMST NOP ADDR OF TMS TIMER NAME IMAGE NOP IMAGE PARAMETERS $MTMS NOP TMS ENTRY POINT. JSB .ENTR DEF .PARA SPC 2 * RETREIVE PROGRAM PARAMETER AND SAVE THEM *  TO INIT THE COMMON BLOCK # 0 SPC 1 LDB .PARA,I SAVE THE FIVE PARAMETERS JSB RMPAR INTO BUF TO SEND THEM INTO SAM DEF *+2 AS THE INITIAL CB0 DEF BUF * LDA BUF RECALL FIRST PARAM (LU) SZA,RSS DEFAULT LU IS 1 INA STA BUF STA LU SET CONSOLE LU SPC 1 IFZ JSB .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! EXT .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! XIF SPC 1 JSB EXEC SWAP THE WHOLE AREA DEF *+3 DEF D22 DEF D3 SWAP THE ENTIRE PARTITION SPC 1 JSB PNAME RETREIVE TMS-APPLICATION NAME DEF *+2 DEF APLNM SAVE NAME HERE LDB @APLN SEARCH LAST CHARAC. TO PUT THE ":" STA12 LBT GET BYTE CPA O40 IS IT SPACE ? RSS YES JMP STA12 NO, LOOP UNTIL SPACE LDA O72 ":" ADB DM1 BACKSPACE BYTE POINTER SBT AND STORE THE ":" LDA @APLN CMA,INA ADA B ADA @MSB1 ADD TO STARTING BYTE ADDR INA STA @MSBX SAVE BYTE POINTER LDA @APLN MOVE PROG NAME LDB @MSB1 INTO THE MESSAGE BUFFER MBT D6 SPC 2 * RETREIVE FWA AND LENGTH OF BUFFER AREA * TO INIT THE TMS MEMORY MANAGEMENT ROUTINE SPC 1 * LEAVE THAT FOR RTE-III M (MAY BE) !! * * EXT COR.A * XEQT EQU 1717B * AVMEM EQU 1751B * BGLWA EQU 1777B * * * LDA XEQT GET ID SEGMENT ADDR * JSB COR.A GET FWA * STA FWA * CMA,INA * LDB BGLWA GET BACKGROUND LWA * ADA AVMEM CHECK IF PROGRAM RUN FOR./BACK. PARTITION * SSA,RSS FOREGROUND ? * LDB AVMEM YES, USE FOREGROUND LWA * ADB DM1 YES, LOST TWO WORDS ! (MMGT PB) !! * LDA FWA B=LWA * CMA,INA * ADA B COMPUTE AVAILABLE MEMORY SIZE * STA LENA * JSB EXEC MEMORY SIZE REQUEST DEF *+5 DEF D26 REQUEST CODE DEF FWA FIRST WORD AVAILABLE DEF LENA # OF WORDS AVAILABLE DEF TEMP PARTITION LENGTH * JSB .MGTR FWA NOP FWA OF BUFFER LENA NOP # OF WORDS JMP .MGTG INITIALISE MEMORY MANAGEMENT SYSTEM * .MGT0 EQU * MEMORY MNGT SYSTEM IS READY. SPC 2 * CHECK ALL INTERACTIVE TERMINALS, UP THE * TERMINAL IF IT IS DOWN AND LOCK IT. SPC 1 LDB .TMLU SET UP TO CALL LURQ ADB DM1 TO LOCK ALL INTERACTIVE DEVICE STB STA33 SET # OF INTER. DEVICES ADDR. ADB D2 STB STA31 SET LU'S BUFFER STB STKLN SAVE LU'S ADDR. TO DO THE UPIO LDA STA33,I RECALL NUMBER OF LU'S CMA,INA AND STA #LU SET UP LU COUNTER * STA26 LDA STKLN,I GET LU JSB .UPIO TRY TO UP THE DEVICE IF DOWN JMP LULAB ERROR RETURN, ABORT TMS WITH ERROR # 1 ISZ STKLN BUMP LU ADDR. ISZ #LU BUMP LU COUNTER JMP STA26 AND LOOP UNTIL THE END * JSB LURQ LOCK ALL INTERCATIVE DEVICE DEF *+4 TO PROTECT PREVENT ANY OTHER DEF IOPTN LOCK/NO WAIT/NO ABORT STA31 NOP BUFFER CONTAINING LU'S STA33 NOP NUMBER OF LU'S HLT 10B ERROR RETURN SZA LOCK OK ? JMP LULAB NO, ABORT TMS WITH ERROR # 1 * LDA STA31,I RECALL FIRST INTERACTIVE LU JSB .LURQ TO GET THE LU-LOCK ID WORD STA RNLCK SAVE FUNNY WORD (LOCKER ID - RN #) SPC 2 * INITIATE LOGGING IF REQUIRED SPC 1 DLD LUXXX,I LOGGING REQUIRED SZB,RSS JMP STA40 NO LOGGING * STB LULOG SET LU OF LOG DEVICE * LDA LULOG UP THE DEVICE IF JSB .UPIO IS WAS DOWN JMP LOGAB CAN'T UP DEVICE !, ABORT TMS ATPPLICATION STA TEMP RETURN OK, SAVE EQT # LDA B GET EQT5 TO CHECK THE DVR TYPE AND LBYTE ISOLATE EQUIPEMENT TYPE CPA O114C DVR 23 ? JMP STA36 YES, OK LOGAB LDA D3 NO, PRINT ERROR MESS: "LOGG. DOWN OR LOCKED" JSB LOGER AND ABORT THE TMS APPLICATION * STA36 JSB LURQ LOCK THE DEVICE TO THAT PROGRAM DEF *+4 DEF IOPTN LOCK/NO WAIT/NO ABORT/ DEF LULOG LU DEF D1 NUMBER OF LU HLT 11B ERROR RETURN SZA LOCK OK ? JMP LOGAB NO, ABORT TMS * LDA TEMP RECALL EQT # CLB TO 'UNBUFFERED' THE LOG DEVICE DIV D10 SO THE COMPLETION OF THE WRITE ALF,ALF MEANS THAT THE PHYSICAL WRITE IS COMPLETE ADA B CONVERT EQT # INTO ASCII ADA =A00 TO BUILD THE COMMAND STA UNBMS+2 " EQ,XX,UN " JSB MESSS CALL THE SYSTEM PROCESSOR DEF *+3 TO UNBUF THE DEVICE DEF UNBMS DEF D10 * JSB OPLOG 'OPEN' THE LOGG DEVICE SPC 2 * CHECK THAT ALL PROGRAM ARE IN IDSEG SPC 1 STA40 LDA .TMSL TMS LINK JSB IDSG? LDA .TMST TMS TIMER JSB IDSG? * LDA .TMPR,I CHECK PROGRAM CONTAINING CMA,INA USER CODE (A = - # OF PRG) * STA43 STA TEMP ADA .TMPR,I COMPUTE INDEX INTO PRG TABLE MPY UPTEN UPT TABLE ENTRY LENGTH INA ADA .TMPR GO INTO PRG TABLE JSB IDSG? LDA TEMP RECALL INDEX INA,SZA END OF TABLE ? JMP STA43 NO, CONTINUE UNTIL END SPC 2 * ALLOCATE BIT TABLE, STACK TABLE AND ALL STACKS SPC 1 LDB .TMLU ADB DM3 LDA B,I GET EMA SIZE IN K WORDS STA TEMP SAVE IT CLB AND CALCULATE THE # OF WORDS PER ELEMENT DIV =D17 USING THE FOLLOWING FORMULA: ADA D2 # WORD/ELEM = 2 + EMA SIZE / 17 STA WPELE CLA,INA FIRST BIT # IN THE TABLE STA FSTBT LDA TEMP RECAL EMA SIZE IN K WORDS MPY D1024 DIV WPELE DIV BY # OF WORDS/ELEMENT ADA DM1 LAST ELEMENT MIGHT NOT BE TOTALLY IN STA LSTBT SETUP LAST BIT # IN THE TABLE CLB DIV D16 COMPUTE LENGTH OF THE TABLE ADA D2 IN WORDS, TO BE SECURE STA STA46 SETUP BIT TABLE LENGTH IN WORD * JSB .MGTG ALLOCATE THE BIT TABLE STA46 NOP LENGTH IN WORDS JMP .ER02 JMP .ER02 STA .BITB SETUP ADDR. OF THE BIT TABLE LDX STA46 AND CLEAR THE BIT TABLE ADA DM1 TO USE X REGISTER CLB SET ALL WORDS TO ZERO STA47 SBX A,I DSX JMP STA47 SPC 1 LDB .TMLU ALLOCATE STACK FOR EACH LU'S. LDA B,I GET STACK LENGTH STA STKLN ADB =D-2 LDA B,I GET TOTAL # OF LU STA #LU AND SAVE LOCALY SPC 1 JSB .MGTG ALLOCATE MEMORY FOR STACK TABLE #LU NOP TABLE LENGTH JMP .ER02 ERROR, NOT ENOUGH MEMORY JMP .ER02 ERROR, NOT ENOUGH MEMORY ADA DM1 OK, A=TABLE ADDR, DO -1 TO USE X REG STA .STKT INIT STACK TABLE ADDR. SPC 1 LDY #LU STAR4 JSB .MGTG ALLOCATE MEMORY FOR EACH STACK STKLN NOP STACK LENGTH .ER02 JSB ERRAB NOT ENOUGH MEMORY TO ALLOCATE JMP *-1 ALL STACKS: ERROR # 02 --> ABORT !!! SAY .STKT,I SAVE ADDR. OF STACK IN STACK TABLE LDB BIT15 SET IN FIRST WORD STB A,I STACK NOT ACTIVE ADA T4OFS CLEAR LINK WORD (TEMP4 IN THE STACK) CLB STB A,I DSY MORE LU ? JMP STAR4 YES, ALLOCATE AN OTHER STACK SPC 2 * ALLOCATE ALL NEEDED CLASS I/O SPC 1 JSB WRI/O SAVE PRG. SCHEDULE PARAM INTO CB0 (STKPT MUST=100001) LDA CLASS RECALL CLASS I/O WORD FOR CB0  IOR BIT13 SET "DO NOT DEALLOCATE CLASS" BIT STA CLAS0 AND SET CLASS I/O TO BE USED FOR CB0 CLA,INA RESET I/O BUF LENGTH STA WRI/L * CLA RESET CLASS WORD STA CLASS TO ALLOCATE A NEW CLASS FOR THE JSB WRI/O TMS-FMP CALL, LENGTH OF BUFFER IS ONE LDA CLASS TO INDICATE THAT THE DIRECTORY IS EMPTY IOR BIT13 SET "DO NOT DEALLOCATE CLASS" BIT STA FMPCL SET THE TMS-FMT CLASS I/O WORD * JSB GTCLW GET A CLASS I/O WORD STA MCLAS SET MAIN CLASS I/O JSB GTCLW GET A CLASS I/O WORD STA ICLAS INIT INTERNAL CLASS I/O JSB GTCLW GET ANOTHER CLASS I/O WORD STA CLASS INIT EXTERNAL CLASS I/O IOR =B40000 SAVE BUFFER CLASS STA CLASG SPC 2 * INITIATE ALL TMS-SYSTEM PROGRAM: TMSL/TMST/TMSIM SPC 1 LDA .TMSL SCHEDULE TMS LINK PRG. STA SCHFL SET SCHEDULE FLAG "WITH WAIT" JSB SCHUP HLT 11B PROGRAM MISSING !!! * LDA .TMST SCHEDULE TMS TIMER PRG. JSB SCHUP HLT 12B PROGRAM MISSING !!! SPC 2 LDA IMAGE,I GET THE NUMBER OF DATA-BASES SZA,RSS ANY DB DEFINED IN THIS APPLICATION ? JMP STAR6 NO, FORGET DB OPEN REQUEST CLB,INB YES, OPEN ALL THE DATA-BASES * STA53 STB TEMP SAVE DB # BLF,BLF ROTATE DB# INTO BITS 15-13 BLF,RBL CLA OPEN DATA BASE REQUEST JSB IMRQT SCHEDULE TMS-IMAGE-MODULE PROGRAM JMP STAR6 LAST DATA BASE HAS BEEN OPEN JMP STA58 RETURN OK CONTINUE STA55 DST BUF ERROR RETURN, SET IMAGE ERR# & RQ # .ER21 JSB ERRAB AND PROCESS IMAGE ERROR (NEVER COME BACK) SPC 1 STA58 LDB IMRQ2 DBOPEN IS SUCCESSFULL ADB D3 INIT THE DBOPEN TABLE LDA IMBF+1 SET THE INITIAL LOCKID WORD STA B,I AFTER PROG. NAME INB LDA .IMF4 MOVE THE CLASS I/O - DB CRC - INA MAX ITEM LN - MAX ENTRY LEN MVW D4 INTO THE DBOPEN TABL. * LDB TEMP RECALL DB# INB AND TRY TO OPEN THE NEXT DATA-BASE JMP STA53 SPC 2 * INTERNAL INITIALISATION PHASE IS COMPLETED: * =========================================== * * START UP PROCESSES, THE INITIAL & ALL * INTERCATIVE PROCESSES. SPC 1 STAR6 CCA SET ABORT TMS WHEN ERROR FLAG STA NOABT CLA SET SCHEDULE FLAG "NO-WAIT" STA SCHFL * LDA PNXXX,I GET NAME ADDR OF THE INITIAL-PROCESS SZA INITIAL-PROCESS ? JMP ISPRL YES, SET IT UP STAR8 JSB STIPR NO, START ALL INTERACTIVE PROCESSES SPC 1 JMP IDLE SPC 2 UPTEN DEC 5 UPT TABLE ENTRY LENGTH TUSEN DEC 5 TUS TABLE ENTRY LENGTH HED . CONSTANT, VARIABLE AND UTILITIES FOR THE START-UP PHASE IOPTN OCT 140001 LU LOCK/NO WAIT/NO ABORT O200 OCT 200 O72 OCT 72 O40 OCT 40 @APLN DBL APLNM O100 OCT 100 O377 OCT 377 O400 OCT 400 D26 DEC 26 LBYTE OCT 177400 O114C OCT 11400 BIT13 OCT 20000 D1024 DEC 1024 CLASG NOP UNBMS ASC 5, EQ,XX,UN UNBUFFERED THE LOG DEVICE SPC 2 IDSG? NOP STA IDSG3 SAVE PROGRAM NAME ADDR JSB IDGET CHECK IF IDSEG IS THERE DEF *+2 IDSG3 NOP PNAME SZA,RSS IDSEG HERE ? JMP IDSG6 NO, ERROR * JSB DORMT PROGRAM DORMANT ? DEF *+2 DEF IDSG3,I PROGRAM NAME ADDR. SSA DORMANT ? JMP IDSG?,I YES, RETURN * LDA IDSG3 NO, DO AN 'OF,PNAME,1' LDB .IDS8 TO MAKE IT DORMANT MVW D3 MOVE PROG. NAME INTO THE BUFFER JSB MESSS CALL SYSTEM PROCESSOR MESSAGE DEF *+3 DEF IDS8 MESSAGE BUFFER DEF D12 MESSAGE LENGTH JMP IDSG?,I AND RETURN * IDSG6 LDA IDSG3  NO, PUT PNAME IN MESSAGE LDB .MS04 MVW D3 LDA IDSG7 MVW =D4 LDA .MS0 JSB OUTM OUTPUT "TMS 00 PNAME MISSING" JMP ABT3 EXIT. * IDSG7 DEF *+1 ASC 4,MISSING .IDS8 DEF IDS8+2 IDS8 ASC 6, OF,XXXXXX,1 SPC 2 IMRQT NOP DST IMBF SET IMAGE RQ CODE & DB# - PID (LOCKIDW) LDA B ALF,RAR ROTATE AND ISOLATE DB# AND D7 STA DB# SAVE DB# INTO B REG ADA .DB INDEX IN DBOPEN TABEL LDA A,I STA IMRQ2 SAVE PRGRAM NAME ADDR. LDA DB# RECALL DB# CMA,INA AND VERIFY IF THE DATA BASE EXIST ADA IMAGE,I ADD TO MAX DB# SSA DATA BASE DEFINED ? JMP IMRQT,I NO, RETURN P+1 LDA IMRQ2,I RECALL 1ST WORD OF PRG NAME SZA PRG NAME DEFINED ? JMP IMRQ1 YES, CONTINUE LDA IMBF NO, RECALL RQ CODE SZA OPEN REQUEST JMP IMRQT,I NO, RETURN P+1 (DB UNDEFINED) IMRQ1 JSB DBNAD RETREIVE DB NAME ADDR FROM DB# LDB .IMF4 MOVE THE DB OPEN INFORMATION MVW D9 INTO THE BUFFER THAT WILL BE SEND TO LDB IMRQ2 THE TMS-IMAGE MODULE, SAVE PROGRAM MVW D3 NAME INTO THE DBOPEN TABLE ISZ IMRQT RETURN ADDR WILL BE P+2 OR P+3 * JSB EXEC SCHEDULE TMS-IMAGE-MODULE DEF *+10 DEF NAB23 QUEUE SCHEDULE WITH WAIT & NO-ABORT IMRQ2 NOP PROGRAM NAME DEF LU 1ST PARAM DEF * DEF * DEF * DEF * DEF IMBF STRING PASSING BUFFER DEF D13 STRING LENGTH JMP IMRQ5 ERROR RETURN (PROGRAM NOT PRESENT) JSB RMPAR RETURN OK, GET PARAMATER BACK DEF *+2 .IMF4 DEF IMBF+4 DLD IMBF+4 SZA,RSS IMAGE REQUEST OK ? JMP IMRQT,I YES, RETURN P+2 IMRQ4 LDB IMBF NO, RECALL IMAGE RQ CODE ISZ IMRQT AND RETURN P+3 JMP IMRQT,I * IMRQ5 CLA,INA a PROGRAM NOT LOADED = ERROR # 1 JMP IMRQ4 SPC 2 DBNAD NOP RETEIVE THE DB NAME ADDR. FROM THE DB# LDA DB# RECALL DB# ADA DM1 INDEX INTO THE DATA BASE DEFINITION TABLE MPY D12 TO RETEIVE DATA BASE CHARACTERISTICS. INA SKIP THE DB COUNT ADA IMAGE INDEX IN THE DEFINITION TABLE. JMP DBNAD,I SPC 2 * DBOPEN DATA BASE * * FORMAT: * ------- * * 4 ENTRIES (ONE FOR EACH POSSIBLE DATA BASE) * 8 WORDS PER ENTRY * * 3 WORDS - TMS-IMAGE-MODULE NAME * 1 WORD - INITIAL LOCKIDWORD ( DB# / PID ) * BIT 15-13 / 12-0 * 1 WORD - CLASS I/O (USED TO SEND RQ TO TMS-IMAGE-MOD.) * 1 WORD - DATA BASE CRC * 1 WORD - MAXIMUM ITEM LENGTH IN WORDS * 1 WORD - MAXIMUM ENTRY LENGTH IN WORDS SPC 2 DB# NOP HOLD THE DATA BASE NUMBER * .DB DEF * DEF .DB1 DEF .DB1+8 DEF .DB1+16 DEF .DB1+24 * .DB1 EQU * REP 32 DEC 0 SPC 2 IMBF BSS 13 BUFFER SEND TO TMS-IMAGE-MODULE D13 DEC 13 SPC 2 OPLOG NOP 'OPEN' THE LOGG DEVICE ISZ REEL# BUMP MAG-TAPE REEL NUMBER * OPLO2 JSB .OPLO+1 CHECK IF DEVICE OK JSB LOGER DEVICE IS NOT OK, REPORT ERROR LDA DM120 WAIT FOR 30 SECONDS LDB .OPLO BUT CHECK EVERY 250 MS JSB WAIT JMP OPLO2 RE-ISSUE THE ERROR MESSAGE SPC 1 .OPLO DEF *+1 NOP LDA LULOG CHECK THAT THE DEVICE IS READY AND OK IOR O400 SET 'REWIND' FUNCTION CODE STA TEMP IOR O200 SET 'DYNAMIC STATUS' FUNCTION CODE STA TEMP1 * JSB EXEC DO A DYNAMIC STATUS DEF *+3 TO CHECK THAT THE DEVICE IS ON LINE DEF D3 DEF TEMP1 SLA DEVICE ON LINE ? JMP OPLO6 NO, REPORT ERROR * JSB EXEC DO THE REWIND !>DEF *+3 DEF D3 CONTROL RQ DEF TEMP * OPLO5 JSB EXEC DO THE DYNAMIC STATUS DEF *+3 DEF D3 CONTROL RQ DEF TEMP1 STA TEMP SAVE STATUS AND O100 ISOLATE TAPE AT LOAD POINT BIT SZA,RSS TAPE AT LOAD POINT ? JMP OPLO5 NO, WAIT UNTIL TAPE AT LOAD POINT LDA TEMP YES, RECALL STATUS AND O377 AND ISOLATE STATUS TO CHECK WRITE ENABLE ... CPA O100 STATUS OK ? JMP OPLO8 YES, WRITE TAPE HEADER AND EXIT * CLA,RSS REPORT "NO WRITE RING" ERROR OPLO6 CLA,INA REPORT "DEVICE OFF LINE" ERROR JMP .OPLO+1,I EXIT CHECK MODULE TO REPORT ERROR SPC 1 OPLO8 LDB OPLO4 INIT HEADER BUFFER LDA D16 STA B,I SET RECORD LENGTH INB STB OPLO9 SET ADDR. FOR TIME STAMP ADB D5 LEAVE ROOM FOR TIME STB OPLO9+1 SET ADDR. FOR YEAR INB LDA REEL# SET MAG-TAPE REEL NUMBER STA B,I INB LDA .LOGH MOVE HEADER INTO THE BUFFER MVW D8 * JSB EXEC GET TIME STAMP FROM THE SYSTEM DEF *+4 DEF D11 OPLO9 BSS 2 BUFFER ADDR * JSB EXEC WRITE ON THE MAG-TAPE DEF *+5 THE MAG-TAPE LOGGING HEADER DEF D2 WRITE DEF LULOG LU OPLO4 DEF BUF+10 BUFFER DEF D16 BUFFER LENGTH JMP OPLOG,I * REEL# DEC 0 LOGGING MAG-TAPE REEL NUMBER .LOGH DEF *+1 DO NOT MIX UP FOLLOWING WORDS ASC 5,TMS LOGG. APLNM BSS 3 D5 DEC 5 D16 DEC 16 DM120 DEC -120 SPC 2 CLLOG NOP 'CLOSE' THE LOGG DEVICE LDA LULOG RECALL LOGG LU ADA O100 WRITE AN EOF AND REWIND STANDBY STA TEMP ADA O400 STA TEMP1 JSB EXEC WRITE EOF DEF *+3 DEF D3 DEF TEMP JSB EXEC REWIND STANDBY DEF *+3 DEF D3 DEF TEMP1 JMP CLLOG,I SPC 2 STIPR NOP START ALL INTERACTIVE PROCESSES LDA STKPT SAVE STACK POINTER STA STIP4 CLA STA SCODE SUBROUTINE CODE=0 FOR START TMS STA SPR80 CLEAR CALL TO THIS ROUTINE (ONLY ONCE) STA STAR8 " " " " STA .PAR5+4 INIT DEFAULT LOCK ID WORD (INIT CB1(7)) * LDX DM1 LAX .TMLU,I GET # OF INTERACTIVE DEVICES CAX STIP2 LBX .STKT,I JSB INSTK INITIALIZE STACK JSB WRI/O START UP THE PROCESS DSX MORE INTERACTIVE DEVICES ? JMP STIP2 YES, CONTINUE LDA STIP4 NO, RESTORE STACK POINTER STA STKPT AND EXIT. JMP STIPR,I * STIP4 NOP .STKT NOP ADDR OF STACK TABLE ADDR - 1 (USAGE OF X) SPC 2 ILRQ STA TEMP NOP HLT 20B HED . T M S --- I D L E L O O P --- EXITZ JSB WRI/O QUEUE UP THIS PROCESS SPC 2 IDLE RSS FLAG TO SCAN/NOT SCAN THE EXT. EVENT WAIT QUEUE JMP IDLEZ LDB .EXTW,I SCAN THE EXTERNAL EVENT WAIT QUEUE SZB,RSS QUEUE EMPTY ? JMP IDLEZ YES, SUSPEND TMSYS ON THE CLASS I/O GET !! * LDB .EXTW NO, GET QUEUE HEAD IDLEQ STB EXTWP SAVE QUEUE POINTER LDB B,I GO AHEAD IN THE QUEUE SZB,RSS END OF QUEUE ? JMP IDLEY YES, SET IDLE LOOP TIMING ADB T3MOF NO, SET B=STACK POINTER LDA B,I A=S REG. LDA A,I A=SUBROUTINE ADDR JSB A,I TRY TO RESTART THE PROCESS LDB EXTWP,I GET NEXT ELEMENT OF THE QUEUE JMP IDLEQ AND LOOP UNTIL END. SPC 1 IDLEZ JSB EXEC CLASS I/O GET DEF *+7 DEF D21 DEF CLASG SAVE BUFFER .BUF DEF BUF DEF DM8 DEF STKPT GET BACK STACK ADDR DEF SCODE GET BACK SUBROUTINE CODE SSA HLT 22B STA TEMP SAVE STATUS OF THE LAST OPERATION SPC 2 LDA SCODE GET SUBROUTINE CODE `HFBSSA SPECIAL OPERATION FROM TMSB ? HLT 24B YES, PROCESS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ADA C.TAB NO, INDEX IN TABLE JMP A,I AND JMP TO RIGHT CODE SPC 2 * EXTERNAL EVENTS WAIT QUEUE PROCESS AND * IDLE LOOP TIMING. SPC 1 IDLEY CLA DO NOT SCAN THE EXT. EVENTS WAIT QUEUE STA IDLE IF WAITING ON THE IDLE LOOP TIMING LDA .DSTK GET DUMMY STACK ADDR STA STKPT TO SET STACK POINTER LDA PAUCD AND SIMULATE A PAUZ REQUEST STA SCODE FOR THAT DUMMY STACK. LDA =D100 PAUSE FOR 1.00 SECONDS STA .PAR1 JMP PAUS EXECUTE PAUSE CODE SPC 1 IDLEX LDA .RSS RETURN FORM THE TIMER, STA IDLE RESTORE THE SCANNING OF THE EXT. EVENT JMP IDLE WAIT QUEUE SPC 1 * DUMMY STACK USED FOR IDLE LOOP TIMING. SPC 1 .DSTK DEF *+1 DUMMY STACK ADDR (DO NOT MIX NEXT WORDS !!) * DEF *+13 DUMMY S REG. DEF *+11 DUMMY Q REG. EXTWP NOP QUEUE POINTER .EXTW DEF *+1 EXTERNAL EVENT WAIT QUEUE HEAD OCT 0 O40K OCT 40000 PAUCD DEC 12 BSS 5 TEMP1/TEMP4 ON THE STACK OCT 40002 VERY 1ST TMS SUB. # (SPECIAL WITH BIT14) OCT 0 RTN ADDR OF THE DUMMY STACK SPC 2 DEXTW NOP DEQUEUE FROM EXTERNAL EVENT WAIT QUEUE STB STKPT B MUST = STACK POINTER ADB T3OFS TO ACCESS THE LINK WORD LDA B,I GET NEXT LINK IN THE QUEUE STA EXTWP,I TO REPLACE THE CURRENT ENTRY CLA STA B,I CLEAR LINK WORD IN THE STACK JMP DEXTW,I SPC 2 IDL00 JSB RELBU RELEASE THE BUFFER CLASS AND FORGET oMH JMP IDLE (THOSE CALL NEVER RETURN TO TMLIB) SPC 1 IDL02 JSB RELBU RELEASE THE BUFFER CLASS AND IDL03 JSB SETST SAVE STATUS & TLOG INTO CB1 WORD 4&5 JMP EXIT4 AND RETURN TO 'TMLIB' SPC 1 IDL04 JSB RELBU RELEASE THE BUFFER CLASS AND IDL41 CLA RESET STATUS & TLOG IDL42 CLB JMP IDL03 SPC 1 IDL06 JSB RELBU RELEASE THE BUFFER CLASS AND JMP EXIT4 RETURN TO 'TMLIB' WITHOUT UPDATING STATUS. SPC 1 IDL08 LDA DM4 DELAY THAT REQUEST, WAIT FOR A MAXIMUM LDB .IDL8 1 SEC, BUT CHECK QUEUE LEN EVERY 250 MS JSB WAIT SUSPEND PROGAM IDL82 JSB #REQU TIME ELAPSED, DO THE REQUEUE NOW DEF *+3 DEF CLASS DEF CLASS SZA REQUE OK ? HLT 40B ERROR !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JMP IDLE * .IDL8 DEF *+1 NOP CHECK QUEUE LENGTH JSB NRCLS RETREIVE THE NUMBER OF COMPLETED DEF *+2 REQUESTED PENDING ON THAT I/O CLASS DEF CLASS COMPLETION QUEUE CPA D1 ONLY ONE ? JMP .IDL8+1,I YES, THE ONE TO BE REQUE JMP IDL82 NO, REQUE NOW TO GET OTHER PENDING RQ SPC 2 WAIT NOP SUSPEND ITSELF FOR SMALL PERIOD OF TIME STB WAITX SAVE ADDR. OF THE CHECK CONDITION ROUTINE SSA,RSS MAKE TIME COUNTER NEGATIVE CMA STA WAITY WAIT2 JSB WAITX,I CHECK FOR THE CONDITION JSB EXEC SUSPEND ITSELF DEF *+6 FOR .25 SEC. DEF D12 TIMED EXECUTION (INITIAL OFFSET) DEF D0 PROGRAM NAME (CALLING PROGRAM) DEF D1 RESOLUTION CODE (1/100 SEC.) DEF D0 EXECUTION MULT. (ONLY ONCE) DEF DM25 TIME (250 MS) ISZ WAITY CONDITION NOT MET YET, WAIT MORE ? JMP WAIT2 YES, WAIT LONGER JMP WAIT,I NO, RETURN TO CALLER * WAITX NOP WAITY NOP DM25 DEC -25 HED TMS RETURN TO USER PROGRAM (RETURN INTO 'TMLIB') EXIT3 CCA H SET REQUEUE FLAG STA RQU? AND RETURN TO TMLIB SPC 1 EXIT4 CCA STA SRFLG SET SEND MAIL-BOX FLAG DLD STKPT,I DST S SET S & Q REGISTER * INB LDA B,I STA RTRNA SET RETURN ADDR SPC 1 LDA Q,I RECALL TMS SUBROUTINE NUMBER CLE CLEAR BIT15 AND ELA,CLE,ELA SAVE BIT14 INTO E RAR,RAR SEZ SPECIAL RETURN ? JMP SEXIT YES, SPECIAL RETURN PROCESSING MPY TUSEN NO, RETURN TO TMLIB ADA .TMSB RETREIVE PRG NAME STA .EPAO INIT 'ENTRY POINT ADDR OF SUB' ADDR ADA DM1 TO GET PROGRAM NAME ADDR LDA A,I GET PROGRAM NAME ADDR STA PNADR SET IT TO THE SCHEDULE RQ LDB RTRNA GET RETURN ADDR SZB FIRST TIME ENTRY ? JMP EXIT6 NO, SKIP CALCULATION OF LOCAL SUB # ADA UPTEN YES, COMPUTE LOCAL SUB # ADA DM1 LDA A,I CMA,INA INA ADA .EPAO DIV TUSEN B IS ALREADY CLEARED CMA,INA MAKE IT NEGATIVE FOR THE FIRST ENTRY STA RTRNA SET RTN ADDR TO NEG. LOCAL SUB # SPC 1 EXIT6 LDA .EPAO,I GET 'ENTRY POINT ADDR OF SUB' STA EPAOS * LDA LEN00 SET CB0 LENGTH IF IT IS DEFINED LDB Q,I INSIDE THIS TMS SUBROUTINE SSB,RSS CB0 DEFINED ? CLA NO, CB0 LEN = 0 STA LEN0 YES, SET CB0 LEN * LDA STKPT ADA T1OFS MOVE FUNCTION PARAMETERS LDB .FPAR FROM THE STACK INTO THE BUFFER SEND MVW #FPAR TO TMLIB. (3 FUNCTION PARAMETERS) LDA Q GET ADDRESS IN THE STACK ADA QCBLA TO MOVE CB DEFINITION MVW D11 MOVE CB'S DEFINITION SPC 1 JSB SRCB SEND ALL NEEDED CB'S SPC 1 LDA RQU? RECALL REQU FLAG SZA,RSS REQU NEEDED ? JMP EXIT8 NO, CONTINUE * JSB #REQU YES, REQUEUE THE PENDING BUFFER L DEF *+3 FROM THE TMS EXTERNAL CLASS I/O DEF CLASS TO THE TMS INTERNAL CLASS I/O DEF ICLAS SZA REQUEUE OK ? HLT 25B !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CLA RESET THE REQUEUE FLAG STA RQU? SPC 2 EXIT8 LDA PNADR RECALL PROGRAM NAME ADDR JSB SCHUP SHEDULE PROGRAM (USER PARTITION) HLT 30B ERROR RETURN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SPC 1 CLA STA SRFLG SET RECEIVE MAIL-BOX FLAG * LDA ICLAS SWAP THE MAIN & THE INTERNAL LDB MCLAS CLASS I/O WORD STA MCLAS STB ICLAS * JSB MAILB SUSPEND TMSYS ON THE MAIN CLASS I/O DEF LCLAS TO WAIT THAT THE UPT RETURN TO TMSYS ABS PARLN WITH THE REQUEST ON THIS CLASS SPC 2 ************************************************************************** SPC 2 LDA ICLAS SWAP BACK THE MAIN & THE INTERNAL LDB MCLAS CLASS I/O WORD TO RESTORE THEM STA MCLAS STB ICLAS SPC 1 LDA SCOD. RESTORE SCODE STA SCODE CPA ABTFL ERROR IN TM-LIBRARY ? JMP TMLER YES, PROCESS IT SPC 1 LDB Q SAVE RETURN ADDRESS INB INTO THE STACK LDA RTRN. STA B,I LDA LCLAS GET LOCAL CLASS I/O SZA,RSS PROGRAM SUSPENDED ON CLASS I/O JMP SAV25 NO, CONTINUE * IOR BIT15 YES, SET BIT 15 TO DIFFERENTIATE FROM PNAME CPA PNADR,I FIRST TIME ? JMP SAV25 NO, CONTINUE STA TEMP YES, SAVE IT TEMPORARILY JSB IDGET RETREIVE ID SEG ADDR DEF *+2 DEF PNADR,I RETURN WITH A = IDSEG ADDR LDB A SET B = IDSEG ADDR LDA TEMP AND REPLACE PNAME WITH CLASS I/O WORD DST PNADR,I AND ID SEG ADDR IN PLACE OF PNAME SPC 1 SAV25 CCA SET 'NO ABORT FLAG' FALSE STA NOABT I.E.: ERRORS WILL ABORT TM SPC 1 P JSB SRCB SAVE CB'S DATA INTO THE EMA ARRAY SPC 1 SAV40 CLA SET 'MEMORY SUSPEND FLAG' STA MSUFL I.E.: PROCESS WILL BE SUSPENDED LDA SCODE RECALL SUBROUTINE CODE ADA I.TAB JMP A,I SPC 1 RQU? OCT 0 REQUEUE FLAG (NOT 0 IF REQUEUE IS NEEDED) SPC 3 * SPECIAL RETURN INSIDE TMSYS INSTEAD OF * RETURNING TO TMLIB. SPC 1 SEXIT ADA .SEXI INDEX INTO RETURN TABLE JMP A,I AND GO EXECUTE THE PROPER STATEMENT SPC 1 .SEXI DEF *+1,I SPECIAL RETURN TABLE DEF SPR80 0 RETURN FROM AN AUXILIARY PROCESS DEF .ER07 1 RETURN FROM AN INTERACTIVE PROCESS --> ERROR DEF IDLEX 2 IDLE LOOP TIMING RETURN SPC 2 .ER07 JSB ERRAB ERROR # 7: RETURN FROM AN INTERACTIVE PROCESS SPC 4 SRCB NOP CLA INIT THE NUMBER OF DEFINED CB'S STA #DFCB LDA Q GET POINTER TO CB'S DEFINITION ADA QCBLA INTO THE STACK LDX A,I GET CB1 LOCAL ADDR LDB STKPT SET UP LOGICAL CB ADDR ADB D2 POINTER INTO THE STACK STB PT * SRCB1 INA INCREMENT CB'S DEFINITION PT CPA S END OF STACK ? JMP SRCB,I YES, RETURN LDB A,I NO, GET CURRENT CB LENGTH RBL,CLE,ERB CLEAR BIT15, E=ENABLE/DESABLE FLAG SEZ CB ENABLED ? JMP SRCB8 NO, GOTO NEXT CB STA TEMP YES, SAVE A (CB DEFINI. PT) LDA PT,I GET LOGICAL CB ADDR. SZA,RSS ALLOCATED ? HLT 32B NO, ERROR !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB MAPCB MAP CB DATA, RETURN ADDR. OF CBX(1) DST SRCB6 SET ACTUAL CB ADDR & CURRENT CB LENGTH SPC 1 LDB PNADR GET SYSTEM COMMON/CLASS I/O FLAG ADB D3 IT IS BIT15 OF WORD FOLLOWING PNAME LDB B,I SSB,RSS SYSTEM COMMON BEING USED ? JMP SRCB5 NO, GO USE CLASS I/O * LDB SRFLG YES, CHECK SEND/RECEIVE FLAG SZB SEND ? JMP SRCB3 YES, MOVE FROM MEMORY TO COMMON CXA NO, MOVE FROM COMMON TO MEMORY LDB SRCB6 GET TO ADDR (INTO EMA ARRAY) JMP SRCB4 AND GO PERFORM THE MOVE SRCB3 CXB SEND, GET TO ADDR (SYSTEM COMMON) SRCB4 MVW SRCB6+1 MOVE DATA JMP SRCB7 AND CONTINUE FOR NEXT CB * SRCB5 JSB MAILB SEND/RECEIVE COMMON BLOCK DATA SRCB6 BSS 2 * SRCB7 LDA TEMP RESTORE CB'S DEFINITION POINTER SPC 1 SRCB8 INA BUMP CB'S DEFINITION PT ADX A,I MAINTAIN LOCAL CB ADDR. INTO X REG ISZ PT BUMP LOGICAL ADDR PT ISZ #DFCB BUMP NUMBER OF DEFINED CB'S JMP SRCB1 AND LOOP UNTIL END SPC 2 STKPA JSB STKP. STACK PARAM .ADDR. JMP IDLE AND EXIT * STKP. NOP SAVE ADDR OF THE 3 FUNCTION PARAMETERS LDA ..PA1 LDB STKPT INTO THE STACK ADB T1OFS MVW #FPAR JMP STKP.,I AND GO TO IDLE LOOP. * D7 DEC 7 D10 DEC 10 .FPAR DEF FPARM ..PA1 DEF .PAR1 NOABT NOP .EPAO NOP PNADR NOP PROGRAM NAME ADDRESS HED START-UP TMS PROCESSES START JSB RELBU DLD STKPT,I INIT S & Q REGISTERS DST S * ISZ B,I SET VERY 1ST TUS# FOR INTER. PROCESS CLA SET STOP-INHIBIT FLAG TO 0 ADB DM1 (TMS CAN BE STOPPED DURING A INTERACTIVE STA B,I PROCESS) * LDA PNX00 MOVE STARTING PROCESS NAME LDB ..PA1 IN PLACE OF PARAMETERS TO MVW D3 SIMULATE A TM SUBROUTINE CALL. JMP SPR88 SPC 4 * * RESTART THE PROCESS AFTER * A MEMORY SUSPEND OPERATION. SPC 1 MSU50 JSB RELBU DLD STKPT,I RESTART PROCESS DST S LDB ..PA1 RESTORE CALLING SEQUENCE MVW D10 AT THE TIME OF THE MEM. SUSP. LDA STKPT ADA T2OFS RETREIVE SUBROUTINE CODE OF LDA A,I SUSPENDED OPERATION STA SCOD2NE AND JMP SAV40 RESTART FROM THE SUSP. POINT SPC 3 T1OFS DEC 7 OFFSET FROM BEGINNING OF STACK TO TEMP1 T2OFS DEC 8 OFFSET FROM BEGINNING OF STACK TO TEMP2 T3OFS DEC 9 OFFSET FROM BEGINNING OF STACK TO TEMP3 T4OFS DEC 10 OFFSET FROM BEGINNING OF STACK TO TEMP4 T3MOF DEC -9 NEG. OFFSET FROM BEGINNING OF STACK TO TEMP3 NSOFS DEC 11 OFFSET FROM BEGINNING OF STACK TO STP-INHIBIT HED WRITE/READ AND LOGGING REQUEST WRRQ JSB RELBU RELEASE OUTPUT BUFFER LDA STKPT RECALL STACK POINTER ADA T2OFS RETREIVE FUNCTION PARAMATERS STA WRRQ3 SET READ BUFFER LENGTH INA TO GET USER SUPPLIED CTL BIT LDB A,I GET USER SUPPLIED CTL BIT LDA STKPT ADA D2 LDA A,I GET CB1 LOGICAL ADDR JSB GCBAD MAP THE FIRST 1025 WORDS INA TO GET CTL BIT FROM CB1 SZB,RSS USER SUPPLY THE CTL BIT ? LDB A,I NO, GET THE STANDARD ONE SWP YES, KEEP IT AND EXCHANGE A & B AND =B177400 ISOLATE CTL BITS RAR,RAR POSITION CTL BIT ADB DM1 TO RETREIVE LU IOR B,I MERGE WITH LU STA TEMP SAVE CONTROL WORD JSB EXEC DO THE READ REQUEST DEF *+10 DEF D17 READ REQUEST DEF TEMP LU DEF * BUFFER ADDR. WRRQ3 NOP BUFFER LENGTH DEF STKPT 1ST PARAM (STACK POINTER) DEF D1 2ND PARAM (SCODE FOR READ RQ) DEF CLASS CLASS I/O WORD DEF * PLACE HOLDER DEF RNLCK BYPASS THE LU-LOCK CHECK JMP IDLE RETURN SPC 1 D17 DEC 17 SPC 2 LOGRT LDA TEMP RECALL HARDWARE STATUS OF THE LOGGING WRITE AND O40 IS IT END OF SZA,RSS THE LOGGING TAPE ? JMP IDL02 NO, IT IS OK, RELEASE BUF. AND RETURN TO 'TMLIB' * JSB CLLOG YES, BUT LAST WRITE IS OK, CLOSE THE LOGG LDA D2 REPORT "END OF TAPE" ERROR JSB LOGER JSB OPLOG 'OPEN' THE NEW LOGG TAPE JMP IDL02 RELEASE THE BUF. & RETURN TO 'TMLIB' HED IMAGE REQUEST IMULK LDX #LU BEFORE UNLCK, CHECK IF LOCKID IS USED ! SPC 1 IMUL2 LBX .STKT,I B=STACK POINTER LDA B,I GET S VALUE SSA STACK ACTIVE ? JMP IMUL7 NO, FORGET IT ADB D2 ADDR. OF ACTUAL CB1 ADDR LDA B,I RETREIVE CB1 ADDR. (0 IF NOT ALLOCATED) ADB DM2 RESTORE B=STACK POINTER JSB GCBAD MAP 1025 FIRST WORDS OF CB & RETURN ADDR. SWP SWAP A & B REG. ADB D11 ADDR. OF CB1(12) (LOCK ID WORD) ADA T2OFS PRESET A TO GET LOCKID FROM STACK AT TEMP2 CPB D11 CB1 ALLOCATED ? LDB A NO, THEN THE LOCKID IS STILL ON STACK ADA D2 PRESET A TO EXAMINE THE WAITING QUEUE JMP IMUL5 AND GO CHECK THIS LOCK ID WORD * IMUL4 LDA A,I GO DOWN IN THE WAITING QUEUE SZA,RSS END OF WAITING QUEUE ? JMP IMUL7 YES, GO TO NEXT STACK LDB A NO, RETREIVE THE LOCK ID FROM ADB D9 THE WAITING BLOCK IN MEMORY IMUL5 JSB .IMU2,I CHECK THIS LOCKID, B=ADDR. OF LOCKID JMP IMUL4 CONTINUE UNTIL END OF WAITING QUEUE * IMUL7 DSX GO TO NEXT STACK JMP IMUL2 UNTIL END OF TABLE JMP .IMU4,I ALL STACK HAVE BEEN CHECKED, EXIT SPC 2 .IMU4 DEF *+1 AND THIS LOCKID IS NO LONGER USED JSB RELBU RELEASE THE BUFFER LDB BUF RECALL THE LOCKID WORD TO JSB IMULO RELEASE ALL RECORDS LOCK TO THIS ID JMP IDLE RETURN OK JMP STA55 ERROR RETURN, ABORT TMS APPLICATION ! SPC 2 IMULO NOP ROUTINE TO PERFORM THE UNLOCK REQUEST LDA D8 IMAGE RQ=8 FOR UNLOCK REQUEST JSB IMRQT SCHEDULE TMS-IMAGE-MODULE PROGRAM HLT 40B IMAGE NOT THERE JMP IMULO,I RETURN OK ISZ IMULO GO PROCEISS FATAL IMAGE ERROR. JMP IMULO,I SPC 2 .IMU2 DEF *+1 SUBROUTINE ENTRY POINT ADDR NOP SUBROUTINE ENTRY POINT LDB B,I GET THE LOCK ID WORD CPB BUF IS IT USED ? JMP IDL08 YES, DELAY THE UNLOCK REQUEST JMP .IMU2+1,I NO, CONTINUE THE SEARCHING * D8 DEC 8 SPC 3 * IMAGE REQUEST: * IF NOT DBOPN REQUEST, STACK PARAMETER AND RETURN * * IF DBPON, RE-INIT CB1[6:13] AND RETURN * DIRECTLY TO 'TMLIB'. SPC 1 IMGRQ LDA .PAR1+14 RECALL IMAGE RQ SZA DBOPN RQ ? JMP STKPA NO, STACK PARAM. AND EXIT * CLB,INB YES, MAP THE CB1 JSB COM.U STA TEMP SAVE CB1 ACTUAL ADDR ADA D13 SAVE ALSO ADDR OF CB1(14) WHERE STA TEMP1 THE IMAGE STATUS SHOULD BE RETURNED * LDA IMAGE,I GET THE NUMBER OF DATA BASES SZA,RSS ANY DB DEFINED IN THIS APPLICATION ? JMP IMG30 NO, RETURN ERROR # 398 CMA,INA STA TEMP2 IMAGE DB COUNTER CLA,INA STA DB# INIT DB# * IMG12 JSB DBNAD RETRIEVE THE DB NAME ADDR FROM THE DB# LDB ..PA7 ADDR OF DB NAME FROM USER CMW D3 DB NAME COMPARE ? JMP IMG20 YES, NOP ISZ DB# NO, CHECK THE NEXT DATA-BASE ISZ TEMP2 ANY DATA-BASE LEFT ? JMP IMG12 YES, CHECK IF IT IS THIS ONE IMG30 LDA =D398 NO, RETURN ERROR # 398 TO THE USER IMG33 STA TEMP1,I JSB STKP. STACK PARAMETER JMP EXIT4 AND RETURN TO 'TMLIB' IMMEDIATLY SPC 1 IMG20 CLA DBOPN SUCCED, RETURN GOOD IMAGE STATUS STA TEMP1,I TO THE USER ISZ TEMP1 STA TEMP1,I RETURN ACCESS LEVEL ISZ TEMP1 STA TEMP1,I RETURN RUN TABLE SIZE ISZ TEMP1 TO RETURN DB-CRC LDA DB# RECALL DB# TO INDEX INTO THE DBOPEN TABLE JSB ICB1I INIT CB1 FOR IMAGE ADA DM5 SET AD:DR OF INITIAL LOCKID WORD MVW D1 STORE INITIAL LOCK ID WORD INA SET ADDR OF DB-CRC LDA A,I GET DB-CRC TO RETURN IT INTO JMP IMG33 IMGAGE STATUS WORD 4, RETURN SPC 1 ICB1I NOP INIT CB1 FOR IMAGE. ADA .DB RETREIVE TMS-IMAGE-MODULE NAME, LDA A,I CLASS I/O, MAX ITM LN & MAX ENT LN. LDB TEMP CB1(1) ADDR ADB D5 CB1(6) ADDR MVW D3 MOVE TMS-IMAGE-MODULE PROG. NAME INA SKIP LOCKID MVW D1 STORE CLASS I/O INA SKIP DB CRC MVW D2 MOVE MAX ITM & MAX ENT LENGTH JMP ICB1I,I SPC 1 ..PA7 DEF .PAR1+6 DM5 DEC -5 SPC 3 * RESTART THE PROCESS AFTER * AN IMAGE REQUEST SPC 1 IMRTN LDA BUF RECALL IMAGE ERROR CODE SZA,RSS FATAL ERROR ? JMP EXIT3 NO, SET REQUEUE FLAG AND RETURN TO USER * JSB RELBU YES, FATAL ERROR, RELEASE BUFFER CLB,INB MAP CB1 TO GET THE LOCKID WORD JSB COM.U AND THEN RETREIVE THE DB# ADA D11 LDA A,I A=LOCKID WORD ALF,RAR ISOLATE DB# AND D7 STA DB# JMP .ER21 AND ABORT TMS. HED COMMON-BLOCK ENABLE/DISABLE PROCESS CBENB LDA .PAR1 SET UP MEMORY SUSP. FLAG STA MSUFL AS REQUESTED BY THE USER LDA ..PA2 JSB MEMOK CHECK THAT THERE IS ENOUGH MEMORY LDA ..PA2 OK, PERFORM THE FUNCTION STA TEMP1 * CBEN3 LDA TEMP1,I GET PARAMETER SZA,RSS PARAMETER DEFINED ? JMP EXITZ NO, RETURN TO THE OTHER PROG. JSB GECB# YES, GET CB # JSB COM.E ENABLE & ALLOCATE THIS CB HLT 43B MEMORY SUSPEND RETURN SZA,RSS ALLOCATED DONE ? .ER05 JSB ERRAB NO, LOCAL CB LENGTH =0 ---> ABORT TMS ISZ TEMP1 GET NEXT PARAMETER JMP CBEN3 SPC 1 CBDES LDA ..PA1 STA TEMP1 * CBDE3 LDA TEMP1,I GET PARAMETER SZ_MA,RSS PARAMETER DEFINED ? JMP CBDE5 NO, RETURN MEMORY AND EXIT JSB GECB# YES, GET CB # JSB COM.D DISABLE CB ISZ TEMP1 GET NEXT PARAMETER JMP CBDE3 * CBDE5 JSB CLECO RETURN FREE MEMORY TO MMGT JMP EXITZ EXIT SPC 1 CBLEN LDA .PAR1 CHANGE CB LENGTH JSB GECB# RETREIVE CB # JSB COM.U INIT A,B & Y STA TEMP1 SAVE CB ACTUAL ADDR LDB LCBLP,I RECALL LOCAL CB LENGTH LDA .PAR2 GET NEW LENGTH SSA NEW LENGTH OK ? .ER20 JSB ERRAB NO, IRRECOVERABLE ERROR, ABORT TMS SZA,RSS OK ? JMP .ER20 NO CBLE3 CMB MAKE - LOC. LENGTH - 1 ADB A NEW LEN - LOC. LEN - 1 SSB,RSS NEW MUST BE = < LOCAL LEN IN ANY CASE ! JMP .ER20 NEW LENGTH IS TOO BIG, ERROR LDB TEMP1 RECALL ACTUAL CB ADDR. SZB ENABLE OR 1ST TIME THROUGH ? JMP CBLE5 YES, CHECK FOR LENGTH WHEN ALLOCATED LDB CCBLP,I NO, RECALL CURRENT LEN TO GET ENABLE RBL,CLE,ERB MOVE ENABLE FLAG INTO E RAL,ERA AND SET ENABLE FLAG WITH NEW CURRENT LENGTH STA CCBLP,I STORE BACK NEW CURRENT CB LENGTH JMP EXIT4 AND RETURN. * CBLE5 ADB DM1 CHECK NEW LEN MUST BE = < LEN WHEN ALLOCATED LDB B,I RECALL LENGTH WHEN ALLOCATED CLA CLEAR 1ST TIME THROUGH STA TEMP1 LDA .PAR2 RESTORE A WITH NEW LENGTH JMP CBLE3 AND CHECK THAT IS CORRECT HED TM SUBROUTINE CALL/EXIT PROCESS SBCAL LDB STKPT CHECK FOR STACK OVERFLOW CMB,INB ADB S ADB =D25 (ALWAYS 10 EXTRA FREE WORDS ON STACK) CMB,INB ADB STKLN SSB STACK OVERFLOW ? .ER12 JSB ERRAB YES, ERROR ALWAYS ABORT !! DLD S NO, RECALL S & Q CMB,INB TO STACK THE NEW CALL ADB A COMPUTE 'DELTA Q' CMB (-X-1) ROOM FOR DELTA Q STB A,I * SAVE MINUS DELTA Q IN THE STACK INA STA TEMP SAVE NEW Q REGISTER VALUE SPC 1 LDB ..PA1 RECALL TM-SUBROUTINE NAME/# ADDR JSB GTSU# GET TM-SUB # (A=TMSUB # ON EXIT) JMP SBCER ERROR RETURN (A = ERR#) STA TEMP,I SAVE TUS # INTO THE STACK LDA TEMP A=NEW Q CLB CLEAR THE STACK LDX QCBLA USE X REG AS COUNTER TO CLEAR THE STACK SBCA4 INA BUMP STACK PT STB A,I CLEAR /RTN ADDR/CB1 LOC ADDR./ DSX JMP SBCA4 LOOP UNTIL END INA SKIP ONE EXTRA WORD TO HAVE S NEW VALUE LDB TEMP GET NEW Q VALUE DST STKPT,I SAVE NEW S & Q REGISTER JMP EXITZ JMP EXIT4 = DO NOT LEAVE THIS PROCESS SPC 1 SBCER LDB D10 NO ABORT PROCESSING STB SCODE SET RETURN SUBROUTINE CODE CMA,INA SET STATUS WITH NEG. ERROR CODE JMP SBRT3 AND EXIT WITH TM-SUB RETURN CODE SPC 2 SBRTN JSB DSTAK AJUST THE STACK JSB CLECO DE-ALLOCATE ALL NECESSARY CB CLA SET STATUS TO OK SBRT3 CLB CLEAR TLOG AND JSB SETST STORE STAT. & TLOG IN CB1 WORD 4 & 5 JMP EXITZ JMP EXIT4 = DO NOT LEAVE THIS PROCESS SPC 3 GTSU# NOP GET TMS-SUB # (B=ADDR OF NAME/#) LDA B,I CHECK FOR THE "NO ABORT" BIT RAL,CLE,SLA,ERA CLEAR AND CHECK BIT 15 STA NOABT SET NOABT FLAG, IF NECESSARY STA B,I AND STORE BACK THE FIRST PARAMETER ADA =D-256 IS THE SUBROUTINE DEFINED SSA BY NAME ? JMP GTSU2 NO, IT IS THE SUBROUTINE # LDA .TMSB,I YES, SUBROUTINE CALL BY NAME STA TEMP1 SAVE # OF SUBROUTINE CMA,INA STA TEMP2 USE AS COUNTER STB TEMP4 SAVE B REG. * GTSU5 LDA TEMP2 ADA TEMP1 STA TEMP3 MPY TUSEN MPY BY T.U.S. TABLE ENTRY LENGTH INA ADA .TMSB LDB TEMP4 ADDR. OF ASKED FOR SUB. NA5HFBME CMW D3 JMP GTSU7 IT IS THIS ONE NOP LESS THAN ISZ TEMP2 GREATER THAN, MORE TM SUBROUTINE ? JMP GTSU5 YES, LOOP UNTIL END .ER10 JSB ERROR NO, SUBROUTINE NAME NOT FOUND JMP GTSU#,I NO ABORT PROCESSING * GTSU7 LDA TEMP3 INA A IS THE SUB # LDB TEMP4 RESTORE B REG STA B,I AND STORE TMS-SUB # IN PLACE OF NAME * GTSU2 LDA B,I IT IS THE SUBROUTINE # SZA,RSS JMP GTSUE ILLEGAL SUB # CMA,INA CHECK THE LEGALITY ADA .TMSB,I SSA IS IT LEGAL ? JMP GTSUE NO, ILLEGAL SUBROUTINE # LDA B,I YES, GET SUB # ISZ GTSU# RETURN OK JMP GTSU#,I SPC 1 .ER11 EQU * GTSUE JSB ERROR ILLEGAL TMS-SUB NUMBER JMP GTSU#,I IF NO-ABORT RETURN IN ERROR RETURN SKP DFINE LDA RQCNT THIS CALL MUST HAVE AT LEAST ADA =D-3 TREE PARAMETERS SSA OK ? .ER09 JSB ERRAB NO, ERROR --> ABORT TMS LDA Q,I RECALL TMS-SUBR. # IN ORDER AND =B37777 TO SET UP 'EPAOS', CLEAR BIT 14 & 15 MPY TUSEN ADA .TMSB A=ADDR OF 'EPAOS' LDB .PAR5+5 RECALL 'ENTRY POINT ADDR. OF SUBROUTINE' STB A,I FROM 'TMLIB' BUFFER TO SAVE IT. LDA Q CHECK THAT ADA QCBLA COMMON IS NOT ALREADY DEFINED INA CPA S COMMON ALREADY DEFINED ? .RSS RSS NO CONTINUE .ER14 JSB ERRAB YES, 2ND TMDFN IN SAME TMSUB --> ABORT TMS LDX DM1 SET UP LOAD INDEX LDY QCBLA SET UP STORE INDEX +H LDB .PAR1 GET CB0 LOCAL ADDR * DFIN1 CMB,INB SAVE COMMON BLOCK DEFINTION INTO STB A THE STACK LBX .PAR3 GET NEXT PARAMETER (CB LOCAL ADDR.) SZB,RSS END OF CALLING SEQUENCE JMP DFIN2 YES, CONTINUE ADA B NO, COMPUTE LOCAL CB LENGTH AND SSA AND VERIFY IT IS OK .ER08 JSB ERRAB ERROR IN CB DEFINTION --> ABORT TMS IOR BIT15 SET BIT 15 (NOT ENABLE) SAY Q,I STORE CB CURRENT LENGTH INTO THE STACK ISX BUMP FORM INDEX, SKIP IF 1ST TIME ISY BUMP TO INDEX IF NOT 1ST TIME RAL,CLE,ERA CLEAR BIT 15 FOR LOCAL CB LENGTH SAY Q,I STORE CB LOCAL LENGTH INTO THE STACK ISY BUMP TO INDEX JMP DFIN1 AND CONTINUE * DFIN2 CYA FIND NEW S VALUE ADA Q A=NEW S VALUE STA STKPT,I SAVE NEW S INTO THE STACK STA S REINIT S REGISTER * LDY QCBLA SET Y TO RECALL LAY Q,I CB0 LOCAL LENGTH SZA,RSS IS TRUE CB DEFINED IN THIS TM-SUBROUTINE ? JMP DFIN3 NO, NO TRUE COMMON IN THIS TM-SUBROUTINE LDB LEN00 YES, IS TRUE COMMON SZB,RSS ALREADY DEFINED ? STA LEN00 NO, INIT LEN0 CPA LEN00 YES, IT MUST HAVE THE RSS THE SAME LENGTH THAT THE FIRST ONE .ER04 JSB ERRAB NO, ERROR ---> ABORT TMS LDA Q,I SET CB0 DEFINED FLAG IOR BIT15 BY MERGING BIT15 WITH THE STA Q,I TMS SUBROUTINE # IN THE STACK * DFIN3 LDA .PAR2 RECALL CB1 LOCAL ADDR SAY Q,I AND SAVE IT INTO THE STACK * LDA STKPT INA NOW ENABLE AUTOMATICALLY STA PT ALL PREVIOUSLY ALLOCATED CB * DFIN5 LAX PT,I GET ACTUAL CB ADDR SZA,RSS ALLOCATED ? JMP DFIN6 NO CXB YES, PASSES CB# TO ENABLE IT JSB COM.E MEMORY IS ALREADY ALLOCATED, SET ENABLE BIT ONLY ^HLT 45B MEMORY SUSPEND RETURN !! DFIN6 DSX MORE COMMON BLOCK JMP DFIN5 YES, CONTINUE * ISZ PT LDA PT,I IS FIRST COMMON BLOCK SZA CURRENTLY ALLOCATED ? JMP EXIT4 YES, EXIT SPC 1 LDB DFNCD NO, ALLOCATE CB # 1 STB SCODE SET SPECIAL OP-CODE FOR MEM. SUSP. DFN10 LDA STKPT ADA T1OFS DLD A,I RECALL PARAM SAVED IN THE STACK DST TEMP1 (X REG. & LOCKID) CLB,INB ENABLE THE FIRST COMMON BLOCK JSB COM.E ALLOCATE MEMORY JMP MSU10 MEMORY SUSPEND RETURN, SUSPEND THE PROCESS SZA,RSS ALLOCATED DONE ? .ER03 JSB ERRAB NO CB1 IN THE 1ST TMSUB. OF A PROCESS STA TEMP YES, SAVE CB1(1) ADDR. LDX TEMP1 SET UP X REGISTER WITH LU # INDEX LBX .TMLU,I GET LU STB A,I AND SAVE IT IN 1ST WORD OF THE CB#1 INA LDB =B2000 READ-WRITE CONTROL BITS STB A,I READ CTL=400B, WRITE CTL=0B INA LBX .TMTP,I STB A,I SET DEVICE TYPE LDB CCBLP,I RECALL CB1 LENGTH ADB =D-3 TREE FIRST WORDS ARE ALREADY SET UP SSB CB1 LENGTH < 3 JMP .ER03 YES, ERROR SZB,RSS JMP .ER03 CBX USE X REG AS A COUNTER CLB INIT THE CB1 TO 0 DFN12 SBX A,I DSX JMP DFN12 * LDB IMAGE,I RECALL THE NUMBER OF DB DEFINED SZB,RSS ANY DB DEFINED ? JMP DFN11 NO, SKIP INIT CB1 FOR IMAGE LDA TEMP2 RECALL PREVIOUS VALUE OF LOCKID ALF,RAR AND ISOLATE DB# AND D7 SZA,RSS DBOPEN TO THAT PROCESS ? JMP DFN11 NO, SKIP INIT CB1 FOR IMAGE LDB CCBLP,I YES, RECALL CURRENT CB LENGTH ADB DM19 IS CB1 BIG ENOUGH TO HANDLE SSB TMS-IMAGE CALL ? JMP DFN11 NO, SKIP INIT CB1 FOR IMAGE JSB ICB1I YES, INIT CB1 FOR IMAGE LDA TEMP2 ]AND PASSES LOCKID WORD STA B,I * DFN11 LDA DFNS# RESET THE SUBROUTINE CODE STA SCODE JMP EXIT4 SPC 1 DFNCD DEC 22 D9 DEC 9 DM8 DEC -8 DM19 DEC -19 DFNS# EQU D9 QCBLA DEC 2 # OF WORDS FROM Q --> CB1 LOCAL ADDR LEN00 DEC 0 INITIAL TRUE COMMON BLOCK LENGTH PT NOP HED TMS PAUSE PROCESS PAUS JSB STIME SAVE CURRENT TIME. LDA STKPT ADA T1OFS STA TEMP ROOM TO STORE FUTURE TIME VALUE ADA D2 STA TEMP3 LINK ADDR LDA .PAR1 GET TIME OF THE PAUSE SSA .ER18 JSB ERRAB MUST BE POSITIVE SZA,RSS JMP EXITZ ALLOWS OTHERS PROCESS TO RUN CLB DST X DLD TTIME JSB DADD ADD TO CURRENT ONE DST TEMP,I AND SAVE FINAL TIME IN STACK JSB DCMX COMPLEMENTE IT DST X AND SAVE IT * LDB .PAUZ GET PAUSE QUEUE HEAD RSS PAUS3 LDB TEMP2 LDA B,I SZA,RSS END OF QUEUE ? JMP PAUS4 YES, ADD NEW ENTRY HERE STB TEMP4 STA TEMP2 ADA DM2 TO GET TIME IN THIS STACK DLD A,I GET TIME IN STACK JSB DADD COMPARE THE TWO TIME SSB COMPARE ? JMP PAUS3 STACK IN QUEUE < NEW STACK --> LOOP SZB HLT 50B LDB TEMP4 S.I.Q > N.S ---> QUEUE NEW STACK HERE LDA B,I GET NEXT LINK PAUS4 STA TEMP3,I SET IN NEW STACK LDA TEMP3 AND SET NEW STACK STA B,I IN THE QUEUE LDA .PAR1 CPB .PAUZ DID WE CHANGE THE QUEUE HEAD ? JMP PAUS8 YES, MUST REQUEST ANOTHER TIME JMP IDLEZ NO, DO NOT CHANGE TIME REQUESTD TO TIMER SPC 2 PAUS0 JSB RELBU TIMER IS BACK HERE, RELEASE THE BUFFER PAUS5 LDA .PAUZ,I AND PROCESS THE PAUSE QUEUE SZA,RSS JMP IDLEZ (HLT) ?????????????????????????????????????????? LDB A,I GET NEXT LINK STB .PAUZ,I ADA T3MOF STA STKPT RE-INIT STACK POINTER LDA PAUCD RE-INIT PAUSE SUBROUTINE CODE STA SCODE SZB,RSS PAUSE QUEUE EMPTY ? JMP EXIT4 YES, RETURN TO TMS LIBRARY NOW JSB WRI/O NO, RE-QUEUE A GOOD BUFFER JSB STIME AND RESTART THE TIMER FOR THE QUEUE HEAD LDB .PAUZ,I GET THE FIRST ONE IN ADB DM2 THE QUEUE TO SCHEDULE DLD B,I GET FINAL TIME JSB DADD FINAL TIME - CURRENT TIME SSB JMP PAUS5 TOO LATE, PROCESS IT IMMETIALLY SZB HLT 52B PAUS8 CMA,INA INDICATE ABSOLUTE OFFSET SSA,RSS JMP PAUS5 TOO LATE, PROCESS IT IMMEDIATELY STA STIME * JSB EXEC PUT "TMST" IN THE TIME LIST DEF *+6 DEF D12 TIMED EXECUTION (INITIAL OFFSET) DEF .TMST,I PROGRAM NAME DEF D1 RESOLUTION CODE ( 1/100 SEC) DEF D0 EXECUTION MULT. (ONLY ONCE) DEF STIME INITIAL TIME OFFSET JMP IDLEZ GOTO IDLE LOOP * D12 DEC 12 SPC 1 STIME NOP LDB .TIME XLA B,I GET CURRENT TIME FROM THE SYSTEM MAP INB XLB B,I DST TTIME JSB DCMX DST X JMP STIME,I * .TIME DEF $TIME+0 TTIME BSS 2 SPC 2 DADD NOP A,B PLUS X,X+1 CLE ADA X ADD LEAST SIGNIFICANT BITS CLO SEZ,CLE INB PROPAGATE CARRY OUT ADB X+1 ADD MOST SIGNIFICANT BITS SOC OVERFLOW ? HLT 53B JMP DADD,I SPC 1 DCMX NOP TWO'COMPLEMENT OF A,B CMA ONE' COMPLEMEMT CMB DST X CLA,INA AND THEN ADD ONE. CLB JSB DADD JMP DCMX,I X BSS 2 SPC 2 .PAUZ DEF *+1 PAUSE QUEUE HEAD OCT 0 SPC 1 HED TMS SUB-PROCESS LAUNCHING PROCESS ISPRL LDB LUXXX,I INITIAL-PROCESS LAUNCHING SZB,RSS LU DEFINED ? LDB LU NO, GET CONSOLE LU  STB .PAR1 LDB ..PA2 LDA PNXXX INITIAL PROCESS NAME ADDR MVW D3 JMP SPR01 SPC 2 SPR00 JSB RELBU PROCESS LAUNCH FROM 'TMSL', RELEASE BUFFER LDA .BUF AND GET PARAMETERS PASSE BY LDB ..PA1 'TMSL' TO MOVE THEM MVW D4 INTO THE RIGTH BUFFER SPR01 CLA,CCE STA .PAR5 NO CB ARE PASSED TO THE PROCESS STA .PAR5+1 STA .PAR5+2 STA .PAR5+3 STA STKPT NO STACK EXIST RIGHT NOW LDA .PAR2 SET THE NO ABORT BIT IN RAL,ERA THE TM-SUBROUTINE NAME STA .PAR2 SPC 1 SPRL CCA SET SUBPRO-QUEUE FLAG TO 'QUEUE UP' STA SPRQF LDA .PAR1 RECALL LU (BIT15 --> DO NOT QUEUE SUBPRO.) RAL,CLE,SLA,ERA CLEAR BIT15 AND STA SPRQF SET SUBPRO-QUEUE FLAG TO 'DO NOT QUEUE' STA SPRLU SAVE LU LDB ..PA2 RECALL TMSUB NAME/# ADDR JSB GTSU# RECALL TMSUB # IN A REG. & .PAR2 CMA,INA,RSS ILLEGAL NAME OR # RETURN CLA RETURN OK CLB CLEAR THE TLOG JSB SETST SET STATUS ACCORDING TO GTSU# SUB. SZA WAS IT OK ? JMP SPR13 NO, FORGET THE LAUNCH LDB .TMLU ADB DM2 DLD B,I CMA,INA ADA B B IS MINUS # OF AUXILIARY DEVICES INB CBX X TO GET FIRST AUXILIARY DEVICE SPR12 LBX .TMLU,I GET ONE LU CPB SPRLU IS IT THIS ONE ? JMP SPR14 YES, ISX NO, GET NEXT ONE INA,SZA MORE LU ? JMP SPR12 YES, CONTINUE SPR13 LDA STKPT NO, FORGET THE LAUNCH SZA IF LAUNCH FROM AN OTHER PROCESS JSB WRI/O RESTART THE CALLING PROCESS JMP STAR8 RETURN TO IDLE LOOP SPC 5 * THE LU IS FOUND, * DUPLICATE CB'S TO BE PASSED TO THE SON PROCESS * IF LU IS FREE THEN START THE PROCESS, * ELSE QUEUE IT ACCORDING TO THE QUEUE REQUEST FLAG. * c| SPR14 CLA INIT LOCK ID WORD TO 0 STA .PAR5+4 * LDA STKPT PROCESS LAUNCH FROM STA SPRLU SAVE STACK POINTER TEMPORARILY SZA,RSS OUTSIDE ? JMP SPR50 YES, SKIP THE FOLLOWING SPC 2 * DUPLICATE CB'S AND PASSES LOCKID * STX SPRTX SAVE X REG LDA ..PA5 NO, SET UP TO GET PARAMETERS JSB MEMOK RESOLVE MEMORY SUSPEND PROBLEM. * JSB .MGTG ALLOCATE A BUFFER TEMPORARILY SPR38 DEC 0 AS INTERMEDIATE STORAGE FOR CB JMP .ER13 TO DUPLICATE THEM. JMP MSU05 ---> GOTO MEM SUSP. DST SPR47 SAVE ADDR. AND LENGTH SPC 1 JSB WRI/O RESTART CALLING PROCESS SPC 1 LDA ..PA5 STA TEMP1 SET UP POINTER TO LOCAL CB'S ADDR. LDA Q STA TEMP2 SAVE Q VALUE LDX SPRTX RECALL X REG TO LAX .STKT,I GET THE STACK POINTER OF THE ADA S0 FUTURE STACK IN ORDER TO INA CALCULATE THE FIRST Q VALUE STA TEMP4 THAT WILL BE WHEN THE CB IS ENABLED * SPR42 LDA TEMP1,I GET LOCAL CB ADDR FROM SZA,RSS THE CALLING SEQUENCE, CB HERE ? JMP SPR45 NO, IT IS THE END OF LIST CLB YES, CLEAR LOCAL ADDR. IN CALLING SEQUENCE STB TEMP1,I SINCE IT WILL BE REPLACED BY LOGICAL ADDR. JSB GECB# SET B = CB NUMBER JSB COM.U INIT A, B & Y AND MAP THE 1025 FIRST WORDS SZA,RSS ALLOCATED ? JMP SPR44 NO, GOTO NEXT ONE SSB YES, ENABLED ? JMP SPR44 NO, GOTO NEXT ONE STB TEMP3 SAVE CURRENT CB LEN IN WORDS FOR MOVE * LDA TEMP4 SET Q VALUE WITH WHAT IT WILL BE STA Q WHEN THAT CB WILL BE ENABLED LDA TEMP1 A=ADDR WHERE CB SHOULD BE SAVED JSB ALCB ALLOCATE MEMORY FOR THAT CB HLT 55B SHOULD NOT HAPPENS, TESTED BY 'MEMOK' LDA TEMP2 RESTORE THE VARIABLE Q STA Q * LAY STKPT,I RECALL ORIGINAL CB LOGICAL ADDR LDB TEMP3 AND LENGTH TO JSB MAPCB MAKE SURE THE ENTIRE CB IS MAPPED LDB SPR47 TO MOVE IT INTO THE INTERMEDIATE MVW TEMP3 BUFFER * LDA TEMP1,I RECALL LOGICAL ADDR AND LENGTH LDB TEMP3 OF NEW CB TO MAKE SURE JSB MAPCB THAT THE ENTIRE CB IS MAPPED LDB A SET DESTINATION ADDR LDA SPR47 GET SOURCE ADDR AND MVW TEMP3 MOVE FROM INTERMEDIATE TO THE NEW ONE SPR44 ISZ TEMP1 BUMP POINTER INTO CALLING SEQUENCE JMP SPR42 AND LOOP UNTIL END OF LIST * SPR45 JSB .MGTR RELEASE TEMPORARY BUFFER SPR47 BSS 2 * LDB IMAGE,I RECALL NUMBER OF DATA BASES SZB,RSS IMAGE USED ? JMP SPR49 NO CLB,INB YES, GET PREVIOUS LOCK ID WORD FROM CB1 JSB COM.U SET A,B,Y & TEMP, MAP THE FIRST 1025 WORDS SZA,RSS ALLOCATED ? JMP SPR49 NO, FORGET IT LDB A B = ACTUAL ADDR ADB DM1 LDB B,I B = ACTUAL SIZE ADB DM19 ACTUAL SIZE - 19 SSB ACTUAL SIZE > 18 JMP SPR49 NO, FORGET IT ADA D11 YES, SET A TO CB1(12) LDA A,I GET LOCK ID WORD STA .PAR5+4 PASSES IT TO THE SON PROCESS * SPR49 LDX SPRTX RESTORE X REG SPC 2 * START THE SON PROCESS, OR QUEUE THE REQUEST * IF LU IS BUSY OR LOCKED. SPC 1 SPR50 LBX .STKT,I GET STACK POINTER LDA B,I SSA,RSS IS THIS LU FREE ? JMP SPR70 NO, GO TO QUEUE THIS REQUEST JSB INSTK YES, INITIALIZE STACK LAX .TMLU,I GET AUXILIARY LU STA TEMP,I AND SAVE IT INTO THE STACK AT S+1 LDB STKPT INIT B JSB LRQ TRY TO LOCK LU JMP SPR85 LOCK WAS SUCCESSFULL, START SON PROCESS SPC 1 LDA SPRQF LOCK HAS FAILED, RECALL QUEUE FLAG SSA QUEUED REQUEST ? JMP SPR56 YES, ILNSERT REQUEST INTO EXTER. EVENTS QUEUE LDA BIT15 NO, RETURN STATUS TO CALLING PROCESS AND STA STKPT,I DO NOT START SON PROCESS. FREE STACK AGAIN LDA SPRLU RESTORE STACK POINTER STA STKPT SPR53 CCA RETURN STAT.=-1 TO CALLING PROCESS, TO CLB INDICATE THAT THE 'TMPRO' RQ IS NEITHER JSB SETST EXECUTED OR QUEUED. LDA STKPT PROCESS LAUNCH FROM SZA,RSS INSIDE ? JMP STAR8 NO, OK * LDA ..PA1 YES, MUST RELEASE ALL ALLOCATED CB ADA D3 STA PT SET UP POINTER TO CB LOGICAL ADDR CLA STA Q TO RELEASE THE CB (CUR. Q > Q) STA .PAR5+4 NO CB HERE JSB RLCB RELEASE THE MEMORY JMP STAR8 AND EXIT SPC 1 SPR56 ADB T3OFS LDA .EXTW,I SET UP TO QUEUE ON THE STA B,I EXTERNAL EVENT WAIT QUEUE STB .EXTW,I LDA .LRQX SET SUBROUTINE ADR INTO THE STACK STA S,I AT S LOCATION INB UPDATE B AND QUEUE THE REQUEST JMP SPR72 SPC 2 * THE LU IS BUSY OR LOCK BY AN OTHER RTE PROGRAM * QUEUE THIS REQUEST IN THE WAITING QUEUE OF * THIS AUXILIARY LU. (REQUEST A 11 WORDS BLOCK TO * MMGT TO SAVE ALL INFORMATIONS) * SPR70 ADB T4OFS UPDATE B TO GET HEAD OF WAITING QUEUE LDA SPRQF AUTOMATIC QUEUE FEATURE SSA,RSS REQUESTED ? JMP SPR53 NO, RETURN STATUS TO CALLING PROCESS SPR72 LDA B,I SZA,RSS JMP SPR75 END OF LIST STA B CONTINUE UNTIL END OF LIST JMP SPR72 * SPR75 STB TEMP1 SAVE ADDR OF LAST ELEMENT IN JSB .MGTG THE QUEUE D11 DEC 11 REQUEST 11 WORDS TO MMGT HLT 56B JMP SPR77 MEMORY SUSPEND RETURN !! STB A,I SAVE ACTUAL BLOCK LENGTH INA STA TEMP1,I LINK THIS BLOCK IN THE LIST CLB STB 0,I END OF LIST INA STX A,I qSAVE INDEX TO TMLU TABLE INA LDB A TO ADDR LDA ..PA2 MVW D8 SAVE ADDR OF CB TO BE PASSED TO JMP IDLE THE SUB-PROCESS, RETURN SPC 1 SPR77 LDA STKPT THIS PROCESS MUST HAVE BEEN SZA LAUNCHED FROM OUTSIDE, IS IT ? HLT 60B NO !!!!!!!!!!!!!!!!!!!!!!!! LDA =D18 SET UP SPECIAL STA SCODE SUBROUTINE CODE LDA D4 AND QUEUE UP AGAIN THIS EXTERNAL STA WRI/L EVENT REQUEST IN THE EXTERNAL CLASS I/O LDA DM4 DELAY THE REQUEUE FOR A MAXIMUM OF 1 SEC, LDB .SPR7 BUT CHECK THE CLASS I/O QUEUE EVERY 250MS JSB WAIT SUSPEND FOR 250MS SPR78 JSB WRI/O CLASS I/O QUEUE CLA,INA (THIS WILL LOAD THE SYSTEM A LOT STA WRI/L BUT WHAT CAN WE DO ?) JMP IDLE * .SPR7 DEF *+1 ADDR OF SUB. EXECUTED EVERY 250MS NOP JSB NRCLS RETREIVE THE NUMBER OF COMPLETED RQ DEF *+2 PENDING ON THAT CLASS I/O DEF CLASS COMPLETION QUEUE. SZA,RSS NONE ? JMP .SPR7+1,I YES, WAIT LONGER JMP SPR78 NO, REQUEUE NOW TO GET OTHER RQ PENDING SPC 2 * PREVIOUS PROCESS HAS COMPLETED, * START THE FIRST ONE OF THE WAITING QUEUE * (USE THE 11 WORDS BLOCK AND REALESE THIS BLOCK) SPC 1 SPR80 JSB STIPR START INTERAC. PROCESS (CLEARED WHEN DONE) LDA STKPT END OF SUB-PROCESS ADA T4OFS CHECK IF SOMETHING IS LDB A,I WAITING FOR THIS LU SZB,RSS WAITING QUEUE EMPTY ? JMP SPR93 YES, UNLOCK LU AND SET IT INACTIVE STB TEMP1 SAVE ADD+1 OF THIS BLOCK LDB B,I AND LINK THE NEXT ONE STB A,I IN PLACE OF THIS ONE. * LDA TEMP1 INA RESTORE INDEX IN TMLU TABLE LDX A,I * INA RESTORE ALL PARAMETERS LDB ..PA2 MVW D8 * LDA TEMP1 RETURN THIS BLOCK OF MEMORY ADA .DM1 TO MMGT LDB A,I GET ACTUAL LENGTH DST SPR82 JSB .MGTR RETURN MEMORY SPR82 BSS 2 LDB STKPT RESTORE B REGISTER JSB INSTK RE-INIT STACK SPC 1 SPR85 LDA ..PA5 STORE LOGICAL CB ADDR INTO LDB STKPT THE STACK ADB D3 MVW D4 LDA .PAR2 RECALL T.U.S. NUMBER TO SIMULATE STA .PAR1 A 'TMSUB' CALL NOW. SPR88 LDA =D8 STA SCODE SIMULATE TM SUB CALL JMP SBCAL SPC 2 * PREVIOUS PROCESS HAS COMPLETED, * AND NO REQUEST IS QUEUING FOR THAT LU * SET THIS LU INACTIVE AND UNLOCK IT (RTE LU UNLOCK) * SPC 1 SPR93 LDB BIT15 SET LU INACTIVE STB STKPT,I ADA DM3 TO RECALL TEMP1 FROM STACK STA SPR95 TO UNLCK THE AUXILIARY LU JSB LCKL? LOCK THIS LU ? JMP IDLE NO, FORGET IT JSB LURQ YES, PERFORM THE UNLOCK CALL DEF *+4 DEF O40K UNLOCK LU SPR95 NOP LU ADDR. DEF D1 UNLOCK ONLY ONE LU HLT 62B ERROR RETURN SZA UNLOCK OK ? HLT 63B JMP IDLE AND RETURN TO IDLE LOOP SPC 3 INSTK NOP INITIALIZE STACK ROUTINE STB STKPT LDY T3OFS CLEAR THE FIRST WORDS OF STACK CLA UP TO TEMP4 (NOT INCLUDED) INST3 SAY B,I DSY JMP INST3 DLD S0 ADA STKPT ABSOLUTE S VALUE ADB STKPT ABSOLUTE Q VALUE DST S DST STKPT,I SET S & Q INITIAL VALUE INA STA TEMP SAVE NEXT Q VALUE LDA BIT14 SET BIT14 THAT INDICATE STACK FOR STA B,I AUXILIARY LU (SPECIAL RTN CD=0) ADB DM1 SET STOP-INHIBITED FLAG TO NOT ZERO STA B,I (PROCESS CANNOT BE STOPPED) ADB DM3 LDA .PAR5+4 SAVE LOCKID WORD INTO THE STACK AT STA B,I TEMP2 TO INIT CB1(12) LATER. ADB DM1 SAVE X REG INTO THE STACK AT STX B,I TEMP1 TO INIT CB1(1)+& & CB1(3) JMP INSTK,I TO ENABLE AND INIT CB1 SPC 2 .LRQX DEF *+1 NOP SUBROUTINE ENTRY POINT JSB LRQ RSS OK, RESTART THE PROCESS JMP .LRQX+1,I LOCK FAIL, RETURN JSB DEXTW DEQUEUE FROM EXTERNAL EVENT WAIT QUEUE JMP SPR80 AND RESTART THE PROCESS SPC 1 LRQ NOP LDA B,I A = S REG. INA STA LRQ3 SET LU ADDR. JSB LCKL? LOCK THIS LU ? JMP LRQ,I NO, FORGET IT JSB LURQ YES, PERFORM THE LU LOCK REQUEST DEF *+4 DEF IOPTN LRQ3 NOP LU DEF D1 # OF LU HLT 64B ERROR RETURN SZA LOCK DONE ? ISZ LRQ NO, RETURN P+2 JMP LRQ,I YES, RETRUN P+1 SPC 1 LCKL? NOP LOCK THIS LU ? LDA A,I GET LU CPA D1 LU = 1 ? JMP LCK?3 YES, PERFORM THE LOCK RQ ADA DM4 IF LU = < 3 DO NOT LOCK IT SSA,RSS LCK?3 ISZ LCKL? > 3, PERFORM THE LOCK RQ JMP LCKL?,I = < 3, FORGET THE LOCK SPC 2 ..PA2 DEF .PAR2 ..PA5 DEF .PAR5 BIT14 EQU O40K SPRQF NOP SON PROCESS QUEUE REQUEST FLAG SPRLU NOP SON PROCESS LU SPRTX NOP DM4 DEC -4 HED TMS SCHEDULE NON-TMS PROGRAM PROCESS SCHPR LDA ..PA1 ADA D2 SKIP PROGRAM NAME HLT 12B !!!!!!!!!!!!! NOT IMPLEMENTED !!!!!!!!!!!!!!!!!!!!! STA TEMP1 USE AS POINTER TO ACCESS USER PARAM * CCA STA SRFLG SET SEND MAIL BOX FLAG * LDA ICLAS SAVE TMS-INTERNAL CLASS WORD STA SCHPZ CLA STA ICLAS INIT ICLAS TO ALLOCATE A CLASS WORD STA RTRNA INIT LENGTH OF 1ST CB SEND * SCH02 ISZ TEMP1 SCH03 LDA TEMP1,I GET PARAM SZA,RSS END OF LIST ? JMP SCH20 YES, JSB GECB# NO, SET COMB# = CB NUMBER JSB COM.U AND INIT A, B & Y SZA,RSS ALLOCATED ? JMP SCH02 NO, FORGET IT SSB HFB YES, ENABLED ? JMP SCH02 NO, FORGET IT DST SCH15 YES, SET MAILB PARAM SCH05 ISZ TEMP1 GET LENGTH OF NEXT CB LDA TEMP1,I CLB SZA,RSS END OF LIST ? JMP SCH07 YES, SEND THE CURRENT ONE JSB GECB# NO, TRY TO GET LENGTH JSB COM.U SZA,RSS ALLOCATED ? JMP SCH05 NO, FORGET IT SSB YES, ENABLED ? JMP SCH05 NO, FORGET IT SCH07 STB TEMP YES, SAVE LENGTH OF NEXT CB LDB SCH15+1 RECALL LENGTH OF CURRENT CB LDA RTRNA RTRNA ALREADY SZA,RSS INIATILIZED ? STB RTRNA NO, SET 1ST CB LEN SEND LDA TEMP RECALL NEXT CB LENGTH JSB MAILB AND SEND CURRENT CB SCH15 BSS 2 JMP SCH03 LOOP UNTIL END SPC 1 SCH20 LDA .PAR1 RECALL FIRST WORD OF PRG NAME SSA,RSS REQUEST WITH WAIT ? JMP SCH25 YES, DO IT WITH WAIT RAL,CLE,ERA NO, CLEAR BIT 15 STA .PAR1 TO RESTORE PROGRAM NAME JSB WRI/O QUEUE UP PROCESS IMMEDIATELY (NO WAIT) SCH25 LDA ..PA1 JSB SCHUP SCHEDULE NON-TMS USER PROGRAM .ER22 JSB ERRAB ERROR RETURN ! * LDA SCHPZ RESTORE THE TMS-INTERNAL CLASS WORD STA ICLAS JMP IDLE AND EXIT * SCHPZ NOP HED TMS ABORT / SOFT STOP PROCESS * SET/RESET STOP-INHIBIT FLAG * =========================== * SIF LDA .PAR1 GET USER REQUEST SZA SET/RESET ? JMP SIF05 DISALLOW STOP OF TMS SIF03 LDB STKPT ALLOW STOP AGAIN ADB NSOFS SET THE STOP-INHIBIT FLAG STA B,I ON THE STACK D\H JMP IDL41 RETURN STATUS OK AND EXIT * SIF05 LDB STPFL RECALL STOP IN PROGRESS FLAG CCA SZB,RSS STOP IN PROGESS ? JMP SIF03 NO, SET FLAG ON THE STACK AND EXIT JMP IDL42 YES, RETURN BAD STATUS TO THE USER SPC 1 STPFL DEC 0 STOP IN PROGESS FLAG (NO 0=IN PROGRESS) SPC 3 * STOP FROM 'TMSL' * ================ * STPX CLA STOP TMS REQUEST FROM 'TMSL' STA STKPT OUTPUT "TMS OPERATOR STOP ! " JMP TMSP1 SPC 2 * STOP FROM A USER REQUEST USING 'TMSTP' CALL * =========================================== * TMSP LDA .PAR1 GET STOP # STA STP# AND SAVE IT LDA STKPT RESET THE STOP-INHIBIT FLAG FOR THIS ADA NSOFS PROCESS CLB STB A,I * TMSP1 CCA SET THE STOP IN PROGRESS FLAG STA STPFL * JSB RELBU RELEASE THE BUFFER LDA =D25 SET THE NEW SUBROUTINE CODE STA SCODE FOR STOP IN PROCESS JSB STIME AND SAVE CURRENT TIME DLD TTIME DST STPTI JMP EXITZ AND QUEUE THAT STOP IN PROGRESS RQ SPC 2 TMSPX CPB D3 TLOG = 3 ? JMP TSP90 YES, CHECK FOR ANSWER "YES" TSP10 LDX #LU NO, CHECK STOP-INHIBIT FLAG OF ALL STACKS TMSP2 LAX .STKT,I A=STACK POINTER LDB A,I GET S SSB STACK ACTIVE ? JMP TMSP3 NO, CHECK IF ANY THINGS IS WAITING ADA NSOFS YES, ACCESS THE STOP-INHIBIT FLAG LDA A,I GET FLAG SZA STOP ALLOWED ? JMP TSP40 NO, WAIT LONGER TMSP6 DSX YES, CHECK NEXT STACK JMP TMSP2 AND LOOP SPC 2 JSB OUTLF YES, PERFORM THE TMS STOP REQUEST JSB OUTLF LDB STKPT LDA .MS4 SZB,RSS STOP FROM 'TMSL' ? JMP TMAB8 YES, PRINT "TMS OPERATOR STOP !" LDA STP# NO, FROM TMLIB, PRINT STOP # JMP TMAB4 SPC 1 TMSP3 ADA T4OFS TO ACCESS QUEUE HEAD OF THE WAITING LIST LDA A,I SZA,RSS WAITING BLOCK ? JMP TMSP6 NO, CONTINUE HLT 13B YES, ERROR !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SPC 2 * TMS CANNOT BE STOPPED (STOP-INHIBIT FLAG AND/OR * SUBPROCESSES WAITING), CHECK IF TIME TO REPORT * THAT, IF NOT WAIT LONGER. * TSP40 JSB STIME GET THE CURRENT TIME DLD STPTI RECALL FINAL TIME JSB DADD FINAL TIME - CURRENT TIME SSB,RSS FINAL TIME REACHED ? JMP IDL08 NO, WAIT LONGER TO REPORT ERROR LDA D500 YES, SET THE NEXT FINAL TIME CLB DST X DLD TTIME JSB DADD ADD TO CURRENT TIME DST STPTI AND SAVE FINAL TIME * * REPORT TMS ACTIVITY NOW: * (LU BUSY & SUBPROCESSES QUEUE UP) * JSB OUTLF SPACE TWO LINE JSB OUTLF LDA .MSX OUTPUT "STOP DELAYED DUE TO ACTIVE TERMINAL" JSB OUTM * TMSP4 LAX .TMLU,I THIS LU IS BUSY JSB CASC STA .MSZ+3 LDA .MSZ JSB OUTM LBX .STKT,I NOW CHECK IF PROCESS ARE ADB T4OFS WAITING FOR THIS LU CCA INIT # OF PRCESS WAITING TSP42 LDB B,I GO ON THE WAITING QUEUE INA INCREMENT THE COUNTER FOR WAITING PROCESS SZB END OF QUEUE ? JMP TSP42 NO, LOOP UNTIL END * SZA,RSS PROCESS WAITING ? JMP TSP70 NO, GO TO NEXT STACK JSB CASC YES, REPORT THE NUMBER OF WAITING PROCESS STA .MSY+3 LDA .MSY JSB OUTM TSP70 DSX ANY MORE STACK ? RSS YES, CHECK IF OK TO REPORT LU BUSY JMP TSP80 NO, ASK FOR ABORT NOW * LAX .STKT,I GET NEXT STACK POINTER LDB A,I B=S REG. SSB STACK ACTIVE ? JMP TSP70 NO, GOTO NEXT STACK ADA NSOFS YES, GRET THE STOP-INHIBIT FLAG LDA A,I SZA STOP ALLOWED ? JMP TMSP4 NO, REPORT LU BUSY JMP TSP70 YES, GOTO NEXT STACK SPC 1 * TMS ACTIVITY HAS BEEN REPORTED, ASK IF "OK TO ABORT ?" * TSP80 LDA LU SET TIME OUT ON THE TERMINAL IOR =B2200 STA TEMP JSB EXEC DEF *+4 DEF D3 CONTROL RQ DEF TEMP LU + 2200B DEF D500 TIME OUT IS 5 SEC. * JSB RELBU RELEASE BUFFER QUEUED IN THE CLASS QUEUE LDA .MSW OUTPUT JSB OUTM "OK TO ABORT (YES/NO) _" LDA LU IOR =B400 MERGE ECHO BIT STA TEMP JSB EXEC REQUEST THE ANSWER DEF *+8 DEF D17 CLASS READ DEF TEMP LU + ECHO BIT, ASCII READ DEF BUF DUMMY BUFFER DEF DM4 MAX BUFFER LENGTH DEF STKPT 1ST PARAM = STACK POINTER DEF SCODE 2ND PARAM = SUBROUTINE CODE DEF CLASS CLASS WORD JMP IDLE SPC 1 TSP90 LDA BUF CHECK THE ANSWER CPA =AYE RSS YES ? JMP TSP10 NO, CHECK IF OK TO STOP LDA BUF+1 NOW CHECK FOR "S" AND =B177400 CPA O514C "S" RSS YES, ABORT TMS NOW JMP TSP10 NO, CHECK IF OK TO STOP JSB OUTLF SPACE ONE LINE JMP ABTX AND ABORT TMS APPLICATION SPC 1 .MSZ DEF *+1 ASC 11, LU XX IS BUSY .MSY DEF *+1 ASC 11, XX PROCESS WAITING .MSX DEF *+1 ASC 11,STOP DELAYED BECAUSE: .MSW DEF *+1 ASC 11,OK TO ABORT(YES/NO) ?_ * STP# NOP SAVE THE STOP NUMBER STPTI BSS 2 D500 DEC 500 O514C OCT 51400 SKP * ABORT FROM 'TMSL' * ================= * ABTX LDA .MS3 JMP TMAB8 REPORT "TMS OPERATOR ABORT ! " SPC 2 * TMS ABORT REQUEST BY A USER CALL 'TMSAB' * ======================================== * TMAB EQVU * ABORT THE TM SOFTWARE LDA .MS37 SET UP TO ABORT MESSAGE LDB .MS12 MVW D3 LDA .PAR1 GET STOP # TMAB4 CCE DECIMAL CONVERSION JSB $CVTX INA LDB .MS15 MVW D2 JSB GPNAD GET TM-SUBROUTINE NAME ADDR LDB .MS18 AND MOVE IT IN MESSAGE MVW D3 LDA .MS1 TMAB8 JSB OUTM OUTPUT "TMS ABORT XXXX TMSUBX" JMP ABT00 CLEAN UP AND EXIT. SPC 3 GPNAD NOP RETREIVE T.U.S. NAME LDA STKPT RECALL STACK POINTER SZA,RSS STACK DEFINED ? JMP GPNA3 NO, LEAVE "TMSYS" INA LDA A,I GET Q REG VALUE LDA A,I GET TUS# OR SPECAIL THINGS WITH BIT14 CLE CLEAR BIT 15 & 14 ELA,CLE,ELA AND MOVE BIT14 INTO E RAR,RAR SEZ SPECIAL CASE ? JMP GPNA5 YES, NO TUS # DEFINED ADA DM1 NO, THIS IS THE TUS#, GET NAME FORM MPY D5 THE TMS TABLE. ADA .TMSB INA,RSS GPNA2 LDA PNX00 JMP GPNAD,I GPNA3 LDA .MS04 LEAVE "TMSYS .." JMP GPNAD,I GPNA5 CPA D1 INTERACTIVE PROCESS ? JMP GPNA2 YES, GET STARTING PROCESS NAME JMP GPNA3 NO, LEAVE "TMSYS" SPC 2 MS0 ASC 16,TMS 00 TMSUB @123456 - MS1 ASC 11,TMS STOP 3456 TMSUB MS3 ASC 11,TMS OPERATOR ABORT ! MS4 ASC 11,TMS OPERATOR STOP ! .MS1 DEF MS1 .MS3 DEF MS3 .MS4 DEF MS4 .MS12 DEF MS1+2 .MS15 DEF MS1+5 .MS18 DEF MS1+8 .MS37 DEF MS3+7 ERR. ASC 2,ERR ASC@ ASC 1, @ .M013 DEF MS0+13 HED TERMINAL-MONITOR ERROR CONDITION PROCESS .ERR DEC 35 TOTAL NUMBER OF ERRORS NOP 1 INTERAC. LU'S DOWN OR LOCKED DEF .ER02+1 2 NOT ENOUGH MEM FOR STACK ALLOCATION DEF .ER03+1 3 NO OR BAD CB1 IN 1ST TUS OF A PROCESS DEF .ER04+1 4 TRUE COMMON HAS NOT THE SAME LENGTH DEF .ER05+1 5 ENABLE CB WITH LENGTH = 0 DEF .ER06+1 6 ENABLE CB FOR THE 2ND3: TIME DEF .ER07+1 7 'RETURN' IN AN INTERAC. PROCESS DEF .ER08+1 8 CB DEFINTION ERROR DEF .ER09+1 9 'TMDFN' HAS LESS THAN 3 PARAMETERS DEF .ER10+1 10 T.U.S. NAME NOT FOUND DEF .ER11+1 11 ILLEGAL T.U.S. NUMBER DEF .ER12+1 12 STACK OVERFLOW ('TMSUB' CALL) --> ABT DEF .ER13+1 13 CB LENGTH > EVER AVAILABLE MEMORY DEF .ER14+1 14 2ND 'TMDFN' IN A T.U.S. --> ABT DEF .ER15+1 15 BAD CB IN 'TMCBE/D' (LEN=0 OR 1ST CB) DEF .ER16+1 16 DISABLE A NO-ALLOCATED CB DEF .ER17+1 17 DISABLE A NO-ENABLE CB DEF .ER18+1 18 TIME IN 'TMPZ' REQUEST IS NOT LEGAL NOP 19 DEF .ER20+1 20 NEW CB LEN IN 'TMCBL' IS NOT LEGAL .IMER DEF .ER21+1 21 RESERVED FOR IMAGE ERROR DEF .ER22+1 22 SCHEDULE A NON-TMS PRG NOT LOADED NOP 23 INTERNAL TMS ERROR (LOGIQUE/TABLE) NOP (TMLIB#4) 24 TMS USER CALL HAS MORE THAN 9 PARAM. NOP (TMLIB#5) 25 'TMDFN' NOT 1ST CALL IN A T.U.S. NOP (TMLIB#6) 26 CB1 DISABLE DURING AN I/O CALL NOP (TMLIB#7) 27 CB1 DISABLE/TOO SMALL FOR 'TBXXX' CALL NOP (TMLIB#8) 28 CB1(1) OR CB1[6:13] HAS BEEN MODIFIED NOP 29 NOP 30 NOP 31 NOP 32 NOP 33 NOP 34 NOP 35 RESERVED FOR LOGGING ERROR SPC 1 IMERC ABS .IMER-.ERR SPC 3 ERRAB NOP ERROR PROCESS FOR FATALS ERRORS CCA STA NOABT SET ABORT FLAG LDA ERRAB STA ERROR JMP ERROR+1 SPC 1 ERROR NOP LDX .ERR ERR02 LAX .ERR CPA ERROR IS IT THIS ERROR ? JMP ERR03 DSX END OF TABLE ? JMP ERR02 NO, CONTINUE HLT 65B YES, ERROR IN ERROR !!! ???????????? SPC 1 ERR03 CXA STA ERR# SAVE ERROR # LDB NOABT CHECK TO ABORT SSB,RSS ABORT ALLOWED ? JMP ERROR,I NO ABORT ! RETURN TO CALLER ERR JSB ERRPR PRINT ERROR MESSAGE JMP ABT00 CLEAN UP AND EXIT. SPC 2 ERRPR NOP FORMAT AND PRINT ERROR MESSAGES LDA ERR# JSB CASC CONVERT IT INTO ASCII STA MS0+2 LDA ERR# RECALL ERROR NUMBER CPA IMERC IS IT AN IMAGE ERROR ? RSS YES JMP ERR04 NO, CONTINUE * LDA BUF+1 RECALL TMS-IMAGE SUBROUTINE CODE MPY D3 ADA .IMGT INDEX IN IMAGE NAME TABLE LDB .MS04 AND MOVE TMS-IMAGE SUBROUTINE MVW D3 NAME INTO OUTPUT BUFFER LDA BUF RECALL IMAGE STATUS CCE DECIMAL CONVERSION JMP ERR05 SPC 1 ERR04 JSB GPNAD LDB .MS04 MVW D3 INA LDA A,I GET EPAOS CMA,INA SZA IS IT DEFINED ? ADA XSUSP YES, COMPUTE RELATIVE ADDR IN THE TM-SUBROUTINE CLE IN ABORT MESSAGE (OCTAL VALUE) ERR05 JSB $CVTX * LDB .MS08 MVW D3 ADB =D-3 CLE,ELB ERR07 LBT CPA O40 RSS JMP ERR08 IOR =B20 ADB DM1 SBT JMP ERR07 ERR08 LDA ASC@ STA MS0+7 LDA ERR# RECALL ERROR NUMBER CPA IMERC IS IT AN IMAGE ERROR ? RSS YES JMP ERR09 NO, CONTINUE DLD ERR. DST MS0+7 SET "ERR " INTO OUTPUT BUFFER JSB DBNAD RETEIVE THE DB NAME ADDR FROM THE DB# LDB .M013 MVW D3 LDA .MS0 ERROR MESSAGE ADDR. LDB =D32 ERROR MESSAGE LENGTH IN BYTES JSB OUTM0 OUTPUT ERROR MESSAGE JMP ERRPR,I ERR09 LDA .MS0 JSB OUTM OUTPUT "TMS XX TMSUB @123456" JMP ERRPR,I SPC 1 CASC NOP CONVERT INTO ASC CLB DIV D10 SZA,RSS LDA =B360 TO HAVE LEADING SPACE INSTEAD OF ZERO ALF,ALF ADA B ADA =A00 JMP CASC,I SPC 1 OUTM NOP LDB D22 MESSAGE LENGTH IN BYTES JSB OUTM0 JMP OUTM,I SPC 1 OUTM0 NOP CLE,ELA --> BYTE POINTER STB CASC LDB @MSBX BYTE DESTINATION ADDR MBT CASC MOVE MESSAGE CMB,INB ADB @MSBU STB CASC JSB EXEC DEF *+5 DEF D2 DEF LU DEF MSBU DEF CASC JMP OUTM0,I * @MSBX NOP SPC 1 OUTLF NOP JSB EXEC OUTPUT ONE SPACE DEF *+5 DEF D2 DEF LU DEF MS0+3 DEF DM1 ONLY ONE BYTE JMP OUTLF,I SPC 2 LULAB LDA ASC01 SET ERROR # 1 STA .LGMS+3 INTO THE ERROR MESSAGE LDA D3 SET 'DOWN OR LOCKED' ERROR MESSAGE JSB LOGER SPC 2 LOGER NOP ERROR DUE TO LOGGING DEVICE STA TEMP SAVE ERROR CODE MPY D7 ADA .LGE0 INDEX INTO ERROR MESSAGES LDB .LGM4 MVW D7 AND MOVE THE RIGHT MESSAGE LDA .LGMS RECALL MESSAGE ADDR JSB OUTM AND PRINT OUT "TMS 28 XXXXXXX " * LDA TEMP RECALL ERROR # CPA D3 FATAL ERROR ? JMP ABT3 YES, ABORT THE TMS APPLICATION CPA D2 MAG-TAPE FULL ? RSS YES, WAIT FOR OPERATOR INPUT JMP LOGER,I NO, RETURN TO CALLER * LDA LU SET UP BINARY READ IOR O100 STA TEMP JSB EXEC WAIT FOR ACKNOWLEGEMENT DEF *+5 DEF D1 DEF TEMP DEF TEMP1 DEF DM1 READ ONLY ONE CHARACTER JSB OUTLF JMP LOGER,I RETURN * .LGE0 DEF *+1 ASC 7,WRITE RING ! ASC 7,OFF LINE ! ASC 7,END OF TAPE. _ ASC 7,DOWN OR LOCKED * .LGMS DEF *+1 ASC 11,TMS 35 XXXXXXXXXXXXXX ASC01 ASC 1,01 * .LGM4 DEF .LGMS+5 SPC 2 ERR# NOP * .MS0 DEF MS0 .MS04 DEF MS0+4 .MS08 DEF MS0+8 SPC 1 .IMGT DEF *+1 ASC 12,DBOPN DBCLS TBGET TBFND ASC 12,TBPUT TBUPD TBDEL TBINF ASC 3,TBULK SPC 2 TMLER LDA .PAR1 RECALL ERROR # ADA =D20gI SET IT TO ACTUAL TMS ERROR # STA ERR# JMP ERR GOTO ERROR PROCESSING HED TERMINAL-MONITOR ABORT PROCESSING ABT00 CLA,INA SET SCHEDULE FLAG "WITH WAIT" STA SCHFL SPC 2 LDA IMAGE,I RECALL TMS-IMAGE-MODULE PROGRAM NAME SZA,RSS IMAGE USED ? JMP ABT50 NO, SKIP IMAGE THINGS * LDA IMERC IMAGE IS USED, SET THE IMAGE ERROR STA ERR# JUST IN CASE CLA,INA INIT INDEX INTO BUF STA ABT21 TO,KEEP TRACK OF THE LOCKID RELEASED. * LDA ABT.1 SET UP ADDR. ROUTINE TO UNLOCK STA .IMU2 ALL RECORDS OWN BY THIS TMS LDA ABT.4 APPLICATION. STA .IMU4 JMP IMULK GO RETREIVE ALL LOCKID'S USED SPC 1 ABT.1 DEF *+1 ABT10 NOP STA ABT22 SAVE A REGISTER STX ABT23 SAVE X REGISTER LDA B,I GET THE LOCKID WORD STA TEMP AND SAVE IT AND PIDMK ISOLATE PID (CLEAR DB#) SZA,RSS LOCKID WORD HERE ? JMP ABT17 NO, CONTINUE LDY ABT21 YES, SET UP Y INDEX REG. ABT13 DSY END OF BUFFER ? RSS NO, CHECK IF THE LOCKID IS ALREADY IN BUF JMP ABT15 YES, THIS IS A NEW LOCKID, DO THE UNLOCK LBY BUF+1 RECALL LOCKID ALREADY RELEASED CPB TEMP IS IT THE SAME ? JMP ABT17 YES, ALREADY RELEASED, FORGET IT JMP ABT13 NO, CONTINUE UP TO THE END OF BUF * ABT15 ISZ ABT21 BUMP BUF INDEX LDA ABT21 AND ADD THIS NEW LOCKID CPA =D47 BUF OVERFLOW ? JMP ABT.4,I YES, FORGET ALL THE UNLOCK ADA .BUF NO, SAVE THE NEW LOCKID LDB TEMP INTO BUF AND STB A,I JSB IMULO RELEASE THIS LOCKID JMP ABT17 RETURN OK DST BUF ERROR RETURN, SET UP ERROR CODES JSB ERRPR PRINT THE ERROR MESSAGE ABT17 LDA ABT22 RESTORE A REG. LDX ABT23 RESTORE X REG. JMP ABT10,I AND SEARCH THE NEXT LOCKID URSED * ABT21 NOP ABT22 NOP ABT23 NOP PIDMK OCT 17777 SPC 1 ABT.4 DEF *+1 CLB,INB CLOSE ALL DATA-BASES OPEN ABT43 STB ABT21 BLF,BLF ROTATE DB# INTO BITS 15-13 BLF,RBL CLA,INA CLOSE DATA BASE REQUEST JSB IMRQT JMP ABT50 THE LAST DATA BASE HAS BEEN CLOSED JMP ABT46 RETURN OK, TRY TO CLOSE THE NEXT ONE DST BUF SET UP IMAGE ERROR CODES JSB ERRPR AND PRINT ERROR MESSAGE * ABT46 LDB ABT21 CLOSE THE NEXT DATA BASE INB JMP ABT43 SPC 2 ABT50 LDB LULOG IS A LOGGING DEVICE SZB DEFINED ? JSB CLLOG YES, 'CLOSE' THE LOGG DEVICE SPC 2 JSB OUTLF OUTPUT ONE BLANK LINE SPC 1 JSB STPPR STOP ALL PROGRAM OF THE APPLICATION SPC 1 JSB RECLS RELEASE ALL TMS CLASS I/O SPC 1 ABT3 LDA @$END MOVE "$END" INTO MESSAGE LDB @MSBX MBT D10 JSB EXEC PRINT " /XXXX: $END" DEF *+5 DEF D2 DEF LU DEF MSBU DEF D7 SPC 1 JSB EXEC ABORT TMSYS ITSELF DEF *+4 DEF D6 DEF D0 DEF D0 KILL TMS HEART PROGRAM !! HLT 67B SPC 2 ABTFL OCT 125252 @MSBU DBL MSBU @MSB1 DBL MSBU+1 MSBU ASC 5, /XXXXX: ASC 16, @$END DBL *+1 ASC 5,$END HED ABORT ALL PROGRAMS OF THE APPLICATION STPPR NOP STOP ALL PROGRAM LDA ABTCD GET ABORT CODE (17) STA SCODE SET SPECIAL ABORT INDICATOR CLA SIGNAL TO 'TMLIB' THAT THERE IS STA #DFCB NO CB'S TO RECEIVE !! STA EPAOS NO ENTRY POINT ADDR OF SUBROUTINE !! SPC 1 LDA .TMST JSB SCHUP ABORT "TMST" PROG. HLT 70B JSB EXEC REMOVE THE TMS-TIMER FROM DEF *+6 THE TIME LIST DEF D12 DEF .TMST,I PROGRAM NAME DEF D1 RESOLUTION CODE ( 1/100 SEC) DEF D0 EXECUTION MULT. (ONLY ONCE) DEӧF DM1 START IT NEXT TBG'S TIC * LDA .TMSL JSB SCHUP ABORT "TMSL" PROG. HLT 71B * LDA .TMPR,I SETUP TO ABORT ALL TMS PROGRAM CMA,INA * STPP5 STA $CVTX ABORT ALL TM PROGRAM ADA .TMPR,I I.E.: ALL PROGRAM DECLARED IN MPY UPTEN THE TMSGN TABLE, MULTIPLY BY ENTRY LEN INA ADA .TMPR JSB SCHUP SHEDULE USER PROG TO ABORT IT HLT 72B * LDA $CVTX INA,SZA JMP STPP5 LOOP UNTIL END JMP STPPR,I * ABTCD DEC 17 SPC 3 $CVTX NOP CONVERSION PROGRAM STA $CVTY ERA STA $CVTZ JSB $OFF LDA $CVTY LDB $CVTZ CLE SSB CCE JSB $CVT3 STA $CVTY JSB $ON LDA $CVTY JMP $CVTX,I * $CVTY NOP $CVTZ NOP SPC 1 $OFF NOP JSB $LIBR OCT 0 PRIVILEDGE ROUTINE JMP $OFF,I SPC 1 $ON NOP JSB $LIBX EXIT FROM PRIVILEDGE ROUTINE DEF $ON SPC 2 RECLS NOP RELEASE ALL TMS CLASS I/O SPC 1 LDA MCLAS RELEASE MAIN CLASS I/O JSB KLCLX SPC 1 LDA ICLAS RELEASE INTERNAL CLASS I/O JSB KLCLX SPC 1 LDA CLASS RELEASE EXTERNAL CLASS I/O JSB KLCLX SPC 1 LDA CLAS0 RELEASE TRUE COMMON CLASS I/O JSB KLCLX SPC 1 LDA FMPCL RELEASE TMS-FMP CLASS I/O JSB KLCLX SPC 1 JMP RECLS,I SPC 2 KLCLX NOP STA KLCL3 JSB KLCLS DEF *+2 DEF KLCL3 SZA HLT 73B JMP KLCLX,I * KLCL3 NOP HED UTILITY SUBROUTINE * EMA UTILITY * =========== SPC 1 EMATB DEC 1 ONE DIMENSION ARRAY DEC -1 LOWER BOUNDS WPELE DEC 10 # WORDS/ELEMENT DEC 0,0 OFFSET SPC 1 * LDA CBLAD CB LOGICAL ADDR. (FROM THE STACK) * JSB GCBAD MAP IN C.B.  (1025 WORDS ONLY) * A = ADDR OF WORD CBX(1) (1ST USER WORD) * B,X & Y ARE NOT MODIFIED * GCBAD NOP SZA,RSS CB ALLOCATED ? JMP GCBAD,I NO, FORGET IT DST GCBA0 SAVE A & B REG. CXA SAVE X & Y REG. SINCE EMA SOFTWARE CYB USE THEM, THIS IS THE FASTEST WAY DST GCBA1 TO DO IT. JSB .EMAP CALL EMA ROUTINE DEF *+4 DEF $TMSA EMA NAME DEF EMATB EMA TABLE DEF GCBA0 SUBSCRIPT VALUE (LOGICAL CB ADDR.) JSB ERR0 LDA B SET TRUE ADDR INTO A ADA CBOVH SKIP CB INTERNAL THINGS LDB GCBA0+1 RESTORE B REG. LDX GCBA1 RESTORE X REG. LDY GCBA1+1 RESTORE Y REG. JMP GCBAD,I AND RETURN * GCBA0 BSS 2 GCBA1 BSS 2 * CBOVH EQU D5 MCBOV DEC -5 SPC 1 * LDA CBLAD CB LOGICAL ADDR. (FROM THE STACK) * LDB CBLEN CB LENGTH IN WORDS * JSB MAPCB MAP THE ENTIRE CB * A = ADDR OF WORD CBX(1), (1ST USER WORD) * B IS UNCHANGED * MAPCB NOP GET ACTUAL ADDR. OF A CB * CHECK FOR 1025 ( 1020 IN FACT) TO USE .EMAP JSB GCBAD JMP MAPCB,I TEMPORARILY !!!!!!!!!!!!!!!!!!!!!!! ADB CBOVH FOR INTERNAL STAFF DST ACBA0 JSB .EMIO CALL EMA ROUTINE DEF *+4 DEF ACBA0+1 BUFFER LENGTH DEF EMATB EMA TABLE DEF ACBA0 SUBSCRIPT VALUE JSB ERR0 ERROR RETURN LDA B SET A=ACTUAL ADDR ADA CBOVH SKIP INTERNAL STAFF LDB ACBA0+1 RESTORE B REG. ADB MCBOV JMP MAPCB,I AND RETURN * ACBA0 BSS 2 SPC 2 * LDA PT ADDR WHERE THE LOGICAL ADDR. IS * TO BE SAVE ( PT INTO THE STACK) * LDB CBLEN CB LENGTH IN WORDS * b JSB ALCB PERFORM THE ALLOCATION AND IF * SUCCESFULL SETUP CB INTERNAL POINTER * AND SAVE CB LOGICAL ADDR. INTO A REG. * ADDRESS. * (P+1) MEMORY SUSPEND RETURN, B=# OF ELEMENT * OF MEMORY REQUIRED * (P+2) RETURN OK, A=ADDR. OF CBX(1) (1ST USER WORD) * AND THE FIRST 1025 WORDS ARE MAPPED. SPC 1 ALCB NOP STA ALCB1 SAVE ADDR IN THE STACK LDA FSTBT RECALL FIRST BIT # OF BIT TABLE JSB ALCB0 AND GO FIND A HOLE IN THE BIT TABLE SSB OK ? JMP .ER13 NO, NEVER OK --> ABORT TMS LDB ALCB4 RECALL # OF ELEMENT REQUIRED SSA IS IT OK NOW ? JMP ALCB,I NO, WAIT --> MEMORY SUSPEND ISZ ALCB YES, SET RETURN ADDR STA ALCB3 AND SAVE THE LOGICAL ADDR OF THE CB * JSB BITST SET THAT PIECE OF MEMORY ALLOCATED DEF *+5 BY SETTING CORESPONDING BITS TO 1 DEF .BITB,I BIT TABLE ADDR DEF ALCB3 STARTING BIT OF THE ZONE DEF ALCB4 NUMBER OF BIT TO SET DEF D1 VALUE TO SET THE BIT * LDA ALCB3 RECALL LOGICAL ADDR OF CB JSB GCBAD MAP THE FIRST 1025 WORDS OF IT ADA DM1 AND INITIALIZE THE 5 FIRST WORDS LDB ALCB2 STB A,I CB LENGTH IN WORDS (-1) ADA DM1 LDB Q STB A,I CURRENT Q VALUE (-2) ADA DM1 LDB ALCB1,I RECALL LOGICAL ADDR OF STB A,I PREVIOUS COMMON BLOCK (-3) ADA DM1 LDB ALCB1 ADDR WHERE THAT CB IS SAVED (-4) STB A,I LDB ALCB3 STORE LOGICAL ADDR. OF THIS CB STB ALCB1,I WHERE IT SHOULD BE SAVED (STACK USUALLY) NLHHN ADA DM1 LDB ALCB4 RECALL CB LENGTH IN STB A,I NUMBER OF ELEMENT (-5) ADA CBOVH RESTORE CB ADDR. OF CBX(1) (1ST USER WORD) JMP ALCB,I * ALCB1 NOP ALCB2 NOP ALCB3 NOP ALCB4 NOP ALCB5 NOP SPC 2 ALCB0 NOP STA ALCB5 SAVE 1ST BIT # IN THE TABLE STB ALCB2 SAVE CB LENGTH IN WORDS LDA B GET CB LENGTH ADA CBOVH AND ADD LENGTH FOR INTERNAL CB DATA CLB TO COMPUTE LEN IN NUMBER OF ELEMENT DIV WPELE BY DIVIDING BY THE # OF WORDS / ELEMENT SZB IF REMAINDER NOT ZERO INA NEED ONE MORE ELEMENT STA ALCB4 SAVE LENGTH IN # OF ELEMENT CMA,INA AND CHECK THAT THIS LENGTH ADA LSTBT DOES NOT EXEED THE TOTAL LENGTH SSA EVER AVAILABLE .ER13 JSB ERRAB TOO BAD. CB IS TOO BIG --> ABORT TMS JSB BITSR SEARCH INTO THE BIT TABLE DEF *+5 FOR A HOLE BIG ENOUGH .BITB NOP BIT TABLE ADDR DEF ALCB5 FIRST BIT NUMBER OF THE TABLE DEF LSTBT LAST BIT NUMBER OF THE TABLE DEF ALCB4 NUMBER OF BIT NEEDED JMP ALCB0,I SPC 2 * THIS SUBROUTINE RELEASE ALLOCATED COMMON-BLOCK * * IT RELEASES CB WITH A "CURRENT Q VALUE" > Q, * IF RECURSIVE ALLOCATION EXIT, THIS SUBROUTINE * WILL LINK THE NEW CB IN PLACE OF THE CURRENT ONE, * THE MEMORY OCCUPIED BY THE DEALLOCATED CB IS * RELEASED AND THE TOTAL MEMORY RELEASED (IN NUMBER * OF ELEMENT) IS SAVED IN TEMP. SPC 1 RLCB NOP LDX D5 INIT X REG TO CHECK ALL CB'S CLA INIT # OF ELEMENT IN MEMORY RELEASED STA TEMP * RLCB2 LAX PT,I GET ACTUAL CB ADDR. SZA,RSS CB ALLOCATED ? JMP RLCB8 NO, CHECK NEXT ONE STA ALCB3 YES, SAVE LOGICAL ADDR. JSB GCBAD  MAP THE 1025 FIRST WORDS OF THIS CB ADA DM2 CHECK IF DE-ALLOCATED LDB A,I IS NEEDED, GET Q AT TIME CMB,INB OF ALLOCATED ADB Q Q NOW - Q AT ALLOC. TIME SSB,RSS DEALLOCATED NEEDED ? JMP RLCB8 NO, CHECK NEXT ONE ADA DM1 YES, RESOLVE RECURSIVE ALLOCATION LDB A,I GET ACTUAL CB ADDR. OF PREVIOUS LEVEL SBX PT,I AND PUT IT IN THE STACK ADA DM2 LDB A,I GET # OF ELEMENT STB ALCB4 SAVE IT TO CLEAR THOSE BITS ADB TEMP AND ACCUMULATE THIS TO KNOW HOW MANY STB TEMP ELEMENTS HAVE BEEN RELEASED * JSB BITST CLEAR BITS IN THE BIT TABLE DEF *+5 DEF .BITB,I BIT TABLE ADDR DEF ALCB3 STARTING BIT NUMBER DEF ALCB4 # OF BITS TO BE CLEARED DEF D0 CLEAR THE BITS, AND CHECK AGAIN JMP RLCB2 FOR THE NEW CB ADDR. (RECURSIVE ALLOC.) * RLCB8 DSX MORE COMMON BLOCK JMP RLCB2 YES, CONTINUE JMP RLCB,I NO, RETURN * FSTBT NOP FIRST BIT NUMBER OF THE BIT TABLE LSTBT NOP LAST BIT NUMBER OF THE BIT TABLE SKP * ENABLE/DESABLE COMMON BLOCK ROUTINE: * ------------------------------------- SPC 1 * 'STKPT' & 'Q' VARIABLE MUST BE SET UP BEFORE * USING ANY OF THE FOLLOWING ROUTINE. * * LDB CB# B=CB NUMBER * JSB COM.U * RETURN (P+1) * A=ACTUAL ADDR INTO EMA ARRAY * B=CURRENT LENGTH WITH BIT15=ENABLE FLAG * Y=INDEX TO GET LOGICAL ADDR FROM STACK * LCBLP=ADDR OF LOCAL CB LENGTH IN THE STACK * CCBLP=ADDR OF CURRENT CB LENGTH IN THE STACK SPC 1 COM.U NOP COMMON BLOCK ENABLE/DISABLE UTILITY CBY Y=CB # ISY TO ACCESS CORRESPONDING LOGICAL ADf`DR BLS MPY D2 ADB QCBLA ADD DISPLACEMENT FROM Q TO CB1 LOCAL ADDR ADB Q ADD Q VALUE TO GET POINTER IN THE STACK STB LCBLP SAVE POINTER TO LOCAL CB LENGTH ADB DM1 STB CCBLP SAVE POINTER TO CURRENT CB LENGTH LAY STKPT,I GET LOGICAL CB ADDRESS FROM STACK JSB GCBAD MAP THE 1025 FIRST WORDS OF THE CB LDB B,I GET CURRENT CB LEN & BIT15=ENABLE FLAG JMP COM.U,I * LCBLP NOP CCBLP NOP SPC 1 COM.E NOP ENABLE ONE COMMON BLOCK JSB COM.U SET A,B,Y,CCBLP & LCBLP, MAP 1ST 1025 WORDS CPB BIT15 B=CURRENT LEN., DOES LOCAL CB EXIST ? JMP CO4.E NO, EXIT WITOUT ALLOCATION SZA ALLOCATED ? JMP CO2.E YES, IT IS ALLOCATED SSB,RSS NO, ENABLE ? HLT 13B YES, ENABLE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CO1.E RBL,CLE,ERB NO, SET BIT15 TO INDICATE ENABLE STB CCBLP,I AND STORE BACK IN THE STACK CYA Y --> A ADA STKPT TO HAVE POINTER INTO THE STACK JSB ALCB ALLOCATE THE MEMORY FOR THE CB JMP COM.E,I RETURN P+1, PUT IN MEMORY SUSPEND ! CO9.E ISZ COM.E RETURN OK (P+2) JMP COM.E,I * CO2.E SSB,RSS ALREADY ENABLE ? JMP CO5.E YES, IT MUST BE A LOCAL ENABLE RBL,CLE,ERB NO, SET BIT15 TO INDICATE ENABLE STB CCBLP,I AND STORE CURRENT LENGTH IN THE STACK CMB,INB STA COM.U SAVE A ADA DM1 VERIFY CURRENT LENGTH VS ACTUAL SIZE LDA A,I GET ACTUAL SIZE ADB A ACTUAL SIZE - LOCAL SIZE SSB ACTUAL GREATER ? STA CCBLP,I NO, CHANGE CURRENT SIZE TO ACTUAL SIZE LDA COM.U YES, RESTORE A TO ACTUAL COMMON ADDR JMP CO9.E SPC 1 CO4.E CLA INDICATE NO ALLOCATION DONE JMP CO9.E * CO5.E ADA DM2 LOCAL ENABLE PROCESS LDA A,I CPA Q SECOND ENABLE IN THE SAME ROUTINE ? .ER06 JSB ERRAB YES, ERROR # 6 --> ABORT TMS JMP CO1.E NO, PERFORM RECURSIVE ALLOCATION OF CB SPC 3 COM.D NOP DESABLE ONE COMMON BLOCK JSB COM.U SZA,RSS ALLOCATED ? .ER16 JSB ERRAB NO, NOT ALLOCATED, ERROR !! SSB YES, ENABLE ? .ER17 JSB ERRAB NO, NOT ENABLED, ERROR !! * ADA DM2 LDB =B77777 SET A LARGE Q VALUE STB A,I TO RETURN MEMORY WITH 'CLECO' ROUTINE ADA DM1 LDB A,I CHECK FOR RECURSIVE ENABLE CCE,SZB RECURSIVELY ENABLED ? JMP COM.D,I YES, SO LEAVE THIS CB ENABLED LDB CCBLP,I NO, INDICATE THAT CB IS RBL,ERB NOW DISABLED. STB CCBLP,I JMP COM.D,I RETURN SPC 3 MEMOK NOP A=POINTER TO CB LOCAL ADDR STA TEMP1 SAVE IT * LDA =D12 INIT MEMORY NEEDED (12) FOR STA SPR38 THE 11 WORDS BLOCK (SUB-PRO LAUNCH) CLA,INA SET UP 1ST BIT NUMBER STA TEMP2 CLA INIT STA TEMP3 TOTAL NUMBER OF ELEMENT NEEDED STA TEMP4 FAIL/SUCCES FLAG (0=OK) * MEMO3 LDA TEMP1,I SZA,RSS CB DEFINED HERE ? JMP MEMO6 END OF CALLING SEQUENCE: NO MORE CB'S JSB GECB# YES, RETREIVE CB # JSB COM.U INIT A,B AND Y REG., MAP THE FIRST 1025 WORDS RBL,CLE,ERB CLEAR BIT 15 OF CB LENGTH IN WORD LDA TEMP2 RECALL STARTING BIT NUMBER JSB ALCB0 AND TRY TO ALLOCATE MEMORY LDB ALCB4 RECALL CB LENGTH IN # OF ELEMENT SSA,RSS ALLOCATION OK ? JMP MEMO4 YES, CONTINUE STA TEMP4 NO, SET FAIL FLAG LDA LSTBT AND SET FIRST BIT TO LAST BIT NUMBER JMP MEMO5 MEMO4 ADA B COMPUTE THE NEW FIRST BIT NUMBER MEMO5 STA TEMP2 SET NEW FIRST BIT NUMBER ADB TEMP3 ACCUMULATE NEEDED NUMBER OF ELEMENT STB TEMP3 INTO TEMP3 LDA ALCB2 RECALL CB LEN IN WORDS (SAVED BY 'ALCB0') LDB SPR38 RECALL OLD MAX CB LENGTH CMB,INB TO SAVE INTO 'SPR38' THE MAXIMUM CB LEN ADB A CURRENT CB LENGTH - MAX CB LEN SSB,RSS CURRENT - MAX >= 0 ? STA SPR38 YES, SET NEW MAXIMUM CB LEN ISZ TEMP1 GET NEXT CB FROM THE CALLING SEQUENCE JMP MEMO3 AND CONTINUE * MEMO6 LDA TEMP4 RECALL THE FLAG SZA,RSS OK ? JMP MEMOK,I YES, RETURN SPC 1 * PUT THAT PROCESS IN MEMORY SUSPEND * ---------------------------------- SPC 1 MSU05 LDB TEMP3 RECALL THE TOTAL # OF ELEMENT REQUIRED MSU10 LDA MSUFL RECALL MEMORY SUSP. FLAG SZA SUSPEND OK ? JMP MSU20 NO, DO NOT SUSPEND THE PROCESS LDA STKPT YES, SUSPEND CURRENT PROCESS ADA =D7 SAVE # OF ELEMENT REQUIRED STB A,I IN THE STACK INA SAVE ALSO CURRENT SUBROUTINE CODE LDB SCODE IN THE STB A,I STACK INA STA TEMP SAVE ADDR OF THE LINK WORD * LDB .MSUP MEMORY SUSPEND QUEUE HEAD MSU12 LDA B,I SZA,RSS JMP MSU14 END OF QUEUE LDB A LOOP UNTIL JMP MSU12 END OF QUEUE IS REACHED * MSU14 STA TEMP,I SET END OF QUEUE IN THE NEW LINK LDA TEMP AND LINK STA B,I NEW STACK IN THE QUEUE. * LDA ..PA1 SAVE CALLING SEQUENCE PARAMETERS LDB S IN THE STACK MVW D10 THERE IS ALWAYS 10 EXTRA FREE WORDS JMP IDLE ON THE STACK ! GOTO IDLE LOOP SPC 1 MSUCD DEC 21 MSUFL NOP MEMORY SUSPEND FLAG (0 --> SUSP.) .MSUP DEF *+1 MEMORY SUSPEND QUEUE HEAD OCT 0 SPC 2 MSU20 LDB Q DO NOT SUSPEND THAT PROCESS, RETURN INB TO THE PROCESS AT THE SPECIAL STA B,I RETURN ADDR. PROVIDED IN THE JMP EXITZ CALLING SEQUENCE. SPC 3 DSTAK NOP DE-STACK ONE LEVEL LDA Q ADA DM1 A IS THE NEW S REGISTER LDB A,I GET MINUS DELTA Q ADB Q B IS THE NEW Q REGISTER DST STKPT,I SAVE S & Q REGISTER IN THE STACK DST S SET NEW S & Q VALUE JMP DSTAK,I SPC 2 CLECO NOP CLEAR ALL NEEDED COMMON BLOCK LDB STKPT RELATED TO THE STATE OF INB THE STACK. STB PT INB POINTER TO ACTUAL ADDR. OF CB1 LDA B,I GET CB1 ADDR JSB GCBAD MAP 1025 FIRST WORDS OF THAT CB LDA A,I GET LU ASSOCIATED WITH THAT STACK ADB =D5 STA B,I AND SAVE IT INTO THE STACK (INTO TEMP1) * JSB RLCB RELEASE THE MEMORY * LDA TEMP MEMORY HAS BEEN RELEASED ? SZA,RSS JMP CLECO,I NO MEMORY RETURNED. CMA,INA MAKE # OF ELEMENT AVAILABLE STA TEMP NEGATIVE. SPC 1 LDB .MSUP TRY TO RESTART SOME PROCESSES * CLEC8 LDA B,I SZA,RSS END OF MEMORY SUSPEND QUEUE ? JMP CLECO,I YES, EXIT STB TEMP1 SAVE QUEUE POINTER STA B ADA =D-2 TO GET REQUESTED LEN LDA A,I A = PROCESS REQUESTED MEMORY LEN ADA TEMP ENOUGH AVAILABLE ? SSA,RSS JMP CLEC8 NO, TRY ANOTHER PROCESS * STA TEMP AJUST FREE MEMORY LEN LDA B,I DEQUEUE THIS PROCESS STA TEMP1,I BY LINKING NEXT ONE CLA STA B,I CLEAR LINK WORD IN THIS STACK LDA SCODE SAVE CURRENT PROCESS SUBROUTINE CODE STA TEMP2 LDA STKPT AND SAVE CURRENT PROCESS STACK ADDR STA TEMP3 LDA MSUCD SET MEMORY SUSPEND SUBROUTINE CODE STA SCODE ADB =D-9 STB STKPT JSB WRI/O REQUEUE THIS PROCESS TO RESTART IT LDA TEMP2 RESTORE CURRENT PROCESS PARAMETERS STA SCODE (SUBROUTINE CODE AND STACK POINTER) LDA TEMP3 STA STKPT LDB TEMP1 RESTORE MEMORY SUSPEND QUEUE POINTER JMP CLEC8 AN~D LOOP UNTIL END OF QUEUE SPC 2 * RETREIVE THE NUMBER OF THE COMMON BLOCK FROM * THE LOCAL CB ADDR * THIS ROUTINE MUST NOT BE USED FOR CB # 1 * * LDA LCBAD A=LOCAL CB ADDR * JSB GECB# * RETURN (P+1) * B = CB# * * IF THE CB IS NOT FOUND, THE TMS APPLICATION * IS ABORTED WITH ERROR # 15 SPC 1 GECB# NOP GET CB# FROM LOCAL CB ADDR. IN A REG STA RELBU SAVE LOCAL CB ADDR CLA INIT THE CB # STA TEMP LDA Q ADA QCBLA TO ACCESS THE FIRST CB LOCAL ADDR LDX A,I GET CB1 LOCAL ADDR * GEC3# INA BUMP STACK POINTER CPA S END OF STACK ? .ER15 JSB ERRAB YES, UNKNOWN OR ILLEGAL CB ADR, ERROR !! ISZ TEMP BUMP CB # INA TO ACCESS LOCAL CB LENGTH LDB A,I GET CB LOCAL LENGTH SZB,RSS LOCAL LENGTH NUL ? JMP GEC3# YES, GO TO NEXT CB XBX X=CB LENGTH, B=CB LOCAL ADDR. ADX B MAINTAIN X=LOCAL CB ADDR CPB RELBU IS IT THIS CB ? RSS YES, CHECK FOR CB # 1 JMP GEC3# NO, CONTINUE LDB TEMP RECALL CB# CPB D1 IS IT CB1 ? JMP .ER15 YES, IT MUST NOT BE --> ABORT TMS JMP GECB#,I NO, RETURN WITH B=CB# SPC 3 RELBU NOP RELEASE BUFFER CLASS JSB EXEC DEF *+8 DEF D21 DEF CLASS DEF BUF DEF D10 DEF TEMP DEF TEMP1 DEF TEMP2 SSA HLT 74B JMP RELBU,I SPC 2 SETST NOP SAVE STATUS & TLOG INTO CB1 WORD 4 & 5 CAX SAVE A INTO X REG LDA STKPT SETUP TO SAVE STATUS & TLOG SZA,RSS STACK DEFINED ? JMP SETST,I NO, FORGET IT ADA D2 YES, ACCESS FIRST COMMON BLOCK LDA A,I 6 GET COMMON LOGICAL ADDR SZA,RSS CB1 ALLOCATED ? JMP SETST,I NO, FORGET IT JSB GCBAD YES, MAP THE CB TO STORE STATUS & TLOG XAX RESTORE STAT IN A, SET X=CB ADDR SAX 3B STORE STATUS SBX 4B STORE TLOG JMP SETST,I SPC 2 WRI/O NOP EXECUTE A WRITE/READ CLASS I/O JSB EXEC DEF *+8 DEF D20 WRITE/READ DEF D0 DUMMY LU DEF BUF DUMMY BUFFER DEF WRI/L DUMMY LENGTH DEF STKPT STACK ADDRESS DEF SCODE SUBROUTINE CODE DEF CLASS CLASS WORD JMP WRI/O,I * WRI/L DEC 5 SPC 2 GTCLW NOP GET A CLASS I/O WORD FROM SYSTEM LDA CLASS SAVE THE CLASS WORD STA TEMP3 CLA INIT TO ZERO TO GET ONE CLASS STA CLASS JSB WRI/O DO A WRITE/READ REQUEST LDA CLASS RECALL THE CLASS WORD IOR BIT13 AND MERGE BIT 13 TO NOT DEALLOCATE STA CLASS THE CLASS NUMBER. JSB RELBU RELEASE THE BUFFER CLASS LDA CLASS A REG. IS THE NEW CLASS NUMBER LDB TEMP3 RESTORE WORD "CLASS" STB CLASS JMP GTCLW,I RETURN WITH A=CLASS I/O WORD SPC 2 SCHUP NOP SCHEDULE A USER PROGRAM (GROUPING OF TMSUB) STA SCHU7 SAVE PARTITION NAME ADDR STA SRFLG SET SEND MAIL BOX FLAG LDB SCHFL RECALL SCHEDULE FLAG (0 --> NO-WAIT) LDA A,I GET FIRST 2 CHAR. OF THE NAME OR SSA,RSS CLASS WORD, CLASS WORD ? JMP SCHU3 NO, GO SCHEDULE PROGRAM AND =B17777 YES, CLEAR BIT 15 OF CLASS WORD SZB,RSS WAIT / NO WAIT ? STB SCHU7 NO WAIT, CLEAR THE FLAG LDB ICLAS PUT LOCAL CLASS WORD INSTEAD OF STA ICLAS TMS INTERNAL CLASS WORD STB SCHRQ SAVE TEMPORARILY INTERNAL CLASS WORD * JSB MAILB DEF SCODE #PARG ABS PARLG * LDA SCHRQ RESTORE TMS INTERNAL CLASS WORD w STA ICLAS LDA SCHU7 WAIT / NO-WAIT REQUEST ? SZA,RSS JMP SCHU8 NO WAIT REQUEST, RETURN IMMEDIATLY * ISZ SCHU7 REQUEST WITH WAIT OPTION SCHU1 LDA DM2 WAIT UNTIL PRG GO TO 'DORMANT' STATE LDB .SCH2 CHEK ROUTINE ADDR JSB WAIT JMP SCHU1 LOOP UNTIL PRG IS DORMANT * .SCH2 DEF *+1 CHECK ROUTINE ADDR NOP CHECK ROUTINE ENTRY POINT LDA SCHU7,I VERIFY THAT PROGRAM IS NOW 'DORMANT' ADA =D15 XLA A,I GET STATUS AND =B17 ISOLATE STATUS SZA DORMANT ? JMP .SCH2+1,I NO, WAIT LONGER JMP SCHU8 YES, EXIT SPC 1 SCHU3 LDA NAB24 GET NO WAIT - NO ABORT CODE SZB REQUEST WITH WAIT ? LDA NAB23 YES, GET WAIT - NO ABORT CODE STA SCHRQ JSB EXEC SCHEDULE REQUEST DEF *+10 DEF SCHRQ QUEUE SCHEDULE - NO ABORT SCHU7 NOP PROGRAM NAME DEF LU LU USED TO START UP THE TMS APPLICATION DEF CLASS TMS EXTERNAL CLASS I/O WORD DEF MCLAS MAIN CLASS I/O WORD DEF ICLAS TMS INTERNAL CLASS I/O WORD DEF CLAS0 TMS CLASS I/O WORD USED FOR CB0 DEF SCODE BUFFER SEND TO PROGRAM DEF #PARG BUFFER LENGTH JMP SCHUP,I ERROR RETURN SCHU8 ISZ SCHUP AND RETURN OK TO USER JMP SCHUP,I * SCHRQ NOP SCHFL NOP NAB23 OCT 100027 NAB24 OCT 100030 SPC 2 MAILB NOP SEND/RECEIVE MAIL-BOX TO/FROM TMLIB DST PARM1 LDA MAILB,I CALLING SEQUENCE: JSB MAILB STA MAIL2 ----------------- DEF BUFF BUF ADDR ISZ MAILB DEC 10 BUF LENGTH LDA SRFLG SZA SEND OR RECEIVE ? JMP MAIL5 SEND MAIL BOX JSB EXEC DEF *+7 DEF D21 CLASS I/O GET DEF ICLAS INTERNAL CLASS I/O WORD MAIL2 NOP DEF MAILB,I BUFFER LENGTH DEF PARM1 DEzF PARM2 SSA HLT 75B ISZ MAILB AJUST RETURN ADDR DLD PARM1 JMP MAILB,I * MAIL5 JSB EXEC DEF *+8 DEF D20 WRITE/READ CLASS I/O CALL DEF D0 DUMMY LU DEF MAIL2,I BUFFER ADDR DEF MAILB,I BUFFER LENGTH DEF PARM1 DEF PARM2 DEF ICLAS INTERNAL CLASS I/O WORD SZA WAS IT OK HLT 76B ISZ MAILB AJUST RETURN ADDR JMP MAILB,I SPC 1 SRFLG NOP SEND/RECEIVE FLAG FOR MAIL-BOX SEND/RECEI. ROUTINE HED CONSTANTS & VARIABLES PARM1 NOP PARM2 NOP * S NOP DO NOT DISTURB NEXT WORDS Q NOP S0 DEC 13,12 (INITIAL S & Q RELATIVE VALUE) TEMP NOP DO NOT DISTURB NEXT WORDS TEMP1 NOP TEMP2 NOP TEMP3 NOP TEMP4 NOP SPC 2 I.TAB DEF *+1,I DEF ILRQ 0 DEF STKPA 1 READ: STACK PARAMETERS DEF IDLE 2 DEF IDLE 3 DEF ILRQ 4 DEF ILRQ 5 DEF CBENB 6 CB ENABLE DEF CBDES 7 CB DISABLE DEF SBCAL 8 DEF DFINE 9 DEF SBRTN 10 DEF STKPA 11 WRITE-READ: STACK PARAMETERS DEF PAUS 12 PAUS REQUEST DEF SPRL 13 SUB-PROCESS LAUNCHING DEF CBLEN 14 CHANGE CB LENGTH DEF SIF 15 SET/RESET STOP-INHIBIT FLAG DEF ILRQ 16 UNLCK-IMAGE FUNCTION (NEVER COME HERE) DEF TMAB 17 ABORT TMS (RQ FROM TMLIB) DEF ILRQ 18 PROCESS LAUNCH FROM 'TMSL' (NEVER RETURN) DEF ILRQ 19 TIMER INTERRUPT (NEVER RETURN) DEF TMSP 20 STOP TMS (RQ FROM TMLIB) DEF ILRQ 21 MEMORY SUSPEND OPERATION DEF DFN10 22 SPECIAL -DEFIN CB'S- OPCODE DEF IMGRQ 23 IMAGE REQUEST STACK PARAMETERS ADDR DEF IDLE 24 LOGGING REQUEST DEF ILRQ 25 STOP TMS IN PROGRESS (NEVER COME HERE) SPC 1 C.TAB DEF *+1,I DEF START 0 START: START UP INITIALS PROCESSES DEF EXIT3 1 READ, REQUEUE THE BUFFER & RETURN TO USER DEF IDL02 2 WRITE, RELEASE THE BUFFER & RETURN TO USER DEF IDL02 3 CNTL, RELEASE THE BUFFER & RETURN TO USER DEF IDL00 4 BUF. WRITE, RELEASE BUFFER & FORGET DEF IDL00 5 BUF. CNTL, RELEASE BUFFER & FORGET DEF IDL04 6 CB ENABLE, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL04 7 CB DISABLE, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL06 8 SB CALL, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL04 9 CB DEF., RELEASE DUMMY BUF. & RETURN TO USER DEF IDL06 10 SB RTN, RELEASE DUMMY BUF. & RETURN TO USER DEF WRRQ 11 WRITE-READ, DO THE READ DEF IDL04 12 PAUSE, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL06 13 SUB-PROCESS DEF ILRQ 14 CHANGE CB LENGTH DEF ILRQ 15 SET/RESET STP-INHIBIT FLG (NEVER GET HERE) DEF IMULK 16 UNLCK-IMAGE FUNCTION DEF ABTX 17 ABORT TMS (RQ FORM 'TMSL') DEF SPR00 18 PROCESS LAUNCH FROM 'TMSL' DEF PAUS0 19 TIMER INTERRUPT DEF STPX 20 STOP TMS (RQ FROM 'TMSL') DEF MSU50 21 MEMORY SUSPEND OPERATION DEF ILRQ 22 SPECIAL DEFINE OPCODE (NEVER GET HERE) DEF IMRTN 23 IMAGE REQUEST RETURN DEF LOGRT 24 LOGGING REQUEST COMPLETED DEF TMSPX 25 STOP TMS IN PROGRESS SPC 2 DM3 DEC -3 DM2 DEC -2 DM1 DEC -1 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D6 DEC 6 D20 DEC 20 D21 DEC 21 D22 DEC 22 * BIT15 OCT 100000 HED *** BUFFER EXCHANGED BETWEEN TMLIB & TMSYS *** * BUFFER RECEIVED FROM TMLIB * IDENTIFY THE TMS REQUEST THAT MUST BE EXECUTED SPC 1 LCLAS NOP CLASS I/O USED BY THE PRG. TO SUSP. ITSELF .PAR1 NOP USER PARAMETERS VALUE ARE RECIEVED HERE .PAR2 NOP .PAR3 NOP .PAR4 NOP .PAR5 NOP BSS 10 RQCNT NOP XSUSP NOP HFBSCOD. NOP SUBROUTINE CODE RETURNED BY TMLIB RTRN. NOP RETURN ADDR IN THE USER PARTITION SPC 1 PARLN EQU RTRN.-LCLAS+1 SPC 2 * BUFFERS SEND BY TMSYS TO TMLIB * DEFINE ALL CLASS I/O WORD TO BE USED, * DEFINE THE CB LOCAL ADDR & LENGTH, * AND GIVE SOME USEFUL INFORMATION TOO SPC 1 * 5 PARAMETERS SEND AS PRG PARAMETERS SPC 1 LU NOP LU USED TO START THE TMS APPLICATION CLASS NOP TMS EXTERNAL CLASS I/O WORD MCLAS NOP TMS MAIN CLASS I/O WORD ICLAS NOP TMS INTERNAL CLASS I/O WORD CLAS0 NOP TMS CB0 SPECIAL CLASS I/O WORD SPC 2 * BUFFER PASSES USING THE STRING PASSING FEATURE SPC 1 SCODE OCT 0 TMS INTERNAL SUBR. CODE SEND BACK TO COMPLETE THE RQ FMPCL NOP TMS-FMP CLASS I/O WORD LEN0 NOP CURRENT CB0 LENGTH #DFCB NOP MINUS # OF DEFINED CB'S EPAOS NOP 'ENTRY POINT ADDR OF SUBROUTINE' RTRNA NOP RETURN ADDR / ABORT CODE RNLCK NOP RN# USED BY LURQ STKPT OCT 100001 STACK POINTER LULOG DEC 0 LU OF THE LOGGING DEVICE BSS 4 OR FILE NAME,CR,SC FPARM BSS 3 FUNCTION PARAMETERS (3 WORDS) BSS 11 CB'S DEFINITION SPC 1 PARLG EQU *-SCODE #FPAR EQU D3 SPC 1 BUF BSS 50 SKP UNS SPC 3 ORG * END 5H E6 92903-18103 1805 S C0122 &.UPIO              H0101 sASMB HED . UP I/O DEVICE IF LU OR EQT IS DOWN NAM .UPIO,7 92903-16100 REV.1805 780526 SPC 3 ********************************************************************** * * * NAME: .UPIO UP AN I/O DEVICE * * SOURCE: &.UPIO 92903-18103 * * BINARY: %.UPIO ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT .UPIO EXT DRTEQ,MESSS * A EQU 0 B EQU 1 SUP SPC 2 * THIS SUBROUTINE DO A "UP,EQT#" IF THE LU OR * THE EQT IS DOWN. * * CALLING SEQUENCE: * LDA LU# * JSB .UPIO * JMP ERROR ERROR RETURN (ILLEGAL LU OR CAN'T UP DEVICE) * NORMAL RETURN * A = EQT # * B = STATUS (EQT5 CONTENT) SPC 3 .UPIO NOP STA TEMP SAVE LU STA TEMP1 SET FIRST TIME FLAG UPIO2 JSB DRTEQ GET EQT # DEF *+2 DEF TEMP LU AND =B77 STA TEMP2 SAVE EQT # SZB,RSS LU DEFINED ? JMP .UPIO,I NO, ERROR RETURN IN P+1 SSB LU OK ? JMP .UPIO,I NO, ERROR RETURN IN P+1 ADB =D4 YES, LU IS OK, CHECK IF EQT IS DOWN    LDA B,I GET EQT WORD#5 STA TEMP2+1 SAVE IT AND =B140000 ISOLATE BIT 15-14 CPA =B40000 EQT DOWN ? JMP UPIO3 YES, TRY TO UP IT CCA NO, CHECK IF THE LU IS DOWN ADA TEMP INDEX INTO DRT ADA DRT ADA LUMAX TO GET DRT WORD#2 LDA A,I GET DRT WORD#2 SSA LU DOWN ? JMP UPIO3 YES, TRY TO UP THE EQT ISZ .UPIO NO, RETURN OK (P+2) DLD TEMP2 SET A&B JMP .UPIO,I * UPIO3 LDA TEMP1 FIRST TIME THROUGH SZA,RSS ? JMP .UPIO,I NO, ERROR RETURN P+1 CLA YES, SET SECOND TIME FLAG STA TEMP1 LDA TEMP2 RECALL EQT # CLB AND PUT IT INTO DIV =D10 ASCII STRING ALF,ALF ADA B ADA =A00 STA UPIOM+2 JSB MESSS CALL SYSTEM PROCESSOR DEF *+3 DEF UPIOM MESSAGE BUFFER DEF D6 MESSAGE LENGTH JMP UPIO2 CHECK IF OK SPC 2 D6 DEC 6 UPIOM ASC 3, UP,XX TEMP NOP TEMP1 NOP TEMP2 BSS 2 SPC 1 DRT EQU 1652B LUMAX EQU 1653B END @   92903-18104 1805 S C0122 &.LURQ              H0101 zASMB HED . SET UP WORD TO BYPASS THE LU LOCK NAM .LURQ,7 92903-16100 REV.1805 780422 SPC 3 ********************************************************************** * * * NAME: .LURQ BYPASS LU LOCK * * SOURCE: &.LURQ 92903-18104 * * BINARY: %.LURQ ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ********************************************************************** * * * ASSEMBLER CALLING SEQUENCE: * * * * LDA LU A=LU * * JSB .LURQ REQUEST BYPASS LULOCK WORD * * RETURN A=BYPASS LULOCK WORD (TO BE USED IN 9TH PARAM. * * OF EXEC CALL) * * OR A=0 IF THE LU IS NOT LOCKED. * * * * FORTRAN CALLING SEQUENCE: * * o   * * IWORD = LURQW(LU) * * * ********************************************************************** SPC 3 ENT .LURQ,LURQW EXT .ENTR,$RNTB SPC 1 A EQU 0 B EQU 1 SUP SKP .LU NOP LURQW NOP FTN ENTRY POINT JSB .ENTR DEF .LU * LDA .LU,I GET LU JSB .LURQ GET BYPASS LULOCK WORD JMP LURQW,I RETURN TO USER SPC 2 .LURQ NOP AND =B77 ADA DM1 INDEX INTO DRT ADA DRT LDA A,I GET DRT WORD # 1 ALF,ALF A = SUB.CHAN. / RN# / EQT# RAL,RAL ROTATE RN# INTO LEAST BITS AND =B37 ISOLATE LOCK RN # SZA,RSS IF LU IS NOT LOCK JMP .LURQ,I RETURN 0 STA TEMP1 SAVE IT TEMPORARILY LDB .RNTB RSS TRACK DOWN $RN TABLE ADDR LDB B,I RBL,CLE,SLB,ERB PEEL OFF INDIRECT BIT JMP *-2 ADB A INDEX IN RN TABLE XLA B,I GET WORD (OWNER ID/LOCKER ID) RTE-IV --- ALF,ALF PUT LOCKER ON LEFT BYTE AND =B177400 MASK OUT LOCKER IOR TEMP1 MERGE WITH RN # JMP .LURQ,I SPC 1 DM1 DEC -1 TEMP1 NOP .RNTB DEF $RNTB DRT EQU 1652B UNS SPC 2 END +B   92903-18105 1805 S C0122 &MMGT              H0101 ZASMB HED . TMS MEMORY MANAGEMENT SOFTWARE NAM MMGT,7 92903-16100 REV.1805 770128 SPC 3 ********************************************************************** * * * NAME: MMGT TMS MEMORY MANAGEMENT * * SOURCE: &MMGT 92903-18105 * * BINARY: %MMGT ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: G.A.A. * * * ********************************************************************** SPC 3 * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1975. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** SPC 3 ENT .MGTG,.MGTR EXT .MGT0 * * PROGRAMMER: G.A. ANZINGER HP AMD 1 MAY 70 BCS * 24 JUN 74 RTE * F. GAULLIER 20 JUN 76 TMS SKP * REQUESTS MAY BE MADE TO ALLOCATE AND RELEASE BUFFERS * FROM THE MEMORY AVAILABLE AFTER LOADING. * * 1. ALLOCATE: CALLING SEQUENCE - * (P) JSB .MGTG * (P+1) (# OF WORDS NEEDED) * (P+2) -RETURN NO MEMORY EVER (A)=-1, (B)=MAX EVER * (P+3) -RETURN NO MEMORY NOW (A)=0, (B)=MAX NOW * (P+4) -RETURN OK (A)=ADDR , (B)=SIZE OR SIZE+1 * * 2. RELEASE BUFFER TO AVAILABLE MEMORY * (P) JSB .MGTR * (P+1) (FWA OF BUFFER) * (P+2) (# OF WORDS RETURNED) * (P+3) -RETURN- (B)=MAX NOW 1'S COMPLEMENT  * * IF A REQUEST FOR A BUFFER OF LENGTH X CANNOT BE FILLED * DURING A GIVEN CALL, RETURN IS MADE WITH: * (A) = 0 * * IF, WHEN BUFFER REQUESTED, - (AVMEM) - SHOWS INSUFFICIENT CORE * AVAILABLE TO CONTAIN A BUFFER OF THE LENGTH REQUESTED, * THEN RETURN IS MADE WITH: * (A) = -1 * (B) = MAXIMUM LENGTH BUFFER THAT THE PROGRAM MAY ALLOCATE. * * TO FIND OUT HOW LARGE A BUFFER MAY BE ALLOCATED, USE THE CALL * * JSB .MGTG * DEC 32767 * * TO INITIATE THIS PROGRAM, GIVE AVAILABLE MEMORY USING * ENTRY .MGTR AND THEN EXECUTE * JMP .MGTG TO INITIALIZE THE SYSTEM * RETURN IS DONE BY EXTERNAL .MGT0 * * BLOCKS OF MEMORY AVAILABLE FOR OUTPUT BUFFERING ARE LINKED THROUGH * THE FIRST TWO WORDS OF EACH BLOCK - * WORD1 - LENGTH OF BLOCK * WORD2 - ADDRESS OF NEXT BLOCK (OR 77777 IF THIS IS LAST BLOCK) * * THE ALLOCATOR 'TRANSFERS' THE UPPER END OF A BLOCK TO IOC AND * SHORTENS THE LENGTH OF THE BLOCK BY THE AMOUNT 'TRANSFERRED' * * * REGISTERS ARE NOT PRESERVED * SKP .MGTG JMP ALCIN INIT (FROM $STRT, RETURNS TO .MGT0) LDA .MGTG,I GET THE LENGTH OF THE REQUEST STA ADX AND SAVE IT LDB A ADA AVMEM ENOUGH MEMORY NOW SSA TO HONOR THE REQUEST? JMP .A1 YES, GO ALLOCATE. ADB MAXEV SSB,RSS WHAT ABOUT LATER? JMP ERETN NEVER! ISZ .MGTG MAYBE, BUT NOT NOW. REJ CLA,CLE,RSS A=0, E=0 NOT NOW ERETN CCA,CLE A=-1,E=0 NOT EVER JMP SETB RETURN * .A1 ISZ .MGTG TRY AN ALLOCATION CCA SET CORE AVAIL. NOW TO 0 STA ALCIN LDB PNTRA START THE SEARCH LOOP WITH .A2 STB BAD SET LAST BUFFER ADDRESS CLE,INB STEP TO THE NEXT ADDRESS LDB B,I GET THE NEXT SEGMENT ADDRESS CPB M7 IF 77777 THEN END OF LIST AND NO JMP NOMOR MEMORY SO REJECT LDA B,I CHECK TO SEE IF THIS IS THE ADA ALCIN LARGEST LENGTH SO FAR LDA B,I GET THE LENGTH CMA,SEZ SET NEG(-1) AND IF STA ALCIN LARGEST SO FAR SAVE ADA ADX WILL IT SATISFY THE REQUEST? CMA,SSA IF ZERO OR NEGATIVE USE IT JMP .A2 ELSE GO TRY NEXT ONE ADA DM2 IS BLOCK AT LEAST 2 WORDS CCE,SSA LARGER THAN REQUEST? JMP .A4 NO-ALLOCATE WHOLE BLOCK ADA D2 (A)=LENGTH(I)-L(X) STA B,I SET NEW L(I) ADA B (A)=BUFFER ADDRESS JMP SETA RETURN TO USER * .A4 LDA B,I ALLOCATE ENTIRE BLOCK. STA ADX SET BUFFER LENGTH STB A BUFFER ADDRESS TO A CCE,INB SET E FOR ACCEPTED RETURN LDB B,I GET THE POINTER TO THE NEXT BLOCK ISZ BAD STEP TO POINTER ADDRESS IN LAST STB BAD,I BLOCK AND SET THE POINTER SETA ISZ .MGTG SETB LDB MAXEV SET B FOR REJECT SZA,RSS IF JUST FOR NOW RESET TO MAX LDB AVMEM AVAILABLE NOW CMB,SEZ SET POSITIVE AND IF REQUEST LDB ADX SATISFIED SET TO LENGTH ISZ .MGTG STEP RETURN ADDRESS JMP .MGTG,I AND RETURN * NOMOR LDA ALCIN PICK UP MAX LEFT DURING SEARCH STA AVMEM UPDATE MAX AVAILABLE NOW JMP REJ NOW RETURN * * .MGTR NOP ENTRY POINT FOR BUFFER RETURN LDA .MGTR,I (A) = FWA RETURN BUFFER (ADX) STA ADX CMA,INA SET NEG AND STA SAVA SAVE ISZ .MGTR LDA .MGTR,I # OF WORDS RETURNED (X) ADA DM2 SSA <2? JMP RETNR BUFFER TO SMALL - IGNORE LDA PNTRA GET THE STARTING POINTER .R11 STA BAD BAD _ AAD INA LDB A,I AAD _ NEXTBUFAD STB A A _ PNTR ADB SAVA AAD -ADX CMB,SSB,INB,SZB ADXB-AAD>=0? RSS SKIP IF FOUND JMP .R11 ELSE CONTINUE * * * LDB BAD GET LOWER BUFFER ADDRESS CPB PNTRA IF LOCAT POINTER JMP .R3 ASSUME NO OVERLAP ADB B,I ADD LENGTH AND ADB SAVA SUBTRACT THE NEW BLOCK ADDRESS CMB,SSB,INB,RSS IF NEG NO OVERLAP SO JMP .R3 JUMP ADB .MGTR,I ELSE COMPUTE NEW LENGTH ADB BAD,I NOW HAVE NEW +OLD-OVERLAP .R4 STB BAD,I SET LENGTH ;CHECK FOR HIGH OVER- ADB BAD LAP COMPUTE END OF BLOCK CMB,CLE,INB AND SUBTRACT FROM THE HIGH BLOCK ADB A A HAS HIGH BLOCK ADDRESS SEZ,CLE,SZB IF RESULT POSITIVE JMP .R5 JUMP ADB A,I ADD OLD UPPER LENGTH ADB BAD,I CURRENT LENGTH STB BAD,I NEW+OLD-OVERLAP CLE,INA GET POINTER AND BRING LDA A,I DOWN TO NEW BLOCK .R5 LDB BAD,I SAVE MAX LENGTH THIS RETURN ISZ BAD STEP TO POINTER ADRRESS STA BAD,I SET THE POINTER LDA AVMEM CHECK TOO SEE IF THIS LENGTH ADA B ADD CURRENT MAX CMB,SEZ,CLE SET NEG; NEW MAX? STB AVMEM YES; SET IT RETNR ISZ .MGTR LDB AVMEM EXIT WITH B=MAX NOW IN 1'S COMPLEMENT JMP .MGTR,I AND RETURN. * .R3 ISZ BAD NO LOW OVERLAP SET NEW BLOCK LDB ADX ADDRESS IN LOW BLOCK STB BAD,I TO LINK THE BLOCKS STB BAD SET POINTER FOR HIGH BLOCK CHECK LDB .MGTR,I SET B TO THE LENGTH OF RETURN JMP .R4 CHECK FOR HIGH OVERLAP * * * PNTRA DEF AVMEM DUMMY BLOCK ADDRESS(DON'T MESS!) AVMEM OCT -1 DUMMY BLOCK LENGTH (NOT USED) OCT 77777 DUMMY BLOCK END (DON'T MESS!) BAD NOP SAVA NOP M7 OCT 77777 DM2 OCT -2 D2 OCT 2 ADX NOP * ALCIN LDA AVMEM INITIALIZATION CODE MAXEV STA * MAX SIZE BLOCK EVER AVAILABLE JMP .MGT0 JMP TO NEXT STARTUP ROUTINE * A EQU 0 B EQU 1 * BSS 0 LENGTH OF PROGRAM * END   92903-18106 1913 S C0222 &TMLIB              H0102 ASMB HED . T M S L I B R A R Y NAM TMLIB,7 92903-16100 REV.1913 781215 SPC 3 ********************************************************************** * * * NAME: TMLIB TMS LIBRARY * * ENT: TMDFN,TMCBE,TMCBD,TMCBL,TMRD,TMWR,TMBWR,TMCTL,TMBCT * * TMWRD,TMCWR,TMSUB,TMSAB,TMPZ,TMPRO,TMSOP,TMLOG * * SOURCE: &TMLIB 92903-18106 * * BINARY: %TMLIB ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT TMDFN,TMCBE,TMCBD,TMCBL ENT TMRD,TMWR,TMBWR,TMCTL,TMBCT,TMWRD,TMCWR ENT TMSUB,TMSAB,TMPZ,TMPRO,TMSOP,TMLOG ENT TMSTP,TMSIF ENT $TML0,$TML3,$TML5,$TML7,$TML8 * * DUMMY ENT: TMLIB FOR 'TMSAN' A PRINT-OUT UTILITY * $TMSA (EMA NAME) TO RESOLVE UNDEF AT * RTE-IV GENERATION TIME IN %TMSLB. * ENT TMLIB,$TMSA EXT .ENTR,EXEC,&MVW,KLCLS,PNAME,RMPAR SPC 1 A EQU 0 B EQU 1 SUP $TMSA EQU * SPC 2 TMLIB EQU * HED *** DATA RECEIVED BY TMLIB, FROM TMSYS. *** * SPC 2 * FIVE PARAMETERS b{OF THE PROGRAM SPC 1 LU NOP LU USED TO START THE APPLICATION (TMSOP) CLASS NOP TMS EXTERNAL CLASS I/O WORD MCLAS NOP TMS MAIN CLASS I/O WORD ICLAS NOP TMS INTERNAL CLASS I/O WORD CLAS0 NOP TMS CB0 SPECIAL CLASS I/O WORD SPC 2 * BUFFER PASSES USING THE STRING PASSING FEATURE SPC 1 SCODZ NOP TMS INTERNAL SUBROUTINE CODE FMPCL NOP FMP-TMS CLASS I/O WORD LEN0 NOP LENGTH OF THE CB0 (0 MEANS NO CB0) #DFCB NOP MINUS # OF DEFINED CB'S EPAOS NOP 'ENTRY POINT ADDR. OF SUBROUTINE' RTRN NOP RETURN ADDR./ABORT CODE RNLCK NOP RN USED BY LU-LOCK ROUTINE STKPT NOP STACK POINTER (PARAM#1 OF REQUEST ON: CLASS) * LULOG BSS 5 LU OF LOG DEVICE (MT OR FILE NAME) * FPAR1 NOP THREE WORDS USED BY THE TMS FUNCTION FPAR2 NOP FPAR3 NOP * .CB1 NOP LOCAL ADDR OF CB1 .LEN1 BSS 10 CURRENT & LOCAL LENGTH OF ALL CB'S SPC 1 PARLG EQU *-SCODZ HED T-M LIBRARY <---> T-M SOFTWARE COMMUNICATION MODULE EXIT2 CLA DEFAULT VALUE IS 0 LDA .PAR1,I STA .PAR1 SET 1ST PARAMETER VALUE EXIT3 CCB STB SRFLG SET SEND MAIL BOX FLAG SPC 1 LDB LEN0 TRUE COMMON SZB,RSS DEFINED ? JMP EXIT5 NO, SKIP JSB GACB0 GET CB0 ADDR STB EXIT4 JSB EXEC YES, SAVE TRUE COMMON. DEF *+8 DEF D20 WRITE/READ CLASS I/O DEF D0 DUMMY LU EXIT4 NOP BUFFER ADDR DEF LEN0 BUFFER LENGTH DEF D1 BIT0 MEANS CB0 ENABLED DEF TEMP DEF CLAS0 CLASS I/O WORD SZA WAS IT OK JMP ERR01 NO, ABORT TMS WITH INTERNAL ERROR 01 SPC 1 EXIT5 JSB SRCB SEND ALL NECESSARY CB SPC 1 EXIT6 LDA SWFLG LOCAL CLASS I/O SLA,RSS NEEDED ? JMP EXIT7 NO LDA LCLAS LOCAL CLASS I/O SZA,RSS ALREADY ALLOCATED ? JSB GTCLW NO, GET ONE CLASS I/O WORD STA LCLAS STORE IT BACK * EXIT7 LDA MCLAS SWAP THE MAIN & THE INTERNAL LDB ICLAS CLASS I/O WORD STA ICLAS STB MCLAS JSB MAILB RESTART TMSYS BY SENDING THIS MAIL-BOX DEF LCLAS SEND SUBROUTINE SPECIFIC PARAMETER ABS PARLN LDA MCLAS SWAP BACK THE MAIN & INTERNAL LDB ICLAS CLASS I/O WORD STA ICLAS STB MCLAS SPC 1 LDB SWFLG PROGRAM MUST ALLOW SWAPPING SLB,RSS JMP EXIT9 NO, GO TERMINATE 'SERIALLY REUSABLE' SPC 1 LDB LCLAS SWAP THE LOCAL & INTERNAL CLASS I/O STB ICLAS TO USE MAILB SUBROUTINE STA LCLAS * CLA STA SRFLG SET MAIL BOX RECEIVE FLAG * JSB MAILB SUSPEND THIS PROGRAM (--> STATE =3) DEF SCODZ WITH THE GET COMMON DESCRIPTOR #PARG ABS PARLG * LDA ICLAS RESTORE BOTH THE LOCAL AND THE INTERNAL LDB LCLAS CLASS I/O, BY SWAPPING THEM AGAIN STA LCLAS STB ICLAS * JMP RSTR4 SPC 1 EXIT9 JSB EXEC COMPLETE THIS PROGRAM DEF *+4 SERIALLY REUSABLE DEF D6 .D0 DEF D0 DEF DM1 SPC 1 **************************************************************** SPC 1 $TML0 JSB RMPAR TM SYSTEM RETURN TO USER PROGRAM DEF *+2 SAVE PARAMETER DEF LU SPC 2 IFZ JSB .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! EXT .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! XIF SPC 2 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 GET STRING DEF D1 DEF SCODZ BUFFER ADDR DEF #PARG BUFFER LENGTH SZA STRING GET SUCCED ? JMP ILSHR NO, PRINT ERROR MESSAGE CPB #PARG GET RIGHT LENGTH ? RSS YES JMP ILSHR NO, PRINT ERROR MESSAGE * LDA XEQT z GET PRIMARY ENTRY POINT ADA D7 FROM ID SEGMENT XLA A,I RTE-IV !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ADA D2 SKIP THE JMP & NOP STA .NTUS SAVE ADDR OF '# OF TUS' ADA A,I TO SKIP ALL DEF'S INA TO ACCESS THE SWAP FLAG LDA A,I GET SWAP FLAG STA SWFLG SAVE SWAPPING FLAG * CLA STA SRFLG SET MAIL BOX RECEIVE FLAG SPC 1 RSTR4 LDA SCODZ RECALL SUBROUTINE CODE STA SCODE TO SET IT LOCALLY CPA A.RU RUN COMMAND ? JMP ILSHR YES, PRINT ERROR MESSAGE CPA A.ON ON COMMAND ? JMP ILSHR YES, PRINT ERROR COMMAND CPA ABTCD ABORT TMS REQUEST ? JMP RSTR5 YES, DO NOT CHECK MCLAS * LDA MCLAS CHECK IF IT IS A GOOD REQUEST SZA,RSS MAIN CLASS I/O DEFINED ? JMP ILSHR NO, PRINT ERROR MESSAGE SPC 1 RSTR5 JSB SRCB NO, RECEIVE ALL ENABLE COMMON BLOCK DATA * LDB .CB1 GET CB1 ADDR LDA #DFCB GET # OF DEFINED CB'S SZA,RSS CB DEFINED ? JMP RSTR7 NO, USE DUMMY CB1 LDA .LEN1 RECALL CB1 LOCAL LENGTH SSA CB1 ENABLED ? RSTR7 LDB .DCB1 STB .COM1 SET LOCAL COPY OF CB1 ADDR * LDB .SBRT SETUP THE RETURN ADDR. (EPAOS=0 IF STB EPAOS,I NOT DEFINED ) SPC 1 LDA SCODE RECALL SUBROUTINE CODE ADA C.TAB INDEX IN TABLE JMP A,I SPC 1 .DCB1 DEF DCB1 .SBRT DEF TMRTN ABTCD DEC 17 ABORT CODE (TERMINATE THIS PROGRAM) A.RU ASC 1,RU A.ON ASC 1,ON .NTUS NOP ADDR OF '# OF TUS' IN THIS UPT .COM1 NOP LOCAL COPY OF CB1 ADDR * DCB1 BSS 6 DUMMY CB1 SKP ILSHR LDA LU SET UP LU SZA,RSS INA STA LU JSB PNAME RETREIVE PROGRAM NAME DEF *+2 FROM IDSEG DEF MES+1 TO MOVE IT INTO ERROR MESSAGE LDA MES+3 REPLACE 6TH BYTE WITH [IOR A: THE ":" (WAS ALREADY A SPACE) STA MES+3 JSB EXEC OUTPUT DEF *+5 " /XXXXX: ILLEGAL SHEDULE REQUEST ! " DEF D2 DEF LU DEF MES DEF D18 * LDA MCLAS CHECK IF THE TMS APPLICATION SZA IS RUNNING ? JMP EXIT9 YES, DO NOT TERMINATE ! JMP ABORT NO, TERMINATE PROGRAM * MES ASC 4, /XXXXX: ASC 14, ILLEGAL SCHEDULE REQUEST ! A: OCT 72 D0 DEC 0 D1 DEC 1 D2 DEC 2 DM1 DEC -1 D7 DEC 7 HED TERMINAL-MONITOR LIBRARY EXIT TO USER PROGRAM RTN90 CCA,RSS SET CB INDIC. FLAG TO SET STATUS RTN92 CLA SET CB INDIC. FLAG TO NOT SET STATUS STA CBINF SET CB INDICATOR FLAG * LDA LEN0 IS TRUE COMMON (CB0) SZA,RSS DEFINED ? JMP RTN96 NO, SKIP RESTORE JSB GACB0 GET CB0 ADDR STB RTN93 JSB EXEC RESTORE TRUE COMMON DEF *+6 DEF D21 CLASS I/O GET DEF CLAS0 CLASS I/O WORD RTN93 NOP DEF LEN0 DEF TEMP CB INDICATOR UPDATE WORD SSA JMP ERR01 ABORT TMS WITH ERROR 01 LDA CBIND MERGE CB INDICATOR FOR CB0 IOR TEMP INTO CBIND STA CBIND SPC 1 RTN96 ISZ CBINF DOES CB INDIC. NEED TO BE STORE ? JMP RTN99 NO, EXIT CLA YES, SET UP STATUS WORD LDB LULOG SZB LOGGING USED ? IOR BIT7 YES, SET BIT 7 FOR LOGGING IOR CBIND MERGE WITH CB'S ENABLE FLAG LDB .COM1 AND STORE THE STATUS INTO ADB D3 CB1(3) STA B,I SPC 1 RTN99 LDA .COM1 SAVE CB1(1) & CB1[6:13] TO VERIFY LDB .SCB1 THAT THE USER DO NOT MODIFY THEM. MVW D1 SAVE LU ADA D4 SKIP CTLBIT, TYPE, STAT, ITL MVW D8 SAVE CB1[6:13] ADA DM10 TO GET STATUS DLD 0,I A=STATUS, B=TLOG JMP RTRN,I EXIT TO CALLING PROGRAM ! SPC 2 D21 DEC 21 CBINF NOP SWFLG NOP SWAP FLAG .SCB1 DEF *+1 NOP HOLD CB1(1) WHILE USER IS EXECUTING $TML3 BSS 8 HOLD CB1[6:13] WHILE USER IS EXECUTING BIT7 OCT 200 SKP * ABORT TMS APPLICATION: * TERMINATE THIS PROGRAM WITHOUT ANY OPTION * TO MAKE IT ACTUALLY DORMANT. SPC 1 ABT LDB .CLS CHECK IF CLOSE FMP FILE REQUESTED LDA FMPCL RECALL FMP CLASS I/O WORD SZB CLOSE REQUESTED ? JSB B,I YES, GO DO THE CLOSE SPC 1 ABORT JSB KLCLS RELEASE THE LOCAL CLASS I/O DEF *+2 IF ANY DEF LCLAS * LDA .D0 STA .D0+1 SUPPRESS TERMINATE OPTION JMP EXIT9 AND TERMINATE PROGRAM. SPC 2 IMEXT LDB ..PA1 SAVE IMAGE PARAMETERS ADDR INTO MVW PARL STANDARD PARAMETERS LOCATION JMP EXIT3 SAVE CB'S AND GO TO TMSYS SPC 2 DM3 DEC -3 DM10 DEC -10 HED GENERAL TRANSFERT PARAMETER GETPA NOP LDB GETPA ADB DM3 LDB B,I STB RTRN. ADB DM1 STB XSUSP STA SCODE SET UP TMS INTERNAL SUBROUTINE CODE LDX PAR# CLA CLEAR FUTUR PARAMETERS ADRESSES SAX .PAR1-1 TO KNOW HOW MANY PARAMETERS ARE DSX PASSED JMP *-3 JMP RTRN.+1 HED *** DATA SEND BY TMLIB, TO TMSYS. *** * SPC 2 * BUFFER PASSES USING A MAIL BOX SPC 1 LCLAS OCT 0 LOCAL CLASS I/O WORD USED TO SUSP. ITSELF .PAR1 NOP USER PARAMETERS ADDR. ARE SET UP .PAR2 NOP HERE BY .ENTR .PAR3 NOP .PAR4 NOP .PAR5 NOP BSS 10 RQCNT NOP XSUSP NOP SCODE NOP SUBROUTINE CODE TO BE SEND TO TMSYS RTRN. NOP RETURN ADDR. TO BE SEND TO TMSYS SPC 1 PARLN EQU RTRN.-LCLAS+1 SPC 3 JSB .ENTR GET PARAMETERS ADDRESS ..PA1 DEF .PAR1 (HOPE IT IS MICRO-CODED) * CLA STA RQCNT TO BE SURE THAT THE LOOP WILUtL END LDX D0 GETP7 LAX .PAR1 SZA,RSS PARAMETER HERE ? JMP GETP8 NO, END OF LIST REACHED ISX YES, INCREMENT X REG JMP GETP7 AND LOOP * GETP8 CXA SAVE # OF PARAMETERS STA RQCNT ADA DM10 NEVER MORE THAN 9 PARAMETERS SSA,RSS JMP ERR04 ABORT TMS WITH INTERNAL ERROR 04 LDA SCODE IF IT IS NOT SZA COMMON BLOCK DEFINITION CALL CPA D9 JMP GETPA,I IT IS, EXIT LDA #DFCB IT IS NOT, SO AT LEAST SZA,RSS ONE CB MUST BE DEFINED JMP ERR05 ABORT TMS WITH INTERNAL ERROR 05 * LDA .SCB1,I VERIFY THAT CB1(1) HAS NOT BEEN MODIFIED CPA .COM1,I OK ? JMP GETPA,I YES, EXIT JMP ERR08 NO, ABORT TMS WITH ERROR # 28 SPC 1 PAR#. EQU RQCNT-.PAR1 PAR# ABS PAR#. PARL. EQU RTRN.-.PAR1+1 PARL ABS PARL. HED TERMINAL-MONITOR READ/WRITE REQUEST REQUEST TMRD NOP CLA,INA SUBROUTINE CODE=1 FOR READ JSB GETPA GO GET PARAMETER * LDX D17 EXEC I/O CODE FOR READ READ3 JSB CB1? CB1 DEFINED ? LDA .PAR1 A=BUFF. ADDR. LDB .PAR2,I B=BUFF. LEN. STB .PAR2 SAVE BUFFER LENGTH FOR THE GET LATER JSB GI/O EXECUTE I/O JMP EXIT3 * D17 DEC 17 SPC 2 READ5 JSB EXEC THE PHYSICAL I/O IS DONE DEF *+5 RETURN FROM PRG: TMSYS IS HERE. DEF D21 CLASS I/O GET TO GET THE INPUT BUFFER DEF ICLAS INTERNAL CLASS I/O WORD DEF FPAR1,I USER BUFFER ADDR. (SAVED & RETURNED BY TMSYS) DEF FPAR2 USER BUFFER LEN. (SAVED & RETURNED BY TMSYS) SSA WAS IT OK ? JMP ERR02 ABORT TMS WITH INTERNAL ERROR 02 * JSB SVST SAVE STATUS & TLOG. JMP RTN92 RESTORE TRUE COMMON SPC 2 TMWR NOP LDA D2 SUBROUTINE CODE=2 FOR WRITE JSB GETPA * LDX D18 JMP READ3 * D18 DEC 18 SPC 2 0.*TMBWR NOP BUFFERED WRITE I.E.: DO NOT LDA D4 SUBROUTINE CODE=4 FOR BUFFERED WRITE JSB GETPA JSB CB1? CB1 DEFINED ? * LDX D18 EXECUTE THE BUFFERED WRITE LDA .PAR1 LDB .PAR2,I JSB GI/O TMBW6 LDA RTRN. RETURN OF BUFFERED CALL, I.E.: STA RTRN RETURN DIRECTLY TO THE USER (SETUP RTRN ADDR) JMP RTN99 AND RETURN WITHOUT RESTORING TRUE COMMON * D4 DEC 4 HED TERMINAL-MONITOR WRITE-READ-REQUEST REQUEST TMWRD NOP LDA D11 SUBROUTINE CODE=11 FOR WRITE/READ JSB GETPA * LDA .PAR1 GET WRITE BUFFER ADDR. LDB .PAR3 GET READ BUFFER ADDR. AND SAVE STB .PAR1 IT INTO 1ST PARAM FOR LATER USE LDB .PAR5 GET OPTIONAL (RD/WR CTL BITS) ADDR STB .PAR3 AND SAVE IT IN 3RD PARAM FOR GI/O LDB .PAR2,I GET WRITE BUF LENGTH LDX D18 WRITE REQUEST JSB GI/O PERFORM THE WRITE PART OF THE REQUEST * CLA LDA .PAR4,I GET READ BUF LENGTH AND SAVE STA .PAR2 IT INTO 2ND PARAM FOR TMSYS CLA LDA .PAR3,I GET WR/RD CTL BITS STA .PAR3 AND SAVE INTO 3RD PARAM FOR TMSYS * JMP EXIT3 EXIT TO TMSYS * D11 DEC 11 SPC 2 TMCWR NOP CLASS I/O WRITE/READ REQUEST FROM TMS !! CLA,INA SAME AS A READ REQUEST JSB GETPA * LDX D20 EXEC I/O CODE FOR WRITE/READ RQ JMP READ3 V30* D20 DEC 20 HED TERMINAL-MONITOR CONTROL REQUEST REQUEST TMCTL NOP LDA D3 SUBROUTINE CODE=3 FOR CONTROL JSB GETPA JSB CB1? CB1 DEFINED ? * JSB CTL JMP EXIT3 * D3 DEC 3 SPC 2 TMBCT NOP LDA D5 SUBROUTINE IS 5 FOR BUFFERED CTL JSB GETPA JSB CB1? CB1 DEFINED ? * JSB CTL JMP TMBW6 RETURN FROM A TMS BUFFERED REQUEST * D5 DEC 5 SPC 1 CTL NOP CLA DEFAULT IS ZERO LDA .PAR1,I GET FUNCTION CODE ALF,ALF RAR,RAR IOR .COM1,I STA I/OLU CLA VALUE IS 0 IF NOT SUPPLIED LDA .PAR2,I STA .PAR2 JSB EXEC EXECUTE THE CLASS I/O CONTROL DEF *+10 DEF D19 CLASS I/O CONTROL REQUEST DEF I/OLU LU DEF .PAR2 PARAMETER DEF CLASS CLASS I/O WORD DEF STKPT 1ST PARAMETER DEF SCODE 2ND PARAMETER DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF RNLCK BYPASS LU-LOCK CHECK SZA WAS IT OK ? JMP ERR02 ABORT TMS WITH INTERNAL ERROR 02 JMP CTL,I * D19 DEC 19 SPC 1 CB1? NOP CHECK THAT CB1 IS DEFINED LDA .LEN1 RECALL CB1 LOCAL LENGTH SSA CB1 DEFINED ? JMP ERR06 NO, USER IS NOT ABLE TO DO I/O CALL JMP CB1?,I YES, CONTINUE HED TERMINAL-MONITOR LOG ON REQUEST TMSOP NOP TMS OPERATOR CALL ENTRY POINT CLA JSB GETPA RETRIEVE CALLING PARAMETERS * LDA .PAR2,I IOR LU MERGE WITH LU STA CTL SAVE LOCALLY * JSB EXEC READ/WRITE CALL DEF *+10 DEF .PAR1,I CODE DEF CTL LU DEF .PAR3,I BUFFER ADDR DEF .PAR4,I BUFFER LENGTH DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF RNLCK BYPASS LU-LOCK CHECK JSB SVST SAVE STATUS & TLOG JMP RTRN.,I RETURN TO USER SPC 3 SVST NOP LDX D3 INDEX INTO 1ST CB SAX .COM1,I TO STORE STATUS ISX AND TO WORD 5 SBX .COM1,I TO STORE TANSMISSION LOG JMP SVST,I HED TERMINAL-MONITOR PROCESS/PROGRAM LAUNCHING REQUEST TMPRO NOP LDA D13 SUBROUTINE CODE=13 FOR LAUNCH PROCESS JSB GETPA * LDA ..PA1 MOUVE END OF PARAMETERS ADA D2 TO HAVE ROOM TO PUT LDB A THE PROCESS NAME (TM SUBROUTINE NAME) ADB D2 JSB &MVW DM4 DEC -4 * LDA .PAR2 NOW MOUVE TM SUBROUTINE NAME LDB ..PA1 INB MVW D3 JMP EXIT2 GET LU# AND EXIT * D13 DEC 13 SPC 3 NOP CLA NO CODE FOR PROGRAM SCHEDULE !!! JSB GETPA * LDA ..PA1 MOVE LAST PARAM TO INA HAVE ROOM FOR PROGRAM NAME LDB A ADB D2 DESTINATION ADDR JSB &MVW DM6 DEC -6 LDA .PAR1 LDB ..PA1 MOVE PROGRAM NAME MVW D3 JMP EXIT3 * D15 DEC 15 HED TERMINAL-MONITOR C.B. ENABLE/DISABLE REQUEST TMCBE NOP LDA D6 SUBROUTINE CODE=6 FOR CB ENABLE JSB GETPA JMP EXIT2 GET THE VALUE OF THE FIRST PARAMETER * D6 DEC 6 SPC 3 TMCBD NOP LDA D7 SUBROUTINE CODE=7 FOR CB DISABLE JSB GETPA JMP EXIT3 SPC 4 TMCBL NOP LDA D14 SUBROUTINE CODE=14 FOR CB LENGTH CHANGE JSB GETPA * CLA DEFAULT VALUE IS ZERO LDA .PAR2,I STA .PAR2 SET SECOND PARAMETER VALUE JMP EXIT3 * D14 DEC 14 HED TERMINAL-MONITOR LOGGING REQUEST TMLOG NOP LDA D24 SUBROUTINE CODE=24 FOR LOGGING JSB GETPA * LDA LULOG GET LU OF LOGGING DEVICE SZA LOG DEVICE DEFINED ? JMP TMLO1 YES, GO TO LOG  CLB NO, RETURN STATUS=-1 TO THE USER CCA AND RETURN IMMEDIATLY JSB SVST SET TMS-STATUS & TLOG JMP TMBW6 AND RETURN SPC 1 TMLO1 JSB CB1? START LOGGING, IS CB1 DEFINED * ??????????????????? CHECK FOR MEMORY PROTECT FENCE !!! LDA .PAR2 RECALL USER DATA BUFFER ADDR. ADA DM16 AND COMPUTE THE ACTUAL BUFFER ADDR. STA TEMP SAVE BUFFER ADDR LDB TMLO8 SAVE USER VALUE TO RESTORE THEM MVW D16 AT THE END * LDB TEMP SET UP THE FIRST 16 WORDS OF THE LDA .PAR3,I LOGGING RECORD ADA D16 SET RECORD LENGTH STA B,I INB STB TMLO5 SET ADDR. FOR TIME STAMP ADB D5 LEAVE ROOM FOR TIME STAMP STB TMLO5+1 SET ADDR. FOR YEAR INB STB TEMP1 SAVE LU ADDR. LDA .COM1,I SET INTERACTIVE LU INTO STA B,I THE LOGGING RECORD INB LDA .PAR1 AND MOVE THE USER HEADER MVW D8 * JSB EXEC GET TIME STAMP FROM THE SYSTEM DEF *+4 DEF D11 TMLO5 BSS 2 BUFFER ADDR * LDA LULOG RECALL LOGGING LU STA .COM1,I AND STORE IT IN PLACE OF TERMINAL LU LDA .D1 SET CTL BIT (BINARY RQ) STA .PAR3 * LDA TEMP A=BUFF. ADDR. LDB A,I B=BUFF. LENGTH LDX D18 X=EXEC RQ JSB GI/O PERFORM THE WRITE * LDA TEMP1,I RESTORE INTERACTIVE LU INTO STA .COM1,I THE FIRST COMMON BLOCK LDA TMLO8 RESTORE THE USER BUFFER LDB TEMP IN FRONT OF THE DATA BUFFER MVW D16 * JMP EXIT3 AND EXIT SPC 1 DM16 DEC -16 D16 DEC 16 D8 DEC 8 D24 DEC 24 TEMP NOP TEMP1 NOP TMLO8 DEF *+1 BSS 16 .D1 DEF D1 HED TERMINAL-MONITOR SUBROUTINE REQUEST TMSUB NOP CALL AN EXTERNAL SUBROUTINE LDA D8 SUBROUTINE CODE=8 FOR T-M SUB. CALL JSB GETPA * oLDA .PAR1 LDB ..PA1 MVW D3 GET PARAMETER JMP EXIT3 SPC 1 SBCAL LDB .NTUS,I GET THE LOCAL # OF SUB. LDA RTRN GET THE WANTED SUB # ADA B LOCAL # - WANTED # SSA IS IT OK ? JMP ERR03 ABORT TMS WITH INTERNAL ERROR 03 LDA RTRN CMA,INA MAKE IT POSITIVE CAX LAX .NTUS,I GET SUBROUTINE ENTRY POINT ADDR RSS LDA A,I PEEL OFF INDIRECT BIT RAL,CLE,SLA,ERA JMP *-2 STA EPAOS JSB A,I AND CALL THE SUBROUTINE DEF *+1 TO BE COMPATIBLE WITH .ENTR CONVENTION * TMRTN LDA D10 SUBROUTINE CODE=10 FOR TMSUB RETURN STA SCODE NO PARAMETERS TO GET JMP EXIT3 SPC 1 TMDFN NOP JSB TMDF3 CHECK THAT RTRN IS STILL NEGATIVE JSB GETPA * CLA STA LEN0 NO TRUE COMMON DEFINED YET LDA EPAOS SAVE ENTRY POINT ADDR. STA .PAR5+5 OF SUB. TO SEND TO TMSYS JMP EXIT3 SPC 1 TMDF3 NOP THIS IS TO BE SURE THAT LDA RTRN THIS CALL IS THE FIRST OF THE SUBROUTINE SSA,RSS STILL NEGATIVE ? JMP ERR05 ABORT TMS WITH INTERNAL ERROR 05 LDA D9 YES, ALLRIGHT JMP TMDF3,I SUBROUTINE CODE=9 FOR CB DEFINITION SPC 1 D9 DEC 9 D10 DEC 10 HED TERMINAL-MONITOR PAUSE/STOP REQUEST TMPZ NOP LDA D12 SUBROUTINE CODE=12 FOR PAUSE REQUEST JSB GETPA JMP EXIT2 * D12 DEC 12 SPC 3 TMSAB NOP LDA ABTCD SUBROUTINE CODE=17 FOR TMS ABORT JSB GETPA JMP EXIT2 SPC 3 TMSTP NOP LDA D20 SUBROUTINE CODE=20 FOR TMS STOP JSB GETPA JMP EXIT2 SPC 3 TMSIF NOP LDA D15 SUBROUTINE CODE=15 FOR STOP-INHIBIT FLAG SET JSB GETPA JMP EXIT2 HED UTILITY SUBROUTINES, CONSTANTS AND VARIABLES ILRQ STA TEMP JMP ERR03 ABORT TMS WITH INTERNAL ERROR 03 SPC 3 ERR01 HL.T 11B CB0 CLASS I/O ERROR ERR02 HLT 12B RN / CLASS I/O ERROR ERR03 LDA D3 INTERNAL LOGIQUE / TABLE INCONSISTENCY JMP ERROR ERR04 LDA D4 GETPA: USER CALL WITH MORE THAN 9 PARAM. JMP ERROR ERR05 LDA D5 TMDFN: NOT 1ST CALL/2ND CALL (USER ERROR) JMP ERROR ERR06 LDA D6 CB1 IS NOT DEFINED FOR AN I/O REQUEST JMP ERROR * D7 USED BY IMAGE: CB1 NOT DEF. OR < 19 WORDS * D8 USED BY IMAGE: USER MODIFY CB1[6:13] ERR08 LDA D8 USER MODIFY CB1(1) JMP ERROR * $TML8 EQU * ERROR STA .PAR1 SET ERROR # LDB ABTFL SET ERROR FLAG INSTEAD OF SUBROUTINE CODE STB SCODE SCODE TO BE SEND CCA SET SEND FLAG STA SRFLG JMP EXIT6 * ABTFL OCT 125252 SPC 2 * TMS-FMP REQUEST HAS BEEN DONE, SAVE * ADDRESS OF THE CLOSE ROUTINE TO CLOSE FILES * WHEN TMS STOP. SPC 1 $TML7 NOP STA .CLS SAVE CLOSE ROUTINE ADDR. LDA FMPCL RECALL FMP CLASS I/O WORD JMP $TML7,I AND RETURN TO FMP-TMS SUBROUTINE SPC 1 .CLS OCT 0 SKP MAILB NOP SEND/RECEIVE MAIL-BOX TO/FROM TMSYS DST PARM1 LDA MAILB,I CALLING SEQUENCE: JSB MAILB STA MAIL2 ----------------- DEF BUFF BUF ADDR ISZ MAILB DEC 10 BUF LENGTH LDA SRFLG SZA SEND OR RECEIVE ? JMP MAIL5 SEND MAIL BOX JSB EXEC DEF *+7 DEF D21 CLASS I/O GET DEF ICLAS INTERNAL CLASS I/O WORD MAIL2 NOP DEF MAILB,I BUFFER LENGTH DEF PARM1 DEF PARM1+1 SSA HLT ISZ MAILB AJUST RETURN ADDR DLD PARM1 JMP MAILB,I * MAIL5 JSB EXEC DEF *+8 DEF D20 WRITE/READ CLASS I/O CALL DEF D0 DUMMY LU DEF MAIL2,I BUFFER ADDR DEF MAILB,I BUFFER LENGTH DEF PARM1 DEF PARM1+1 DEF ICLAS INTERNAL CLASS I/O WORD SZA WAS IT OK HLT ISZ MAILB AJUST RETURN ADDR JMP MAILB,I SPC 1 SRFLG NOP SEND/RECEIVE FLAG FOR MAIL-BOX SEND/RECEI. ROUTINE PARM1 BSS 2 SPC 3 SRCB NOP SEND/RECEIVE ALL NECESSARY COMMON BLOCK CLA RESET CB INDICATOR STA CBIND LDA #DFCB GET MINUS OF DEFINED CB'S SZA,RSS DEFINED CB'S ? JMP SRCB,I NO, RETURN CMA,INA YES, MAKE IT NEGATIVE STA TEMP1 TO USE TEMP1 AS A COUNTER LDB D2 INIT CB# WORD (SET BIT TO STB CB# CORRESPONDING CB #) LDX .CB1 MAINTAIN LOCAL CB ADDR IN X LDB @.LN1 USE B AS A POINTER TO CB DEFINITION SCR01 LDA B,I GET CURRENT CB LENGTH RAL,CLE,ERA CLEAR BIT15 SEZ CB ENABLED ? JMP SCR05 NO, CHECK NEXT ONE STA SCR04+1 YES, SET CB LENGTH SPC 1 LDA SWFLG GET SYS COM/CLASS I/O FLAG (BIT15) SSA SYSTEM COMMON USED ? JMP SCR03 YES, SKIP SEND/RECEIVE MAILBOX * STB TEMP NO, SAVE CB DEFINITION PT STX SCR04 SET CB ADDR JSB MAILB SEND/RECEIVE CB DATA SCR04 BSS 2 BUFFER ADDR / BUFFER LENGTH LDB TEMP RESTORE B SPC 1 SCR03 LDA CBIND UPDATE CB INDICATOR IOR CB# STA CBIND SCR05 INB BUMP POINTER TO COM. BL. LIST ADX B,I MAINTAIN LOCAL CB ADDR INB LDA CB# SET NEXT BIT IN CB# WORD RAL STA CB# ISZ TEMP1 MORE CB DEFINED ? JMP SCR01 YES, LOOP UNTIL FINISHED JMP SRCB,I NO, RETURN * CB# NOP CBIND NOP @.LN1 DEF .LEN1 SPC 2 GI/O NOP STA I/OB BUFFER STB I/OL LENGTH STX I/OC EXEC I/O CODE * LDB .COM1 XBX GET READ-WRITE CONTROL BIT LAX 1 GEˀT 2ND WORD OF COMMON BLOCK # 1 SLB READ OR WRITE ? ALF,ALF READ LDB .PAR3 FUNCTION CODE SUPPLIED BY SZB THE USER FOR THIS CALL ? LDA B,I YES, GET IT AND RHALF NO, KEEP THE STANDARD ONE ALF,ALF RAR,RAR IOR .COM1,I MERGE WITH LU STA I/OLU * JSB EXEC DEF *+10 DEF I/OC EXEC CODE DEF I/OLU CONTROL WORD I/OB NOP BUFFER DEF I/OL LENGTH DEF STKPT 1ST PARAMETER DEF SCODE 2ND PARAMETER DEF CLASS CLASS I/O WORD DEF * PLACE HOLDER !! DEF RNLCK BYPASS LU-LOCK CHECK SZA WAS IT OK ? JMP ERR02 ABORT TMS WITH INTERNAL ERROR 02 JMP GI/O,I SPC 1 RHALF OCT 377 I/OC NOP I/OL NOP I/OLU NOP SPC 2 GACB0 NOP GET CB0 ADDR JSB CB1? CB1 MUST BE ENABLE LDB LEN0 RECALL CB0 LENGTH CMB,INB AND ADB .COM1 ADD TO CB1 ADDR TO HAVE CB0 ADDR. JMP GACB0,I EXIT WITH ADDR IN B REG. SPC 3 GTCLW NOP ALLOCATED A CLASS I/O CLA WHEN OWNER CLASS I/O WILL BE RELEASE STA GTCLX THIS SUBROUTINE WILL BE REPLACED JSB EXEC BY THE SYSTEM ROUTINE. DEF *+5 THE CLASS MUST BE OWNED BY THE CALLING PROGRAM DEF D19 SO THE ABORT PROCEDURE WILL BE EASIER DEF D0 I.E.: THE PROGRAM WILL BE ABORTED DEF * AND HOPFULLY THE CLASS I/O RELEASED. DEF GTCLX LDA GTCLX IOR B20K SET BIT13 'DO NOT DEALLOCATE CLASS' STA GTCLX JSB EXEC DEF *+5 DEF D21 DEF GTCLX DEF * DEF D0 LDA GTCLX JMP GTCLW,I * GTCLX NOP B20K OCT 20000 SPC 3 $TML5 EQU * TABLE OF ADDR. GET BY TMLIM WHEN NEEDED DEF IMEXT ADDR OF RETURN POINT INTO TMLIB FROM TMLIM DEF STKPT ADDR OF THE STACK POINTER VARIAB0.*LE DEF FPAR1 ADDR OF THE FIRST FUNCTION PARAMETER DEF CLASS ADDR OF THE TMS EXTERNAL CLASS I/O WORD DEF ICLAS ADDR OF THE TMS INTERNAL CLASS I/O WORD SKP C.TAB DEF *+1,I DEF ILRQ 0 START TMS (NEVER IN TMS-SUBROUTINE) DEF READ5 1 STANDARD READ DEF RTN92 2 STANDARD WRITE DEF RTN92 3 CONTROL DEF ILRQ 4 BUF. WRITE (NEVER COME BACK) DEF ILRQ 5 BUF. CTL (NEVER COME BACK) DEF RTN90 6 CB ENABLE DEF RTN90 7 CB DISABLE DEF SBCAL 8 TM SUB. CALL DEF RTN90 9 DEFINE COMMON IN A TM SUB. DEF RTN92 10 RETURN FROM A TM SUB DEF READ5 11 WRITE/READ DEF RTN92 12 PAUSE DEF RTN92 13 PROCESS LAUNCHING DEF RTN92 14 CHANGE CB LENGTH DEF RTN92 15 SET/RESET STOP-INHIBIT FLAG DEF ILRQ 16 UNLCK-IMAGE FUNCTION (NEVER COME TO TMLIB) DEF ABT 17 ABORT TMS APPL. (TERMINATE THIS PRG.) DEF ILRQ 18 PROCESS LAUNCHING BY TMSL DEF ILRQ 19 TMS-TIMER INTERRUPT DEF ILRQ 20 STOP TMS APPL. (NEVER COME TO TMLIB) DEF ILRQ 21 MEMORY SUSPEND (NEVER COME TO TMLIB) DEF ILRQ 22 MEMORY SUSPEND (NEVER COME TO TMLIB) DEF RTN92 23 IMAGE REQUEST DEF RTN92 24 LOGGING REQUEST DEF ILRQ 25 STOP IN PROGRESS (NEVER COME TO TMLIB) REP 5 DEF ILRQ SPC 2 XEQT EQU 1717B SPC 2 UNS ORG * DEFINE LAST LOCATION END (0  92903-18107 1913 S C0122 &TMFMP              H0101 ASMB HED . TMS-FMP CALL SAVE AND RESTORE DCB NAM TMFMP,7 92903-16100 REV.1913 781218 SPC 3 ********************************************************************** * * * NAME: TMFMP TMS-FMP CALL * * ENT: TDCBS,TDCBR,TDCBC * * SOURCE: &TMFMP 92903-18107 * * BINARY: %TMFMP ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT TDCBS,TDCBR,TDCBC EXT $TML7,.ENTR,WRITF,CLOSE,EXEC,LOCF,ICRLU * A EQU 0 B EQU 1 SUP SKP * THIS CODE PROVIDES TWO SUBROUTINES TO SAVE AND RESTORE * THE DCB BUFFER USED BY THE FMP CALLS. * * WHEN THE FILE HAS BEEN SUCCESSFULY OPEN OR CREATED, THE * USER SAVES THE DCB INTO SAM USING 'TDCBS', THE NEXT TIME THE USER * WANTS TO ACCESS THAT FILE HE RESTORES THE DCB USING 'TDCBR' * * * TDCBS - RECORD FILE NAME IN THE DIRECTORY IF A NEW FILE * AND SAVE CORRESPONDING DCB IF DCB IS OPEN. * IF THE CR# IS NOT SPECIFIED (=0), TMS-FMP WILL TAKE * THE FILE FROM THE DIRECTORY IF IT EXIST INSTEAD OF * TAKING THE FILE FROM THE 1ST MOUNTED CR. * IF THE CR# IS NOT SPECIFIED, TMS-FMP WILL RETURN * THE CR# INTO NAME(4). * TDCBR - RESTORE THE DCB CORRESPONDING TO THE FILE NAME * TDCBC - CLOSE THE FILE CORRESPONDING TO THE FILE NAME * * CALLING SEQUENCE: * ------------------- * * IF ( TDCBS(FNAME,IDCB [,IERR] ) ) GOTO ERROR * * FNAME - FILE NAME INFORMATION (5 WORDS LONG) * FNAME[1:3] ASCII FILE NAME * FNAME[4:4] CARTRIDGE REFERENCE NUMBER * * IDCB - DCB BUFFER SET UP BY OPEN OR CREAT FMP CALL * DCB SIZE IS ASSUMED TO BE 144 WORDS. * * IERR - OPTIONAL PARAMETER WHERE THE ERROR CODE * IS RETURNED. * = -1 THE FILE IS ALREADY IN THE DIRECTORY, * THE DCB IS ALREADY SAVED. * = -2 THE FILE IS NOT IN THE DIRECTORY, THE * DCB IS NOT OPEN, NOTHING HAS BEEN SAVED. * = -3 DIRECTORY OVERFLOW (MORE THAN 15 FILES) * * * IF( TDCBR(FNAME,IDCB [,IERR] ) ) GOTO ERROR * * FNAME - FILE NAME, AS IN TDCBS CALL * * IDCB - BUFFER WHERE THE DCB WILL BE RETURNED * DCB SIZE IS ASSUMED TO BE 144 WORDS. * * ERROR RETURN IF TRY TO RESTORE THE DCB OF A FILE THAT HAS * NOT BEEN SAVED. * SKP * * IF( TDCBC(FNAME) ) GOTO ERROR * * FNAME - FILE NAME AS IN TDCBS CALL * * ERROR RETURN IF TRY TO CLOSE A DCB OF A FILE THAT HAS NOT * BEEN SAVED, OR FROM A DIFFERENT PROGRAM THAT THE ONE USED * TO OPEN THE FILE. * SPC 2 * FORMAT OF THE DIRECTORY: * -------------------------- * * 6 WORDS PER ENTRY. 15 ENTRIES MAX. ---> 15*6=90 WORDS FOR *  THE DIRECTORY BUFFER. * * * FILE NAME - 3 WORDS * CR # - 1 WORD * CLASS I/O # - 1 WORD * IDSEG ADDR. - 1 WORD * * THE CLASS I/O WORD IS THE CLASS I/O USED TO SAVE THE DCB INTO SAM. * EACH FILE HAS A DIFFERENT CLASS AND THE DCB IS THE ONLY BUFFER QUEUE * ON THAT CLASS. * BIT15 OF CLASS WORD INDICATE IF THE DCB HAS BEEN SAVED INTO SAM * OR NOT. * = 0 THE DCB IS IN THE USER BUFFER (HAS BEEN RESTORED) * = 1 THE DCB IS INTO SAM (HAS BEEN SAVED) * BIT13 OF CLASS WORD IS SET/RESET TO NOT-DEALLOCATE/DEALLOCATE THE * CLASS AS NEEDED. * THE USER ADDR OF THE DCB IS SAVED/RESTORED USING THE 1ST PARAM * OF THE CLASS I/O CALL. THIS ADDR IS NEEDED WHEN THE DCB IS RESTORED * TO ADJUST THE ABSOLUTE ADDR WHICH IS HELD IN DCB(13). * * THE IDSEG ADDR IS KEPT IN THE DIRECTORY FOR 2 REASONS: * - DCB(10) MUST HAVE THE IDSEG ADDR OF THE PROGRAM THAT ISSUES THE * FMP CALL. (THIS IS THE OPEN FLAG). THIS SET OF SUBROUTINE RESTORES * DCB(10) AS NEEDED. * - ONLY THE PROGRAM THAT OPEN THE FILE, CAN CLOSE THE FILE. TMS-FMP * WILL CLOSE THE FILE ONLY WHEN THE UPT THAT OPEN THAT FILE IS * SCHEDULED TO COMPLETE. TMS-FMP WILL REJECT TDCBC CALL IF NOT * ISSUE FORM THE UPT THAT OPEN THAT FILE. SKP TDCBC NOP CLOSE ONE FILE LDB *-1 LDA .DCB SET LOCAL DCB ADDR STA .IDCB LDA DM2 JMP TDCB. SPC 2 TDCBS NOP DCB SAVE ENTRY POINT LDB *-1 LDA D2 JMP TDCB. SPC 2 TDCBR NOP DCB RESTORE ENTRY POINT LDB *-1 CLA,INA TDCB. STA FLAG SET REQUEST TYPE FLAG STB TDCB SET RETURN ADDR JMP TDCB+1 GO EXECUTE .ENTR * DM2 DEC -2 FLAG NOP SPC 5 .NAME NOP ADDR OF FILE NAME (5 WORDS LONG) .IDCB NOP +,ADDR OF THE DCB .IER DEC 0 TDCB NOP DUMMY ENTRY POINT JSB .ENTR GET PARAMETERS ADDR DEF .NAME * LDA .CLS CLOSE ROUTINE ADDR JSB $TML7 PASS IT TO 'TMLIB' AND * LDB .NAME SAVE USER ADDR OF THE CR# ADB D3 STB .CR# SPC 1 TDCB3 STA CLASS GET FROM TMLIB THE TMS-FMP CLASS I/O CCE READ IN THE FILE DIRECTORY JSB SAMIO FROM SAM .DIRB DEF DIRBU BUFFER ADDR D90 DEC 90 BUFFER LENGTH CPB D1 DIRECTORY LENGTH = 1 ? CLB YES, SET IT TO ZERO STB DIRLN AND SAVE DIRECTORY LENGTH * LDA .DIRB SET UP END OF DIRECTORY ADDR ADA DIRLN STA .DIRE SPC 1 LDA FLAG RECALL REQUEST FLAG CPA DM1 CLOSE ALL FILES REQUEST ? JMP RSTSV YES, DO NOT SEARCH INTO THE DIRECTORY SPC 1 LDA .DIRB SEARCH INTO THE DIRECTORY FOR THE FILE NAME ADD02 STA DIRPT SAVE DIRECTORY POINTER CPA .DIRE END OF DIRECTORY ? JMP ADD20 YES, IT IS A NEW FILE LDB .NAME SEARCH INTO THE DIRECTORY CMW D3 COMPARE WORD ? JMP ADD05 YES, FOUND IT NOP NO, CONTINUE SEARCHING ADD04 LDA DIRPT RECALL POINTER ADA DETL AND GOTO NEXT ENTRY JMP ADD02 TO LOOP UNTIL THE END * ADD05 LDB .CR#,I GET THE CR# SUPPLY BY THE USER SZB,RSS DEFINED ? JMP ADD10 NO, GET THE ONE FROM THE DIRECTORY CPB A,I YES, IS IT THE ONE THAT IS IN THE DIRECTORY ? JMP RSTSV YES, IT IS EXACTLY THE SAME FILE. JMP ADD04 NO, RESUME THE SCAN OF THE DIRECTORY * ADD10 LDB A,I GET THE CR# FROM THE DIRECTORY STB .CR#,I AND RETURN IT TO THE USER. JMP RSTSV GO RESTORE THE DCB SPC 2 ADD20 LDA FLAG THE FILE IS NOT FOUND, RECALL RQ FLAG CPA D2 SAVE REQUEST ? RSS YES, SAVE IF DCB IS OPEN JMP ERR NO, NOT jSAVE RQ, MUST BE IN THE DIRECTORY * LDA .IDCB CHECK IF THE DCB IS OPEN ADA D9 ACCESS OPEN FLAG LDA A,I CPA XEQT DCB OPEN ? RSS YES, SAVE THAT FILE JMP ERR02 NO, RETURN DCB NOT OPEN ERROR * LDA DIRLN ADDITION OF A NEW FILE INTO THE DIRECTORY CPA D90 DIRECTORY FULL ? JMP ERR03 YES, RETURN DIRECTORY FULL ERROR LDB DIRPT NO, INSERT IT LDA .NAME AT THE END OF THE DIRECTORY MVW D4 STB CLWPT CLA INIT CLASS I/O WORD TO ZERO STA B,I INB LDA XEQT AND SAVE ID SEGMENT ADDR OF THE STA B,I PROGRAM THAT HAS DEFINED THE DCB (FOR THE CLOSE) * ADB DM2 NOW CHECK IF CR# WAS DEFINED STB TEMP SAVE ADDR OF CR# IN THE DIRECTORY LDA B,I RECALL CR# SZA DEFINED ? JMP ADD28 YES, KEEP IT JSB LOCF NO, RETREIVE THE LU AND THEN THE CR DEF *+8 DEF .IDCB,I DCB DEF TEMP1 IERR DEF TEMP1 IREC DEF TEMP1 IRB DEF TEMP1 IOFF DEF TEMP1 JSEC DEF LU# JLU SZA FMP CALL OK ? HLT 13B NO, ERROR !!!!!!!!!!!!!!!!!! LDA LU# YES, RECALL LU AND MAKE IT NEG CMA,INA TO RETREIVE THE CR STA LU# JSB ICRLU GET CR FROM LU DEF *+2 DEF LU# SSA OK ? HLT 15B NO, ERROR !!!!!!!!!!!!!!!!!!!!!! STA TEMP,I YES, STORE CR# INTO THE DIRECTORY STA .CR#,I AND RETURN IT TO THE USER * ADD28 LDA DIRLN UPDATE DIRECTORY LENGTH ADA DETL STA DIRLN * LDA CLWPT,I RECALL CLASS I/O WORD JMP SAV AND GO TO SAVE THE DCB SPC 1 DIRPT NOP CLWPT NOP XEQPT NOP LU# EQU XEQPT .CR# NOP D1 DEC 1 D2 DEC 2 D4 DEC 4 NBT13 OCT 157777 DETL DEC 6 DIRECTORY ENTRY LENGTH DMETL DEC -6 DM1 DEC -1 DMg3 DEC -3 SPC 2 RSTSV LDA DIRPT ADA D4 SET THE CLASS WORD POINTER STA CLWPT INA SET THE IDSEG POINTER STA XEQPT CMA CHECK LEGALITY OF THE FILE NUMBER ADA .DIRE SSA FILE NUMBER OK ? JMP ERR NO, RETURN ERROR LDA CLWPT,I GET THE CLASS I/O WORD LDB FLAG RECALL REQUEST FLAG CPB D2 SAVE REQUEST ? JMP SAV YES, GOTO SAVE THE DCB SSA,RSS NO, IT IS RST/CLS, CLASS OK ? JMP CLS75 NO, GO CHECK FOR CLOSE REQUEST * RAL,CLE,ERA CLEAR BIT 15 OF CLASS WORD SSB,RSS RESTORE REQUEST ? JMP RST10 YES, GOTO RESTORE DCB AND NBT13 NO, IT IS CLOSE, RELEASE THE CLASS LDB XEQT AND VERIFY THAT IT IS THE GOOD PROGRAM CPB XEQPT,I TO PERFORM THE CLOSE, OK ? JMP RST10 YES, GO RESTORE THE DCB JMP CLS78 NO, TRY TO CLOSE THE NEXT FILE * RST10 STA CLWPT,I STORE BACK THE CLASS WORD, WITH BIT15=0 LDB .IDCB TO INDICATE "DCB RESTORED" STB RST13 SET DCB ADDR CCE READ FROM SAM JSB SAMIO RST13 NOP BUFFER ADDR DEC 144 BUFFER LENGTH * LDA .IDCB MODIFIED DCB WORDS THAT MUST ADA D9 BE MODIFIED LDB XEQT STB A,I ADA D3 LDB A,I ADB .IDCB ADD NEW STARTING ADDR ADB PARM1 AND SUBSTRACT THE OLD ONE STB A,I TO GET THE NEW ABSOLUTE POINTER * LDA FLAG RECALL REQUEST FLAG CPA DM1 IS IT CLOSE ALL FILE REQUEST ? JMP CLS40 YES, CONTINUE CPA DM2 IS IT CLOSE ONE FILE ? JMP CLS45 YES, GO CLOSE THE FILE JMP OKRTN NO, IT WAS A RESTORE, RETURN OK SPC 2 SAV SSA DCB ALREADY SAVED ? JMP ERR YES, RETURN ERROR TO CALLER * LDB .IDCB SET BUFFER ADDR STB SAV13 CMB,INB SAVE ALSO INTO SAM THE CURRENT{ STB PARM1 DCB ADDRESS CLE WRITE BUFFER TO SAM JSB SAMIO SAV13 NOP BUFFER ADDR DEC 144 BUFFER LENGTH LDA TEMP1 RECALL THE CLASS WORD IOR =B120000 MERGE BIT15 TO INDICATE -DCB SAVED- STA CLWPT,I AND BIT13 TO NOT DEALLOCATE THE CLASS * LDA .IDCB MODIFIED DCB WORD TO ADA D9 "FREE" THAT DCB, SO IF IT IS CLB RE-USED, THE SAVE FILE WILL NOT STB A,I BE CLOSED. JMP OKRTN SPC 2 * SAVE DIRECTORY BUFFER INTO SAM AND * RETURN TO THE USER THE STATUS. * ERR03 LDA DM3 RETURN 'DIRECTORY FULL' ERROR CODE JMP RTRN * ERR02 LDA DM2 RETURN 'DCB NOT OPEN' ERROR CODE JMP RTRN * OKRTN CLA,RSS RETURN 'SUCCESFUL OPERATION' STATUS * ERR CCA ERROR RETURN (VALUE= .TRUE.) * RTRN STA RTNVA SPC 1 LDA DIRLN SAVE BACK DIRECTORY INTO SAM SZA,RSS AJUST DIRECTORY LENGTH CLA,INA BEFORE THE WRITE/READ CALL STA DIRLN CLE SEND DIRECTORY TO SAM LDA CLASS GET CLASS I/O WORD JSB SAMIO DEF DIRBU DIRECTORY BUFFER DIRLN NOP DIRECTORY LENGTH SPC 1 LDA RTNVA RECALL RETURN VALUE STA .IER,I SET ERROR CODE CLB RESET ERROR ADDR STB .IER FOR THE NEXT TIME (OPTIONAL PARAM) JMP TDCB,I AND RETURN * RTNVA NOP HED CLOSE ALL FILES RECORDED IN THE DIRECTORY .CLS DEF *+1 NOP CLOSE ALL FILE ROUTINE ENTRY POINT LDB *-1 RECALL RETURN ADDR. STB TDCB SET UP RETURN ADDR. CCB SET FLAG FOR CLOSE ALL FILES REQUEST STB FLAG LDB .DCB SET LOCAL DCB BUFFER STB .IDCB LDB .DIRB INITIALIZE DIRECTORY POINTER STB DIRPT JMP TDCB3 GO GET DIRECTORY FROM SAM * CLS40 JSB WRITF DCB HAS BEEN RESTORED DEF *+5 WRITE AN EOF DEF .IDCB,I DCB ADDR DEF TEMP ERR CODE RETURNED HERE DEF * BUFFER ADDR DEF DM1 WRITE EOF SSA FMP CALL OK ? HLT 17B NO, ERROR !!!!!!!!!!!!!!!!!!!!!!!!! CLS45 JSB CLOSE YES, CLOSE THE FILE DEF *+2 DEF .IDCB,I DCB ADDR SSA FMP CALL OK ? HLT 21B NO, ERROR !!!!!!!!!!!!!!!!!!!!!!!!! * LDA DIRPT THE FILE HAS BEEN CLOSE, DELETE ADA DETL THE CORRESPONDING ENTRY FROM THE DIRECTORY LDB .DIRE COMPUTE LENGTH TO MOVE CMB,INB ADB A IN ORDER TO SUPPRESS THAT ENTRY CMB,INB STB TEMP SAVE WORD COUNT SZB,RSS MOVE NEEDED ? JMP CLS42 NO, SKIP THE MOVE LDB A GET FORM ADDR ADB DMETL SET TO ADDR MVW TEMP AND REPACK THE DIRECTORY CLS42 LDA DIRLN UPDATE DIRECTORY LENGTH ADA DMETL AS WELL STA DIRLN LDA .DIRE UPDATE ALSO END OF DIRECTORY ADA DMETL STA .DIRE * LDB FLAG RECALL REQUEST FLAG CPB DM2 WAS IT CLOSE ONE FILE REQUEST ? JMP OKRTN YES, RETURN * JMP RSTSV TRY TO CLOSE NEXT FILE IN THE DIRECTORY SPC 1 CLS75 CPB DM1 IS IT CLOSE ALL FILES REQUEST ? RSS YES, CONTINUE JMP ERR NO, ERROR RETURN * CLS78 LDA DIRPT GO TO NEXT FILE IN THE DIRECTORY ADA DETL STA DIRPT JMP RSTSV HED UTUILITY SUBROUTINE SAMIO NOP WRITE/READ DIRECTORY TO/FROM SAM CLB B=LU SEZ A=CLASS I/O, IF GET REQUEST SWAP A&B SWP DST TEMP1 AND SAVE CLASS I/O AND LU LDA D20 SET UP REQUEST CODE (20 FOR WRITE/READ) SEZ IF GET REQUEST INA SET UP GET RCODE (21) STA TEMP LDA SAMIO,I GET BUFFER ADDR STA SAMI3 AND SET BUFFER ADDR ISZ SAMIO PREPARE FOR BUFFER LENGTK640H * JSB EXEC WRITE/READ OR GET REQUEST DEF *+8 DEF TEMP RQ DEF TEMP1+1 LU OR CLASS SAMI3 NOP BUFFER ADDR. DEF SAMIO,I BUFFER LENGTH DEF PARM1 DEF PARM2 DEF TEMP1 CLASS OR 3RD PARAM * ISZ SAMIO AJUST RETURN ADDR SSA EXEC CALL OK ? HLT 23B JMP SAMIO,I RETURN SPC 1 CLASS NOP PARM1 NOP PARM2 NOP TEMP NOP TEMP1 BSS 2 * .DCB DEF *+1 BSS 144 DIRBU BSS 90 (15 FILES MAX) .DIRE NOP SPC 1 D20 DEC 20 D9 DEC 9 D3 DEC 3 SPC 2 XEQT EQU 1717B SPC 1 UNS ORG * DEFINE LAST LOCATION END 6   92903-18108 1913 S C0122 &$TTMS              H0101 pASMB HED . *** T M S T I M E R *** NAM $TTMS,7 92903-16100 REV.1913 781215 SPC 3 ********************************************************************** * * * NAME: $TTMS TMS TIMER * * SOURCE: &$TTMS 92903-18108 * * BINARY: %$TTMS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 EXT RMPAR,EXEC,PNAME ENT $TTMS SUP A EQU 0 B EQU 1 SPC 3 * THIS PROGRAM IS A PART OF THE TERMINAL MONITOR SOFTWARE (TMS), * IT IS USED BY TMS TO PROVIDE A TIMER. WHEN TMSYS NEEDS A TIME * INTERVAL, IT PUT THAT PROGRAM IN THE TIME LIST FOR THE PERIOD OF * TIME, AND WHEN 'TTMS' IS SCHEDULE FROM THE TIME LIST, IT RETURN * A MAIL BOX TO 'TMSYS' TO SIGNAL THAT THE TIME IS PASSED. SPC 4 LU NOP ECLAS OCT 0 EXTERNAL CLASS I O WORD ABTCD DEC 17 ABORT CODE TIMCD DEC 19 TMS TIMER CODE MES ASC 13, /XXXXX: ILLEGAL SCHEDULE ASC 5,REQUEST ! .MES1 DEF MES+1 IP BSS 5 IB BSS 8 IBLEN DEC -16 * SCODE EQU IB STKPT EQU IB+7 SPC 2 $TTMS JSB RMPAR RETREIVE PRG PARAMETERS DEF *+2 DEF IP *  LDA IP INIT LU WITH PARAM 1 STA LU * CMA,INA IF(LU<3 OR LU>63) LU=1 ADA D3 CMA LDB LU CMB,INB ADB D63 IOR B LDB D1 GET DEFAULT LU SSA OK ? STB LU NO, SET DEFAULT LU SPC 1 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 STRING RQ DEF D1 GET DEF IB BUFFER DEF IBLEN BUFFER LENGTH SZA GET OK ? JMP TTM70 NO, CHECK IF FROM TIME LIST LDA SCODE YES, CHECK REQUEST CODE SZA,RSS INITIALIZATION ? JMP TTM50 YES, GO INIT CPA ABTCD IS IT ABORT ? JMP TTM60 YES, TERMINATE PROGRAM JMP TTM90 IF NOT REPORT ERROR SKP * TMSYS INITIALISE THIS PROGRAM: * SAVE LOCALLY THE CLASS I/O WORD, AND * TERMINATE WITH 'SAVE SUSP. POINT' OPTION. * TTM50 LDA STKPT RECALL STKPT CPA =B100001 IS IT OK ? RSS YES CONTINUE JMP TTM90 NO, REPORT ERROR LDA ECLAS VERIFY THAT THE CLASS IS NOT SZA ALREADY DEFINED JMP TTM80 THE CLASS WAS DEFINED ! ERROR LDA IP+1 RECALL 2ND PARAM STA ECLAS TO INIT THE CLASS I/O WORD JMP TTM95 AND TERMINATE 'SAVE SUS. PT' IF OK SPC 2 * TMSYS STOP THE APPLICATION: * TERMINATE THIS PROGRAM WITHOUT ANY OPTION. * TTM60 LDA IP+1 TMSYS REQUEST TO STOP APPL., CHECK CPA ECLAS IF CLASS STILL OK ? JMP TTM99 YES, TERMINATE WITH NO OPTION JMP TTM90 NO,REPORT ERROR SPC 3 * SHEDULE WITHOUT STRING PASSING: * MUST BE FROM THE TIME LIST ! * TTM70 LDA ECLAS CHECK THE CLASS WORD SZA,RSS CLASS WORD DEFINED ? JMP TTM99 NO, TERMINATE THE PROGRAM FOR EVER LDA IP+1 YES, CHECK IF FROM CPA DM2 TIME L IST ? RSS YES, CONTINUE JMP TTM90 NO, REPORT ERROR SPC 1 JSB EXEC SEND INFO TO TMSYS DEF *+8 DEF NAB20 WRITE/READ NO ABORT DEF D0 DEF IP DEF D1 BUFFER LEN DEF D0 DEF TIMCD DEF ECLAS CLASS WORD JMP TTM80 ERROR RETURN !! SPC 1 TTM75 JSB EXEC TERMINATE PROGRAM DEF *+6 WITH 'SAVE SUSPENSION POINT' OPTION DEF D6 DEF D0 DEF D1 DEF D0 DEF DM2 SPC 1 ********************************************************************* SPC 1 JMP $TTMS RESTART FORM BEGINING HED ERROR PROCESSING TTM80 CLA RESET THE CLASS I/O WORD STA ECLAS * TTM90 LDA .MES1 REPORT ERROR STA T.001 JSB PNAME DEF *+2 T.001 DEF T.001,I LDA MES+3 MERGE THE ":" IOR A: STA MES+3 JSB EXEC PRINT ERROR MESSAGE DEF *+5 DEF D2 DEF LU DEF MES DEF D18 * TTM95 LDA ECLAS TERMINATE PROGRAM WITH CURRENT OPTION SZA CALL I/O WORD DEFINED ? JMP TTM75 YES, TERMINATE 'SAVE SUSP. PT.' SPC 1 TTM99 CLA RESET THE CLASS I/O WORD STA ECLAS IN CASE OF PROGRAM BEING CORE RESIDENT JSB EXEC DEF *+2 DEF D6 SPC 2 A: OCT 72 ":" NAB20 OCT 100024 * DM2 DEC -2 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D6 DEC 6 D14 DEC 14 D18 DEC 18 D63 DEC 63 END   92903-18109 1913 S C0122 &$LTMS              H0101 pASMB HED . *** T M S L I N K *** NAM $LTMS,7 92903-16100 REV.1913 781215 SPC 3 ********************************************************************** * * * NAME: $LTMS TMS LINK * * SOURCE: &$LTMS 92903-18109 * * BINARY: %$LTMS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SKP * SPC 3 * * * THIS PROGRAM IS A PART OF THE TERMINAL MONITOR SOFTWARE (TMS), * IT IS USE TO INTERACT WITH THE TMS FROM A EXTERNAL DEVICE. * USING TMSL, ONE CAN LAUNCH A PROCESS ON A GIVEN DEVICE, * STOP OR ABORT THE TMS APPLICATION. * * *RU,TMSL [, [LU] [,T.U.S NAME] ] * * WHERE: * LU IS THE LOGICAL UNIT ON WHICH THE PROCESS 'T.U.S. NAME' * WILL BE LAUNCH. * THE LU MAY BE OMITTED, IN WHICH CASE THE CURRENT ONE * WILL BE USED. * IF LU=98 OR LU=99, THE TMS APPLICATION IS STOPPED OR * ABORTED. * * TUS NAM TMS-USER-SUBROUTINE NAME THAT WILL BE LAUNCH ON * THE LOGICAL UNIT LU. * IF OMITTED THE FOLLOWING PROMPT IS GIVEN WON THE * DEVICE: * "T.U.S. NAME [,LU ] ? " * AND TMSL WAIT FOR THE ANSWER. * * NOTE: * IF THERE IS NO STRING PASSING (I.E.: SHEDULE FROM A PROGRAM * WITHOUT GIVING A STRING TO BE PASSED), THE FIVE PARAMETERS ARE * CHECKED. * OR * P1 IS 98 OR 99 P1 IS LU * P2,P3,P4 D'ONT CARE P2,P3,P4 IS THE T.U.S. * P5 MUST BE -1 P5 MUST BE -2 * * *********************************************** F. GAULLIER (HPG) *** SPC 3 ENT $LTMS EXT RMPAR,EXEC,PNAME,$PARS,REIO SUP SPC 2 LU NOP LUI NOP LU + ECHO BIT ECLAS OCT 0 EXTERNAL CLASS I O WORD ABTCD DEC 17 ABORT CODE STPCD DEC 20 TMS STOP CODE LNKCD DEC 18 TMS-LINK CODE MES ASC 13, /XXXXX: ILLEGAL SCHEDULE ASC 5,REQUEST ! MESA ASC 11,T.U.S. NAME [,LU] ? _ .MES1 DEF MES+1 IP BSS 33 IB BSS 8 IBLEN DEC -16 * SCODE EQU IB STKPT EQU IB+7 SPC 2 $LTMS JSB RMPAR RETREIVE PRG PARAMETERS DEF *+2 DEF IP * LDA IP INIT LU WITH PARAM 1 STA LU * CMA,INA IF(LU<3 OR LU>63) LU=1 ADA D3 CMA STA L.001 LDA LU CMA,INA ADA D63 IOR L.001 LDB D1 GET DEFAULT LU SSA OK ? STB LU NO, SET DEFAULT LU * LDA .D1 INIT SPECIAL FLAG STA .NAME SPC 1 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 STRING RQ .D1 DEF D1 GET DEF IB BUFFER DEF IBLEN BUFFER LENGTH SZA GET OK ? JMP LTM70 NO, CHECK IF FROM TIME LIST LDA SCODE YES, CHECK REQUEST CODE SZA,RSS INITIALIZATION ? JMP LTM50 YES, GO INIT CPA ABTCD IS IT ABORT ? JMP LTM60 YES, TERMINATE PROGRAM SPC 2  * NOT FROM TMSYS, MUST BE FROM * USER REQUEST "RU,...." * LDA ECLAS CHECK THAT CLASS STILL OK SZA,RSS OK ? JMP LTM90 IF NOT, REPORT ERROR SPC 1 LDA .IP12 SET POINTER STA .NAME LDA .IP8 STA .LU JMP PARSE GO PARSE BUFFER SPC 1 * REQUEST T.U.S AND LU * LTM10 JSB EXEC PRINT "T.U.S. NAME [,LU] ?" DEF *+5 DEF D2 DEF LU DEF MESA DEF DM21 * LDA LU IOR =B400 STA LUI LU + ECHO JSB REIO READ THE ANSWER DEF *+5 BUT BE SWAPPABLE DEF D1 DEF LUI .IB DEF IB DEF IBLEN SZB,RSS INPUT ? JMP LTM95 NO, TERMINATE THE PROGRAM * LDA .IP SET POINTER STA .NAME LDA .IP4 STA .LU * PARSE LDA .IB RECALL BUFFER ADR JSB $PARS AND DO THE PARSE .IP DEF IP STORE RESULT * DLD .LU,I GET TYPE & DATA CPA D1 NUMBER DEFINE ? JMP LTM14 YES, KEEP IT SZA LU DEFAULTED ? JMP LTM90 NO, REPORT ERROR LDB LU YES, GET DEFAULT LU * LTM14 CPB D99 IS IT ABORT REQUEST ? JMP LTM40 YES, GO DO IT CPB D98 IS IT STOP REQUEST ? JMP LTM41 YES, GO DO IT LDA .NAME,I RECALL NAME TYPE CPA DM1 SPECIAL ERROR FLAG ? JMP LTM90 YES, REPORT ERROR CPA DM2 SPECIAL FLAG ? JMP LTM27 YES, LAUNCH THE T.U.S. CPA D2 IS TUS NAME ASCII ? RSS YES, SEND REQUEST TO TMSYS JMP LTM10 NO, ASK AGAIN STB IP SET LU FOR THE LAUNCH LDA .NAME INA GET ADDR OF NAME LDB .IP1 AND MOVE NAME INTO IP MVW D3 LTM27 LDA LNKCD GET TMS-LINK CODE SPC 1 LTM30 STA TEMP SET TMS-CODE NUMBER LDA ECLAS LAST CHECK THAT THE CLASS SZCA,RSS IS STILL OK JMP LTM80 CLASS NOT DEFINED ! ERROR JSB EXEC SEND INFO TO TMSYS DEF *+8 DEF NAB20 WRITE/READ NO ABORT DEF D0 DEF IP DEF D4 BUFFER LEN DEF D0 DEF TEMP TMS-CODE NUMBER DEF ECLAS CLASS WORD JMP LTM80 ERROR RETURN !! SPC 1 LTM38 JSB EXEC TERMINATE PROGRAM DEF *+9 WITH 'SAVE SUSPENSION POINT' OPTION DEF D6 DEF D0 CURRENT PROGRAM DEF D1 'SAVE SUSP. POINT' OPTION DEF D0 1ST PARAM DEF D0 1ND PARAM DEF D0 3RD PARAM DEF D0 4TH PARAM DEF D0 5TH PARAM SPC 1 ********************************************************************* SPC 1 JMP $LTMS RESTART FORM BEGINING SPC 3 * OPERATOR REQUEST TO ABORT/STOP THE * TMS APPLICATION * LTM40 CLA STA IP+1 LDA ABTCD GET ABORT CODE JMP LTM30 AND SEND REQUEST TO TMSYS SPC 1 LTM41 LDA STPCD GET STOP CODE JMP LTM30 AND SEND REQUEST TO TMSYS SKP * TMSYS INITIALISE THIS PROGRAM: * SAVE LOCALLY THE CLASS I/O WORD, AND * TERMINATE WITH 'SAVE SUSP. POINT' OPTION. * LTM50 LDA STKPT RECALL STKPT CPA =B100001 IS IT OK ? RSS YES CONTINUE JMP LTM90 NO, REPORT ERROR LDA ECLAS VERIFY THAT THE CLASS IS SZA NOT ALREADY DEFINED JMP LTM80 THE CLASS WAS DEFINED ! ERROR LDA IP+1 RECALL 2ND PARAM STA ECLAS TO INIT THE CLASS I/O WORD JMP LTM95 AND TERMINATE 'SAVE SUS. PT' IF OK SPC 2 * TMSYS STOP THE APPLICATION: * TERMINATE THIS PROGRAM WITHOUT ANY OPTION. * LTM60 LDA IP+1 TMSYS REQUEST TO STOP APPL., CHECK CPA ECLAS IF CLASS STILL OK ? JMP LTM99 YES, TERMINATE WIT2H NO OPTION JMP LTM90 NO,REPORT ERROR SPC 3 * SHEDULE WITHOUT STRING PASSING: * LTM70 LDA .IP4 NO STRING PASSES, CHECK FROM STA .NAME 'ETMSP', SET SPECIAL ERROR FLAG LDB IP RECALL FIRST PARAM. LDA IP+4 RECALL 5TH PARAM. SZA,RSS NOT DEFINED ? JMP LTM10 YES, ASK TUS & LU SSA,RSS SPECIAL REQUEST FLAG ? JMP LTM90 NO, REPORT ERROR JMP LTM14 YES, TRY TO DO THE REQUEST HED ERROR PROCESSING LTM80 CLA RESET THE CLASS I/O WORD STA ECLAS LDA .NAME,I RECALL FLAG CPA DM1 SPECIAL SOP/ABORT RQ ? JMP LTM95 YES, TMS ALREADY STOPPED * LTM90 LDA .MES1 REPORT ERROR STA T.001 JSB PNAME DEF *+2 T.001 DEF T.001,I LDA MES+3 MERGE THE ":" IOR A: STA MES+3 JSB EXEC PRINT ERROR MESSAGE DEF *+5 DEF D2 DEF LU DEF MES DEF D18 * LTM95 LDA ECLAS TERMINATE PROGRAM WITH CURRENT OPTION SZA CALL I/O WORD DEFINED ? JMP LTM38 YES, TERMINATE 'SAVE SUSP. PT.' SPC 1 LTM99 CLA RESET THE CLASS I/O WORD STA ECLAS IN CASE OF PROGRAM BEING CORE RESIDENT JSB EXEC DEF *+2 DEF D6 SKP A: OCT 72 ":" L.001 NOP TEMP NOP NAB20 OCT 100024 * .IP1 DEF IP+1 .IP4 DEF IP+4 .IP8 DEF IP+8 .IP12 DEF IP+12 .LU NOP .NAME NOP DM21 DEC -21 DM2 DEC -2 DM1 DEC -1 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D6 DEC 6 D14 DEC 14 D18 DEC 18 D63 DEC 63 D98 DEC 98 D99 DEC 99 END r   92903-18110 1913 S C0122 &TMLIM              H0101 }ASMB HED . T M S - I M A G E L I B R A R Y NAM TMLIM,7 92903-16100 REV.1913 781218 SPC 3 ********************************************************************** * * * NAME: TMLIM TMS-IMAGE CALL * * ENT: TBGET,TBDEL,TBPUT,TBFND,TBUPD,TBULK * * SOURCE: &TMLIM 92903-18110 * * BINARY: %TMLIM ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT TBGET,TBDEL,TBPUT,TBFND,TBUPD,TBULK ENT TBOPN EXT $TML3,$TML5,$TML8 EXT .ENTR,.DRCT,EXEC,DORMT SPC 1 A EQU 0 B EQU 1 SUP HED TERMINAL-MONITOR DBOPN REQUEST TBOPN NOP CLA JSB GETPA SPC 1 JSB UNLCK UNLOCK ALL RECORD FROM PREVIOUS DB SPC 1 LDA .PAR1 INA SKIP THE 1ST WORD LDB ..PA1 AND MOVE DBNAME INTO .PAR7 ADB D6 MVW D4 * LDA .PAR4 IMG STATUS ADDR LDB .PAR1 DB# ADDR DST .PAR2 SAVE THEM LDA RTRN SAVE USER RETURN ADDR STA .PAR1 TO HAVE IT ON RETURN LDA RTNAD GET RETURN ADDR INTO TMLIM STA RTRN SO TMLIB VILL RETURN INTO TMLIiM LDA ..PA1 A = PARAM ADDR JMP .EXIT,I GOTO TMLIB * RTNAD DEF *+1 JSB RCONF RESET POINTER LDA .SAVR RECALL STATUS FROM CB1[14:17] ADA D2 LDB .PAR2 ADDR OF USER STATUS BUFFER MVW D4 MOVE THE STATUS IN USER BUFFER LDA .SAVR,I RECALL DB# ALF,RAR STA .PAR3,I AND STORE IT INTO 1ST WORD OF DBNAME SPC 1 RTN LDA .IMPG RETURN TO THE USER FROM A TMS-IMAGE CALL LDB .SCB1 SAVE CB1[6:13] TO MAKE SUR THE USER MVW D8 DO NOT MODIFY THOSE WORDS. JMP .PAR1,I RETURN HED TERMINAL-MONITOR DBGET REQUEST TBGET NOP LDA D2 SUBROUTINE CODE=2 FOR READ JSB GETPA GO GET PARAMETER SPC 1 CLB SET UP IARG LENGTH LDA .PAR3,I RECALL MODE ADA DM3 IF MODE 1 & 2 NO IARG SSA,RSS LDB .MITL,I IT IS MODE 3 OR 4, GET MAX ITEM LEN STB TEMP * LDB .PAR7 LOCK WORD ADDR JSB GETLW GET LOCK WORD LDA .SAVR MOVE SAVE RUN TABLE BUFFER MVW D8 LDA .PAR3,I GET MODE STA B,I INB LDA .PAR2 MOVE DATA SET NAME MVW D3 LDA .PAR6 MOVE IARG MVW TEMP ADB M.BUF COMPUTE MAIL BOX LENGTH STB BUFLN SET MAIL BOX LENGTH * LDA .PAR4 STATUS USER ADDR LDB .PAR5 USER BUFFER ADDR TBGE8 JSB SENDI GIVE PARAM. ADDR. TO TMLIB & GOTO TMLIB TO SUSP. SPC 1 JSB RECMB RESTORE PARM ADDR & RECEIVE MAIL BOX LDA BUF+1 RECALL TMS-IMAGE-RQ-COD LDB D4 IMAGE STATUS LENGTH ADA DM4 SUBSTRACT 4 FORM IMRQC SSA,RSS DBGET OR DBFND CALL ? CLB,INB NO, IMAGE STATUS LENGTH IS 1 STB TEMP SET IMAGE STATUS LENGTH * LDA .RCBU STORE VALUE INTO USER BUFFER LDB .SAVR RESTORE SAVE RUN TABLE BUFFER MVW D8 LDB .PAR2 STORE IMAGE STATUS IN USER BUFFER MVW TEMP LDB .PAR2,I RECALL IMAGE STATUS SZB WAS IT OK ? JMP RTN NO, DO NOT STORE ENTRY INTO USER BUF. LDB .PAR3 STORE ENTRY (DATA RECORD + MEDIA RECORD) SZB,RSS USER BUFFER ADDR DEFINED ? JMP RTN NO, RETURN IMMEDIATELY INA SKIP WORD COUNT MVW RCBUF+12 USE ENTRY LENGTH JMP RTN RETURN TO USER CODE * D8 DEC 8 DM4 DEC -4 .RCBU DEF RCBUF HED TMS-IMAGE TBULK REQUEST TBULK NOP LDA D8 JSB GETPA SPC 1 JSB UNLCK UNLOCK ALL RECORDS OWN BY THE PROCESS SPC 1 RTNDI LDA RTRN RETURN TO THE USER DIRECTLY STA .PAR1 SET RETURN ADDR JMP RTN AND GO TO CENTRAL RETURN PROCESS SPC 2 UNLCK NOP LDA .SAVR,I GET LOCK ID WORD AND PIDMK ISOLATE PID SZA,RSS ID DEFINED ? JMP UNLCK,I NO, FORGET THE CALL LDA .SAVR,I YES, RECALL DB# - PID STA BUF SEND IT TO TMSYS AND DBMSK KEEP DB# BUT CLEAR PID STA .SAVR,I TO RETURN LCKID TO THE USER * JSB EXEC SEND BUFFER TO TMSYS (USING EXTERNAL CLASS) DEF *+8 DEF D20 CLASS I/O WRITE/READ DEF D0 DUMMY LU DEF BUF BUFFER SEND DEF D1 BUFFER LENGTH DEF STKPT 1ST PARAM. (STACK POINTER) DEF ULKCD 2ND PARAM. (TMS INTERNAL SUBR. CODE) DEF ECLAS TMS EXTERNAL CLASS I/O WORD JMP UNLCK,I SPC 2 D1 DEC 1 D20 DEC 20 PIDMK OCT 17777 DBMSK OCT 160000 SPC 2 IMSCD EQU 23 ULKCD DEC 16 HED TMS-IMAGE DBFND REQUEST TBFND NOP LDA D3 JSB GETPA SPC 1 LDB .PAR6 LOCK WORD ADDR JSB GETLW GET LOCK WORD LDA .SAVR MOVE SAVE RUN TABLE BUFFER MVW D8 LDA .PAR3 MOVE DATA SET NAME MVW D3 LDA .PAR4 MOVE KEY ITEM NAME (IPATH) MVW D3 LDA .PAR5 MOVE KEY ITEM VALUE (IARG) MVW .MITL,I ADB M.BUF STB BUFLN SET MAIL BOX LENGTH * LDA .PAR2 USER BUFFER ADDR FOR STATUS CLB NO BUFFER ADDR (DBGET COMPATIBLE) JMP TBGE8 USE DBGET CODE TO FINISH SPC 2 .MITL DEF *+1 DEC 50 MAXIMUM ITEM LENGTH IN WORD (DEFAULT) .METL DEF *+1 DEC 256 MAXIMUM ENTRY LENGTH IN WORD (DEFAULT) * MBUFL DEC 271 MAXIMUM BUF LEN RETURNED BY TMS-IMAGE-MODULE HED TMS-IMAGE DBPUT/DBUPD/DBDEL REQUEST TBPUT NOP LDA D4 JSB GETPA SPC 1 LDB .D2 FORCE SPECIAL LOCK WORD TO UNLCK JSB GETLW GET UNLOCK REQUEST ONLY LDA .SAVR,I GET LOCK WORD ID STA B,I INB TBPU5 LDA .PAR2 MOVE DATA SET NAME MVW D3 LDA .PAR4,I GET NUMBER OF DEFINED ITEM # INA FOR WORD COUNT STA TEMP LDA .PAR4 MOVE ITEM # DEFINTION ARRAY (INBR) MVW TEMP LDA .PAR5 MOVE ITEMS VALUE (IVALU) MVW .METL,I TBUP8 ADB M.BUF COMPUTE BUFFER LENGTH STB BUFLN SET BUFFER LENGTH * LDA .PAR3 SAVE USER STATUS ADDR CLB JSB SENDI SAVE PARAM ADDR & SEND MAIL BOX SPC 1 JSB RECMB RESTORE PARAM ADDR & RECEIVE MAIL BOX LDA RCBUF RECALL IMAGE STATUS STA .PAR2,I AND STORE IT INTO USER BUFFER JMP RTN RETURN TO USER SPC 2 TBUPD NOP LDA D5 JSB GETPA SPC 1 LDB .D2 FORCE SPECIAL LOCK WORD TO UNLCK JSB GETLW GET UNLOCK REQUEST ONLY LDA .SAVR MOVE SAVE RUN TABLE BUFFER MVW D8 JMP TBPU5 FINISHES LIKE DBPUT CALL SPC 2 TBDEL NOP LDA D6 JSB GETPA SPC 1 LDB .D2 FORCE SPECIAL LOCK WORD TO UNLCK JSB GETLW GET UNLOCK REQUEST ONLY LDA .SAVR MOVE SAVE RUN TABLE AREA MVW D8 LDA .PAR2 MOVE DATA SET NAME MVW D3 JMP TBUP8 * .D2 DEF D2 HED GENERAL TRANSFERT PARAMETER ADDRESS ROUTINE GETPA NOP LDB GETPA  ADB DM3 LDB B,I STB RTRN ADB DM1 STB XSUSP LDX PAR# CLB CLEAR FUTUR PARAMETERS ADRESSES SBX .PAR1-1 TO KNOW HOW MANY PARAMETERS ARE DSX PASSED JMP *-3 STA IMRQC SET UP IMAGE-REQUEST-CODE STA .PA15 SET UP IMAGE-REQUEST-CODE JMP RTRN+1 SPC 1 .PAR1 NOP .PAR2 NOP .PAR3 NOP .PAR4 NOP .PAR5 NOP .PAR6 NOP .PAR7 NOP BSS 7 .PA15 NOP RQCNT NOP XSUSP NOP ABS IMSCD TMS INTERNAL SUBROUTINE CODE FOR IMAGE RQ RTRN NOP JSB .ENTR GET PARAMETERS ADDRESS ..PA1 DEF .PAR1 (HOPE IT IS MICRO-CODED) * CLA STA RQCNT TO BE SURE THAT THE LOOP WILL END LDX D0 GETP7 LAX .PAR1 SZA,RSS PARAMETER HERE ? JMP GETP8 NO, END OF LIST REACHED ISX YES, INCREMENT X REG JMP GETP7 AND LOOP * GETP8 CXA SAVE # OF PARAMETERS STA RQCNT ADA DM10 NEVER MORE THAN 9 PARAMETERS SSA,RSS HLT JSB CONF RECONFIGURE PT ADDR JMP GETPA,I SPC 1 PAR#. EQU RQCNT-.PAR1 PAR# ABS PAR#. HED UTILITY SUBROUTINE D0 DEC 0 DM1 DEC -1 DM3 DEC -3 DM10 DEC -10 SPC 2 GETLW NOP SET LOCK WORD AND INIT BUFFER POINTER CLA DEFAULT VALUE IS ZERO LDA B,I GET LOCK WORD VALUE LDB .BUF INIT B REG = BUFFER WORD POINTER STA B,I STORE LOCK WORD INTO BUFFER INB BUMP POINTER BUFFER JMP GETLW,I SPC 3 SENDI NOP SAVE USER PARAMETERS ADDR AND STA .PAR2 SEND THE BUFFER TO IMAGE MODULE STB .PAR3 THEN EXIT USING TMLIB. LDA RTRN SAVE RETURN ADDR IN USER CODE STA .PAR1 LDA BUFLN ADJUST BUFFER LENGTH ADA D4 STA BUFLN SPC 1 *------------------------------------- * * JSB EXEC CALL TMS-IMAGE-MODULE PROGRAM * DEF *+10 * DEF NAB24 RQUEUE SCHEDULE - NO WAIT - NO ABORT *.IMPG NOP PROGRAM NAME * DEF * * DEF * * DEF * * DEF * * DEF * * DEF IMRQC BUFFER TO PASSED USING STRING PASSING * DEF BUFLN BUFFER LENGTH * HLT 10B ERROR RETURN * *------------------------------------- * JSB EXEC SEND THE REQUEST TO TMS-IMAGE-MODULE DEF *+8 USING THE IMAGE CLASS I/O DEF NAB20 CLASS I/O WRITE/READ - NO ABORT DEF D0 DUMMY LU DEF IMRQC BUFFER ADDR DEF BUFLN BUFFER LENGTH DEF * 1ST PARAM DEF * 2ND PARAM .IMCL NOP ADDR OF IMAGE CLASS I/O WORD HLT 22B ERROR RETURN SZA OK ? HLT 23B ERROR !! * JSB DORMT CHECK STATUS OF THE TMS-IMAGE-MODULE DEF *+3 .IMPG NOP PROGRAM NAME DEF RCONF PROGRAM STATUS RETURNED HERE. * SSA DORMANT ? HLT 23B YES, IT IS IMPOSSIBLE !!! * LDA RCONF RECALL PROG STATUS AND B17 ISOLATE THE STATUS BITS SZA SCHEDULE ? JMP SEND3 YES, DO NOT ISSUE THE SCHEDULE * JSB EXEC NO, SCHEDULE THE TMS-IMAGE-MODULE DEF *+8 DEF NAB24 QUEUE SCHEDULE - NO WAIT - NA ABORT DEF .IMPG,I PROGRAM NAME DEF * 1ST PARAM DEF * 2ND PARAM DEF * 3RD PARAM DEF DM1 4TH PARAM, SPECIAL FLAG ! DEF * 5TH PARAM HLT 25B ERROR RETURN !! * *------------------------------------- SPC 1 SEND3 LDA SENDI GET RETURN ADDR STA RTRN AND SET TMS RETURN ADDR. INTO TMLIM LDA ..PA1 SET A REG = ADDR OF PARAM. AREA JMP .EXIT,I AND GOTO TMLIB ---> TMSYS SPC 3 RCONF NOP RESTORE PARAM ADDR CLA INDICATE RETURN TO THE USER JSB CONF RECONFIGURE LOCAL TABLE ADDR LDA .PARX RESTORE TMS FUNCTION PARAMETERS LDB ..PA1 TO GET BACK USER PARAMETERS ADDR MVW D3 JMP RCONF,I SPC 2 RECMB NOP RESTORE PARAM ADDR & RECEIVE MAIL-BOX JSB RCONF * JSB EXEC GET THE BUFFER FROM TMS-IMAGE-MODULE DEF *+7 DEF NAB21 CLASS I/O GET WITH NO-ABORT DEF .ICLA,I CLASS I/O WORD (TMS INTERNAL CLASS) .BUF DEF BUF BUFFER DEF MBUFL BUFFER LENGTH DEF PARM1 DEF PARM2 HLT 10B ERROR RETURN * LDA PARM1 CHECK THAT CORRECT PARAMETERS CPA STKPT HAVE BEEN RETURNED BY THE RSS TMS-IMAGE-MODULE PROGRAM. HLT LDA PARM2 CPA STKPT+1 RSS HLT * JMP RECMB,I SPC 1 NAB20 OCT 100024 NAB21 OCT 100025 NAB24 OCT 100030 B17 OCT 17 BUFLN NOP SKP CONF NOP STA M.BUF SAVE RETURN TO USER FLAG JSB .DRCT DEF $TML3 STA .SCB1 ADDR OF LOCAL COPY OF CB1[6:13] JSB .DRCT DEF $TML5 PARAMETER TABLE ADDR LDB .TBL MVW D5 * LDB .STKP,I GET STACK POINTER STB STKPT SET STACK POINTER * LDA .PARX GET ADDR OF THE THREE FUNCTION PARAMETERS ADA D3 LDB A,I GET CB1 ADDR ADB D5 STB .IMPG SAVE TMS-IMAGE MODULE PRG. NAME ADDR ADB D3 STB .IMCL SAVE TMS-IMAGE CLASS I/O ADDR INB STB .MITL SAVE MAXIMUM ITEM LENGTH ADDR INB STB .METL SAVE MAXIMUM ENTRY LENGTH ADDR INB STB .SAVR SAVE ADR OF THE SAVE RUN TABLE AREA INA LDA A,I GET CB1 CURRENT LENGTH SSA ENABLED ? JMP ERM07 CB1 NOT ENABLED: ERROR 07 ADA DM19 YES, LENGTH MUST BE AT LEAST 19 SSA LENGTH OK ? JMP ERM07 CB1 TOO SMALL: ERROR 07 * LDB M.BUF RECALL RETURN TO USER FLAG SSB,RSS RETURN TO THE USER ? JMP CONF7 YES, D'ONT DO ANY CHECK * {?LDA IMRQC NO, VERIFY CB1[6:13] AND THE DB# SZA,RSS SUPLLY BY THE USER, TBOPN REQUEST ? JMP CONF7 YES, NO CHECK * LDA .IMPG NO, VERIFY CB1[6:13] LDB .SCB1 ADDR OF LOCAL COPY CMW D8 IS IT THE SAME ? JMP CONF4 YES, IT IS OK NOP NO JMP ERM08 NO, ABORT TMS WITH ERROR # 28 * CONF4 LDA .SAVR,I RECALL DB# FROM CB1(12) AND DBMSK ISOLATE IT AND ALF,RAR ROTATE DB# TO LSB BIT 2-0 CPA .PAR1,I IS IT THE DB# SUPPLY BY THE USER ? RSS YES, IT IS OK JMP ERM11 NO, RETURN IMAGE ERROR # 399 * CONF7 LDA .ECLA,I GET TMS EXTERNAL CLASS I/O STA ECLAS LDA .BUF CMA,INA STA M.BUF MINUS ADDR OF BUF JMP CONF,I * DM19 DEC -19 SPC 1 .TBL DEF *+1 .EXIT NOP ADDR TO EXIT INTO TMLIB .STKP NOP ADDR OF THE STACK POINTER VALUE .PARX NOP FUNCTION PARAMETERS ADDR. IN TMLIB .ECLA NOP TMS EXTERNAL CLASS I/O WORD ADDR .ICLA NOP TMS INTERNAL CLASS I/O WORD ADDR SPC 1 .SAVR NOP ADDR OF LOCK ID WORD M.BUF NOP MINUS ADDR OF BUF SPC 3 ERM11 LDA D399 DBNAME IN TBXXX CALL IS WRONG LDB IMRQC RECALL SUBROUTINE CODE SZB DBOPN ? CPB D2 DBGET ? STA .PAR4,I YES, STORE STATUS CPB D3 DBFND ? STA .PAR2,I YES, STORE STATUS CPB D4 DBPUT ? STA .PAR3,I YES, STORE STATUS CPB D5 DBUPD ? STA .PAR3,I YES, STORE STATUS CPB D6 DBDEL ? STA .PAR3,I YES, STORE STATUS * CPB D7 DBINF ? * STA . ,I YES, STORE STATUS JMP RTNDI AND RETURN ERROR CODE TO THE USER * ERM07 LDA D7 CB1 NOT ENABLED OR TOO SMALL JMP $TML8 * ERM08 LDA D8 USER HAS MODIFIED CB1[6:13] JMP $TML8 SPC 3 D2 DEC 2 D3 DEC 3 D4 DEC 4 D5 DEC 5 D6 640 DEC 6 D7 DEC 7 D399 DEC 399 SPC 1 TEMP NOP PARM1 NOP PARM2 NOP SPC 1 .SCB1 NOP ADDR. OF LOCAL COPY OF CB1[6:13] SPC 2 * BUFFER SEND FORM TMLIM TO TMSIM SPC 1 IMRQC NOP IMAGE REQUEST CODE ECLAS NOP TMS EXTERNAL CLASS I/O WORD STKPT NOP PARAMETER THAT MUST BE SEND BACK WITH ANSWER ABS IMSCD (STACK POINTER/TMS INTERNAL SUBROUTINE CODE) BUF BSS 389 (1+1+3+128+256 TO SEND DBPUT) SPC 1 RCBUF EQU BUF+2 SPC 2 UNS * ORG * DEFINE LAST LOCATION END |D6   92903-18111 1913 S C0322 &$ITMS              H0103 sASMB HED . ** T M S - I M A G E - M O D U L E ** NAM $ITMS,7 92903-16100 REV.1913 781219 SPC 3 ********************************************************************** * * * NAME: $ITMS TMS-IMAGE MODULE * * SOURCE: &$ITMS 92903-18111 * * BINARY: %$ITMS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT $ITMS SPC 1 EXT RMPAR,PNAME,EXEC,CNUMD,PRTN,KLCLS EXT $PARS,DBCRC EXT DBINT,DBOPN,DBCLS,DBUPD,DBDEL EXT DBPUT,DBFND,DBINF,DBGET,DBLCK EXT HASH SPC 1 A EQU 0 B EQU 1 SUP SPC 4 $ITMS STA LOCTB SAVE LOCK TABLE ADDR STA LOCTE AND INIT LOCK TABLE POINTERS STB PROTB STB PROTE LDB A,I RECALL B REG VALUE JSB RMPAR AND RETREIVE PARAMETER DEF *+2 DEF P1 SPC 1 JSB EXEC SWAP THE WHOLE AREA DEF *+3 DEF D22 DEF D3 SWAP THE ENTIRE PARTITION SPC 2 IFZ JSB .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! EXT .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! XIF SPC 2 JSB PNAME GET PROGRAM NAME DEF *+2 .ILIS DEF ILIST+1 SKP * SHEDULE REQUEST ACCEPTED BY THIS PROGRAM: * =========================================== * * * - IF NO STRING IS PASSES: * * * THE 4TH PARAMETER IS CHECKED, IF = -1 THEN THE PROGRAM TRY TO * GET A REQUEST BUFFER ON SPECIAL CLASS ALLOCATED BY THIS PROGRAM * AND RETURNED TO USER ON THE DBOPN CALL. IF THE GET FAIL THE * PROGRAM TERMINATES FOR EVER IF IT WAS DORMANT, OR WITH 'SAVE * SUSPENSION POINT' OPTION IF IT WAS IN THAT STATE. * * IF THE 4TH PARAMATER IS NOT -1, THEN IT IS ASSUMED TO BE A * CLASS I/O WORD AND A CLASS I/O GET IS EXECUTED ON THAT CLASS. * * IF THE GET FAIL, A ERROR MESSAGE IS PRINTED ON THE SYSTEM * CONSOLE AND THE PROGRAM TERMINATES WITH THE CURRENT OPTION. * * IF THE GET SUCCEED, THE FIRST WORD OF THE BUFFER IS ASSUMED * TO BE THE REQUEST CODE. IF IT IS LEGAL (0 =< RQ =<8), THE * REQUEST IS PERFORMED, ELSE THE ERROR MESSAGE IS PRINTED ON * THE SYSTEM CONSOLE AND THE PROGRAM TERMINATES WITH THE * CURRENT OPTION. * * * - IF A STRING IS PASSES: * * * THE FIRST WORD OF THE STRING IS ASSUMED TO BE THE REQUEST CODE * IF IT IS LEGAL (BETWEEN 0 & 8) THE REQUEST IS PERFORMED. * IF THE REQUEST CODE IS NOT LEGAL, THE STRING IS CHECKED AGAINST * ",,1" OPTAIN FROM THE FOLLOWING RTE/FMGR COMMAND "RU,TMSIM,,,1" * * IF THE STRING DOES NOT MATCHE, A MESSAGE IS PRINTED ON THE * TERMINAL USED TO SHEDULE THE PROGRAM, AND THE PROGRAM * TERMINATES WITH THE CURRENT OPTION. * * IF THE STRING MATCHES, AND THE DATA-BASE IS CLOSE, THE * FOLLOWING MESSAGE IS PRINTED: * NO DATA-BASE CURRENTLY OPEN. * * IF THE STRING MATCHES, AND A DATA-BASE IS STILL OPEN, THE * USER IS PROMPTED WITH THE FOLLOWING: * DATA-BASE= * LEVEL WORD= ^ * SEC-CODE= * IF THE USER ANSWER CORRECTLY, THE DATA-BASE IS CLOSED IMMEDIATLY * REGARDLESS OF ANY LOCKING CONSIDERATION, AND THE PROGRAM * TERMINATES FOR EVER. (NO SAVE SUSP. OPTION) * * THIS PROCEDURE SHOULD BE USE ONLY IN CASE OF EMMERGENCY !! * * * THE ERROR MESSAGE PRINTED ON THE TERMINAL IS THE FOLLOWING: * * /XXXXX : ILLEGAL SCHEDULE REQUEST ! SKP * FATAL ERROR # MEANING * * 1 [DBOPN] TMSIM COPY MISSING, NOT LOADED (DONE * LOCALLY BY TMLIM) * 2 [DBOPN] LEVEL ACCESS WORD IS NOT THE GREATER ONE * 3 [DBOPN] USE OF THIS PROGRAM TO ACCES AN OTHER DATA-BASE * 500 THE PROGRAM HAS NOT BEEN INITAILIZED * (NO DBOPN REQUEST) * 501 UPDATE A FILE NOT SAVED IN THE AUTOMATIC * SAVED RUN TABLE. SPC 2 * NEW IMAGE STATUS MEANING * * 397 [IMG-STAT] LOCK TABLE OVERFLOW. * 399 [IMG-STAT] IMAGE TBXXX CALL WITH DATA-BASE NAME THAT HAS NOT * BEEN OPENED TO THIS PROCESS. * 400 [IMG-STAT] ERROR RETURNED WHEN PROCESS SHOULD BE SUSPENDED * AND THE 'NO WAIT' OPTION HAS BEEN SPECIFIED * 401 [IMG-STAT] DEADLOCK ERROR ! * 403 [IMG-STAT] UNLOCK RECORD LOCKED BY AN OTHER PROCESS * 404 [IMG-STAT] UNLOCK RECORD WITHOUT HAVING A LOCKID (NEVER * REQUEST ANY LOCK) * 405 [IMG-STAT] DBPUT IN A MASTER WITHOUT HAVING LOCK THE ENTRY * IN ADVANCE * 406 [IMG-STAT] A PROCESS THAT OWN NON-EXCLUSIVELY A RECORD, TRY * TO LOCK THAT RECORD EXCLUSIVELY. SKP * MAXIMUM VALUE CONSIDERATION * =========================== * * - IMAGE MAXIMUM VALUE: * * MAXIMUM NUMBER OF DATA-SET PER DATA-BASE : 50 v* MAXIMUM NUMBER OF ITEM PER DATA-BASE : 255 * MAXIMUM NUMBER OF ITEM PER DATA-SET ENTRY : 127 * * MAXIMUM ENTRY LENGTH (MEDIA+DATA) : 256 WORDS * MAXIMUM ITEM LENGTH : 63 WORDS * * * - TMS-IMAGE COMMUNICATION MAXIMUM BUFFER LENGTH: * * MAXIMUM BUFFER LENGTH RECEIVED BY THIS PROGRAM IS * FOR A DBPUT CALL : 4+1+1+3+128+256 = 393 = RBULN * WHERE 4,1,1,3 ARE TMS INTERNAL BUFFER * 128 IS INBR (MAX # OF ITEM/DATA-SET + 1) * AND 256 IS IVALUE (MAX ENTRY LENGTH) * * MAXIMUM BUFFER LENGTH SEND BY THIS PROGRAM IS * FOR A DBGET CALL : 2+8+4+1+256 = 271 = SBULN * WHERE 2,8,4,1 ARE TMS INTERNAL BUFFER * AND 256 IS THE ENTRY VALUE (MAX ENTRY LENGTH) * * ANY BUFFER RETURNED BY DBINF SHOULD BE SMALLER THAN THAT. SKP LDA LOCTB GET FWA OF BUFFER LDB PROTB GET LWA OF BUFFER CMB,INB ADB LOCTB COMPUTE LENGTH STA PT SAVE FWA CLA STA PT,I ISZ PT CLEAR THE BUFFER INB,SZB JMP *-3 SPC 1 * ALLOCATE A CLASS I/O WORD, PASSES IT BACK TO THE * CALLER, SO WHEN THE CALLER NEED TO REQUEST THAT PROGRAM * IT CAN USE A SCHEDULE REQUEST OR IF THE PROGRAM IS NOT * DORMANT IT CAN SEND A MAIL BOX USING THIS CLASS I/O * IN ORDER TO NOT SUSPEND ITSELF. * JSB GTCLW ALLOCATE A CLASS I/O STA CLASS SAVE THE CALSS I/O WORD * JMP DEB05 SPC 3 ILSHR LDA P1 SET UP LU SZA,RSS ILSH3 CLA,INA STA P1 LDA .ILIS SET PROGRAM NAME IN THE MESSAGE LDB .MES1 MVW D3 JSB EXEC OUTPUT DEF *+5 "ILLEGAL SHEDULE REQUEST ! " DEF D2 DEF P1 DEF MES DEF D18 LDA ACTIV GET ACTIVE FLAG SZA,RSS PROGRAM ACTIVE ? JSB ABORT NO, TERMINATE PROGRAM JMP EXIT4 YES, SAVE SUSPENSION POINT * MES ASC 5, /XXXXX : ASC 13,ILLEGAL SCHEDULE REQUEST ! D18 DEC 18 D14 DEC 14 D8 DEC 8 .MES1 DEF MES+1 D22 DEC 22 D7 DEC 7 * ILIST DEC 1 BSS 3 * SBULN DEC 271 MAX BUF LEN TO SEND RBULN DEF 393 MAX BUF LEN TO RECEIVE * ISTAT BSS 10 * CLASS NOP * SPC 1 P1 BSS 3 PARAMETERS GET BY RMPAR CLAS# OCT 0 P4 MAY BE THE CLASS I/O WORD NOP HED T-M LIBRARY <---> TMS-IMAGE MODULE COMMUNICATION EXIT5 ADA D2 ADJUST MAIL BOX LENGTH CLB STB ERCOD NO FATAL ERROR REPORTED LDB SCODE RETURN THE TMS-IMSGE-RQ-CODE STB ERCOD+1 TO THE CALLER SPC 1 EXIT6 STA LTEM SET MAIL BOX LENGTH * LDA CLAS# RELEASE CLASS I/O IF NOT ALREADY DONE JSB KLCLX LDA ECLAS RECALL CLASS I/O THAT SHOULD BE USED STA CLAS# TO SEND THE RESULT LDA PARM SET UP OPTIONAL CLASS I/0 PARAMETERS LDB PARM+1 WITH THOSE SUPPLIED BY THE USER JSB PSAM SEND ANSWER TO THE USER USING HIS CLASS I/O DEF ERCOD BUFFER ADDR LTEM NOP BUFFER LENGTH SPC 1 EXIT3 LDA RSTAR,I GET RESTART QUEUE HEAD SZA,RSS SOMETHING TO RESTART ? JMP EXIT4 NO, EXIT RAL,CLE,ERA YES, CLEAR BIT 15 LDB A,I REMOVE THAT PROCESS FROM THE STB RSTAR,I RESTART QUEUE CLB STB A,I CLEAR LINK WORD IN THE PROCESS DIRECTORY INA LDB A,I RECALL CLASS I/O STB CLAS# SET CLASS I/O WORD CLB STB A,I CLEAR CALL I/O IN THE PROCESS DIRECTORY LDA CLAS# SET CLASS I/O WORD IN A REG. JMP DEB15 AND RESTART PROGRAM SPC 1 EXIT4 LDA CLASS TRY TO GET A REQUEST ON THE SPECIAL CLASS JSB GSAM GET NO-WAIT & NO-ABORT SSA,RSS SOMETHING GET ? JMP DEB20 YES, GO PROCESS REQUEST * RTNFL OCT 0 RETURN FLAG (NOP/RSS) TO RTN PARAM TO CALLER JMP EXIT9 IF NOP; EXIT WITHOUT 'PRTN' * SPCLF RSS CLEARED ONLY WHEN SPECIAL CLOSE JMP SPCLS REQUEST IS REQUESTED, RETURN TO SPECIAL PROCESS * JSB PRTN SEND RETURN PARAMETERS TO CALLER DEF *+2 DEF RTPAR RETURN PARAMETRS BUFFER * EXIT9 JSB EXEC COMPLETE THIS PROGRAM DEF *+4 SAVING SUSPENSION POINT. DEF D6 .D0 DEF D0 DEF D1 SPC 1 **************************************************************** SPC 1 JSB RMPAR RETREIVE SCHEDULE PARAMETERS DEF *+2 DEF P1 SAVE PARAMETER * DEB05 CLA SET RETURN FLAG TO NOT USE 'PRTN' STA RTNFL SPC 1 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 DEF D1 .SCOD DEF SCODE BUFFER ADDR DEF RBULN BUFFER LENGTH DST PARM1 SAVE STATUS & LENGTH SZA,RSS STRING GET SUCCED ? JMP DEB18 YES, GO PROCESS REQUEST * LDA CLAS# NO STRING, CHECK FOR A MAIL BOX CPA DM1 WANTS TO GET FROM THE SPECIAL CLASS ? JMP EXIT4 YES, GO DO THE GET SZA,RSS CLASS I/O DEFINED ? JMP ILSH3 NO, PRINT 'ILLEGAL SCHEDULE REQUEST' DEB15 AND =B17777 YES, RELEASE BUFFER ON THE NEXT GET IOR B20K BUT DO NOT DEALLOCATE THE CLASS I/O JSB GSAM GET NO-WAIT & NO-ABORT SSA SOMETHING GET ? JMP ILSH3 NO, PRINT MESSAGE AND EXIT JMP DEB25 YES, PROCESS THE REQUEST SPC 2 DEB18 BLS SET TLOG IN CHARACTERS LDA .SCOD BUFFER ADDR JSB $PARS PARSE THE BUFFER DEF BTEMP AND STORE RESULTE INTO BTEMP * LDA BTEMP+1 RECALL FIRST PARAM VALUE CPA ARU IS IT A "RU, .... " COMMAND ? JMP SPCL3 YES, CHECK FOR EMERGENCY PROCEDURE SPC 1 DEB20 CLA NO CLASS I/O IS DEFINE IN THAT WORD STA CLAS# SPC 2 DEB25 LDA SCODE GET REQUEST CODE SSA NEGATIVE ? JMP ILSH3 YES, ERROR ADA =D-9 GREATER THAN 9 SSA,RSS JMP ILSH3 YES, ERROR LDA SCODE NO, RECALL SUBROUTINE CODE LDB ACTIV RECALL ACTIVE FLAG SZB DATA BASE OPEN ? JMP DEB30 YES, CONTINUE SZA NO, OPEN REQUEST ? JMP ER500 NO, REJECT THIS CALL SPC 1 DEB30 ADA C.TAB INDEX IN TABLE JMP A,I HED EMERGENCY CLOSE PROCEDURE SPCL3 LDA BTEMP+8 VERIFY THAT THE 1ST PARAM SZA IS NOT DEFINED JMP ILSH3 ERROR ! LDA BTEMP+12 VERIFY THAT THE 2ND PARAM SZA IS NOT DEFINED JMP ILSHR ERROR ! LDA BTEMP+16 VERIFY THAT THE 3RD PARAM ADA BTEMP+17 IS "1" CPA D2 COMPARE TYPE+VALUE RSS OK, DO SPECIAL CLOSE REQUEST JMP ILSHR SPC 1 LDA P1 RECALL LU SZA,RSS CLA,INA STA P1 SAVE LU IOR =B400 STA P1+1 SAVE LU FOR INPUT SPC 1 LDA ACTIV DATA-BASE OPEN SZA,RSS OPEN ? JMP SPCL9 NO, REPORT ERROR SPC 1 SPCL5 JSB EXEC PRINT "DATA-BASE=" DEF *+5 DEF D2 DEF P1 LU DEF MSDB BUFFER DEF D7 JSB SPCL0 READ AND PARSE ANSWER CPB D2 ASCII ? RSS YES, OK JMP SPCL5 NO, TRY AGAIN LDB .DBNM CHECK IF CORRECT CMW D3 JMP SPCL6 OK, ASK LEVEL WORD NOP DO NOT COMPARE JMP ILSHR REJECT THE SHEDULE REQUEST * SPCL6 JSB EXEC PRINT "LEVEL =" DEF *+5 DEF D2 DEF P1 DEF MSLE DEF D5 JSB SPCL0 READ AND PARSE ANSWER SZB,RSS NUL ? LDA .SP YES, TAKE DEFAULT ASCII VALUE SZB CPB D2 ASCII ? RSS YES, OK JMP SPCL6 NO, TRY AGAIN LDB .DBN3 CHECK IF CORRECT CMW D3 JMP SPCL7 OK, ASK LEVEL WORD NOP DO N67OT COMPARE JMP ILSHR REJECT THE SHEDULE REQUEST * SPCL7 JSB EXEC PRINT "SEC.-CODE=" DEF *+5 DEF D2 DEF P1 LU DEF MSSC BUFFER DEF D7 JSB SPCL0 READ AND PARSE ANSWER SZB NUL ? CPB D1 NUMERIC ? RSS YES, OK JMP SPCL7 NO, TRY AGAIN LDB A,I CHECK IF CORRECT CPB DBNAM+6 RSS JMP ILSHR REJECT THE SHEDULE REQUEST * CLA,INA SET SCODE FOR DBCLOSE STA SCODE CLA SET SPECIAL CLOSE FLAG STA SPCLF TO RETURN AFTER THE CLOSE JMP XDBC0 * SPCLS LDA .DBNM MOVE DATA-BASE NAME INTO THE MESSAGE LDB .MS9X MVW D3 LDA RTPAR RECALL DBCLOSE IMAGE STATUS SZA,RSS OK ? JMP SPCL8 YES, PRINT MESSAGE SSA NO, PRINT ERROR MESSAGE CMA,INA STA TEMP JSB CNUMD DEF *+3 DEF TEMP DEF MS9+16 LDA .MS8 LDB .MS9Y MVW D8 SPCL8 JSB EXEC PRINT "DATA-BASE XXXXXX SUCCESSFULLY CLOSE" DEF *+5 DEF D2 DEF P1 DEF MS9 DEF D20 JMP EXIT9 SPC 1 SPCL9 JSB EXEC PRINT "NO DATA-BASE CURRENTLY OPEN" DEF *+5 DEF D2 DEF P1 DEF MS7 DEF D16 JSB ABORT TERMINATE PROGRAM JMP EXIT9 SPC 1 MSDB ASC 7, DATA-BASE = _ MSLE ASC 5, LEVEL = _ MSSC ASC 7, SEC.-CODE = _ MS9 ASC 20, DATA-BASE: XXXXXX SUCCESSFULLY CLOSED. MS7 ASC 16, NO DATA-BASE CURRENTLY OPEN ! .MS8 DEF *+1 ASC 8,; CLOSE ERROR : .SP DEF *+1 ASC 3, .MS9Y DEF MS9+9 .MS9X DEF MS9+6 ARU ASC 1,RU .DBN3 DEF DBNAM+3 D16 DEC 16 SPC 1 SPCL0 NOP JSB EXEC READ ANSWER DEF *+5 DEF D1 DEF P1+1 .BUF DEF BUF DEF DM7 LDA .BUF RECALL BUFFER ADDR JSB $PARS PARSE BUFFER DEF BTEMP OUTPUT BUFFER LDA .BTE1  ADDR. OF DATA LDB BTEMP TYPE OF DATA JMP SPCL0,I * .BTE1 DEF BTEMP+1 DM7 DEC -7 HED IMAGE / INTERNAL ERROR PROCESSING ERR? NOP FOR INTERNAL IMAGE RQ, CHECK STATUS LDA ISTAT RECALL IMAGE STATUS JSB .ERR? JMP ERR?,I SPC 2 * FATAL ERROR PROCESSING ---> ABORT CALLER * .ERR? NOP SZA,RSS OK ? JMP .ERR?,I YES, CONTINUE EROR JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! LDB SCODE SZB,RSS OPEN REQUEST ? JMP RTPRG YES, USE SPECIAL RETURN WITH 'PRTN' CPB D1 CLOSE REQUEST ? JMP RTPRG CPB D8 TBULK REQUEST ? JMP RTPRG DST ERCOD SET UP ERROR CODE & REQUEST CODE LDA D2 SET BUFFER LENGTH JMP EXIT6 AND GO SEND THE ANSWER TO THE CALLER SPC 1 ER500 JSB ABORT TERMINATE THE PROGRAM LDA =D500 DATA-BASE HAS NOT BEEN OPENED JMP EROR SPC 2 * IMAGE ERROR PROCESSING ---> THE ERROR NUMBER * IS RETURNED TO THE USER, IN PLACE OF * THE IMAGE STATUS. * SIMST LDB SCODE SET IMAGE STATUS ADB S.TAB A REG = ERROR CODE JMP B,I JUMP TO RIGHT CODE SPC 1 SIMS1 STA BTEMP+8 SET IMAGE STATUS JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JMP XDBF3 AND RETURN * SIMS2 STA BTEMP SET IMAGE STATUS JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JMP XDBP5 AND RETURN SPC 1 S.TAB DEF *+1,I DEF ILRQ DBOPN DEF ILRQ DBCLS DEF SIMS1 DBGET DEF SIMS1 DBFND DEF SIMS2 DBPUT DEF SIMS2 DBUPD DEF SIMS2 DBDEL DEF ILRQ DBINF DEF ILRQ TBULK SPC 2 * TERMINATE THIS PROGRAM WITHOUT ANY OPTION * TO MAKE IT ACTUALLY DORMANT. SPC 1 ABORT NOP LDA .D0 5# STA .D0+1 SUPPRESS TERMINATE OPTION JMP ABORT,I AND TERMINATE PROGRAM. SPC 1 RSTAR DEF *+1 RESTART PROCESS QUEUE OCT 0 SPC 1 ACTIV OCT 0 # OF OPEN/CLOSE REQUEST HED DBOPN PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1:3] (3) DATA-BASE NAME * BUF[4:6] (3) LEVEL ACCESS WORD * BUF[7] (1) SECURITY CODE SPC 1 * RETURN VALUE USING 'PRTN' SUBROUTINE: * * RTPAR[1] (1) 0 / ERROR CODE * RTPAR[2] (1) TMS-SUBROUTINE CODE IF ERROR * RTPAR[3] (1) DATA-BASE CRC * RTPAR[4] (1) MAXIMUM ITEM LENGTH * RTPAR[5] (1) MAXIMUM ENTRY LENGTH SPC 1 XDBOP LDA CLAS# RELEASE MAIL BOX & CLASS JSB KLCLX * LDA ACTIV GET ACTIVE FLAG SZA IS IT THE FIRST ENTRY ? JMP XDBO4 NO, CHECK THAT IT IS THE SAME DATA BASE SPC 1 LDA .BUF SAVE DATA-BASE NAME & LEVEL WORD LDB .DBNM & SECURITY CODE MVW D7 SPC 1 JSB DBINT INITIALIZE RUN TABLE AREA DEF *+5 DEF BUF DATA BASE NAME DEF BUF+6 SECURITY CODE DEF ILIST LIST OF PROGRAM DEF ISTAT JSB ERR? OK ? SPC 1 JSB DBOPN OPEN THE DATA BASE DEF *+6 DEF BUF DATA BASE NAME DEF BUF+3 LEVEL ACCESS WORD DEF BUF+6 SECURITY CODE DEF D2 MODE DEF ISTAT STATUS JSB ERR? OK ? LDA ISTAT+1 RECALL LEVEL ACCESS CPA =D15 IS IT THE HIGHEST LEVEL ? JMP XDBO2 YES, GO LOCK THE DATA BASE LDA D2 NO, DBOPN ERR#2: BAD LEVEL ACCESS WORD JMP EROR PASSES ERROR BACK TO CALLING PRG & TERMINATE SPC 1 XDBO2 JSB DBLCK LOCK THE WHOLE DATA BASE DEF *+3 DEF D2 LOTB@ DATA SET NUMBER (INTO DS#) * LDA BUF+Fp9 RECALL MODE ADA =D-3 SSA TYPE 1 OR 2 ? JSB RSTRT YES, RESTORE RUN TABLE NOP SPC 1 JSB DBGET READ FORM DATA BASE DEF *+6 DEF DS# DATA SET NAME .BF09 DEF BUF+9 MODE DEF BTEMP+8 STATUS RETURNED HERE DEF BTEMP+13 BUFFER DEF BUF+13 IARG LDA BTEMP+8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB SAVRT SAVE RUN TABLE SPC 1 LDA BUF+9 RECALL DBGET MODE JSB LOCK LOCK/UNLCK ENTRY AS REQUESTED SPC 1 LDA ENTLN RECALL ENTRY LENGTH STA BTEMP+12 TO SEND IT XDBG9 ADA D13 SPC 1 LDB LCKID PASSES BACK THE LOCK-ID WORD STB BTEMP (IT IS PROC. INDEX DIRECTORY: PID) LDB LCKID+1 PASSES BACK ALSO THE NEXT WORD STB BTEMP+1 SPC 1 JMP EXIT5 AND RETURN SPC 1 .BF10 DEF BUF+10 D13 DEC 13 HED DBFND PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2:9] (8) LOCK ID AND SAVE RUN TABLE * BUF[10:12] (3) DATA SET NAME * BUF[13:15] (3) KEY ITEM NAME * BUF[16:X] (N) KEY ITEM VALUE SPC 2 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1:8] (8) LOCK ID AND SAVE RUN TABLE * BTEMP[9:12] (4) IMAGE STATUS SPC 2 XDBFN LDA .BF09 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * JSB DBFND SET UP THE CHAIN DEF *+5 DEF BTEMP+8 STATUS DEF DS# DATA SET NAME DEF BUF+12 KEY ITEM NAME DEF BUF+15 KEY ITEM VALUE LDA BTEMP+8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * JSB SAVRT SAVE RUN TABLE SPC 1 CLA SET MODE=0 FOR DBFND REQUEST JSB LOCK LOCK/UNLOCK ENTRY AS REQUESTED SPC 1 XDBF3 CCA TO AJUST BUFFER LENGTH JMP XDBG9 HED DBPUT PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2] (1) LOCK ID WORD * BUF[3:5] (3) DATA SET NAME * BUF[6:X] (N) INBR * BUF[Y:Z] (M) IVALUE SPC 2 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1] (1) IMAGE STATUS SPC 2 XDBPU LDA .BF02 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * LDA BUF+5 RECALL # OF ITEM INA ADA .BF05 STA XDBP3 SET IVALU ADDR SPC 1 LDA D5 SET MODE=5 FOR DBPUT REQUEST JSB LOCK UNLOCK REQUEST AS REQUESTED SPC 1 JSB DBPUT STORE DATA INTO THE DATA BASE DEF *+6 DEF DS# DATA SET NAME DEF BTEMP STATUS .BF05 DEF BUF+5 INBR XDBP3 NOP IVALU DEF BTEMP+1 TEMPORARY BUFFER LDA BTEMP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * XDBP5 CLA,INA MAIL BOX LENGTH JMP EXIT5 RETURN SPC 1 .BF02 DEF BUF+2 HED DBUPD PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2:9] (8) LOCK ID AND SAVE RUN TABLE * BUF[10:12] (3) DATA SET NAME * BUF[13:X] (N) INBR * BUF[Y:Z] (M) IVALUE SPC 2 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/S"yUB # (TMS INTERNAL) * BTEMP[1] (1) IMAGE STATUS SPC 2 XDBUP LDA .BF09 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * JSB RSTRT RESTORE RUN TABLE JMP XDBU7 WRONG DATA SET ---> ERROR # 501 SPC 1 LDA D6 SET MODE=6 FOR DBUPD JSB LOCK UNLOCK ENTRY AS REQUESTED SPC 1 LDA BUF+12 RECALL # OF ITEM INA ADA .BF12 STA XDBU3 SET IVALU ADDR * JSB DBUPD UPDATE ITEM VALUE IN AN ENTRY DEF *+6 DEF DS# DATA SET NAME DEF BTEMP STATUS .BF12 DEF BUF+12 INBR XDBU3 NOP IVALU DEF BTEMP+1 TEMPORARY BUFFER USED BY IMAGE LDA BTEMP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * JMP XDBP5 TERMINATE LIKE DBPUT SPC 3 XDBU7 LDA =D501 BAD RUN TABLE SAVED JMP EROR ERROR # 501 HED DBDEL PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2:9] (8) LOCK ID AND SAVE RUN TABLE * BUF[10:12] (3) DATA SET NAME SPC 2 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1] (1) IMAGE STATUS SPC 2 XDBDE LDA .BF09 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * JSB RSTRT RESTORE RUN TABLE JMP XDBU7 WRONG DATA SET ---> ERROR#501 SPC 1 LDA D6 SET MODE=6 FOR DBDEL JSB LOCK UNLOCK ENTRY AS REQUESTED SPC 1 JSB DBDEL DELETE ENTRY IN A DATA SET DEF *+3 DEF DS# DATA SET NAME DEF BTEMP STATUS LDA BTEMP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * JMP XDBP5 RE|>TURN TO USER PROGRAM HED !!! XDBIN NOP HLT 20B SPC 1 ILRQ STA TEMP NOP HLT 22B SPC 2 CHECK NOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! LIB 1 NOP SSB !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JMP CHECK,I SZA,RSS JMP CHECK,I LDB SCODE CPB D2 JMP CHEC1 CPB D3 JMP CHEC1 JMP CHEC3 CHEC1 CPA =D107 JMP CHECK,I * CHEC3 STA CHEC9 JSB CNUMD DEF *+3 DEF SCODE DEF CHMS+4 JSB CNUMD DEF *+3 DEF CHEC9 DEF CHMS+9 JSB EXEC DEF *+5 DEF D2 DEF D1 DEF CHMS DEF D12 LDA CHEC9 JMP CHECK,I * CHEC9 NOP D12 DEC 12 CHMS ASC 12, DB CODEXXXXXX ERRXXXXXX HED UTILITY SUBROUTINE DSNUM NOP FIND DATA SET NUMBER STA DSNU3 LDA A,I GET FIRST CHAR. OR NUM. STA ISTAT+1 ADA DM256 IS IT ALREADY SSA A NUMBER ? JMP DSNU7 YES, SKIP THE DBINF JSB DBINF DATA SET NAME ---> DATA SET # DEF *+5 DEF S TYPE DEF D5 MODE DSNU3 NOP DATA SET NAME DEF ISTAT STATUS JSB ERR? OK ? DSNU7 LDA ISTAT+1 STA DS# SET DATA SET NUMBER JSB DBINF DS# ---> TYPE/CAPACITY/ENTRY LENGTH DEF *+5 DEF S TYPE DEF D2 MODE DEF DS# DATA SET NUMBER DEF ISTAT STATUS JSB ERR? OK ? LDA .IST4 MOVE INFO LDB .DSTP MVW D3 JMP DSNUM,I * .IST4 DEF ISTAT+4 .DSTP DEF DSTYP DS# NOP DATA SET NUMBER DSTYP NOP DATA SET TYPE (ASCII) CAPAC NOP CAPACITY OF THE DATA SET ENTLN NOP ENTRY LENGTH ITEM# NOP KEY ITEM NUMBER ITMLN NOP ITEM LENGTH SPC 1 KYITM NOP RETREIVE KEY ITEM CHARACTERITICS JSB DBINF DS# ---> K^;EY ITEM # DEF *+5 DEF I TYPE DEF D3 MODE DEF DS# DATA SET NUMBER DEF ISTAT STATUS JSB ERR? OK LDA ISTAT+1 GET NUMBER OF KEY ITEM CPA D1 MUST BE ONLY ONE RSS SINCE THAT ROUTINE IS ONLY CALLED HLT 30B FOR MASTER DATA SET LDA ISTAT+2 GET KEY ITEM # JSB GITLN GET ITEM LEN JMP KYITM,I SPC 1 GIT#L NOP GET ITEM # & LEN FROM ITEM NAME STA GTM#3 SET ITEM NAME ADDR LDA A,I GET FIRST CHAR. OR NUM. STA ISTAT+1 ADA DM256 IS IT ALREADY SSA A NUMBER ? JMP GTM#7 YES, SKIP THE DBINF JSB DBINF ITEM NAME ---> ITEM # DEF *+5 DEF I TYPE DEF D5 MODE GTM#3 NOP ITEM NAME DEF ISTAT STATUS JSB ERR? OK ? GTM#7 LDA ISTAT+1 GET ITEM # JSB GITLN RETREIVE ITEM LENGTH JMP GIT#L,I * DM256 DEC -256 SPC 1 GITLN NOP GET ITEM LENGTH STA ITEM# SAVE ITEM # JSB DBINF ITEM # ---> ITEM LENGTH DEF *+5 DEF I TYPE DEF D2 MODE DEF ITEM# ITEM NUMBER DEF ISTAT STATUS JSB ERR? OK ? LDA ISTAT+6 GET ITEM LENGTH STA ITMLN JMP GITLN,I SPC 2 SAVRT NOP SAVE RUN TABLE INFORMATION JSB DBINF SAVE RUN TABLE DEF *+5 DEF S TYPE DEF D6 MODE DEF DS# DATA SET NUMBER DEF BTEMP+2 BUFFER LDA BTEMP+2 RECALL STATUS JSB .ERR? OK ? * LDA DS# SAVE DATA-SET # STA BTEMP+2 JMP SAVRT,I SPC 1 RSTRT NOP RESTORE RUN TABLE LDA BUF+3 RECALL DATA SET # SAVED CPA DS# SAME DATA SET ? CLB,RSS YES, RESTORE RUN TABLE JMP RSTRT,I NO, EXIT * STB BUF+3 JSB DBINF RESTORE THE RUN TABLE m DEF *+5 DEF R TYPE: RESTORE RUN TABLE DEF D6 MODE DEF DS# DATA SET NUMBER DEF BUF+3 BUFFER LDA BUF+3 RECALL STATUS JSB .ERR? OK ? LDA DS# RESTORE INITIAL MAIL BOX BUFFER STA BUF+3 FOR LOCK ALGORITM ! ISZ RSTRT RETURN OK (P+2) JMP RSTRT,I SPC 1 S ASC 1,S R ASC 1,R I ASC 1,I D. OCT 104 SPC 2 PSAM NOP PUT MAIL BOX INTO SAM DST PARM1 SET PARAMETERS LDA PSAM,I GET BUFFER ADDR STA PSAM2 ISZ PSAM JSB EXEC CALL I/O WRITE/READ DEF *+8 DEF D20 WRITE/READ REQUEST DEF D0 DUMMY LU PSAM2 NOP BUFFER ADDR DEF PSAM,I BUFFER LENGTH DEF PARM1 DEF PARM2 DEF CLAS# CALL I/O WORD SZA HLT 40B ISZ PSAM SET RETURN ADDR JMP PSAM,I SPC 2 GSAM NOP IOR BIT15 SET NO-WAIT BIT STA TEMP JSB EXEC CLASS I/O GET DEF *+7 DEF NAB21 GET NO-ABORT DEF TEMP CLASS I/O WORD DEF SCODE BUFFER ADDR DEF RBULN BUFFER LENGTH DEF PARM1 DEF PARM2 CCA ABORT RETURN, NOTHING HAS BEEN GET JMP GSAM,I RETURN OK * NAB21 OCT 100025 SPC 2 GTCLW NOP ALLOCATED A CLASS I/O CLA WHEN OWNER CLASS I/O WILL BE RELEASE STA GTCLX THIS SUBROUTINE WILL BE REPLACED JSB EXEC BY THE SYSTEM ROUTINE. DEF *+5 THE CLASS MUST BE OWNED BY THE CALLING PROGRAM DEF D19 SO THE ABORT PROCEDURE WILL BE EASIER DEF D0 I.E.: THE PROGRAM WILL BE ABORTED DEF * AND HOPFULLY THE CLASS I/O RELEASED. DEF GTCLX LDA GTCLX IOR B20K SET BIT13 'DO NOT DEALLOACATE' STA GTCLX JSB EXEC DEF *+5 DEF D21 DEF GTCLX DEF * DEF D0 LDA GTCLLX JMP GTCLW,I * GTCLX NOP B20K OCT 20000 D19 DEC 19 SPC 1 KLCLX NOP STA KLCL3 SAVE CLASS I/O WORD JSB KLCLS RELEASE THE CLASS DEF *+2 DEF KLCL3 SZA OK ? HLT 50B JMP KLCLX,I * KLCL3 NOP HED *** LOCKING MEGHANISM *** * FORMAT OF THE BUFFER USED IS AS FOLLOW: * SPC 2 * * 15 8 7 6 5 0 * ADDRESS ******************************** * L * PIDX * * DS # *<--- LOCTB (PT) * ! O * RECORD # * * ! C ******************************** * ! K --->* PIDX *W * DS # * [W] BIT IS THE * ! ! * RECORD # * 'SOMEONE WAITING' * ! T ! ******************************** * ! A ! * .... .... * FREE ENTRY * ! B ! * 0 * * ! + L ! ******************************** [N] BIT IS THE * ! E ! * .... * N* .... * 'NON-EXCLUSIVE * ! ! * .... .... * LOCK FLAG' * ! ! ******************************** * ! ! * *<--- LOCTE * ! ! * * * ! ! . . * \ ! / ! . . * \!/ ! * . ! * ! * ! . . * P ! * *<--- PROTE * R ! ******************************** * O ! *1* LINK IN RESTART QUEUE * PROCESS IN * C ! * CLASS I/O WORD * RESTART QUEUE * E ! *X* # O|F RECORDS LOCKED * * S ! ******************************** * S ----+ POINTER TO LOCK TABLE * PROCESS WAITING * * CLASS I/O WORD * ON A RECORD * D *X* # OF RECORDS LOCKED * * I ******************************** * R * 0 * * E * 0 * * C *X* # OF RECORDS LOCKED *<--- PROTB (PIDPT) * T ******************************** * O * R [X] FLAG SET WHEN PID IS ALLOCATED * Y AND CLEAR WHEN PID IS DEALLOACTED * * SPC 2 * PIDX IS THE PROCESS ID INDEX IN PROCESS DIRECTORY * * PIDPT IS THE PROCESS ID POINTER INTO THE PROCESS DIRECTORY SKP * LOCK PERFORM ALL LOCKING/UNLOCKING FUNCTION * * CALLING SEQUENCE: * LDA MODE (IDENTIFY IMAGE FUNCTION PERFORMED) * JSB LOCK * RETURN ONLY IF FUNCTION IS CORRECTLY PERFORMED. * * IF AN ERROR IS FOUND OR IF THE PROCESS NEED TO BE SUSPENDED * EXIT IS DONE DIRECTLY. (NO RETURN TO CALLING PRG) SPC 1 LOCK NOP STA LOCKM SAVE MODE * LDA LOCKW GET FUNCTION TO BE PERFORMED AND D3 MASK BIT 0 & 1 - LOCK & UNLCK BIT SZA,RSS ANY FUNCTION REQUESTED ? JMP LOCK,I NO, RETURN TO CALLER * LDA LOCKW RECALL LOCK WORD TO AND D4 SET THE LOCK EXCLUSIVE FLAG ALF FROM BIT2 TO BIT6 STA LCKXF SET LOCK EXCLUSIVE FLAG SPC 1 JSB SPIDD ACCESS PROCESS ID DIRECTORY RSS PID WAS NOT DEFINED, AND UNLOCK IS REQUESTED ! JMP LCK20 PID IS OK, CONTINUE THE LOCKING/UNLOCKING PROCESS SPC 1 LDA LOCKM LOCKID WAS NOT DEFINED, CHECK THE RQ CPA D5 DBPUT ? RSS YEB@ EXCLUSI. * LKX30 LDA PT UNLOCK THE RECORD ADA D2 INITIALIZE THE BEGINING STA PT0 OF THE LOCK TABLE JSB UNLCK AND PERFORM THE UNLOCK FUNCTION JMP LKX00,I AND EXIT SPC 1 * ADD AN ENTRY IN THE LOCK TABLE. * LKX50 LDA LOCKW RECALL LOCK WORD SLA,RSS LOCK REQUESTED ? JMP LKX00,I NO, RETURN TO CALLER LKX52 LDA PIDX YES, ADD AN ENTRY IN THE LOCK TABLE ALF,ALF IOR DS# MERGE PID INDEX WITH DATA SET # IOR LCKXF MERGE EXCLUSIVE/NON-EXCLUSIVE FLAG LDB PTHOL GET ADDR OF LAST EMPTY ENTRY STA B,I TO STORE IT INTO THE TABLE INB LDA REC# SAVE ALSO RECORD NUMBER STA B,I INTO THE TABLE INB LDA PTHOL WAS IT AT THE CPA LOCTE END OF THE LOCK TABLE ? STB LOCTE YES, UPDATE END OF LOCK TABLE ISZ PIDPT,I INCREMENT # OF RECORD LOCKED JMP LKX00,I AND RETURN TO CALLER SPC 2 * SUSPEND CALLING PROCESS IF IT IS A LOCK REQUEST * WITH WAIT OPTION AND NO DEADLOCK OCCURS. * LK2X70 LDB LOCKW RECALL LOCK WORD RBR,SLB UNLOCK REQUESTED ? JMP LCKE3 YES, ERROR # 403 * LDA LCKXF IS EXCLUSIVE LOCK SZA,RSS REQUESTED ? JMP LKX71 YES, SUSPEND THE PROCESS LDA PT,I NO, HOW IS THE RECORD LOCKED AND BIT6 SZA,RSS RECORD LOCKED EXCLUSIVELY ? JMP LKX71 YES, SO SUSPEND THE PROCESS * LKX75 LDA PT NO, MAKE SURE THAT RECORD IS NOT ADA D2 ALREADY OWNED BY THE CARRENT PROCESS JSB SLTB0 SCAN THE END OF THE LOCK TABLE JMP LKX52 END OF TABLE, THIS REC. CAN BE LOCKED (NON-EXCLUS.) LDA PT,I AN OTHER ENTRY WHICH LOCK THE SAME AND BIT6 RECORD HAS BEEN FOUND, VERIFY THAT SZA,RSS IT IS LOCKED WITH NON-EXCLUSIVE OPTION HLT 13B EXCLUSIVE LOCK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! LDA PT,I RECALL FIRST WORD IN THE LOCK TBALE ALF,ALF TO RETEIVE THE OWNER OF THAT ENTRY AND =B377 GET PID CPA PIDX IS THE OWNER THE CURRENT PROCESS ? JMP LKX00,I YES, ALREADY OWNED, FORGET THE REQUEST JMP LKX75 NO, CONTINUE SCANNING UP TO THE END OF TABLE * LKX71 LDA =D400 NO WAIT ERROR = 400 LDB LOCKW RECAL LOCK WORD SSB NO WAIT REQUEST ? JMP SIMST YES, RETURN ERROR# 400 TO USER IN IMAGE ST * LDA PT,I RETREIVE IF THERE IS A DEADLOCK CONDITION LKX72 ALF,ALF ISOLATE OWNER OF THE RECORD AND =B377 CPA PIDX IS OWNER IS THE CALLING PROCESS ? (ALWAYS FAIL 1ST TIME) JMP LCKE1 YES, DEADLOCK CONDITION, ERROR # 401 CMA,INA NO, CHECK IF THE OWNER IS SUSPENDED INA MPY D3 RETREIVE POINTER ON A RECORD FROM ADA PROTB THE PROCESS ID DIRECTORY ADA DM2 TO ACCESS POINTER LDB A,I GET POINTER TO RECORD LOCK TABLE LDA B,I GET RECORD OWNER-DS# FROM LOCK TABLE SZB,RSS PROCESS SUSPENDED ? SS JMP LKX74 NO, PROCEED WITH THE SUSPEND SSB,RSS CHECK IF IN RESTART QUEUE, IF YES SKIP JMP LKX72 NOT RST. QUEUE, IT IS SUSP., TRACK DOWN ONE MORE * LKX74 LDA ITMLN RECALL ITEM LENGTH TO SAVE ADA D19 INTO SAM THE EXACT LENGTH (19+ITEMLN) STA LKX77 SET BUFFER LEN JSB PSAM SEND BUFFER INTO SAM DEF SCODE BUFFER ADDR LKX77 NOP BUFFER LENGTH * LDA CLAS# OK, SUSPEND THE CALLING PROCESS LDB PIDPT SAVE CLASS I/O INTO THE PID DIRECTORY ADB DM1 STA B,I ADB DM1 UPDATE POINTER LDA PT AND SAVE POINTER TO RECORD LOCK TABLE STA B,I INTO THE DIRECTORY LDA PT,I RECALL THE RECORD LOCK ENTRY IOR BIT7 TO SET 'SOMEONE IS WAITING' BIT STA PT,I JMP EXIT3 EXIT WITHOUT DOING THE IMAGE CALL SPC 2 LCKE3 LDA =D403 ERROR # 403, UNLCK REC. LOCKED BY AN OTHER JMP SIMST GO SET IMAGE STATUS * LCKE4 LDA =D404 ERROR # 404, UNLCK REC. WITHOUT A LOCK ID JMP SIMST GO SET IMAGE STATUS * LCKE5 LDA =D405 ERROR # 405, PUT IN A MASTER WITHOUT LOCK ID JMP SIMST * LCKE6 LDA =D406 ERROR # 406, GO FROM NON-EXCLUSIVE TO JMP SIMST EXCLUSIVE LOCK IN THE SAME PROCESS * LCKE1 LDA =D401 DEADLOCK ERROR = 401 JMP SIMST GO SET IMAGE STATUS SPC 1 REC# NOP LCKXF NOP EXCLUSIVE LOCK FLAG IN BIT 6 .BF13 DEF BUF+13 SKP * UNLOCK: CLEAR AN ENTRY IN THE LOCK TABLE * OR RESTART A WAITING PROCESS AND GIVE THAT * ENTRY TO THIS WAITING PROCESS. * * THE ADDRESS OF THE ENTRY CLEARED OR PASSED IS IN PT * * NOTE: WHEN A NON-ECLUSIVE LOCK IS RESTARTED AFTER BEING SUSPSENDED * IT BECOMES A EXCLUSIVE LOCK REQUEST, ALSO ONLY ONE PROCESS IS * RESTARTED AT A TIME EVEN IF MORE THAN ONE NON-ECLUSIVE LOCK * REQUEST IS SUSPENDED (WHENDa A PROCESS IS RESTARTED NO CHECK IS * MADE FOR EXCLUSIVE/NON-EXCLUSIVE LOCK). * THOSE ARE NOT ACTUALLY BUGS BUT CAN BE IMPROVE IN THE FUTURE! * UNLCK NOP LDA PT,I RECALL THE ENTRY FROM THE LOCK TABLE ALF,ALF ROTATE TO GET 'SOMEONE IS WAITING' BIT SSA,RSS SOMEONE WAITING ? JMP UNLC8 NO, CLEAR ENTRY * RAL CHECK 'NON-EXCLUSIVE LOCK' BIT SSA JMP ULC72 NO-EXCL., VERIFY THAT NO OTHER ENTRY EXIST * ULC40 CLA EXCLUSIVE LOCK, SEARCH WHICH PROCESS WAIT STA TEMP INIT # OF WAITERS COUNTER LDA PROTE SEARCH WAITERS ULC42 JSB SRCWT IN THE PROCESS ID DIRECTORY JMP ULC45 END OF DIRECTORY RETURN STA TEMP1 SAVE DIRECTORY ADDR OF THE WAITER ISZ TEMP COUNT THE # OF WAITER JMP ULC42 AND LOOP UNTIL END ULC45 LDA TEMP GET # OF WAITERS SZA,RSS MUST BE AT LEAST ONE HLT 65B !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SPC 1 * PASSES THIS ENTRY TO ONE OF THE WAITERS AND * RESTART IT. * LDB RSTAR YES, RESTART WAITERS, GET RESTART ULC52 LDA B,I QUEUE HEAD, GET NEXT ELEMENT OF THE QUEUE SZA,RSS END OF QUEUE ? JMP ULC54 YES, ADD THE NEW ONE RAL,CLE,ERA NO, CLEAR BIT 15 AND LDB A GO GET NEXT ONE JMP ULC52 * ULC54 STA TEMP1,I SET NEW END OF QUEUE LDA TEMP1 SET BIT15 IN THE ADDR TO INDICATE IOR BIT15 LINK INTO THE RESTART QUEUE INSTEAD OF STA B,I POINTER TO LOCK TABLE. LDB TEMP1 RECALL ADDR INTO THE PROCESS DIRECTORY ADB D2 TO ACCESS THE # OF RECORD LOCKED ISZ B,I INCREMENT # OF RECORDS LOCKED JSB SPIDX COMPUTE THE PIDX OF THE WAITER ALF,ALF ROTATE IT INTO UPPER BYTE STA TEMP1 AND SAVE IT LDA PT,I GIVE THIS RECORD TO THE WAITER AND MASK1 CLEAR OLD PIDX AND 'NON-EXCLUS. LOCK' FLAG IOR TEMP1 AND PUT THE NEW ONE LDB TEMP RECALL # OF WAITERS CPB D1 ONLY ONE WAITERS ? AND NBIT7 YES, CLEAR BIT [W] STA PT,I AND STORE IT BACK JMP UNLC9 SPC 1 * NO-EXCLUSIVE LOCKED RECORD IS RELEASED, * DO NOT RESTART THE WAITER, BUT SET WAIT BIT * IN ONE OF THOSE IDENTICAL ENTRY IN THE LOCK TABLE * AND MAKE ALL WAITERS WAIT ON THAT ENTRY * ULC72 DLD PT,I RE-INIT RC# & DS# ( FOR THE TBULK COMMAND STB REC# THAT HAS NOT INITIATED THOSE VARIABLE) AND B77 STA DS# * LDA PT SAVE CURRENT POINTER IN THE LOCK TABLE STA TEMP INA AND CLEAR TEMPORARILY THIS ENTRY CLB STB A,I TO MAKE SURE AN OTHER ONE IS FOUND * LDA PT0 RECALL THE STARTING OF THE LOCK TABLE JSB SLTB0 AND SCAN THE END OF THE LOCK TABLE JMP ULC75 NO OTHER ENTRY LIKE THIS, RESTART WAITER LDB PT AN OTHER ENTRY IS FOUND, RESTORE PT LDA TEMP AND SAVE THE NEW ENTRY POINTER STA PT INTO TEMP STB TEMP LDA B,I IOR BIT7 SET THE "WAIT BIT" INTO THAT ENTRY STA B,I * LDA PROTE MAKE ALL THE WAITERS ULC73 JSB SRCWT WAIT ON THIS NEW ENTRY JMP UNLC8 NO MORE WAITERS, CLEAR THE ENTRY IN LOCK TABLE LDB TEMP RECALL LOCK TABLE ENTRY ADDR STB A,I AND STORE IT INTO THE DIRECTORY JMP ULC73 LOOP UNTIL END OF DIRECTORY * ULC75 LDB TEMP SINCE NO IDENTICAL ENTRY EXIST IN THE STB PT LOCK TABLE, RESTORE THE ENTRY AND INB RESTART THE WAITING PROCESS LDA REC# STA B,I JMP ULC40 RESTART THE WAITER SPC 1 * DELETE AN ENTRY IN THE LOCK TABLE. * UNLC8 CLA LDB PT CLEAR THE ENTRY IN THE LOCK TABLE STA B,I INB c STA B,I * UNLC9 LDA PIDPT,I ADA DM1 DECREMENT # OF RECORD OWNED BY THE STA PIDPT,I CURRENT PROCESS JMP UNLCK,I AND EXIT SPC 2 SRCWT NOP SEARCH THE WAITERS INTO THE PROCESS CPA PROTE ID DIRECTORY, FIRST CALL ? RSS YES, DO NOT BUMP POINTER SRCW3 ADA D2 NO, BUMP POINTER CPA PROTB END OF DIRECTORY ? JMP SRCWT,I YES, RETURN P+1 INA NO, CHECK THIS ENTRY LDB A,I GET POINTER TO LOCK TABLE ENTRY CPB PT WAITING ON THIS ENTRY ? RSS YES, RETURN P+2 JMP SRCW3 NO, CONTINUE ISZ SRCWT JMP SRCWT,I SPC 5 * SEARCH IN THE PROCESS ID DIRECTORY * * CALLING SEQUENCE: * JSB SPIDD * RETURN P+1 - UNLOCK REQUEST AND NO LOCK ID IS DEFINED !! * RETURN P+2 - OLD OR NEW PID * * ON RETURN P+2, PIDPT & PIDX ARE SET UP SPC 1 SPIDD NOP SEARCH IN PROCESS ID DIRECTORY LDA LCKID RECALL LOCKID WORD (DB#-PID) FROM AND PIDMS USER BUFFER AND ISOLATE PID STA PIDX SET PID SZA IS PID DEFINED ? JMP SPID4 YES, SETUP PIDPT LDA LOCKW NO, RECALL LOCK WORD RAR,SLA UNLOCK REQUEST ? JMP SPIDD,I YES, ERROR * LDB PROTB GET START OF PROCESS ID DIRECTORY SPID2 CPB PROTE END OF DIRECTORY ? JMP SPID3 YES, SETUP NEW PID LDA B,I GET # OF RECORD LOCKED SZA,RSS PID FREE HERE ? JMP SPID3 YES ADB DM3 NO, GO TO NEXT ENTRY JMP SPID2 CONTINUE * SPID3 STB PIDPT INIT PIDPT JSB SPIDX COMPUTE PIDX STA PIDX SET PID (FIRST IS ONE) IOR LCKID MERGE WITH DB# TO BUILD LOCKIDWORD STA LCKID SET IT THERE IN CASE OF SUSPEND LDB PIDPT RESTORE B TO LDA BIT15 INIT THE PROCESS ID DIRECTORY STA B,I SET # OF REC. LCK ADB DM1 CLA STA B,I SET CLASS I/O WORD ADB DM1 STA B,I SET POINTER TO LCK TABLE LDA PIDPT WAS IT A NEW PID CPA PROTE ADDED AT THE END ? RSS YES, UPDATE END OF DIRECTORY JMP SPID5 NO, RETURN OK ADB DM1 YES, UPDATE B AND STB PROTE SET NEW END OF PROCESS ID DIREC. JSB PACK PACK LOCK TABLE IF NECESSARY JMP SPID5 AND RETURN OK * SPID4 CMA,INA CALCULATE THE PID POINTER INA MPY D3 ADA PROTB STA PIDPT SET PID POINTER SPID5 ISZ SPIDD JMP SPIDD,I AND RETURN OK * PIDMS OCT 17777 PID # MASK SPC 3 SPIDX NOP CMB,INB ADB PROTB COMPUTE CLA DIRECTORY INDEX SWP DIV D3 INA (PID# MUST BE < 17777 OCTAL) !!! JMP SPIDX,I EXIT WITH A=PIDX SPC 2 * SEARCH IN RECORD LOCK TABLE * * CALLING SEQUENCE: * PRIOR CALLING THIS FUNCTION, SET UP THE FOLLOWING: * REC#, DS#, PIDX * JSB SLTBL * RETURN P+1 - RECORD NOT LOCKED * RETURN P+2 - RECORD IS LOCKED BY AN OTHER PROCESS * RETURN P+3 - RECORD IS LOCKED BY THE CALLING PROCESS * * ON RETURN P+2 & P+3, THE ADDRESS OF THE ENTRY ACCESSED * IS SAVED INTO PT, AND THE ADDRESS OF * THE LAST EMPTY ENTRY IN THE LOCK TABLE * IS SAVED INTO PTHOL SPC 2 SLTBL NOP SEARCH IN LOCK TABLE LDA REC# CHECK THAT REC# IS NEVER NUL (0) SZA,RSS HLT 67B !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! LDA LOCTE INIT LAST EMPTY ENTRY IN LOCK TABLE STA PTHOL WITH THE END OF TABLE LDA LOCTB GET FIRST ADDR OF LOCK TABLE * JSB SLTB0 LOOK IN THE LOCK TABLE JMP SLTBL,I END OF TABLE, RETURN NO SUCH RECORD LDA PT,I \RECALL FIRST WORD OF THE ENTRY IN THE ALF,ALF LOCK TABLE AND ISOLATE THE PID AND =B377 CPA PIDX RECORD OWNED BY THE CALLING PROCESS ? ISZ SLTBL YES, EXIT P+3 (RECORD BELONG TO CALLING PROCESS) ISZ SLTBL NO, EXIT P+2 (RECORD LOCKED BY ANOTHER PROCESS) JMP SLTBL,I SPC 2 SLTB0 NOP SLTL2 STA PT CPA LOCTE END OF LOCK TABLE ? JMP SLTB0,I YES, EXIT P+1 (RECORD NOT FOUND) DLD PT,I GET LOCK ENTRY CPB REC# IS IT THE SAME RECORD RSS YES, JMP SLTL4 NO, GO GET NEXT ENTRY AND B77 MASK OUT DATA SET # CPA DS# IS IT THE SAME DATA-SET ? JMP SLTL6 YES, RETURN P+2 SLTL4 LDA PT GO TO NEXT ENTRY SZB,RSS IS THAT ENTRY EMPTY ? STA PTHOL YES, UPDATE LAST EMPTY ENTRY IN THE LOCK TABLE ADA D2 JMP SLTL2 CONTINUE * SLTL6 ISZ SLTB0 RETURN P+2 ( RECORD FIND IN THE JMP SLTB0,I LOCK TABLE) SPC 2 PIDPT NOP PID DIRECTORY POINTER PIDX NOP PID DIRECTORY INDEX PT NOP PT0 NOP PTHOL NOP LAST EMPTY ENTRY IN THE LOCK TABLE * LOCTB NOP FWA OF LOCK TABLE LOCTE NOP LWA OF LOCK TABLE PROTB NOP FWA OF DIRECTORY (DIRECTORY IS BACKWARD) PROTE NOP LWA OF DIRECTORY LOCKM NOP * BIT6 OCT 100 BIT7 OCT 200 NBIT7 OCT 177577 B77 OCT 77 MASK1 OCT 277 CLEAR UPPER BYTE & BIT 6 SPC 3 * THIS PROGRAM PACKS THE LOCK TABLE SPC 1 PACK NOP LDB LOCTE CHECK IF PACK IS NEEDED ADB D6 CMB,INB ADB PROTE SSB,RSS NEEDED ? JMP PACK,I NO, RETURN IMMEDIATELY * LDA LOCTB YES, GET START ADDR OF LOCK TABLE STA PACKA INIT FROM POINTER STA PACKB INIT TO POINTER * PACK2 LDA PACKA CHECK FOR END OF TABLE CPA LOCTE END OF TABLE ? JMP PACK8 YES DLD PACKA,I GET OAN ENTRY SZA,RSS ENTRY HERE ? JMP PACK4 NO, ENTRY EMPTY PACK3 DST PACKB,I YES, STORE IT BACK AND BIT7 MASK OUT SOMEONE IS WAITING BIT SZA,RSS IS SOMEONE WAITING ? JMP PACK7 NO, FORGET DIRECTORY BUSINESS * LDA PROTB YES, UPDATE DIRECTORY CONTENT PACK6 CPA PROTE TO REFLECT THE CHANGE JMP PACK7 IT IS THE END OF DIRECTORY ADA DM2 TO GET LOCK TABLE POINTER LDB A,I GET POINTER ADA DM1 CPB PACKA DIRECTORY REFERS TO THE MODIFIED ONE ? INA,RSS YES, MODIFY DIRECTORY JMP PACK6 NO, CONTINUE LDB PACKB SET NEW POINTER VALUE STB A,I INTO THE DIRECTORY ADA DM1 JMP PACK6 CONTINUE * PACK7 ISZ PACKA BUMP POINTERS TO LOCK TABLE ISZ PACKA ISZ PACKB ISZ PACKB JMP PACK2 AND LOOP UNTIL END OF LOCK TABLE * PACK4 ISZ PACKA SKIP THE EMPTY SPACE ISZ PACKA LDA PACKA CHECK FOR END OF TABLE CPA LOCTE END OF LOCK TABLE ? JMP PACK8 YES DLD PACKA,I GET ENTRY SZA,RSS ENTRY EMPTY ? JMP PACK4 YES, LOOP ON EMPTY ENTRY JMP PACK3 NO, STORE ENTRY AND UPDATE DIRECTORY SPC 1 PACK8 LDA PACKB SET UP NEW END OF LOCK TABLE CPA LOCTE ONE HOLE FOUND ? JMP PACK9 NO FATAL ERROR STA LOCTE YES, SET NEW END OF LOCK TABLE JMP PACK,I * PACK9 LDA =D397 ERROR LOCK TABLE OVERFLOW JMP SIMST GO SET IMAGE STATUS SPC 1 PACKA NOP PACKB NOP HED CONSTANTS & VARAIBLES DM3 DEC -3 DM2 DEC -2 DM1 DEC -1 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D5 DEC 5 D6 DEC 6 D20 DEC 20 D21 DEC 21 * BIT15 OCT 100000 SPC 1 TEMP NOP TEMP1 NOP PARM1 NOP PARM2 NOP SPC 1 C.TAB DEF *+1,I DEF XDBOP 0 - DBOPN DEF XDBCL 1 - DBCLS DEF XDBGE 2 - DBGET DEF XDBFuB@ SOFT STOP, * C * TIME=5MN IF 98 OR -IPAR2 IF <0 * C * - ANY OTHER VALUE --> HARD STOP * C * * C * THIS CALL WILL STOP THE TMS APPLICATION * C * IF RUNNING. * C * IF NOT RUNNING, NOTHING HAPPENS. * C ********************************************* C C DIMENSION NAME(3) LOGICAL DORMT DATA NAME/2HL ,2H ,2H / C CALL MOVCA(IPAR1,1,NAME,2,4) IF(IDGET(NAME).EQ.0) RETURN IF(IDGET(IPAR1).EQ.0) RETURN J=98 K=5 IF(IPAR2.EQ.98) GOTO 5 K=-IPAR2 IF(K .GT. 0) GOTO 5 J=99 5 CALL EXEC(23,NAME,J,K,0,0,-1) 10 IF( DORMT(IPAR1) ) RETURN CALL EXEC(12,0,1,0,-50) GOTO 10 END END$     92903-18201 1913 S C0122 &DCMON              H0101 {FTN4 PROGRAM DCMON(3,50),92903-16200 REV.1913 781212 C C C NAME: DCMON DATACAP MONITOR PROGRAM C SOURCE: &DCMON 92903-18201 C BINARY: %DCMON ----NONE--- PART OF RDCMON 92903-16200 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C **************************************************************** C * * C * THIS PROGRAM IS SCHEDULED EACH TIME ONE OF THE F2, F3, F5 * C * F6, F7 OR F8 SOFT KEY ON THE 2645/2648 CRT TERMINAL IS * C * USED. * C * THOSE SOFT KEY ARE LOADED LIKE THIS BY 'DCMON' IN THE * C * SUBROUTINE 'DCSFK'. * C * THIS PROGRAM IS ALSO SCHEDULED EACH TIME ONE THE DATACAP * C * PROGRAM (I.E.: TGP, TMPGN, TMP ) TERMINATES IN ORDER TO * C * RESTORE THE SOFT KEY FOR THE NEXT TASK THAT THE USER WILL * C * REQUEST. * C * * C * INTEGER DCMON, DATA DCMON/2HDC,2HMO,2HN / * C * CALL EXEC(100030B,DCMON,LU,P1) * C * GOTO XXX DCMON IS NO RP'ED * C * RETURN OK: DCMON HAS BEEN SCHEDULED. * C * * C * :RU,DCMON,,P1,P2 * C * Z * C * P1 FUNCTION PARAMETER * C * * C * P1 = 0 -------> PRINT GENERATOR SCREEN * C * P1 = 1 -------> PRINT TMP SCREEN * C * * C * P1 = 2 -------> RU,TMPX ( X = P2 ) * C * P1 = 3 -------> RU,LTMPX,,TSE ( X = P2 ) * C * P1 = 4 -------> CALL ETMSP(TMPX,98) ( X = P2 ) * C * * C * * C * TMP COPY NUMBER X (1 OR 2) IS DEFINED BY P2 * C * * C **************************************************************** C C DIMENSION IPARM(5),IMESA(30),TMPX(3),LTMPX(3),PARM(4) . ,TSE(3),COMAD(35),ON(2),CRLF(3),EROR(8) . ,BADCH(11),BUSY(19),BUSI(16),NOVA(17) . ,IREG(2),DRCTY(128),IPOB(3),IBORT(32) C INTEGER TMPX,PARM,TSE,COMAD,ON,CRLF,EROR,BADCH . ,BUSY,BUSI,AREG,BREG,DRCTY EQUIVALENCE (REG,IREG,AREG),(IREG(2),BREG) LOGICAL ISBTW INTEGER DORMT C C-----FIXED CHARACTER STRINGS C C-----PROGRAM NAMES C DATA TMPX/2HTM,2HP ,2H / DATA TSE/2HTS,2HE ,2H / DATA LTMPX/2HLT,2HMP,2H / DATA ON/2HON,2H, / C C-----FORMAT MODE OFF, MEMORY UNLOCK, BLOCK MODE OFF, UNLOCK KEYBOARD C-----HOME UP CURSOR, CLEAR DISPLAY C DATA IMESA/15530B,15555B,15446B,65460B,41040B,15542B,15510B, .15512B/ DATA IBORT/15530B,15555B,15446B,65460B,41040B,15542B,15510B, .15512B,15446B,62102B,40B, .2HO.,2HK ,2HTO,2H S,2HTO,2HP ,2HTM,2HP ,2H ?,2H ,2H(Y, .2H/N,2H) ,2H: ,20040B,15446B,62100B,15504B,15504B,15504B, .20~137B/ DATA CRLF/6412B,6412B,15512B/ DATA EROR/15446B,62103B,2HER,2HRO,2HR!,15446B,2Hd@,2H / DATA BADCH/2HBa,2Hd ,2Han,2Hsw,2Her,2H. ,15510B,15446B . ,2Ha+,2H29,2HC_/ DATA BUSY/2HTh,2He ,2HTM,2HP ,2His,2H a,2Hlr . ,2Hea,2Hdy,2H s,2Hta,2Hrt,2Hed,2H. ,5*2H / DATA BUSI/2HTh,2He ,2HTM,2HP ,2His . ,2H s,2Hhu,2Ht ,2Hdo,2Hwn,2H. ,5*2H / DATA NOVA/2HTh,2He ,2HTM,2HP ,2His . ,2H n,2Hot,2H d,2Hef,2Hin,2Hed,2H. ,5*2H / C C C-----GET TERMINAL LOGICAL UNIT # AND FUNCTION C CALL RMPAR(IPARM) LUCRT=LOGLU(I) CALL EXEC(3,2200B+LUCRT,0) IFONC=IPARM(2) IF(IFONC.EQ.1) GOTO 2100 IF(.NOT.ISBTW(IFONC,2,4)) GOTO 20 C C-----PRINT SCREEN ON THE CRT AND PROGRAM S.F.K. --2645A-- C CALL DCSFK(LUCRT,0) GOTO 9999 C C-----START TMP/TMPD, START TSE FOR TMP/TMPD OR STOP TMP/TMPD C 20 INOMB=2H1 IF(IPARM(3).NE.0) INOMB=2H2 CALL EXEC(2,LUCRT,IMESA,8) CALL MOVCA(INOMB,1,TMPX,4,1) CALL MOVCA(INOMB,1,LTMPX,5,1) IADRS=IDGET(TMPX) IF(IFONC.EQ.4) GOTO 2005 IF(IADRS.EQ.0) GOTO 30 ISTUS=DORMT(TMPX) IF(ISTUS.NE.0.AND.IFONC.EQ.2) GOTO 30 IF(ISTUS.EQ.0.AND.IFONC.EQ.3) GOTO 30 CALL BLAN(COMAD,1,60) CALL MOVEW(EROR,COMAD,8) IF(IFONC.EQ.2) CALL MOVEW(BUSY,COMAD(9),19) IF(IFONC.EQ.3) CALL MOVEW(BUSI,COMAD(9),16) I=30 C-----PRINT TMP SCREE, PRINT ERROR MESSAGE AND TERMINATE 220 CALL DCSFK(LUCRT,3) CALL EXEC(2,LUCRT,COMAD,I) GOTO 9999 C C-----STOP TMP COPY IF RUNNING C 2005 IF(TMPX(2) .EQ. 2HP2) IBORT(19)=2HPD CALL EXEC(2,LUCRT,IBORT,32) 2008 CALL REIO(1,500B+LUCRT,I,-1) CALL EXEC(2,LUCRT,CRLF,3) K=IGET1(I,1) IF(K .EQ. 1HY) GOTO 2020 IF(K .EQ. 1HN .OR. K .EQ. 1H ) GOTO 2050 CALL MOVEW(EROR,COMAD,8) CALL MOVEW(BADCH,COMAD(9),11) CALL EXEC(2,LUCRT,COMAD,19) GO?TO 2008 2020 CALL ETMSP(TMPX,98) 2050 CALL EXEC(3,2200B+LUCRT,0) C-----PRINT TMP SCREEN AND EXIT 2100 CALL DCSFK(LUCRT,3) GOTO 9999 C C-----SET PARAMETERS AND SCHEDULE CALLED PROGRAM C 30 IF(IADRS.NE.0) GOTO 35 CALL MOVEW(EROR,COMAD,8) CALL MOVEW(NOVA,COMAD(9),17) I=25 GOTO 220 C C-----BUILD "ON,... " COMMAND, SET CRT LU, ... C 35 CALL BLAN(COMAD,1,40) CALL MOVEW(ON,COMAD,2) COMAD(6)=2H, COMAD(7)=IASC(LUCRT) C C-----PREPARE TO SCHEDULE TMP C IF(IFONC.NE.2) GOTO 40 CALL MOVEW(TMPX,COMAD(3),2) GOTO 100 40 CALL MOVEW(LTMPX,COMAD(3),3) COMAD(8)=2H, C C-----PREPARE TO SCHEDULE LTMP,,TSE C CALL MOVEW(TSE,COMAD(9),3) GOTO 100 C C-----EXECUTION OF THE SCHEDULE C 100 LENGH=ISUPB(COMAD,20) I=MESSS(COMAD,2*LENGH) IF(I.EQ.0) GOTO 150 CALL DCSFK(LUCRT,0) CALL EXEC(2,LUCRT,COMAD,-LENGH) C C-----WAIT UNTIL THE CRT LU IS LOCK AND THEN COMPLETE C DO NOT WAIT MORE THAN 1 MINUTE IN ANY CASE. C 150 K=0 160 CALL EXEC(12,0,2,0,-1) K=K+1 IF(LURQW(LUCRT) .NE. 0) GOTO 9999 IF(K .LT. 60) GOTO 160 C C-----END OF PROGRAM C 9999 END END$   92903-18202 1913 S C0122 &DCSFK              H0101 sASMB HED . D C M O N S C R E E N D A T A NAM DCSFK,7 92903-16200 REV.1913 790210 * * * NAME: DCSFK SCREEN DATA * SOURCE: &DCSFK 92903-18202 * BINARY: %DCSFK ----NONE--- PART OF %DCMON 92903-16200 * * PGMR: FRANCOIS GAULLIER SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 2 ENT DCSFK EXT .ENTR,EXEC SPC 1 A EQU 0 B EQU 1 SUP SPC 3 .LU NOP .FLAG NOP DCSFK NOP JSB .ENTR DEF .LU SPC 1 LDA .FLAG,I RECALL FUNCTION SZA,RSS PRINT SCREEN 0 ? JMP SCRN0 YES, PRINT SFK MAP CPA D2 END OF THE SCREEN ? JMP SCRN2 YES, PRINT END OF THE SCREEN CPA D3 TMP SCREEN ? JMP SCRN3 YES, PRINT TMP SCREEN JMP DCSFK,I NO, FORGET THE REQUEST SPC 2 SCRN0 LDA .DSC0 LDB LNG00 JMP SCRNX * .DSC0 DEF DSCR0 SPC 1 SCRN2 LDA .DSC2 LDB LNG02 JMP SCRNX * .DSC2 DEF DSCR2 SPC 1 SCRN3 LDA .DSC3 LDB LNG03 JMP SCRNX * .DSC3 DEF DSCR3 SPC 2 SCRNX STA SCRNY STB TEMP * JSB EXEC OUPUT THE SCREEN DEF *+5 DEF D2 DEF .LU,I SCRNY NOP DEF TEMP * JMP DCSFK,I * D1 DEC 1 D2 DEC 2 D3 DEC 3 TEMP NOP HED . D C M O N S C R E E N D A T A (GENERATOR) DSCR0 EQU * BYT 33,143 LOCK KEYBOARD BYT 33,130,33,155 FMT MODE OFF, UNLCK MEMORY BYT 33,46,153,60,102,0 BLOCK MODE OFF * * SET HARDWARE SWITCH n* BYT 33,46 ASC 10,s0a0b0c1d0e0f1g1h0j0 BYT 113,0 * * SET SOFT KEY * BYT 33,46 * SFK 1 - RU,TGP,,0,0,0,0 ASC 12,f1k2a015LRU,TGP,,0,0,0,0 BYT 33,46 * SFK 2 - RU,DCMON,,0,0 ASC 11,f2k2a013LRU,DCMON,,0,0 BYT 33,46 * SFK 3 - RU,TMPGN,0,0,0,0,0 FOR TMP ASC 14,f3k2a019LRU,TMPGN,0,0,0,0,0 BYT 33,46 * SFK 4 - RU,DCMON,,0,0 ASC 11,f4k2a013LRU,DCMON,,0,0 BYT 33,46 * SFK 5 - RU,DCMON,,0,0 ASC 11,f5k2a013LRU,DCMON,,0,0 BYT 33,46 * SFK 6 - RU,DCMON,,0,0 ASC 11,f6k2a013LRU,DCMON,,0,0 BYT 33,46 * SFK 7 - RU,TMPGN,0,0,0,0,1 FOR TMPD ASC 14,f7k2a019LRU,TMPGN,0,0,0,0,1 BYT 33,46 * SFK 8 - RU,DCMON,,1,0 ASC 11,f8k2a013LRU,DCMON,,1,0 * BYT 33,110,33,112 HOME UP, CLEAR DISPLAY * * LINE # : 1 * BYT 33,46,144,106 ASC 7, DATACAP/1000 BYT 33,46,144,100 BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 31 ASC 10,SOFT KEY ASSIGNMENTS BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 61 BYT 33,46,144,106 ASC 10, HP 92903A REV.1913 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 19 ASC 12,DATACAP IS READY ! - BYT 40,0 BYT 33,46,144,104 ASC 9,GENERATOR SELECTIO BYT 116,0 BYT 15,12 * * LINE # : 4 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 5 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 17,40 ASC 4, START BYT 40,16 ASC 1,.. BYT 40,17 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 40 BYT 16,56 ASC \ 1,. BYT 17,40 ASC 4, START BYT 16,40 ASC 7,.. . BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 2,. BYT 40,17 ASC 3,TGP BYT 40,16 ASC 1,.. BYT 40,17 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 40 BYT 16,56 ASC 2,. BYT 17,124 ASC 3,MPGN BYT 40,16 ASC 7,.. . BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,1 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,2 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f3 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f4 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5,Transactio BYT 156,16 ASC 1,.. BYT 17,40 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 40 BYT 16,56 BYT 56,17 ASC 5,Trans. Mon BYT 56,16 ASC 1,.. BYT 17,40 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 66 BYT 16,56 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5, Generator BYT 40,16 ASC 1,.. BYT 17,40 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 40 BYT 16,56 BYT 56,17 ASC 5, Generator BYT 40,16 ASC 1,.. BYT 17,40 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 66 BY1T 16,56 BYT 15,12 * * LINE # : 10 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 11 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 17,40 ASC 3, BYT 40,16 ASC 2, .. BYT 40,17 BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 39 BYT 16,40 ASC 2,.. BYT 17,40 ASC 3,START BYT 40,16 ASC 2, .. BYT 17,40 ASC 4,CONTROL BYT 16,40 BYT 56,0 BYT 15,12 * * LINE # : 13 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 4, BYT 40,16 ASC 2, .. BYT 17,40 BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 39 BYT 16,40 ASC 1,.. BYT 40,17 ASC 3, TMPG BYT 116,0 BYT 33,46,144,104 BYT 104,0 BYT 33,46,144,100 ASC 1, BYT 16,56 ASC 1,. BYT 17,40 ASC 4, TMP BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,5 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,6 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f7 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f8 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 15 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 27 ASC 1,.. BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 40 ASC 1,.. BYT 17,40 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 53 BYT 16,56 BYT 56,17 ASC 5,Transactio BYT 156,16 BYT 56,0 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 27 ASC 1,.. BYT 40,17 ASC 3, BYT 40,16 ASC 3, .. BYT 17,40 BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 53 BYT 16,56 ASC 1,. BYT 17,40 ASC 4,Monitor BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 17 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G DSCR2 BYT 15,12 * * LINE # : 18 * BYT 15,12 * * LINE # : 19 * BYT 33,51,102,16 ASC 22,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, * BYT 33,154 MEMORY LOCK BYT 33,142 UNLOCK KEYBOARD SPC 1 LNG00 ABS *-DSCR0 LNG02 ABS *-1-DSCR2 HED . D C M O N S C R E E N D A T A (TMP) DSCR3 EQU * BYT 33,143 LOCK KEYBOARD BYT 33,130,33,155 FMT MODE OFF, UNLCK MEMORY BYT 33,46,153,60,102,0 BLOCK MODE OFF * * SET HARDWARE SWITCH * BYT 33,46 ASC 10,s0a0b0c1d0e0f1g1h0j0 BYT 113,0 * * SET SOFT KEY * BYT 33,46 * SFK 1 - RU,DCMON,,2,0 ASC 11,f1k2a013LRU,DCMON,,2,0 BYT 33z,46 * SFK 2 - RU,DCMON,,3,0 ASC 11,f2k2a013LRU,DCMON,,3,0 BYT 33,46 * SFK 3 - RU,DCMON,,4,0 ASC 11,f3k2a013LRU,DCMON,,4,0 BYT 33,46 * SFK 4 - RU,DCMON,,0,0 ASC 11,f4k2a013LRU,DCMON,,0,0 BYT 33,46 * SFK 5 - RU,DCMON,,2,1 ASC 11,f5k2a013LRU,DCMON,,2,1 BYT 33,46 * SFK 6 - RU,DCMON,,3,1 ASC 11,f6k2a013LRU,DCMON,,3,1 BYT 33,46 * SFK 7 - RU,DCMON,,4,1 ASC 11,f7k2a013LRU,DCMON,,4,1 BYT 33,46 * SFK 8 - RU,DCMON,,0,0 ASC 11,f8k2a013LRU,DCMON,,0,0 * BYT 33,110,33,112 HOME UP, CLEAR DISPLAY * * * LINE # : 1 * BYT 33,46,144,106 ASC 7, DATACAP/1000 BYT 33,46,144,100 BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 31 ASC 10,SOFT KEY ASSIGNMENTS BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 61 BYT 33,46,144,106 ASC 10, HP 92903A REV.1913 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 19 ASC 12,DATACAP IS READY ! - BYT 40,0 BYT 33,46,144,104 ASC 8,ON LINE OPERATIO BYT 116,0 BYT 15,12 * * LINE # : 4 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 5 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 17,40 ASC 4, START BYT 40,16 ASC 1,.. BYT 40,17 ASC 5, START BYT 16,56 ASC 1,. BYT 17,40 ASC 4, STOP BYT 16,40 ASC 7,.. . BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 2,. BYT 40,17 ASC 3,TMP BYT 40,16  ASC 1,.. BYT 40,17 ASC 5, TSE BYT 16,56 ASC 2,. BYT 17,40 ASC 3,TMP BYT 40,16 ASC 7,.. . BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,1 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,2 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f3 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f4 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5,Transactio BYT 156,16 ASC 1,.. BYT 17,124 ASC 5,rans.Spec. BYT 16,56 BYT 56,17 BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 53 BYT 16,56 BYT 56,17 BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 66 BYT 16,56 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5, Monitor BYT 40,16 ASC 1,.. BYT 17,40 ASC 5, Editor BYT 16,56 BYT 56,17 BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 53 BYT 16,56 BYT 56,17 BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 66 BYT 16,56 BYT 15,12 * * LINE # : 10 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 11 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,T>vR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 17,40 ASC 3, START BYT 40,16 ASC 2, .. BYT 40,17 ASC 4, START BYT 40,16 ASC 2, .. BYT 40,17 ASC 4, STOP BYT 16,40 ASC 1,.. BYT 40,17 ASC 4, TGP BYT 40,16 ASC 1, . BYT 15,12 * * LINE # : 13 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 3, TM BYT 120,0 BYT 33,46,144,104 BYT 104,0 BYT 33,46,144,100 BYT 40,16 ASC 2, .. BYT 17,40 ASC 3, TSE BYT 33,46,144,104 BYT 104,0 BYT 33,46,144,100 ASC 1, BYT 16,40 ASC 1,.. BYT 40,17 ASC 2, TM BYT 120,0 BYT 33,46,144,104 BYT 104,0 BYT 33,46,144,100 ASC 2, BYT 16,56 ASC 1,. BYT 17,40 ASC 4, TMPGN BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,5 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,6 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f7 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f8 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 15 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 27 ASC 1,.. BYT 33,46,141,53,6K6401,61,103,0 POSITION CURSOR - 40 ASC 1,.. BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 53 ASC 1,.. BYT 17,124 ASC 5,ransaction BYT 16,56 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 27 ASC 1,.. BYT 40,17 ASC 3, BYT 40,16 ASC 3, .. BYT 17,40 ASC 3, BYT 16,40 ASC 2, .. BYT 17,104 ASC 5,evelopment BYT 16,56 BYT 15,12 * * LINE # : 17 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 18 * BYT 15,12 * * LINE # : 19 * BYT 33,51,102,16 ASC 22,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, * BYT 33,154 MEMORY LOCK BYT 33,142 UNLOCK KEYBOARD SPC 1 LNG03 ABS *-DSCR3 END 6   92903-18203 1913 S C0122 *TYPE0 TR FILE CREATES TYPE 0 FILES             H0101 tf:** :** *TYPE0 (HP 92903-18203 REV.1913 790130) :** :** CREATES TYPE 0 FILES ON LU=2 :** :** IF THE USER WANTS TO CREATE THOSE FILES FOR DIFERENTS LU'S :** EDIT THE TRANSFER FILE TO CHANGE THE CREATE COMMAND. :** :PU,MT::-2 :PU,LP::-2 :PU,LCTU::-2 :PU,RCTU::-2 :CA,6:P,0 :CR,RCTU,5,BO,BO,EO,BI :CR,LCTU,4,BO,BO,EO,BI :CR,MT,8,BO,BO,EO,BI :CR,LP,6,WR,FS,PA,AS :IF,6P,NE,0,1 :: :AN, :DP, UNABLE TO CREATE TYPE 0 FILE ON LU=2 ::   92903-18204 1913 S C0122 *DATCA TR FILE TO INSTALL DATACAP            H0101 :SV,4,9,IH :** :** *DATCA (HP 92903-18204 REV.1913 790131) :** :** LOADS ALL DATACAP PROGRAMS, AND SAVES THEM ON LU=2 IF REQUIRED. :** :** IF THE USER WANTS TO SAVE PROGRAM ON LU=3, EDIT THE :** TRANSFER FILE TO CHANGE THE NEXT LINE TO: :CA,8,3 :CA,8,2 :CA,7,8G,*,-1 :LL,0G :IF,1G,EQ,,1 :IF,1G,NE,0,14 :AN, :AN,. :AN,. PLEASE ENTER THE FOLLOWING COMMAND: :AN,. :AN,. TR,*DATCA::CR,CR#,LIST LU,LOAD FLAG :AN,. :AN,. WHERE CR IS THE CARTRIDGE WHERE '*DATCA' RESIDES. :AN,. CR# IS THE CARTRIDGE WHERE DATACAP'S MODULES RESIDE. :AN,. LOAD FLAG IS 0 TO LOAD PROGRAMS TEMPORARILY AND :AN,. NOT 0 TO SAVE PROGRAMS AS TYPE 6 FILES. :AN,. :AN, :SV,9G,,IH :: :AN, :AN, **************************************************************** :AN, * * :AN, * C R E A T I O N O F T Y P E 0 F I L E S * :AN, * * :AN, **************************************************************** :AN, :CA,6:P,0 ::*TYPE0::1G :IF,6P,NE,0,-24 :CA,6,2G :IF,6G,EQ,,1 :IF,6G,NE,0,1 :CA,6,0G :IF,3G,NE,,1 :CA,3,0 :AN, :IF,3G,NE,0,2 :DP, FROM CR=,1G, LIST LU=,6G, PROGRAM LOADED TEMPORARILY ! :IF,,EQ,,1 :DP, FROM CR=,1G, LIST LU=,6G, PROGRAMS SAVED ONTO TYPE 6 FILES. :AN, :AN, :AN, :AN, :AN, **************************************************************** :AN, * * :AN, * L O A D I N G O F D C M O N * :AN, * * :AN, **************************************************************** :AN, :OF,DCMON :RU,LOADR,,%DCMON::1G,6G :IF,10G,EQ,DCMON,8 :AN, :AN, LOADER HAS FAILED: :AN, 'DCMON' IS NOT READY ! :AN, :AN, DATACAP IS NOT READY, MUST RE-RUN THE TRANFER FILE *DATCA :AN, :SV,9G,,IH :: :AN, :AN, LOADER COMێPLETED, 'DCMON' IS SAVED AS TYPE 6 FILE. :AN, :PU,DCMON::7G :CA,6:P,0 :SP,DCMON::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO SAVE PROGRAM 'DCMON', NO ROOM ON LU=,8G :IF,,EQ,,-16 :OF,DCMON :RP,DCMON :AN, :AN, **************************************************************** :AN, * * :AN, * L O A D I N G O F T M P G N * :AN, * * :AN, **************************************************************** :AN, :OF,TMPGN :OF,TMPG0 :OF,TMPG1 :OF,TMPG2 :OF,TMPG3 :OF,TMPG4 :OF,TMPG5 :RU,LOADR,>TMPGN::1G,,6G,SS,,,15 :IF,10G,EQ,TMPGN,8 :AN, :AN, LOADER HAS FAILED: :AN, 'TMPGN' IS NOT READY ! :AN, :AN, DATACAP IS NOT READY, MUST RE-RUN THE TRANSFER FILE *DATCA :AN, :SV,9G,,IH :: :IF,3G,EQ,0,39 :AN, :AN, LOADER COMPLETED, 'TMPGN' IS SAVED AS TYPE 6 FILES. :AN, :PU,TMPGN::7G :PU,TMPG0::7G :PU,TMPG1::7G :PU,TMPG2::7G :PU,TMPG3::7G :PU,TMPG4::7G :PU,TMPG5::7G :CA,6:P,0 :SP,TMPGN::7G :SP,TMPG0::7G :SP,TMPG1::7G :SP,TMPG2::7G :SP,TMPG3::7G :SP,TMPG4::7G :SP,TMPG5::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO SAVE PROGAM 'TMPGN', NO ROOM ON LU=,8G :IF,,EQ,,-29 :OF,TMPGN :OF,TMPG0 :OF,TMPG1 :OF,TMPG2 :OF,TMPG3 :OF,TMPG4 :OF,TMPG5 :PU,/TMPGN::7G :PU,\TMPGN::7G :CA,6:P,0 :ST,/TMPGN::1G,/TMPGN::7G :ST,\TMPGN::1G,\TMPGN::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO RESTORE FILES: /TMPGN & \TMPGN, NO ROOM ON LU=,8G :IF,,EQ,,-45 ::/TMPGN::7G :AN, :AN, **************************************************************** :AN, * * :AN, * L O A D I N G O F T G P * :AN, * * :AN, **************************************************************** :AN, :OF,TGP :OF,TGP0 :OF,TGP1 :OF,TGP2 :OF,TGP3 :OF,TGP4 :OF,TGP5 :OF,TG P6 :OF,TGP7 :OF,TGP8 :OF,TGP9 :OF,TGPI0 :OF,TGPI1 :OF,TGPI2 :OF,TGPI3 :OF,TGPI4 :RU,LOADR,>TGP::1G,,6G,SS,,,20 :IF,10G,EQ,TGP,8 :AN, :AN, LOADER HAS FAILED: :AN, 'TGP' IS NOT READY ! :AN, :AN, DATACAP IS NOT READY, MUST RE-RUN THE TRANSFER FILE *DATCA :AN, :SV,9G,,IH :: :IF,3G,EQ,0,65 :AN, :AN, LOADER COMPLETED 'TGP' IS SAVED AS TYPE 6 FILES. :AN, :PU,TGP::7G :PU,TGP0::7G :PU,TGP1::7G :PU,TGP2::7G :PU,TGP3::7G :PU,TGP4::7G :PU,TGP5::7G :PU,TGP6::7G :PU,TGP7::7G :PU,TGP8::7G :PU,TGP9::7G :PU,TGPI0::7G :PU,TGPI1::7G :PU,TGPI2::7G :PU,TGPI3::7G :PU,TGPI4::7G :CA,6:P,0 :SP,TGP::7G :SP,TGP0::7G :SP,TGP1::7G :SP,TGP2::7G :SP,TGP3::7G :SP,TGP4::7G :SP,TGP5::7G :SP,TGP6::7G :SP,TGP7::7G :SP,TGP8::7G :SP,TGP9::7G :SP,TGPI0::7G :SP,TGPI1::7G :SP,TGPI2::7G :SP,TGPI3::7G :SP,TGPI4::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO SAVE PROGRAM 'TGP', NO ROOM ON LU=,8G :IF,,EQ,,-49 :OF,TGP :OF,TGP0 :OF,TGP1 :OF,TGP2 :OF,TGP3 :OF,TGP4 :OF,TGP5 :OF,TGP6 :OF,TGP7 :OF,TGP8 :OF,TGP9 :OF,TGPI0 :OF,TGPI1 :OF,TGPI2 :OF,TGPI3 :OF,TGPI4 :PU,/TGP::7G :PU,\TGP::7G :CA,6:P,0 :ST,/TGP::1G,/TGP::7G :ST,\TGP::1G,\TGP::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO RESTORE FILES: /TGP & \TGP, NO ROOM ON LU=,8G :IF,,EQ,,-69 ::/TGP::7G :AN, :AN, DATACAP  IS  READY !! :AN,  :RU,DCMON,0G,0,0,0,0 :SV,9G,,IH   92903-18205 1913 S C0122 &DISEX USER DISPLAY SUBR             H0101 FTN4 SUBROUTINE DISEX, 92903-16205 REV.1913 790203 C C SOURCE 92903-18205 C C C ********************************************************* C * THIS IS AN EXAMPLE OF A USER DISPLAY SUBROUTINE * C * USING THE SYSTEM TIME AVAILABLE IN IBUF TO DISPLAY * C * A FRIENDLY GREETING TO THE PERSON ABOUT TO ENTER DATA * C * AN ALPHANUMERIC DISPLAY OR PRINTER OPTION IS REQUIRED * C ********************************************************* C C LOGICAL BKSFL C COMMON KEEP(5),LUQ,LMQ,IBUF(500) . ,ITSNU,INDEX,IQNUM,ITMTP,ITMLN,IBUPT,BKSFL,INBKS,IQBKS . ,IER,NSTAT,ITEMP(10),ICOMEN C C ( USER DECLARATIONS BEGIN HERE ) C DIMENSION MESSM(7),MESSA(7),MESSE(7) C CALL TMDFN(KEEP,KEEP,KEEP,ITSNU,ITSNU,ICOMEN) C C ( BEGIN USER CODE HERE ) C C DATA MESSM/2HGO,2HOD,2H M,2HOR,2HNI,2HNG,2H / DATA MESSA/2HGO,2HOD,2H A,2HFT,2HER,2HNO,2HON/ DATA MESSE/2HGO,2HOD,2H E,2HVE,2HNI,2HNG,2H / C C TEST FOR APPROPRIATE ITMTP AND ITMTP VALUES C IF (ITMTP .NE. 0) GO TO 90 IF (ITMLN .NE. 14) GO TO 90 C IF (IBUF(4) .GT. 2H11) GO TO 10 C--------PREV. LINE TESTS FOR TIME GREATER THAN 11:59 CALL MOVEW (MESSM,IBUF(IBUPT),7) GO TO 90 C 10 IF (IBUF(4) .GT. 2H16) GO TO 20 C--------PREV. LINE TESTS FOR TIME GREATER THAN 16:59 (4:59 PM) CALL MOVEW (MESSA,IBUF(IBUPT),7) GO TO 90 C 20 CALL MOVEW (MESSE,IBUF(IBUPT),7) C 90 RETURN END Wo  92903-18206 1913 S C0122 &VALX2 USER VALIDATE SUBR             H0101 FTN4 SUBROUTINE VALX2, 92903-16206 REV.1913 790130 C C SOURCE 92903-18206 C C C ****************************************************** C * THIS IS AN EXAMPLE OF A USER VALIDATION MODULE * C * THAT CHECKS TO INSURE THAT THE COMPLETED QUANTITY * C * IS LESS THAN THE RUN QUANTITY PUNCHED ON THE CARD * C ****************************************************** C C LOGICAL BKSFL C COMMON KEEP1(5),LUQ,LMQ,IBUF(500) . ,ITSNU,INDEX,IQNUM,ITMTP,ITMLN,IBUPT,BKSFL,INBKS,IQBKS . ,IER,NSTAT,ITEMP(10),ICOMEN C C (NO USER DECLARATIONS) C CALL TMDFN(KEEP1,KEEP1,KEEP1,ITSNU,ITSNU,ICOMEN) C C ( BEGIN USER CODE HERE ) C C-----ANSWER GREATER THAN RUN QUANTITY? C IF (IBUF(IBUPT) .GT. IBUF(IBUPT-1)) GO TO 9000 C C-----RETURN OK (NO ERROR) C IER=0 RETURN C C-----RETURN AN ERROR TO TMP C 9000 IER=1 NSTAT=0 RETURN END   92903-18207 1913 S C0122 SWIPDB SCHEMA FOR WIP DATA BASE             H0101 "T$CONTROL LIST,ERRORS=5,ROOT,SET,TABLE ; BEGIN DATA BASE WIPDB;CR100;100; <> LEVELS: ITEMS: MEMPLI,U6; <> MHLOCI,U6; <> MLOCNI,U6; <> MOPERI,U4; <> DEMPLI,U6; <> DLOCNI,U6; <> DWO1,U10; <> DPARTI,U12; <> DOPER1,U4; <> DOURSI,R2; <> DRGOVI,U2; <> MWOI,U10; <> MPARTI,U12; <> MQTYI,I1; <> DTIMEI,U4; <