Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

COMMENT * SIMULA specification;
OPTIONS(/E:CODE,NOCHECK,packent);
BOOLEAN PROCEDURE pack;

!*;! MACRO-10 code !*;!

	TITLE	pack
	SUBTTL	SIMULA utility, PACK procedure

;!*** Copyright 1975 by the Swedish Defence Research Institute. ***
;!*** Copying is allowed.					***

;!Author:	Stephan Oldgren, ENEA, Sept 1975
;!Modified by:	Lars Enderin, FOA, Jan 1976
;!Version:	3A [150]
;!Purpose:	external procedure to pack data in a
;!		SIMULA program
;!Contents:	PUCCS	convert character from ASCII to SIXBIT
;!		PUPI	pack INTEGER, BOOLEAN and CHARACTER
;!		PUPL	pack LONG REAL
;!		PUPR	pack REAL
;!		PUPT	pack TEXT
;!		PUSPV	store packed variable
;!		MAINPROGRAM procedure control

SEARCH	SIMMAC,SIMMCR,SIMRPA
SALL
MACINIT
ENTRY	PACKENT

;! Offsets in procedure block

result==ZBI%S		;! Function value
PAREA== result+1	;! Parameter (ZFL) for packed area
PBYP==	PAREA+2		;! ZFL for number of bits to bypass in packed area
UAREA==	PBYP+2		;! ZFL for unpacked area (array or variable)
ISIZE==	UAREA+2		;! ZFL for item size (bits)


;! Ac assignments

XIND=	3	;! Offset of current UAREA relative to first UAREA (0,2,4 etc)
XPADR=	4	;! Address (dynamic) of packed area
XPMAX=	5	;! Max offset relative to XPADR or max XPADR value
XPOFF=	6	;! Current bit offset within packed area
XPBYP=	7	;! Number of bits to bypass in current packed word
XUTYP=	XPBYP	;! Type of unpacked area
XUADR=	10	;! Address (dynamic) of unpacked area (UAREA)
XUMAX=	11	;! Max offset or address in UAREA
XUNBY=	XUMAX	;! Number of bytes left in unpacked area
XSIZ=	12	;! Bit size of packed item
XUBYT=	1	;! Number of bytes to skip in unpacked text
XA=	0	;! Work ac
XB=	XUBYT	;! - " -
XC=	2	;! - " -
XD=	XPBYP	;! - " -
XE=	13	;! - " -
XF=	14	;! - " -
XAREA=	16	;! Used to save XUADR, XUMAX in PUUT
XG=	XAREA	;! Work ac, also JSP ac for NEXT and ERROREXIT (simplifies debug)

;! CONSTANTS DEFINITIONS

QWL=	^D36	;!word length
QHWL=	QWL/2	;!half word length
QQWL=	QWL/4	;!quarter word length
QDWL=	QWL*2	;!double word length
QBYA=	7	;!byte length ASCII
QBYS=	6	;!byte length SIXBIT
QNBA=	5	;!number of bytes in one word ASCII

	OPDEF	ERROREXIT	[JSP	XG,NOGOOD]
	OPDEF	NEXT		[JSP	XG,NEXT]
	OPDEF	STOREPACKED	[PUSHJ	XPDP,PUSPV]

;! ERROR MESSAGES
ERPM1::!	ASCIZ/Parameter missing in PACK/

SUBTTL	PUPI
;!Purpose:		pack routine for variable of type integer,boolean
;!			or character
;!			packing is done by deleting the necessary bits to
;!			the right of the sign bit
;!Entry:		PUPI
;!Input arguments:	XPADR	address of block instance of area to
;!				pack data into
;!			XPMAX	max offset of area to pack into
;!			XPOFF	start offset of area to pack into
;!			XUADR	address of area to be packed
;!			XUMAX	max address of area to be packed
;!			XSIZ	size of packed variable
;!Normal exit:		NEXT
;!			XUTYP  contains type of variable
;!Error exit:		ERROREXIT (BRANCH NOGOOD)
;!Output arguments:	XPOFF	(see above) now points at first bit 
;!				after the now packed variable
;!Call format:		EXEC PUPI
;!Used subroutine:	PUSPV

