Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0078/comp/sd.mac
There are 2 other files named sd.mac in the archive. Click here to see a list.
	SUBTTL	SD module

;NAME:	SD
;====

;AUTHOR:	Kim Walden
;======		Claes Wihlborg

;VERSION:	3A [1,3,4,12,13,40,144,202]

;PURPOSE:	To keep track of BLOCK LEVELS
;=======	

;ENVIRONMENT:	SD is called by:	EXEC <entry point name>
;===========	and returns control by: RETURN


COMMENT;

Syntax Dispatch, SD, is part of PASS 1 and prepares
the setting up of a file DF1. SD will produce a list of records
(DCZQU, DCZHE and DCZHB) in which all declared entities will
have been properly rearranged, so that module DP may later scan
through the list once, linearly, and produce DF1.
The rearrangements are effected in one pass, simultaneously
with the syntax recognition. SR successively calls SD, when
encountering a declaration or the beginning
or end of a block, and SD keeps track of the nesting level
with the aid of a block stack (described below), consisting of 64 levels.

On each level, five sublists are maintained and are linked to the proper
sublist(s) of the nearest lower stack level when leaving a block,
until finally remains, when the outermost block is completed, a linear
list, properly ordered.

SD contains 12 ENTRY POINTS:

SDBEG, SDEND, SDZQU, SDSPEC, SDESPE, SDHID, SDABEG, SDALLOC, SDPEND, SDEXT, SDPPN

;
COMMENT;

Block Stack used by SD: (Contains 64 levels, each comprising 7 words)

offset

	0			      17 18			      35
       I--------------------------------I-------------------------------I
  0    I	start of list 1		I	  end of list 1		I
       I--------------------------------I-------------------------------I


	0			      17 18			      35
       I--------------------------------I-------------------------------I
  1    I	start of list 2		I	  end of list 2		I
       I--------------------------------I-------------------------------I


	0			      17 18			      35
       I--------------------------------I-------------------------------I
  2    I	start of list 3		I	  end of list 3		I
       I--------------------------------I-------------------------------I


	0			      17 18			      35
       I--------------------------------I-------------------------------I
  3    I	start of list 4		I	  end of list 4		I
       I--------------------------------I-------------------------------I


	0			      17 18			      35
       I--------------------------------I-------------------------------I
  4    I	start of list 5		I	  end of list 5		I
       I--------------------------------I-------------------------------I


	0 1			      17 18			      35
       I--------------------------------I-------------------------------I
  5    I	     ZHSOBL		I	      ZHSLSB		I
       I-I------------------------------I-------------------------------I
  6    I*I	     ZHSRBC		I	      ZHSAST		I
       I-I------------------------------I-------------------------------I

* = ZHSRFL


ZHSOBL = own block length
ZHSLSB = length of largest subblock
ZHSRFL = reduced subblock flag
ZHSRBC = reduced subblock count
ZHSAST = start offset for this block


list 1:	All DCZQU:s on this level, not in list 2 or list 3.
	This list starts with a DCZHE or a DCZHB.

list 2: DCZQU:s of OBJECT REFERENCE variables and ARRAY variables
	of this level.

list 3:	DCZQU:s of SIMPLE TEXT variables of this level.

list 4:	HIDDEN attributes (DCZQU:s) followed by
	ATTRIBUTE sublists interior to this level.

list 5:	PROTECTED attributes (DCZQU:s)  followed by
	BLOCK sublists interior to this level

;
COMMENT;
Assignments to certain fields, performed by SDBEG and SDEND on call:
(remarks on used notation is given below)


				    SDBEG
		------------------------------------------------
					 ZHS
block type	ZHE  ZHE  ZHE  ZHB  ZHB  OBL  ZHE  ZHS  ZHS  ZHS
----- ----	SOL  DLV  EBL  SBL  KDP  ZHE  BNM  RFL  RBC  AST
					 LEN
		------------------------------------------------

QFOR	(ZHE)	+1   -1			  0    0   off   0    0

							     ast
QRBLOCK	(ZHE)	+1   +0   +0		  0  rbc+1 on  rbc+1  +
							     obl

QUBLOCK	(ZHE)	+1   -1   +0		  2    0   on    0    0


QPROCB	(ZHB)	+1   -1   DLV  ebl   0  2/3/4  0   on    0    0

							     ast
QPROCB	(ZHE)	+0   +0   +0		  0    0   on    0    +
							     obl

QPBLOCK	(ZHB)	+1   -1   DLV  ebl   0    0    0   on    0    0


QCLASB	(ZHB)	+1   -1   DLV  ebl   &   0/2   0   off   0    0


QINSPEC	(ZHB)	+1   -1   +0    0    0    0    0   off   0    0



Remarks:	Current level is the new level, just being constructed,
		in case of SDBEG, and the level being current before
		the stacklevel is decremented, in case of SDEND.

		The fields of current level are furnished by the values
		of the corresponding table entries, as a result of a call
		to either SDBEG or SDEND. Entries preceded by + or - are
		values relative to the contents of the same field of
		nearest lower level.

		Furthermore upper case letters in an entry means
		the value of the corresponding field of CURRENT level, e.g. RBC,
		and lower case letters denotes the value of the same field
		of the nearest lower level, e.g. rbc.


		      SDEND
		------------------
block type	ZHE  ZHE  zhs  zhs
		LEN  BNM  rbc  lsb
		------------------

QFOR	(ZHE)	 0    0    -    -


		OBL
QRBLOCK	(ZHE)	 +    -   RBC  max(lsb,OBL+LSB)
		LSB

		OBL
QUBLOCK	(ZHE)	 +    0    -    -
		LSB

		OBL
QPROCB	(ZHB)	 +    0    -    -
		LSB

		OBL
QPROCB	(ZHE)	 +    0    -   OBL+LSB
		LSB

		OBL
QPBLOCK	(ZHB)	 +    0    -    -
		LSB


QCLASB	(ZHB)	OBL   0    -    -



QINSPEC	(ZHB)	 0    0    -    -


;
	SALL
	SEARCH	SIMMC1,SIMMAC,SIMMCR
	CTITLE SD (SYNTAX DISPATCH)
	MACINIT
	TWOSEG
	RELOC	400000

;FIELD DEFINITIONS:
;===== ===========

;	DF	(ZHSOBL,5,18,17)	;own block length
	DF	(ZHSLSB,5,18,35)	;largest subblock length
	DF	(ZHSRBC,6,17,17)	;reduced subblock count
;	DF	(ZHSAST,6,18,35)	;start offset for this block
;	DSW	(ZHSRFL,6,0)		;if on, subblocks are to be reduced


;MACRO DEFINITIONS:
;===== ===========

DEFINE ERROR(NR,TYP,MESSAGE)<
;	IFN QDEBUG,<
;		OUTSTR	[ASCIZ/MESSAGE
;/]>
	IFN QERIMP,<
		ERR'TYP	QE,Q1SD.E+NR
	>
	SETONA	YERNC
