Compucolor.org – Virtual Media

Listing of file='MACROS.FOR;03' on disk='vmedia/ratfor-sector.ccvf'

	INTEGER FUNCTION DEFTOK(TOKEN,TOKSIZ,FD)
	IMPLICIT BYTE (A-Z)
	INTEGER FD,LOOKUP
	BYTE DEFN(80),TOKEN(80)
C
	T = GTOK(TOKEN,TOKSIZ,FD)
23058	IF(.NOT.(T.NE.-3)) GOTO 23059
	IF(.NOT.(T.NE.-100)) GOTO 23060
	GOTO 23059
23060	CONTINUE
	IF(.NOT.(LOOKUP(TOKEN,DEFN).EQ.0)) GOTO 23062
	GOTO 23059
23062	CONTINUE
	IF(.NOT.(DEFN(1).EQ.-10)) GOTO 23062
	CALL GETDEF(TOKEN,TOKSIZ,DEFN,200,FD)
	CALL INSTAL(TOKEN,DEFN)
	GOTO 23065
23064	CONTINUE
	CALL PBSTR(DEFN)
23065	CONTINUE
	T = GTOK(TOKEN,TOKSIZ,FD)
	IF(.NOT.(T.EQ.10)) GOTO 23066
	T = GTOK(TOKEN,TOKSIZ,FD)
23066	CONTINUE
	GOTO 23058
23059	CONTINUE
	DEFTOK = T
	RETURN
	END

	SUBROUTINE GETDEF(TOKEN,TOKSIZ,DEFN,DEFSIZ,FD)
	IMPLICIT BYTE (A-Z)
	INTEGER FD
	BYTE TOKEN(80),DEFN(80),PTOKEN(80)
C
	C = GTOK(PTOKEN,80,FD)
	IF(.NOT.(C.EQ.'(')) GOTO 23136
	T = '('
	GOTO 23137
23136	CONTINUE
	T = ' '
	CALL PBSTR(PTOKEN)
23137	CONTINUE
	IF(.NOT.(GTOK(TOKEN,TOKSIZ,FD).NE.-100)) GOTO 23138
	CALL ERROR('10-NON-ALPHANUMERIC NAME IN DEFINE.')
23138	CONTINUE
	C = GTOK(PTOKEN,80,FD)
	IF(.NOT.(T.EQ.' ')) GOTO 23140
	CALL PBSTR(PTOKEN)
	I = 1
23142	CONTINUE
	C = NGETCH(C,FD)
	IF(.NOT.(I.GT.DEFSIZ)) GOTO 23145
	CALL ERROR('11-DEFINITION TOO LONG.')
23145	CONTINUE
	DEFN(I) = C
	I = I+1
23143	IF(.NOT.(C.EQ.'#'.OR.C.EQ.10.OR.C.EQ.-3.OR.C.EQ.' '))
     *	GOTO 23142
23144	CONTINUE
	IF(.NOT.(C.EQ.'#')) GOTO 23147
	CALL PUTBAK(C)
23147	CONTINUE
	GOTO 23141
23140	CONTINUE
	IF(.NOT.(T.EQ.'(')) GOTO 23149
	IF(.NOT.(T.EQ.',')) GOTO 23151
	CALL ERROR('12-MISSING COMMA IN DEFINE.')
23151	CONTINUE
	NLPAR = 0
	I = 1
23153	IF(.NOT.(NLPAR.EQ.0)) GOTO 23155
	IF(.NOT.(I.GT.DEFSIZ)) GOTO 23156
	CALL ERROR('11-DEFINITION TOO LONG.')
	GOTO 23157
23156	CONTINUE
	IF(.NOT.(NGETCH(DEFN(I),FD).EQ.-3)) GOTO 23158
	CALL ERROR('13-MISSING RIGHT PAREN IN DEFINE.')
	GOTO 23159
23158	CONTINUE
	IF(.NOT.(DEFN(I).EQ.'(')) GOTO 23160
	NLPAR = NLPAR+1
	GOTO 23161
23160	CONTINUE
	IF(.NOT.(DEFN(I).EQ.')')) GOTO 23162
	NLPAR = NLPAR-1
23162	CONTINUE
23161	CONTINUE
23159	CONTINUE
23157	CONTINUE
23154	I = I+1
	GOTO 23153
23155	CONTINUE
	GOTO 23150
