perm filename TXBL.MAC[SIM,SYS] blob sn#460337 filedate 1979-07-20 generic text, type T, neo UTF8
	SUBTTL	TEXT HANDLING

	SEARCH	SIMMAC,SIMMCR,SIMRPA
	
	SALL
	RTITLE	TXBL
	SUBTTL	Text procedures for Blanks, Strip, Sub, T1 := T2
	ERRMAC	TX
	MACINIT
	TWOSEG
	RELOC	400K


COMMENT ;
AUTHOR:		ELISABETH $LUND
VERSION:	1
PURPOSE:	Contains those text handling routines used by OCIN and IONF
CONTENTS:
;


	INTERN	.TXBL	;BLANKS
	INTERN	.TXST	;STRIP
	INTERN	.TXSU	;SUB
	INTERN	.TXVA	;Text value assignment T1:=T2

	QTXW=30
	QTXE=1

	EXTERN	.CSRA	;RESTORE ACCUMULATORS
	EXTERN	.CSSA.	;SAVE ACCUMULATORS
	EXTERN	.SAAR	;ALLOCATE RECORD
	SUBTTL	MACROS AND OPDEFS

DEFINE	RESULT	<
	SKIPE	XSAC,YCSZAC(XLOW)
	EXEC	.CSRA
	CENABLE
	RETURN
>
DEFINE	INIT2	<EXCH	XWAC1,(XTAC)
		EXCH	XWAC2,1(XTAC)
>
DEFINE	EXIT2	<EXCH	XWAC2,1(XTAC)
		EXCH	XWAC1,(XTAC)
		RETURN
>
DEFINE	INIT3	<EXCH	XWAC1,(XTAC)
		EXCH	XWAC2,1(XTAC)
		EXCH	XWAC3,2(XTAC)
>
DEFINE	EXIT3	<EXCH	XWAC3,2(XTAC)
		EXCH	XWAC2,1(XTAC)
		EXCH	XWAC1,(XTAC)
		RETURN
>
DEFINE	INIT4	<IF	CAIN	XTAC,XWAC1
			GOTO	FALSE
		THEN	EXCH	XWAC1,(XTAC)
			EXCH	XWAC2,1(XTAC)
			EXCH	XWAC3,2(XTAC)
			EXCH	XWAC4,3(XTAC)
		FI
>
DEFINE	EXIT4	<IF	CAIN	XTAC,XWAC1
			GOTO	FALSE
		THEN	EXCH	XWAC4,3(XTAC)
			EXCH	XWAC3,2(XTAC)
			EXCH	XWAC2,1(XTAC)
			EXCH	XWAC1,0(XTAC)
		FI
		RETURN
>
	SUBTTL	TXBL


COMMENT ;
PURPOSE:		IMPLEMENT STANDARD TEXT PROCEDURE BLANKS
ENTRY:			.TXBL
INPUT ARGUMENTS:	REG Xtop CONTAINING LENGTH OF TEXT
NORMAL EXIT:		RETURN
ERROR EXIT:		-
CALL FORMAT:		EXEC .TXBL
;


