Google
 
Trailing-Edge - PDP-10 Archives - decuslib20-01 - decus/20-0002/lepaux.sai
There is 1 other file named lepaux.sai in the archive. Click here to see a list.
COMMENT    VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY ITMNAM,SETTYPE,XITEM,NAMEITEM,COPYITEM,BTRIP,REVLST
C00004 00003	INTERNAL SIMPLE ITEMVAR PROCEDURE XITEM(STRING ID)
C00006 00004	INTERNAL ITEMVAR PROCEDURE BTRIP(ITEMVAR A,O,V)
C00007 00005	INTERNAL RECURSIVE MATCHING PROCEDURE EQVRLN(? ITEMVAR A,V1,V2)
C00008 00006	INTERNAL ITEMVAR PROCEDURE COPYITEM(ITEMVAR IV)
C00011 00007	INTERNAL PROCEDURE CPRLNS(ITEMVAR P1,P2)
C00013 ENDMK
C;


ENTRY ITMNAM,SETTYPE,XITEM,NAMEITEM,COPYITEM,BTRIP,REVLST;
BEGIN "LEPAUX"

REQUIRE "ABBREV.SAI[S,RHT]" SOURCEFILE;

IFCR DECLARATION(GLOBSW)=0 THENC DEFINE GLOBSW=0;

IFC GLOBSW THENC
	DEFINE MINGLOBALITEMNUMBER='6000;
ENDC

PRELOADWITH 
	"ANY",
	"MAINPI",
	"BINDIT",
	"EVTYPI",
	"ITEM4",
	"ITEM5",
	"ITEM6",
	"ITEM7";
OWN INTERNAL STRING ARRAY RIPNMS[0:7];

INTERNAL SIMPLE STRING PROCEDURE ITMNAM(ITEMVAR N);
	BEGIN
	STRING S;
	INTEGER I;
	IF 0#(N)<8 THEN RETURN(RIPNMS[#(N)]);
	S_CVIS(N,I);
	RETURN(IF I THEN "ITEM"&CVS(CVN(N)) ELSE S);
	END;

INTERNAL SIMPLE PROCEDURE SETTYPE(ITEMVAR FOO;INTEGER TYP);
	STARTCODE
	EXTERNAL INTEGER INFTB,GINFTB;
	MOVE	3,FOO;
	MOVE	1,TYP;
IFC GLOBSW THENC
	CAIL	1,MINGLOBALITEMNUMBER;
	SKIPA	2,GINFTB;
ENDC
	MOVE	2,INFTB;
	DPB	1,2;
	END;

! Only an expert better use this;

INTERNAL SIMPLE ITEMVAR PROCEDURE IMUNGE(ITEMVAR I;INTEGER T(1),D(0),P(0));
	BEGIN
	SETTYPE(I,T);
	(I,INTEGER)_D;
	PROPS(I)_P;
	RETURN(I);
	END;

INTERNAL LIST PROCEDURE REVLST(LIST L);
	BEGIN
	! *** this can be made much more efficient ***;
	LIST LL;
	LL_NIL;
	WHILE LENGTH(L) DO 
		PUT LOP(L) IN LL BEFORE 1;
	RETURN(LL);
	END;


INTERNAL SIMPLE ITEMVAR PROCEDURE XITEM(STRING ID);
	BEGIN
	INTEGER F;
	ITEMVAR X;
	COMMENT GENERATES AN ITEM OF THE INDICATED NAME;
	X_CVSI(ID,F);
	IF F THEN 
		BEGIN
		X_NEW;
		NEWPNAME(X,ID);
		END;
	RETURN(X);
	END;


INTERNAL SIMPLE ITEMVAR PROCEDURE NAMEITEM(ITEMVAR ITM;STRING ID);
	BEGIN
	INTEGER F;ITEMVAR I;
	IF ID THEN
		BEGIN
		I_CVSI(ID,F);
		IF F(IITM) THEN
			USERERR(CVN(I),1," ALREADY HAVE AN ITEM NAMED "&ID&" ");
		NEWPNAME(ITM,ID);
		END;
	RETURN(ITM);
	END;

INTERNAL PROCEDURE ZAPITEM(ITEMVAR IV);
	BEGIN
	ERASE IVANYANY;
	ERASE ANYIVANY;
	ERASE ANYANYIV;
	DELETE (IV);
	END;


INTERNAL ITEMVAR PROCEDURE BTRIP(ITEMVAR A,O,V);
	BEGIN
	ITEMVAR L,N;
	N_NEW;
	MAKE NN[AOV];
	L_[AOV]; ERASE NNANY;
	DELETE(N);
	RETURN( L);
	END;


