Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0078/comp/carl.mac
There are 2 other files named carl.mac in the archive. Click here to see a list.
	SEARCH	SIMMAC,SIMMC2
	sall
	CTITLE	CARL
	SUBTTL	CARL - READ DECLARATIONS FROM DF1

COMMENT;	=== ROUTINE CARL ===

UPDATE:		4 [36,40,136,140,214,322]

PURPOSE:	READ A SEGMENT OF THE DECL. FILE INTO THE DECL. STACK.
		THE SEGMENT IS DELIMITED BY ZHE(ZHB) RECORDS, AND IS INPUT BY O2D1.
		THE DECLARATION STRUCTURE IS CHECKED AND COMPLETED BY
		FILLING PREFIX LINKS, CHECKING QUALIFICATIONS AND VIRTUAL
		MATCHES, ETC.
		NOTE THE SPECIAL TREATMENT OF LINE NUMBERS FOR DIAGNOSTICS
ENTRY:		EXEC CARL
NORMAL EXIT:	RETURN
ERROR EXITS:	NONE
USES:		O2D1
;
	TWOSEG
	RELOC	400K
EXTERN	YELIN1,YELIN2,YCADLV,YOLINE
EXTERN YDICTB,YDCSTP,CAUD,YRDSTP,YBKSTP,CAUS,CADS,O2D1,YUNDEC,YZHET
EXTERN	CAPROT,CAUNPR	;[40]
EXTERN CADISP,CAUNDI,O2LN3,EXQC
EXTERN	YCALID,YCATYE,YCAZHE,YCA1SC,YCAPLE,YCAVRT,YORZHB
INTERN	CABSTU,CARL

CARL.E:	RFAIL	IMPROPER DF1 STRUCTURE

OPDEF	ECADF1	[PUSHJ	XPDP,CARL.E]

DEFINE	$$$DO	<GOTO FALSE>
DEFINE	$$$THEN	<GOTO FALSE>

DEFINE	ON(A)	<IFOFF A>

OPDEF	DISPLAY	[PUSHJ	XPDP,CADS]
OPDEF	UNDISP	[PUSHJ	XPDP,CAUD]
QMXBLEN=1777	;MAX BLOCK LENGTH
	MACINIT
;UPDATE BLOCK STACK

CABSTU:	L	X1,YBKSTP
	PUSH	X1,XZHE
	ST	X1,YBKSTP
	L	YRDSTP
	HRLM	(X1)
	RETURN
DSW SCATYE,YCATYE,36	;TYPE ERROR SWITCH
DSW SCAN1,YCA1SC,36	;FIRST SCAN SWITCH

CARL:	PROC
	SAVE	<X2,X3,X4,X5,X6>

	STACK	YOLINE
	HRRZ	XZHE,YDCSTP	;CURRENT TOP OF STACK
	EXEC	O2D1		;READ ZHE OR ZHB, FOLLOWED BY ZQU LIST, AND FOR
				;EACH DECLARED CLASS OR PROCEDURE ZQU,
				;ITS ZHB WITH ZQU SUBLIST, ETC.
	STACK	YDCSTP		;ITS A MIRACLE THIS WORKS
	ASSERT <CAMN	XZHE,YDCSTP
		ECADF1
		WHEN XZHE,ZQU
		ECADF1>
	WHEN	XZHE,ZHB
	ZF	ZHBZHB(XZHE)	; FIELD IS NOT CLEARED FOR INSPECT PASS 1
	ST	XZHE,YCAZHE	;SAVE XZHE
	SETON	SCAN1		;FIRST SCAN
	SETZM	YCAPLE
	SETZM	YCAVRT
		; CHECK FOR UPDATE OF BLOCK QUANTS (REDUCED INTO PREFIXED BLOCK)
		LF	X1,ZHETYP(XZHE)
		IF	CAIE	X1,QRBLOCK
		THEN
			L	X1,YBKSTP
			LOOP	; FIND ENCLOSING BLOCK WHICH IS UNREDUCED
				POP	X1,X4
				LF	,ZHETYP(X4)
			AS	CAIE	QFOR
				CAIN	QRBLOCK
				GOTO	TRUE
				ASSERT<CAIN	QINSPE
					RFAIL	REDUCTION TO INSPECT
				>
			SA
			IF	CAIE	QPBLOCK
			THEN	; UPDATE ZQU:S
				ASSERT<	LF	,ZHEDLV(XZHE)
					LF	X1,ZHEDLV(X4)
					CAME	X1,X0
					RFAIL	INVALID DLV ALLOCATION
					; THIS MAY EASILY SHOW UP IF A PREFIXED
					; BLOCK OCCURS IN A FOR STATEMENT OR INSPECTION
				>
				LF	X4,ZHBZHB(X4)	; PREFIX TO BLOCK
				L	X2,XZHE
				SKIPE	X4
				EXEC	CARLSD
			FI
		FI