23149	CONTINUE
	CALL ERROR('14-UNEXPECTED TOKEN IN DEFINE.')
23150	CONTINUE
23141	CONTINUE
	DEFN(I-1) = -2
	RETURN
	END

	SUBROUTINE INITKW
	IMPLICIT BYTE (A-Z)
	BYTE DEFNAM(7),DEFTYP(2)
C
C	COMMON BLOCKS
C
	INTEGER AVAIL,TABLE(2000),TABPTR(26)
	COMMON /CLOOK/AVAIL,TABLE,TABPTR
C
	DATA DEFNAM/'D','E','F','I','N','E',-2/
	DATA DEFTYP/-10,-2/
C
	AVAIL = 1
	DO 23239 I=1,26
	TABPTR(I) = 0
23239	CONTINUE
23240	CONTINUE
	CALL INSTAL(DEFNAM,DEFTYP)
	RETURN
	END

	SUBROUTINE INSTAL(NAME,DEFN)
	IMPLICIT BYTE (A-Z)
	INTEGER LENGTH,DLEN,NLEN,C
	BYTE NAME(1),DEFN(1)
C
C	COMMON BLOCKS
C
	INTEGER AVAIL,TABLE(2000),TABPTR(26)
	COMMON /CLOOK/AVAIL,TABLE,TABPTR
C
	NLEN = LENGTH(NAME)+1
	DLEN = LENGTH(DEFN)+1
	IF(.NOT.(AVAIL+NLEN+DLEN.GT.6500)) GOTO 23241
	CALL PUTLIN(NAME,3)
	CALL ERROR('20-TOO MANY DEFINITIONS.')
	RETURN
23241	CONTINUE
	IF(.NOT.(NAME(1).LT.'A'.OR.NAME(1).GT.'Z')) GOTO 23243
	RETURN
23243	CONTINUE
	C = NAME(1)-'A'+1
	IF(.NOT.(TABPTR(C).NE.0)) GOTO 23245
	C = TABPTR(C)
23247	IF(.NOT.(TABLE(C).NE.-4)) GOTO 23248
	C = TABLE(C)
	GOTO 23247
23248	CONTINUE
	TABLE(C) = AVAIL
	GOTO 23246
23245	CONTINUE
	TABPTR(C) = AVAIL
23246	CONTINUE
	TABLE(AVAIL) = -4
	CALL SCOPY(NAME,1,TABLE,AVAIL+1)
	TABLE(AVAIL+NLEN) = -2
	AVAIL = AVAIL+NLEN+DLEN+1
	RETURN
	END

	LOGICAL FUNCTION LOOKUP(NAME,DEFN)
	IMPLICIT BYTE (A-Z)
	INTEGER C,I
	BYTE NAME(80),DEFN(80)
C
	INTEGER AVAIL,TABLE(2000),TABPTR(26)
	COMMON /CLOOK/AVAIL,TABLE,TABPTR
C
	IF(.NOT.(NAME(1).LT.'A'.OR.NAME(1).GT.'Z')) GOTO 23286
	LOOKUP = 0
	RETURN
23286	CONTINUE
	C = NAME(1)-'A'+1
	IF(.NOT.(TABPTR(C).EQ.0)) GOTO 23288
	LOOKUP = 0
	RETURN
23288	CONTINUE
	C = TABPTR(C)
23290	CONTINUE
	I = C+1
	K = 1
23293	IF(.NOT.(NAME(K).NE.-2)) GOTO 23295
	IF(.NOT.(TABLE(I).NE.NAME(K)) GOTO 23296
	IF(.NOT.(TABLE(C).EQ.-4)) GOTO 23298
	LOOKUP = 0
	RETURN
23298	CONTINUE
	C = TABLE(C)
	GOTO 23291
23296	CONTINUE
	I = I+1
23294	K = K+1
	GOTO 23293
23295	CONTINUE
	IF(.NOT.(TABLE(I).EQ.-2)) GOTO 23300
C
	I = I+1
	K = 1
  222	IF(.NOT.(TABLE(I).NE.-2)) GOTO 333
	DEFN(K) = TABLE(I)
	K = K+1
	I = I+1
	GOTO 222
  333	DEFN(K) = -2
C
	LOOKUP = X'FF'
	RETURN
23300	CONTINUE
	LOOKUP = 0
	RETURN
23291	GOTO 23290
23292	CONTINUE
	END