/SUBROUTINE PACK(ITEXT,INEXT,SIX,NC,TERM)
/Version 01.26

/Routine to convert data packed in 8-bit RDLIN/WRLIN format into
/FORTRAN format 6-bit packed ascii. Argument definitions:

/	ITEXT:	Array containing input 8-bit string
/	INEXT:	Pointer into ITEXT
/	SIX:	Output FORTRAN format 6-bit array
/	NC:	Max. number of characters to pack up
/	TERM:	Array of acceptable terminator characters

/Notes: According to FORTRAN convention, SIX will be padded with
/spaces to an even word boundary, even if termination occurs in
/the middle of a word. (I.e., a multiple of 6 characters will be
/packed into SIX before exit.)

/The format of TERM is as follows:

/	TERM(1): Number of terminator characters in ARRAY
/	TERM(2): Hole to recieve actual character which terminated
/	TERM(3)-TERM(N): Terminator characters, as specified by TERM(1)

/The ABS of the values in the terminator array are used in the
/comparison. If the element is negative, then the terminating
/character is passed to the SIX array.

/This routine uses the global IPTR to address arrays. IPTR is
/left pointing to the next character in the array on exit.
/The use of INEXT follows standard convention as follows:

/	INEXT +: On entry, IPTR=INEXT, On exit INEXT=IPTR
/	INEXT 0: Ues old IPTR, don't change INEXT on exit
/	INEXT -: On entry, IPTR=ABS(INEXT), don't change INEXT

	COMMON	STRFUN
IPTR,	ORG	.+0003		/Define global pointer

	EXTERN	PUTWRD
	EXTERN	GETWRD

	SECT	PACK
	JA	#ST
	TEXT	+PACK  +	/Section name

#RET,	SETX	#XR
	SETB	#BASE
	JA	.+3
#BASE,	ORG	.+6		/Base 0&1
TERM,	ORG	.+3		/Base 2
INEXT,	ORG	.+3		/Base 3
NC,	ORG	.+3		/Base 4
NCHAR,	ORG	.+3		/Base 5
OUTPTR, ORG	.+3		/Base 6
NWDS,	ORG	.+3		/Base 7

	ORG	#BASE+30
	FNOP
	JA	#RET
	FNOP
#GOBAK, 0;0

ICHAR,	ORG	.+3
ITEMP,
#XR,	ORG	.+3		/XR 0,1,2 =ITEMP
	1;0;0			/XR3=1, XR4 and 5 for indexing


THREE,	F 3.0
FIVE,	F 5.0
SIX,	F 6.0
THRTY2, F 32.0			/Octal 40
SIXTY4, F 64.0			/Octal 100
NINTY6, F 96.0			/Octal 140
F127,	F 127.0 		/Octal 177
F2080,	F 2080			/Octal 4040

	BASE	#BASE

#ST,	STARTD
	0210			/Load Return JA
	FSTA	#GOBAK,0	/Store it
	0200			/Load ARGS pointer
	SETX	#XR		/Set index
	SETB	#BASE		/And base pags
	LDX	0,1
	FSTA	#BASE		/Store ARGS pointer

	FLDA%	#BASE,1+	/Load pointer to ITEXT
	FSTA	ITX1,0		/In several places
	FLDA%	#BASE,1+
	FSTA	INEXT		/Store pointer to INEXT
	FLDA%	#BASE,1+
	FSTA	PAKD		/Store pointer to six bit array
	FLDA%	#BASE,1+
	FSTA	NC		/Pointer to NC
	FLDA%	#BASE,1+
	FSTA	TERM		/Store pointer to TERM array

	FLDA	JGLEFT,0	/ASSIGN LEFT TO NEXT
	FSTA	NEXT,0

	STARTF

	FLDA%	INEXT		/Get pointer
	JEQ	ARG0		/If zero, use global
	JGT	SETIPT		/If pos, set global
	FNEG			/If neg, make positive
SETIPT, FSTA	IPTR		/Set Global pointer

/Compute number of 12 bit words needed for max characters specified.
/Must be multiple of three for space padding so we compute FORTRAN
/variables required times 3