CARL.1:	L	X2,XZHE
	LF()	ZHETYP(X2)
	IF		;PROCEDURE ZHE FIRST IN LIST?
		CAIE	QPROCB
	THEN		;DISPLAY PARAMETERS, FILL IN ZHBZE POINTER
		L	XZHE,YORZHB	; INVALID OR UNKNOWN PREFIX, OR OUTERMOST BLOCK
		DISPLAY
		SF(X2)	ZHBZE(XZHE)
		GOTO	CARL.L
	FI;
	IF		;PREFIXED BLOCK?
		SKIPE	X4,YORZHB
		CAIE	QPBLOCK
	THEN
		LF	X1,ZHBZQU(X4)
		LF	,ZQULID(X1)
		ST	YCALID
		SF(X4)	ZHBZHB(X2)
		GOTO	CARL.P
	FI
	WHEN	X2,ZHB
	GOTO	CARL.D
	GOTO	CARL.L

CARL.S:	;--- BEGIN SCAN HERE ---
	L	YELIN1
	ST	YELIN2
	IFON	SCERFL
	ERRLI
	SETOFF	SCERFL
	LF(X1)	ZDETYP(X2)
	CAIE	X1,ZQU%V
	GOTO	[JUMPN	X1,CARL.H
		GOTO	CARL.X]
;--- ZQU RECORD ---
IF	IFON	ZQUIVA(X2)	;[40] ON IF HIDDEN
THEN
LF	,ZQULNE(X2)
ST	YELIN1
IF
	ON	SCAN1
THEN
	SETZ	X1,
	IF
		LF()	ZQUKND(X2)	;KIND=SIMPLE OR KIND=ARRAY
		CAILE	QARRAY
		GOTO	FALSE
		LF()	ZQUTYP(X2)	;AND TYPE =/= LABEL
		CAIN	QLABEL
	THEN
		L	X1,YCAPLE
	ELSE
		IFEQF	X2,ZQUMOD,QVIRTUAL
		L	X1,YCAVRT
	FI
	;/UPDATE OFFSET OR VIRTUAL INDEX/
	ADDM	X1,OFFSET(ZQUIND)(X2)
	SF(XZHE)ZQUZHE(X2)	;LINK TO SURROUNDING BLOCK
	LF(X1)	ZQUZQU(X2)	;QUALIFICATION?
	IF
		JUMPN	X1,TRUE
	THEN	;TRANSLATE FROM ID TO ZQU
		LF()	ZDCZQU(X1,YDICTB)
		IF	;No ZQU exists for this id
			SKIPE
		THEN	;Usually an error, except for param to MACRO-10
						edit(322)
			LF X1,ZQUZHE(X2)	;[322] Check type of block we are in
			IF	;[322] Not within declaration of MACRO-10 procedure
				LF ,ZDETYP(X1)
				CAIE ZHB%V
				GOTO TRUE
				IFNEQF X1,ZHETYP,QPROCB
				GOTO TRUE
				LF ,ZHBMFO(X1)
				CAIE QEXMAC
				CAIN QEXMQI
			THEN	;Error
				LF X1,ZQUZQU(X2)
				ERROR1 1,X1,Qualifier XXXX is not a class
			FI
			LI	X0,YUNDEC
			LF	X1,ZQUKND(X2)
			CAIN	X1,QCLASS
			 SETZ	X0,	; Remove prefix if class
		FI
		SF()	ZQUZQU(X2)
	FI;
