SUBROUTINE CMPSTR

C	INCLUDE "FLX:FLXINC.FLX"
$NOLIST
	INCLUDE "FLX:FLXINC.FLX"
$LIST

C
C	***********************************************************
C
C	TO COMPILE-STRING
C
C	***********************************************************
C KL Danneil	16-Feb-83	RT11
C Using INTEGER*2 arrays for strings is very painful in RT11. Especially since
C the first 2 bytes are used by Flecs to store the present length of the
C string. This makes it difficult to use RT11 string library functions and
C acutally provides very little advantage. If the maximum length of the string
C was also stored someplace, then a real advantage could be realised by
C having the string handling subroutines check for legal bounds (ie. force
C truncation at string full with error code return). At present, Flecs doesn't
C provide any error checking on strings and very little error checking on many
C other functions.
C Another diffivulty is that Flecs often doesn't use its own string handling
C subroutines when checking the present length of a string. So any control
C we might add is likely to fail.
C Never the less, we will attempt to do the following--
C	Use BYTE arrays. Use the 1st byte as the present length of the string.
C	Use the 2nd byte as the maximum length in bytes the string can be.
C	Universally use SLEN to obtain present string length.
C	Use SMAXLN (new subroutine) to obtain size of string allowed.
C	Change all the RT11 string library routines to support bounds checking.
C To use the 2nd byte requires changes to CMPSTR to initialize all STRING's
C with DATA statements.
C
	String	SBYTE '      BYTE '
	String	SSTARO '*0'
	String	SZERO '0'
C
D	type *,'Compile-String'
D	type 3,CURSOR,(SFLX(II),II=2,(Slen(SFLX)+3)/2)	!still word aligned
D	type 4
D3	FORMAT ('$',1I3,' *',132A2)
D4	FORMAT ('+','*')
C end KLD
C
	STRTYP = TERROR
	REPEAT WHILE (STRTYP.NE.TERROR .AND. CH.EQ.CHCOMA)
D	type *,'CMPSTR1- STRTYP=',STRTYP
	IF (STRTYP.NE.TERROR)
	STRTYP = TERROR
	GET-CHARACTER
	FIN
	WHILE (CHTYPE.EQ.TBLANK) GET-CHARACTER
	IF (CHTYPE.EQ.TLETTR)
	START = CURSOR
	WHILE (CHTYPE.LE.TDIGIT) GET-CHARACTER
	LEN = CURSOR - START
	CALL CPYSUB (SVARBL,SFLX,START,LEN)
	WHILE (CHTYPE.EQ.TBLANK) GET-CHARACTER
D	type *,'CMPSTR2-'
	CONDITIONAL
	(CHTYPE.EQ.TLP)
	STRLEN = 0
	GET-CHARACTER
	WHILE (CH.EQ.CHSPAC) GET-CHARACTER
	WHILE (CHTYPE.EQ.TDIGIT)
	STRLEN = STRLEN*10 + (CH-CHZERO)
	GET-CHARACTER
	FIN
C
C	*********************************************************
C
Ckld	STRLEN = STRLEN + 1		!EXTRA SPACE FOR NULL TERM.
C
C	*********************************************************
C
	WHILE (CH.EQ.CHSPAC) GET-CHARACTER
	IF (CHTYPE.EQ.TRP .AND. STRLEN.GT.0)
	GET-CHARACTER
	STRTYP = TVARBL
D	type *,'STRTYP=TVARBL'
	FIN
	FIN
	(CH.EQ.CHQUOT)
	STRLEN = 0		!kld
	GET-CHARACTER
	START = CURSOR
	UNTIL (CH.EQ.CHQUOT .OR. CHTYPE.EQ.TEOL)  GET-CHARACTER
	IF (CH.EQ.CHQUOT)
	LEN = CURSOR - START
	CALL CPYSUB (SSTRNG,SFLX,START,LEN)
	STRTYP = TCONST
	GET-CHARACTER
	WHILE (CH.EQ.CHQUOT)
	START = CURSOR
	STRTYP = TERROR
	GET-CHARACTER
	UNTIL (CH.EQ.CHQUOT .OR. CHTYPE.EQ.TEOL)  GET-CHARACTER
	IF (CH.EQ.CHQUOT)
	LEN = CURSOR - START
	CALL CATSUB (SSTRNG,SFLX,START,LEN)
Ckld???	STRLEN = Slen(SSTRNG)		!kld
	STRTYP = TCONST
	GET-CHARACTER
	FIN
	FIN
C
C	*********************************************************
C
Ckld	CALL CATSTR (SSTRNG,SB)	!EXTRA SPACE FOR NULL TERM.
C
C	*********************************************************
C
Ckld	STRLEN = SSTRNG(1)
	STRLEN = Slen(SSTRNG)	!kld 22-Feb-83
	FIN
	FIN
	FIN