ARG0,	FLDA%	NC		/NWDS=3*(FIX((NC+5)/6))
	FSTA	NC		/Take opportunity to store locally
	FADD	FIVE
	FDIV	SIX
	ALN 0
	FNORM			/FIX the result
	FMUL	THREE
	FSTA	NWDS		/Store NWDS

	XTA	3		/Load 1 into FAC
	FSTA	NCHAR		/Init. character counter
	FNEG
	FADDM	IPTR		/Back up IPTR before pre-increment
	FCLA
	FSTA	OUTPTR		/Set output pointer

/Start here and purge leading spaces

PURGE,	JSA	UPPER		/Get next character
	FLDA	ICHAR		/Get the character in FAC
	FSUB	THRTY2		/Is it a space code
	JEQ	PURGE		/Yes, ignore it
	JA	LEFT+2		/No, start moving characters

/Here to process Left hand byte

LEFT,	JSA	UPPER		/Get next character

/If we fall out the bottom, we can move the character over.
/We must 6-bitize the character. Characters from 0-77 remain
/unchanged. Characters from 100-137 (we've already folded lower
/case characters) get moved to 0-37. Note that this makes control
/characters into their alphabetic equivalents.

	FLDA	ICHAR		/Load the character again
	FSTA	ITEMP		/Store in ITEMP
	FSUB	SIXTY4		/See if it's 0-77
	JLT	CHROK		/It is, leave it
	FSTA	ITEMP		/If not store fixed character
CHROK,	ADDX	6,0		/ITEMP=ITEMP*64

/Now test the character. Remember, it's already set up in ITEMP
/in case we terminate.

	JSA	TEST		/Test the characters
	JA	TERML		/Match! terminate
	FLDA	NCHAR		/Load number of characters moved
	FSUB	NC		/See if we reached MAX.
	JEQ	MAXL		/We did, terminate

	XTA	3		/Load 1 into FAC
	FADDM	NCHAR		/Bump NCHAR

/Now, process the Right hand byte.

	JSA	UPPER		/Get next character into ICHAR
	JSA	TEST
	JA	TERMR		/Match!

	FLDA	ICHAR		/Load the lower byte character
	FSUB	SIXTY4		/Test for 6-bit ness
	JGE	FACOK		/If 100-137, FAC=corrected character

	FLDA	ICHAR		/Load Right hand byte
FACOK,	FADDM	ITEMP		/Add to upper byte

	FLDA	NCHAR		/Is number of characters at MAX
	FSUB	NC
	JEQ	MAXR		/Yes, terminate

	XTA	3		/No, then bump NCHAR
	FADDM	NCHAR

/Here to install two bytes into the output array.

MOVE6,	XTA	3		/Add one
	FADDM	OUTPTR		/to output word pointer

	JSR	PUTWRD		/Call PUTWRD to store the byte pair
	JA	.+0010
PAKD,	JA	.		/Address of PAKD array in here
	JA	OUTPTR		/Address of pointer
	JA	ITEMP		/2 bytes just input

/Next either points to LEFT before termination. After termination,
/it either points to SPSP, where it sets the double space into ITEMP,
/or to MOVE6, which will fill up PAKD with spaces.

	FLDA	NWDS		/Have we reached NWDS yet
	FSUB	OUTPTR
NEXT,	JGT	NEXT		/No, call NEXT

/Loop here to find a terminator character. We purge the input
/array until we find a valid terminator. This gets rid of
/unwanted extra characters

XIT,	JSA	TEST		/Test last character
	JA	GTERM		/Match

	JSA	GETCHR		/Get next one
	FSTA	ICHAR		/Store it
	JA	XIT		/And loop back

GTERM,	LDX	1,5		/Point to TERM(2)
	FLDA	ICHAR		/Load the terminating character
	FSTA%	TERM,5		/Store it for the user

	XTA	3		/Load the one we subtracted before
	FADDM	IPTR		/to correct IPTR for pre-increment

	FLDA%	INEXT		/Load INEXT now
	JLE	#GOBAK		/If negative, just return
	FLDA	IPTR		/Otherwise, return INEXT=IPTR
	FSTA%	INEXT		/Store it
	JA	#GOBAK		/And return