ELSE	;SECOND SCAN
	IF	;Qualification is not class
		IFNEQF	X2,ZQUTYP,QREF
		GOTO	FALSE
		LF(X4)	ZQUZQU(X2)
		JUMPE	X4,FALSE
		LF()	ZQUKND(X4)
		CAIN	QCLASS
		GOTO	FALSE
		CAIN	X4,YUNDEC
	THEN
		LF(X1)	ZQULID(X4)
		ERROR1	1,X1,<QUALIF NOT CLASS>
		LI	X1,YUNDEC	;MAKE QUALIF UNDEFINED
		SF(X1)	ZQUZQU(X2)
	FI;
	;//CHECK FOR REDECLARATION OR VIRTUAL MATCH//
	LF(X3)	ZQULID(X2)
	ST	X3,YCALID
	LF(X4)	ZDCZDC(X3,YDICTB)
	IF
		IFOFF	ZQUDD(X2)	;[140]
		JUMPN	X4,TRUE	;Old decl or specification exists
	THEN
		LF(X6)	ZDCZQU(X4)
		LF(X5)	ZQUZHE(X6)
		IF		;SAME BLOCK LEVEL
			LF()	ZHESOL(X5)
			LF(X1)	ZHESOL(XZHE)
			CAME	X1
		THEN
;[140]
			L	X1,YCALID
			LI	X4,YDICTB(X3)
			WHILE
				LF	X6,ZDCZQU(X4)
				CAMN	X6,X2
			DO	;SCAN PAST REDECLARATIONS
				IF	IFEQF	X2,ZQUMOD,QVIRTUAL
				THEN
					LF	X5,ZQULNE(X6)
					ST	X5,YELIN1
					IF	IFNEQF	X6,ZQUMOD,QVIRTUAL
					THEN
						ERRI1	QE,424	;ILL VIRT SPEC
					ELSE
						ERROR1	8,YCALID,<DOUBLE DECL.>
					FI
					ST	X5,YELIN2
					ERRLI
					SETON	ZQUDD(X2)
					SETON	ZQUDD(X6)
					SETF	YUNDEC,ZDCZQU(X4)
				FI
				LF	X4,ZDCZDC(X4)
			OD
			IF	IFOFF	ZQUDD(X2)
			THEN
				SETF	YUNDEC,ZDCZQU(X4)
			ELSE
				LF	X5,ZDCZDC(X4)
				LF	X6,ZDCZQU(X5)
				IF	JUMPE	X5,FALSE
					IFNEQF	X6,ZQUMOD,QVIRTUAL
				THEN	;Old is virtual
					IF	;Current also virtual
						IFNEQF	X2,ZQUMOD,QVIRTUAL
					THEN	;Illegal virtual spec
						ERRI1	QE,424
						SETON ZQUDD(X2)
						SETF YUNDEC,ZDCZQU(X4)
					ELSE
						EXEC	CARLVI
			FI	FI	FI
REPEAT 0,<;[140]
			IFON	ZQUSYS(X2)
			GOTO	L2
			IFON	ZQUGLOB(X2)
			GOTO	L2
			IF	;OLD WAS A VIRTUAL
				LF()	ZQUMOD(X6)
				CAIE	QVIRTUAL
			THEN
				CAIE	X2,(X6)
				EXEC	CARLVI
			ELSE
			L2():	IF	;SAME BLOCK
					CAME	X5,XZHE
				THEN
					LF	X6,ZDCZQU(X3,YDICTB)
					SETON	ZQUDD(X6)	;[136]
					LF	X5,ZQULNE(X6)
					CAML	X5,YELIN1
					EXCH	X5,YELIN1	; FIRST ID LNE TO YELIN1
					; for good diagnostic msg
					ERROR1	8,YCALID,<DOUBLE DECL.>
					L	YELIN1
					ST	YELIN2
					ERRLI
					L	X4,(X4)	; TAKE OLD DICTIONARY ENTRY
					HRRI	X4,YUNDEC
					ST	X4,YDICTB(X3)	; AND REPLACE CURRENT ENTRY WITH IT
			FI	FI
;[140]>
	FI	FI
FI	;(SECOND SCAN)
FI	;[40] HIDDEN SPEC
	STEP	X2,ZQU
	GOTO	CARL.S
CARL.H:	;--- HEADER RECORD (ZHE OR ZHB), OR END OF SEGMENT ---

	SETZM	YCAPLE		;ASSUME NO PREF
	SETZM	YCAVRT		;AND NO VIRTUALS
	; UNDISPLAY TO ENCLOSING LEVEL
	LF	X3,ZHESOL(X2)
	WHILE	LF	,ZHESOL(XZHE)
		CAMGE	,X3
	DO
		EXEC	CAUNDI
		EXEC	CAPROT	;[40]
		EXEC	CAUS
	OD
	ASSERT<SOS	X3
		CAIE	(X3)
		JUMPN	CARL.E
	>
	LF(X1)	ZHETYP(X2)