>

DEFINE ERR1<
	L	YSMLIN
	ST	YELIN1
	L	YSMSEM
	ST	YESEM
	CLEARM	YELIN2>

DEFINE ERR2<
	LF	X0,ZQUTEM(XPTR)
	ST	YELIN1
	ST	YELIN2
	CLEARM	YESEM
	LF	X1,ZQULID(XPTR) >

DEFINE	CHKSP(ATYP,ZTYP)	;used in sdspec
<	LF	X1,ZTYP(,ATYP)
	IF	JUMPE	X1,FALSE
	THEN	LF	,ZTYP(XPTR)
		JUMPN	SDSPER
		SF	X1,ZTYP(XPTR)
	FI >

DEFINE .EXIT(A)<L9()>
;ASSEMBLY TIME VARIABLES:
;======== ==== =========

QMXLEN=^D1023		;max block length
QMXNRP=^D255		;max number of param
QMXBNM=^D511		;max reduced subbl count
QMXVRT=^D255		;max number of virtuals
QEXMSK=7777		;used to test for external id
QERRST=0		;first error number

;LOCAL VARIABLES:
;===== =========

	EXTERN	YC1DC	;next free zde-record
	EXTERN	YSWCHA
	EXTERN	YSRIN,YSREN,YSRDEV,YSRPPN
	EXTERN	YLSVAL
	EXTERN	.JBREL	;top of low segment
	EXTERN	ZSE1
	EXTERN	YBSTP	;current stack level
	EXTERN 	YASTR	;array start dczqu
	EXTERN	YDLV	;giving compilation level
	EXTERN	YSDENL	;linkage list used by sdend
	EXTERN	O1SFDC	;[144] Copies SFD record
	EXTERN	O1XR	;outp routine for cross ref
	EXTERN	T1AB	;termination error routine
	EXTERN	YDPD,YELIN1,YELIN2,YESEM,YMPSIZ,YSMLIN,YSMSEM
	EXTERN	YBHREL,I1RX50
	EXTERN	YRELBL	;[3] Set to [-1,,0] for global class/proc, zero for main
	EXTERN	YSIMNAME;[13] Name of global class/proc (RADIX50)
	EXTERN	YEXZQU	;[144] Start of chain of ZQU's for external specs
	EXTERN	YEXTS	;[144] File lookup info
	EXTERN	YZQUGLO	;[144] Copy of global ZQU for finding ATR file
	EXTERN	YSFD,YSFDP,YSFDN,YSFDPPN,YSFD1 ;[144] Temp SFD info

	EXTERN	SH	;[144] Symbol hash

;ENTRY POINTS:
;===== ======
	INTERN	SDBEG
	INTERN	SDEND
	INTERN	SDZQU
	INTERN	SDEXT
	INTERN	SDSPEC
	INTERN	SDESPE
	INTERN	SDHID	;[40]
	INTERN	SDABEG
	INTERN	SDAEND
	INTERN	SDPPN
	INTERN	SDALLOC
	INTERN	SDPEND

;REG ASSIGNMENTS FOR SD:
;=== =========== === ==

XSTACP=4	;current stack level, never saved
;XALLOC=10	;points to new record allocated by SDALLOC
	SUBTTL	submodule SDBEG


COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	This routine is called by SR on each
		entry to a BLOCK, a CLASS body or a PROCEDURE body.
		It allocates a new DCZQU or DCZHB - record, and
		sets the values of certain fields in this record,
		according to TABLE above.

ERROR conditions:	Block Stack overflow


calling ARGUMENTS:	reg:	contents of right half


				 18    20 21    23 24              35
				I--------I--------I------------------I
			X1SR1	I ZDETYP I ZHETYP I		     I
				I--------I--------I------------------I



				 18             23 24              35
				I-----------------I------------------I
			X1SR2	I         0       I    ZHEFIX        I
				I-----------------I------------------I


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;REG ASSIGNMENTS FOR SDBEG
;=== =========== === =====

XTAG=2		;used to hold ZDETYP
XEBL=3		;used to hold ZHEEBL
XTYP=5		;used to hold ZHETYP
XSOL=7		;used to hold ZHESOL
XDLV=11		;used to hold ZHEDLV
XLEN=14		;start offset of certain block types

	PROC
SDBEG:	IFONA	YBSOV
	RETURN
	XALLO==XALLOC	;[202]
	SAVE	<XSOL,XDLV,XALLO,X1SR1,X1SR2> ;[202]
	L	XSTACP,YBSTP
	MOVSS	X1SR1
	LF	XTAG,ZDETYP(,X1SR1)
;allocate 3 word if ZHE, 4 words if ZHB
	L	[XWD 3,3]
	CAIE	XTAG,QQZHE
	L	[XWD 4,4]
	EXEC	SDALLO
;if stack full, then error
	CAILE	XSTACP,YDPD+77*QSTLL
	GOTO	SDERR0
;push stack, set pointers to start and end of list 1
;and clear remainder of stack level
	ADDI	XSTACP,QSTLL
	ST	XSTACP,YBSTP
	SF	XALLOC,ZHSSTR(XSTACP)
	SF	XALLOC,ZHSEND(XSTACP)
	SETZB	X0,X1
	STD	1(XSTACP)
	STD	3(XSTACP)
	STD	5(XSTACP)
;set ZDETYP,ZHETYP and ZHEFIX
	HLLM	X1SR1,(XALLOC)
	SF	X1SR2,ZHEFIX(XALLOC)
	LF	XTYP,ZHETYP(,X1SR1)

XPRVZH=X1SR1
XPRVZQ=X1SR2

;only to be used when valid pointers
	LF	XPRVZH,ZHSSTR(XSTACP,-QSTLL)
	LF	XPRVZQ,ZHSEND(XSTACP,-QSTLL)
;if outermost block, get start values for DLV,EBL,SOL into regs
;if not, get values from lower level
	IF	CAIE	XSTACP,YDPD+QSTLL
		GOTO	FALSE
	THEN	L	XDLV,YDLV
		MOVN	XEBL,XDLV
		SETZ	XSOL,
		IFON	YSWCE
		LI	XEBL,0
	ELSE
		LF	XSOL,ZHESOL(XPRVZH)
		LF	XDLV,ZHEDLV(XPRVZH)
		HRRE	XDLV,XDLV
		LF	XEBL,ZHEEBL(XPRVZH)
	FI
	SETZ	XLEN,
	CAIE	XTAG,QQZHE
	GOTO	.ZHB
;ZHE found
.ZHE:	SETON	ZHSRFL(XSTACP)
	CAIN	XTYP,QPROCB
	GOTO	.AST
;RBLOCK or FOR
	ADDI	XSOL,1
	CAIE	XTYP,QFOR
	GOTO	.RED
;FOR-block
	SETOFF	ZHSRFL(XSTACP)
	SUBI	XDLV,1
	GOTO	.SOL
