reduce-historical/psl-1983/kernel/printers.red

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