C LD4FRQ.FTN,SEGSRC,CEH-LSS-KJC, 10/19/82 C Frequently called subroutines for SEG C Copyright (c) 1981, Prime Computer, Inc., Natick, MA 01760 C C CONTAINS LOCPAG,SEGPRW,ASSSEG,GETBLK C C LOCPAG - ROUTINE TO GET A 2048 WORD PAGE FOR THE LOADER C C THE LOADER FOR SEGMENTED P400 LOADING RESIDES IN THE LOWER 32K OF MEMORY. C MEMORY ABOVE THE LOADER IS RESERVED FOR A BUFFER POOL WHICH IS USED AS FOLLOWS. C BEGINNING IMMEDIATELY ABOVE THE LOADER AND EVERY :4000 WORDS C THEREAFTER A NEW BUFFER BEGINS. C SOME VERSIONS OF SEG USE SEGMENT :4001 FOR THE BUFFERS. IN THIS CASE C THE REST OF SEGMENT :4000 IS USED FOR THE MAP. C THESE BUFFERS ARE USED AS NEEDED FOR LOADING PROCEDURE, COMMON AND LINK C FRAME INFORMATION. WHEN ALL THE BUFFERS ARE IN USE AND A NEW ONE IS NEEDED C AN ATTEMPT IS MADE TO FIND THE OLDEST. THIS IS DONE BY TAKING THE OLDEST C ASSIGNED BUFFER, MAKING SURE THAT IT IS THE START OF A SEGMENT CHAIN C (SEE BELOW) AND USING IT. IN AS MUCH AS THE LOADER NORMALLY LOADS 'UP' C AND DOES NOT REFERENCE TOO MANY THINGS THAT ARE 'VERY OLD' THIS C SHOULD BE AN ACCEPTIBLE ALGORYTHM. C C THE BUFFER TABLE (BUFTBL) CONTAINS 4 WORDS FOR EACH BUFFER: C C WORD 1 - BIT 1 - SET THIS BUFFER HAS BEEN MODIFIED C BIT 2 - SET - THIS BUFFER IS ASSIGNED C BITS 5-16 - SEGMENT NUMBER C WORD 2 - BITS 1-11 SLOT NUMBER C BITS 12-16 PAGE NUMBER(SEG'S 4K PAGES) C WORD 3 - BUFFER ADDRESS C WORD 4 - NEXT BUFTBL ENTRY IN THIS SEGMENT CHAIN (SEE BELOW) C C THE LOADER SETS BUFTBL UP AND PASSES IT TO LOCPAG IN COMMON. C C THE LOADER SUPPORTS MULTIPLE SEGMENTS AT THIS TIME. THESE SEGMENTS ARE C REPRESENTED BY AN N WORD TABLE (SEGTBL) WHICH LOCPAG MAINTAINS WHICH C CONTAINS A POINTER TO THE FIRST BUFFER USED FOR THE CORRESPONDING SEGMENT C AS ITS ENTRIES. THUS TO FIND A PARTICULAR MEMORY RANGE THE BUFFER CHAIN C FOR THE SEGMENT IS ACCESSED TO LOCATE THE START OF THE CHAIN AND THEN THE C CHAIN AS DEFINED IN BUFTBL IS FOLLOWED TILL THE DESIRED MEMORY RANGE IS C FOUND OR TILL THE CHAIN ENDS. C MODIFICATIONS: C 10/19/82 Don Koch Fixed symbol table overflow check in GETBLK. C SUBROUTINE LOCPAG(I) C INTEGER SEGOFF,LSTOFF,SEGTMP,PRWPT(2),ISLOT,NXTPAG INTEGER WRCNT,ISUB,CODE,I,J,K,L INTEGER*4 IARG COMMON /WRCNT/WRCNT $INSERT SYSCOM>KEYS.INS.FTN $INSERT LODCOM.INS.FTN DATA LSTOFF/1/,WRCNT/0/,PRWPT/BUFSEG,0/ C C HERE BEGINS THE EXECUTABLE CODE C J=AND(I+1,:1) /*SUBSCRIPT FOR THE 'OTHER GUY' NXTPAG=RS(CURPAG(I+1),11) /*FOR INSERTION IN TABLES C SEE IF A POSITION IN SEGTBL IS ASSIGNED C IF(AND(MAP1(P4SUBS),:1000).NE.0) GO TO 500 /*ASSIGNED IF(AND(MAP1(P4SUBS),:4000).EQ.0) GO TO 200 /*NOT SPLIT C C SPLIT SEGMENT, DIF PROC.PART, GET DATA AND ASS THAT TOO. C IF DATA JUST ASS. DATA - ETC. C IF(AND(MAP1(P4SUBS),:10000).NE.0) GO TO 200 IARG = INTL(-SYMSIZ) * MAP1(P4SUBS+MA$SIZ) /* GET POINTER TO NEXT IF(AND(MAP1(IARG),:1000).NE.0) GO TO 150 /*DATA ALREADY ASSIGNED IF(ISLOT.GT.SEGS) GO TO 9000 /*ERROR MAP1(IARG)=MAP1(IARG)+ISLOT+:1000 ISLOT=ISLOT+1 150 MAP1(P4SUBS)=MAP1(P4SUBS)+RT(MAP1(IARG),10) /*USE SAME SLOT GO TO 400 C C DO REGULAR ASSIGN C 200 IF(ISLOT.GT.SEGS) GO TO 9000 /*TOO MANY SEGMETS MAP1(P4SUBS)=MAP1(P4SUBS)+ISLOT+:1000 /*ASS. SLOT,SAY USED ISLOT=ISLOT+1 C C EXTEND SEGDIR C 400 CALL SGDR$$(K$MSIZ,SEGDIR,(ISLOT)*32+1,IARG,CODE) IF(CODE.NE.0) GO TO 9000 C 500 ISUB=RT(MAP1(P4SUBS),9) /*GET ASSIGNED SLOT SEGOFF=SEGTBL(ISUB+1) IF(SEGOFF.EQ.0) GO TO 2000 /*HAVE A NEW SEGMENT C C LOOK DOWN CHAIN OF BUFFERS FOR SEGMENT C 1000 IF(RT(BUFTBL(SEGOFF+1),5).EQ.NXTPAG) GO TO 6000 /*FOUND IT IF(BUFTBL(SEGOFF+3).EQ.0) GO TO 2000 /*END OF LINE SEGOFF=BUFTBL(SEGOFF+3) GO TO 1000 C C GET A NEW BUFFER FOR THIS CHAIN C 2000 IF(AND(BUFTBL(LSTOFF),:40000).EQ.0) GO TO 3000 /*NOT USED SEGTMP=RS(BUFTBL(LSTOFF+1),5) /*GET SLOT LSTOFF=SEGTBL(SEGTMP+1) /*GET START OF CHAIN FROM SEGTBL IF(CURBUF(J+1).NE.BUFTBL(LSTOFF+2)) GO TO 2100 /*BUFFERS AREN'T THE SAME CURSEG(J+1)=-1 /*KILL OTHER BUFFER C 2100 SEGTBL(SEGTMP+1)=BUFTBL(LSTOFF+3) /*REMOVE FIRST BUFFER C C GET POSTION OF BUFFER FOR I/O ETC. C 3000 CONTINUE C PRWPT(1)=BUFSEG /*SEGMENT OF BUFFER PRWPT(2)=BUFTBL(LSTOFF+2) /*WORD ADDRESS OF BUFFER IF(BUFTBL(LSTOFF).GE.0) GO TO 4000 /*NOT MODIFIED C C WRITE OUT MODIFIED BUFFER C SEGTMP=BUFTBL(LSTOFF+1)+1 /*POINT INTO BUFCTL CALL SEGPRW(K$WRIT,PRWPT,SEGTMP) /*WRITE IT OUT L=SEGTMP-1 K=MOD(L,16)+1 /*BIT L=RS(L,4)+1 /*WORD BUFCTL(L)=OR(BUFCTL(L),BITMSK(K)) /*THIS BUFFER IS ON DISK WRCNT=WRCNT+1 /*COUNT A WRITE C 4000 IF(SEGOFF.NE.0) BUFTBL(SEGOFF+3)=LSTOFF /*CHAIN THIS BUFFER TO SEGMENT SEGOFF=LSTOFF /*NEW OFFSET POINTER BUFTBL(SEGOFF)=SEGPNT+:40000 /*SET UP BUFTBL BUFTBL(SEGOFF+1)=LS(ISUB,5)+NXTPAG SEGTMP=BUFTBL(SEGOFF+1)+1 /*NEW POINTER INTO BUFCTL BUFTBL(SEGOFF+3)=0 /*END OF THIS CHAIN LSTOFF=LSTOFF+4 IF(BUFTBL(LSTOFF).EQ.-1) LSTOFF=1 IF(SEGTBL(ISUB+1).EQ.0) SEGTBL(ISUB+1)=SEGOFF C C HAS THIS MEMORY RANGE EVER BEEN USED C L=SEGTMP-1 K=MOD(L,16)+1 /*BIT L=RS(L,4)+1 /*WORD IF(AND(BUFCTL(L),BITMSK(K)).NE.0) GO TO 5000 /*YES C CALL SET1(PRWPT) /*NO, ZERO IT GO TO 6000 C 5000 CALL SEGPRW(K$READ,PRWPT,SEGTMP) /*READ IT IN C 6000 CURSEG(I+1)=SEGPNT CURBUF(I+1)=BUFTBL(SEGOFF+2) IF(I.NE.0) GO TO 6100 BUFTBL(SEGOFF)=OR(BUFTBL(SEGOFF),:100000) MAP1(P4SUBS)=OR(MAP1(P4SUBS),:100000) IF(AND(MAP1(P4SUBS),:4000).NE.0) + MAP1(IARG) = OR(MAP1(IARG),:100000) C LOADSG=BUFSEG /*SEGMENT OF BUFFER 6100 RETURN C 9000 CALL ERRPR$(K$NRTN,CODE,0,0,'LOCPAG',6) C END C SEGPRW - ROUTINE TO POSITION INTO SEGDIR AND DO I/O, THEN CLOSE C C CALLING SEQUENCE: CALL SEGPRW(IOCMD,IADDR,IOFF) C C WHERE: IOCMD IS THE I/O COMMAND C IADDR IS THE ADDRESS OF THE BUFFER (DOUBLE PRECISION) C IOFF IS THE POSITION IN THE SEGDIR C SUBROUTINE SEGPRW(IOCMD,IADDR,IOFF) C INTEGER*2 IOCMD,IOFF,IARG,CODE INTEGER*4 IADDR C C LODCOM.INS.FTN IS LISTED IN LOCPAG NOLIST $INSERT LODCOM.INS.FTN LIST $INSERT SYSCOM>KEYS.INS.FTN C CALL SGDR$$(K$SPOS,SEGDIR,IOFF+OFFSET,IARG,CODE) IF(CODE.NE.0) GO TO 9000 CALL SRCH$$(K$ISEG+IOCMD+K$GETU,SEGDIR,0,SGUNIT,IARG,CODE) /*OPEN SEGMENT IF(CODE.NE.0) GO TO 9000 CALL PRWF$$(IOCMD,SGUNIT,IADDR,:4000,000000,IARG,CODE) /*WRITE BUFFER IF (CODE.NE.0) GO TO 9000 C CALL SRCH$$(K$CLOS,0,0,SGUNIT,IARG,CODE) /*CLOSE SEGMENT IF(CODE.NE.0) GO TO 9000 RETURN C 9000 CALL ERRPR$(K$NRTN,CODE,0,0,'SEGPRW',6) END C ASSSEG - ROUTINE TO ASSIGN SPACE IN A SEGMENT C C CALLING SEQUENCE: CALL ASSSEG(FLAG,USEGNO,SIZE,SEGNO,WDADDR,ALTRTN) C C WHERE: FLAG IS A FLAG WORD C BIT 1 - SET SPLIT THE SEGMENT, CLEAR UNSPLIT SEGMENT C BIT 2 - SET LONG COMMON C BIT 3 - SET PROCEDURE SEGMENT C BIT 4 - SET ASSIGNED SEGMENT NUMBER, CLEAR DEFAULT SEGMNT C BIT 5 - SET, LOAD ON A PAGE BOUNDARY C BIT 6 - SET, PERMANENT ASSIGNMENT C BIT 7 - ANY KIND OF SEGMENT C BIT 8 - SET, CLEAR RELATIVE SEGMENT ASSIGNMENT C BITS 9-16 - UNUSED C C C USEGNO IS THE USER'S SEGMENT CHOICE C SIZE IS THE NUMBER OF LOCATIONS REQUIRED. IF BIT 2 OF FLAGS C IS SET, WORD 2 OF SIZE CONTAINS NUMBER OF FULL C SEGMENTS NEEDED. C SEGNO IS THE SEGMENT NUMBER ASSIGNED C WDADDR IS THE WORD NUMBER ASSIGNED IN THE SEGMENT C ALTRTN IS TAKEN IS THERE ARE NO FREE SEGMENTS C SUBROUTINE ASSSEG(FLAG,USEGNO,SIZE,SEGNO,WDADDR,ALTRTN) C INTEGER*2 FLAG,SIZE(2),SEGNO,WDADDR,ALTRTN,ISEGNO,SYMLIT(3), + SYMBLK(8),SYMADD,JSEGNO,USEGNO,KSEGNO,K,ERRSEV INTEGER*4 LPT EQUIVALENCE (ISEGNO,SYMBLK(2)),(POINT2(7),LPT) COMMON /ERRSEV/ERRSEV C C LODCOM.INS.FTN IS LISTED IN LOCPAG NOLIST $INSERT LODCOM.INS.FTN LIST $INSERT SYSCOM>KEYS.INS.FTN $INSERT SYSCOM>ERRD.INS.FTN C C DATA SYMLIT/'ASSSEG'/ DATA SYMBLK/0,0,:177777,:177777,0,:777,0,0/ C JSEGNO=-1 /* IN CASE LONG COMMON ISEGNO=:4001 /* THIS WILL BE START IF NO USER CHOICE KSEGNO=USEGNO-1 /* IN CASE RELATIVE ASSIGNMENT IF(AND(FLAG,:10000).NE.0) ISEGNO=USEGNO /* USER WANTS THIS ONE CALL INITNE(POINT2,:21,0) /* INIT A SYMBOL TABLE SEARCH 1000 IF(NEXT(POINT2).EQ.0) GO TO 4000 /* NEED A NEW SEGMENT C C NOT THERE YET, FOUND IT, GET NEW SEGMENT (FOR 'IF' BELOW) C IF(MAP1(LPT+A$SEGM)-ISEGNO) 1000,1100,4000 1100 IF(FLAG.LT.0) GO TO 9200 /*CAN'T SPLIT AN ALREADY ASS. SEG IF(AND(FLAG,:40000).NE.0) GO TO 3000 /*NEED FULL SEGMENT IF(AND(MAP1(LPT),:40000).NE.0) GO TO 3000 /*ITS FULL IF(AND(FLAG,:1000).NE.0) GO TO 2000 /*ANY KIND OF SEGMENT IF(AND(MAP1(LPT),FLAG,:20000).NE.0) GO TO 2000 /*PROCEDURE, TRY THIS C C NOW MUST CHECK FOR DATA. IF FLAGS(:20000) RESET AND MAP(:10000) SET, C OK, NEED DATA, AND HAVE DATA. C IF(AND(FLAG,:20000).NE.0) GO TO 3000 /*TRY ANOTHER IF(AND(MAP1(LPT),:10000).NE.0) GO TO 2000 /*TRY THIS IF(AND(MAP1(LPT),:4000).EQ.0) GO TO 3000 GO TO 1000 /*TRY ANOTHER WITH THIS SEGMENT NUMBER C C TEST FOR RELATIVE ASSIGNMENT C 2000 IF(AND(FLAG,:10000).NE.0) GO TO 2300 /*SPECIFIC IF(USEGNO.EQ.0) GO TO 2200 /*NOT RELATIVE KSEGNO=KSEGNO+1 IF(KSEGNO.NE.MAP1(LPT+A$REL)) GO TO 3000 /*TRY ANOTHER IF(AND(FLAG,:400).EQ.0) GO TO 2300 C C CLEAR RELATIVE ASSIGNMENT AND RETURN C MAP1(LPT+A$REL)=0 RETURN C 2200 IF(MAP1(LPT+A$REL).NE.0) GO TO 3000 C C RANGE MINUS CURRENT TOP MUST BE GREATER THAN SIZE IF THERE IS ROOM C RANGE=MAP1(LPT+A$RANG), TOP=MAP1(LPT+A$TOP) C 2300 IF(MAP1(LPT+A$RANG).EQ.MAP1(LPT+A$TOP)) GO TO 2500 /*TEST FOR EMPTY C C TEST FOR LOAD ON A PAGE BOUNDARY C IF(AND(FLAG,:4000).EQ.0) GO TO 2400 /*NOT IF(SIZE(1).EQ.0) GO TO 2500 /*A DON'T CARE K=AND(MAP1(LPT+A$TOP)+:1777,:176000)-1 /*TENTATIVE TOP IF(IUCAS(MAP1(LPT+A$RANG)-K,SIZE(1)).LT.0) GO TO 3000 /*NO GO FLAG=AND(FLAG,:173777) /*DISCARD PAGE BIT MAP1(LPT+A$TOP)=K /*NEW TOP GO TO 2500 C 2400 IF(IUCAS(MAP1(LPT+A$RANG)-MAP1(LPT+A$TOP),SIZE(1)).LE.0)GOTO 3000 C C OK, USE THIS ONE C 2500 IF(JSEGNO.LT.0) SEGNO=ISEGNO /*RETURN VALUES TO USER IF(AND(FLAG,:2000).NE.0) GO TO 2600 /*THIS IS PERMANENT IF(AND(MAP1(LPT),:2000).NE.0) GO TO 2600 MAP1(LPT)=MAP1(LPT)+:2000 MAP1(LPT+A$OLD)=MAP1(LPT+A$TOP) /*SAVE OLD TOP C BEGIN ON EVEN WORD BOUNDARY 2600 IF(SIZE(1).NE.0) MAP1(LPT+A$TOP)=OR(MAP1(LPT+A$TOP),1) WDADDR=MAP1(LPT+A$TOP)+1 /*PBRK IS TOP + 1 IF(SIZE(1).EQ.0) GO TO 2605 /*DATA INITIALIZATION--NOP MAP1(LPT+A$TOP)=MAP1(LPT+A$TOP)+SIZE(1) /*UPDATE TOP IN SYMBOL TABLE IF(MAP1(LPT+A$TOP).EQ.MAP1(LPT+A$RANG))MAP1(LPT)=MAP1(LPT)+:40000 /*FULL 2605 RETURN C C TRY NEXT SEGMENT C 3000 IF(ISEGNO.EQ.:3777) GO TO 9000 /*CAN'T WRAP THROUGH TO :4000 ISEGNO=ISEGNO+1 GO TO 1000 C C LONG COMMON, GET MORE THAN ONE SEGMENT C 3800 IF(JSEGNO.GE.0) GO TO 3805 SEGNO=ISEGNO /*ASSIGN FIRST SEGMENT GO TO 3810 3805 IF(ISEGNO.NE.JSEGNO+1) GO TO 9200 /*CONTIGUOUS SEGS. MISSISNG 3810 JSEGNO=ISEGNO MAP1(LPT)=:50000 /*FLAG AS A FULL DATA SEGMENT SIZE(2)=SIZE(2)-1 IF(SIZE(2).EQ.0) FLAG=FLAG-:40000 /*DONE WITH FULL SEGMENTS IF(SIZE(1).NE.0 .OR. SIZE(2).NE.0) GO TO 3815 WDADDR = 0 RETURN /* SET TO START OF COMMON BLOCK 3815 IF(ISEGNO.EQ.:3777) GO TO 9000 /*CAN'T WRAP THROUGH ISEGNO=ISEGNO+1 GO TO 1000 /*CYCLE AFTER NEXT C C C MUST CREATE A NEW SEGMENT C 4000 CALL SYMADD(SYMBLK,POINT2) IF(AND(FLAG,:10000).NE.0) GO TO 4100 /*SPECIFICALLY ASSIGNED IF(USEGNO.EQ.0) GO TO 4100 /*NOT RELATIVELY ASSIGNED MAP1(LPT+A$REL)=KSEGNO+1 /*MAKE A RELATIVE ASSIGNEMNT 4100 IF(AND(FLAG,:40000).NE.0) GO TO 4500 /*LONG COMMON? IF(JSEGNO.GE.0) GO TO 4500 /*LAST LONG COMMON SEGMENT IF(AND(FLAG,:20000).EQ.0) GO TO 4500 /*DATA SEGMENT IF(IUCAS(:177000,SIZE(1)).LE.0) GO TO 4500 /*PREVENT DATA WRAP MAP1(LPT)=:20000 /*SET PROC FLAG IF(AND(FLAG,:4000).EQ.0) GO TO 2500 /*MAY NEED TO FIX TOP MAP1(LPT+A$TOP)=:1777 GO TO 2500 C C C CREATE A DATA SEGMENT C 4500 IF(FLAG.LT.0) GO TO 4600 MAP1(LPT+A$TOP)=:177777 /*USUAL TOP IF(AND(FLAG,:40000).NE.0) GO TO 3800 /*LONG COMMON MAP1(LPT)=:10000 /*FLAG AS A DATA SEGMENT GO TO 2500 C C SPLIT SEGMENT C 4600 MAP1(LPT)=:14000 MAP1(LPT+A$TOP)=SIZE(1)-1 C C ADD SYMBOL FOR PROCEDURE HALF C CALL SYMADD(SYMBLK,POINT2) MAP1(LPT)=:24000 /*FLAG AS A DATA SEGMENT, SPLIT MAP1(LPT+A$RANG)=SIZE(1)-1 /*SET TOP FOR SPLIT RETURN C C 9000 CALL ERRPR$(K$IRTN,E$NULL,'NO FREE SEGMENTS TO ASSIGN',26, + SYMLIT,6) CALL SS$ERR ERRSEV =-1 /* WARNING IF INTERACTIVE GO TO ALTRTN C 9200 CALL ERRPR$(K$IRTN,E$NULL,'SEGMENT ALREADY DEFINED',23,SYMLIT,6) ERRSEV =1 GO TO ALTRTN END C GETBLK - ROUTINE TO GET A SYMBOL TABLE SLOT C INTEGER FUNCTION GETBLK(JSLOT) C INTEGER*2 MAPEND,JSLOT C COMMON /MAPEND/MAPEND(65535) C C LODCOM.INS.FTN IS LISTED IN LOCPAG NOLIST $INSERT LODCOM.INS.FTN LIST C SYMLOW=SYMLOW+1 JSLOT = -SYMSIZ * SYMLOW IF(LOC(MAP1(JSLOT)).GT.LOC(MAPEND) + SYMLOW) GO TO 100 GETBLK=0 RETURN 100 JSLOT=SYMLOW GETBLK=1 RETURN END