Artifact 57a28d4cb04f7ad66178379d95ee718d23b7b5a527fc3fab934e0a0f4d2d96dc:

• File psl-1983/kernel/sequence.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 11810) [annotate] [blame] [check-ins using] [more...]

%
% SEQUENCE.RED - Useful functions on strings, vectors and lists
% 
% Author:      Martin Griss and Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        10 September 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.KERNEL>SEQUENCE.RED.2, 25-Jan-83 16:11:28, Edit by PERDUE
%  Removed Make-String, leaving MkString.
%  STRINGS pkg defines Make-String (differently and Common LISP compatibly)
%  <PSL.INTERP>SEQUENCE.RED.2, 27-Feb-82 00:46:03, Edit by BENSON
%  Started adding more vector types
%  <PSL.INTERP>STRING-OPS.RED.11,  6-Jan-82 20:41:16, Edit by BENSON
%  Changed String and Vector into Nexprs

on SysLisp;

% Indexing operations

syslsp procedure Indx(R1, R2);		%. Element of sequence
begin scalar Tmp1, Tmp2;
    if not PosIntP R2 then return IndexError(R2, 'Indx);   % Subscript
    Tmp1 := Inf R1;
    Tmp2 := Tag R1;
    return case Tmp2 of
	Str, Bytes:
	    if R2 > StrLen Tmp1 then
		RangeError(R1, R2, 'Indx)
	    else StrByt(Tmp1, R2);
	Vect:
	    if R2 > VecLen Tmp1 then
		RangeError(R1, R2, 'Indx)
	    else VecItm(Tmp1, R2);
	Wrds:
	    if R2 > WrdLen Tmp1 then
		RangeError(R1, R2, 'Indx)
	    else WrdItm(Tmp1, R2);
	HalfWords:
	    if R2 > HalfWordLen Tmp1 then
		RangeError(R1, R2, 'Indx)
	    else HalfWordItm(Tmp1, R2);
	Pair:
	<<  Tmp2 := R2;
	    while Tmp2 > 0 do
	    <<  R1 := cdr R1;
		if atom R1 then RangeError(R1, R2, 'Indx);
		Tmp2 := Tmp2 - 1 >>;
	    car R1 >>;
	default:
	    NonSequenceError(R1, 'Indx);
    end;
end;

syslsp procedure SetIndx(R1, R2, R3);	%. Store at index of sequence
begin scalar Tmp1, Tmp2;
    if not PosIntP R2 then return IndexError(R2, 'SetIndx);   % Subscript
    Tmp1 := Inf R1;
    Tmp2 := Tag R1;
    return case Tmp2 of
	Str, Bytes:
	    if R2 > StrLen Tmp1 then
		RangeError(R1, R2, 'SetIndx)
	    else
	    <<  StrByt(Tmp1, R2) := R3;
		R3 >>;
	Vect:
	    if R2 > VecLen Tmp1 then
		RangeError(R1, R2, 'SetIndx)
	    else
	    <<  VecItm(Tmp1, R2) := R3;
		R3 >>;
	Wrds:
	    if R2 > WrdLen Tmp1 then
		RangeError(R1, R2, 'SetIndx)
	    else
	    <<  WrdItm(Tmp1, R2) := R3;
		R3 >>;
	HalfWords:
	    if R2 > HalfWordLen Tmp1 then
		RangeError(R1, R2, 'SetIndx)
	    else
	    <<  HalfWordItm(Tmp1, R2) := R3;
		R3 >>;
	Pair:
	<<  Tmp2 := R2;
	    while Tmp2 > 0 do
	    <<  R1 := cdr R1;
		if atom R1 then RangeError(R1, R2, 'SetIndx);
		Tmp2 := Tmp2 - 1 >>;
	    Rplaca(R1, R3);
	    R3 >>;
	default:
	    NonSequenceError(R1, 'SetIndx);
    end;
end;

% String and vector sub-part operations.

syslsp procedure Sub(R1, R2, R3);	%. Obsolete subsequence function
    SubSeq(R1, R2, R2 + R3 + 1);

syslsp procedure SubSeq(R1, R2, R3);	% R2 is lower bound, R3 upper
begin scalar NewSize, OldSize, NewItem;
    if not PosIntP R2 then return IndexError(R2, 'SubSeq);
    if not PosIntP R3 then return IndexError(R3, 'SubSeq);
    NewSize := R3 - R2 - 1;
    if NewSize < -1 then return RangeError(R1, R3, 'SubSeq);
    return case Tag R1 of
	Str, Bytes:
	<<  OldSize := StrLen StrInf R1;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq)
	    else
	    <<  NewItem := GtSTR NewSize;
		R3 := StrInf R1;
		for I := 0 step 1 until NewSize do
		    StrByt(NewItem, I) := StrByt(R3, R2 + I);
		case Tag R1 of
		    Str:
			MkSTR NewItem;
		    Bytes:
			MkBYTES NewItem;
		end >> >>;
	Vect:
	<<  OldSize := VecLen VecInf R1;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq)
	    else
	    <<  NewItem := GtVECT NewSize;
		R3 := VecInf R1;
		for I := 0 step 1 until NewSize do
		    VecItm(NewItem, I) := VecItm(R3, R2 + I);
		MkVEC NewItem >> >>;
	Wrds:
	<<  OldSize := WrdLen WrdInf R1;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq)
	    else
	    <<  NewItem := GtWRDS NewSize;
		R3 := WrdInf R1;
		for I := 0 step 1 until NewSize do
		    WrdItm(NewItem, I) := WrdItm(R3, R2 + I);
		MkWRDS NewItem >> >>;
	HalfWords:
	<<  OldSize := HalfWordLen HalfWordInf R1;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq)
	    else
	    <<  NewItem := GtHalfWords NewSize;
		R3 := HalfWordInf R1;
		for I := 0 step 1 until NewSize do
		    HalfWordItm(NewItem, I) := HalfWordItm(R3, R2 + I);
		MkHalfWords NewItem >> >>;
	Pair:
	<<  for I := 1 step 1 until R2 do
		if PairP R1 then R1 := rest R1
		else RangeError(R1, R2, 'SubSeq);
	    NewItem := NIL . NIL;
	    for I := 0 step 1 until NewSize do
		if PairP R1 then
		<<  TConc(NewItem, first R1);
		    R1 := rest R1 >>
		else RangeError(R1, R3, 'SubSeq);
	    car NewItem >>;
	default:
	    NonSequenceError(R1, 'SubSeq);
    end;
end;

syslsp procedure SetSub(R1, R2, R3, R4); %. Obsolete subsequence function
    SetSubSeq(R1, R2, R2 + R3 + 1, R4);

syslsp procedure SetSubSeq(R1, R2, R3, R4);	% R2 is lower bound, R3 upper
begin scalar NewSize, OldSize, SubSize, NewItem;
    if not PosIntP R2 then return IndexError(R2, 'SetSubSeq);
    if not PosIntP R3 then return IndexError(R3, 'SetSubSeq);
    NewSize := R3 - R2 - 1;
    if NewSize < -1 then return RangeError(R1, R3, 'SetSubSeq);
    case Tag R1 of
	Str, Bytes:
	<<  if not StringP R4 and not BytesP R4 then return
		NonStringError(R4, 'SetSubSeq);
	    OldSize := StrLen StrInf R1;
	    NewItem := StrInf R4;
	    SubSize := StrLen NewItem;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq)
	    else if not (NewSize eq SubSize) then
		RangeError(R4, NewSize, 'SetSubSeq)
	    else
	    <<  R3 := StrInf R1;
		for I := 0 step 1 until NewSize do
		    StrByt(R3, R2 + I) := StrByt(NewItem, I) >> >>;
	Vect:
	<<  if not VectorP R4 then return
		NonVectorError(R4, 'SetSubSeq);
	    OldSize := VecLen VecInf R1;
	    NewItem := VecInf R4;
	    SubSize := VecLen NewItem;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq)
	    else if not (NewSize eq SubSize) then
		RangeError(R4, NewSize, 'SetSubSeq)
	    else
	    <<  R3 := VecInf R1;
		for I := 0 step 1 until NewSize do
		    VecItm(R3, R2 + I) := VecItm(NewItem, I) >> >>;
	Wrds:
	<<  if not WrdsP R4 then return
		NonVectorError(R4, 'SetSubSeq);
	    OldSize := WrdLen WrdInf R1;
	    NewItem := WrdInf R4;
	    SubSize := WrdLen NewItem;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq)
	    else if not (NewSize eq SubSize) then
		RangeError(R4, NewSize, 'SetSubSeq)
	    else
	    <<  R3 := WrdInf R1;
		for I := 0 step 1 until NewSize do
		    WrdItm(R3, R2 + I) := WrdItm(NewItem, I) >> >>;
	HalfWords:
	<<  if not HalfWordsP R4 then return
		NonVectorError(R4, 'SetSubSeq);
	    OldSize := HalfWordLen HalfWordInf R1;
	    NewItem := HalfWordInf R4;
	    SubSize := HalfWordLen NewItem;
	    if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq)
	    else if not (NewSize eq SubSize) then
		RangeError(R4, NewSize, 'SetSubSeq)
	    else
	    <<  R3 := HalfWordInf R1;
		for I := 0 step 1 until NewSize do
		    HalfWordItm(R3, R2 + I) := HalfWordItm(NewItem, I) >> >>;
	Pair:
	<<  if not PairP R4 and not null R4 then return
		NonPairError(R4, 'SetSubSeq);
	    for I := 1 step 1 until R2 do
		if PairP R1 then R1 := rest R1
		else RangeError(R1, R2, 'SetSubSeq);
	    NewItem := R4;
	    for I := 0 step 1 until NewSize do
		if PairP R1 and PairP NewItem then
		<<  RPlaca(R1, first NewItem);
		    R1 := rest R1;
		    NewItem := rest NewItem >>
		else RangeError(R1, R3, 'SetSubSeq) >>;
	default:
	    NonSequenceError(R1, 'SetSubSeq);
    end;
    return R4;
end;

syslsp procedure Concat(R1, R2);	%. Concatenate 2 sequences
begin scalar I1, I2, Tmp1, Tmp2, Tmp3;
return case Tag R1 of
    STR, BYTES:
    <<  if not (StringP R2 or BytesP R2) then return
	    NonStringError(R2, 'Concat);
	Tmp1 := StrInf R1;
	Tmp2 := StrInf R2;
	I1 := StrLen Tmp1;
	I2 := StrLen Tmp2;
	Tmp3 := GtSTR(I1 + I2 + 1);		% R1 and R2 can move
	Tmp1 := StrInf R1;
	Tmp2 := StrInf R2;
	for I := 0 step 1 until I1 do
	    StrByt(Tmp3, I) := StrByt(Tmp1, I);
	for I := 0 step 1 until I2 do
	    StrByt(Tmp3, I1 + I + 1) := StrByt(Tmp2, I);
	if StringP R1 then MkSTR Tmp3 else MkBYTES Tmp3 >>;
    VECT:
    <<  if not VectorP R2 then return
	    NonVectorError(R2, 'Concat);
	Tmp1 := VecInf R1;
	Tmp2 := VecInf R2;
	I1 := VecLen Tmp1;
	I2 := VecLen Tmp2;
	Tmp3 := GtVECT(I1 + I2 + 1);		% R1 and R2 can move
	Tmp1 := VecInf R1;
	Tmp2 := VecInf R2;
	for I := 0 step 1 until I1 do
	    VecItm(Tmp3, I) := VecItm(Tmp1, I);
	for I := 0 step 1 until I2 do
	    VecItm(Tmp3, I1 + I + 1) := VecItm(Tmp2, I);
	MkVEC Tmp3 >>;
    WRDS:
    <<  if not WrdsP R2 then return
	    NonVectorError(R2, 'Concat);
	Tmp1 := WrdInf R1;
	Tmp2 := WrdInf R2;
	I1 := WrdLen Tmp1;
	I2 := WrdLen Tmp2;
	Tmp3 := GtWrds(I1 + I2 + 1);		% R1 and R2 can move
	Tmp1 := WrdInf R1;
	Tmp2 := WrdInf R2;
	for I := 0 step 1 until I1 do
	    WrdItm(Tmp3, I) := WrdItm(Tmp1, I);
	for I := 0 step 1 until I2 do
	    WrdItm(Tmp3, I1 + I + 1) := WrdItm(Tmp2, I);
	MkWRDS Tmp3 >>;
    HALFWORDS:
    <<  if not HalfWordsP R2 then return
	    NonVectorError(R2, 'Concat);
	Tmp1 := HalfWordInf R1;
	Tmp2 := HalfWordInf R2;
	I1 := HalfWordLen Tmp1;
	I2 := HalfWordLen Tmp2;
	Tmp3 := GtHalfWords(I1 + I2 + 1);		% R1 and R2 can move
	Tmp1 := HalfWordInf R1;
	Tmp2 := HalfWordInf R2;
	for I := 0 step 1 until I1 do
	    HalfWordItm(Tmp3, I) := HalfWordItm(Tmp1, I);
	for I := 0 step 1 until I2 do
	    HalfWordItm(Tmp3, I1 + I + 1) := HalfWordItm(Tmp2, I);
	MkHalfWords Tmp3 >>;
    PAIR, ID:
	if null R1 or PairP R1 then Append(R1, R2);
    default:
	NonSequenceError(R1, 'Concat);
    end;
end;

syslsp procedure Size S;		%. Upper bound of sequence
    case Tag S of
	STR, BYTES, WRDS, VECT, HALFWORDS:
	    GetLen Inf S;
	ID:
	    -1;
	PAIR:
	begin scalar I;
	    I := -1;
	    while PairP S do
	    <<  I := I + 1;
	        S := cdr S >>;
	    return I;
	end;
	default:
	    NonSequenceError(S, 'Size);
    end;

syslsp procedure MkString(L, C); %. Make str with upb L, all chars C
begin scalar L1, S;
    if IntP L then L1 := IntInf L else return NonIntegerError(L, 'MkString);
    if L1 < -1 then return NonPositiveIntegerError(L, 'MkString);
    S := GtStr L1;
    for I := 0 step 1 until L1 do
	StrByt(S, I) := C;
    return MkSTR S;
end;

syslsp procedure Make!-Bytes(L, C); %. Make byte vector with upb L, all items C
begin scalar L1, S;
    if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Bytes);
    if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Bytes);
    S := GtStr L1;
    for I := 0 step 1 until L1 do
	StrByt(S, I) := C;
    return MkBytes S;
end;

syslsp procedure Make!-HalfWords(L, C); %. Make h vect with upb L, all items C
begin scalar L1, S;
    if IntP L then L1 := IntInf L else
	return NonIntegerError(L, 'Make!-HalfWords);
    if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-HalfWords);
    S := GtHalfWords L1;
    for I := 0 step 1 until L1 do
	HalfWordItm(S, I) := C;
    return MkHalfWords S;
end;

syslsp procedure Make!-Words(L, C); %. Make w vect with upb L, all items C
begin scalar L1, S;
    if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Words);
    if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Words);
    S := GtWrds L1;
    for I := 0 step 1 until L1 do
	WrdItm(S, I) := C;
    return MkWrds S;
end;

syslsp procedure Make!-Vector(L, C); %. Make vect with upb L, all items C
begin scalar L1, S;
    if IntP L then L1 := IntInf L else return
	NonIntegerError(L, 'Make!-Vector);
    if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Vector);
    S := GtVECT L1;
    for I := 0 step 1 until L1 do
	VecItm(S, I) := C;
    return MkVEC S;
end;

off SysLisp;

% Maybe we want to support efficient compilation of these, as with LIST,
% by functions String2, String3, Vector2, Vector3, etc.

nexpr procedure String U;	%. Analogous to LIST, string constructor
    List2String U;

nexpr procedure Vector U;	%. Analogous to LIST, vector constructor
    List2Vector U;

END;