/Here on a terminator when expecting a LEFT hand byte. TEST will have
/left XR 5 pointing to the terminator character in TERM. If this
/character is negative, we act as though a MAX count terminated,
/which will move the character over. Otherwise, just set routine
/up to return double spaces forever, letting NWDS cause exit.

TERML,	FLDA%	TERM,5		/Load terminating character from TERM
	JLT	MAXL		/If negative, leave character there

/Here to pack up spaces to end of NWDS words

SPSP,	FLDA	F2080		/Load "  "
	FSTA	ITEMP		/Set into ITEMP

/Re-direct NEXT so MOVE6 recursively calls itself with "  " in ITEMP

	STARTD
	FLDA	JGMOV6,0	/Assign MOVE6 TO NEXT
SETNXT, FSTA	NEXT,0		/Store the address
	STARTF			/Reset F mode
	JA	MOVE6		/Call MOVE6 now

/Here on terminator character when expecting Right hand byte.
/Test leaves XR5 pointing to TERM char in TERM

TERMR,	FLDA%	TERM,5		/Load term. character from TERM
	JGE	MAXL		/If positive, continue
	FNEG			/Make it positive
	JA	TMNEG		/Go stick it on upper byte

/Here when MAX characters terminated when expecting LEFT byte.
/As long as theres room in PAKD, we'll move the last characer.
/ITEMP already contains 64*CHAR, just add a space here.
/We set up NEXT to goto SPSP after this word is transferred.

MAXL,	FLDA	THRTY2		/Load a space code
TMNEG,	FADDM	ITEMP		/Add to upper byte

/Here when MAX number of characters exceeded when expecting Right
/hand byte.

MAXR,	STARTD
	FLDA	JGSPSP,0	/ASSIGN SPSP TO NEXT
	JA	SETNXT		/Go store it

/Here for a few misc. routines.

/Get a character from ITEXT. We pre-increment the pointer.
/Remember to correct it before exiting "PACK". The character is
/returned in the FAC

GETCHR, 0;0
	XTA	3		/Load 1 into FAC
	FADDM	IPTR		/Pre-increment the pointer

	JSR	GETWRD
	JA	GETCHR
ITX1,	JA	.		/Address of ITEXT in here
	JA	IPTR		/Pointer arg.
	JA	F127		/AND arg

/Here to get a folded character from ITEXT.

UPPER,	0;0
	JSA	GETCHR		/Get next character
	FSTA	ICHAR		/Store it
	FSUB	NINTY6		/See if lower case
	JLT	UPPER		/Return if not
	FADD	SIXTY4		/Or fold it up
	FSTA	ICHAR		/Store the result
	JA	UPPER

/Subroutine to test TERM array for a match.
/RETURN+0 if match
/RETURN+2 if not

/TERM indexing assumse that there is no MAGIC number correction.
/Thus, TERM(1) uses INDEX=0, etc. Note that TERM(1) can thus be
/addressed without indexing.

TEST,	0;0
	LDX	1,5		/Set XR5 for TERM(2)
	FLDA%	TERM,0		/Load count of elements
	FNEG			/Negate and set counter
	ATX	4		/into XR 4

TLOOP,	FLDA%	TERM,5+ 	/Get TERM(3) through TERM(N)
	JGE	.+3		/Take ABS
	FNEG
	FSUB	ICHAR		/Compare the input character
	JEQ	TEST		/Take RETURN+0 if match
	JXN	TLOOP,4+	/Or loop on all elements

	STARTD			/Set address mode
	FLDA	TEST,0		/Load return address
	FADD	DTWO		/Add 2
	STARTF			/Reset F mode
	JAC			/And return

JGSPSP, JGT	SPSP
JGLEFT, JGT	LEFT
JGMOV6, JGT	MOVE6
DTWO,	0;2			/D.P. 2 for address arithmetic