IF
	ON	SCAN1
THEN
	;FOR CLASS/PROCEDURE, UPDATE ZQU POINTER
	IF
		CAIE	X1,QCLASB
		CAIN	X1,QPROCB
		GOTO	TRUE
	THEN	;LINK ZHB TO ZQU
		LF(X3)	ZHBZQU(X2)
		ADD	X3,YCAZHE
		ASSERT<WHENNOT	X3,ZQU
			RFAIL	ZQU EXPECTED AT ZHBZQU
		>
		SF(X3)	ZHBZQU(X2)
		SF(X2)	ZQUZB(X3)	;Reverse the link
		LF	,ZQULNE(X3)
		ST	YELIN1
	FI;
	IFON	ZQUEXT(X3)
	 XEC	O2LN3
	IF	;Class block
		CAIE	X1,QCLASB
	THEN	;Prefix link
		LF(X4)	ZQUZQU(X3)
		ZF	ZQUZQU(X3)	;CLEAR ZQUZQU FIELD AFTER USE
		IF	;Prefix exists
			JUMPN	X4,TRUE
		THEN
			LF	,ZQULID(X4)
			ST	YCALID
			IF	; Prefix not previously declared
				CAMGE	X4,X3
			THEN
				STACK	X2
				L	X1,YCALID
				LF	X2,ZHBZQU(X2)
				LF	X2,ZQULID(X2)
				ERRI2	QE,<Q2.ERR+^D40>
				ASSERT<NOP	[ASCIZ/PREFIX %ID TO %ID IS NOT PREVIOUSLY DECLARED/]
				>
				UNSTK	X2
				ZF	ZHBZHB(X2)	; DELETE PREFIX
				GOTO	CARL.D
			FI
			LF	X4,ZQUZB(X4)
			SF	X4,ZHBZHB(X2)
CARL.P:			IFOFF	SCAN1
			 GOTO	CARL.D
			LF(X5)	ZHBZQU(X4)	;GET PREFIX ZQU IN X5
			IF	;Prefix not a class
				LF()	ZHETYP(X4)
				CAIE	QCLASB
				GOTO	TRUE
				LF	,ZQUTYP(X5)
				JUMPE	FALSE
				CAIN	QNOTYP
			THEN
				SEVER1	3,YCALID,PREF NOT A CLASS
				ZF	ZHBZHB(X2)	;CLEAR PREF LINK
			ELSE
				LF	,ZHBSZD(X4)
				LF	X1,ZHBSZD(X2)
				CAML	X1
				SF	,ZHBSZD(X2)	; BACK UP DISPLAY SIZE FROM PREFIX
				IF	IFOFF	ZHBKDP(X4)
				THEN	; BACK DOWN ZHBKDP
					SETON	ZHBKDP(X2)
				FI
				IF	IFOFF	ZHBLOC(X4)
				THEN	; BACK DOWN ZHBLOC
					SETON	ZHBLOC(X2)
				FI
				LF()	ZHEDLV(X2)
				LF(X1)	ZHEDLV(X4)
				IF
					CAME	X1
					GOTO	TRUE
					IFOFF	ZQUIS(X5)
				THEN
					IF	SKIPN	X1
					THEN	; INVALID PREFIX LEVEL
						SEVER1	4,YCALID,PREF NOT ON SAME LEVEL
					ELSE	; FIRST OCCURRENCE OF SIMSET/SIMULATION
						EXEC	CASDL	; SET DLV:S
						LF	,ZHEDLV(X4)
						SKIPN
						 SEVER1	4,YCALID,PREF NOT ON SAME LEVEL
					FI
				ELSE	; CHECK PREFIX SOURCE LEVELS
					IF	IFON	ZQUSYS(X5)
					THEN	; OFF
						LF	,ZHESOL(X2)
						LF	X1,ZHESOL(X4)
						CAME	X1
						 SEVER1	4,YCALID,PREFIX NOT ON SAME LEVEL
					FI
				FI
				EXEC	CARLSD
			FI
		FI
	FI
CARL.D:	;DISPLAY LEVEL (INITIAL VALUE)
	LF()	ZHEDLV(X2)	;STD := SZD := - DLV
	MOVN
	AOJ	,
	SF()	ZHBSTD(X2)
	LF	X1,ZHBSZD(X2)
	HRRZ
	CAMLE	X1
	 SF()	ZHBSZD(X2)
