Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0050/tblstr.for
There is 1 other file named tblstr.for in the archive. Click here to see a list.
SUBROUTINE TBLSTR
C
C ROUTINE TO HANDLE TBLTRN TEXT STRINGS
C
C DONALD E. BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C
COMMON/TBLTRN/I,IADDRS,IADJST,IBASE,IBLANK,IDGT(16),
1IERR,IFILL,IFKNT,IKODE,ILEFT,ILINE,ILPT,ILTR,IBYTE,
2IMASK,LMAX,NMORE,IMOST,INSERT,IOCT(13),IOPRTR,IOUT,
3IPAREN,IPNCTN(11),IPRCN,IRADIX,IREAD,IREPT,IRIGHT,
4ISHIFT,ISIGN,ISTAR,ISTORE(478),ITEN,ITEST,ITITLE(6),
5ITTY,IWIDE,IWRITE,J,JADJST,JBASE,JBLANK,JERR,KPAREN,
6JFKNT,JKODE(37),JLEFT,JMASK,JMORE,JPAREN,JRADIX,LOOP,
7JRIGHT,JSHIFT,JSIGN,K,KADJST,KBASE,KERR,KIND,KLINE,
8KLM,KLTR,KMASK,KNT,KNTLTR,KNTWRD,KODE,KRADIX,IDBG,
9KREAD,KSHIFT,L,LEAST,LETTER(160),LMASK,LOCK,LSTNEW,
1LTTR(160),M,MASK,MASTER(5000),MAX,MLEFT,MORE,MOST,
2MRIGHT,MULT,N,NEW,NEXT,NSIGN,NTITLE(6),NUMBER,LRADIX,
3KMAX,INLINE,JPNCTN(50),KPNCTN(50),LPNCTN,JOPRTR,NLTR,
4JBYTE,ILOOP,ISKIP,IVALUE,INSN(6),JNSN,IMAX,JMAX,
5KNSN,MLTR,JLTR,JLOOP,IPFX,JPFX,LSIGN,IIARG,JJARG,
6KKARG,LLARG,JVALUE,MIN,IAC,IARG,JARG,KARG,LARG,JSTFY,
7LENGTH(20),LNGMIN,IORDER,IRMV,KSIGN
C
C KODE=4, ' (APOSTROPHE OR SINGLE QUOTE) OPERATOR
C KODE=36, '' (DOUBLE APOSTROPHE) OPERATOR
1 ILEFT=IRIGHT
2 ILEFT=ILEFT+1
IF(ILEFT.GT.MLTR)GO TO 4
IF(LETTER(ILEFT).EQ.IBLANK)GO TO 2
IRIGHT=ILEFT
3 IRIGHT=IRIGHT+1
IF(IRIGHT.GT.MLTR)GO TO 4
IF(LETTER(IRIGHT).NE.LETTER(ILEFT))GO TO 3
4 IF(LOOP.NE.0)GO TO 6
IF(IRIGHT.LE.(LMAX-5))GO TO 6
IF(ILINE.EQ.JERR)GO TO 6
JERR=ILINE
JBLANK=1
WRITE(ITTY,5)ILINE
5 FORMAT(1X,4HLINE,1I6,
132H PROBABLY EXCEEDS MAXIMUM LENGTH)
6 ILEFT=ILEFT+1
IF(ISKIP.NE.0)GO TO 81
IF(IFKNT.NE.0)GO TO 80
IF(IARG.EQ.0)GO TO 7
IF(ILEFT.LE.LARG)GO TO 7
IF(JARG.GT.0)JARG=JARG-1
7 IF(KNTWRD.NE.0)GO TO 8
IADDRS=0
IKODE=KODE
8 KNTWRD=KNTWRD+1
IF(IOPRTR.EQ.23)GO TO 27
IF(IOPRTR.EQ.72)GO TO 33
IF(IOPRTR.EQ.118)GO TO 27
IF(IOPRTR.EQ.15)GO TO 9
IF(IOPRTR.NE.37)GO TO 24
C
C DEFINE SYMBOL AS TEXT STRING
9 IF(MASTER(IADDRS).EQ.16)GO TO 18
IF(IERR.NE.0)GO TO 24
IF(MASTER(IADDRS).EQ.8)GO TO 10
IF(INSERT.EQ.0)GO TO 24
GO TO 11
10 IF(MASTER(IADDRS-1).NE.0)GO TO 12
C DEFINE NEW DATA CELL IF NONE PRESENT
11 LSTNEW=MASTER(IADDRS+1)-1
IF((LSTNEW-IRIGHT+ILEFT-4).LE.
1(MOST+NEXT))GO TO 84
MASTER(IADDRS)=8
MASTER(IADDRS-1)=-LSTNEW
MASTER(LSTNEW)=-IADDRS+1
MASTER(LSTNEW-1)=0
LEAST=LSTNEW
IF(INSERT.EQ.0)GO TO 15
LEAST=LEAST-2
GO TO 14
12 LSTNEW=-MASTER(IADDRS-1)
IF((LSTNEW-IRIGHT+ILEFT-3).LE.
1(MOST+NEXT))GO TO 84
LEAST=MASTER(LSTNEW+1)
I=LSTNEW-1
13 I=I-MASTER(I)-2
IF(I.GT.LEAST)GO TO 13
IF(INSERT.EQ.0)GO TO 15
C DEFINE NUMBER OF ARGUMENTS
14 MOST=MOST-MULT
INSERT=0
NEXT=0
MULT=0
MASK=0
KPAREN=0
MASTER(LEAST)=MASTER(MOST+1)
15 LEAST=LEAST-2
MASTER(LEAST+1)=IRIGHT-ILEFT
I=IRIGHT
IF(IRIGHT.LE.ILEFT)GO TO 17
IF(KODE.EQ.36)GO TO 45
C DEFINE AS DIRECT COPY OF TEXT
16 I=I-1
MASTER(LEAST)=LETTER(I)
LEAST=LEAST-1
IF(I.GT.ILEFT)GO TO 16
17 MASTER(LSTNEW+1)=LEAST
MASTER(LEAST)=0
GO TO 82
C
C RENAME AS FOR STATEMENT A=.'/,,,/
18 IF(KNTWRD.NE.4)GO TO 24
IF(KODE.EQ.36)GO TO 45
IF(ILEFT.EQ.IRIGHT)GO TO 82
IF(LETTER(ILEFT).NE.IBLANK)GO TO 19
ILEFT=ILEFT+1
GO TO 18
19 J=IRIGHT
20 J=J-1
IF(LETTER(J).EQ.IBLANK)GO TO 20
INDEX=J-ILEFT+1
I=INDEX
IF(I.GT.20)I=20
LIMIT=LENGTH(I)
IF(LIMIT.EQ.0)LIMIT=LNGMIN
I=0
21 KOUNT=J
22 NEW=LIMIT-3
LIMIT=MASTER(LIMIT)
IF(LIMIT.LE.0)GO TO 83
IF(MASTER(NEW+2).LE.2)GO TO 22
IF((LIMIT+INDEX).EQ.NEW)GO TO 23
IF(NEW.LT.LNGMIN)GO TO 22
IF(INDEX.LT.20)LIMIT=LNGMIN
GO TO 22
23 IF(MASTER(NEW).NE.LETTER(KOUNT))GO TO 21
NEW=NEW-1
KOUNT=KOUNT-1
IF(KOUNT.GE.ILEFT)GO TO 23
NEW=NEW+INDEX+2
IF(NEW.EQ.IADDRS)GO TO 21
MASTER(IADDRS)=MASTER(NEW)
MASTER(IADDRS-1)=MASTER(NEW-1)
IRMV=NEW
GO TO 82
C
C WRITE THE TEXT STRING ONTO LPT OR TTY
24 IF(ITEST.NE.0)GO TO 82
IF(IRIGHT.LE.ILEFT)GO TO 82
J=IRIGHT-1
IF(KODE.EQ.36)GO TO 26
IF(IWRITE.EQ.ITTY)GO TO 26
WRITE(IWRITE,25)(LETTER(I),I=ILEFT,J)
25 FORMAT(150A1)
GO TO 82
26 WRITE(ITTY,25)IBLANK,(LETTER(I),I=ILEFT,J)
JBLANK=1
GO TO 82
C
C ********************************************
C * SYMBOL IN RANGE OF TTL OR NSN OPERATOR *
C ********************************************
C
27 IF(IRIGHT.LE.ILEFT)GO TO 79
IF(LETTER(ILEFT).NE.IBLANK)GO TO 28
ILEFT=ILEFT+1
GO TO 27
28 IF(IOPRTR.EQ.23)GO TO 30
JNSN=0
29 JNSN=JNSN+1
INSN(JNSN)=LETTER(ILEFT)
IF(JNSN.EQ.6)GO TO 79
GO TO 32
30 KNTLTR=0
31 KNTLTR=KNTLTR+1
ITITLE(KNTLTR)=LETTER(ILEFT)
IF(KNTLTR.EQ.6)GO TO 79
32 ILEFT=ILEFT+1
IF(IRIGHT.LE.ILEFT)GO TO 79
IF(LETTER(ILEFT).EQ.IBLANK)GO TO 32
IF(IOPRTR.EQ.23)GO TO 31
GO TO 29
C
C ***********************************
C * TEXT IN RANGE OF ACC OPERATOR *
C ***********************************
C
33 I=0
34 IF(IRIGHT.LE.ILEFT)GO TO 79
IF(LETTER(ILEFT).NE.IBLANK)GO TO 35
ILEFT=ILEFT+1
GO TO 34
35 I=I+1
IF(I.GT.LPNCTN)GO TO 37
IF(JPNCTN(I).NE.LETTER(ILEFT))GO TO 35
36 IF(I.EQ.LPNCTN)GO TO 37
JPNCTN(I)=JPNCTN(I+1)
KPNCTN(I)=KPNCTN(I+1)
I=I+1
GO TO 36
C
C NOTE --- IF MORE THAN 50 CHARACTERS ARE TO BE
C ASSIGNED TO CHARACTER CLASSES, THEN THE DIMENSIONS
C OF JPNCTN AND OF KPNCTN, AND THE FOLLOWING TEST
C MUST BE CHANGED.
C
37 IF(I.GT.50)GO TO 83
LPNCTN=I
JPNCTN(I)=LETTER(ILEFT)
J=7
38 J=J+1
K=1
39 IF(K.EQ.I)GO TO 40
IF(KPNCTN(K).EQ.J)GO TO 38
K=K+1
GO TO 39
40 KPNCTN(I)=J
41 ILEFT=ILEFT+1
IF(IRIGHT.LE.ILEFT)GO TO 44
IF(LETTER(ILEFT).EQ.IBLANK)GO TO 41
I=0
42 I=I+1
IF(I.GT.LPNCTN)GO TO 43
IF(JPNCTN(I).NE.LETTER(ILEFT))GO TO 42
KPNCTN(LPNCTN)=KPNCTN(I)
GO TO 79
43 LPNCTN=LPNCTN-1
GO TO 79
44 KPNCTN(I)=5
GO TO 79
C
C ************************************
C * DEFINE SYMBOL AS COMPILED TEXT *
C ************************************
C
45 KIND=0
NEW=LEAST+1
I=ILEFT-1
C
C DETERMINE COMPILATION CODE IDENTIFIER CHARACTER
C THIS IS INITIALLY THE ASTERISK
NUMBER=0
46 IF(NUMBER.EQ.LPNCTN)GO TO 83
NUMBER=NUMBER+1
IF(KPNCTN(NUMBER).NE.7)GO TO 46
C
C FIND NEXT SYMBOL IN TEXT STRING
47 N=KIND
48 KIND=0
ILEFT=I+1
K=ILEFT
INDEX=0
49 I=I+1
IF(I.GE.IRIGHT)GO TO 55
J=LETTER(I)
DO 51 L=1,11
IF(J.NE.IPNCTN(L))GO TO 51
IF(L.EQ.3)GO TO 53
IF(KIND.EQ.0)GO TO 50
IF(KIND.NE.L)GO TO 55
GO TO 49
50 KIND=L
GO TO 49
51 CONTINUE
IF(KIND.GT.0)GO TO 55
IF(KIND.LT.-1)GO TO 49
DO 52 L=1,10
IF(J.NE.IDGT(L))GO TO 52
KIND=-1
K=K+1
IF(INDEX.LE.10000)INDEX=(10*INDEX)+L-1
GO TO 49
52 CONTINUE
IF(KIND.EQ.0)GO TO 54
KIND=-2
GO TO 49
C
C ASTERISK IN TEXT
53 IF(KIND.GT.0)GO TO 55
IF(KIND.EQ.-1)GO TO 70
IF(KIND.EQ.-2)GO TO 49
54 KIND=-3
GO TO 49
C
C MATCH SYMBOL IN ORIGINAL SYMBOL DICTIONARY
55 I=I-1
IF(KIND.EQ.0)GO TO 75
IF(KIND.EQ.1)GO TO 48
IF(KIND.EQ.2)GO TO 71
IF(KIND.EQ.-1)GO TO 71
J=1
KODE=I-K+1
56 M=J+2
J=ISTORE(J)+M
IF(M.EQ.J)GO TO 71
IF(KODE.NE.(J-M))GO TO 56
L=K
57 IF(ISTORE(M).NE.LETTER(L))GO TO 56
M=M+1
L=L+1
IF(M.LT.J)GO TO 57
C
C CHECK IF CODE CAN BE USED WITH INTEGER PREFIX
J=J-L+K-1
J=ISTORE(J)
IF(J.EQ.1001)GO TO 71
IF(KIND.NE.-2)GO TO 59
M=0
58 M=M+1
IF(JKODE(M).EQ.0)GO TO 71
IF(JKODE(M).NE.J)GO TO 58
IF(INDEX.NE.0)GO TO 59
J=J+1
KIND=0
C
C MAKE BE COMPILED CODE (FORM A=.''/,/)
59 IF(MASTER(IADDRS).NE.16)GO TO 62
IF(KIND.EQ.-2)GO TO 60
INDEX=0
GO TO 61
60 J=J+1
61 MASTER(IADDRS)=J
MASTER(IADDRS-1)=INDEX
GO TO 82
C
C INSERT COMPILED CODE INTO DEFINITION
62 M=0
CALL DANUMB(0,J,10,IOCT,M,0,13)
IF(N.GE.0)GO TO 63
MASTER(LEAST)=IBLANK
LEAST=LEAST-1
63 IF((LEAST-M-1).LE.MOST)GO TO 78
DO 64 L=1,M
MASTER(LEAST)=IOCT(L)
64 LEAST=LEAST-1
MASTER(LEAST)=JPNCTN(NUMBER)
LEAST=LEAST-1
IF(KIND.EQ.-2)GO TO 68
IF(J.EQ.6)GO TO 75
IF(J.EQ.7)GO TO 75
KIND=3
IF(J.EQ.4)GO TO 65
IF(J.EQ.36)GO TO 65
IF(J.NE.83)GO TO 47
C
C DETERMINE END OF TEXT STRING WITHIN TEXT STRING
65 IF((I+1).EQ.IRIGHT)GO TO 47
I=I+1
IF(LETTER(I).EQ.IBLANK)GO TO 65
ILEFT=I
IF((I+1).EQ.IRIGHT)GO TO 73
GO TO 67
66 IF(LETTER(I).EQ.LETTER(ILEFT))GO TO 73
67 I=I+1
IF((I+1).NE.IRIGHT)GO TO 66
GO TO 73
C
C INSERT INTEGER PREFIX AS SUFFIX OF COMPILED CODE
68 IF((LEAST-K+ILEFT-3).LE.MOST)GO TO 78
IF(INDEX.EQ.1)GO TO 69
MASTER(LEAST)=IDGT(2)
MASTER(LEAST-1)=IDGT(3)
MASTER(LEAST-2)=JPNCTN(NUMBER)
LEAST=LEAST-3
69 MASTER(LEAST)=LETTER(ILEFT)
LEAST=LEAST-1
ILEFT=ILEFT+1
IF(ILEFT.LT.K)GO TO 69
KIND=-1
GO TO 47
C
C INSERT TEXT SYMBOL INTO DEFINITION IF NO MATCH
70 KIND=3
71 IF(MASTER(IADDRS).EQ.16)GO TO 83
IF(N.EQ.3)GO TO 73
IF(KIND.EQ.N)GO TO 72
IF(N.GE.0)GO TO 73
IF(KIND.EQ.3)GO TO 72
IF(KIND.GE.0)GO TO 73
72 MASTER(LEAST)=IBLANK
LEAST=LEAST-1
73 IF((LEAST-I+ILEFT-1).LE.MOST)GO TO 78
74 MASTER(LEAST)=LETTER(ILEFT)
LEAST=LEAST-1
ILEFT=ILEFT+1
IF(ILEFT.LE.I)GO TO 74
GO TO 47
C
C REVERSE TEXT WHEN COMPILATON DONE
75 MASTER(NEW)=NEW-LEAST-1
J=LEAST
76 NEW=NEW-1
J=J+1
IF(NEW.LE.J)GO TO 77
K=MASTER(NEW)
MASTER(NEW)=MASTER(J)
MASTER(J)=K
GO TO 76
77 MASTER(LEAST)=0
MASTER(LSTNEW+1)=LEAST
GO TO 82
C
C PREPARE TO EXIT IF MASTER OVERFLOWS
78 MASTER(IADDRS-1)=0
LEAST=LSTNEW+1
MASTER(LEAST)=0
GO TO 84
C
C *******************************
C * RETURN TO CALLING PROGRAM *
C *******************************
C
C KODE IS RETURNED AS FOLLOWS
C KODE = 0, CALL TBLNXT.
C KODE = 1, ERROR DETECTED.
C KODE = 2, OVERFLOW OF STORAGE.
C
79 IOPRTR=0
GO TO 82
80 KNTWRD=KNTWRD+1
GO TO 82
81 ISKIP=ISKIP-1
82 KODE=0
GO TO 85
83 KODE=1
GO TO 85
84 KODE=2
85 RETURN
END