.RED:	L	X1,XSTACP
	SUBI	X1,QSTLL
	IFOFF	ZHSRFL(X1)
	GOTO	.URD
;to be reduced
	LF	,ZHSRBC(XSTACP,-QSTLL)
	ADDI	1
	CAILE	QMXBNM
	EXEC	SDERR8
	SF	,ZHSRBC(XSTACP)
	SF	,ZHEBNM(XALLOC)
.AST:	LF	,ZHSAST(XSTACP,-QSTLL)
	LF	X1,ZHSOBL(XSTACP,-QSTLL)
	ADD	X1
	SF	,ZHSAST(XSTACP)
	GOTO	.SOL
;to be unreduced
.URD:	LI	XTYP,QUBLOCK
	SF	XTYP,ZHETYP(XALLOC)
	SUBI	XDLV,1
	LI	XLEN,2
	GOTO	.OBL
;ZHB found
.ZHB:	ADDI	XSOL,1
	SUBI	XDLV,1
	SETZM	3(XALLOC)
	IF	IFOFF	YSWCE
		GOTO	FALSE
	THEN	SETON	ZHBEXT(XALLOC)
	FI
	IF	CAIGE	XTYP,QCLASB
		GOTO	FALSE
	THEN	;class/inspect
		SETOFF	ZHSRFL(XSTACP)
		CAIE	XTYP,QCLASB
		GOTO	.SOL
		;class
		LF	,ZQUQID(XPRVZQ)
		SKIPN
		LI	XLEN,2
		CAIN	XSTACP,YDPD+QSTLL
		GOTO	.SBL
		;not outermost level
		LF	,ZHETYP(XPRVZH)
		CAIE	QCLASB
		GOTO	.SBL
		SETON	ZHBKDP(XPRVZH)
		GOTO	.SBL
	FI
;proc(ZHB)/pblock
	SETON	ZHSRFL(XSTACP)
	CAIE	XTYP,QPROCB
	GOTO	.SBL
;proc(ZHB)
	LI	XLEN,2
	LF	,ZQUTYP(XPRVZQ)
	IF	CAIN	QNOTYPE
		GOTO	FALSE
	THEN	LI	XLEN,3
		CAIN	QLREAL
		LI	XLEN,4
		CAIN	QTEXT
		LI	XLEN,4
	FI
	IF	IFOFFA	YSWEFO
		GOTO	FALSE
	THEN	SETF	QEXFOR,ZHBMFO(XALLOC)	;[4]
		LI	XLEN,YFOPAD+1
	ELSE
	IF	IFOFFA	YSWEM
		GOTO	FALSE
	THEN	SETF	QEXMAC,ZHBMFO(XALLOC)	;[4]
	ELSE
	IF	IFOFFA	YSWEMN
		GOTO	FALSE
	THEN	SETON	ZHBNCK(XALLOC)
		SETF	QEXMAC,ZHBMFO(XALLOC)	;[13]
	ELSE
	IF	IFOFFA	YSWE40
		GOTO	FALSE
	THEN	SETF	QEXF40,ZHBMFO(XALLOC)	;[4]
		LI	XLEN,YFOPAD+1
	FI FI FI FI ;[4] Allow YSWEMQ together with YSWEMN
	IF	;[4]
		IFOFFA	YSWEMQ	;[4]
		GOTO	FALSE	;[4]
	THEN	SETF	QEXMQI,ZHBMFO(XALLOC)	;[4]
	FI
.SBL:	SF	XEBL,ZHBSBL(XALLOC)
	MOVN	XEBL,XDLV
.OBL:	SF	XLEN,ZHSOBL(XSTACP)
	SF	XLEN,ZHELEN(XALLOC)
.SOL:	SF	XSOL,ZHESOL(XALLOC)
	SF	XDLV,ZHEDLV(XALLOC)

	CAIL	XEBL,QMAXDIS		;[12] Error if more than
	EXEC	SDER22			;[12] 30 display levels

	SF	XEBL,ZHEEBL(XALLOC)
.EXIT():RETURN

SDERR0:	ERR1
	ERROR	(0,,BLOCK STACK OVERFLOW)
	SETONA	YBSOV
	SETONA	YERNP2
	GOTO	.EXIT
	EPROC
PURGE	XEBL,XSOL,XDLV,XLEN,XTAG,XTYP,XPRVZH,XPRVZQ
	SUBTTL	submodule SDEND

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	Called by SR on EXIT from a BLOCK, a CLASS body or
		a PROCEDURE body.
		It links the lists of the current STACK level
		together in a proper way, and ties them to the previous
		level.
		Furthermore it completes the fields of the records
		corresponding to this level according to TABLE above.

ERROR conditions:	Too large BLOCK LENGTH
			Too many REDUCED SUBBLOCKS

calling ARGUMENTS: NONE

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;REG ASSIGNMENT FOR SDEND
;=== ========== === =====

XTAG=2		;used to hold ZDETYP
XZH=3		;pointer to current ZHE/ZHB
XTYP=5		;used to hold ZHETYP
XENP=7		;stack entry of list to be extended
XSTP=10		;stack entry of list to be appended
XEN=11		;last record of list to be extended
XST=12		;first record of list to be appended
XPTR=13		;work pointer

	PROC
SDEND:	IFONA	YBSOV
	RETURN		
	SAVE	<XTAG,XZH,XENP,XSTP,XEN,XST,XPTR>
	L	XSTACP,YBSTP
	LF	XZH,ZHSSTR(XSTACP)	;point to current ZHE/ZHB
	LF	XTAG,ZDETYP(XZH)
	LF	XTYP,ZHETYP(XZH)
	IF	;Class then protect attributes [40]
		CAIN	XTAG,QQZHB
		CAIE	XTYP,QCLASB
		GOTO	FALSE
	THEN
		EXEC	SDPRO	;Protect attributes
	FI
;if proc(ZHB) or class(ZHB) prepare linkage to previous list 4
;else to prev list 5
	LI	4-QSTLL
	CAIE	XTAG,QQZHB
	GOTO	.FIX
	CAIE	XTYP,QPROCB
	CAIN	XTYP,QCLASB
	SUBI	1
.FIX:	HRLM	YSDENL+3
;go through YSDENL and for each entry,
;link together the two lists referred to
	LI	XPTR,YSDENL
	WHILE	LF	XENP,ZHSSTR(XPTR)
		ADD	XENP,XSTACP
		LF	XSTP,ZHSEND(XPTR)
		ADD	XSTP,XSTACP
		LF	XST,ZHSSTR(XSTP)
		LF	XEN,ZHSEND(XENP)
		JUMPE	XST,TRUE	;jump if nothing to append
		IF	JUMPN	XEN,FALSE
		THEN	;nothing to extend
			SF	XST,ZHSSTR(XENP)
		ELSE
			SF	XST,ZDELNK(XEN)
		FI
		LF	XST,ZHSEND(XSTP)
		SF	XST,ZHSEND(XENP)
	DO	ADDI	XPTR,1
		SKIPE	(XPTR)
	OD
