TITLE	DATA - PPL DATA OPERATIONS (CONSTRUCTION, SELECTION)
	SUBTTL	T.STANDISH/EAT/ 19-NOV-72

	HISEG
	SEARCH	PPL

	SUBTTL	CODE FOR CONSTRUCTOR FUNCTIONS

;WE ENTER HERE FROM THE INTERPRETER WITH THE STACK IN
;   THE FOLLOWING FORM:
;	X1 X2 X3 ... XN F
;   WHERE THE FOLLOWING AC'S HAVE BEEN SETUP
;	L =	FNAPP(N)
;	TOP =	B,,PTR(X1)
;	ARGP =	B,,PTR(X1)
;	S =	N,,PZADR(DDEF)

;THIS CODE MAKES A STRUCTURE OR SEQUENCE, AND RETURNS A CONST LEXEME
;   POINTING TO IT AT THE STACK POSITION POINTED TO BY TOP.

;CFNAM IS AN INTERNAL LOW SEGMENT NAME CONTAINING THE IDT RELADR
;   OF THE NAME OF THE FUNCTION YOU JUST STARTED TO EXECUTE.

DODOP:	MOVE	AC1,(S)		;AC1_PZ WORD OF DDEF
	HLRZ	AC2,AC1		;SWITCH ON DDEF TYPE
	ANDCMI	AC2,(GCBIT+SYSBIT+CPYBIT) ;EXTRACT OFF GC,SYS,CPY BITS
	XCT	DTAB-B.STRUCT(AC2)	;DISPATCH ON DDEF BLOCK TYPE
DTAB:	JRST	CSTRUCT		;STRUCT-GO MAKE STRUCTURE
	EXERR	MSG(IUALT)	;IMPROPER USE OF ALTERNATE NAME
	JRST	CSEQ		;SEQ-GO MAKE POLYADIC SEQUENCE
	JRST	CVSEQ		;VSEQ-GO MAKE VARIADIC SEQUENCE
	SUBTTL	CONSTRUCT A STRUCTURE

	REPEAT 0, <THIS ROUTINE FIRST PROCESSES THE ARGUMENT
	LIST POINTED TO BY ARGP TO SUBSTITUTE VALUES FOR ALL
	LOCAL VARIABLES,NAMES,RELOCS AND SELECTION EXPRESSIONS.
	THIS REDUCES THE ARGLIST TO A LIST OF CONSTANTS. IT THEN
	CHECKS THE TYPES OF THE ELEMENTS IN THE ARGLIST TO
	SEE IF THEY ARE APPROPRIATE FOR USE IN THE GIVEN
	CONSTRUCTION, USING INFORMATION ABOUT COMPONENT TYPES
	EXTRACTED FROM THE DDEF BLOCK. ADDITIONALLY, IN THE CASE OF
	POLYADIC SEQUENCES AND STRUCTURES IT CHECKS TO SEE THAT
	THE LENGTH OF THE ARGLIST IS PROPER.  IF THESE CHECKS
	SUCCEED, IT COPIES THE CONSTANTS IN THE ARGUMENT LIST
	AND CONSTRUCTS AN OBJECT OF THE APPROPRIATE
	SIZE AND COMPOSITION.>

;CODE TO MAKE A STRUCTURE. S=STE FOR DDEF

CSTRUCT:SAVE	<AC3,L>
	SAVE	<S>		;SAVE S ACROSS ARGLSB
	PUSHJ	P,ARGLSB	;COERCE ARGLIST TO CONSTANTS
	  EXERR	  MSG(IPCON)	;IMPROPER PARAMETER TO CONSTRUCTOR
	MOVE	S,(P)		;REFRESH S
	PUSHJ	P,TYPCHK	;CHECK TYPES OF ARGUMENTS
	RESTOR	<S>		;RESTORE S
	HRRZ	AC1,(S)		;CHECK NUMBER OF ARGS AGAINST
	HLRZ	AC1,(AC1)	;LENGTH OF STRUCTURE
	SUBI	AC1,1		;AC1=#COMPONENTS OF STRUCTURE
	HLRZ	R,S		;GET NUMBER OF ARGS
	CAIE	R,(AC1)		;CORRECT NUMBER TO MAKE STRUCTURE?
WNARGC:	EXERR	MSG(WNARC)	;WRONG NUMBER OF ARGS TO CONSTRUCTOR
CS2:	PUSHJ	P,LCOPY		;COPY ARGLIST
	MOVEI	AC2,^D18	;STORE SIZE OF ELEMENT IN AC2
	PUSHJ	P,BLOCK		;COMPUTE SIZE OF PACKING AREA
	MOVEI	R2,1(R)		;RESULT IN R, R2_R+1
	PUSHJ	P,MKBLK		;GO MAKE BLOCK OF SIZE R
	BLKARG	0,0(R2)		;PZADR IN R,DZADR IN R2
	HRRZ	L,CFNAM		;L_RELADR OF DDEF
	HRLM	L,(R)		;STORE DATA TYPE IN BLOCK PZWORD
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	HRLI	R,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	SAVE	R		;SAVE IT ON STACK
	GET	AC3,TOPF	;FOR RESULT OF CONSTRUCTION
	HRLI	AC3,B		;AT TOP IN CAR STACK
	MOVEI	R,LSTATM/2+2	;STORE CODE FOR PACKING PZADRESSES
	ADDI	R2,1		;R2=BASE OF PACKING ZONE
	PUSHJ	P,PACK		;GO PACK ARGLIST ELEMENTS
	POP	P,@AC3		;PLACE RESULT OF CONSTRUCTION ON AR STACK
	RESTOR	<L,AC3>
	JRST	RESUM1		;RESUME INTERPRETATION
	SUBTTL	CONSTRUCT A SEQUENCE

CSEQ:	SAVE	<AC3,AC4,L>
	SAVE	<S>		;SAVE S ACROSS ARGLSB
	PUSHJ	P,ARGLSB	;COERCE ARGLIST TO LIST OF CONSTANTS
	  EXERR	  MSG(IPCON)	;IMPROPER PARAMETER TO CONSTRUCTOR
	MOVE	S,(P)		;REFRESH S
	PUSHJ	P,TYPCHK	;CHECK TYPES OF ARGUMENTS
	RESTOR	<S>		;RESTORE S
	HRRZ	B,(S)		;CHECK NUMBER OF ARGUMENTS
	GET	AC1,UBF		;AGAINST LENGTH OF STRUCTURE
	GET	AC2,LBF		;TO SEE IF NUMBER OF ARGS IS CORRECT
	SUB	AC1,AC2
	ADDI	AC1,1		;LENGTH=UB-LB+1
	GET	AC4,TYPF	;SAVE TYPE FIELD IN AC4
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	JUMPN	ARGP,.+2	;USER SUPPLY ANY ARGS?
	JUMPN	AC1,WNARGC	;NO, ERROR IF SEQUENCE IS OF NONZERO LENGTH
	HLRZ	R,S		;FETCH NUMBER OF ARGS
	CAME	R,AC1		;IF NUMBER OF ARGS IN LIST =# REQD,OK.
	JRST	WNARGC		;ERROR-WRONG # OF ARGS TO CONSTRUCTOR
CSQ2:	PUSHJ	P,LCOPY		;COPY ARGS IN ARGLIST
	LSH	AC4,-1		;SHIFT ELEMENT TYPE RIGHT ONE
	CAIG	AC4,LSTATM/2	;SEE IF ATOMIC
	SKIPA	AC2,LTABL(AC4)	;IF SO AC2_APPROPRIATE SIZE
	MOVEI	AC2,^D18	;ELSE AC2_LENGTH=18
	PUSHJ	P,BLOCK		;COMPUTE SIZE OF PACKING AREA
	MOVE	R2,R		;SET UP PARAMETERS TO MAKE BLOCK
	ADDI	R2,1		;PACKING AREA SIZE +1 IN R2
	PUSHJ	P,MKBLK		;GO MAKE BLOCK OF PROPER SIZE
	BLKARG	0,0(R2)		;BLANK DATA TYPE FIELD
	HRRZ	L,CFNAM		;GET DATA TYPE IN L
	HRLM	L,(R)		;STORE IN PZWORD FOR BLOCK
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	HRLI	R,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	SAVE	R
	GET	AC3,TOPF	;STORE IN TOP OF CAR
	HRLI	AC3,B		;INDEX TOP RELADR BY B
	MOVEI	R,1(AC4)	;SET CODE FOR ELEMENT TYPE IN R
	CAILE	R,LSTATM/2+1	;IF <=5 SKIP CODE OK, ELSE
	MOVEI	R,LSTATM/2+2	;SET CODE TO 6 FOR PZADR'S
	ADDI	R2,1		;R2=ABSADR OF PACKING ZONE
	PUSHJ	P,PACK		;GO DO PACKING
	POP	P,@AC3		;STORE LEXEME ON AR STACK
