FTN7X,L,I PROGRAM ECCE(4, 60),** ECCE Rev 2.2 04/11/83 MSH ** C C ************************************************************************* C *** *** C *** T H E E D I N B U R G H *** C *** *** C *** C O M P A T I B L E C O N T E X T E D I T O R *** C *** *** C *** *** C *+* Conceived by: *** C *** HAMISH DEWAR (EDINBURGH UNIVERSITY COMPUTER SCIENCE DEPT.) *** C *** *** C *** First translation from IMP to FORTE by: *** C *** KEITH FARVIS (EDINBURGH REGIONAL COMPUTING CENTRE, 1976) *** C *** *** C *** Rewritten for Hewlett Packard System 1000 by: *** C *** MIKE HURST (HEWLETT PACKARD LTD. 1979) *** C *** *** C *** Modifications for FORTRAN-77 by: *** C *** MIKE HURST (HELWETT PACKARD LTD. 1983) *** C *** *** C ************************************************************************* C C C C C C C B L O C K C O M M O N A R E A S . C C C Global editor variables, mainly concerned with command parsing. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) C C SYM = Current character from the terminal. C PEND = Next character from the terminal. C SYMTYP = Lookup table of command types. C TYPE = The type of a command. C CODE = The command code. C TEXT = The text associated with the command. C NUM = Repetition count. C CHAIN = Link to the position of brackets in the input command. C PP1 = Temporary pointer into the file buffer. C MON = Monitoring indicator. C CASE = Case indicator. C STOP = Repetition limit for commands (constant). C PRINT1 = Print indicator. C PRINT2 = Print indicator. C LINMAX = Maximum number of characters per line. C C C The command buffer and control pointers. C COMMON /COMMD/ C, CIBASE, TIBASE, CI, TI, CMAX INTEGER C, CIBASE, TIBASE, CI, TI, CMAX DIMENSION C(128) C C C = Command input array (Commands --> <-- Text). C CIBASE = Bottom of command array. C TIBASE = Top of command array. C CI = Current command index. C TI = Current text index. C CMAX = Maximum command index for this command line. C C C The macro text store. C COMMON /MACRO/ STORED, POS1, POS2, POS3 INTEGER STORED, POS1, POS2, POS3 DIMENSION STORED(192) C C STORED = Array for storage of the macro command strings. C POS1 = C POS2 = Three indexes into the STORED array. C POS3 = C C C The file buffer and pointers. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) C COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES C C A = The file buffer. This holds both the main and secondary C files, one before the other. The data is packed one C character per byte (two characters per array element C for the 16-bit System 1000 computer). C This will be a machine dependant feature. C BUFLEN = The character length of the buffer. C BYTES = Number of characters stored per buffer element A(n). C C The buffer pointers are arranged as follows:- C C LINE ONE LINE T WO AND LAST LINE C ! ! ! ! ! ! ! ! C TOP FBEG LBEG PP FP LEND FEND BOT C C TOP = Top of file buffer (constant). C FBEG = Beginning of file (index). C LBEG = Beginning of current line (index). C PP = Previous pointer(index). C FP = File pointer (index). C LEND = End of current line (index). C FEND = End of file (index). C BOT = Bottom of file buffer (constant). C C When matching a string in the file:- C MS = Start of matching string (index). C ML = Last character of matching string (index). C C C Extra pointers for the secondary input facility. C COMMON /SINPR/ SEXTRA, SINPUT, SINTOP, SFP, SECFP, SEND, + MFP, MLEND, MEND, MARKER INTEGER SEXTRA, SINTOP, SFP, SECFP, SEND, + MFP, MLEND, MEND, MARKER LOGICAL SINPUT C C For the secondary input there is no gap between the top and bottom C segments of the file and hence no use of the PP pointer. C C LINE ONE LINE TWO AND LAST LINE C ! ! ! ! ! C SINTOP SFP LEND FEND BOT C C SINTOP = Top of the secondary buffer (constant). C SFP = Secondary file pointer (index). C SECFP = Copy of secondary file pointer. C SEND = Copy of secondary file end pointer. C MFP = Copy of main file pointer. C MLEND = Copy of main line end pointer. C MEND = Copy of main file end pointer. C MARKER = Pointer in main file for transfer of text in the 'A' C command. C SINPUT = True if secondary input operative. C SEXTRA = Size of secondary buffer (constant). C C C The character set used. C COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ C C The characters here are the ASCII set but may need redefining if C other sets are used by any particular machine. ASCII is used C rather than hollerith constants to simplify the arithmetic in C command decoding e.t.c.. C C C Input - output stream numbers. C COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT C C The input-output streams are defined so that:- C TTY = The users terminal. C MIN = The main input file. C SIN = The secondary input file (read only). C IN = Current input stream ( = MIN or SIN or 0). C OUT = The output stream. C C C C C *** IMPLEMENTATION SPECIFIC VARIABLES *** C C C Line buffers for terminal input-output. C COMMON /TTYIO/ ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM INTEGER ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM DIMENSION ILINE(128), OLINE(138), PRSTR(2) C C C NAMR tables and data control blocks for RTE-IV file access. C COMMON /FILIO/ MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME INTEGER MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME DIMENSION MITAB(10), MIDCB(272), + SITAB(10), SIDCB(144), + MOTAB(10), MODCB(272) DIMENSION SONAME(3) C C C *** END OF IMPLEMENTATION SPECIFIC VARIABLES *** C C C C C I N I T I A L I S A T I O N O F C O N S T A N T S . C C C *** Note. HP FTN4 cannot support the initialisation of common area C *** variables here. This is done in the "BLOCK DATA" subprogram at C *** the end of the subroutines. C C 1. Looping limit and maximum line length:- C DATA STOP /-1000/ C DATA LINMAX /256/ C C 2. Input-output stream constants:- C DATA TTY /1/ C DATA MIN /0/ C DATA SIN /0/ C DATA IN /0/ C DATA OUT /0/ C C 3. Commands:- C DATA CIBASE /1/ C DATA TIBASE /128/ C C 4. Command type table:- C C ! " # $ % & ' ( ) * + , - . / C 0 1 2 3 4 5 6 7 8 9 : ; < = > ? C @ A B C D E F G H I J K L M N O C P Q R S T U V W X Y Z [ \ ] ^ _ C C DATA SYMTYP/ C + 64, 3, 3, 3, 2, 3, 3, 75, 73, 64, 3, 76, 2, 3, 3, C + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 3, 3, 3, 64, C + 3,218, 10, 18, 5, 8,116, 10, 2, 6, 10, 10, 58,120,250, 2, C + 74, 50, 10, 22, 85, 53, 6, 2, 32, 32, 32, 3, 74, 3, 3, 3/ C C (octal values) C 100, 3, 3, 3, 2, 3, 3,113,111,100, 3,114, 2, 3, 3, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 3, 3, 3,100, C 3,332, 12, 22, 5, 10,164, 12, 2, 6, 12, 12, 72,170,372, 2, C 112, 62, 12, 26,125, 65, 6, 2, 40, 40, 40, 3,112, 3, 3, 3 C C (meaning of bit positions) C 7 (200) = Secondary input specific commands. C 6 (100) = Secondary input permissable commands. C 5 ( 40) = A special '%' command. C 4 ( 20) = A special '%' command. C 3 ( 10) = C 2 ( 4) = C 1 ( 2) = C 0 ( 1) = C C C *** IMPLEMENTATION SPECIFIC INITIALISATION *** C C 5. ASCII character set:- C DATA KNL /10/, KFF /12/ C + KSPACE/32/, KXCLAM/33/, KDQUOT/34/, KHASH /35/, KDOLLR/36/, C + KPCENT/37/, KAND /38/, KQUOTE/39/, KLPAR /40/, KRPAR /41/, C + KSTAR /42/, KPLUS /43/, KCOMMA/44/, KMINUS/45/, KDOT /46/, C + KSLASH/47/, K0 /48/, K1 /49/, K2 /50/, K3 /51/, C + K4 /52/, K5 /53/, K6 /54/, K7 /55/, K8 /56/, C + K9 /57/, KCOLON/58/, KSEMIC/59/, KLT /60/, KEQ /61/, C + KGT /62/, KQUEST/63/, KAT /64/, KA /65/, KB /66/, C + KC /67/, KD /68/, KE /69/, KF /70/, KG /71/, C + KH /72/, KI /73/, KJ /74/, KK /75/, KL /76/, C + KM /77/, KN /78/, KO /79/, KP /80/, KQ /81/, C + KR /82/, KS /83/, KT /84/, KU /85/, KV /86/, C + KW /87/, KX /88/, KY /89/, KZ /90/, KLBRAC/91/, C + KBACKS/92/, KRBRAC/93/, KUPARR/94/, KSUB /95/, C + KGRAV /96/, KLA /97/, KLZ /122/ C C C 6. File buffer size and packing:- C (BUFLEN = dimension of A times the number of bytes per word). C DATA BYTES /2/ C DATA BUFLEN /10000/ C C C E N D O F C O N S T A N T I N I T I A L I S A T I O N C C C C C C R U N T I M E I N I T I A L I S A T I O N . C C C Fetch input, secondary and output file names. CALL FILES C C Open files and set up input-output streams. CALL OPNFI C C Initialise file buffer pointers. CALL EINIT C C Send an indentification string to the terminal. CALL PSTRG(4HEdit, -4) CALL NEWLN C C C C C C O M M A N D I N P U T P H A S E . C C C Fetch the next command from the terminal. 1000 CONTINUE I = 1 IF (SINPUT) I = 2 CALL PRMPT(2H>>, I) CALL RITEM C C Ignore blank lines IF (TYPE.EQ.1) GOTO 1000 C C Set up command buffer pointers. CI = CIBASE TI = TIBASE CHAIN = 0 IF (TYPE.NE.0 .OR. CMAX.EQ.0) GOTO 1100 C(CMAX+2) = NUM CALL RITEM IF (TYPE.NE.1) GOTO 4402 GOTO 5000 1100 CONTINUE C C Special '%' type commands ? IF (SYM.EQ.KPCENT) GOTO 1300 C C Ordinary commands. The first item has already been read. 1200 CONTINUE I = IAND(TYPE, 15) C C Check for illegal main input / secondary input type. J = IAND(TYPE/64, 3) IF ((SINPUT .AND. J.LT.1) .OR. (.NOT.SINPUT .AND. J.GT.1)) + GOTO 4400 C C Default values. CODE = SYM TEXT = 0 NUM = 1 CALL RITEM C C Go to the appropriate command type. GOTO (02000, 02000, 02000, 02000, 02400, 02500, 02600, 02700, + 02800, 02900, 03000, 03100, 03200, 02000, 02000, 02000), + I+1 C C C Special '%' type commands. 1300 CONTINUE CALL RDSYM IF (SYM.GE.KLA .AND. SYM.LE.KLZ) SYM = SYM-KLA+KA CODE = SYM IF (CODE.LT.KA) GOTO 4405 CALL RITEM C C Go to one of the special command types. GOTO (02000, 02100, 02200, 02300), + IAND(SYMTYP(CODE-KSPACE)/16, 3)+1 C C C C C C O M M A N D T Y P E D E C O D I N G . C C C 0. Illegal type. 02000 CONTINUE GOTO 4405 C C C 1. Special '%' commands: %C, %A, %S, %T C %C = Normal closure of the editor. C %A = Abort closure. (Output left in the scratch file). C %S = Switch between main and secondary inputs. C %T = Rewind to the top of the file. 02100 CONTINUE IF (CODE.NE.KS) GOTO 9000 CALL SWINP GOTO 5800 C C C 2. Macro definitions: %X, %Y, %Z 02200 CONTINUE IF (SYM.NE.KEQ) GOTO 4401 I = ((CODE-KX)*64)+1 C C Read command line into STORED buffer for later use. 2210 CONTINUE CALL RDSYM STORED(I) = SYM IF (SYM.EQ.KNL) GOTO 1000 IF (IAND(I, 63).EQ.0) GOTO 4406 I = I+1 GOTO 2210 C C C 3. Monitoring modes: %F, %M, %Q C Case modes: %L, %N, %U 02300 CONTINUE IF (CODE.EQ.KF .OR. CODE.EQ.KM .OR. CODE.EQ.KQ) MON = KM-CODE IF (CODE.EQ.KL .OR. CODE.EQ.KN .OR. CODE.EQ.KU) CASE = KN-CODE GOTO 1000 C C C 4. Find 02400 CONTINUE IF (TYPE.NE.0) NUM = 0 C C C 5. Delete, Traverse, Uncover, ( + Find ). 02500 CONTINUE C C Put limit of search into code item and reset to default. CODE = NUM*128+CODE NUM = 1 IF (TYPE.EQ.0) CALL RITEM C C C 6. Insert, Substitute, Verify, ( + Find, Delete, Traverse, Uncover ). 02600 CONTINUE C C Check for legitimate quote symbol. IF (TYPE.NE.3) GOTO 4404 TEXT = TI I = SYM C C Get the text string for these commands. 2610 CONTINUE CALL RDSYM IF (SYM.EQ.KNL) PEND = SYM C C End of text ? IF (SYM.EQ.KNL .OR. SYM.EQ.I) GOTO 2620 C C String too long ? IF (TI.LE.CI) GOTO 4406 C C Convert to lower case if lower case mode set. IF (CASE.LT.0 .AND. SYM.GE.KA .AND. SYM.LE.KZ) + SYM = SYM-KA+KLA C C Convert to upper case if upper case mode set. IF (CASE.GT.0 .AND. SYM.GE.KLA .AND. SYM.LE.KLZ) + SYM = SYM-KLA+KA C(TI) = SYM TI = TI-1 GOTO 2610 C C End of text. 2620 IF ((SYM.EQ.KNL .OR. TI.EQ.TEXT) + .AND. CODE.NE.KI .AND. CODE.NE.KS) GOTO 4404 C(TI) = 0 TI = TI-1 GOTO 2810 C C C 7. - undefined -. 02700 CONTINUE GOTO 4405 C C C 8. Move, Erase. 02800 CONTINUE IF (SYM.NE.KMINUS) GOTO 3010 C C Convert 'M-' and 'E-' to 'O' and 'W'. CODE = CODE+10 2810 CALL RITEM GOTO 3020 C C C 9. Close parenthesis. 02900 CONTINUE CALL UCHAN C C Do parentheses match ? IF (TEXT.EQ.0) GOTO 4403 C C Put in the parenthesis. CODE = KY C(TEXT+2) = NUM TEXT = TEXT+3 C C C 10. Get, Kill etc.. 03000 CONTINUE C C Funny character ? 3010 IF (TYPE.EQ.3) GOTO 4401 3020 IF (TYPE.EQ.0) CALL RITEM GOTO 4000 C C C 11. Open parenthesis. 03100 CONTINUE CODE = KX GOTO 3210 C C C 12. Comma. 03200 CONTINUE CODE = KZ C C Ignore following newline. IF (TYPE.EQ.1) CALL RITEM 3210 TEXT = CHAIN CHAIN = CI NUM = 0 C C C 4000 CONTINUE CALL STACK(CODE) CALL STACK(TEXT) CALL STACK(NUM) C C Make sure command string is not too long. IF (CI+4.GE.TI) GOTO 4406 C C Get next command if not at an end of line. IF (TYPE.NE.1) GOTO 1200 CALL UCHAN IF (TEXT.NE.0) GOTO 4403 CMAX = CI C C Add an extra closing bracket. CALL STACK(KY) CALL STACK(CIBASE) CALL STACK(1) CALL STACK(0) GOTO 5000 C C C C C C O M M A N D I N P U T E R R O R R E P O R T S . C C 4400 CALL PSTRG(4H SIN, -4) GOTO 4402 4401 CALL PSYM(KSPACE) CALL PSYM(CODE) 4402 CODE = SYM GOTO 4405 4403 CALL PSTRG(3H (), -3) GOTO 4407 4404 CALL PSTRG(9H TEXT FOR, -9) 4405 CALL PSYM(KSPACE) CALL PSYM(CODE) GOTO 4407 4406 CALL PSTRG(5H SIZE, -5) 4407 CALL PSYM(KQUEST) CALL NEWLN IF (CI.NE.CIBASE) CMAX = 0 C C Ignore type ahead. CALL TSKIP GOTO 1000 C C C C C C O M M A N D E X E C U T I O N P H A S E . C C 5000 CONTINUE CI = CIBASE C 5100 CONTINUE CODE = IAND(C(CI), 127) C C Are we at the end of a command line ? IF (CODE.EQ.0) GOTO 5800 C C Set up next command. TEXT = C(CI+1) NUM = C(CI+2) CI = CI+3 C 5200 CONTINUE NUM = NUM-1 GOTO (06100, 06200, 06300, 06400, 06500, 06600, 06700, 06800, + 06900, 07000, 07100, 07200, 07300, 07400, 07500, 07600, + 07700, 07800, 07900, 08000, 08100, 08200, 08300, 08400, + 08500, 08600, 08700, 08800), CODE-KAT C 5300 CONTINUE IF (NUM.NE.0 .AND. NUM.NE.STOP) GOTO 5200 GOTO 5100 C 5400 CONTINUE IF (NUM.LT.0) GOTO 5100 IF(C(CI).NE.KBACKS) GOTO 5500 CI = CI+3 GOTO 5100 C 5500 CONTINUE I = C(CI) C C Check for an opening parenthesis. IF (I.EQ.KX) CI = C(CI+1) CI = CI+3 C C Check for closing parenthesis or comma. IF (I.NE.KY .AND. I.NE.KZ) GOTO 5510 NUM = C(CI-1)-1 GOTO 5400 5510 CONTINUE IF (I.NE.0) GOTO 5500 C C C C C C O M M A N D E X E C U T I O N E R R O R R E P O R T S. C C CALL PSTRG(10H FAILURE: , -10) IF (CODE.NE.KO .AND. CODE.NE.KW) GOTO 5610 C C Restore 'E-' and 'M-' from 'O' and 'W'. CALL PSYM(CODE-10) CODE = KMINUS 5610 CONTINUE CALL PSYM(CODE) C C Print out text. IF (TEXT.EQ.0) GOTO 5620 CALL PSYM(KQUOTE) 5611 IF (C(TEXT).EQ.0) GOTO 5612 CALL PSYM(C(TEXT)) TEXT = TEXT-1 GOTO 5611 5612 CONTINUE CALL PSYM(KQUOTE) 5620 CONTINUE CALL NEWLN C C Ignore type ahead. CALL TSKIP PRINT1 = 0 C C C C C E N D O F C O M M A N D E X E C U T I O N P H A S E . C C 5800 CONTINUE IF (SYM.NE.KNL .OR. MON.LT.0 .OR. + (PRINT1.EQ.LEND .AND. (MON.EQ.0 .OR. PRINT2.EQ.FP+PP))) + GOTO 1000 NUM = 0 CALL PRINT GOTO 1000 C C C C C I N D I V I D U A L C O M M A N D E X E C U T I O N . C C C Open parenthesis. (Repetition number reset on close parenthesis). 08400 CONTINUE C(TEXT+2) = NUM+1 GOTO 5100 C C Close parenthesis. 08500 CONTINUE IF (NUM.EQ.0 .OR. NUM.EQ.STOP) GOTO 5100 C(CI-1) = NUM C C Comma. 08600 CONTINUE CI = TEXT GOTO 5100 C C Right shift. 07800 CONTINUE IF (FP.EQ.LEND) GOTO 5400 CALL RIGHT GOTO 5300 C C Left shift. 07200 CONTINUE IF (PP.EQ.LBEG) GOTO 5400 CALL LEFT MS = 0 GOTO 5300 C C Erase. 06500 CONTINUE IF (FP.EQ.LEND) GOTO 5400 FP = FP+1 GOTO 5300 C C Erase back. 07500 CONTINUE IF (PP.EQ.LBEG) GOTO 5400 PP = PP-1 GOTO 5300 C C Verify. 08200 CONTINUE I = FP J = TEXT 8210 IF (JGET(I).NE.C(J)) GOTO 8220 I = I+1 J = J-1 GOTO 8210 8220 CONTINUE IF (C(J).NE.0) GOTO 5400 MS = FP ML = I GOTO 5300 C C Find. 06600 CONTINUE IF (MATCH(N).EQ.0) GOTO 5400 GOTO 5300 C C Uncover. 08100 CONTINUE IF (MATCH(N).EQ.0) GOTO 5400 PP = PP1 GOTO 5300 C C Delete. 06400 CONTINUE IF (MATCH(N).EQ.0) GOTO 5400 FP = ML GOTO 5300 C C Traverse. 08000 CONTINUE IF (MATCH(N).EQ.0) GOTO 5400 C C Substitute ( + Traverse ). 07900 CONTINUE IF (FP.NE.MS) GOTO 5400 FP = ML C C Insert ( + Substitute + Traverse ). 06900 CONTINUE CALL GETSP IF (PP-LBEG+LEND-FP.GE.LINMAX) GOTO 5400 I = TEXT 6910 CONTINUE IF (C(I).EQ.0) GOTO 5300 CALL PUTPP(C(I)) I = I-1 GOTO 6910 C C Get. 06700 CONTINUE CALL PRMPT(1H., 1) CALL GETSP CALL RSYM(I) IF (I.EQ.KDOT) GOTO 5400 CALL LSTAR 6710 IF (I.EQ.KNL) GOTO 6720 IF (CASE.LT.0 .AND. I.GE.KA .AND. I.LE.KZ) I = I-KA+KLA IF (CASE.GT.0 .AND. I.GE.KLA .AND. I.LE.KLZ) I = I-KLA+KA CALL PUTPP(I) CALL RSYM(I) GOTO 6710 6720 CONTINUE C C Break ( + Get ). 06200 CONTINUE CALL BREAK GOTO 5300 C C Print. 07600 CONTINUE CALL PRINT IF (NUM.EQ.0) GOTO 5100 C C Move ( + Print ). 07300 CONTINUE CALL RSTAR IF (FP.EQ.FEND) GOTO 5400 CALL BREAK 7310 CALL REFRS GOTO 5300 C C Kill. 07100 CONTINUE PP = LBEG 7110 FP = LEND 7120 IF (FP.EQ.FEND) GOTO 5400 GOTO 7310 C C Join. 07000 CONTINUE CALL RSTAR IF (PP-LBEG.GT.LINMAX) GOTO 5400 GOTO 7120 C C Move back. 08300 CONTINUE CALL GETSP IF (LBEG.EQ.FBEG) GOTO 5400 CALL LSTAR CALL LEFT LEND = FP 8310 CONTINUE PP = PP-1 K = JGET(PP) IF (K.EQ.KNL) GOTO 8320 CALL PUTFP(K) GOTO 8310 8320 CONTINUE PP = PP+1 LBEG = PP MS = 0 GOTO 5300 C C Note. 07400 CONTINUE MARKER = FP GOTO 5300 C C Abstract. 06100 CONTINUE CALL GETSP IF (SINTOP.GT.MARKER .OR. MARKER.GE.SFP) GOTO 5400 IMARK = MARKER 160 DO 161 I = 1,LINMAX CALL PUTPP(IMARK) IMARK = IMARK+1 IF (IMARK.EQ.SFP) GOTO 162 161 CONTINUE CALL GETSP GOTO 160 162 LBEG = PP GOTO 5300 C C Invert failure condition. 08800 CONTINUE GOTO 5400 C C - undefined commands -. 06300 CONTINUE 06800 CONTINUE 07700 CONTINUE 08700 CONTINUE GOTO 4405 C C C C C E D I T O R T E R M I N A T I O N . C C 9000 CONTINUE IF (CODE.EQ.KA .OR. OUT.EQ.0) GOTO 9100 C C Set flag for %C or %T. OUT = 2 C C Move to the bottom of the file. 9010 CONTINUE CALL RSTAR IF (FP.EQ.FEND) GOTO 9020 CALL BREAK CALL REFRS GOTO 9010 9020 CONTINUE C C Write buffer out to file. 9030 IF (FBEG.EQ.PP) GOTO 9040 CALL PLINE GOTO 9030 9040 CONTINUE C C Close files. 9100 CONTINUE CALL CLSFI C C Check for %T. IF (CODE.NE.KT) GOTO 9900 C C Re-open all files, initialise buffer and jump to restart. CALL OPNFI CALL EINIT CALL PRINT GOTO 1000 9900 CONTINUE END SUBROUTINE EINIT C C Initialise file buffer pointers. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /COMMD/ C, CIBASE, TIBASE, CI, TI, CMAX INTEGER C, CIBASE, TIBASE, CI, TI, CMAX DIMENSION C(128) COMMON /MACRO/ STORED, POS1, POS2, POS3 INTEGER STORED, POS1, POS2, POS3 DIMENSION STORED(192) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT PEND = 0 PRINT1 = 0 PRINT2 = 0 CMAX = 0 STORED(1) = KNL STORED(65) = KNL STORED(129) = KNL POS1 = 0 POS2 = 0 POS3 = 0 CALL BINIT MS = 0 ML = 0 IN = MIN CALL RLINE RETURN END SUBROUTINE SWINP C C Switch between main and secondary inputs. C COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT RETURN END INTEGER FUNCTION MATCH(DUMMY) C C A logical function to find a matching string in the file using C the code+limit 'string'. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /COMMD/ C, CIBASE, TIBASE, CI, TI, CMAX INTEGER C, CIBASE, TIBASE, CI, TI, CMAX DIMENSION C(128) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ INTEGER DUMMY INTEGER FP1, T1, LIM, SKIP C C Pick up search limit and first letter. LIM = C(CI-3)/128 T1 = C(TEXT) 1000 CONTINUE C C Note old positions of the pointers. PP1 = PP FP1 = FP C C Search one line. 1100 CONTINUE SKIP = JFIND(FP, T1)-FP CALL JMOVE(PP, FP, SKIP) PP = PP+SKIP FP = FP+SKIP IF (FP.EQ.LEND) GOTO 1200 IF (FP.EQ.MS .AND. CODE.NE.KD .AND. CODE.NE. KT) GOTO 1110 C C We have found a match for the first letter. Now try the rest. I = FP J = TEXT 1101 CONTINUE I = I+1 J = J-1 L = C(J) IF (L.EQ.0) GOTO 3000 IF (L.EQ.JGET(I)) GOTO 1101 1110 CONTINUE C C Match failed. Move one character right and repeat. CALL RIGHT GOTO 1100 1200 CONTINUE C C End of line. LIM = LIM-1 C C Fail if limit reached or end of file. IF (LIM.EQ.0 .OR. FP.EQ.FEND) GOTO 2000 C C Move over end of line (or throw away text if 'U' command). IF (CODE.EQ.KU) GOTO 1300 CALL BREAK GOTO 1400 1300 CONTINUE PP = PP1 1400 CONTINUE CALL REFRS GOTO 1000 C C False exit for not matched. 2000 PP = PP1 FP = FP1 MATCH = 0 RETURN C C True exit for successful match. 3000 MS = FP ML = I MATCH = 1 RETURN END SUBROUTINE REFRS C C Ensure there is sufficient breathing space in the file buffer for C the next line of input, and input it. C COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES C C Move to the end of the current line. FP = FP+1 C C Make sure of space. CALL GETSP C C Get next line. CALL RLINE RETURN END SUBROUTINE GETSP C C Make space in the main buffer (if necessary) by outputting the C top half. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ INTEGER MAINFP, P1 C C Is there enough space in the main buffer. IF (FP-PP.GT.2*LINMAX) RETURN P1 = (FBEG+LBEG)/2 C C Logical pointer error !?!?!? IF (P1.LE.FBEG) GOTO 999 C C Flush out half the top section of the file buffer. 100 CONTINUE CALL PLINE IF (FBEG.LT.P1) GOTO 100 C C Move up the rest of the top section. CALL JMOVE(TOP, FBEG, PP-FBEG) LBEG = TOP+LBEG-FBEG PP = TOP+PP-FBEG FBEG = TOP RETURN C C Logical pointer error ?!?!? 999 CALL PSTRG(29H** Text pointers corrupted !!, -29) CALL NEWLN CALL CLSFI CALL EXEC(6) END SUBROUTINE BREAK C C Insert a newline character into the file buffer. C COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ CALL PUTPP(KNL) LBEG = PP END SUBROUTINE RLINE C C Read the next line from the file into the file buffer. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ INTEGER P1, ILEN C C Are we at the end of the current section of the file in the file C buffer ? IF (FP.EQ.FEND) GOTO 200 C C No ... move to the next line in the file buffer. LEND = JFIND(FP, KNL) RETURN 200 CONTINUE C C Reset buffer pointers. MS = 0 PRINT1 = 0 PRINT2 = 0 FP = BOT-LINMAX C *** Coerce FP to a word boundary. FP = FP/BYTES*BYTES C C Read in the next line from the file to the position defined by FP. C Note that as FORTRAN arrays start at element 1 (and not 0) we have C to add one to the word address of FP in A. CALL INLN(A(1+FP/BYTES), ILEN) C C Check for end of file (or no null input). IF (ILEN.GE.0) GOTO 300 FP = BOT LEND = FP FEND = LEND GOTO 400 300 CONTINUE C C Set line end and file end pointers to the end of the new line and C add a newline character. LEND = FP+ILEN FEND = LEND+1 400 CONTINUE P1 = PP PP = LEND CALL PUTPP(KNL) PP = P1 RETURN END SUBROUTINE PLINE C C Print out the top line in the file buffer. This routine assumes C that a line exists before the PP pointer. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ INTEGER P1, ILEN C C Set ILEN to the length of the first line in the buffer. ILEN = JFIND(FBEG, KNL)-FBEG C C *** Make sure this line is aligned on a word boundary before writing C *** it out. P1 = FBEG/BYTES*BYTES IF (P1.NE.FBEG) CALL JMOVE(P1, FBEG, ILEN) C C Write out the line and advance FBEG to the start of the next line. CALL OUTLN(A(1+P1/BYTES), ILEN) FBEG = FBEG+ILEN+1 RETURN END SUBROUTINE UCHAN C C Use temporary links to locate last unmatched open parenthesis C (if any). Fix up any comma units en route. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /COMMD/ C, CIBASE, TIBASE, CI, TI, CMAX INTEGER C, CIBASE, TIBASE, CI, TI, CMAX DIMENSION C(128) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ 100 CONTINUE TEXT = CHAIN IF (TEXT.EQ.0) RETURN CHAIN = C(TEXT+1) C(TEXT+1) = CI IF (C(TEXT).NE.KX) GOTO 100 RETURN END SUBROUTINE STACK(V) C C Push a command item onto the command array. C COMMON /COMMD/ C, CIBASE, TIBASE, CI, TI, CMAX INTEGER C, CIBASE, TIBASE, CI, TI, CMAX DIMENSION C(128) INTEGER V C(CI) = V CI = CI+1 RETURN END SUBROUTINE RITEM C C Read command item (symbol or number), skipping leading spaces, C standardising case and detecting macro letters. Set up the type C of the item (from SYMTYP) into TYPE. For a numeric item, assemble C a sequence a digits and return the value in NUM. C Note that NUM is not altered for non numeric types. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /MACRO/ STORED, POS1, POS2, POS3 INTEGER STORED, POS1, POS2, POS3 DIMENSION STORED(192) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ 100 CONTINUE C C Default type for end of line. TYPE = 1 C C Skip spaces. 110 CONTINUE CALL RDSYM IF (SYM.EQ.KSPACE) GOTO 110 C C Treate any control character as a newline. IF (SYM.LT.KSPACE) RETURN C C Ensure upper case. IF (SYM.GE.KLA .AND. SYM.LE.KLZ) SYM = SYM-KLA+KA C C Fetch item type. TYPE = SYMTYP(SYM-KSPACE) C C Return unless numeric or a macro letter (X, Y, Z). IF (IAND(TYPE, 15).NE.0) RETURN IF (TYPE.NE.32) GOTO 200 POS1 = POS2 POS2 = POS3 POS3 = ((SYM-KX)*64)+1 GOTO 100 200 CONTINUE IF (TYPE.NE.0) GOTO 300 C C A decimal digit. NUM = SYM-K0 210 CONTINUE CALL RDSYM IF (SYM.LT.K0 .OR. SYM.GT.K9) GOTO 220 NUM = NUM*10+(SYM-K0) GOTO 210 220 CONTINUE PEND = SYM RETURN C C '!', '*', '?' etc.. 300 TYPE = 0 NUM = 0 IF (SYM.EQ.KSTAR) RETURN NUM = STOP+1 IF (SYM.EQ.KQUEST) RETURN NUM = STOP RETURN END SUBROUTINE RDSYM C C Reads the next command symbol from the terminal or macro buffers C into the variable SYM. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /MACRO/ STORED, POS1, POS2, POS3 INTEGER STORED, POS1, POS2, POS3 DIMENSION STORED(192) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ IF (PEND.EQ.0) GOTO 100 SYM = PEND PEND = 0 RETURN 100 CONTINUE 200 IF (POS3.EQ.0) GOTO 300 SYM = STORED(POS3) POS3 = POS3+1 IF (SYM.NE.KNL) RETURN POS3 = POS2 POS2 = POS1 POS1 = 0 GOTO 200 300 CONTINUE CALL RSYM(SYM) RETURN END SUBROUTINE PRINT C C Print out the current line on the terminal. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ INTEGER P1 LOGICAL REVID PRINT1 = LEND PRINT2 = FP+PP CALL PSYM(KSPACE) C C *** Special for HP 26xx series terminals. Use reverse video for the C *** section of the current line prior to the file pointer. REVID = PP.NE.LBEG .AND. NUM.EQ.0 IF (REVID) CALL PSTRG(4H&dJ, -4) P1 = LBEG 100 CONTINUE C C Check for the position of the file pointer. IF (P1.NE.PP) GOTO 110 C C Type the file pointer unless we are at the beginning of the line. C C Generally the file pointer will be a caret (or up-arrow) symbol. C IF (P1.NE.LBEG .AND. NUM.EQ.0) CALL PSYM(KUPARR) C C *** But for HP terminals come out of reverse video mode. IF (REVID) CALL PSTRG(4H&d@, -4) P1 = FP 110 CONTINUE IF (P1.EQ.LEND) GOTO 200 CALL PSYM(JGET(P1)) P1 = P1+1 GOTO 100 C C End of file ? 200 IF (P1.EQ.FEND) CALL PSTRG(7H**END**, -7) CALL PSYM(KSPACE) CALL NEWLN END C C C ************************************************************************* C *** *** C *** I M P L E M E N T A T I O N S P E C I F I C S E C T I O N *** C *** *** C ************************************************************************* C C C C C T E R M I N A L I N P U T - O U T P U T R O U T I N E S. C C SUBROUTINE PRMPT(PS, PL) C C Set up the interactive terminal prompt string. This is two C characters long maximum. C COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /TTYIO/ ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM INTEGER ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM DIMENSION ILINE(128), OLINE(138), PRSTR(2) INTEGER PS, PL PRSTR = PS C C *** For HP RTE-IV terminal drivers we use a '_' to suppress the C *** newline at the end of the prompt. CALL SBYTE(PRSTR, PL, KSUB) PRLEN = PL+1 RETURN END SUBROUTINE RSYM(ICHAR) C C Read the next character from the interactive terminal. Here it C is line buffered. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /TTYIO/ ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM INTEGER ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM DIMENSION ILINE(128), OLINE(138), PRSTR(2) INTEGER ICHAR INTEGER IEQT5 C C Is the line buffer empty ? IF (ILINEP.GT.0) GOTO 20 C C Yes ... issue the prompt and read in a new line. C *** Here we use the HP RTE-IV re-entrant input-output routine. 11 CONTINUE CALL REIO(2, TTY, PRSTR, -PRLEN) CALL REIO(1, 256+TTY, ILINE, -LINMAX) CALL ABREG(IEQT5, ILINEM) C C Check for unexpected end of file ( EOT or ctrl 'D' ). IF (IAND(IEQT5, 32).EQ.0) GOTO 20 CALL REIO(2, TTY, 0, 0) CALL REIO(2, TTY, 15H** EOF ignored!, -15) GOTO 11 20 CONTINUE C C Have all the characters in the line buffer been returned ? IF (ILINEP.GE.ILINEM) GOTO 30 C C No ... return the next character. ICHAR = LBYTE(ILINE, ILINEP) ILINEP = ILINEP+1 RETURN 30 CONTINUE C C End of line. Return a newline character and zero the line pointer. ICHAR = KNL ILINEP = 0 RETURN END SUBROUTINE TSKIP C C Throw away any characters type in but not yet read. C COMMON /TTYIO/ ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM INTEGER ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM DIMENSION ILINE(128), OLINE(138), PRLEN(2) ILINEP = 0 C C *** In systems which support type-ahead, special look ahead code C *** will be required here. C RETURN END SUBROUTINE PSTRG(STRING, ILEN) C C Put the contents of the STRING into the terminal buffer. C INTEGER STRING, ILEN DIMENSION STRING(63) INTEGER I, L IF (ILEN.LT.0) L = -ILEN IF (ILEN.EQ.0) RETURN IF (ILEN.GT.0) L = 2*ILEN DO 10 I = 0, L-1 CALL PSYM(LBYTE(STRING, I)) 10 CONTINUE RETURN END SUBROUTINE PNUM(N) C C Print the number N on the terminal. C COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ INTEGER IN, J, K LOGICAL LZ C C Less than or greater than zero ? IF (N.LT.0) GOTO 10 IN = N GOTO 20 10 CONTINUE IN = -N CALL PSYM(KMINUS) 20 CONTINUE C C Print out digits (leading zeros suppressed). LZ = .FALSE. DO 30 J = 4, 0, -1 K = MOD(IN/(10**J), 10)+K0 LZ = LZ .OR. K.NE.K0 .OR. J.EQ.0 IF (LZ) CALL PSYM(K) 30 CONTINUE RETURN END SUBROUTINE PSYM(ICHAR) C C Output a character to the terminal. Here it is line buffered. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /TTYIO/ ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM INTEGER ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM DIMENSION ILINE(128), OLINE(138), PRSTR(2) INTEGER ICHAR C C Queue character in the line buffer unless this is an newline. IF (ICHAR.EQ.KNL) GOTO 10 CALL SBYTE(OLINE, OLINEP, ICHAR) OLINEP = OLINEP+1 C C Force newline if buffer full, otherwise return. IF (OLINEP.LT.LINMAX+10) RETURN 10 CONTINUE C C Write line to the terminal. CALL NEWLN RETURN END SUBROUTINE NEWLN C C Output the current write buffer contents to the terminal. C COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /TTYIO/ ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM INTEGER ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM DIMENSION ILINE(128), OLINE(138), PRSTR(2) C C *** Here we use the HP RTE-IV re-entrant input-output routine. CALL REIO(2, TTY, OLINE, -OLINEP) OLINEP = 0 RETURN END C C C D I S C F I L E I N P U T - O U T P U T R O U T I N E S . C C SUBROUTINE FILES C C Fetch the names of the main input, secondary input and main output C files. C EXTERNAL LOGLU INTEGER LOGLU COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /FILIO/ MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME INTEGER MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME DIMENSION MITAB(10), MIDCB(272), + SITAB(10), SIDCB(144), + MOTAB(10), MODCB(272) DIMENSION SONAME(3) INTEGER LINE, LINEM, LINEL DIMENSION LINE(40) INTEGER IA, IB, I C C ECCE is run from a RTE-IV session with the following command: C C RUN,ECCE,
,, C C
= A valid FMGR file name. C For a null input file use a 0 (zero). C C = A valid FMGR file name. C If this parameter is omitted the secondary C input file defaults to a copy of the main C input file. For a null secondary input use a C 0 (zero): this will give a larger window into C the main input file. C C = A valid FMGR file name. C If this parameter is omitted the output file C will replace the main input file (on closing C ECCE). To just look at an input file without C altering it a 0 (zero) may be use here. C C Get LU of scheduling terminal. TTY = LOGLU(IA) C C Fetch the ECCE run string from the host FMGR. CALL EXEC(14, 1, LINE, -80) CALL ABREG(IA, IB) IF (IA.LT.0) GOTO 9000 LINEL = 1 LINEM = IB C C Skip the first two parameters in the ECCE run string ( "RU,ECCE," ). CALL NAMR(MITAB, LINE, LINEM, LINEL) CALL NAMR(MITAB, LINE, LINEM, LINEL) C C Parse the main input file name. CALL NAMR(MITAB, LINE, LINEM, LINEL) IF (IAND(MITAB(4), 003B).EQ.0) GOTO 9100 C C Parse the secondary input file name. CALL NAMR(SITAB, LINE, LINEM, LINEL) IF (IAND(SITAB(4), 003B).NE.0) GOTO 210 DO 201 I = 1, 10 SITAB(I) = MITAB(I) 201 CONTINUE 210 CONTINUE C C Parse the main output file name. CALL NAMR(MOTAB, LINE, LINEM, LINEL) IF (IAND(MOTAB(4), 003B).NE.0) GOTO 310 DO 301 I = 1, 10 MOTAB(I) = MITAB(I) 301 CONTINUE 310 CONTINUE RETURN C C Errors ... Print message and halt. 9000 CALL PSTRG(35H** Cannot pick up parameter string., -35) GOTO 9110 9100 CALL PSTRG( + 56H** Parameters? RUN,ECCE,,,., + -56) 9110 CALL NEWLN CALL EXEC(6) END SUBROUTINE OPNFI C C This opens up all the input-output streams using the information C from the FILES subroutine. C C *** For HP RTE-IV a temporary scratch file is created for output. C *** This is renamed to the required output file when the editor is C *** closed. C COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /FILIO/ MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME INTEGER MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME DIMENSION MITAB(10), MIDCB(272), + SITAB(10), SIDCB(144), + MOTAB(10), MODCB(272) DIMENSION SONAME(3) INTEGER MINAME, MIPARM, MISECU, MICART DIMENSION MINAME(3) EQUIVALENCE (MINAME, MITAB(1)), (MIPARM, MITAB(4)), + (MISECU, MITAB(5)), (MICART, MITAB(6)) INTEGER SINAME, SIPARM, SISECU, SICART DIMENSION SINAME(3) EQUIVALENCE (SINAME, SITAB(1)), (SIPARM, SITAB(4)), + (SISECU, SITAB(5)), (SICART, SITAB(6)) INTEGER MONAME, MOPARM, MOSECU, MOCART, MOTYPE, MOSIZE DIMENSION MONAME(3) EQUIVALENCE (MONAME, MOTAB(1)), (MOPARM, MOTAB(4)), + (MOSECU, MOTAB(5)), (MOCART, MOTAB(6)), + (MOTYPE, MOTAB(7)), (MOSIZE, MOTAB(8)) INTEGER ERROR, JSEC, JLU, JTYPE, JSIZE DIMENSION JSIZE(4) DATA JSEC /48/ DATA JLU / 0/ DATA JTYPE / 3/ DATA JSIZE / 0, 0, 0, 0/ C C C Open main input file (unless null). MIN = 0 IF (MINAME.EQ.0) GOTO 100 CALL OPEN(MIDCB, ERROR, MINAME, 0, MISECU, MICART, 256) IF (ERROR.LT.0) GOTO 9000 CALL LOCF(MIDCB, ERROR, J, J, J, JSEC, JLU, JTYPE) IF (ERROR.LT.0) GOTO 9000 MIN = 1 100 CONTINUE C C Open secondary input file (unless null). SIN = 0 IF (SINAME.EQ.0) GOTO 200 CALL OPEN(SIDCB, ERROR, SINAME, 0, SISECU, SICART, 128) IF (ERROR.LT.0) GOTO 9100 SIN = 2 200 CONTINUE C C Create temporary scratch file for output. OUT = 0 IF (MONAME.EQ.0) GOTO 300 IF (MOCART.EQ.0) MOCART = -JLU IF (MOTYPE.EQ.0) MOTYPE = JTYPE IF (MOSIZE.EQ.0) MOSIZE = JSEC/2 C JSIZE(2) = MOSIZE C CALL CRETS(MODCB, ERROR, 0, SONAME C + JSIZE, MOTYPE, MOSECU, MOCART, 256) SONAME(1) = 2H.E SONAME(2) = 2HCC SONAME(3) = 2HE. CALL CREAT(MODCB, ERROR, SONAME, + MOSIZE, MOTYPE, MOSECU, MOCART, 256) IF (ERROR.LT.0) GOTO 9200 OUT = 1 300 CONTINUE RETURN C C Error ... Print message and stop. 9000 CALL PSTRG(21H** Cannot open source, -21) GOTO 9210 9100 CALL PSTRG(24H** Cannot open secondary, -24) GOTO 9210 9200 CALL PSTRG(24H** Cannot create scratch, -24) 9210 CALL PSTRG(19H file. FMGR error , -19) CALL PNUM(ERROR) CALL NEWLN CALL EXEC(6) END SUBROUTINE INLN(BUFFER, SIZE) C C Read the next line from the main (or secondary) input file into C the array BUFFER . SIZE returns the number of characters input. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /FILIO/ MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME INTEGER MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME DIMENSION MITAB(10), MIDCB(272), + SITAB(10), SIDCB(144), + MOTAB(10), MODCB(272) DIMENSION SONAME(3) INTEGER BUFFER, SIZE DIMENSION BUFFER(128) INTEGER ERROR C C Null input file ? SIZE = -1 IF (IN.EQ.0) RETURN C C Read a record from the appropriate file. IF (IN.EQ.MIN) CALL READF(MIDCB, ERROR, BUFFER, LINMAX/2, SIZE) IF (IN.EQ.SIN) CALL READF(SIDCB, ERROR, BUFFER, LINMAX/2, SIZE) C C Check for end of file error. IF (ERROR.EQ.-12) SIZE = -1 IF (SIZE.LT.0) RETURN C C Check for other errors. IF (ERROR.LT.0) GOTO 99 C C Convert word count to character count. SIZE = 2*SIZE C C Strip off any trailing spaces. * 10 IF (SIZE.EQ.0 .OR. LBYTE(BUFFER, SIZE-1).NE.KSPACE) RETURN * SIZE = SIZE-1 * GOTO 10 RETURN C C Disc read error ... print message and stop. 99 CALL PSTRG(14H** Read from , -14) IF (IN.EQ.MIN) CALL PSTRG(6Hsource, -6) IF (IN.EQ.SIN) CALL PSTRG(9Hsecondary, -9) CALL PSTRG(21H failed. FMGR error , -21) CALL PNUM(ERROR) CALL NEWLN CALL EXEC(6) END SUBROUTINE OUTLN(BUFFER, SIZE) C C Write the line in BUFFER to the output file. SIZE gives the C number of characters to be output. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /FILIO/ MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME INTEGER MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME DIMENSION MITAB(10), MIDCB(272), + SITAB(10), SIDCB(144), + MOTAB(10), MODCB(272) DIMENSION SONAME(3) INTEGER BUFFER, SIZE DIMENSION BUFFER(128) INTEGER ERROR, ISIZE C C Null output ? IF (OUT.EQ.0) RETURN ISIZE = SIZE C C *** A requirement of the HP RTE-IV File Manager is that there must C *** be an even number of characters to each record (line) in a file. C *** Here we add an extra space to the end of any odd length lines. C *** Note that BUFFER is equivalent to A(n) in the file buffer. C *** Therefore this space is overwritting the newline character at C *** the end this line in the file buffer. This will not matter as C *** long as the start of the next line has been marked with a C *** pointer. See the PLINE routine. IF (IAND(ISIZE, 1).EQ.0) GOTO 10 CALL SBYTE(BUFFER, ISIZE, KSPACE) ISIZE = ISIZE+1 10 CONTINUE C C *** There must be no blank lines in an File Manager file. Here we C *** substitute two spaces for zero length lines. C *** These two spaces cannot be appended to the BUFFER as the latter C *** will overwrite the first character of the next line in the file C *** buffer. We use a seperate call to WRITF for this case. IF (ISIZE.GT.0) GOTO 20 CALL WRITF(MODCB, ERROR, 2H , 1) GOTO 30 20 CONTINUE CALL WRITF(MODCB, ERROR, BUFFER, ISIZE/2) 30 CONTINUE C C Check for errors. IF (ERROR.GE.0) RETURN C C Disc write failed ... print error message and stop. CALL PSTRG(44H** Write to output file failed. FMGR error , -44) CALL PNUM(ERROR) CALL NEWLN CALL EXEC(6) END SUBROUTINE CLSFI C C Close input and output streams (if open). C COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /FILIO/ MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME INTEGER MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME DIMENSION MITAB(10), MIDCB(272), + SITAB(10), SIDCB(144), + MOTAB(10), MODCB(272) DIMENSION SONAME(3) INTEGER MONAME, MOPARM, MOSECU, MOCART DIMENSION MONAME(3) EQUIVALENCE (MONAME, MOTAB(1)), (MOPARM, MOTAB(4)), + (MOSECU, MOTAB(5)), (MOCART, MOTAB(6)) INTEGER ERROR IF (MIN.NE.0) CALL CLOSE(MIDCB) IF (SIN.NE.0) CALL CLOSE(SIDCB) IF (OUT.EQ.0) RETURN IF (OUT.EQ.1) GOTO 100 C C Normal close. Rename the scratch file to the required output file C name. Purge any previously existing copy of this file. CALL PURGE(MIDCB, ERROR, MONAME, MOSECU, MOCART) IF (ERROR.LT.0 .AND. ERROR.NE.-6) GOTO 99 CALL NAMF(MODCB, ERROR, SONAME, MONAME, MOSECU, MOCART) IF (ERROR.GE.0) RETURN C C Some error occured ... 99 CALL PSTRG(41H** Cannot close output file. FMGR error , -41) CALL PNUM(ERROR) CALL NEWLN C C Abort close. Leave the editing in the scratch file. 100 CALL CLOSE(MODCB) CALL PSTRG(33H** Editing left in scratch file ', -33) CALL PSTRG(SONAME, -6) CALL PSTRG(2H'., -2) CALL NEWLN RETURN END BLOCK DATA EDATA C C *** This block data subprogram is required by HP FTN4 to reserve area C *** form the named common blocks. C *** The block data subprogram containing the file buffer and pointers C *** resides along with the file buffer access routines below. C COMMON /CECCE/ SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX INTEGER SYM, PEND, SYMTYP, TYPE, CODE, TEXT, + NUM, CHAIN, PP1, MON, CASE, + STOP, PRINT1, PRINT2, LINMAX DIMENSION SYMTYP(63) C COMMON /COMMD/ C, CIBASE, TIBASE, CI, TI, CMAX INTEGER C, CIBASE, TIBASE, CI, TI, CMAX DIMENSION C(128) C COMMON /MACRO/ STORED, POS1, POS2, POS3 INTEGER STORED, POS1, POS2, POS3 DIMENSION STORED(192) C COMMON /SINPR/ SEXTRA, SINPUT, SINTOP, SFP, SECFP, SEND, + MFP, MLEND, MEND, MARKER INTEGER SEXTRA, SINTOP, SFP, SECFP, SEND, + MFP, MLEND, MEND, MARKER LOGICAL SINPUT C COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ C COMMON /IOCHN/ TTY, IN, MIN, SIN, OUT INTEGER TTY, IN, MIN, SIN, OUT C COMMON /TTYIO/ ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM INTEGER ILINE, ILINEP, ILINEM, PRSTR, PRLEN, + OLINE, OLINEP, OLINEM DIMENSION ILINE(128), OLINE(138), PRSTR(2) C COMMON /FILIO/ MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME INTEGER MITAB, MIDCB, SITAB, SIDCB, MOTAB, MODCB, + SONAME DIMENSION MITAB(10), MIDCB(272), + SITAB(10), SIDCB(144), + MOTAB(10), MODCB(272) DIMENSION SONAME(3) C C C C C 1. Looping limit and maximum line length:- DATA STOP /-1000/ DATA LINMAX /256/ C C 2. Input-output stream constants:- DATA TTY /1/ DATA MIN /0/ DATA SIN /0/ DATA IN /0/ DATA OUT /0/ C C 3. Commands:- DATA CIBASE /1/ DATA TIBASE /128/ C C 4. Command type table:- C C ! " # $ % & ' ( ) * + , - . / C 0 1 2 3 4 5 6 7 8 9 : ; < = > ? C @ A B C D E F G H I J K L M N O C P Q R S T U V W X Y Z [ \ ] ^ _ C DATA SYMTYP/ + 64, 3, 3, 3, 2, 3, 3, 75, 73, 64, 3, 76, 2, 3, 3, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 3, 3, 3, 64, + 3,218, 10, 18, 5, 8,116, 10, 2, 6, 10, 10, 58,120,250, 2, + 74, 50, 10, 22, 85, 53, 6, 2, 32, 32, 32, 3, 74, 3, 3, 3/ C (octal values) C 100, 3, 3, 3, 2, 3, 3,113,111,100, 3,114, 2, 3, 3, C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 3, 3, 3,100, C 3,332, 12, 22, 5, 10,164, 12, 2, 6, 12, 12, 72,170,372, 2, C 112, 62, 12, 26,125, 65, 6, 2, 40, 40, 40, 3,112, 3, 3, 3 C C (meaning of bit positions) C 7 (200) = Secondary input specific commands. C 6 (100) = Secondary input permissable commands. C 5 ( 40) = A special '%' command. C 4 ( 20) = A special '%' command. C 3 ( 10) = C 2 ( 4) = C 1 ( 2) = C 0 ( 1) = C C C 5. ASCII character set:- DATA KNL /10/, KFF /12/, + KSPACE/32/, KXCLAM/33/, KDQUOT/34/, KHASH /35/, KDOLLR/36/, + KPCENT/37/, KAND /38/, KQUOTE/39/, KLPAR /40/, KRPAR /41/, + KSTAR /42/, KPLUS /43/, KCOMMA/44/, KMINUS/45/, KDOT /46/, + KSLASH/47/, K0 /48/, K1 /49/, K2 /50/, K3 /51/, + K4 /52/, K5 /53/, K6 /54/, K7 /55/, K8 /56/, + K9 /57/, KCOLON/58/, KSEMIC/59/, KLT /60/, KEQ /61/, + KGT /62/, KQUEST/63/, KAT /64/, KA /65/, KB /66/, + KC /67/, KD /68/, KE /69/, KF /70/, KG /71/, + KH /72/, KI /73/, KJ /74/, KK /75/, KL /76/, + KM /77/, KN /78/, KO /79/, KP /80/, KQ /81/, + KR /82/, KS /83/, KT /84/, KU /85/, KV /86/, + KW /87/, KX /88/, KY /89/, KZ /90/, KLBRAC/91/, + KBACKS/92/, KRBRAC/93/, KUPARR/94/, KSUB /95/, + KGRAV /96/, KLA /97/, KLZ /122/ C C END C C C ************************************************************************* C *** *** C *** F I L E B U F F E R A C C E S S R O U T I N E S *** C *** *** C ************************************************************************* C C C Access to the characters in the file buffer should be as efficient C as possible. It is strongly recommended that the following routines C should be machine coded. C C SUBROUTINE BINIT C C Initialise the file buffer pointers. Here the pointers are byte C indexes into the file buffer array A . If these following C routines are machine coded then it might be worth converting the C pointer to physical byte addresses. All buffer accesses are done C via these routines and so this change will be transparent to the C code above this point. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES TOP = 2*BYTES BOT = BUFLEN*BYTES-1 FBEG = TOP PP = FBEG-1 CALL PUTPP(KNL) LBEG = PP FP = BOT LEND = FP FEND = LEND RETURN END SUBROUTINE RSTAR C C Move down the file buffer until a newline character is reached. C This routine is implementation transparent but is included here C as it will benifit from machine coding. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES 10 CONTINUE IF (FP.EQ.LEND) RETURN CALL RIGHT GOTO 10 END SUBROUTINE RIGHT C C Move down one character in the file buffer, ignoring any newline C character. This routine is implementation transparent but is C included here as it will benifit from machine coding. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES CALL PUTPP(JGET(FP)) FP = FP+1 RETURN END SUBROUTINE LSTAR C C Move back up the file buffer until a newline character is reached. C Once again this routine will benifit from machine coding. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES 10 CONTINUE IF (PP.EQ.LBEG) RETURN CALL LEFT GOTO 10 END SUBROUTINE LEFT C C Move back one character in the file buffer. Once again this C routine will benifit from machine coding. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES PP = PP-1 CALL PUTFP(JGET(PP)) RETURN END INTEGER FUNCTION JGET(IP) C C This is essentially a mapping function into the buffer, the index C (or byte address) being IP . C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) INTEGER IP JGET = LBYTE(A, IP) RETURN END SUBROUTINE PUTPP(ICHAR) C C Another mapping routine to store the character ICHAR in the file C buffer at PP pointer. PP is post incremented. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER ICHAR CALL SBYTE(A, PP, ICHAR) PP = PP+1 RETURN END SUBROUTINE PUTFP(ICHAR) C C Another mapping routine to store the character ICHAR is the file C buffer at the FP pointer. FP is pre-decremented. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES FP = FP-1 CALL SBYTE(A, FP, ICHAR) RETURN END SUBROUTINE JMOVE(IPTO, IPFROM, ILEN) C C Move bytes within the file buffer. ILEN bytes are transfered from C the position indexed by IPFROM to the position indexed by IPTO. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) INTEGER IPTO, IPFROM, ILEN INTEGER I, P1, P2 IF (ILEN.LE.0) RETURN P1 = IPTO P2 = IPFROM DO 10 I = 1, ILEN CALL SBYTE(A, P1, LBYTE(A, P2)) P1 = P1+1 P2 = P2+1 10 CONTINUE RETURN END INTEGER FUNCTION JFIND(IP, ICHAR) C C Search for the character ICHAR in the file buffer, starting at C the position indexed by the pointer IP . The scan terminates C when the character has been found or a newline is reached. This C function returns as its result the point where the scan finished. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) COMMON /KSYMS/ KNL, KFF, + KSPACE, KXCLAM, KDQUOT, KHASH, KDOLLR, KPCENT, + KAND, KQUOTE, KLPAR, KRPAR, KSTAR, KPLUS, + KCOMMA, KMINUS, KDOT, KSLASH, K0, K1, + K2, K3, K4, K5, K6, K7, + K8, K9, KCOLON, KSEMIC, KLT, KEQ, + KGT, KQUEST, KAT, KA, KB, KC, + KD, KE, KF, KG, KH, KI, + KJ, KK, KL, KM, KN, KO, + KP, KQ, KR, KS, KT, KU, + KV, KW, KX, KY, KZ, KLBRAC, + KBACKS, KRBRAC, KUPARR, KSUB, + KGRAV, KLA, KLZ INTEGER IP, ICHAR INTEGER P1 P1 = IP 10 CONTINUE K = LBYTE(A, P1) IF (K.EQ.ICHAR .OR. K.EQ.KNL) GOTO 20 P1 = P1+1 GOTO 10 20 CONTINUE JFIND = P1 RETURN END BLOCK DATA BDATA C C This block data subprogram includes the file buffer and pointers. C This data area should reside with the file buffer access routines C if they are machine coded. C COMMON /BUFF/ A INTEGER A DIMENSION A(10000) C COMMON /BUFPR/ TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES INTEGER TOP, FBEG, LBEG, PP, FP, LEND, + FEND, BOT, MS, ML, BUFLEN, BYTES C C DATA BUFLEN /10000/ DATA BYTES /2/ C C END C C C C G E N E R A L B Y T E A C C E S S R O U T I N E S . C C INTEGER FUNCTION LBYTE(IARRAY, IBDISP) C C This function returns the byte displaced by IBDISP from the start C of the array IARRAY. The high order byte of IARRAY(1) is byte C zero. This routine assumes a 16-bit machine word and that each C byte is as ASCII character (top bit clear). C INTEGER IARRAY, IBDISP DIMENSION IARRAY(128) INTEGER K K = IARRAY(1+IBDISP/2) IF (IAND(IBDISP, 1).EQ.1) GOTO 10 LBYTE = ISHFT(K, -8) RETURN 10 CONTINUE LBYTE = IAND(K, 377B) RETURN END SUBROUTINE SBYTE(IARRAY, IBDISP, ICHAR) C C Store the byte ICHAR at a displacement IBDISP from the start C of the array IARRAY . The high order byte of IARRAY(1) is byte C zero. This routine assumes a 16-bit machine word and that each C byte is an ASCII character (top bit clear). C INTEGER IARRAY, IBDISP, ICHAR DIMENSION IARRAY(128) INTEGER I I = 1+IBDISP/2 IF (IAND(IBDISP, 1).EQ.1) GOTO 10 IARRAY(I) = IAND(IARRAY(I), 177B)+ISHFT(ICHAR, 8) RETURN 10 CONTINUE IARRAY(I) = IAND(IARRAY(I), 77400B)+IAND(ICHAR, 177B) RETURN END