.TXBL:	PROC
	LOWADR
	CDEFER		;Defer ↑C-REENTER
	IF	;Any intermediate results
		SKIPN	XSAC,@(XPDP)
		GOTO	FALSE
	THEN	;Save them, put text length in XWAC1
		HLRZ	XTAC,XSAC
		STACK	XWAC1(XTAC)
		EXEC	.CSSA.
		UNSTK	XWAC1
	FI
	AOS	(XPDP)
	IF	;Not NOTEXT
		JUMPE	XWAC1,FALSE
	THEN
		WHILE	;Length < 0 or > 2↑18-1 ? [41]
			TLNN	XWAC1,-1	;[41]
			GOTO	FALSE		;[41]
		DO				;[41]
			;[41]:
			TXERC	QDSNIN,15,BLANKS: Parameter out of range
			NEWVALUE XWAC1		;[41]
		OD
		;COMPUTE RECORD LENGTH (WORDS)
		LI	XSAC,5*ZTE%S+5-1
		ADD	XSAC,XWAC1
		IDIVI	XSAC,5
		L	XTAC,XSAC
		HRLI	XTAC,QZTE
		;[41] The following two instructions were
		;moved to precede the .SAAR call:
		L	X0,[ASCII/     /]
		ST	X0,YSANIN(XLOW)	;initiate value for SAAR
		EXEC	.SAAR		;ALLOCATE TEXT RECORD
	IFN QSADEA,<	;UPDATE YSADEA IN DEALLOCATE VER.
		L	X0,YSATOP(XLOW)
		ST	X0,YSADEA(XLOW)
		>

		SF	XWAC1,ZTECLN(XTAC)
	
		;Note: the following code relies on the following text variable
		;format:	XWD	ZTVSP,ZTVZTE
		;		XWD	ZTVLNG,ZTVCP
	
		MOVSI	XWAC2,(XWAC1)	;ZTVLNG=XWAC1, ZTVCP=0 (POS=1)
		LI	XWAC1,(XTAC)	;ZTVSP=0, ZTVZTE=XTAC
	ELSE	;NOTEXT is the answer
		SETZB	XWAC1,XWAC2
	FI

	RESULT
	EPROC
	SUBTTL	TXST


COMMENT ;
PURPOSE:		IMPLEMENT STANDARD FUNCTION STRIP
ENTRY:			.TXST
INPUT ARGUMENTS:	REG XTAC CONTAINING NUMBER OF XTOP
			XTOP CONTAINING TEXT REFERENCE
NORMAL EXIT:		RETURN
ERROR EXIT:		-
OUTPUT ARGUMENTS:	XTOP, XTOP+1
CALL FORMAT:		EXEC	.TXST
;


.TXST:	PROC
	INIT2
	STACK	XWAC3
	STACK	XWAC4
	STACK	XWAC5

	;COMPUTE ADDRESS OF WORD CONTAINING LAST CHARACTER

	LI	X1,ZTE%S(XWAC1)
	LF	XWAC4,ZTVSP(,XWAC1)
	LF	X0,ZTVLNG(,XWAC1)
	JUMPE	X0,L2		;NOTEXT if length=0
	ADD	XWAC4,X0


	;COMPUTE NUMBER OF WORDS IN TEXT

	IDIVI	XWAC4,5
	ADD	X1,XWAC4
	IF
		JUMPE	XWAC5,FALSE
	THEN
		;LAST CHARACTER IN TEXT DOES NOT TERMINATE A FULL WORD
		L	XWAC3,(X1)
		XCT	TXRSH(XWAC5)	;SHIFT OUT IRRELEVANT CHARACTERS
		CAME	XWAC3,YTXBLW(XWAC5)
		GOTO	L1		;ALL WERE NOT BLANK
		;ALL WERE BLANK, ACCOUNT FOR THEM
		SUB	X0,XWAC5
		JUMPLE	X0,L2		;[57] NOTEXT if no more char's
	FI
	LOOP	;CHECK FOR FULL WORDS OF BLANKS
		SUBI	X1,1
		L	XWAC3,(X1)
	AS
		CAME	XWAC3,[ASCII /     /]
		GOTO	FALSE
		SUBI	X0,5
		JUMPG	X0,TRUE
		;All characters are used up, we have NOTEXT
		GOTO	L2
	SA
	LSH	XWAC3,-1

	;LOOK FOR BLANKS IN END OF TEXT AND COUNT THEM

L1():!	SETZ	XWAC4,
	LOOP
		LSHC	XWAC3,-7
	AS
		TLC	XWAC4,(" "B6)
		JUMPN	XWAC4,FALSE
		SOJG	X0,TRUE
	SA
	;LENGTH VALUE, POS=1
	HRLZ	XWAC2,X0
	SKIPN	XWAC2
L2():!	SETZB	XWAC1,XWAC2	;NOTEXT IF LENGTH=0
	;RESTORE REGS

	UNSTK	XWAC5
	UNSTK	XWAC4
	UNSTK	XWAC3
	EXIT2
	EPROC

;SHIFT OUT CHARACTERS THAT DO NOT BELONG TO TEXT
;INDEX BY XWAC5=NUMBER OF CHARACTERS TO KEEP (1-4)