PUPI:	PROC
	;!compute number of bits to be deleted in each element
	LI	XC,QWL
	SUB	XC,XSIZ
	;!construct bit mask with zeroes in place of the packed
	;!variable and ones in the  rest
	SETO	XE,
	LSH	XE,(XC)
	SETCA	XE,XE
	WHILE	;! there are any elements left in the variable
		CAMLE	XUADR,XUMAX
		GOTO	FALSE
	DO
		;!load element and increment address
		L	XA,(XUADR)
		ADDI	XUADR,1
		IF	;! CHARACTER
			CAIE	XUTYP,QCHARACTER
			GOTO	FALSE
		THEN
			LSH	XA,(XC)
		ELSE	;! BOOLEANs or INTEGERs
			;!initialize XB with sign bit from XA
			;!pack the variable to the left part of the word XA
			;!the truncated bits are moved into XB
			SETZ	XB,	;! [211]
			SKIPGE	XA	;! [211]
			SETO	XB,
			ROTC	XA,1(XC)
			MOVN	XC,XC
			ROT	XB,(XC)
			MOVM	XC,XC
			ROTC	XA,-1
			ANDCM	XA,XE
			IF	;! NOT BOOLEAN
				CAIN	XUTYP,QBOOLEAN
				GOTO	FALSE
			THEN	;! ERROR if truncated bits are significant
				JUMPG	XB,NOGOOD
				AOJL	XB,NOGOOD
		FI	FI
		STOREPACKED
		ERROREXIT	;! If something was wrong
	OD
	NEXT
	EPROC

SUBTTL	PUPL
;!Purpose:		pack routine for variable of type long real
;!			packing is done by deleting necessary bits
;!			at the end of each element
;!Entry:		PUPL
;!Input arguments:	XPADR	address of block instance of area to
;!				pack data into
;!			XPMAX	max offset of area to pack into
;!			XPOFF	start offset of area to pack into
;!			XUADR	address of area to be packed
;!			XUMAX	max address of area to be packed
;!			XSIZ	size of packed variable
;!Normal exit:		NEXT
;!Error exit:		ERROREXIT
;!Output arguments:	XPOFF	(see above) now points at first bit 
;!				after the now packed variable
;!Call format:		EXEC PUPL
;!Used subroutine:	PUSPV

PUPL:	PROC
	;!if size of packed field not greater than word length
	;!skip the second word of every element and treat
	;!only the first word
	;!else treat both words
	IF
		CAILE	XSIZ,QWL
		GOTO	FALSE
	THEN
		;!make a bit mask with zeroes in bits corresponding
		;!to the packed variable and ones in the rest
		SETO	XE,
		LI	XF,QWL
		SUB	XF,XSIZ
		LSH	XE,(XF)
		SETCA	XE,XE
		;!while there are remaining elements in the variable
		WHILE
			CAMLE	XUADR,XUMAX
			GOTO	FALSE
		DO
			;!load first word of element and increment address
			L	XA,(XUADR)
			ADDI	XUADR,2
			ANDCM	XA,XE	;!delete necessary bits to the right
			STOREPACKED
			ERROREXIT
		OD
	ELSE
		;!make a bit mask with zeroes in bits corresponding
		;!to the packed variable and ones in the rest
		SETO	XF,
		LI	XE,QWL
		SUB	XE,XSIZ
		LSH	XF,(XE)
		SETZ	XE,
		;! save  XSIZ-word length
		L	XC,XSIZ
		SUBI	XC,QWL
		HRLM	XC,(XPDP)
		;!while there are remaining elements in variable
		WHILE
			CAMLE	XUADR,XUMAX
			GOTO	FALSE
		DO	;!load first word of element
			;!store the whole word in area
			;!to pack data into
			L	XA,(XUADR)
			SETZ	XE,		;!make bit mask
			LI	XSIZ,QWL
			EXEC 	PUSPV
			ERROREXIT
			;!error return if second word of element is
			;!outside the variable
			CAILE	XUADR,1(XUMAX)
			ERROREXIT
			;!load  second word of element and increment address
			IF	;! Special place
				CAIE	XUADR,PBYP+1(XCB)
				GOTO	FALSE
			THEN	;! Take 2nd word from ZFL for UAREA
				LI	XA,UAREA+1(XIND)
				ADDI	XA,(XCB)
				L	XA,@XA
			ELSE	;! take it from next word
				L	XA,1(XUADR)
			FI
			ADDI	XUADR,2
			HLRZ	XSIZ,(XPDP)
			L	XE,XF
			ANDCM	XA,XE	;! Delete bits to the right
			STOREPACKED
			ERROREXIT
		OD
	FI
	NEXT
	EPROC