;calculate offset start
RNAME <XOFS,XRBC>,<XENP,XSTP>
	CAIN	XTYP,QINSPEC
	GOTO	.EXIT
	CAIN	XTYP,QFOR
	GOTO	.EXIT
	LF	XPTR,ZHSSTR(XSTACP)
	LF	XOFS,ZHSAST(XSTACP)
	LF	,ZHELEN(XZH)
	ADD	XOFS,X0
;go through compound list and for each ZQU,
;calculate OFFSET and store in ZQUIND
	WHILE	LF	XPTR,ZDELNK(XPTR)
		JUMPE	XPTR,FALSE
		LF	,ZDETYP(XPTR)
		CAIE	QQZQU
		GOTO	FALSE
	DO	IF	IFOFF	ZQULEN(XPTR)
			GOTO	FALSE
		THEN	;ZQUIND contains length
			LF	,ZQUIND(XPTR)
			SF	XOFS,ZQUIND(XPTR)
			ADD	XOFS,X0		;incr OFFSET counter
			SETOFF	ZQULEN(XPTR)
		FI
	OD
;form ZHSOBL+ZHSLSB
	LF	,ZHSOBL(XSTACP)
	LF	X1,ZHSLSB(XSTACP)
	ADD	X1
;set length
	CAILE	QMXLEN
	EXEC	SDERR7
	SF	,ZHELEN(XZH)
;if proc(ZHE) then update ZHSLSB
	IF	CAIN	XTYP,QPROCB
		CAIE	XTAG,QQZHE
		GOTO	FALSE
	THEN	SF	,ZHSLSB(XSTACP,-QSTLL)
	FI
	CAIE	XTYP,QRBLOCK
	GOTO	.EXIT
;reduced block
	LF	X1,ZHSLSB(XSTACP,-QSTLL)
	IF	CAMG	X1
		GOTO	FALSE
	THEN	;OBL+LSB>previous LSB
		SF	,ZHSLSB(XSTACP,-QSTLL)
	FI
	LF	XRBC,ZHSRBC(XSTACP)
	SF	XRBC,ZHSRBC(XSTACP,-QSTLL)
.EXIT():SUBI	XSTACP,QSTLL		;pop block stack
	ST	XSTACP,YBSTP
	RETURN
	EPROC
PURGE XZH,XST,XEN,XOFS,XRBC,XTAG,XTYP

;YSDENL:	XWD	0,1
;		XWD	0,2
;		XWD	0,3
;		XWD	4-QSTLL/3-QSTLL,0
;		XWD	4-QSTLL,4
;		XWD	0,0

SDERR7:	PROC
	ERR1
	ERROR(7,,TOO LARGE BLOCK LENGTH)
	RETURN
	EPROC

SDERR8:	PROC
	ERR1
	ERROR(8,,TOO MANY REDUCED SUBBLOCKS)
	RETURN
	EPROC
	SUBTTL	submodule SDZQU

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	Sets up a new DCZQU record, links it properly into
		the DC list (of current level), and sets values to
		fields in the record, according to input arguments.

ERROR conditions:	NONE

calling ARGUMENTS:	ac:	contents of right half


				 18         23 24                  35
				I-------------I----------------------I
			X1CUR	I      0      I        ZQULID        I
				I-------------I----------------------I


				 18    20        26    29 30 32 33 35
				I--------I------I--------I-----I-----I
			X1SR1	I ZDETYP I  0   I ZQUTYP I MOD I KND I
				I--------I------I--------I-----I-----I


				 18				   35
				I------------------------------------I
			X1SR2	I		ZQUIND               I
				I------------------------------------I


				 18				   35
				I------------------------------------I
			X1SR3	I		ZQUQID		     I
				I------------------------------------I


				 18				   35
				I------------------------------------I
	     mem loc: YLSCLIN	I		ZQULNE		     I
				I------------------------------------I

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;AC ASSIGNMENTS FOR SDZQU:
;== =========== === =====

XKND=2		;used to hold ZQUKND
XLEN=3		;length of decl var
XTYP=5		;used to hold ZQUTYP
XPTR=7		;work pointer
	PROC
SDZQU:	IFONA	YBSOV
	RETURN		
	IF	IFONA	YSWC
		CAIGE	X1CUR,QLOWID
		GOTO	FALSE
	THEN	;output symbol to cross ref table
		TRO	X1CUR,1B18
		EXEC	O1XR
		TRZ	X1CUR,1B18
	FI
	XALLO==XALLOC	;[202]
	SAVE	<XKND,XLEN,XPTR,XALLO>	;[202]
	L	XSTACP,YBSTP
	L	[XWD 3,3]
	EXEC	SDALLOC		;allocate 3 zero words
	HRLM	X1SR1,(XALLOC)	;set ZDETYP,ZQUTYP,ZQUMOD,ZQUKND
	LF	,YLSCLIN
;set fields
	SF	,ZQUTEM(XALLOC)
	SF	X1CUR,ZQULID(XALLOC)
	SF	X1SR3,ZQUQID(XALLOC)
	LF	XTYP,ZQUTYP(XALLOC)
	SETZ	XPTR,
	IF
		JUMPE	XTYP,FALSE	;jump if QUNDEF
		LF	,ZQUMOD(XALLOC)
		CAIN	QVIRTUAL
		GOTO	FALSE
	THEN	;not VIRTUAL or FORMAL
		LF	XKND,ZQUKND(XALLOC)
		IF	
			CAIE	XTYP,QLABEL
			CAIN	XKND,QPROCE
			GOTO	TRUE
			CAIE	XKND,QCLASS
			GOTO	FALSE
		THEN	;label,procedure or class
			SF	X1SR2,ZQUIND(XALLOC)
			IF	;This represents the outermost block
				CAIN	XSTACP,YDPD	;(bottom of block stack)
				CAIN	XTYP,QLABEL
				GOTO	FALSE
			THEN	;[1] replace the name .MAIN in the REL file
				SETON	ZQUGLO(XALLOC)
				L	YZSE1(X1CUR)
				EXEC	I1RX50
				ST	YSIMNAME	;[13] Record the name
				HRRZ	X1,YBHREL
				ST	7(X1)	;[1] Change name (in name block)
				ST	4(X1)	;[1] Also in entry block
				HRROS	YRELBL	;[3] Signal external class/proc
				;[144]  Copy ZQU for inclusion in YEXZQU list
				;	Also make a ZHB
				STACK	X1NXT
				LD	(XALLOC)
				ZF	ZQUIND
				STD	YZQUGLO
				;Dummy ZHB
				SETZB	X1ID2,X1NXT
				L	X1ID1,YEXTS+11	;[144] REL file device
				IF	;Device given
					JUMPE	X1ID1,FALSE
				THEN	;Find its internal id number
					SETOFA	YZSE	;New entries allowed
					EXEC	SH
				FI
				SF	X1NXT,ZHBDEV(,YZQUGLO+3)
				L	X1ID1,YEXTS+4	;REL file name
				EXEC	SH
				SF	X1NXT,ZHBXID(,YZQUGLO+3)
				L	X1,YEXTS+7	;PPN
				IF	;PPN = 0
					JUMPN	X1,FALSE
				THEN	;Explicit request if filename differs
					; from SIMULA name
					L	YEXTS+4	;File name
					CAME	YZSE1(X1CUR)
					SETO	X1,	;Signal with ppn=-1
				FI
				SF	X1,ZHBPPN(,YZQUGLO+3)
				LI	YZQUGLO
				EXEC	SDZQUC	;Put the copy on a chain
				UNSTK	X1NXT
			FI
		ELSE
			LI	XLEN,1
			LI	XPTR,1
			IF
				CAIE	XTYP,QREF
				CAIN	XKND,QARRAY
				AOJA	XPTR,FALSE
			THEN
				CAIN	XTYP,QLREAL
				SOSA	XPTR
				CAIN	XTYP,QTEXT
				AOSA	XLEN
				SUBI	XPTR,1
			FI
			SF	XLEN,ZQUIND(XALLOC)	
			SETON	ZQULEN(XALLOC)	
			LF	,ZHSOBL(XSTACP)	
			ADD	XLEN			
			SF	,ZHSOBL(XSTACP)	
		FI
	FI