ELSE	;SECOND SCAN
FI
;ADD NEW LEVEL
CARL.L:	ST	XZHE,YZHET
	L	XZHE,X2
	; NOTE OPTIMIZATION POSSIBILITY
	; IT IS NOT NECESSARY TO DISPLAY PROCEDURE
	; PARAMETERS WHEN THEIR ZHB IS READ
	EXEC	CABSTU
	IF
		LF()	ZDETYP(X2)
		CAIE	ZHE%V
	THEN
		DISPLAY
		STEP	X2,ZHE
	ELSE
		EXEC	CAUNPR,<[1]>	;[40]
		EXEC	CADISP
		STEP	X2,ZHB
	FI
	GOTO	CARL.S
;***************************************************

CARL.X:	L	X4,YDCSTP	;SAVE YDCSTP
	WHILE
		CAMG	XZHE,YCAZHE
	DO
		EXEC	CAUNDI
		EXEC	CAPROT	;[40]
		EXEC	CAUS
	OD
	IF
		ON	SCAN1
	THEN
		EXEC	CAUNDI
		EXEC	CAPROT	;[40]
		LF	,ZHETYP(XZHE)
		IF	CAIE	QPROCB
		THEN	; UNDISPLAY PARAMETERS
			L	XZHE,YORZHB
			UNDISPLAY
		FI
		EXEC	CAUS
		L	XZHE,YCAZHE
		ST	XZHE,YZHET
		ST	X4,YDCSTP
		SETOFF	SCAN1
		GOTO	CARL.1
	FI
	ST	X4,YDCSTP
	L	0(XPDP)
	UNSTK	YDCSTP
	UNSTK	YOLINE
	LF	,ZHETYP(XZHE)
	IF	CAIE	QFOR
	THEN	; RESET ZQUZHE:S TO ENCLOSING NON-FOR RECORD
		L	X1,YBKSTP
		POP	X1,X2
		WHILE	LF,ZHETYP(X2)
			CAIE	QFOR
		DO
			POP	X1,X2
		OD
		LI	X1,ZHE%S(XZHE)
		WHILE	RECTYPE(X1) IS ZQU
		DO
			SF	X2,ZQUZHE(X1)
			STEP	X1,ZQU
		OD
	FI
	EXEC	EXQC
	RETURN
	EPROC
COMMENT;
PURPOSE:	SET ZHEDLV, ZHEEBL AND ZHBSBL IN SIMSET/SIMULATION AND THEIR ATTRIBUTE CLASSES

ENTRY:		CASDL

INPUT:		X0	DLV OF SIMSET/SIMULATION

OUTPUT:		ZHEDLV ETC. OF SIMSET,SIMULATION,LINKAGE,LINK,HEAD AND PROCESS ZHB
		X0 IS NOT DESTROYED

;
CASDL:	PROC
	SAVE	<X2,X3,X4>
	ST	YCADLV
	MOVN	X4,X0
	SUBI	X4,1
	L	X2,X0
	L	X3,[QIDSET,,QIDSIM]	; ZQULID FOR SIMSET AND SIMULATION
	WHILE	SKIPN	X3
	DO
		LF	X1,ZDCZQU(X3,YDICTB)
		HRRI	X3,YDICTB(X3)
		WHILE
			IFON	ZQUSYS(X1)	; STANDARD CLASS HAS BEEN REDECLARED
		DO
			HLR	X3,(X3)
			LF	X1,ZDCZQU(X3)
		OD
		LF	X1,ZQUZB(X1)
		SF	X2,ZHEDLV(X1)	; PARENT DLV
		SF	X4,ZHBSBL(X1)
		AOJ	X4,
		SOJ	X2,
		STEP	X1,ZHB
		WHILE	WHENNOT	X1,ZQU
		DO
			LF	,ZQUKND(X1)
			IF	CAIE	QCLASS
			THEN	; UPDATE SON ZHEDLV
				LF	X1,ZQUZB(X1)
				SF	X2,ZHEDLV(X1)
				SF	X4,ZHBSBL(X1)
				MOVN	X2
				SF	,ZHEEBL(X1)
				LF	X1,ZHBZQU(X1)
			FI
			STEP	X1,ZQU
		OD
		AOJ	X2,
		SOJ	X4,
		HLRZ	X3,X3
	OD
	L	X2
	RETURN
	EPROC