SUBTTL	PUPR
;!Purpose:		pack routine for variable of type real
;!			packing is done by deleting necessary bits
;!			at the end of each element
;!Entry:		PUPR
;!Input arguments:	XPADR	address of block instance of area to
;!				pack data into
;!			XPMAX	max offset of area to pack into
;!			XPOFF	start offset of area to pack into
;!			XUADR	address of area to be packed
;!			XUMAX	max address of area to be packed
;!			XSIZ	size of packed variable
;!Normal exit:		NEXT
;!Error exit:		ERROREXIT
;!Output arguments:	XPOFF	(see above) now points at first bit 
;!				after the now packed variable
;!Call format:		EXEC PUPR
;!Used subroutine:	PUSPV
;!
PUPR:	PROC
	;!make bit mask with zeroes in the place of
	;!the packed variable and ones in the rest
	SETO	XE,
	LI	XF,QWL
	SUB	XF,XSIZ
	LSH	XE,(XF)
	SETCA	XE,XE

	;!while there are remaining elements in the variable
	WHILE
		CAMLE	XUADR,XUMAX
		GOTO	FALSE
	DO
		;!load variable and increment address
		L	XA,(XUADR)
		ADDI	XUADR,1
		ANDCM	XA,XE	;! Delete bits to the right
		STOREPACKED
		ERROREXIT
	OD
	NEXT
	EPROC

SUBTTL	PUPT
;!Purpose:		pack routine for variable of type text
;!			packing is done by converting each character
;!			to sixbit or by moving the whole character to output
;!Entry:		PUPT
;!Input arguments:	XPADR	address of block instance of area to
;!				pack data into
;!			XPMAX	max offset of area to pack into
;!			XPOFF	start offset of area to pack into
;!			XUADR	address of text specification
;!			XUMAX	max address of text specification
;!			XSIZ	size of packed field
;!Normal exit:		NEXT
;!Error exit:		ERROREXIT
;!Output arguments:	XPOFF	(see above) now points at first bit 
;!				after the now packed variable
;!Call format:		EXEC PUPT
;!Used subroutine:	PUSPV

PUPT:	PROC
	;!make bit mask for SIXBIT or ASCII character
	SETZ	XF,
	SETO	XE,
	IF
		CAIE	XSIZ,6
		GOTO	FALSE
	THEN
		ROTC	XE,-QBYS
	ELSE
		ROTC	XE,-QBYA
	FI
	WHILE
		CAMLE	XUADR,XUMAX
		GOTO	FALSE
	DO
		;!save address
		L	XAREA,XUADR
		HRL	XAREA,XUMAX
		LD	XUADR,(XUADR)
		;!error exit if text specification empty
		JUMPE	XUADR,NOGOOD
		HLRZ	XA,XUADR
		HLLI	XUADR,0
		HLRZ	XUNBY,XUNBY
		;!compute start address
		IDIVI	XA,QNBA
		ADDI	XA,2
		ADD	XUADR,XA
		;!observe that XB=XUBYT now contains number of bytes to be
		;!bypassed before start of text in the word(XUADR)
		;!initiate counter for number of bytes in one word and
		;!byte pointer to text variable
		L	XF,[POINT	QBYA,(XUADR)]
		;!move byte pointer to first byte to be treated
		IF	JUMPLE	XUBYT,FALSE
		THEN
			LOOP	IBP	XF
			AS	SOJG	XUBYT,TRUE
			SA
		FI
		WHILE	;! Bytes remain in text variable
			JUMPLE	XUNBY,FALSE
		DO
			;!load byte with ASCII character
			;!convert to SIXBIT and store in
			;!area to pack data into
			ILDB	XA,XF
			SUBI	XUNBY,1
			IF
				CAIE	XSIZ,6
				GOTO	FALSE
			THEN
				SUBI	XA,40	;! Convert to SIXBIT
				IF	;! In range
					JUMPLE	XA,FALSE
					CAILE	XA,137
					GOTO	FALSE
				THEN	;! Subtract 40 again for lower case
					CAILE	XA,77
					SUBI	XA,40
					ROT	XA,-QBYS ;! Place in 1st byte
				ELSE	;! Convert to SIXBIT space char
					SETZ	XA,
				FI
			ELSE
				ROT	XA,-QBYA
			FI
			STOREPACKED
			ERROREXIT
		OD
		;!reinitialize address to text specification and increment 
		;!it to point at the next text element if any
		HRRI	XUADR,2(XAREA)
		HLR	XUMAX,XAREA
	OD
	NEXT
	EPROC
	LIT