RNAME <XPRV>,<XKND>

;establish link to prev record
	ADD	XPTR,XSTACP	
	IF
		SKIPE	(XPTR)	;skip if list empty
		GOTO	FALSE
	THEN
		SF	XALLOC,ZHSSTR(XPTR)	
	ELSE
		LF	XPRV,ZHSEND(XPTR)	;point to last rec
		SF	XALLOC,ZDELNK(XPRV)
	FI
	SF	XALLOC,ZHSEND(XPTR)
	RETURN
	EPROC
PURGE	XLEN,XTYP,XPTR
	SUBTTL	submodule SDEXT

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:		SDEXT is called for every external item in the
			source text. It creates one ZQU, one ZHB and
			one ZHE(QQUACH) record. However not all information
			is available but is inserted by DP when reading the
			corresponding ATR-file.

Entry conditions:

				 18    20 21    23 24              35
				I--------I--------I------------------I
			X1SR1	I ZDETYP I ZHETYP I		     I
				I--------I--------I------------------I


				 18    20        26    29 30 32 33 35
				I--------I------I--------I-----I-----I
			X1SR2	I ZDETYP I  0   I ZQUTYP I MOD I KND I
				I--------I------I--------I-----I-----I


				 18				   35
				I------------------------------------I
			X1SR3	I		ZQUQID		     I
				I------------------------------------I


			YSRIN	Internal id-no
			YSREN	External id-no (name of ATR-file)
			YSRDEV	Device of ATR-file
			YSRPPN	PPN of ATR-file

			YLSLLIN	Line no of declaration


ERRORS:
			External must be copied into main
			External must not be copied indirectly
			External must not be attribute

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

XPTR==2
XDLV==3
XSOL==4

	PROC
SDEXT:
	IFONA	YBSOV
	RETURN
	XALLO==XALLOC	;[202]
	SAVE	<XALLO,X1CUR,XPTR,XDLV,XSOL> ;[202]

	L	[13,,13]
	EXEC	SDALLOC
	SKIPN	X1CUR,YSRIN
	L	X1CUR,YSREN
	TRO	X1CUR,3B19
	IFONA	YSWC
	EXEC	O1XR
	TRZ	X1CUR,3B19

;create ZQU

	SF	X1CUR,ZQULID(XALLOC)
	HRLM	X1SR1,(XALLOC)
	SETON	ZQUEXT(XALLOC)
	LF	,YLSLLIN
	SF	,ZQUTEM(XALLOC)
	SF	X1SR3,ZQUQID(XALLOC)
	L	XPTR,YBSTP
;link ZQU
	IF
		SKIPE	(XPTR)
		GOTO	FALSE
	THEN
		SF	XALLOC,ZHSSTR(XPTR)
	ELSE
		LF	X1,ZHSEND(XPTR)
		SF	XALLOC,ZDELNK(X1)
	FI
	SF	XALLOC,ZHSEND(XPTR)
	LI	(XALLOC)	;[144]
	EXEC	SDZQUC		;[144] Put on YEXZQU chain

;create ZHB

	ADDI	XALLOC,3
	HRLM	X1SR2,(XALLOC)
	IF	;we are now at block stack bottom
		CAIE	XPTR,YDPD
		GOTO	FALSE
	THEN	;we have an external declaration outside the program
		LI	XDLV,0
		LI	XSOL,1
		IF
			IFON	YSWCE
			GOTO	FALSE
		THEN	;outside MAIN
			EXEC	XER1
		FI
	ELSE	;EXTERNAL is copied
		LF	X1,ZHSSTR(XPTR)
		LF	XDLV,ZHEEBL(X1)
		SF	XDLV,ZHBSBL(XALLOC)
		LF	XDLV,ZHEDLV(X1)
		SUBI	XDLV,1
		LF	XSOL,ZHESOL(X1)
		ADDI	XSOL,1
		IF
			IFOFF	YSWCE
			GOTO FALSE
		THEN	;indirect copying
			EXEC	XER2
		FI
		IF
			LF	,ZHETYP(X1)
			CAIE	QCLASB
			GOTO	FALSE
		THEN	;EXTERNAL as attribute
			EXEC	XER3
		FI
	FI
	SF	XDLV,ZHEDLV(XALLOC)
	MOVN	XDLV,XDLV

	CAIL	XDLV,QMAXDIS	;[12]	TEST ON MAX DISPLAY LEVEL
	EXEC	SDER22		;[12]

	SF	XDLV,ZHEEBL(XALLOC)
	SF	XSOL,ZHESOL(XALLOC)
	L	YSRDEV
	SF	,ZHBDEV(XALLOC)
	L	YSREN
	SF	,ZHBXID(XALLOC)
	SKIPE	X1,YSFDN	;[144] If SFD's were present in file spec
	EXEC	SDMSFD		;[144] Make new SFD record
	L	YSRPPN
	SF	,ZHBPPN(XALLOC)
;link ZHB
	IF
		SKIPE	3(XPTR)
		GOTO	FALSE
	THEN	;ATR list empty
		SF	XALLOC,ZHSSTR(XPTR,3)
	ELSE
		LF	X1,ZHSEND(XPTR,3)
		SF	XALLOC,ZDELNK(X1)
	FI
	SF	XALLOC,ZHSEND(XPTR,3)

;create ZHE(QQUACH)

	ADDI	XALLOC,5
	ADDI	X1CUR,(BYTE (3)QQZHE,QQUACH(30)0)
	MOVSM	X1CUR,(XALLOC)
	SETOM	1(XALLOC)