CSQ4:	RESTOR	<L,AC4,AC3>
	TRNE	FF,TUPARG	;IS THIS A SPECIAL TUPARG CALL
	JRST	TUPRET		;YES, GO BACK TO TUPRET IN INTERP
	JRST	RESUM1		;RESUME INTERPRETATION

;CODE TO MAKE AND STACK A NULL SEQUENCE

CSQ3:	MOVEI	R2,1		;SET BLOCK SIZE TO 1
	PUSHJ	P,MKBLK		;GO MAKE A BLOCK
	BLKARG	0,0(R2)		;BLOCK TYPE NOT GIVEN
	HRRZ	L,CFNAM		;L_DATA TYPE
	HRLM	L,(R)		;SET DATA TYPE IN BLOCK
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	HRLI	R,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	GET	AC3,TOPF	;GO GET TOPF OF CAR
	HRLI	AC3,B		;INDEX IT BY B
	MOVEM	R,@AC3
	JRST	CSQ4		;RESTORE AC'S AND RETURN TO FINDPH
	SUBTTL	CONSTRUCT A VARIADIC SEQUENCE

CVSEQ:	SAVE	<AC3,AC4,L>
	SAVE	<S>		;SAVE S ACROSS ARGLSB
	PUSHJ	P,ARGLSB	;COERCE ARGLIST TO CONSTANTS
	  EXERR	  MSG(IPCON)	;IMPROPER ARGUMENT TO CONSTRUCTOR
	MOVE	S,(P)		;REFRESH S
	PUSHJ	P,TYPCHK	;CHECK TYPES OF ARGUMENTS
	RESTOR	<S>		;RESTORE S
	JUMPE	ARGP,CVSQ1	;DO SPECIAL CODE TO MAKE VSEQ OF LENGTH ZERO
	HLRZ	R,S		;GET NUMBER OF ARGS TO CONSTRUCTOR
CVSQ3:	SAVE	<S>		;SAVE S ACROSS LCOPY
	PUSHJ	P,LCOPY		;COPY ARGS IN ARGLIST
	RESTOR	<S>		;RESTORE S
	HRRZ	B,(S)		;B_DZADR OF VSEQ DEF
	GET	AC4,TYPF	;AC4_ELEMENT TYPE
	GET	AC3,LBF		;AC3_LOWER BOUND EXTENDED
	LSH	AC4,-1		;SHIFT ELEMENT TYPE RIGHT ONE
	CAIG	AC4,LSTATM/2	;SKIP IF TYPE IS NON-ATOMIC
	SKIPA	AC2,LTABL(AC4)	;AC2_APPROPRIATE SIZE
	MOVEI	AC2,^D18	;AC2_SIZE 18 FOR NON-ATOMIC ELEMENTS
	HLRZ	AC1,S		;FETCH NUMBER OF ARGS TO CONSTRUCTOR
	PUSHJ	P,BLOCK		;COMPUTE SIZE OF PACKING AREA
	MOVE	R2,R		;SET UP SIZE FOR MAKE BLOCK
	ADDI	R2,2
	PUSHJ	P,MKBLK		;GO MAKE BLOCK OF PROPER SIZE
	BLKARG	0,0(R2)
	HRRZ	L,CFNAM		;GET PROPER DATA TYPE
	HRLM	L,(R)		;STORE VSEQ TYPE IN PZWORD
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	HRLI	R,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	ADD	AC3,AC1		;COMPUTE UPPER BOUND=LB+LENGTH-1
	SUBI	AC3,1
	MOVE	L,AC3		;L=UPPER BOUND
	GET	AC3,TOPF	;STORE CONSTANT LEXEME ON TOP OF CAR 
	HRLI	AC3,B		;STACK
	SAVE	R		;REMEMBER LEXEME
	MOVEI	R,1(AC4)	;SET CODE FOR ELEMENT TYPE IN R
	CAILE	R,LSTATM/2+1	;IF <=5 OK ELSE USE 6
	MOVEI	R,LSTATM/2+2
	HRRM	L,1(R2)		;STORE UB IN VSEQ
	ADDI	R2,2		;R2=BASE ADDRESS OF PACKING ZONE
	PUSHJ	P,PACK		;GO PACK ARGUMENTS IN VSEQ
	POP	P,@AC3		;PLACE RESULT OF CONSTRUCTION ON STACK
	JRST	CSQ4		;RESTORE AC'S AND RETURN TO FINDPH

CVSQ1:	PUSHJ	P,MKBLK		;MAKE BLOCK OF LENGTH 2
	BLKARG  0,2		;DATA TYPE BLANK
	HRRZ	L,CFNAM		;GET DATA TYPE OF VSEQ
	HRLM	L,(R)		;AND STORE IN PZWORD
	HRRZ	B,(S)		;SET UPPER BOUND FIELD
	GET	AC1,LBF		;AC1_LOWER BOUND
	SUBI	AC1,1		;UB=LB-1
	HRRM	AC1,1(R2)	;STORE IN BLOCK
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	HRLI	R,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	GET	AC3,TOPF	;STORE CONSTANT LEXEME
	HRLI	AC3,B		;ON TOP OF CAR STACK
	MOVEM	R,@AC3
	JRST	CSQ4		;RESTORE AC'S AND RESUME SYNTAX ANALYSIS
	SUBTTL	SUBROUTINES FOR CONSTRUCTOR FUNCTIONS

;SUBROUTINE TO PROCESS AN ARGLIST & REDUCE IT TO CONSTANTS.
;   ASSUMES ARGP POINTS TO FIRST ARGUMENT AND S[LH] HAS NUMBER OF ARGS.
;   THIS ROUTINE SKIPS UNLESS ONE OR MORE OF THE ARGUMENTS IS IN ERROR.

ARGLSB:	MOVEI	AC1,MKCNST	;SETUP FOR REPEATED CALL ON MKCNST
	JRST	ARGSEQ		;DISTRIBUTE CALLS TO MKCNST OVER ARGLIST

;ROUTINE TO COERCE A LEXEME TO A CONSTANT AT ARGP.
;   CLOBBERS R,R2. RECOMPUTES B IF NECESSARY.
;   SKIP RETURN IF OK, NON-SKIP IF ERROR.

MKCNST:	SAVE	<AC1,AC2,L,T>
	MOVE	L,@ARGP		;L_ARGUMENT TO BE COERCED
MKC1:	LGET	AC1,LTYPF	;AC1_LEXEME TYPE
	XCT	MKTAB(AC1)	;DISPATCH ON LEXEME TYPE
MKTAB:	JRST	ERROR8		;OP-ERROR
	JRST	CLCL		;PROCID-GET VALUE
	JRST	CLCL		;FORML-GET VALUE
	JRST	CLCL		;LCL-GET VALUE
	JRST	CID		;ID-GET VALUE
	JRST	CTBOUT		;CONST-ALREADY A CONSTANT-GO OUT
	JRST	CRELOC		;RELOC-CODERCE TO INTEGER CONSTANT
	JRST	ERROR8		;DEMAND-SYSTEM ERROR
	JRST	CSELX		;SELX-COERCE TO CONSTANT
	JRST	ERROR8		;$ID-IMPROPER ARGUMENT
	JRST	CDMR		;DUMREF-FETCH VALUE OF REFERENCED LCL

CRELOC:	CALL	RLCINT		;CONVERT RELOC TO INT
CTBOUT:	AOS	-4(P)		;SUCCESSFUL (SKIP) RETURN
ERROR8:	RESTOR	<T,L>		;RESTORE ACCUMULATORES
	JRST	X21		;RESTORE AC2,1 AND RETURN
;CODE TO GET A VALUE OF A LOCAL IN THE CAR

CLCL:	MOVEI	L,ARBASE(L)	;L_RELADR OF LOCAL IN CAR
	HRLI	L,B		;INDEX L BY B
	SKIPA	L,@L		;GET LOCAL QUANTITY

;CODE TO FETCH A LEXEME REFERENCED BY A DUMREF

CDMR:	CALL	GETDMR		;FETCH REFERENCED LEXEME
	JUMPE	L,ERROR8	;ERROR IF LOCAL UNASSIGNED
	MOVEM	L,@ARGP		;STORE IN CAR IN PLACE OF LOCAL
	JRST	MKC1		;AND RESUME ANALYSIS WITH
				;SUBSTITUTED LEXEME

;CODE TO GET THE VALUE OF A GLOBAL IDENTIFIER

