Artifact c875d7313dfb71bbf96b3ddd7445944fd730239caa63bf99de879e7c7ee33fc9:

• File psl-1983/kernel/printers.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: 18167) [annotate] [blame] [check-ins using] [more...]

%
% PRINTERS.RED - Printing functions for various data types
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        27 August 1981
% Copyright (c) 1981 University of Utah
%
%  <PSL.KERNEL>PRINTERS.RED.17,  7-Mar-83 11:53:59, Edit by KESSLER
%  Change Channelwriteblankoreol to check linelength = 0 also.
% Edit by MLGriss, 11:31am  Saturday, 5 February 1983
%   Fix ChannelWriteBitstring to put out a single 0 if needed
%   Fixed to handle largest NEGATIVE number correctly
%   Used to get ------, since -(largest neg) NOT=largestPOS
% <PSL.KERNEL>PRINTERS.RED.14, 31-Jan-83 15:45:30, Edit by PERDUE
% Fix to printing of EVECTORs
% Edit by Cris Perdue, 29 Jan 1983 1620-PST
% Removed definition of EVecInf (both compile- and load-time)
% Edit by Cris Perdue, 27 Jan 1983 1436-PST
% Put in Kessler's change so CheckLineFit won't write EOL if LineLength = 0
%  <PSL.KERNEL>PRINTERS.RED.11, 10-Jan-83 13:58:14, Edit by PERDUE
%  Added some code to handle EVectors, especially to represent OBJECTs
%  <PSL.KERNEL>PRINTERS.RED.10, 21-Dec-82 15:24:18, Edit by BENSON
%  Changed order of tests in WriteInteger so that -ive hex #s are done right
%  <PSL.KERNEL>PRINTERS.RED.9,  4-Oct-82 10:04:34, Edit by BENSON
%  Added PrinLength and PrinLevel
%  <PSL.KERNEL>PRINTERS.RED.3, 23-Sep-82 13:16:20, Edit by BENSON
%  Look for # of args in code pointer, changed : to space in #<...> stuff
%  <PSL.INTERP>PRINTERS.RED.12,  2-Sep-82 09:01:31, Edit by BENSON
%  (QUOTE x y) prints correctly, not as 'x
%  <PSL.INTERP>PRINTERS.RED.11,  4-May-82 20:31:32, Edit by BENSON
%  Printers keep tags on, for Emode GC
%  <PSL.VAX-INTERP>PRINTERS.RED.6, 18-Feb-82 16:30:12, Edit by BENSON
%  Added printer for unbound, changed code to #<Code:xx>
%  <PSL.VAX-INTERP>PRINTERS.RED.2, 20-Jan-82 02:11:16, Edit by GRISS
%  fixed prining of zero length vectors
%  <PSL.VAX-INTERP>PRINTERS.RED.1, 15-Jan-82 14:27:13, Edit by BENSON
%  Changed for new integer tags
%  <PSL.INTERP>PRINTERS.RED.13,  7-Jan-82 22:47:40, Edit by BENSON
%  Made (QUOTE xxx) print as 'xxx
%  <PSL.INTERP>PRINTERS.RED.12,  5-Jan-82 21:37:41, Edit by BENSON
%  Changed OBase to OutputBase!*

fluid '(OutputBase!*			% current output base
        PrinLength			% length of structures to print
	PrinLevel			% level of recursion to print
	CurrentScanTable!*
	IDEscapeChar!*
	!*Lower);		% print IDs with uppercase chars lowered
global '(LispScanTable!*);

LoadTime
<<  OutputBase!* := 10;
    IDEscapeChar!* := 33;		% (char !!)
    CurrentScanTable!* := LispScanTable!* >>; % so TokenTypeOfChar works right

on SysLisp;

CompileTime <<
syslsp smacro procedure UpperCaseP Ch;
    Ch >= char A and Ch <= char Z;

syslsp smacro procedure LowerCaseP Ch;
    Ch >= char !a and Ch <= char !z;

