COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	BEGIN
C00012 ENDMK
C⊗;
BEGIN


SPECIAL ?&X?&, ?&Y?&;


EXPR PRELIST (L, N);
	FOR NEW ?&X?& ← 1 TO N FOR NEW I IN L COLLECT <I>;


EXPR SUFLIST (L, N);
	IF N LESSP 1 THEN L
	ELSE WHILE L AND NOT((N ← N-1) LESSP 0) DO L ← CDR L;


EXPR STR (X);
	PROG2(	IF X ← EXPLODEC X THEN RPLACD(LAST X, '(?")) ELSE X ← '(?"),
		READLIST('?" CONS X));


EXPR STRP (X);
	ATOM X AND NOT NUMBERP X AND ?&STRP(GET(X, 'PNAME), LAST GET(X, 'PNAME));


% EXPR STRP (X);	-- VERSION THAT DOES NOT USE THE LAP FUNCTION &STRP	%
%	ATOM X AND NOT NUMBERP X AND (X ← EXPLODE X)				%
%		AND CAR X EQ '?" AND CAR LAST(X) EQ '?";			%


EXPR STRLEN (X);
	LENGTH EXPLODEC X;


EXPR SEQ (X, Y);
	EXPLODEC X = EXPLODEC Y;


EXPR AT (X);
	IF NOT ATOM X THEN AT STR(X)
	ELSE IF NUMBERP X THEN READLIST('?/ CONS EXPLODE X)
	ELSE IF NOT STRP(X) THEN X
	ELSE	BEGIN  NEW S,D,G;
		G ← GENSYM();
		S ← GET(X, 'PNAME);
		PUTPROP(G,
			D ← MAPCAR(FUNCTION(LAMBDA (X);
				CAR GET(GENSYM(), 'PNAME)), S),
			'PNAME);
		RETURN(IF ?©(S, D) THEN '?&NONAME ELSE INTERN G);
		END;


% EXPR AT (X);		-- VERSION THAT DOES NOT USE THE LAP FUNCTION ©	%
%	READLIST(FOR NEW I IN EXPLODEC X COLLECT <'?/, I>);			%


EXPR CAT (X, Y);
	READLIST('?" CONS EXPLODEC X @ EXPLODEC Y @ <'?">);


EXPR SUBSTR (S, STRT, LEN);
	READLIST('?"
		CONS (	IF NUMBERP LEN THEN (EXPLODEC S)↓(STRT-1) ↑ LEN
			ELSE (EXPLODEC S)↓(STRT-1))
		@ <'?">);


EXPR PRINTSTR (X);
	TERPRI PRINC X;


EXPR PRINTTY (X);
	BEGIN  NEW FILE;
	FILE ← OUTC(NIL, NIL);
	PRINC X;
	PRINC " ";
	OUTC(FILE, NIL);
	RETURN X;
	END;


EXPR NEQ (X, Y);
	NOT(X EQ Y);


EXPR NEQUAL (X, Y);
	NOT(X EQUAL Y);


EXPR LEQUAL (X, Y);
	NOT(X GREATERP Y);


EXPR GEQUAL (X, Y);
	NOT(X LESSP Y);


EXPR ?&VECTOR (PREFIX, FN, X, Y);
	IF PREFIX THEN 
		IF X AND ATOM X THEN
			IF GET(FN, 'MACRO) THEN EVAL <FN, <'QUOTE, X>> ELSE FN(X)
		ELSE MAPCAR(FN, X)
	ELSE 	BEGIN
		NEW V, L, ATOMX, ATOMY, CARX, CARY, M;
		ATOMX ← X AND ATOM X;
		ATOMY ← Y AND ATOM Y;
		M     ← GET(FN, 'MACRO);
		IF ATOMX AND ATOMY THEN
			RETURN	IF M THEN EVAL <FN, <'QUOTE, X>, <'QUOTE, Y>>
				ELSE FN(X, Y);
		V ← L ← <NIL>;
	LOOP; 	IF NULL X OR NULL Y THEN RETURN CDR V;
		IF ATOMX THEN CARX ← X ELSE CARX ← CAR X ALSO X ← CDR X;
		IF ATOMY THEN CARY ← Y ELSE CARY ← CAR Y ALSO Y ← CDR Y;
		L ← CDR RPLACD(L,
		       <IF M THEN EVAL <FN, <'QUOTE, CARX>, <'QUOTE, CARY>>
			ELSE FN(CARX, CARY)>);
		GO LOOP;
		END;


EXPR ?&REPLACE (L, X, V);
	IF X THEN ?&REP1(L, X, V, CAR X, 1)
	ELSE V;


EXPR ?&REP1 (L, X, V, Y, N);
	IF ATOM L THEN 
		IF Y = N THEN ?&REPLACE(NIL, CDR X, V) CONS NIL
		ELSE NIL CONS ?&REP1(NIL, X, V, Y, ADD1 N)
	ELSE IF Y = N THEN ?&REPLACE(CAR L, CDR X, V) CONS CDR L
	ELSE CAR L CONS ?&REP1(CDR L, X, V, Y, ADD1 N);


EXPR ?&DECOMPOSE (TEM, L);
	PROG2(?&DEC1(TEM, L, NIL), L);


EXPR ?&DEC1 (TEM, L, U);
	IF NULL TEM THEN
		NULL L
	ELSE IF ATOM TEM THEN
		TEM EQ '_ OR SET(TEM, L) OR T
	ELSE IF ATOM L THEN
		(NULL L AND TEM = '(_)) OR ?&SETNIL(TEM)
	ELSE IF CAR TEM EQ '_ THEN
		?&DEC1(CDR TEM, L, T) OR ?&DEC1(TEM, CDR L, U)
	ELSE IF U THEN
		?&DEC1(CAR TEM, CAR L, T) AND ?&DEC1(CDR TEM, CDR L, T)
	ELSE U ← ?&DEC1(CAR TEM, CAR L, NIL)
		ALSO ?&DEC1(CDR TEM, CDR L, NIL) AND U;


EXPR ?&SETNIL (TEM);
	IF NULL TEM OR TEM EQ '_ THEN NIL
	ELSE IF ATOM TEM THEN SET(TEM, NIL)
	ELSE ?&SETNIL(CAR TEM) ALSO ?&SETNIL(CDR TEM);


INLINE	(LAP ?© SUBR)	% COPY(PNAME(SOURCE), PNAME(DESTINATION)) %
	(PUSH P 6)		% FREE UP ACC 6 FOR A COUNT %
	(MOVEI 6 4)		% CHARS_LEFT ← 4 %
	(PUSH P (C 0))		% PREVIOUS LINK %
	(MOVE 3 ISPTR_)		% INITIALIZE SOURCE BYTE POINTER %
	(MOVEM 3 SPTR_)
	(MOVE 3 IDPTR_)		% INITIALIZE DESTINATION BYTE POINTER %
	(MOVEM 3 DPTR_)
	(HLRZ?@ 4 1)		% 4 ← CAR(1) %
	(HLRZ?@ 5 2)		% 5 ← CAR(2) %
	(133000 0 SPTR_)	% IBP -- SKIP OVER THE FIRST " %
LOOP_	(134000 3 SPTR_)	% ILDB -- GET A CHARACTER %
	(CAIN 3 42)		% " ? %
	(JRST 0 FINISH_)	% YES %
	(136000 3 DPTR_)	% IDPB -- NO, DEPOSIT IT IN DESTINATION %
	(367000 6 LOOP_)	% SOJG -- CHARS_LEFT ← CHARS_LEFT-1 %
	(MOVEI 6 4)		% CHARS_LEFT ← 4 %
	(MOVEM 2 0 P)		% PREVIOUS LINK %
	(MOVE 3 ISPTR_)		% REINITIALIZE SOURCE BYTE POINTER %
	(MOVEM 3 SPTR_)
	(HRRZ?@ 1 1)		% 1 ← CDR(1) %
	(HLRZ?@ 4 1)		% 4 ← CAR(1) %
	(134000 3 SPTR_)	% ILDB -- GET FIRST CHARACTER IN NEXT WORD %
	(CAIN 3 42)		% " ? %
	(JRST 0 LASTCH_)	% YES %
	(136000 3 DPTR_)	% IDPB -- NO, DEPOSIT IT IN DESTINATION %
	(MOVE 3 IDPTR_)		% REINITIALIZE DESTINATION BYTE POINTER %
	(MOVEM 3 DPTR_)
	(HRRZ?@ 2 2)		% 2 ← CDR(2) %
	(HLRZ?@ 5 2)		% 5 ← CAR(2) %
	(JRST 0 LOOP_)
LASTCH_	(MOVEI 1 0)		% STICK 0 IN LAST CHARACTER OF DESTINATION %
	(136000 1 DPTR_)	% IDPB %
FINISH_	(MOVEI 1 0)		% RETURN NIL %
	(CAIN 6 4)
	(JRST 0 NULLCDR_)
LOOP1_	(136000 1 DPTR_)	% IDPB -- PAD OUT DESTINATION WITH 0'S %
	(365000 6 LOOP1_)	% SOJGE %
EXIT_	(POP P 2)
	(POP P 6)
	(POPJ P)
NULLCDR_(336000 0 0 P)			% SKIPN %
	(334000 1 (C 0 0 (QUOTE T) 0))	% SKIPA -- RETURN T IF NO CHARACTERS IN PNAME ("") %
	(HRRM?@ 1 0 P)			% RPLACD -- SHORTEN PNAME LIST BY ONE %
	(JRST 0 EXIT_)
ISPTR_	(440700 0 0 4)
IDPTR_	(440700 0 0 5)
SPTR_	(0)
DPTR_	(0)
	NIL;


INLINE	(LAP ?&STRP SUBR)	%		1	2	3	4	5		%
	(HLRZ?@ 3 1)		% CAR		WD1	WDL	ADDR1				%
	(MOVE 4 PTR_)		%		WD1	WDL	ADDR1	BP:44			%
	(134000 5 4)		% ILDB		WD1	WDL	ADDR1	BP:35	CHR1		%
	(CAIE 5 42)
	(JRST 0 FALSE_)		%		WD1	WDL	ADDR1	BP:35	CHR1≠"		%
	(MOVEI 5 5)		%		WD1	WDL	ADDR1	BP:35	COUNT=5		%
	(CAMN 1 2)
	(364000 5 LOOP_)	% SOJA		WD1  =	WDL	ADDR1	BP:35	COUNT=4		%
	(HLRZ?@ 3 2)		% CAR		WD1  ≠	WDL	ADDRL	BP:35	COUNT=5		%
	(MOVE 4 PTR_)		%		WD1	WDL	ADDRL	BP:44	COUNT=5		%
LOOP_	(134000 1 4)		% ILDB		CHR	WDL	ADDRL	BP	COUNT		%
	(JUMPE 1 FALSE_)	%		CHR=0	WDL	ADDRL	BP	COUNT		%
	(CAIN 1 42)
	(JRST 0 TRUE_)		%		CHR="	WDL	ADDRL	BP	COUNT		%
	(367000 5 LOOP_)	% SOJG		CHR	WDL	ADDRL	BP	COUNT-1		%
FALSE_	(TDZA 1 1)
TRUE_	(MOVEI 1 (QUOTE T))
	(POPJ P)
PTR_	(440700 0 0 3)
	NIL;


END.