CID:	MOVE	AC2,IDTP	;AC2_DZADR OF IDT
	HRRZ	AC2,(AC2)
	ADDI	AC2,(L)		;AC2_ABSADR OF STE
	MOVE	L,(AC2)		;L_STE OF IDENTIFIER
	HLRZ	AC1,L		;AC1_CLASS OF IDENTIFIER
	XCT	CIDTBL(AC1)	;DISPATCH ON ID TYPE
CIDTBL:	JRST	ERROR8		;UNDEFINED IDENTIFIER
	JRST	CIDVAR		;VAR-GET VALUE
	JRST	ERROR8		;FN-IMPROPER PARAMETER
	JRST	ERROR8		;DDEF-IMPROPER PARAMETER
	JRST	ERROR8		;SEL-IMPROPER PARAMETER
	JRST	CIDCEV		;CEV-GO GET VALUE
	JRST	ERROR8		;ATOM-IMPROPER PARAMETER
	JRST	ERROR8		;I.SFN-IMPROPER PARAMETER
	JRST	ERROR8		;RESW - IMPROPER PARAMETER

CIDVAR:	HRRZ	AC1,L		;CHECK TO SEE IF RIGHT HALF
	JUMPE	AC1,ERROR8	;OF STE IS NON-ZERO
	HRLI	AC1,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	MOVEM	AC1,@ARGP	;AND STACK IT ON STACK AT ARGP
	JRST	CTBOUT		;AND EXIT

CIDCEV:	HRRZ	AC1,L		;GET CONTINUOUS VALUE AND
	JUMPE	AC1,ERROR8	;IF IT IS NON-ZERO MAKE
	HRRZ	AC2,(AC1)	;CONSTANT OUT OF IT
	HRRZ	AC1,1(AC2)	;AC2_DZADR OF CEV BLOCK,
	JUMPE	AC1,ERROR8	;AC1=CONTINUOUS VALUE,ERROR IF ZERO
	HRLI	AC1,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	MOVEM	AC1,@ARGP	;AND STACK ON STACK,THEN
	JRST	CTBOUT		;EXIT


;CODE TO COERCE A SELECTION EXPRESSION INTO A CONSTANT

CSELX:	HRRZ	B,(L)		;B_DZADR OF LVALUE BLOCK
	PUSHJ	P,SELECT	;RETURNS WITH VALUE IN (R,R2),ELTYPE IN T
	JRST	CSELX1		;R WAS PZADR IF HAD NORMAL RETURN
	LSH	T,-1		;HALVE TYPE FIELD TO MAKE SRETRN HAPPY
	PUSHJ	P,SRETRN	;MAKES BLOCK OUT OF (R,R2) OF TYPE T
CSELX2:	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	MOVEM	R,@ARGP		;STORE ON CAR AT ARGP
	JRST	CTBOUT		;AND EXIT

CSELX1:	HRLI	R,(LXM(STAK,CONST))	;MAKE CONST LEXEME
	JRST	CSELX2		;AND GO STACK IT ON CAR AT ARGP
;ROUTINE TO CHECK TYPES OF ARGUMENTS IN ARGLIST.
;   ASSUMES ARGP --> FIRST ARG AND S[LH] CONTAINS # OF ARGS

TYPCHK:	MOVEI	AC1,TYPEOK	;SETUP ADR OF ROUTINE TO BE CALLED
	MOVEI	AC2,1		;INIT ARG COUNTER
	CALL	ARGSEQ		;ENUMERATE ARGLIST, CALLING TYPEOK
	  JFCL			;ARGENU SKIPS IF NO ARGS
	RETURN

;ROUTINE TO CHECK THE TYPE OF THE ITH ARGUMENT IN THE ARGLIST
;AGAINST THE TYPE REQUIRED FOR THE ITH ELEMENT
;AS SPECIFIED BY THE DATA TYPE BEING CONSTRUCTED.
;AC2=ORDINAL NUMBER OF THE ARGUMENT,S=STE FOR DDEF (CAUTION:MAYBE
;CLOBBERED BY ARGLSB WHICH CLOBBERS T=S=AC12). IF NO ERROR,
;TYPEOK EXITS NORMALLY. OTHERWISE IT DOES EXERR.

TYPEOK:	SAVE	<AC2>		;PROTECT ARG COUNTER
	HRRZ	AC1,S		;AC1_PZADR OF DDEF BLOCK
	PUSHJ	P,ITHTYP	;R_TYPE OF ITH ELEMENT (AC2=I)
	HLRZ	AC1,(L)		;FETCH DATA TYPE OF ITH ARGUMENT
	ANDCMI	AC1,(SYSBIT+GCBIT+CPYBIT) ;MASK OTHER BITS
	MOVE	AC2,R		;AC2_TYPE OF ITH ELEMENT
	PUSHJ	P,CHKPRD	;CALL INSTANCE
	EXERR	MSG(IPCON)	;WRONG TYPE ARGUMENT TO CONSTRUCTOR
	RESTOR	<AC2>		;RESTORE ARG COUNT
	AOJA	AC2,CPOPJ	;INCREMENT ARG COUNT AND RETURN
;ROUTINE TO COMPUTE REQUIRED TYPE OF ITH ARGUMENT IN
;A CONSTRUCTION. AC1=PZADR OF DDEF BLOCK
;FOR CONSTRUCTOR,AC2=I. RESULT IN R( AS RELADR OF TYPE
;ID IN IDT.)

ITHTYP:	SAVE	<AC1>
	HLRZ	R,(AC1)		;R_DDEF TYPE
	ANDCMI	R,(GCBIT+CPYBIT+SYSBIT) ;EXTRACT OFF GC,CPY,SYS BITS
	XCT	ITHT-B.STRUCT(R) ;DISPATCH ON DDEF TYPE
ITHT:	JRST	STRITH		;STRUCT-GET TYPE OF ITH ELEMENT
	ERROR   MSG(CNARG)	;ARG WAS ALT IN ITHTYP
	JRST	SEQITH		;SEQ-GET ELEMENT TYPE
	JRST	SEQITH		;VSEQ-GET ELEMENT TYPE

STRITH:	EXCH	B,AC1		;B_PZADR OF DDEF BLOCK
	HRRZ	B,(B)		;B_DZADR OF DDEF BLOCK
	GET	R,WLF		;R_WORD LENGTH
	CAML	AC2,R		;IF I<WLF, OK
	EXERR	MSG(TMARG)	;TOO MANY ARGUMENTS TO MAKE STRUCTURE
	ADDI	B,(AC2)		;B_ABSADR OF ITH SEL:TYPE PAIR
	HRRZ	R,(B)		;R_ELEMENT TYPE OF ITH ELEMENT
	MOVE	B,AC1		;RESTORE B,AC1 
	JRST	X1		;RESTORE AC1 AND RETURN

SEQITH:	EXCH	AC1,B		;B_PZADR OF DDEF BLOCK
	HRRZ	B,(B)		;B_DZADR OF DDEF BLOCK
	GET	R,TYPF		;R_ELEMENT TYPE
	JRST	X1		;RESTORE AC1 AND RETURN
	POPJ	P,		;AND EXIT
;CODE TO COPY AN ARGLIST OF CONSTANTS IN CAR POINTED

LCOPY:	SAVE	<AC1>		;PROTECT AN AC
	MOVEI	AC1,SGCOPY	;SETUP ADR OF SINGLE COPY ROUTINE
	CALL	ARGSEQ		;DISTRIBUTE CALLS TO SGCOPY OVER ARGLIST
	  JFCL			;ARGSEQ SKIPS IF NO ARGS
	JRST	X1		;RESTORE AC1 AND RETURN

SGCOPY:	HRRZ	AC1,@ARGP	;FETCH PZADR OF DATUM TO BE COPIED
	CALL	COPY		;MAKE A COPY (IF NECESSARY)
	HRRZ	B,(CAR)		;RESTORE BASE ADR OF CAR
	HRRM	R,@ARGP		;STORE PZADR OF COPY
	RETURN
;ALGORITHM TO COMPUTE REQUIRED LENGTH OF PACKING ZONE
;FOR N OBJECTS OF SIZE S=1,7,18,36 OR 72, WHERE AC1=N,
;AC2=S. RESULT IN R IN UNITS OF WORDS.

BLOCK:	SAVE	<AC1,AC2>	;SAVE ACCUMULATORS
	MOVE	R,AC1		;R_N
	IMUL	R,AC2		;R_N*S
	CAIE	AC2,7		;IF S=7 SKIP
	JRST	.+4		;ELSE GO TO .+4
	SUBI	AC1,1		;AC1_N-1
	IDIVI	AC1,5		;AC1_ENTIER((N-1)/5)
	ADD	R,AC1		;R_N*S+ENTIER((N-1)/5)
	IDIVI	R,^D36		;R_ENTIER(R/36)
	SKIPE	R2		;IF HAD NON-ZERO REMAINDER IN R2
	ADDI	R,1		;THEN ADD 1 TO R,NEED ONE MORE WORD
	RESTORE	<AC2,AC1>	;RESTORE ACCUMULATORS
	POPJ	P,		;EXIT