TXRSH==	.-1
	LSH	XWAC3,-<1+4*7>
	LSH	XWAC3,-<1+3*7>
	LSH	XWAC3,-<1+2*7>
	LSH	XWAC3,-<1+1*7>

;PARTIALLY BLANK WORDS - INDEX BY NUMBER OF CHARACTERS TO MATCH

YTXBLW==.-1
	EXP	" ","  ","   ","    "
	SUBTTL	TXSU


COMMENT;
PURPOSE:		IMPLEMENT PROCEDURE SUB(P,N)
ENTRY:			.TXSU
INPUT ARGUMENTS:	XTAC	CONTAINING NUMBER OF XTOP
			[64] Left half = -1 if no error message is wanted.
			Returns NOTEXT on errors if so.
			XTOP-XTOP+1 TEXT REFERENCE
			XTOP+2  P
			XTOP+3  N
NORMAL EXIT:		RETURN
ERROR EXIT:		-
OUTPUT ARGUMENTS:	XTOP AND XTOP+1 CONTAINING NEW TEXT REFERENCE
CALL FORMAT:		EXEC .TXSU
;
.TXSU:	PROC
	INIT4
	;[41]:
	WHILE	;length negative
		JUMPGE	XWAC4,FALSE
	DO	;run-time error
		JUMPL	XTAC,L8	;[64]
		TXERC	QDSNIN,7,SUB: 2nd parameter out of range
		NEWVALUE	XWAC4
	OD
	;End of [41]
	IF	;length=0
		JUMPG	XWAC4,FALSE
	THEN	;Return NOTEXT
L8():!		SETZB	XWAC1,XWAC2
		GOTO	L9
	FI
	WHILE			;[41]
		SOJGE	XWAC3,FALSE	;POS-1 LT 0
	DO	;RUNTIME ERROR
		JUMPL	XTAC,L8	;[64]
		;[41]:
		TXERC	QDSNIN,6,SUB: 1st parameter out of range
		NEWVALUE XWAC3		;[41]
	OD

L7():!	;[41]
	;COMPUTE NUMBER OF CHARACTERS IN MAIN TEXT AND SUBTEXT
	LF	X1,ZTVSP(,XWAC1)
	ADD	X1,XWAC3	;NEW STARTING POSITION
	LF	X0,ZTVLNG(,XWAC1)
				;[41]
	;CHECK IF TOO LONG SUBFIELD
	WHILE
		SUBI	X0,(XWAC3)	;[41] remaining characters in main text
		CAML	X0,XWAC4
		GOTO	FALSE
	DO
TXSUER:		JUMPL	XTAC,L8	;[64]
		;[41]:
		LF	X0,ZTVLNG(,XWAC1)
	
		IF
			;position > length
			CAMG	XWAC3,X0
			GOTO	FALSE
		THEN
			TXERC	QDSNIN,6,SUB: 1st parameter out of range
			NEWVALUE	XWAC3
			GOTO	L7
		FI
		TXERC	QDSNIN,7,SUB: 2nd parameter out of range
		NEWVALUE XWAC4		;[41]
	OD
	;CREATE A NEW TEXT REF
	HRLZ	XWAC2,XWAC4		;LENGTH = N, POS=1
	SF	X1,ZTVSP(,XWAC1)	;SP=OLD SP+P-1, ZTE IDENTICAL

	;RESTORE REGS
L9():!
	EXIT4
	EPROC
	SUBTTL	TXVA


COMMENT;
PURPOSE:		TEXT VALUE ASSIGNMENT T1:=T2
ENTRY:			.TXVA
INPUT ARGUMENTS:	XTAC CONTAINING NUMBER OF XTOP
			XTOP-XTOP+1 TEXT VARIABLE T1
			XTOP+2-XTOP+3 TEXT VARIABLE T2
NORMAL EXIT:		RETURN
ERROR EXIT:		-
OUTPUT ARGUMENTS:	XTOP ,XTOP+1
CALL FORMAT:		EXEC	.TXVA
;