syslsp smacro procedure RaiseChar Ch;
    (Ch - char !a) + char A;

syslsp smacro procedure LowerChar Ch;
    (Ch - char A) + char !a;
>>;

CompileTime flag('(CheckLineFit WriteNumber1 ChannelWriteBitString),
		 'InternalFunction);

%. Writes EOL first if given Len causes max line length to be exceeded
syslsp procedure CheckLineFit(Len, Chn, Fn, Itm);
<<  if (LinePosition[Chn] + Len > MaxLine[Chn]) and (MaxLine[Chn] > 0) then
	ChannelWriteChar(Chn, char EOL);
    IDApply2(Chn, Itm, Fn) >>;

syslsp procedure ChannelWriteString(Channel, Strng);
%
% Strng may be tagged or not, but it must have a length field accesible
% by StrLen.
%
begin scalar UpLim;
    UpLim := StrLen StrInf Strng;
    for I := 0 step 1 until UpLim do
	ChannelWriteChar(Channel, StrByt(StrInf Strng, I));
end;

syslsp procedure WriteString S;
    ChannelWriteString(LispVar OUT!*, S);

internal WString DigitString = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
internal WString WriteNumberBuffer[40];

syslsp procedure ChannelWriteSysInteger(Channel, Number, Radix);
begin scalar Exponent,N1;
    return if (Exponent := SysPowerOf2P Radix) then
	ChannelWriteBitString(Channel, Number, Radix - 1, Exponent)
    else if Number < 0 then
    <<  ChannelWriteChar(Channel, char '!-);
        WriteNumber1(Channel,-(Number/Radix),Radix); % To catch largest NEG
	ChannelWriteChar(Channel,
			 StrByt(DigitString, - MOD(Number, Radix))) >>
    else if Number = 0 then ChannelWriteChar(Channel, char !0)
    else WriteNumber1(Channel, Number, Radix);
end;

syslsp procedure WriteNumber1(Channel, Number, Radix);
    if Number = 0 then Channel
    else
    <<  WriteNumber1(Channel, Number / Radix, Radix);
	ChannelWriteChar(Channel,
			 StrByt(DigitString, MOD(Number, Radix))) >>;

syslsp procedure ChannelWriteBitString(Channel, Number, DigitMask, Exponent);
 if Number = 0 then ChannelWriteChar(Channel,char !0)
  else  ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent);

syslsp procedure ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent);
    if Number = 0 then Channel		% Channel means nothing here
    else				% just trying to fool the compiler
    <<  ChannelWriteBitStrAux(Channel,
			      LSH(Number, -Exponent),
			      DigitMask,
			      Exponent);
	ChannelWriteChar(Channel,
			 StrByt(DigitString,
				LAND(Number, DigitMask))) >>;

syslsp procedure WriteSysInteger(Number, Radix);
    ChannelWriteSysInteger(LispVar OUT!*, Number, Radix);

syslsp procedure ChannelWriteFixnum(Channel, Num);
    ChannelWriteInteger(Channel, FixVal FixInf Num);