;ROUTINE TO PACK AN ARGLIST INTO A ZONE.

;CALLING PARAMETERS:
;	AC1 =	NUMBER OF ELEMENTS IN ARGLIST
;	AC2 =	PACKING SIZE OF EACH ELEMENT
;	R =	ELEMENT TYPE CODE, WHERE
;		INT =	1
;		REAL =	2
;		DBL =	3
;		BOOL =	4
;		CHAR =	5
;		NONE =	6
;		ADDRESS=7
;	R2 =	ABSOLUTE ADDRESS OF THE FIRST WORD OF THE PACKING ZONE.

PACK:	XCT	PCKTAB-1(R)	;DISPATCH ON ELEMENT TYPE CODE
PCKTAB:	JRST	PKINT		;INT-GO PACK INTGERS
	JRST	PKREAL		;REAL-GO PACK REALS
	JRST	PKDBL		;DBL-GO PACK DOUBLES
	JRST	PKBOOL		;BOOL-GO PACK BOOLS
	JRST	PKCHAR		;CHAR-GO PACK CHARACTERS
	POPJ	P,		;NONE-PACKING NULLS IS A NO-OP
	JRST	PKADR		;ADR-GO PACK PZADR'S
PKREAL:
PKINT:	SAVE	<ARGP>		;SAVE ARGP FOR LATER RESTORATION
PKI1:	MOVE	L,@ARGP		;GET LEXEME IN L
	HRRZ	L,(L)		;L_DZADR
	MOVE	L,1(L)		;L_INT OR REAL
	MOVEM	L,(R2)		;STORE IN PACKING ZONE
	ADDI	ARGP,1		;MOVE TO NEXT ARGUMENT
	ADDI	R2,1		;INCREMENT TARGET PACKING ADDRESS
	SOJG	AC1,PKI1	;IF MORE LEFT GO AROUND,ELSE
	RESTOR	<ARGP>		;RESTORE ARGP
	POPJ	P,		;AND EXIT
;ROUTINE TO PACK DOUBLES

PKDBL:	SAVE	<ARGP>
PKD1:	MOVE	L,@ARGP		;L_LEXEME FOR ITH DOUBLE
	HRRZ	L,(L)		;L_DZADR OF DOUBLE DATA BLOCK
	MOVE	R,1(L)		;GET FIRST HALF OF DOUBLE IN R
	MOVEM	R,(R2)		;AND STORE IN (R2)
	MOVE	R,2(L)		;GET SECOND HALF OF DOUBLE IN R
	MOVEM	R,1(R2)		;STORE ADJACENT TO FIRST HALF
	ADDI	R2,2		;INCREMENT R2 BY TWO
	ADDI	ARGP,1		;MOVE TO NEXT ARGUMENT
	SOJG	AC1,PKD1	;IF MORE LEFT,GO AROUND
	RESTOR	<ARGP>		;ELSE RESTORE ARGP
	POPJ	P,		;AND EXIT

;ROUTINE TO PACK BOOLEAN VALUES 

PKBOOL:	SAVE	<ARGP>
	MOVSI	R,(POINT 1,(R2)) ;SETUP BYTE PTR FOR BOOLS
	JRST	PKBC1		;GO TO COMMON CODE FOR BOOLS AND CHARS

;ROUTINE TO PACK CHARACTERS

PKCHAR:	SAVE	<ARGP>
	MOVSI	R,(POINT 7,(R2)) ;SETUP BYTE PTR FOR CHARS

;COMMON CODE FOR BOOLS AND CHARS

PKBC1:	MOVE	L,@ARGP		;L_LEXEME WITH VALUE TO BE PACKED
	HRRZ	L,(L)		;L_DZADR OF DATA BLOCK
	MOVE	L,1(L)		;L_BOOL OR CHAR TO BE PACKED
	IDPB	L,R		;MOVE BYTE TO LOC. SPECFIED BY R
	ADDI	ARGP,1		;MOVE TO NEXT ARGUMENT
	SOJG	AC1,PKBC1	;IF MORE GO AROUND
	RESTOR	<ARGP>		;RESTORE ARGP
	POPJ	P,		;AND EXIT

;ROUTINE TO PACK ADDRESSES

PKADR:	SAVE	<ARGP>
	MOVSI	R,(POINT 18,(R2)) ;SETUP BYTE PTR FOR ADDRESSES
PKA1:	HRRZ	L,@ARGP		;L_PZADR OF DATUM
	IDPB	L,R		;DEPOSIT IT IN LOC. SPECIFIED BY R
	ADDI	ARGP,1		;MOVE TO NEXT ARGUMENT
	SOJG	AC1,PKA1	;IF MORE LEFT GO AROUND
	RESTOR	<ARGP>		;ELSE RESTORE ARGP
	POPJ	P,		;AND EXIT
	SUBTTL	SELECTION

;COMPOUND SELECTION.

;ENTER WITH STACK IN THE FORM
;	S1 S2 ... SN X
;WHERE THE FOLLOWING AC'S ARE SET UP:
;	L =	SELAPP(N)
;	ARGP =	B,,PTR(S1)
;	TOP =	B,,PTR(X)		;NOTE UNUSUAL CONVENTION

;SELECTORS S1 THRU SN ARE APPLIED TO X IN LEFT TO RIGHT (NUMERICAL)
;   ORDER.  THE RESULT OF EACH SIMPLE SELECTION REPLACES THE SELECTAND
;   (ORIGINALLY X).  AT THE COMPLETION OF COMPOUND SELECTION,
;   THE RESULT MUST BE PLACED IN THE S1 POSITION AND THE STACK POPPED.

CSELCT:	MOVEI	AC1,SSELCT	;SETUP REPEATED CALL FOR SIMPLE SELECTION
	HRRZ	AC2,L		;SUPPLY NUMBER OF SELECTORS
	CALL	ARGENU		;ENUMERATE SELECTOR LIST
	MOVE	AC1,@TOP	;FETCH RESULT OF COMPOUND SELECTION
	MOVEM	AC1,@ARGP	;STORE IN FIRST SELECTOR POSITION
	MOVE	TOP,ARGP	;POP STACK
	SET	TOP,TOPF	;STORE STACK PTR IN CAR
	JRST	RESUM1		;RESUME INTERPRETATION AFTER INCREMENTING CPM
;ROUTINE TO PERFORM SIMPLE SELECTION X[S], WHERE
;	ARGP =	B,,PTR(S)
;	TOP =	B,,PTR(X)
;THE RESULT IS LEFT AT THE X POSITION ON THE STACK

SSELCT:	EXCH	ARGP,TOP	;MAKE ARGP-->X
	CALL	MKCNST		;COERCE X TO A CONSTANT
	  EXERR	  MSG(IPSEL)	;IMPROPER PARAMETER FOR SELECTION
	EXCH	ARGP,TOP	;RESTORE POINTERS
	MOVE	L,@TOP		;GET LEXEME FOR CONSTANT
	HLRZ	AC1,(L)		;AC1_DATA TYPE
	TRNE	AC1,(SYSBIT)	;IF SYSBIT ON THEN ERROR
	ERROR	MSG(SYSEL)	;ATTEMPT TO SELECT FROM SYSTEM OBJECT
	CAIG	AC1,LSTATM	;SEE IF SELECTAND IS ATOMIC,IF SO ERROR
	EXERR	MSG(ATSEL)	;ATTEMPT TO SELECT COMPONENT OF ATOMIC DATUM
	HRRZ	AC2,@IDTP	;AC2_DZADR OF IDT
	ADD	AC2,AC1		;AC2=ABSADR OF STE FOR DATA TYPE
	HRRZ	AC2,(AC2)	;AC2=PZADR OF DDEF BLOCK
	SKIPN	AC2		;IF DDEF BLOCK IS ZERO THEN DDEF UNDEFINED
	ERROR	MSG(DDMSE)	;DATA DEF MISSING DURING SELECTION
	HLRZ	R,(AC2)		;R_TYPE OF DDEF BLOCK
	ANDCMI	R,(SYSBIT+GCBIT+CPYBIT) ;MASK OUT OTHER BITS
	XCT	SSTBL-B.STRUCT(R) ;DISPATCH ON DDEF TYPE
SSTBL:	JRST	SSTRCT		;GO DO SELECTION ON STRUCTURE
	ERROR	MSG(DDALT)	;DDEF WAS ALT IN SELECTION
	JRST	SSEQ		;GO DO SELECTION ON SEQUENCE
	JRST	SVSEQ		;GO DO SELECTION ON VARIADIC SEQUENCE
