Artifact f9e6c27c1f808e8ce8ab72377ab10d2f4732b130fb90c24f16f4b553ea6ab692:

• File psl-1983/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: 2685) [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
%

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

off SysLisp;

END;