FTN4 SUBROUTINE TMGCR(IERFL),92903-16401 REV.1913 781115 C C C NAME: TMGCR,HDR,EXTNL,DBL,MONAM,FLHND,MRLOC,NBTUS,STUSP C SOURCE: &TMGCR 92903-18401 C RELOC: %TMGCR 92903-16401 PART OF RTMGLB C C PGMR: 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 * THIS ROUTINE CREATES ALL RELOCATA- * C * TABLE AND TRANSFER FILES ASSOCIAT- * C * TED TO AN APPLICATION. * C * THIS ROUTINE IS COMMON TO TMPGN AND * C * TMSGN PROGRAMS. * C *************************************** C C C STOP USED: 3050 - 3052 C ---------- C C IERFL ERROR FLAG RETURN BY THE COMPILER: C =0 RETURN OK, LOAD ALL PROGRAMS. C =3 FATAL ERROR, WAIT ACKNOWLEDGMENT FROM OPERATOR C AND TERMINATE. C =-1 FATAL ERROR, NO ROOM ON CARTRIDGE, WRITE MESSAGE AND C AND TERMINATE. C C C IERFLG ERROR FLAG C IERTN RETURN ADDR IN CASE OF CR FULL C ITMFL TMSLB EXISTENCE FLAG C C C IRQFLG(1) : MAIN PROGRAM C BIT15 LOADER MUST USE COMMAND FILE C BIT14 SYSTEM COMMON IS USED (MAIN MUST ACCESS IT) C IRQFLG(2) : TMST-TMSL-TMSIM C IRQFLG(3) : USER PARTITION # 1 C IRQFLG(I) : USER PARTITION # (I-2) C C C C-----LABEL COMMON # 1 GENERAL INFORMATION C COMMON /TMGC1/LU C C-----LABEL COMMON # 2 FLAGS C COMMON /TMGC2/ITMFL,IRQFLG(30) C C-----LABEL COMMON # 3 BUFFER AREA C COMMON /TMGC3/IDUM0(7),NCRTH(1) C C-----LABEL COMMON # 4 BUFFER USED IN CREATION PHASE & ERROR FLAG C COMMON /TMGC4/IERFLG,IERNB,IERTN,ITEMP(40) C C DIMENSION IASMB(6),IMESA(23),IEROR(10) C LOGICAL STUSP,DORMT,ISBIT C DATA IMESA/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B .,2H ,15446B,2HdC,2HCR,2HEA,2HTI,2HON,2H P,2HHA,2HSE,15446B .,2Hd@,6412B,5012B,15554B/ DATA IEROR/6412B,6412B,15446B,2HdC,2HER,2HRO,51033B,2H&d .,2H@ ,2H: / C C-----INIT INTERNAL COMPILER ERROR FLAG [IERFLG] C INIT ERROR ADDRESS RETURN INTO IERTN C IERFLG=0 ASSIGN 5200 TO IERTN IERNB=0 CALL EXEC(2,LU,IMESA,23) C C------STOP THE TMS APPLICATION ! C CALL MOVEW(NCRTH(5),ITEMP,2) ITEMP(3)=2H CALL LURQ(100000B,0,0) CALL ETMSP(ITEMP,99) CALL LURQ(1,LU,1) C C CHECK EXISTANCE OF %TMSLB (INIT FLAG ITMFL ) C CALL FLHND(0,2HCK) C IF(IRQFLG.EQ.0) GOTO 1000 C C **************************************************************** C * * C * * C * TMS-MAIN PROGRAM GENERATION * C * * C * GENERATES FILES: %XXXX - >XXXX * C * * C * * C **************************************************************** C IRQFLG=1 CALL FLHND(2H ,2HOP) C C MAIN PROGRAM GENERATION (%XXXX) C LTUSEN=5 LUPTEN=5 NTUS=NBTUS(NCRTH) NUPT=NBUPT(NCRTH) IPARA=16B LTMSAD=IPARA+3 ID0ADR=LTMSAD+7+NCRTH(26)*12 ITMLU=ID0ADR+4 ITMSB=ITMLU+1+NCRTH(4)-NCRTH(2) ITMPR=ITMSB+1+LTUSEN*NTUS LENPRG=ITMPR+1+LUPTEN*NUPT C CALL HDR(2H ,LENPRG) C CALL EXTNL(2H ) C CALL DBL(0,2HIN) CALL DBL(76000B+IPARA,2HMR) CALL DBL(16001B,2HX ) CALL DBL(IPARA,2HR ) CALL DBL(IPARA,2HR ) IF(STUSP(NCRTH(18),L,K)) STOP 3050 L=ITMSB+1+(L-1)*LTUSEN CALL DBL(L,2HR ) IF(STUSP(NCRTH(22),L,K)) GOTO 30 L=ITMSB+1+(L-1)*LTUSEN GO TO 40 30 L=ID0ADR 40 CALL DBL(L,2HR ) C SET UP THE 'DEF LUINP' CALL DBL(IPARA+1,2HR ) C SET UP THE 'DEF .TMLU' CALL DBL(ITMLU,2HR ) C SET UP THE 'DEF .TMTP' CALL DBL(((NCRTH(4)-NCRTH(2))/2)+ITMLU,2HR ) C SET UP THE 'DEF .TMSB' CALL DBL(ITMSB,2HR ) C SET UP THE 'DEF .TMPR' CALL DBL(ITMPR,2HR ) C SET UP: 'DEF TMSL' , 'DEF TMST' AND 'DEF IMAGE' CALL DBL(LTMSAD,2HR ) CALL DBL(LTMSAD+3,2HR ) CALL DBL(LTMSAD+6,2HR ) CALL DBL(0,2H ) C SET UP INITIAL PROCESS LU & LOGGING LU CALL DBL(NCRTH(25),2H ) CALL DBL(NCRTH(13),2H ) C SET UP 'TMSL' AND 'TMST' PROGRAM NAME IASMB(3)=2H CALL MOVCA(NCRTH,9,IASMB,2,4) CALL PUTCA(IASMB,1HL,1) CALL MONAM(IASMB) CALL PUTCA(IASMB,1HT,1) CALL MONAM(IASMB) C SET UP IMAGE THINGS CALL DBL(NCRTH(26),2H ) IF(NCRTH(26) .EQ. 0) GOTO 60 J=27 DO 55 I=1,NCRTH(26) DO 53 K=1,4 CALL MONAM(NCRTH(J)) 53 J=J+3 55 J=J+3 C SET UP CONSTANT 0 60 CALL DBL(0,2H ) C C GENERAL INFORMATION: EMA SIZE - # OF LU - # OF INT. LU - STACK SZ C CALL DBL(NCRTH(9),2H ) CALL DBL((NCRTH(4)-NCRTH(2))/2,2H ) CALL DBL((NCRTH(3)-NCRTH(2))/2,2H ) CALL DBL(NCRTH(21),2H ) C SET UP LOGICAL UNIT/TYPES DO 400 J=NCRTH(2),NCRTH(4)-2,2 CALL DBL(NCRTH(J),2H ) 400 CONTINUE DO 410 J=NCRTH(2),NCRTH(4)-2,2 CALL DBL(NCRTH(J+1),2H ) 410 CONTINUE C C TOTAL NUMBER OF TMSUB C CALL DBL(NTUS,2H ) C C SET UP TUS TABLE (LTUSEN WORDS PER ENTRY) C N=-1 J=NCRTH(4) 700 K=NCRTH(J) N=N+1 DO 710 L=J+3,K-3,3 C-----EXIT THE LOOP WHEN LIBRARY IF( ISBIT(NCRTH(L),15) ) GOTO 720 CALL MONAM(NCRTH(L)) CALL DBL(ITMPR+1+N*LUPTEN,2HR ) CALL DBL(0,2H ) 710 CONTINUE 720 J=K IF( J .NE. NCRTH+1 ) GOTO 700 C C NUMBER OF PROGRAMS C CALL DBL(NUPT,2H ) C C SET UP UPT TABLE ( LUPTEN WORDS PER ENTRY ) C ICHAR=2HA J=NCRTH(4) 750 CALL MOVEW(NCRTH(5),IASMB,2) IASMB(3)=ICHAR CALL ISUPB(IASMB,3) CALL MONAM(IASMB) C-----SET UP SYSTEM COMMON FLAG (WORD AFTER PNAME) L=0 IF( ISBIT(NCRTH(J+2),15) ) L=100000B CALL DBL(L,2H ) IF(L .NE. 0) CALL SETBT(IRQFLG,14,1) C-----SET BACK POINTER TO 1ST TUS IN THAT UPT IF(STUSP(NCRTH(J+3),L,M)) STOP 3052 L=ITMSB+1+(L-1)*LTUSEN CALL DBL(L,2HR ) ICHAR=ICHAR+400B J=NCRTH(J) IF(J .NE. NCRTH+1) GOTO 750 C CALL DBL(0,2HND) C C END RECORD C CALL FLHND(0,2HCS) C IF(ITMFL .GE. 0) CALL SETBT(IRQFLG,15,1) C 1000 IF(IRQFLG(2).EQ.0) GOTO 2000 C C **************************************************************** C * * C * * C * TMS-MAIN MODULES GENERATION * C * * C * GENERATES FILES: %TXXXX - >TXXXX * C * %LXXXX - >LXXXX * C * %IMAG. - >IMAG. * C * AS NEEDED. * C * * C * * C **************************************************************** C C IRQFLG(2)=0 DO 1500 I=1,2+NCRTH(26) C IF(I .GE. 3) GOTO 1100 C K=2HT IF(I .EQ. 2) K=2HL IASMB=K CALL MOVEW(NCRTH(5),IASMB(2),2) CALL ISUPB(IASMB,3) IF(IDGET(IASMB) .NE. 0) GOTO 1500 J=1 GOTO 1200 C 1100 K=I-3 L=27+15*K IF(.NOT. DORMT(NCRTH(L+9)) ) GOTO 1500 J=6 C 1200 CALL FLHND(K,2HOP) C CALL HDR(K,J) C CALL EXTNL(K) C C PROGRAM GENERATION C CALL DBL(0,2HIN) IF(I .LT. 3 ) GOTO 1250 C CALL DBL(0,2HC ) CALL DBL(NCRTH(L+14)-1,2HC ) CALL DBL(076000B,2HMC) CALL DBL(104200B,2H ) CALL DBL(0,2HR ) 1250 CALL DBL(026001B,2HX ) CALL DBL(0,2HND) C C END RECORD C J=0 IF(I .GE. 3) J=2 CALL FLHND(J,2HCS) C CALL SETBT(IRQFLG(2),I,1) C 1500 CONTINUE C-----SET BIT 15 IF LOADER MUST USE COMMAND FILE '>?APLT' IF(IRQFLG(2).NE.0 .AND. ITMFL.GE.0) . CALL SETBT(IRQFLG(2),15,1) C C **************************************************************** C * * C * * C * TMS-USER PARTITION GENERATION * C * * C * GENERATES FILES: %XXXXN - >XXXXN * C * AS NEEDED * C * * C * * C **************************************************************** C 2000 DO 2900 I=1,NUPT IF(IRQFLG(I+2).EQ.0) GOTO 2900 C CALL FLHND((2H @)+I,2HOP) C J=IUPPT(I,N) C CALL HDR((2H @)+I,4+N) C CALL EXTNL((2H @)+I) C C PROGRAM GENERATION (%XXXXN) C CALL DBL(0,2HIN) CALL DBL(0,2H ) CALL DBL(026001B,2HX ) CALL DBL(N,2H ) N=2 K=NCRTH(J) DO 2030 L=J+3,K-3,3 C EXIT THE LOOP WHEN LIBRARY IF( ISBIT(NCRTH(L),15) ) GOTO 2040 CALL DBL(N,2HX ) 2030 N=N+1 C C BIT0 = SWAPPING OPTION (ALWAYS SET NOW !!) C BIT15 = SYSTEM COMMON FLAG C 2040 ISWP=1 IF( ISBIT(NCRTH(J+2),15) ) ISWP=100001B CALL DBL(ISWP,2H ) C C WRITE LAST PROGRAM RECORD C CALL DBL(0,2HND) C C END RECORD C CALL FLHND(0,2HCS) C 2900 CONTINUE C C C CREATION PHASE IS COMPLETED, WRITE MESS. ON CRT IF NEEDED C AND RETURN. C C IERFL=0 IF(IERFLG.EQ.0) RETURN CALL MOVEW(IEROR,ITEMP,10) CALL MOVEW(26HLoading impossible due to ,ITEMP(11),13) CALL MOVEW(18Hprevious error ! ,ITEMP(24),9) CALL EXEC(2,LU,ITEMP,32) IERFL=3 C-----CLEAR LOADING REQUEST FLAG 5100 DO 5112 I=1,28 5112 IRQFLG(I)=0 RETURN C C NO ROOM ON CARTRIDGE !! C 5200 IERFL=-1 GOTO 5100 C C-----END OF COMPILER------------------------- C END SUBROUTINE HDR(IPARM,LEN),92903-16401 REV.1913 790124 C C C ******************************************* C * * C * THIS SUBROUTINE GENERATES THE BINARY * C * NAM RECORD OF ALL PROGRAMS. * C * * C * CALL HDR(P1,P2) * C * * C * P1 - DEFINE THE PROGRAM (MAIN, USER * C * PARTITION, LINK, TIMER OR IMAGE) * C * P2 - TOTAL LENGTH OF THE MODULE * C * * C ******************************************* C C LOGICAL ISBIT C C C-----LABEL COMMON # 3 BUFFER AREA C COMMON /TMGC3/IDUM0(7),NCRTH(1) C C-----LABEL COMMON # 4 BUFFER USED IN CREATION PHASE & ERROR FLAG C COMMON /TMGC4/IERFLG,IERNB,IERTN,IERMS(7),IRLOC(70),ITRSF(20) C C C INITIALISATION C CALL NUL(IRLOC,70) IRLOC(2)=20000B CALL MOVEW(NCRTH(5),IRLOC(4),2) IRLOC(6)=IPARM IRLOC(7)=LEN IRLOC(10)=3 IF(IPARM .EQ. 2H ) GOTO 30 IF(IPARM .GT. 4 ) GOTO 50 C C-----SET UP HEADER FOR TMS IMAGE MODULE C L=27+15*IPARM CALL MOVEW(NCRTH(L+9),IRLOC(4),3) IRLOC(9)=NCRTH(L+14) IRLOC(11)=60 CALL MOVEW(6HIMAG. ,IRLOC(18),3) GOTO 40 C C-----SET UP HEADER FOR TMS LINK & TIMER MODULE C 50 IF(IPARM.NE.2HT .AND. IPARM.NE.2HL ) GOTO 100 IRLOC(4)=IPARM CALL MOVEW(NCRTH(5),IRLOC(5),2) IRLOC(11)=10 CALL MOVEW(6HTIMER ,IRLOC(18),3) IF(IPARM .EQ. 2HT ) GOTO 40 IRLOC(11)=70 CALL MOVEW(6HLINK ,IRLOC(18),3) GOTO 40 C C-----SET UP HEADER FOR USER PARTITION C 100 CALL MOVEW(6HUPT.. ,IRLOC(18),3) K=IAND(IPARM,177B)-100B J=IASC(K) CALL MOVCA(J,1,IRLOC,38,2) J=IUPPT(K,N) IRLOC(11)=65 C-----DETERMINE COMMON SIZE AND CHECK THAT ALL FILES EXIST IMAXI=0 K=NCRTH(J) ISYCOM=32000 IF(.NOT. ISBIT(NCRTH(J+2),15) ) GOTO 22 ISYCOM=IGET(1753B) 22 DO 25 I=J+3,K-3,3 ITRSF(20)=ISYCOM CALL FLHND(I,2HMX) IF(IMAXI.LT.ITRSF(9)) IMAXI=ITRSF(9) 25 CONTINUE IRLOC(9)=IMAXI GOTO 40 C C-----SETUP HEADER FOR MAIN PROGRAM C 30 CALL MOVEW(6HMAIN ,IRLOC(18),3) IRLOC(9)=1 IRLOC(11)=65 C C-----MOVE THE COMMENT AREA C 40 CALL ISUPB(IRLOC(4),3) CALL MOVEW(NCRTH(87),IRLOC(21),10) C C-----WRITE HEADER IN THE RELOCATABLE FILE C CALL FLHND(30,2HWR) RETURN END SUBROUTINE EXTNL(IPARM),92903-16401 REV.1913 781113 C C C C **************************************** C * * C * THIS SUBROUTINE GENERATES THE EXTER- * C * NAL RECORD OF THE MAIN PROGRAM AND * C * PROGRAMS ASSOCIATED TO AN APPLICATION* C * * C * CALL EXTNL(P1) * C * * C * P1 = IDENTIFIES THE MODULE TO BE * C * GENERATED. * C * * C **************************************** C C C C C-----LABEL COMMON # 2 FLAGS C COMMON /TMGC2/ITMFL C C-----LABEL COMMON # 3 BUFFER AREA C COMMON /TMGC3/IDUM0(7),NCRTH(1) C C-----LABEL COMMON # 4 BUFFER USED IN CREATION PHASE & ERROR FLAG C COMMON /TMGC4/IERFLG,IERNB,IERTN,IERMS(7),IRLOC(70),ITRSF(20) C C DIMENSION NAME(3) C CALL MOVEW(NCRTH(5),NAME,2) NAME(3)=IPARM C IF(IPARM .NE. 2H ) GOTO 200 C C GENERATE MAIN PROGRAM EXTERNAL : '$MTMS' C EMA RECORD C CALL MOVEW(6H$MTMS ,IRLOC(4),3) ASSIGN 750 TO IRTRN GOTO 260 C 200 K=IAND(IPARM,077400B)/256 IF(K .EQ. 40B) GOTO 300 C C GENERATE LINK, TIMER OR IMAGE MODULE EXTERNAL C '$LTMS' OR '$TTMS' OR '$ITMS' C CALL MOVEW(6H$ITMS ,IRLOC(4),3) IF(IPARM .LE. 4 ) GOTO 220 IRLOC(4)=IOR(22000B,K) NAME=IPARM CALL MOVEW(NCRTH(5),NAME(2),2) GOTO 250 220 CALL MOVEW(NCRTH(27+9+15*IPARM),NAME,3) 250 ASSIGN 800 TO IRTRN 260 IRLOC(6)=IAND(IRLOC(6),77400B)+1 I=7 CALL MRLOC(NAME,0,0) GOTO 700 C C GENERATE USER PARTITION EXTERNAL : '$TML0' AND C ALL THE TUS. C 300 CALL MOVEW(6H$TML0 ,IRLOC(4),3) IRLOC(6)=IAND(IRLOC(6),077400B)+1 C C TRANSFERT FILE GENERATION C CALL MRLOC(NAME,0,0) C SETUP FOR 'EXT TMSB' GENERATION J=IUPPT(IAND(IPARM,177B)-100B,N) L=2 I=7 C C GENERATE BINARY & TRANSFERT FILE AT THE SAME TIME C ASSIGN 500 TO IRTRN K=NCRTH(J) DO 500 N=J+3,K-3,3 M=IAND(NCRTH(N),100000B) CALL MRLOC(NCRTH(N),M,0) IF(M .NE. 0) GOTO 500 CALL MOVEW(NCRTH(N),IRLOC(I),3) IRLOC(I+2)=IAND(IRLOC(I+2),077400B)+L L=L+1 I=I+3 IF(I.GE.59) GOTO 700 500 CONTINUE ASSIGN 800 TO IRTRN C C OUTPUT EXTERNAL RECORD C 700 IRLOC(2)=100000B+(I-4)/3 CALL FLHND(I-1,2HWR) I=4 GOTO IRTRN C C OUTPUT EMA RECORD (MAIN PROGRAM ONLY) C 750 IRLOC(2)=140000B+NCRTH(9)