reduce-historical/r30/part.red

SYMBOLIC PROCEDURE SIMPPART U;
   BEGIN SCALAR EXPN;
      EXPN := PREPSQ!* SIMP!* CAR U;
      U := CDR U;
      WHILE U DO
	 BEGIN SCALAR X,Y;
	   IF ATOM EXPN
	     THEN MSGPRI("Expression",EXPN,
			 "does not have part",CAR U,T)
            ELSE IF NOT NUMBERP(X := REVAL CAR U)
	     THEN MSGPRI("Invalid argument",CAR U,"to part",NIL,T)
	    ELSE IF X=0
	     THEN RETURN <<EXPN := CAR EXPN; U := NIL>>
	    ELSE IF X<0 THEN <<X := -X; Y := REVERSE CDR EXPN>>
 	    ELSE Y := CDR EXPN;
	   IF LENGTH Y<X
	     THEN MSGPRI("Expression",EXPN,
			 "does not have part",CAR U,T)
	    ELSE EXPN := NTH(Y,X);
       U := CDR U
     END;
      RETURN SIMP EXPN
   END;

PUT('PART,'SIMPFN,'SIMPPART);

SYMBOLIC PROCEDURE SIMPSETPART U;
   %Simplifies a SETPART expression;
   (LAMBDA X; SIMP SIMPSETP1(PREPSQ!* SIMP!* CAR U,REVERSE CDR X,CAR X))
    REVERSE CDR U;

SYMBOLIC PROCEDURE SIMPSETP1(EXPN,PTLIST,REP);
   IF NULL PTLIST THEN REP
    ELSE IF ATOM EXPN
	     THEN MSGPRI("Expression",EXPN,
			 "does not have part",CAR PTLIST,T)
    ELSE BEGIN SCALAR X;
      IF NOT NUMBERP(X := REVAL CAR PTLIST)
	     THEN MSGPRI("Invalid argument",CAR PTLIST,"to part",NIL,T)
       ELSE RETURN 
	IF X=0 THEN REP . CDR EXPN
	 ELSE IF X<0
	  THEN CAR EXPN . 
		REVERSE SSL(REVERSE CDR EXPN,
			    -X,CDR PTLIST,REP,EXPN . CAR PTLIST)
	 ELSE CAR EXPN . SSL(CDR EXPN,X,CDR PTLIST,
			     REP,EXPN . CAR PTLIST)
   END;

SYMBOLIC PROCEDURE SSL(EXPN,INDX,PTLIST,REP,REST);
   IF NULL EXPN
     THEN MSGPRI("Expression",CAR REST,"does not have part",CDR REST)
    ELSE IF INDX=1 THEN SIMPSETP1(CAR EXPN,PTLIST,REP) . CDR EXPN
    ELSE CAR EXPN . SSL(CDR EXPN,INDX-1,PTLIST,REP,REST);

PUT('PART,'SETQFN,'SETPART!*);

PUT('SETPART!*,'SIMPFN,'SIMPSETPART);

SYMBOLIC PROCEDURE ARGLENGTH U;
   BEGIN SCALAR X;
      X := PREPSQ!* SIMP!* U;
      RETURN IF ATOM X THEN -1 ELSE LENGTH CDR X
   END;

FLAG('(ARGLENGTH),'OPFN);


END;