SUBTTL	PUSPV
;!;!
;!Purpose:		store packed variable in area to pack data into
;!Entry:		PUSPV
;!Input arguments:	XPADR	address of block instance of area to
;!				pack data into
;!			XPMAX	max offset of area to pack into
;!			XPOFF	start offset of area to pack into
;!			XSIZE	size of packed variable
;!			XA	packed element left adjusted
;!			XE	bit mask corresponding to packed element
;!				with zeroes in place of packed element
;!				and ones in the rest
;!Normal exit:		SKIP RETURN
;!Error exit:		RETURN with PACK = 0 (false)
;!Output arguments:	XPOFF	(see above) now points at first bit 
;!				after the now packed element
;!Call format:		STOREPACKED (EXEC PUSPV)
;!Used subroutine:	PUSPV

PUSPV:	PROC
	SAVE	<XE,XF,XPBYP>
	N==3	;! Number of words saved
	;!error return if overflow in area to pack data into
	L	XC,XPOFF
	ADD	XC,XSIZ
	CAMLE	XC,XPMAX
	GOTO	L9

	;!make a word offset from the bit offset
	IDIVI	XPOFF,QWL
	;!now XPOFF contains word offset and
	;!XPOFF+1 = XPBYP contains number of bits to be bypassed
	;!compute address to area to pack data into and store it in XPOFF
	ADD	XPOFF,XPADR
	SETZ	XB,
	SETO	XF,
	;!rotate packed variable and bit mask to position
	;!defined by XPBYP
	MOVN	XPBYP,XPBYP
	ROTC	XA,(XPBYP)
	ROTC	XE,(XPBYP)
	MOVM	XPBYP,XPBYP
	;!move corresponding part of packed variable to first word
	;!of area to pack data into
	L	XC,(XPOFF)
	AND	XC,XE
	IOR	XC,XA
	ST	XC,(XPOFF)
	;!increment bit pointer with size of packed variable
	ADD	XPBYP,XSIZ
	IF	;! the whole variable is not yet treated
		CAIGE	XPBYP,QWL
		GOTO	FALSE
	THEN	;! Increment offset
		ADDI	XPOFF,1
		SUBI	XPBYP,QWL
		IF	;! More bits left
			JUMPE	XPBYP,FALSE
		THEN	;! Must pack rest into next word
			L	XC,(XPOFF)
			AND	XC,XF
			IOR	XC,XB
			ST	XC,(XPOFF)
	FI	FI
	AOS	-N(XPDP)	;! Ok, Skip return
L9():!	;!reset offset to bit offset
	SUB	XPOFF,XPADR
	IMULI	XPOFF,QWL
	ADD	XPOFF,XPBYP
	RETURN
	EPROC