COMMENT;
PURPOSE:	SET YCAVRT AND YCAPLE FOR UPDATING OF ZQUIND FIELDS
		TO ACCOUNT FOR PREFIXES

ENTRY:		CARLSD

INPUT:		X2	THIS ZHE RECORD
		X4	PREFIX ZHB RECORD

OUTPUT:		YCAVRT,YCAPLE,ZHELEN(X2) AND ZHBVRT(X2)
;
CARLSD:		LF()	ZHELEN(X4)
		LF	X1,ZHELEN(X2)
		ST	YCAPLE
		ADD	X1
		SF()	ZHELEN(X2)
		CAILE	QMXBLEN
		 ERROR2	34,BLOCK TOO LARGE
		WHENNOT	X2,ZHB
		 RET
		;UPDATE ZHBVRT
		LF(X1)	ZHBVRT(X4)
		ST	X1,YCAVRT
		LF()	ZHBVRT(X2)
		ADD	X1
		SF()	ZHBVRT(X2)
		RETURN
COMMENT;	=== ROUTINE CARLVI ===
PURPOSE:	TO CHECK FOR POSSIBLE VIRTUAL MATCH WHEN SCANNING
		A DSTACK SEGMENT. CALLED FROM CARL WHEN A
		(RE)DECLARATION IS ENCOUNTERED ON THE SAME LEVEL
		AS A PREVIOUS DECLARATION OR SPECIFICATION WHICH HAS
		MODE VIRTUAL.
ENTRY:		EXEC CARLVI
INPUT:		X2 POINTS TO ZQU OF MOST RECENT POSSIBLE MATCH
		X6 POINTS TO ZQU OF NEXT OLDER POSSIBLE MATCH
EXIT:		RETURN
;


CARLVI:	PROC
	SAVE	<X2>
	LF()	ZQUKND(X6)
	LF(X1)	ZQUKND(X2)
	IF
		CAMN	X1	;KINDS DO NOT MATCH
	THEN
		ERROR1	5,YCALID,<VIRT. MATCH, WRONG KIND>
	ELSE		;CHECK TYPES
		SETOFF	SCATYE
		LF(X3)	ZQUTYP(X2)	;CURRENT TYPE
		LF(X1)	ZQUTYP(X6)	;TYPE OF OLDER MATCH OR SPEC
		IF
			CAMN	X1,X3	;UNEQUAL TYPES?
		THEN
			CAIE	X1,QNOTYPE	;OK IF NOTYPE TO TYPE
			SETON	SCATYE
		ELSE		;EQUAL TYPES, CHECK FOR REF
			IF
				CAIE	X3,QREF	;[36]
			THEN		;ENSURE EQUAL OR SUBORD. QUAL.
				LF()	ZQUZQU(X6)
				LF(X1)	ZQUZQU(X2)
				LOOP
					CAIE	X1,YUNDEC	;[214] Accept undeclared
					CAMN	X1
					GOTO	L1
				AS
					LF(X1)	ZQUZB(X1)
					LF(X1)	ZHBZHB(X1)
					JUMPE	X1,FALSE
					LF(X1)	ZHBZQU(X1)
					JUMPN	X1,TRUE
				SA
				SETON	SCATYE	;LOOP EXIT WITHOUT MATCH
		L1():	FI
		FI
		IFON	SCATYE
		ERROR1	6,YCALID,<VIRT. MATCH, WRONG TYPE OR QUAL.>
		SETF(1)	ZQUNSB(X2)	;MARK THIS ZQU AS VIRTUAL MATCH
		SETF(QVIRTUAL)	ZQUMOD(X2)
		IF	IFOFF	ZQUPTD(X2)	;[140]
			GOTO	FALSE
			LF	,ZQUZHE(X6)	;[140]
			LF	X1,ZQUZHE(X2)	;[140]
			CAMN	X1		;[140]
		THEN				;[140]
			SETOFF	ZQUPTD(X2)
			L	X1,YCALID
			ERRI1	QE,425	;VM PROTECTED
		FI
		IF	IFOFF	ZQUPTD(X6)	;[40]
		THEN
			SETON	ZQUPTD(X2)	;[40]
		FI
	FI
	RETURN
	EPROC
	LIT
	RELOC	0
	VAR
END;*** CARL