;CODE TO SELECT FROM A STRUCTURE.
;ENTER AC1=PZADR OF DDEF BLOCK
;      AC2=DATA TYPE OF SELECTAND
;	ARGP =	B,,PTR(S)	;S IS SELECTOR ON STACK
;	TOP =	B,,PTR(X)	;X IS OBJECT BEING SELECTED FROM

SSTRCT:	MOVE	L,@ARGP		;FETCH SELECTOR
	LGET	R,LTYPF		;SEE IF SELECTOR IS PROCID
	CAIN	R,PROCID
	JRST	SSTR4		;YES, TREAT INTEGER SELECTORS
	CALL	EVALID		;NO, SEE IF IT CAN BE COERCED TO ID
	  JRST	  SSTR4		;NO, TREAT INTEGER SELECTORS
	HRRZ	L,@ARGP		;FETCH ID INTERNAL NAME
	ADD	L,@IDTP		;AN ID, SEE WHAT KIND
	HLRZ	L,(L)		;GET LH OF SYMBOL TABLE ENTRY
	CAIE	L,I.SEL		;A SELECTOR?
	JRST	SSTR4		;NO, ASSUME INDEXED SELECTION
	HRLZ	L,@ARGP		;YES. L[LH]_SELECTOR NAME
	HRRZ	B,(AC2)		;FIND ORDINAL POSITION OF SELECTOR
	HRLI	B,R		;INDEX B BY R
	GET	R,WLF		;B_DZADR OF STRUCT DDEF BLOCK,INDXD BY R
SSTR1:	SOJG	R,.+2		;R_WLENGTH OF DDEF BLOCK
	EXERR	MSG(ISELS)	;IMPROPER SELECTOR FOR STRUCTURE
SSTR2:	HRR	L,@B		;GET NTH SEL:TYPE PAIR IN DDEF BLOCK
	CAMN	L,@B		;COMPARE L WITH SEL:TYPE PAIR
	JRST	SSTR3		;FOUND SELECTOR,GO TO SSTR3,RHS(L)=ELTYPE
	SOJG	R,SSTR2		;GO AROUND IF R>0
	EXERR	MSG(ISELS)	;IMPROPER SELECTOR FOR STRUCTURE
SSTR3:	MOVEI	AC1,(R)		;AC1_ORDINAL NUMBER OF SELECTOR
SSTR6:	MOVEI	T,LSTATM+2	;T_ELEMENT TYPE FOR HALF WORD CALCULATION
	PUSHJ	P,FIELDP	;CALCULATE R=DISP,R2=BEG, AND AC2=18
	ADDI	R,1		;INCREMENT DISPLACEMENT BY ONE
	HRRZ	T,L		;T=ELTYPE OF STR FIELD
SLCOUT:	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	HRRZ	AC1,@TOP	;AC1_PZADR OF DATUM
	PUSHJ	P,MKLVL		;MAKE AN LVALUE
	MOVEM	R,@TOP		;STORE SELX LEXEME AT ARGP-3
	RETURN
SSTR4:	PUSHJ	P,MKCNST	;COERCE SELECTOR TO A CONSTANT
	  EXERR	  MSG(ISELS)	;IMPROPER SELECTOR FOR STRUCTURE
	MOVE	L,@ARGP		;GET LEXEME FOR SELECTOR IN L
	HLRZ	R2,(L)		;R_DATA TYPE OF CONSTANT
	ANDI	R2,077777	;IF WASNT INT THEN
	CAIE	R2,U.INT	;THEN HAD ILLEGAL SELECTOR
SSTR5:	EXERR MSG(ILSEL)	;ILLEGAL SELECTOR
	HRRZ	B,(L)		;B_DZADR OF INTEGER
	GET	AC1,INTF	;AC1_ORDINAL # OF COMPONENT
	JUMPLE	AC1,SSTR5	;ILLEGAL IF NEGATIVE OR ZERO
	HRRZ	B,(AC2)		;B_DZADR OF DDEF BLOCK
	GET	R,WLF		;R_WLF OF DDEF BLOCK
	CAML	AC1,R		;IF ORDINAL SEL<WLF,OK,ELSE
	JRST	SSTR5		;ORDINAL SELECTOR TOO LARGE
	ADD	B,AC1		;B_ABS ADR OF SEL:TYPE PAIR
	MOVE	L,(B)		;L_SEL:TYPE PAIR
	JRST	SSTR6		;GO TO SSTR6 TO FINISH
;CODE FOR SELECTION ON SEQUENCES
;AC2=PZADR OF DDEF BLOCK
;	ARGP =	B,,PTR(S)	;S IS SELECTOR
;	TOP =	B,,PTR(X)	;X IS SELECTAND

SSEQ:	SAVE	<AC3,AC4,AC5>
	HRRZ	B,(AC2)		;B_DZADR OF DATA BLOCK
	GET	AC3,LBF		;AC3_LOWER BOUND FIELD,EXTENDED
	GET	AC4,UBF		;AC4_UPPER BOUND FIELD EXTENDED
	MOVEI	AC5,0		;AC5_0 =CODE FOR SEQ
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	JRST	CSSEQ		;GO TO COMMON CODE FOR SEQ AND VSEQ

SVSEQ:	SAVE	<AC3,AC4,AC5>
	MOVE	L,@TOP		;GET UPPER BOUND FROM DATUM
	HRRZ	B,(L)		;B_DZADR OF SELECTAND
	GET	AC4,UDUBF	;GET UPPER BOUND FROM DATUM
	HRRZ	B,(AC2)		;B_DZADR OF DDEF BLOCK
	GET	AC3,LBF		;AC3_LOWER BOUND FIELD EXTENDED
	MOVEI	AC5,1		;AC5_1=CODE FOR VSEQ
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	JRST	CSSEQ		;GO TO COMMON CODE FOR SEQ AND VSEQ
;CODE COMMON TO DO SELECTION ON SEQ'S AND VSEQ'S.
;ENTER WITH AC2=PZADR OF DDEF BLOCK,AC1=DATA TYPE OF SELECTAND
;AC3=LB,AC4=UB,AC5=0 OR 1 IF SEQ OR VSEQ RESPECTIVELY.

CSSEQ:	PUSHJ	P,MKCNST	;COERCE SELECTOR TO A CONSTANT
	  EXERR	  MSG(ISELQ)	;IMPROPER SELECTOR FOR SEQUENCE
	MOVE	L,@ARGP		;GET LEXEME FOR CONSTANT IN L
	HLRZ	R2,(L)		;R2_DATA TYPE OF CONSTANT
	ANDI	R2,077777	;
	CAIE	R2,U.INT	;IF NOT INT THEN ERROR
	JRST	SSTR5		;GO PRINT ERROR MESSAGE
	HRRZ	B,(L)		;B_DZADR OF CONSTANT
	GET	AC1,INTF	;GET SELECTOR SUBSCRIPT
	CAML	AC1,AC3		;ERROR IF SELECTOR NOT >= LB
	CAMLE	AC1,AC4		;ERROR IF SELECTOR OUT OF BOUNDS
CCSEQ1:	EXERR MSG(SSOUT)	;SELECTOR SUBSCRIPT OUT OF BOUNDS
	SUB	AC1,AC3		;AC1_AC1-AC3+1
	ADDI	AC1,1		;AC1=ORDINAL NUMBER OF SELECTOR
	HRRZ	B,(AC2)		;B_DZADR OF DATA BLOCK
	GET	T,TYPF		;T_ELEMENT TYPE
	PUSHJ	P,FIELDP	;AC2=LENGTH,R=DISP,R2=BEG
	ADDI	R,1(AC5)	;INCREMENT DISP FOR SEQ OR VSEQ
	RESTOR	<AC5,AC4,AC3>	;RESTORE ACCUMULATORS
	JRST	SLCOUT		;GO PERFORM COMMON LVALUE CODE
	SUBTTL	SELECTOR ROUTINES

;ROUTINE TO CREATE AN L-VALUE FROM FIELD PARAMETERS.
;AC1=PZADR OF DATUM,AC2=LENGTH,T=ELTYPE(RELADR IN IDT),,
;R=DISP,R2=BEG. RESULTS:R2=PZADR OF LVAL,R=SELX LEXEME,