syslsp procedure ChannelWriteInteger(Channel, Num);
begin scalar CurrentBase;
    if (CurrentBase := LispVar OutputBase!*) neq 10 then
    <<  ChannelWriteSysInteger(Channel, CurrentBase, 10);
	ChannelWriteChar(Channel, char !#) >>;
    ChannelWriteSysInteger(Channel,
			   Num,
			   CurrentBase);
end;

syslsp procedure ChannelWriteSysFloat(Channel, FloatPtr);
begin scalar Ch, ChIndex;
    WriteFloat(WriteNumberBuffer, FloatPtr);
    ChannelWriteString(Channel, WriteNumberBuffer);
end;

syslsp procedure ChannelWriteFloat(Channel, LispFloatPtr);
    ChannelWriteSysFloat(Channel, FloatBase FltInf LispFloatPtr);

syslsp procedure ChannelPrintString(Channel, Strng);
begin scalar Len, Ch;
    ChannelWriteChar(Channel, char !");
    Len := StrLen StrInf Strng;
    for I := 0 step 1 until Len do
    <<  Ch := StrByt(StrInf Strng, I);
	if Ch eq char !" then ChannelWriteChar(Channel, char !");
	ChannelWriteChar(Channel, Ch) >>;
    ChannelWriteChar(Channel, char !");
end;

syslsp procedure ChannelWriteID(Channel, Itm);
    if not LispVar !*Lower then
	ChannelWriteString(Channel, SymNam IDInf Itm)
    else begin scalar Ch, Len;
	Itm := StrInf SymNam IDInf Itm;
	Len := StrLen Itm;
	for I := 0 step 1 until Len do
	<<  Ch := StrByt(Itm, I);
	    if UpperCaseP Ch then Ch := LowerChar Ch;
	    ChannelWriteChar(Channel, Ch) >>;
    end;

syslsp procedure ChannelWriteUnbound(Channel, Itm);
<<  ChannelWriteString(Channel, "#<Unbound:");
    ChannelWriteID(Channel, Itm);
    ChannelWriteChar(Channel, char '!>) >>;

syslsp procedure ChannelPrintID(Channel, Itm);
begin scalar Len, Ch, TokenType;
    Itm := StrInf SymNam IDInf Itm;
    Len := StrLen Itm;
    Ch := StrByt(Itm, 0);
    if TokenTypeOfChar Ch neq 10 then ChannelWriteChar(Channel,
						       LispVar IDEscapeChar!*);
    if not LispVar !*Lower then
    <<  ChannelWriteChar(Channel, Ch);
	for I := 1 step 1 until Len do
	<<  Ch := StrByt(Itm, I);
	    TokenType := TokenTypeOfChar Ch;
	    if not (TokenType <= 10
			or TokenType eq PLUSSIGN
			or TokenType eq MINUSSIGN) then
		ChannelWriteChar(Channel, LispVar IDEscapeChar!*);
	    ChannelWriteChar(Channel, Ch) >> >>
    else
    <<  if UpperCaseP Ch then Ch := LowerChar Ch;
	ChannelWriteChar(Channel, Ch);
	for I := 1 step 1 until Len do
	<<  Ch := StrByt(Itm, I);
	    TokenType := TokenTypeOfChar Ch;
	    if not (TokenType <= 10
			or TokenType eq PLUSSIGN
			or TokenType eq MINUSSIGN) then
	        ChannelWriteChar(Channel, LispVar IDEscapeChar!*);
	    if UpperCaseP Ch then Ch := LowerChar Ch;
	    ChannelWriteChar(Channel, Ch) >> >>
end;

syslsp procedure ChannelPrintUnbound(Channel, Itm);
<<  ChannelWriteString(Channel, "#<Unbound ");
    ChannelPrintID(Channel, Itm);
    ChannelWriteChar(Channel, char '!>) >>;

syslsp procedure ChannelWriteCodePointer(Channel, CP);
begin scalar N;
    CP := CodeInf CP;
    ChannelWriteString(Channel, "#<Code ");
    N := !%code!-number!-of!-arguments CP;
    if N >= 0 and N <= MaxArgs then
    <<  ChannelWriteSysInteger(Channel, N, 10);
	ChannelWriteChar(Channel, char BLANK) >>:
    ChannelWriteSysInteger(Channel, CP, CompressedBinaryRadix);
    ChannelWriteChar(Channel, char '!>);
end;

syslsp procedure ChannelWriteUnknownItem(Channel, Itm);
<<  ChannelWriteString(Channel, "#<Unknown ");
    ChannelWriteSysInteger(Channel, Itm, CompressedBinaryRadix);
    ChannelWriteChar(Channel, char !>) >>;

syslsp procedure ChannelWriteBlankOrEOL Channel;
<<  if (LinePosition[Channel] + 1 >= MaxLine[Channel]) and
       (MaxLine[Channel] > 0) then
	ChannelWriteChar(Channel, char EOL)
    else
	ChannelWriteChar(Channel, char ! ) >>;

syslsp procedure ChannelWritePair(Channel, Itm, Level);
    if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then
	ChannelWriteChar(Channel, char '!#)
    else
begin scalar N;
    Level := Level + 1;
    CheckLineFit(1, Channel, 'ChannelWriteChar, char !( );
    if not IntP LispVar PrinLength or 1 <= LispVar PrinLength then
    <<  RecursiveChannelPrin2(Channel, car Itm, Level);
	N := 2;
	Itm := cdr Itm;
	while PairP Itm and
		(not IntP LispVar PrinLength or N <= LispVar PrinLength) do
	<<  ChannelWriteBlankOrEOL Channel;
	    RecursiveChannelPrin2(Channel, car Itm, Level);
	    N := N + 1;
	    Itm := cdr Itm >>;
	if PairP Itm then
	    CheckLineFit(3, Channel, 'ChannelWriteString, " ...")
	else
	if Itm then
	<<  CheckLineFit(3, Channel, 'ChannelWriteString, " . ");
	    RecursiveChannelPrin2(Channel, Itm, Level) >> >>
    else
	CheckLineFit(3, Channel, 'ChannelWriteString, "...");
    CheckLineFit(1, Channel, 'ChannelWriteChar, char !) );
end;

syslsp procedure ChannelPrintPair(Channel, Itm, Level);
    if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then
	ChannelWriteChar(Channel, char '!#)
    else
begin scalar N;
    Level := Level + 1;
    CheckLineFit(1, Channel, 'ChannelWriteChar, char !( );
    if not IntP LispVar PrinLength or 1 <= LispVar PrinLength then
    <<  RecursiveChannelPrin1(Channel, car Itm, Level);
	N := 2;
	Itm := cdr Itm;
	while PairP Itm and
		(not IntP LispVar PrinLength or N <= LispVar PrinLength) do
	<<  ChannelWriteBlankOrEOL Channel;
	    RecursiveChannelPrin1(Channel, car Itm, Level);
	    N := N + 1;
	    Itm := cdr Itm >>;
	if PairP Itm then
	    CheckLineFit(3, Channel, 'ChannelWriteString, " ...")
	else
	if Itm then
	<<  CheckLineFit(3, Channel, 'ChannelWriteString, " . ");
	    RecursiveChannelPrin1(Channel, Itm, Level) >> >>
    else
	CheckLineFit(3, Channel, 'ChannelWriteString, "...");
    CheckLineFit(1, Channel, 'ChannelWriteChar, char !) );
end;

syslsp procedure ChannelWriteVector(Channel, Vec, Level);
    if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then
	ChannelWriteChar(Channel, char '!#)
    else
begin scalar Len, I;
    Level := Level + 1;
    CheckLineFit(1, Channel, 'ChannelWriteChar, char '![ );
    Len := VecLen VecInf Vec;
    If Len<0 then     
      return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] );
    I := 0;
LoopBegin:
    if not IntP LispVar PrinLength or I < LispVar PrinLength then
    <<  RecursiveChannelPrin2(Channel, VecItm(VecInf Vec, I), Level);
	if (I := I + 1) <= Len then
	<<  ChannelWriteBlankOrEOL Channel;
	    goto LoopBegin >> >>
    else
	CheckLineFit(3, Channel, 'ChannelWriteString, "...");	
    CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] );
end;

syslsp procedure ChannelPrintVector(Channel, Vec, Level);
    if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then
	ChannelWriteChar(Channel, char '!#)
    else
begin scalar Len, I;
    Level := Level + 1;
    CheckLineFit(1, Channel, 'ChannelWriteChar, char '![ );
    Len := VecLen VecInf Vec;
    If Len<0 then     
      return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] );
    I := 0;
LoopBegin:
    if not IntP LispVar PrinLength or I < LispVar PrinLength then
    <<  RecursiveChannelPrin1(Channel, VecItm(VecInf Vec, I), Level);
	if (I := I + 1) <= Len then
	<<  ChannelWriteBlankOrEOL Channel;
	    goto LoopBegin >> >>
    else
	CheckLineFit(3, Channel, 'ChannelWriteString, "...");	
    CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] );
end;

syslsp procedure ChannelWriteEVector(Channel, EVec, Level);
begin
    scalar handler;
    if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then
	ChannelWriteChar(Channel, char '!#)
    else
        if getd('object!-get!-handler!-quietly)
	   and (handler :=
	         object!-get!-handler!-quietly(EVec, 'ChannelPrin)) then
	   apply(handler, list(EVec, Channel, Level, NIL))
	else
	<< ChannelWriteString(Channel, "#<EVector ");
	   ChannelWriteSysInteger(Channel, EVecInf EVec,
					CompressedBinaryRadix);
	   ChannelWriteChar(Channel, char '!>); >>;
end;

syslsp procedure ChannelPrintEVector(Channel, EVec, Level);
begin
    scalar handler;
    if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then
	ChannelWriteChar(Channel, char '!#)
    else
        if getd('object!-get!-handler!-quietly)
	   and (handler :=
	         object!-get!-handler!-quietly(EVec, 'ChannelPrin)) then
	   apply(handler, list(EVec, Channel, Level, T))
	else
	<< ChannelWriteString(Channel, "#<EVector ");
	   ChannelWriteSysInteger(Channel, EVecInf EVec,
					CompressedBinaryRadix);
	   ChannelWriteChar(Channel, char '!>); >>;
end;

syslsp procedure ChannelWriteWords(Channel, Itm);
begin scalar Len, I;
    ChannelWriteString(Channel, "#<Words:");
    Len := WrdLen WrdInf Itm;
    if Len < 0 then     
      return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> );
    I := 0;
LoopBegin:
    if not IntP LispVar PrinLength or I < LispVar PrinLength then
    <<  CheckLineFit(10, Channel, 'ChannelWriteInteger, WrdItm(WrdInf Itm, I));
	if (I := I + 1) <= Len then
	<<  ChannelWriteBlankOrEOL Channel;
	    goto LoopBegin >> >>
    else
	CheckLineFit(3, Channel, 'ChannelWriteString, "...");
    CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> );
end;

syslsp procedure ChannelWriteHalfWords(Channel, Itm);
begin scalar Len, I;
    ChannelWriteString(Channel, "#<Halfwords:");
    Len := HalfWordLen HalfWordInf Itm;
    if Len < 0 then     
      return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> );
    I := 0;
LoopBegin:
    if not IntP LispVar PrinLength or I < LispVar PrinLength then
    <<  CheckLineFit(10, Channel, 'ChannelWriteInteger,
			HalfWordItm(HalfWordInf Itm, I));
	if (I := I + 1) <= Len then
	<<  ChannelWriteBlankOrEOL Channel;
	    goto LoopBegin >> >>
    else
	CheckLineFit(3, Channel, 'ChannelWriteString, "...");
    CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> );
end;

syslsp procedure ChannelWriteBytes(Channel, Itm);
begin scalar Len, I;
    ChannelWriteString(Channel, "#<Bytes:");
    Len := StrLen StrInf Itm;
    if Len < 0 then     
      return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> );
    I := 0;
LoopBegin:
    if not IntP LispVar PrinLength or I < LispVar PrinLength then
    <<  CheckLineFit(10, Channel, 'ChannelWriteInteger, StrByt(StrInf Itm, I));
	if (I := I + 1) <= Len then
	<<  ChannelWriteBlankOrEOL Channel;
	    goto LoopBegin >> >>
    else
	CheckLineFit(3, Channel, 'ChannelWriteString, "...");
    CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> );
end;

syslsp procedure ChannelPrin2(Channel, Itm);	%. Display Itm on Channel
    RecursiveChannelPrin2(Channel, Itm, 0);

syslsp procedure RecursiveChannelPrin2(Channel, Itm, Level);
<<  case Tag Itm of
	PosInt, NegInt:
	    CheckLineFit(10, Channel, 'ChannelWriteInteger, Itm);
	ID:
	    CheckLineFit(StrLen StrInf SymNam IDInf Itm + 1,
				Channel, 'ChannelWriteID, Itm);
	UNBOUND:
	    CheckLineFit(StrLen StrInf SymNam IDInf Itm + 12,
				Channel, 'ChannelWriteUnbound, Itm);
	STR:
	    CheckLineFit(StrLen StrInf Itm + 1,
				Channel, 'ChannelWriteString, Itm);
	CODE:
	    CheckLineFit(14, Channel, 'ChannelWriteCodePointer, Itm);
	FIXN:
	    CheckLineFit(20, Channel, 'ChannelWriteFixnum, Itm);
	FLTN:
	    CheckLineFit(30, Channel, 'ChannelWriteFloat, Itm);
	WRDS:
	    ChannelWriteWords(Channel, Itm);
	Halfwords:
	    ChannelWriteHalfWords(Channel, Itm);
	Bytes:
	    ChannelWriteBytes(Channel, Itm);
	PAIR:
	    ChannelWritePair(Channel, Itm, Level);
	VECT:
	    ChannelWriteVector(Channel, Itm, Level);
	EVECT:
	    ChannelWriteEVector(Channel, Itm, Level);
	default: 
	    CheckLineFit(20, Channel, 'ChannelWriteUnknownItem, Itm)
    end;
    Itm >>;

syslsp procedure Prin2 Itm;		%. ChannelPrin2 to current channel
    ChannelPrin2(LispVar OUT!*, Itm);

syslsp procedure ChannelPrin1(Channel, Itm);	%. Display Itm in READable form
    RecursiveChannelPrin1(Channel, Itm, 0);

syslsp procedure RecursiveChannelPrin1(Channel, Itm, Level);
<<  case Tag Itm of
	PosInt, NegInt:
	    CheckLineFit(10, Channel, 'ChannelWriteInteger, Itm);
	ID:				% leave room for possible escape chars
	    CheckLineFit(StrLen StrInf SymNam IDInf Itm + 5,
				Channel, 'ChannelPrintID, Itm);
	UNBOUND:			% leave room for possible escape chars
	    CheckLineFit(StrLen StrInf SymNam IDInf Itm + 16,
				Channel, 'ChannelPrintUnbound, Itm);
	STR:
	    CheckLineFit(StrLen StrInf Itm + 4,
				Channel, 'ChannelPrintString, Itm);
	CODE:
	    CheckLineFit(14, Channel, 'ChannelWriteCodePointer, Itm);
	FIXN:
	    CheckLineFit(20, Channel, 'ChannelWriteFixnum, Itm);
	FLTN:
	    CheckLineFit(20, Channel, 'ChannelWriteFloat, Itm);
	WRDS:
	    ChannelWriteWords(Channel, Itm);
	Halfwords:
	    ChannelWriteHalfWords(Channel, Itm);
	Bytes:
	    ChannelWriteBytes(Channel, Itm);
	PAIR:
	    ChannelPrintPair(Channel, Itm, Level);
	VECT:
	    ChannelPrintVector(Channel, Itm, Level);
	EVECT:
	    ChannelPrintEVector(Channel, Itm, Level);
	default: 
	    CheckLineFit(20, Channel, 'ChannelWriteUnknownItem, Itm)
    end;
    Itm >>;

syslsp procedure Prin1 Itm;		%. ChannelPrin1 to current output
    ChannelPrin1(LispVar OUT!*, Itm);

off SysLisp;

END;