SUBTTL	MAINPROGRAM
;!Purpose:		To pack a number of variables defined by a 
;!			SIMULA program into another variable also
;!			defined by the SIMULA program
;!Entry:		PACKENT
;!Used subroutines:	PUPI	pack integer,boolean or character
;!			PUPL	pack long real
;!			PUPR	pack real
;!			PUPT	pack text
;!

PACKENT:;!	Execution starts here for PACK routine
	SETOM	result(XCB)	;! Assume true result as a start
	SETZ	XIND,
	IF	;! ISIZE was not given
		SKIPE	ISIZE(XCB)
		GOTO	FALSE
	THEN	;! Error, not enough parameters
		OUTSTR	ERPM1
		RTSERR	QDSCON,214
		ERROREXIT
	FI
	SETZB	XE,XB

	;!read parameters for area to pack data into and number of bits
	;!to be bypassed at the beginning of that area
	;!ie the first two parameters
	BEGIN
	;!error exit if area to pack data into is a constant or an
	;!expression
	LF	XA,ZFLDTP(XCB,PAREA)
	CAIL	XA,QDTCON
	ERROREXIT
	;!check type of area
	;!error exit if not REAL,LONG REAL,INTEGER,BOOLEAN 
;!**	GETTYPE	XD,PAREA
	LF	XD,ZFLATP(XCB,PAREA)
	CAIG	XD,QBOOLEAN
	CAIN	XD,QCHARACTER
	ERROREXIT
	;!check kind of area,error exit if not ARRAY or SIMPLE
;!**	GETKIND	XE,PAREA
	LF	XE,ZFLAKD(XCB,PAREA)
	IF	;! NOT array
		CAIN	XE,QARRAY
		GOTO	FALSE
	THEN	;! Must be simple variable
		CAIE	XE,QSIMPLE
		ERROREXIT
		;!treat simple variable
		;!load dynamic address and compute max bit offset and bit offset
		;!to first bit in variable
;!**		GETADD	PAREA,<XPADR-XWAC1>
		IF	;! No thunk
			SKIPL	PAREA(XCB)
			GOTO	FALSE
		THEN	;! Get address the easy way
			LF	XPADR,ZFLZBI(XCB,PAREA)
			HRL	XPADR,PAREA+1(XCB)
		ELSE	;! Use PHFA
			LI	XPADR,(XCB)
			HRLI	XPADR,PAREA
			EXEC	PHFA
			XWD	XPADR-XWAC1,[0]
		FI
		HLRZ	XPMAX,XPADR
		CAIN	XD,QLREAL
		ADDI	XPMAX,1
		IMULI	XPMAX,QWL
		ADDI	XPMAX,QWL
		HLRZ	XPOFF,XPADR
		IMULI	XPOFF,QWL
		HLLI	XPADR
	ELSE	;!treat array variables
		;!load dynamic address and compute number of bits in array
;!**		GETAADD	PAREA,3
		IF	;! No thunk
			SKIPL	PAREA(XCB)
			GOTO	FALSE
		THEN	;! Get address the easy way
			LF	XPADR,ZFLZBI(XCB,PAREA)
			ADD	XPADR,PAREA+1(XCB)
			L	XPADR,(XPADR)
		ELSE	;! Use PHFM
			LI	XPADR,(XCB)
			HRLI	XPADR,PAREA
			EXEC	PHFM
			XWD	XPADR-XWAC1,[0]
		FI
		LF	XPMAX,ZARLEN(XPADR)
		IMULI	XPMAX,QWL
		;!compute offset to first element
		LF	XPOFF,ZARSUB(XPADR)
		IMULI	XPOFF,3*QWL
		ADDI	XPOFF,3*QWL
	FI

	;!read parameter for number of bits to be bypassed
	;!at the beginning of area to pack data into
	;!error exit if not simple integer
;!**	GETTYPE	XC,PBYP
	LF	XA,ZFLAKD(XCB,PBYP)
	LF	XC,ZFLATP(XCB,PBYP)
	CAIN	XA,QSIMPLE
	CAIE	XC,QINTEGER
	ERROREXIT