.TXVA:	PROC
	INIT4
	STACK	XLOW
	LOWADR
	CDEFER
	LI	(XWAC1)
	IF
		JUMPN	X0,FALSE
	THEN
		;RETURN IF NOTEXT:=NOTEXT
		JUMPE	XWAC3,TXVA1
		JUMPN	XWAC3,TXVAE
	FI
	IF	;TEXT OBJECT NOT IN THE POOL
		CAMGE	YSABOT(XLOW)
		GOTO	TRUE
		CAMGE	YSATOP(XLOW)
		GOTO	FALSE
	THEN	RTSERR	104
	FI
	STACK	XTAC
	STACK	XWAC5
	STACK	XWAC6
	STACK	XWAC7
	;COMPUTE LENGTH OF TEXT
	LF	XWAC5,ZTVLNG(,XWAC1)
	LF	XWAC6,ZTVLNG(,XWAC3)
	IF
		SUB	XWAC5,XWAC6
		JUMPGE	XWAC5,FALSE
	THEN
TXVAE:
		;RIGHT HAND TEXT TOO LONG
		;RUNTIME ERROR
		;[41]:
		TXERC	QDSCON,10,Text assignment: r.h.s. text too long
		LI	XWAC5,0		;[41]
		LF	XWAC6,ZTVLNG(,XWAC1);Truncate when user proceeds [41]
	FI
	;COMPUTE BYTE POINTER TO FIRST BYTE IN T2
	LI	X2,ZTE%S(XWAC3)	;FIRST WORD OF T2.MAIN
	LF	,ZTVSP(,XWAC3)
	IDIVI	X0,5
	ADD	X2,TXBY(X1)
	ADD	X2,X0
	;COMPUTE BYTEPOINTER TO FIRST BYTE IN T1
	LF	X0,ZTVSP(,XWAC1)
	IDIVI	X0,5
	L	X1,TXBY(X1)
	ADDI	ZTE%S(XWAC1)
	ADD	X1,X0
	;MOVE TEXT TO T1 FROM T2
	;CHECK IF MORE THAN ONE WORD TO MOVE AND
	;IF TEXTS START AT A FULLWORD BOUNDARY
	IF
		CAIGE	XWAC6,5
		GOTO	FALSE
		TLNE	X1,320000
		GOTO	FALSE
		TLNE	X2,320000
		GOTO	FALSE
	THEN
		;SPEC CASE, BOTH TEXTS AT FULLWORD BOUNDARY
		IDIVI	XWAC6,5
		EXCH	XWAC6,XWAC7
		IF
			CAIGE	XWAC7,3
			GOTO	FALSE
		THEN
			;3 WORDS OR MORE
			HRL	X0,X2
			HRR	X0,X1
			ADD	X2,XWAC7
			ADD	X1,XWAC7
			BLT	X0,-1(X1)
		ELSE
			LOOP
				L	X0,(X2)
				ST	X0,(X1)
				ADDI	X1,1
				ADDI	X2,1
			AS
				SOJG	XWAC7,TRUE
			SA
		FI
	FI
	IF	;ANYTHING TO MOVE
		SOJL	XWAC6,FALSE
	THEN
		LOOP
			ILDB	X2
			IDPB	X1
		AS
			SOJGE	XWAC6,TRUE
		SA
	FI
	IF	;LEFT HAND TEXT IS LONGER
		SOJL	XWAC5,FALSE
	THEN	;PAD WITH BLANKS
		LI	" "
		LOOP
			IDPB	X1
		AS
			SOJGE	XWAC5,TRUE
		SA
	FI
	;RESTORE REGS
TXVA2:
	UNSTK	XWAC7
	UNSTK	XWAC6
	UNSTK	XWAC5
	UNSTK	XTAC
TXVA1:
	CENABLE
	UNSTK	XLOW
	EXIT4
	EPROC
	SUBTTL	TABLES

TXBY:		;LEFT HAND OF BYTE POINTER  BYTE SIZE=7
	XWD	440700,0
	XWD	350700,0
	XWD	260700,0
	XWD	170700,0
	XWD	100700,0
	XWD	010700,0
	LIT
	END