;link ZHE
	IF
		SKIPE	4(XPTR)
		GOTO	FALSE
	THEN	;subblock list empty
		SF	XALLOC,ZHSEND(XPTR,4)
		SETZM	2(XALLOC)
	ELSE
		LF	X1,ZHSSTR(XPTR,4)
		SF	X1,ZDELNK(XALLOC)
	FI
	SF	XALLOC,ZHSSTR(XPTR,4)

	RETURN
	EPROC

XER1:	PROC
	ERR1
	ERROR(11,,EXTERNAL MUST BE COPIED INTO MAIN)
	RETURN
	EPROC

XER2:	PROC
	ERR1
	ERROR(12,,EXTERNAL MUST NOT BE INDIRECTLY COPIED)
	RETURN
	EPROC

XER3:	PROC
	ERR1
	ERROR(13,,EXTERNAL MUST NOT BE ATTRIBUTE)
	RETURN
	EPROC

		;[12] NEW ERROR MESS.
SDER22:	PROC
	ERR1
	ERROR(22,,DISPLAY SIZE OVERFLOW)
	RETURN
	EPROC

SDZQUC: PROC	;[144] (New) Put ZQU on chain of externals
		;Input:	X0 :- ZQU record
	MOVS	X1,YEXZQU	; X1:=[first ZQU on chain,,last]
	IF	; List is still empty
		JUMPN	X1,FALSE
	THEN	;Start with this ZQU
		ST	YEXZQU
	ELSE	;Chain it
		SF	,ZQUIND(X1)
	FI	;
	HRLM	YEXZQU	; Remember this as last ZQU
	RETURN
	EPROC

SDMSFD::PROC	;[144] Make SFD path from YSFD table
	SAVE	X2
	LI	X1,YSRPPN
	SETZ	X2,	;Make the copy, allocating a new record and updating
	EXEC	O1SFDC	;YSRPPN to point to the new copy
	RETURN
	EPROC
	SUBTTL	submodule SDSPEC

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	Called by SR when encountering a parameter specification.
		It sets the corresponding field in the DCZQU record.


ERROR conditions:	specified but not FORMAL
			parameter previously specified


calling ARGUMENTS:	reg:	contents of right half


				 18              26    29 30 32 33 35
				I---------------I--------I-----I-----I
			X1SR1	I       0       I ZQUTYP I MOD I KND I
				I---------------I--------I-----I-----I


				 18         23 24                  35
				I-------------I----------------------I
			X1CUR	I      0      I        ZQULID        I
				I-------------I----------------------I


				 18				   35
				I------------------------------------I
			X1SR3	I		ZQUQID		     I
				I------------------------------------I

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;REG ASSIGNMENTS FOR SDSPEC:
;=== =========== === ======

XPTR=5		;work pointer

	PROC
SDSPEC:	IFONA	YBSOV
	RETURN		
	SAVE	<X1SR1,XPTR>
	L	XSTACP,YBSTP
	LF	XPTR,ZHSSTR(XSTACP)	;point to DCZHB
XSPEC=X1SR1
	MOVSS	XSPEC
	WHILE	LF	XPTR,ZDELNK(XPTR)	;point to next record
		JUMPE	XPTR,SDERR2
	DO	LF	,ZQULID(XPTR)
		CAME	X1CUR
	OD
;match found
	CHKSP	(XSPEC,ZQUTYP)
	CAIN	X1,QREF
	SF	X1SR3,ZQUQID(XPTR)
	CHKSP	(XSPEC,ZQUMOD)
	CHKSP	(XSPEC,ZQUKND)
	RETURN

SDERR2:
	L	X1,X1CUR
	ERR1
	ERROR(2,I1,XXXX SPECIFIED BUT NOT FORMAL)
	RETURN

SDSPER:
	EXEC	SDERR1
	RETURN
	EPROC


SDERR1:	PROC
	SAVE	X1
	L	X1,X1CUR
	ERR1
	ERROR(1,I1,XXXX PREVIOUSLY SPECIFIED)
	RETURN

	EPROC
	PURGE	XPTR,XSPEC
	SUBTTL	submodule SDESPE

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	Called by SR when the last parameter specification
		has been processed.
		It scans through all DCZQU:s of current level and
		checks validity of MODE/TYPE/SPEC combinations.
		An action table is used to speed up checking and
		default value settings.
		Virtual indices and parameter lengths are also
		calculated.


ERROR conditions:	parameter not specified
			parameter illegally specified
			too many formals
			too many virtuals
			illegal FORTRAN specification


calling ARGUMENTS: NONE

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;REG ASSIGNMENTS FOR SDESPE:
;=== =========== === ======

XZPTR=1		;pointer to DCZHB
XMOD=2		;used to hold ZQUMOD
XKND=3		;used to hold ZQUKND
XTYP=5		;used to hold ZQUTYP
XPTR=7		;work pointer
XLEN=10		;used to accumulate block length
XIDX=11		;virt index count
XNRP=12		;number of param
XSPEC=13	;used to index action table
XSTAT=14	;-1 if global fortran procedure

	PROC
SDESPE:	IFONA	YBSOV
	RETURN		
	SAVE	<XMOD,XKND,XPTR,XLEN,XIDX,XNRP,XSPEC>
	L	XSTACP,YBSTP
	LF	XZPTR,ZHSSTR(XSTACP)	;point to DCZHB
	MOVE	XPTR,XZPTR
	SETZB	XIDX,XNRP
	LF	XLEN,ZHSOBL(XSTACP)
	SETZ	XSTAT,
	IFOFFA	YSWE40
	IFONA	YSWEFO
	SETO	XSTAT,
.NSP:	WHILE	LF	XPTR,ZDELNK(XPTR)	;link to next record
		JUMPE	XPTR,FALSE
	DO	LF	XTYP,ZQUTYP(XPTR)
		JUMPE	XTYP,SDERR3
		LF	XMOD,ZQUMOD(XPTR)
		IF
			CAIE	XMOD,QVIRTUAL
			GOTO	FALSE
		THEN
			SF	XIDX,ZQUIND(XPTR)	;index to ZQUIND
			AOJA	XIDX,.NSP	
		FI
		ADDI	XNRP,1
		;calculate ACTION TABLE entry
		IMULI	XMOD,3
		LF	XKND,ZQUKND(XPTR)
		ADD	XMOD,XKND
		SUBI	XMOD,1
		SUBI	XTYP,1
		;get table info and take appropriate action
		LDB	XSPEC,YSDPTB(XTYP)
		TRNN	XSPEC,3b33
		EXEC	SDERR4
		IF	JUMPE	XSTAT,FALSE
		THEN	;external FORTRAN procedure
			TRNN	XSPEC,1b34
			GOTO	XER4
		FI
		IF
			TRNE	XSPEC,2B33	;skip if dflt ref
			GOTO	FALSE
		THEN
			LI	QREFER
			SF	,ZQUMOD(XPTR)
		ELSE
			IF
				TRNE	XSPEC,1B33	;dflt val
				GOTO	FALSE
			THEN
				LI	QVALUE
				SF	,ZQUMOD(XPTR)
			FI
		FI
		TRZ	XSPEC,7b34			;isolate LEN field
		ADDI	XSPEC,1
		SF	(XSPEC) ZQUIND(XPTR)	;set length
		SETON	ZQULEN(XPTR)		;seton offset marker
		ADD	XLEN,XSPEC			;update len acc
	OD
	CAILE	XNRP,QMXNRP
	EXEC	SDERR5
	SF	XNRP,ZHBNRP(XZPTR)
	CAILE	XIDX,QMXVRT
	EXEC	SDERR6
	SF	XIDX,ZHBVRT(XZPTR)
	SF	XLEN,ZHSOBL(XSTACP)
	RETURN