;!**	GETVAL	PBYP,6,<XPADR>
	IF	;! No thunk
		SKIPL	PBYP(XCB)
		GOTO	FALSE
	THEN	;! Simple value access
		LF	XPBYP,ZFLZBI(XCB,PBYP)
		ADD	XPBYP,PBYP+1(XCB)
		L	XPBYP,(XPBYP)
	ELSE	;! Do it the hard way
		LI	XPBYP,(XCB)
		HRLI	XPBYP,PBYP
		EXEC	PHFV
		XWD	XPBYP-XWAC1,[1B<XPADR-XWAC1>]
	FI
	;!error exit if negative value
	JUMPL	XPBYP,NOGOOD
	;!add number of bits to bypass to offset
	ADD	XPOFF,XPBYP
	;!
	;!now the contents of the registers are as follows
	;!	XPADR	block instance of area to pack into
	;!	XPMAX	max bit offset
	;!	XPOFF	bit offset to first bit in area to pack into
	;!
	ENDD

GETNXT:	;!read parameters for area to pack and size of packed variable
	;!ie the next two parameters
	;!XIND contains index to parameter table
	BEGIN
	;!check type of area,
	;!error exit if not REAL,LONG REAL,INTEGER,BOOLEAN,
	;!CHARACTER or TEXT
;!**	GETTYPE	XUTYP,UAREA,XIND
	LI	XUADR,UAREA(XIND)
	ADDI	XUADR,(XCB)
	LF	XUTYP,ZFLATP(XUADR)
	CAILE	XUTYP,QTEXT
	ERROREXIT
	;!check kind of area,error exit if not ARRAY or SIMPLE
;!**	GETKIND	XE,UAREA,XIND
	LF	XE,ZFLAKD(XUADR)
	IF	;! Not array
		CAIN	XE,QARRAY
		GOTO	FALSE
	THEN	;! Must be simple
		CAIE	XE,QSIMPLE
		ERROREXIT
		;!treat simple variable
		;!load value and store it, if necessary, then set XUADR
		;!to point at first word of value
;!**		GETVAL	UAREA(XIND),7,<XPADR>
		IF	;! No thunk
			SKIPL	(XUADR)
			GOTO	FALSE
		THEN	;! Get dynamic address
			HRL	XUADR,1(XUADR)
			HRR	XUADR,(XUADR)
		ELSE	;! Compute value to ac's first
			HRLI	XUADR,UAREA(XIND)
			HRRI	XUADR,(XCB)
			EXEC	PHFV
			XWD	XUADR-XWAC1,[1B<XPADR-XWAC1>]
			IF	;! TEXT
				CAIE	XUTYP,QTEXT
				GOTO	FALSE
			THEN	;! Change ZFL to ZTV
				;! Garbage collector does not care
				LI	XB,UAREA(XIND)
				ADDI	XB,(XCB)
				STD	XUADR,(XB)
				LI	XUADR,(XCB)
				HRLI	XUADR,UAREA(XIND)
			ELSE	;! Save first word in PBYP+1
				ST	XUADR,PBYP+1(XCB)
				IF	;! LONG REAL
					CAIE	XUTYP,QLREAL
					GOTO	FALSE
				THEN	;! Also use 2nd word of this par ZFL
					LI	XB,UAREA(XIND)
					ADDI	XB,(XCB)
					ST	XUADR+1,1(XB)
					LI	XUADR,(XCB)
					HRLI	XUADR,UAREA(XCB)
		FI	FI	FI
		HLRZ	XUMAX,XUADR
		CAIE	XUTYP,QLREAL
		CAIN	XUTYP,QTEXT
		ADDI	XUMAX,1
	ELSE	;!treat array variables
		;!load dynamic address and compute max offset and start offset
