Artifact 827e9e3c6e8155c92cec1b76335b6938351a88543030281c589fd2526f979876:

• File psl-1983/3-1/kernel/cons-mkvect.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: 4917) [annotate] [blame] [check-ins using] [more...]

%
% CONS-MKVECT.RED - Standard Lisp constructor functions
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        20 August 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.KERNEL>CONS-MKVECT.RED.4, 28-Feb-83 11:41:46, Edit by PERDUE
%  Moved Make-Words, Make-Halfwords, etc. here from SEQUENCE.RED
%  Also moved STRING and VECTOR here from there.
% Edit by Cris Perdue, 23 Feb 1983 1045-PST
% Changed occurrences of HeapUpperbound to HeapTrapBound in optimized
% allocators to supported pre-GC traps.
%  <PSL.KERNEL>CONS-MKVECT.RED.2, 10-Jan-83 15:50:08, Edit by PERDUE
%  Added MkEVect
% Edit by GRISS: (?)
% Optimized CONS, XCONS and NCONS
%  <PSL.INTERP>CONS-MKVECT.RED.5,  9-Feb-82 06:25:51, Edit by GRISS
%  Added HardCons

CompileTime flag('(HardCons), 'InternalFunction);

on SysLisp;

external WVar HeapLast, HeapTrapBound;

syslsp procedure HardCons(U, V);	% Basic CONS with car U and cdr V
begin scalar P;
    HeapLast := HeapLast - AddressingUnitsPerItem*PairPack();
    P := GtHeap PairPack();
    P[0] := U;
    P[1] := V;
    return MkPAIR P;
end;

syslsp procedure Cons(U, V);		%. Construct pair with car U and cdr V
begin scalar HP;
return
<<  HP := HeapLast;
    if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack())
		> HeapTrapBound then
	HardCons(U, V)
    else
    <<  HP[0] := U;
	HP[1] := V;
	MkPAIR HP >> >>;
end;

syslsp procedure XCons(U, V);		%. eXchanged Cons
begin scalar HP;
return
<<  HP := HeapLast;
    if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack())
		> HeapTrapBound then
	HardCons(V, U)
    else
    <<  HP[0] := V;
	HP[1] := U;
	MkPAIR HP >> >>;
end;

syslsp procedure NCons U;		%. U . NIL
begin scalar HP;
return
<<  HP := HeapLast;
    if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack())
		> HeapTrapBound then
	HardCons(U, NIL)
    else
    <<  HP[0] := U;
	HP[1] := NIL;
	MkPAIR HP >> >>;
end;

syslsp procedure MkVect N;		%. Allocate vector, init all to NIL
    if IntP N then
    <<  N := IntInf N;
	if N < (-1) then
	    StdError
		'"A vector with fewer than zero elements cannot be allocated"
	else begin scalar V;
	    V := GtVect N;
	    for I := 0 step 1 until N do VecItm(V, I) := NIL;
	    return MkVEC V;		% Tag it
	end >>
    else NonIntegerError(N, 'MkVect);

syslsp procedure MkEVECTOR(N,ETAG);      %. Allocate Evect, init all to NIL
    if IntP N then
    <<  N := IntInf N;
        if N < (-1) then
            StdError
                '"An  Evect with fewer than zero elements cannot be allocated"
        else begin scalar V;
            V := GtEVect N;
            EVecItm(V,0):=ETAG;
            for I := 1 step 1 until N do VecItm(V, I) := NIL;
            return MkEVECT V;            % Tag it
        end >>
    else NonIntegerError(N, 'MkEVECT);

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;

% 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;

off SysLisp;

END;