D	type *,'CMPSTR3- STRTYP,STRLEN=',STRTYP,STRLEN
	IF (STRTYP.NE.TERROR)
C Form the declairation statement--	BYTE variable-name(number)	kld
Ckld	CALL CPYSTR (SST,SINT)
	CALL CPYSTR(SST,SBYTE)		!kld
	CALL CATSTR (SST,SVARBL)
	CALL CATSTR (SST,SLP)
Ckld	WHEN (STRLEN.GT.0)  NUMBER = ((STRLEN-1)/OCHPWD + 1) + 1	!RT11
	WHEN (STRLEN.GT.0)  NUMBER = (STRLEN+3+1)/2		!kld
	ELSE		    NUMBER = 2	!kld
Ckld	ELSE		    NUMBER = 1
	NUMBER = NUMBER * 2		!kld
	CONVERT-NUMBER-TO-STRING
	CALL CATSTR (SST,SNUMBR)
	CALL CATSTR (SST,SRP)
	PUT-STATEMENT
Ckld	IF (STRTYP.EQ.TCONST)
C Form the DATA statement--	DATA variable-name/		kld
D	type *,'CMPSTR4- Form DATA'
	CALL CPYSTR (SST,SDATA)
	CALL CATSTR (SST,SVARBL)
	CALL CATSTR (SST,SLASH)
C
C	*********************************************************
C
C	 REDUCE STRLEN SO FLECS LENGTH OF STRING DOES NOT INCLUDE
C	 EXTRA SPACE FOR NULL TERMINATION
C
	NUMBER = STRLEN
Ckld	NUMBER = STRLEN - 1
C
C	*********************************************************
C
	CONVERT-NUMBER-TO-STRING
Ckld	CALL CATSTR (SST,SNUMBR)
	WHEN (STRTYP .EQ. TCONST) CALL CATSTR (SST,SNUMBR)	!kld
	ELSE	CALL CATSTR (SST,SZERO)	!kld
	CALL CATSTR(SST,SCOMMA)		!kld
	CALL CATSTR(SST,SNUMBR)		!kld
	IF (STRTYP .EQ. TCONST)		!kld
D	type *,'CMPSTR5- TCONST'
Ckld	LEN = SSTRNG(1)
	LEN = STRLEN			!kld
	START = 1
	NUMBER = 1			!kld
	CONVERT-NUMBER-TO-STRING
	WHILE (LEN.GT.0)
	CALL CATSTR (SST,SCOMMA)
Ckld	WHEN (LEN.GE.OCHPWD) NUMBER = OCHPWD
Ckld	ELSE		     NUMBER = LEN
Ckld	NUMBER = 1			!kld
Ckld	CONVERT-NUMBER-TO-STRING
	CALL CATSTR (SST,SNUMBR)
	CALL CATSTR (SST,SH)
	CALL CATSUB (SST,SSTRNG,START,NUMBER)
	LEN = LEN - NUMBER
	START = START + NUMBER
	FIN
	Fin				!kld
	IF (STRTYP .EQ. TVARBL)		!kld