SDERR3:	LI	QREFER
	SF	,ZQUMOD(XPTR)	;set MODE reference, not to fool PHASE2 
				;into believing that parameter list is terminated
	STACK	X1
	ADDI	XNRP,1
	ERR2
	ERROR(3,I1,FORMAL PARAMETER XXXX NOT SPECIFIED)
	UNSTK	X1
	GOTO	.NSP
	EPROC

SDERR4:	PROC
	SAVE	X1
	ERR2
	ERROR(4,I1,FORMAL PARAMETER XXXX ILLEGALLY SPECIFIED)
	RETURN
	EPROC

SDERR5:	PROC
	LI	XPTR,-3(XZPTR)
	ERR2
	ERROR(5,I1,XXXX HAS TOO MANY FORMALS)
	LI	XZPTR,3(XPTR)
	RETURN
	EPROC

SDERR6:	PROC
	LI	XPTR,-3(XZPTR)
	ERR2
	ERROR(6,I1,XXXX HAS TOO MANY VIRTUALS)
	LI	XZPTR,3(XPTR)
	RETURN
	EPROC

XER4:	PROC
	STACK	X1
	ERR2
	ERROR(14,I1,XXXX HAS ILLEGAL FORTRAN SPECIFICATION)
	SETONA	YERNP2
	UNSTK	X1
	GOTO	.NSP
	EPROC
SCALAR(<QI,QR,QV,QS>)
SCALAR(<L1,L2,F1,F2>)

;Action Table:

YSDTAB:
;				          simple
;			   (UNSPECIFIED:  array      )
;				          procedure

;      integer   real  longreal  char  boolean   text    ref    label   notype

BYTE(2) QV,F1,  QV,F1,  QV,F2,  QV,F1,  QV,F1,  QR,L2,  QR,L1,  QR,L2,  0,0
BYTE(2) QR,F1,  QR,F1,  QR,F1,  QR,F1,  QR,F1,  QR,L1,  QR,L1,  0,0,    0,0
BYTE(2) QR,L2,  QR,L2,  QR,L2,  QR,L2,  QR,L2,  QR,L2,  QR,L2,  QR,L2,  QR,L2


;				          simple
;			         (VALUE:  array      )   
;				          procedure

;      integer   real  longreal  char  boolean   text    ref    label   notype

BYTE(2) QS,F1,  QS,F1,  QS,F2,  QS,F1,  QS,F1,  QS,L2,  QI,L1,  QI,L2,  0,0
BYTE(2) QS,F1,  QS,F1,  QS,F1,  QS,F1,  QS,F1,  QI,L1,  QI,L1,  0,0,    0,0
BYTE(2) QI,L2,  QI,L2,  QI,L2,  QI,L2,  QI,L2,  QI,L2,  QI,L2,  QI,L2,  QI,L2


;				          simple
;			          (NAME:  array      )    
;				          procedure

;      integer   real  longreal  char  boolean   text    ref    label   notype

BYTE(2) QS,F2,  QS,F2,  QS,F2,  QS,F2,  QS,F2,  QS,L2,  QS,L2,  QS,L2,  0,0
BYTE(2) QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2,  0,0,    0,0
BYTE(2) QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2,  QS,L2

COMMENT;

meaning of ENTRY:	bits	<0:1>	00:	illegal combination (QI)

					01:	default mode = REF to be set (QR)

					10:	default mode = VALUE to be set (QV)

					11:	legal combination (QS)

				<2>	 0:	parameter not to be used
						in FORTRAN sub programs

					 1:	parameter can be used
						in FORTRAN sub programs

				<3>	 0:	length of parameter = 1

					 1:	length of parameter = 2

;


QBPPOS=3
;Pointer Table to Action Table:

YSDPTB: REPEAT 11,<POINT 4,YSDTAB(XMOD),QBPPOS
		   QBPPOS=QBPPOS+4>

	PURGE	XTYP,XZPTR,XMOD,XKND,XPTR,XLEN,XIDX,XNRP,XSPEC
	SUBTTL	submodule SDHID [40]

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	Called from SR for each identifier in the 
		protection part.

Arguments:	X1SR1 contains flags in left halfword and fields in right.


ERROR conditions:	Conflict between specifications.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


SDHID:	PROC
	IFONA	YBSOV
	RETURN
	IFONA	YSWC
	EXEC	O1XR
	XALLO==XALLOC	;[202]
	SAVE	<XALLO,X2,X3>	;[202]
	L	X2,YBSTP
	ADDI	X2,4
	MOVS	X1,X1SR1
	ADD	X1,X1SR1
;TEST IF PROTECTED
	IFONA	ZQUTPT(X1)
	EXEC	SDHIDS
;TEST IF HIDDEN
	SUBI	X2,1
	IFONA	ZQUHID(X1)
	EXEC	SDHIDS

	RETURN
	EPROC


SDHIDS:	PROC
	LF	X3,ZHSSTR(X2)
	IF
		JUMPE	X3,FALSE
		WHENNOT X3,ZQU
		GOTO	FALSE
	THEN	;CHECK FOR CONFLICT WITH EARLIER SPECS
		IF
			L	X1
			XOR	(X3)
			IFOFFA	ZQUNOT
			GOTO	FALSE
		THEN	;CONFLICT
			TRON	X1SR1,1
			EXEC	SDER17
			RETURN
		FI
		L	XALLOC,X3
		LOOP
			LF	,ZQULID(XALLOC)
			IF
				CAME	X1CUR
				GOTO	FALSE
			THEN
				TRON	X1,2
				EXEC	SDERR1
				RETURN
			FI
		AS
			LF	XALLOC,ZDELNK(XALLOC)
			JUMPE	XALLOC,FALSE
			WHEN	XALLOC,ZQU
			GOTO	TRUE
		SA
	FI
	L	[3,,3]
	EXEC	SDALLOC
	SETZM	1(XALLOC)
	SF	X3,ZDELNK(XALLOC)
	SF	XALLOC,ZHSSTR(X2)
	SKIPN	X3
	SF	XALLOC,ZHSEND(X2)
	SETOFA	ZQUTPT(X1)
	ST	X1,(XALLOC)
	LF	,YLSCLIN
	SF	,ZQUTEM(XALLOC)
	SETON	ZQUIVA(XALLOC)
	SF	X1CUR,ZQULID(XALLOC)
	RETURN
	EPROC