;!**	GETAADD	UAREA(XIND),7,<XPADR>
		IF	;! No thunk
			SKIPL	(XUADR)
			GOTO	FALSE
		THEN	;! Simple computation of array address
			LF	XB,ZFLZBI(XUADR)
			ADD	XB,1(XUADR)
			L	XUADR,(XB)
		ELSE	;! Use PHFM
			LI	XUADR,(XCB)
			HRLI	XUADR,UAREA(XIND)
			EXEC	PHFM
			XWD	XUADR-XWAC1,[1B<XPADR-XWAC1>]
		FI
		LF	XUMAX,ZARLEN(XUADR)
		SUBI	XUMAX,1
		LF	XE,ZARSUB(XUADR)
		IMULI	XE,3
		ADDI	XE,3
		HRL	XUADR,XE
	FI

	;!read argument for size of packed variable
	;!error exit if not of type integer and of kind simple or
	;!if size greater than double word length for long real variables or
	;! greater than word length for other variables
;!**	GETTYPE	XE,ISIZE,XIND
	LI	XSIZ,ISIZE(XIND)
	ADDI	XSIZ,(XCB)
	LF	XB,ZFLAKD(XSIZ)
	LF	XE,ZFLATP(XSIZ)
	CAIN	XE,QINTEGER
	CAIE	XB,QSIMPLE
	ERROREXIT
;!**	GETVAL	ISIZE(XIND),11,<XPADR,XUADR>
	IF	;! No thunk
		SKIPL	(XSIZ)
		GOTO	FALSE
	THEN	;! Simple evaluation
		LF	XB,ZFLZBI(XSIZ)
		ADD	XB,1(XSIZ)
		L	XSIZ,(XB)
	ELSE	;! Use PHFV
		LI	XSIZ,(XCB)
		HRLI	XSIZ,ISIZE(XIND)
		EXEC	PHFV
		XWD	XSIZ-XWAC1,[1B<XPADR-XWAC1>+1B<XUADR-XWAC1>]
	FI
	;!error exit if size is as follows:
	;!type of var	greater than		less than
	;!INTEGER	WORD LENGTH		2
	;!REAL	 	- " -			10
	;!CHARACTER	 - " -			7
	;!BOOLEAN	 - " -			1
	;!LONG REAL	DOUBLE WORD LENGTH	10
	;!TEXT		  7			6
	L	XB,SIZTAB-1(XUTYP)
	HLRZ	XB
	CAIL	XSIZ,(XB)
	CAMGE	XSIZ
	ERROREXIT
	;!change dynamic address to real address and max offset to max address
	HLRZ	XE,XUADR
	HLLI	XUADR,
	ADD	XUMAX,XUADR
	ADD	XUADR,XE
	;!now the contents of the ac's are as follows
	;!	XUTYP	type of area to pack
	;!	XUADR	address of first word of area to pack
	;!		or if text, address to first text specification
	;!	XUMAX	max address of area to pack (not if text)
	;!		or if text, max address of text specifications
	;!	XSIZ	size of packed variable
	;!
	ENDD

	;!select correct subroutine for each type of variable
	XCT	ROUTAB-1(XUTYP)
NEXT:	;!Check for more arguments
	ADDI	XIND,2*2	;! Step to next UAREA, ISIZE pair
	LI	XB,(XCB)
	ADDI	XB,(XIND)
	SKIPN	UAREA(XB)
	GOTO	FINISH

	IF	;! There is room for both UAREA and ISIZE parameters
		Q==2*<<^D31/2>*2-4>
		CAILE	XIND,Q
		GOTO	FALSE
	THEN	;! Handle next pair if ISIZE is given
		SKIPE	ISIZE(XB)
		GOTO	GETNXT
	FI

	;! *** ERROR, wrong number of parameters *** ;!

	OUTSTR	ERPM1
	RTSERR	QDSCON,214
NOGOOD:	SETZM	result(XCB)
	GOTO	FINISH
FINISH=CSEP

SIZTAB:	XWD	QWL,2		;! INTEGER
	XWD	QWL,10		;! REAL
	XWD	2*QWL,10	;! LONG REAL
	XWD	QWL,7		;! CHARACTER
	XWD	QWL,1		;! BOOLEAN
	XWD	7,6		;! TEXT

ROUTAB:	BRANCH	PUPI
	BRANCH	PUPR
	BRANCH	PUPL
	BRANCH	PUPI
	BRANCH	PUPI
	BRANCH	PUPT

	LIT
	END;