MKLVL:	SAVE	<AC3,R,R2>
	PUSHJ	P,MKBLK		;MAKE A BLOCK
	BLKARG	SYSBIT+B.LVAL,3	;3 WORDS LONG OF TYPE LVAL
	MOVE	AC3,R		;AC3_PZADR OF LVAL
	MOVE	B,R2		;B_DZADR OF LVAL BLOCK
	RESTOR	<R2,R>
	SET	T,ELTF		;ELEMENT TYPE _T
	SET	AC1,PZAF	;PZADR _ AC1
	SET	R,DISPF		;DISPLACEMENT FIELD_R
	SET	R2,BEGF		;BEGINNING FIELD_R2
	SET	AC2,LENF	;LENGTH FIELD _ AC2
	MOVE	R,AC3		;R,R2_PZADR OF LVAL
	MOVE	R2,AC3		;R_SELX LEXEME
	HRLI	R,(LXM(STAK,SELX)) ;MAKE SELX LEXEME
	RESTOR	<AC3>		;RESTORE ACCUMULATOR
	JRST	BPOPJ		;RECOMPUTE B=DZADR OF CAR AND EXIT
;ROUTINE TO CALCULATE FIELD PARAMETERS OF ITH COMPONENT OF
;A HOMOGENEOUS ARRAY OF ELEMENTS OF ELTYPE T (=RELADR IN IDT
;OF ELEMENT TYPE), WHERE AC1=ORDINAL NUMBER OF ELEMENT. ALL ACCUMULATORS
;SAVED. RESULTS:AC2=LENGTH,R=DISP (RELATIVE TO ZERO, R2=BEG.

FIELDP:	SAVE	<T>		;SAVE ELEMENT TYPE
	LSH	T,-1		;SHIFT ELEMENT TYPE ONE RIGHT
	CAIG	T,LSTATM/2	;SEE IF ELEMENT IS ATOMIC
	SKIPA	AC2,LTABL(T)	;IF SO AC2_APPROPRIATE LENGTH
	MOVEI	AC2,^D18	;ELSE ,IF NON-ATOMIC,LENGTH_18
	PUSHJ	P,DBFIND	;GO CALCULATE DISP & BEG IN (R,R2)
	RESTOR	<T>		;RESTORE ELEMENT TYPE
	POPJ	P,		;AND EXIT

LTABL:	EXP	^D36		;INT-LENGTH=36
	EXP	^D36		;REAL-LENGTH=36
	EXP	^D72		;DBL-LENGTH=72
	EXP	^D1		;BOOL-LENGTH=1
	EXP	^D7		;CHAR-LENGTH=7
	EXP	^D0		;NONE-LENGTH=0
	EXP	^D18		;PZADR-LENGTH=18

;DBFIND CALCULATES A DISPLACEMENT (IN R) AND A BEGINNING
;BIT POSITION (IN R2), OF THE ITH FIELD (I>=1) OF LENGTH
;(AC2),WHERE I=(AC1), IN A PACKED ARRAY OF HOMOGENEOUS ELEMENTS
;EACH OF LENGTH =(AC2) STARTING AT ADDRESS 0 WITH BITS OF
;SUCCESSIVE WORDS NUMBERED FROM 0-35. NO ACCUMULATORS
;OTHER THAN (R,R2) ARE CLOBBERED. NOTE:THE ACCUMULATOR
;PAIRS (AC1,AC2) AND (R,R2) MUST EACH BE ADJACENT PAIRS
;OF ACCUMULATORS.

DBFIND:	SAVE	<AC1,AC2>	;SAVE AC1 AND AC2
	SUBI	AC1,1		;AC1_I-1
	MOVE	R,AC1		;R_I-1
	IMUL	R,AC2		;R_(I-1)*LENGTH
	CAIE	AC2,7		;IF LENGTH#7 (NOT CHARACTER)
	JRST	.+3		;DONT ADD FUDGE FACTOR FOR CHARS
	IDIVI	AC1,5		;ELSE ADD FUDGE FACTOR FOR CHARS
	ADD	R,AC1		;R_R+ENTIER((I-1)/5)
	IDIVI	R,^D36		;R_ENTIER(R/36)=DISP
	JRST	X21		;RESTORE AC2,AC1 AND RETURN
	SUBTTL	SYSTEM FUNCTIONS FOR USER-DEFINED DATA

;LENGTH FUNCTIONS FOR ALL USER DATA, WHERE LENGTH = NUMBER
;OF COMPONENTS OF A COMPOUND STRUCTURE, AND, BY CONVENTION,
;THE LENGTH OF ALL ATOMS IS 1.

	REPEAT 0, <AC1=PZADR OF DATUM WHOSE LENGTH WILL BE TAKEN.
	R=RESULT , R2 IS CLOBBERED.>

LENGT:	HLRZ	R,(AC1)		;R_DATA TYPE
	TRNE	R,(SYSBIT)	;SKIP IF WAS USER TYPE
	ERROR MSG(SYLEN)	;ATTEMPT TO GET LENGTH OF SYSTEM OBJECT
	ANDI	R,077777	;EXTRACT OFF GC,SYS AND CPY BITS
	CAILE	R,LSTATM	;SKIP IF ATOMIC TYPE
	JRST	LENGT1		;ELSE GO COMPUTE LENGTH
	MOVEI	R,1		;LENGTH OF ATOMS IS 1
	POPJ	P,		;EXIT

LENGT1:	ADD	R,@IDTP		;R_DZADR OF STE FOR DATA TYPE
	HRRZ	R2,(R)		;R2_PZADR OF DDEF
	HLRZ	R,(R2)		;R_DDEF TYPE
	ANDCMI	R,(GCBIT+SYSBIT+CPYBIT) ;MASK OUT OTHER BITS
	XCT	LNGTBL-B.STRUCT(R) ;DISPATCH ON DDEF TYPE
LNGTBL:	JRST	LNGSTR		;STRUCT-LENGTH IS WLENTGH-1
	ERROR	MSG(ALLEN)	;LENGTH OF ALT CAN'T EXIST
	JRST	LNGSEQ		;SEQ-LENGTH IS UB-LB+1
	JRST	LNGVSQ		;VSEQ-LENGTH IS UB-LB+1

LNGSTR:	HRRZ	R,(R2)		;TO CALCULATE LENGTH OF
	HLRZ	R,(R)		;STRUCT, WE USE WLENGTH-1
	SUBI	R,1
	POPJ	P,		;EXIT WITH LENGTH IN R

LNGSEQ:	HRRZ	R,(R2)		;R_DZADR OF SEQ DATA DEF
	HLRE	R2,1(R)		;R2_LOWER BOUND
	HRRE	R,2(R)		;R_UPPER BOUND
	SUB	R,R2		;COMPUTE LENGTH=UB-LB+1
	AOJA	R,CPOPJ		;RETURN WITH LENGTH IN R
LNGVSQ:	SAVE	<AC1>		;SAVE AC1
	HRRZ	R,(R2)		;R_DZADR OF SEQ DATA DEF
	HLRE	R2,1(R)		;R2_LOWER BOUND
	HRRZ	AC1,(AC1)	;AC1_DZADR OF DATUM
	HRRE	R,1(AC1)	;R_UPPER BOUND
	SUB	R,R2		;COMPUTE LENGTH =UB-LB+1
	AOJA	R,X1		;RETURN, RESTORING AC1. LENGTH IN R


;SYSTEM FUNCTION FOR LENGTH. RESULT LEXEME IN R,MAY CLOBBER B.

SLENGTH:EXP	1		;TAKES ONE ARGUMENT
	PUSHJ	P,MKCNST	;COERCE ARGUMENT TO A CONSTANT
	  ILLTYPE		;ERROR
	HRRZ	AC1,@ARGP	;AC1_PZADR OF DATUM
	PUSHJ	P,LENGT		;GET LENGTH,RESULT IN R
	MOVEI	T,U.INT/2	;SET DATA TYPE IN T
	JRST	SRETRN		;MAKE BLOCK OF TYPE T FROM (R,R2)
				;AND EXIT

;ROUTINE TO MAKE VSEQ OF SPECIFIED TYPE,LENGTH AND INITIAL ELEMENT
;OF FORM MAKE(TYPE,LENGTH,INITIAL.ELEMENT)

SMAKE:	EXP	3
	CALL	EVALID		;EVAL FIRST ARG TO AN ID
MERR2:	  ILLTYPE		;IMPROPER ARGUMENT TYPE
	MOVE	L,@ARGP		;FETCH RESULTANT ID LEXEME
	HRRZ	AC4,L		;SAVE ID INTERNAL NAME FOR LATER
	ADD	L,@IDTP		;COMPUTE ABS ADR OF STE IN IDT
	HLRZ	R,(L)		;GET LH OF STE
	CAIE	R,I.DDEF	;IF FIRST ARG NOT DDEF NAME,
	ILLTYPE			;  THEN IS AN ERROR
	HRRZ	R,(L)		;OK. GET PZADR OF DDEF BLOCK
	HLRZ	R2,(R)		;GET LH OF PZ WORD
	CAIE	R2,B.VSEQ(SYSBIT)
	ILLTYPE			;ERROR IF NOT VARIADIC SEQUENCE DEF
	HRRZ	B,(R)		;OK, GET DZADR OF VSEQ BLOCK
	GET	AC2,TYPF	;AC2_REQD ELEMENT TYPE
	GET	AC3,LBF		;AC3_LOWER BOUND FIELD
	ADDI	ARGP,1
	HRRZ	B,(CAR)		;B_DZADR OF CAR FOR USE IN MKCONST
	PUSHJ	P,MKCNST	;COERCE 2ND ARG. TO CONSTANT
	  ILLTYPE		;ERROR
	MOVE	L,@ARGP
	MOVE	B,(L)		;B_PZWORD OF VALUE
	HLRZ	R2,B		;R2_TYPE OF CONSTANT
	ANDI	R2,077777	;EXTRACT OFF GC,CPY AND SYS BITS
	CAIE	R2,U.INT	;SECOND ARG. MUST BE INT,ERROR IF NOT
MERR3:	SFNERR	MSG(MAKE2)	;SECOND ARG. MUST BE NON-NEG INTEGER
	GET	AC5,INTF	;AC5_INTEGER FOR LENGTH
	JUMPL	AC5,MERR3	;ERROR IF INT < 0
	ADDI	ARGP,1		;SEQUENCE TO THIRD ARG
	HRRZ	B,(CAR)		;B_DZADR OF CAR
	PUSHJ	P,MKCNST	;COERCE 3RD ARGUMENT TO CONSTANT
	  ILLTYPE		;ERROR
	MOVE	L,@ARGP		;GET LEXEME FOR THIRD ARGUMENT IN L
	HLRZ	AC1,(L)		;AC1_DATA TYPE OF CONSTANT
	ANDI	AC1,077777
	PUSHJ	P,CHKPRD	;CHECK TO SEE THAT INITIAL.ELEMNT IS OK TYPE
MERR4:	SFNERR	MSG(MAKE3)	;3RD ARG. IS NOT OF PROPER TYPE
	EXCH	AC1,AC2		;EXCHANGE TYPE CODES OF CLASS AND TYPE
	LSH	AC1,-1		;SHIFT TYPE OF INIT. ELEMENT RIGHT ONE
	CAILE	AC1,LSTATM/2	;ELEMENT TYPE ATOMIC?
	MOVEI	AC1,LSTATM/2+1	;NO, SET CODE FOR NON-ATOMIC
	MOVE	AC2,LTABL(AC1)	;AC2_SIZE IN BITS OF ELEMENT TO BE PACKED
	EXCH	AC1,AC5		;AC1_NUMBER OF ELEMENTS
	PUSHJ	P,BLOCK		;COMPUTE IN R SIZE OF PACKING ZONE
	MOVEI	R2,2(R)		;R2_R+2
	PUSHJ	P,MKBLK		;MAKE A BLOCK OF REQUIRED SIZE
	BLKARG	0,0(R2)		;PZADR IN R,DZADR IN R2
	HRLI	R,(LXM(STAK,CONST)) ;MAKE CONST LEXEME
	HRLM	AC4,(R)		;SET TYPE OF NEW DATUM
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	IDPB	R,PZSAV		;SAVE PZADR OF DATUM BEING CONSTRUCTED
				;  TO PROTECT IT FROM GC
	ADD	AC3,AC1		;COMPUTE UB FOR VSEQ
	SUBI	AC3,1		;UB=LENGTH+LB-1
	MOVE	AC4,R2		;AC4_DZADR OF NEW DATUM
	MOVE	B,R2		;B_DZADR OF NEW DATUM
	SET	AC3,UDUBF	;FILL IN USER DEFINED UPPER BOUND FIELD
	JUMPE	AC1,MAKENX	;EXIT NOW IF ZERO LENGTH VSEQ
	MOVEI	AC3,(R)		;AC3_PZADR OF NEW DATUM
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	CAILE	AC5,LSTATM/2	;SKIP IF DATA TYPE WAS ATOMIC
	JRST	MAKENA		;ELSE GO TREAT NON-ATOMIC CASE
	MOVE	L,@ARGP		;LOAD (R,R2) WITH ATOMIC DATUM
	HRRZ	L,(L)		;L_DZADR OF INITIAL ELEMENT
	MOVE	R,1(L)		;GET TOP HALF
	MOVE	R2,2(L)		;GET BOTTOM HALF
	CAIN	AC5,U.DBL/2	;IF ELEMENT TYPE WAS 2 HAD DOUBLE
	JRST	MAKED		;GO PACK DOUBLES
	MOVE	L,AC2		;ELSE MAKE BYTE POINTER

	LSH	L,6		;SHIFT LEFT SIX
	ADDI	L,AC4		;INDEX L BY AC4
	LSH	L,^D18		;POINTER POINTS TO (AC4)+1
	ADDI	L,1		;0BITS TO RIGHT OF BYTE
	IDPB	R,L		;DEPOSIT BYTE
	SOJG	AC1,.-1		;GO AROUND IF MORE
	JRST	MAKENX		;GO EXIT WITH LEXEME IN R


MAKED:	ADDI	AC4,2		;AC4_BASE ADDR OF PACKING ZONE
	MOVEM	R,(AC4)		;PACK FIRST HALF OF DOUBLE
	MOVEM	R2,1(AC4)	;PACK SECOND HALF OF DOUBLE
	SOJG	AC1,MAKED	;GO AROUND IF MORE LEFT
	JRST	MAKENX		;GO EXIT WITH LEXEME IN R

MAKENA:	MOVE	AC5,AC1		;AC5=NUMBER OF ELEMENTS
	MOVE	L,[POINT 18,2(AC4)] ;L_BYTE POINTER
	HRRZ	AC1,@ARGP	;AC1_PZADR OF INITIAL ELEMENT
MAKEN1:	PUSHJ	P,COPY		;GO COPY ELEMENT
	HRRZ	AC4,(AC3)	;RECOMPUTE DZADR OF PACKING SONE
	IDPB	R,L		;LOAD BYTE INTO ZONE
	SOJG	AC5,MAKEN1	;GO AROUND IF MORE
MAKENX:	MOVE	R,@PZSAV	;PICK UP SAVED LEXEME
	SOS	PZSAV		;REMOVE FROM SAVED STATUS
	RETURN
;ROUTINE TO GET THE LOWER BOUND OF A DATUM

SL.BOU:	EXP	1
	CALL	MKCNST		;COERCE TO A CONSTANT
	  ILLTYPE		;ERROR
	MOVE	L,@ARGP		;GET THE COERCED LEXEME
	MOVE	L,(L)		;GET ADDRESSED PZ WORD
	LGET	BLTF		;EXTRACT BLOCK TYPE FIELD
	ADD	R,@IDTP		;GET STE ADDR.
	HRRZ	B,(R)		;GET THE RH OF THE STE
	HLRZ	R2,(R)		;GET ID TYPE FIELD
	CAIE	R2,I.DDEF	;MAKE SURE IT'S A DDEF
	ILLTYPE			;NO, MUST HAVE BEEN ATOM OR OTHER NONSENSE
	JUMPE	B,DDGONE	;BOMB IF DDEF HAS BEEN ERASED
	HLRZ	R2,(B)		;GET DDEF TYPE FIELD
	HRRZ	B,(B)		;GET DZ ADDR OF DDEF BLOCK
	CAIN	R2,B.STRUCT(SYSBIT)	;RETURN 1 FOR A STRUCT
	MOVEI	R,1
	CAIE	R2,B.SEQ(SYSBIT)	;RETURN LBF FOR SEQ OR VSEQ
	CAIN	R2,B.VSEQ(SYSBIT)
	GET	LBF
	MOVEI	T,U.INT/2	;MAKE IT AN INT
	JRST	SRETRN

DDGONE:	ERROR	MSG(DDMIS)	;MISSING DATA DEFINITION

;SYSTEM FUNCTION FOR CONCATENATION.
;CONCATENATES TWO VARIADIC SEQUENCES OF IDENTICAL TYPE.

SCONCA:	EXP	2		;TAKES TWO ARGUMENTS, ARG1 AND ARG2
	CALL	MKCNST		;COERCE FIRST ARG TO A CONSTANT
	  ILLTYPE		;ERROR
	MOVE	L,@ARGP
	HRRZ	R,L		;R_PZADR OF ARG1
	HLRZ	R2,(R)		;R2_DATA TYPE OF ARG1
	ANDI	R2,077777	;REMOVE GC,SYS AND CPY BITS
	MOVE	AC3,R2		;SAVE PZADR OF ARG1 IN AC3 FOR LATER
	ADD	R2,@IDTP	;R2_ABS ADR OF TYPE(ARG1)
	MOVE	R,(R2)		;R_IDT ENTRY FOR TYPE(ARG1)
	HLRZ	R2,R		;GET ID TYPE
	CAIE	R2,I.DDEF	;MUST BE DATA DEFINITION
	ILLTYPE
	HLRZ	AC2,(R)		;AC2_DATA TYPE OF DDEF
	ANDI	AC2,077777	;REMOVE GC,CPY AND SYS BITS
	CAIE	AC2,B.VSEQ	;SKIP IF WAS VARIADIC SEQUENCE
CONC2:	ILLTYPE
	HRRZ	B,(R)		;B_DZADR OF DDEF BLOCK
	GET 	AC2,TYPF	;AC2_REQUIRED ELEMENT TYPE
	ADDI	ARGP,1		;CONSIDER SECOND ARGUMENT
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	CALL	MKCNST		;COERCE ARG2 TO A CONSTANT
	  ILLTYPE		;ERROR
	MOVE	L,@ARGP
	HLRZ	R,(L)		;R_DATA TYPE OF ARG2
	ANDI	R,077777	;EXTRACT OFF GC,SYS AND CPY BITS
	CAME	R,AC3		;SEE IF ARG2 IS SAME TYPE AS ARG1
	JRST	CONC2		;IF NOT PRINT ERROR
	SUBI	ARGP,1		;POINT TO FIRST ARG AGAIN
	CAILE	AC3,LSTATM	;IF ELEMENTS NON-ATOMIC
	PUSHJ	P,LCOPY		;THEN COPY ARGUMENTS
	HRRZ	AC1,@ARGP	;AC1_PZADR OF ARG1
	HRRZ	AC7,(AC1)
	HRRE	AC7,1(AC7)	;AC7_UPPER BOUND OF ARG1
	PUSHJ	P,LENGT		;R=LENGTH(ARG1)
	MOVE	AC4,R		;STORE LENGTH OF ARG1 IN AC4
	ADDI	ARGP,1		;POINT TO 2ND ARG
	HRRZ	AC1,@ARGP	;AC1_PZADR OF ARG2
	PUSHJ	P,LENGT		;R=LENGTH(ARG2)
	MOVE	AC5,R		;STORE LENGTH OF ARG2 IN AC5
	MOVE	T,AC2		;SAVE ELEMENT TYPE IN T
	LSH	AC2,-1		;CONVERT ELEMENT TYPE INTO INDEX
	CAILE	AC2,LSTATM/2	;INTO LENGTH TABLE
	MOVEI	AC2,LSTATM/2+1	;AND USE IT TO GET SIZE OF ELEMENT
	MOVE	AC2,LTABL(AC2)	;IN BITS
	MOVE	AC1,AC4		;AC1_LENGTH(ARG1)+LENGTH(ARG2)
	ADD	AC1,AC5
	PUSHJ	P,BLOCK		;CALCULATE LENGTH OF BLOCK REQUIRED
	MOVEI	R2,2(R)		;R2_LENGTH OF BLOCK TO MAKE
	PUSHJ	P,MKBLK		;GO MAKE IT
	BLKARG	0,0(R2)		;PZADR IN R, DZADR IN R2
	HRRZ	B,(CAR)		;RECOMPUTE DZADR OF CAR
	HRLM	AC3,(R)		;STORE DATA TYPE IN LHS OF PZWORD
	ADD	AC7,AC5		;AC7_NEW UPPER BOUND
	HRRM	AC7,1(R2)	;STORE IN RESULT DATA BLOCK
	MOVEI	AC7,1(AC4)	;AC7_1+LENGTH(ARG1)
	JUMPE	AC4,CONC3	;GO TO CONC3 IF LENGTH(ARG1)=0
	SUBI	ARGP,1		;MAKE ARGP POINT TO ARG1
	MOVE	L,@ARGP		;GET ARG1
	HRRZ	L,(L)		;L_DZADR OF ARG1
	HLRZ	AC1,(L)		;AC1_WLENGTH(ARG1)
	SUBI	AC1,2		;AC1_WLENGTH(ARG1)-2
	ADDI	ARGP,1		;MAKE ARGP POINT TO ARG2
	JUMPE	AC1,CONC3	;GO TO CONC3 IF LENGTH IS 0
	MOVEI	AC2,1(R2)	;AC2_DZADR OF RESULT+1
	MOVEI	AC3,1(L)		;AC3_DZADR OF ARG1+1
	HRLI	AC2,AC1		;INDEX AC2 BY AC1
	HRLI	AC3,AC1		;INDEX AC3 BY AC1
CONC4:	MOVE	L,@AC3		;TRANSFER WORD FROM ARG1
	MOVEM	L,@AC2		;TO RESULT
	SOJG	AC1,CONC4	;GO AROUND IF MORE LEFT

	;DATA TRANSFER OF ELEMENTS OF ARG1 COMPLETE

CONC3:	MOVE	AC3,R		;AC3_PZADR OF RESULT
	MOVE	AC4,R2		;AC4_DZADR OF RESULT
	JUMPE	AC5,CONC5	;GO OUT IF LENGTH(ARG2)=0
	;HERE WE HAVE TO COMPUTE THE FIELD PARAMETERS OF
	;THE LENGTH(ARG1)+1ST ELEMENT.

	MOVE	AC1,AC7		;AC1_ORDINAL NO. OF ELEMENT, NOTE:
				;T=SAVED ELEMENT TYPE
	PUSHJ	P,FIELDP	;CALCULATE FIELD PARAMETERS
	HRRZ	L,@ARGP		;AC2=LENGTH,R=DISP,R2=BEG
	HRRZ	L,(L)		;L_DZADR OF ARG2
	MOVEI	AC7,2(L)	;AC7_BASE OF ARG2 PACKING ZONE
	MOVEI	AC6,2(AC4)	;AC6_BASE OF RESULT PACKING ZONE
	CAIN	AC2,^D72	;SKIP IF ELEMENT TYPE NOT =DBL
	JRST	CONC6		;GO TRANSFER DOUBLES

	;CALCULATE DESTINATION BYTE POINTER
	MOVEI	AC1,^D36	;AC1_36
	SUB	AC1,R2		;P=36-(BEG+LENGTH)
	SUB	AC1,AC2	
	LSH	AC1,6		;SHIFT AC1 LEFT SIX
	ADD	AC1,AC2		;ADD SIZE
	LSH	AC1,6		;SHIFT LEFT SIX MORE
	ADDI	AC1,AC6		;INDEX POINTER BY AC6
	HRL	R,AC1		;R_BYTE POINTER TO DESTINATION

	;CONSTRUCT BYTE POINTER FOR SOURCE
	MOVEI	AC1,^D36	;(AC2)=LENGTH,BEG=0
	SUB	AC1,AC2		;P=36-(BEG+LENGTH)
	LSH	AC1,6		;SHIFT AC1 LEFT SIX
	ADD	AC1,AC2		;ADD IN SIZE
	LSH	AC1,6		;SHIFT LEFT SIX MORE
	ADDI	AC1,AC7		;INDEX BYTE PTR BY AC7
	HRLZ	R2,AC1		;R2=BYTE POINTER FOR SOURCE

	;NOTE: (AC5)= NO. OF ELEMENTS TO BE TRANSFERRED
	LDB	AC1,R2		;FETCH BYTE FROM SOURCE
	DPB	AC1,R		;DEPOSIT BYTE IN DESTINATION
	SOJE	AC5,CONC5	;GO CONC5 , IF NO MORE LEFT
CONC8:	ILDB	AC1,R2		;TRANSFER BYTE FROM
	IDPB	AC1,R		;ARG2 TO RESULT
	SOJG	AC5,CONC8	;IF MORE GO AROUND

	;TRANSFER IS COMPLETE, SO EXIT

CONC5:	HRLI	AC3,(LXM(STAK,CONST)) ;MAKE CONST LEXEME
	MOVE	R,AC3		;STORE CONSTANT LEXEME IN R
	POPJ	P,		;AND EXIT

	;CODE TO TRANSFER DOUBLES 

CONC6:	ADD	AC6,R		;AC6=DISP+BASE ADR OF RESULT PCKNG ZONE
CONC9:	MOVE	AC1,(AC7)	;MOVE FIRST HALF OF
	MOVEM	AC1,(AC6)	;DOUBLE FROM ARG2 TO RESULT
	MOVE	AC1,1(AC7)	;MOVE SECOND HALF OF DOUBLE
	MOVEM	AC1,1(AC6)	;FROM ARG2 TO RESULT
	ADDI	AC7,2		;INCREMENT AC7 AND AC6 BY TWO EACH
	ADDI	AC6,2
	SOJG	AC5,CONC9	;GO AROUND IF MORE LEFT,
	JRST	CONC5		;ELSE GO OUT.


	LIT
	END