INTERNAL RECURSIVE MATCHING PROCEDURE EQVRLN(? ITEMVAR A,V1,V2);
	BEGIN
	 ? A, ? V1, ? V2 | AV1V2 DO SUCCEED;
	 ? A, ? V1, ? V2 | AV2V1  (AV1V2) DO SUCCEED;
	FAIL;
	END;


INTERNAL ITEMVAR PROCEDURE COPYITEM(ITEMVAR IV);
	BEGIN 
	COMMENT RETURNS NEW(DATUM(IV));
	CASE TYPEIT(IV) OF

		BEGIN
		
	[0]	BEGIN
		USERERR(CVN(IV),1," IS A DELETED ITEM.  COPYITEM LOSES HERE");
		RETURN(NEW);
		END;

	[1]	RETURN(NEW); COMMENT UNTYPED;

	[2]	BEGIN COMMENT A BRACKETED TRIPLE;
		USERERR(CVN(IV),1,"COPYITEM DOESNT KNOW ABOUT BRACKETED TRIPLES");
		RETURN(NEW);
		END;

	[3]	RETURN(NEW(DATUM(IV,STRING)));
	[4]	RETURN(NEW(DATUM(IV,REAL)));
	[5]	RETURN(NEW(DATUM(IV,INTEGER)));
	[6]	RETURN(NEW(DATUM(IV,SET)));
	[7]	RETURN(NEW(DATUM(IV,LIST)));
	[8]	BEGIN
		ITEMVAR XX; XX_NEW;
		ASSIGN(XX,DATUM(IV));
		RETURN(XX);
		END;
	[9]	BEGIN
		USERERR(CVN(IV),1," COPYITEM LOSES FOR PROCESSES");
		RETURN(NEW);
		END;
	[10]	BEGIN
		USERERR(CVN(IV),1," COPYITEM LOSES FOR EVENTS");
		RETURN(NEW);
		END;
	[11]	BEGIN
		USERERR(CVN(IV),1," COPYITEM LOSES FOR CONTEXTS");
		RETURN(NEW);
		END;
	[12]	BEGIN
		USERERR(CVN(IV),1," COPYITEM LOSES FOR REF ITEMS");
		RETURN(NEW);
		END;
	[16]	RETURN(NEW(DATUM(IV,STRING ARRAY)));
	[17]	RETURN(NEW(DATUM(IV,REAL ARRAY)));
	[18]	RETURN(NEW(DATUM(IV,INTEGER ARRAY)));
	[19]	RETURN(NEW(DATUM(IV,SET ARRAY)));
	[20]	RETURN(NEW(DATUM(IV,LIST ARRAY)));
	[24]	BEGIN
		USERERR(CVN(IV),1," CPOYITEM LOSES FOR CONTEXT ARRAYS");
		RETURN(NEW);
		END;
	[25]
		END;

	END;



INTERNAL PROCEDURE CPRLNS(ITEMVAR P1,P2);
	BEGIN
	ITEMVAR X,Y;
	 X,Y | P1XY DO MAKE P2XY;
	 X,Y | XP1Y DO MAKE XP2Y;
	 X,Y | XYP1 DO MAKE XYP2;
	END;

INTERNAL SIMPLE ITEMVAR PROCEDURE ITPCHK(ITEMVAR I;INTEGER T);
	BEGIN
	IF TYPEIT(I)T THEN
		USERERR(1,1,"ITEMVAR "&ITMNAM(I)&" HAS TYPE "&CVS(TYPEIT(I))&
				" INSTEAD OF "&CVS(T));
	RETURN(I);
	END;

INTERNAL SIMPLE ITEMVAR PROCEDURE PRPCHK(ITEMVAR I;INTEGER P);
	BEGIN
	IF (PROPS(I) LAND P) THEN
		USERERR(1,1,"ITEMVAR "&ITMNAM(I)&" LACKS PROP "&CVOS(P));
	RETURN(I);
	END;

INTERNAL SIMPLE ITEMVAR PROCEDURE PRPON(ITEMVAR I;INTEGER P);
	BEGIN
	PROPS(I)_PROPS(I) LOR P;
	RETURN(I);
	END;

INTERNAL SIMPLE ITEMVAR PROCEDURE PRPOFF(ITEMVAR I;INTEGER P);
	BEGIN
	PROPS(I)_PROPS(I) LAND (LNOT P);
	RETURN(I);
	END;

END