C Fill in-- 0,Max-length,(Number-2)*0	Include RT11 termination 0('s)	!kld
D	type *,'CMPSTR6- TVARBL'
	CALL CATSTR(SST,SCOMMA)		!kld
	NUMBER= STRLEN			!kld
	CONVERT-NUMBER-TO-STRING	!kld
	CALL CATSTR(SST,SNUMBR)		!kld
	CALL CATSTR(SST,SSTARO)		!kld
	Fin				!kld
C Wether Variable or Constant type- End with termination then /		!kld
C Fill in RT11 termination 0('s)	!kld
	NUMBER = 1 + MOD(STRLEN+1,2)	!If STRLEN is Odd 2 0's, Even=> 1 !kld
	CONVERT-NUMBER-TO-STRING	!kld
	CALL CATSTR(SST,SCOMMA)		!kld
	CALL CATSTR(SST,SNUMBR)		!kld
	CALL CATSTR(SST,SSTARO)		!kld
C End with /				!kld
	CALL CATSTR (SST,SLASH)
	PUT-STATEMENT
Ckld	FIN
	FIN
	FIN
	WHILE (CHTYPE.EQ.TBLANK)  GET-CHARACTER
	FIN
	WHEN (STRTYP.NE.TERROR)  SCAN-GARBAGE
	ELSE
	ESTOP = ESTOP + 1
	ESTACK(ESTOP) = 8
	SAVE-ORIGINAL-STATEMENT
	FIN
	RETURN

	TO CONVERT-NUMBER-TO-STRING
	SNUMBR(1) = 0
	CALL Slenpt(0,SNUMBR)		!kld
	POWER = 10000
D	type *,'NUMBER=',NUMBER
	DO (I = 1, 4)
	POWER = POWER / 10
	DIGIT = MOD(NUMBER/POWER,10)
Ckld	UNLESS (DIGIT.EQ.0 .AND. SNUMBR(1).EQ.0 .AND. I.NE.4)
	UNLESS ((DIGIT.EQ.0).AND.(Slen(SNUMBR).EQ.0).AND.(I.NE.4)) !kld
	SDIGIT(1) = 1
	DIGIT = CHZERO + DIGIT
cD	type 5,DIGIT
cD5	FORMAT (' ',' DIGIT=',1A2)
	CALL PUTCH (SDIGIT(2),1,DIGIT)	!	still word aligned	kld
Ckld	CALL CHPUT (DIGIT,SDIGIT,3,2,1)	!kld
	CALL CATSTR (SNUMBR,SDIGIT)
	FIN
	FIN
D	type 7,(SNUMBR(II),II=1,3)	!still word aligned	kld
D7	FORMAT (' ',' SNUMBR=',1I3,' *',2A2)	!kld
	FIN

	TO FORCE-NEXT-NUMBER
	IF (NEXTNO.NE.0)
	CALL PUTNUM(SFORCE,NEXTNO)
	CALL PUT(LINENO,SFORCE,FORTCL)
	NEXTNO=0
	FIN
	FIN

	TO GET-CHARACTER
Ckld	CURSOR=CURSOR+1
Ckld	CPOS=CPOS+1
Ckld	CPOS=1				!kld
Ckld	IF (CPOS.GT.NCHPWD)
Ckld	CWD=CWD+1
Ckld	CPOS=1
Ckld	FIN
C	WHEN(CURSOR.GT.SFLX(1))
Ckld	WHEN(CURSOR.GT.Slen(SFLX))	!kld 22-Feb-83
Ckld	CH = -1
	CH = CHNEXT (SFLX,CURSOR,CWD,CPOS)	!kld
CD	type 1,CURSOR,CH		!kld
CD1	FORMAT (' ','CURSOR,GETCH=',1I3,' *',1A1)		!kld
	WHEN (CH .EQ. -1)		!kld
	CHTYPE=TEOL
	FIN
	ELSE
Ckld	CALL GETCH(SFLX(CWD),CPOS,CH)
	CHTYPE=CHTYP(CH)
	FIN
	FIN

	TO PUT-STATEMENT
	UNLESS (NEXTNO.EQ.0)
	WHEN (STNO.EQ.0)
	STNO=NEXTNO
	NEXTNO=0
	FIN
	ELSE FORCE-NEXT-NUMBER
	FIN
	UNLESS (STNO.EQ.0)
	CALL PUTNUM(SST,STNO)
	STNO=0
	FIN
	SSTLEN = Slen(SST)		!kld
D	type 21,(SST(II),II=1,SSTLEN/2+1)	!kld still word alligned
D21	FORMAT ('$','PUT-STATEMENT SST=',1I3,'*',150A2)
D	type 23
D23	FORMAT ('+','*')
Ckld	WHEN (SST(1).LE.72) CALL PUT(LINENO,SST,FORTCL)
	WHEN (SSTLEN.LE.72)		!kld
	CALL PUT(LINENO,SST,FORTCL)	!kld 22-Feb-83
	FIN				!kld
	ELSE
	CALL CPYSUB (SLIST,SST,1,72)
	CALL PUT(LINENO,SLIST,FORTCL)
	S=73
	L=66
Ckld	REPEAT UNTIL (S.GT.SST(1))
	REPEAT UNTIL (S.GT.Slen(SST))	!kld 22-Feb-83
Ckld	IF(S+L-1.GT.SST(1)) L=SST(1)-S+1
	IF(S+L-1.GT.Slen(SST)) L=Slen(SST)-S+1	!kld 22-Feb-83
	CALL CPYSTR(SLIST,SB5I1)
	CALL CATSUB(SLIST,SST,S,L)
D	type 27,(SLIST(II),II=1,Slen(SLIST)/2+1)
D27	FORMAT ('$','PUT-STATEMENT SLIST ''s=',1I3,'*',150A2)
D	type 23
	CALL PUT(LINENO,SLIST,FORTCL)
	S=S+66
	FIN
	FIN
	FIN
	TO SAVE-ORIGINAL-STATEMENT
	UNLESS (SAVED)
	SAVED=.TRUE.
	HOLDNO=LINENO
	CALL CPYSTR(SHOLD,SFLX)
	FIN
	FIN
	TO SCAN-GARBAGE
	WHILE (CHTYPE.EQ.TBLANK) GET-CHARACTER
	IF (CH.EQ.CHEXCL)
	WHILE (CHTYPE.NE.TEOL) GET-CHARACTER
	FIN
	IF(CHTYPE.NE.TEOL)
	ESTOP=ESTOP+1
	ESTACK(ESTOP)=2
	SAVE-ORIGINAL-STATEMENT
Ckld	SFLX(1)=CURSOR-1
	CALL Slenpt(CURSOR-1,SFLX)	!kld 22-Feb-83
	FIN
	FIN
	END