SDER17:	PROC
	ERR1
	ERROR(17,,conflict between specifications)
	RETURN
	EPROC
	SUBTTL	submodule SDPRO [40]

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	Called from SDEND when end of class body is recognized.
		Searches attributes for protection.


ERROR conditions:	PROTECTED attribute not found.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


XPTR=3

DEFINE	FIND1<
	EXEC	SDPRO1
	>

DEFINE	FIND2(N)<
	LF	X1,ZHSSTR(XSTACP,N-1)
	IFE N-1,<LF X1,ZDELNK(X1)>
	WHILE
		JUMPE	X1,FALSE
	DO
		SETON	ZQUTPT(X1)
		SETON	ZQUIVA(X1)
		LF	X1,ZDELNK(X1)
	OD
	>

DEFINE	FIND3(N)<
	LF	X1,ZHSSTR(XSTACP,N-1)
	IFE N-1,<LF X1,ZDELNK(X1)>
	WHILE
		JUMPE	X1,FALSE
	DO
		LF	,ZQULID(X1)
		CAMN	X2
		RETURN
		LF	X1,ZDELNK(X1)
	OD
	>


SDPRO:	PROC
	SAVE	<X1,X2,XPTR>
	LF	XPTR,ZHSSTR(XSTACP,4)
	IF
		JUMPE	XPTR,FALSE
		WHENNOT	XPTR,ZQU
		GOTO	FALSE
	THEN	;PROTECT SPECIFICATIONS EXISTS
		IF
			IFON	ZQUNOT(XPTR)
			GOTO	FALSE
		THEN	;PROTECT NAMED ATTRIBUTES
			LOOP
				FIND1
				SETON	ZQUIVA(X1)
				SETON	ZQUTPT(X1)
			AS
				LF	XPTR,ZDELNK(XPTR)
				JUMPE	XPTR,FALSE
				WHEN	XPTR,ZQU
				GOTO	TRUE
			SA
		ELSE	;PROTECT ALL BUT NAMED ATTRIBUTES
			FIND2(1)
			FIND2(2)
			FIND2(3)
			LOOP
				FIND1
				SETOFF	ZQUIVA(X1)
				SETOFF	ZQUTPT(X1)
			AS
				LF	XPTR,ZDELNK(XPTR)
				JUMPE	XPTR,FALSE
				WHEN	XPTR,ZQU
				GOTO	TRUE
			SA
		FI
		SF	XPTR,ZHSSTR(XSTACP,4)
		IF
			JUMPN	XPTR,FALSE
		THEN
			SF	XPTR,ZHSEND(XSTACP,4)
		FI
	FI
	RETURN
	EPROC

SDPRO1:	PROC
	LF	X2,ZQULID(XPTR)
	FIND3(1)
	FIND3(2)
	FIND3(3)
SDER23:
	ERR2
	ERROR(23,I1,attribute XXXX not  found)
	L	X1,XPTR
	RETURN
	EPROC
	SUBTTL	submodule SDABEG

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	Called by SR after having issued a first call
		on SDZQU when processing an ARRAY declaration.
		It saves the last DCZQU address.

ERROR conditions:	NONE

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


	PROC
SDABEG:	IFONA	YBSOV
	RETURN		
	L	X1,YBSTP	
	LF	,ZHSEND(X1,2)	;point to end of ARRAY/REF list
	ST	YASTR		;save adr of DCZQU of last ARRAY var
	RETURN
	EPROC
	SUBTTL	submodule SDPEND

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	To fixup the fields of the OUTERMOST
		stack level upon PROGRAM EXIT.

ERROR conditions:	NONE

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


SDPEND:	LF	,ZHSOBL(,YDPD)
	ST	YMPSIZ
	LF	,ZHSLSB(,YDPD)
	ADDM	YMPSIZ
	RETURN
	SUBTTL	submodule SDAEND

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:	To furnish all the ARRAYs of an ARRAY segment
		with their proper BOUNDS.

ERROR conditions:	NONE

calling ARGUMENTS:	reg:	contents of right half


				 18                       30       35
				I------------------------I-----------I
			X1SR2	I           0            I   ZQUNSB  I
				I------------------------I-----------I

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


	PROC
SDAEND:	IFONA	YBSOV
	RETURN		
	L	X1,YASTR	
	LOOP	SF	X1SR2,ZQUNSB(X1)	;store NSB arg
		LF	X1,ZDELNK(X1)		;link to next record
	AS	JUMPG	X1,TRUE
	SA
	RETURN
	EPROC
	SUBTTL	submodule SDPPN

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:		When a PPN is found in an external identifier,
			the lexical scanner converts the numbers as if
			they were decimal and stores them in YLSVAL.
			The function of SDPPN is to reconvert them from
			decimal to octal.

Entry conditions:

			YLSVAL	holds value to be converted


Exit conditions:
			X0	right halfword holds the converted value


ERRORS:			NOT OCTAL DIGIT IN PPN
			MORE THAN SIX DIGITS IN PPN

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

SDPPN:	PROC
	SAVE	<X1,X2,X3>
	L	YLSVAL
	LI	X3,6
	LOOP
		IDIVI	^D10
		CAILE	X1,7
		GOTO	XER5
		LSHC	X1,-3
	AS
		SOJG	X3,TRUE
	SA
	JUMPN	XER6
	HLRZ	X2
	RETURN
XER5:
	ERR1
	ERROR(15,,PPN NOT OCTAL DIGIT)
	RETURN
XER6:
	ERR1
	ERROR(16,,PPN MORE THAN SIX DIGITS)
	RETURN
	EPROC
	SUBTTL	SUBROUTINE SDALLOC

COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function:		Allocates memory in the dynamic pool.

Entry conditions:	X0 = N,,N    N= number of words to allocate

Exit conditions:	XALLOC	points to base of allocated area


ERRORS:		NOT ENOUGH CORE PASS 1

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

SDALLOC:PROC
	HRRZ	XALLOC,YC1DC
	ADDM	YC1DC
	SKIPGE	YC1DC
	GOTO	ZSET
	HRRZ	.JBREL
	ADDI	4000

	IF
	IFG QTRACE,<EXTERN YTRPAS
		IFON	YTRSW
		GOTO	FALSE>
		CORE
		GOTO	FALSE
	THEN
		MOVSI	-4000
		ADDM	YC1DC
	ELSE
		ERR	QT,Q1SD.T
		BRANCH	T1AB
	FI

ZSET:	SETZM	2(XALLOC)
	RETURN
	EPROC
	LIT
	END