Artifact 29848500467da8c11ba378a1ad8f9560350d57aeda7105988295cb8b7437ef3b:

• File psl-1983/3-1/util/format.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: 4727) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/format.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: 4727) [annotate] [blame] [check-ins using]

%
% Format.RED - Formatted print routine
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        27 August 1981
% Copyright (c) 1981 University of Utah
%


CompileTime <<

load(Syslisp, Fast!-Vector);

flag('(format!-freshline format1 format2 clear!-string!-write
	return!-string!-write), 'internalfunction);

fluid '(FormatForFormat!* string!-write!-channel next!-string!-write!-char
        string!-write!-buffer);

>>;

% First, lambda-bind FormatForFormat!*

lisp procedure Format(Stream, FormatForFormat!*, A1, A2, A3, A4, A5,
					 A6, A7, A8, A9, A10,
					 A11, A12, A13);
 Format1(Stream, FormatForFormat!*, A1, A2, A3, A4, A5,
			    A6, A7, A8, A9, A10,
			    A11, A12, A13);


% Then, push all the registers on the stack and set up a pointer to them

lap '((!*entry Format1 expr 15)
	(!*PUSH (reg 3))
	(!*LOC (reg 2) (frame 1))
	(!*PUSH (reg 4))
	(!*PUSH (reg 5))
	(!*PUSH (reg 6))
	(!*PUSH (reg 7))
	(!*PUSH (reg 8))
	(!*PUSH (reg 9))
	(!*PUSH (reg 10))
	(!*PUSH (reg 11))
	(!*PUSH (reg 12))
	(!*PUSH (reg 13))
	(!*PUSH (reg 14))
	(!*PUSH (reg 15))
	(!*CALL Format2)
	(!*EXIT 14)
);

on SysLisp;

% Finally, actual Format, with 2 arguments, stream and
% pointer to array of parameters

syslsp procedure Format2(Stream, FormatArgs); %. Formatted print
%
% If the character is not one of these (either upper or lower case), then an
% error occurs.
%
begin scalar UpLim, I, Ch, UpCh;
    if Stream eq NIL then
    <<  Stream := lispvar string!-write!-channel;
	clear!-string!-write() >>
    else if Stream eq T then
	Stream := LispVar OUT!*;
    UpLim := StrLen StrInf LispVar FormatForFormat!*;
    I := 0;
    while I <= UpLim do
    <<  Ch := StrByt(StrInf LispVar FormatForFormat!*, I);
	if Ch neq char !~ then 
	    ChannelWriteChar(Stream, Ch)
	else
	begin
	    I := I + 1;
	    Ch := StrByt(StrInf LispVar FormatForFormat!*, I);
	    UpCh := if Ch >= char lower A and Ch <= char lower Z
			then IPlus2(IDifference(Ch, char lower A), char A)
			else Ch;
	    case UpCh of
	    char A:
	    <<  ChannelPrin2(Stream, FormatArgs[0]);
		FormatArgs := &FormatArgs[StackDirection]  >>;
	    char S:
	    <<  ChannelPrin1(Stream, FormatArgs[0]);
		FormatArgs := &FormatArgs[StackDirection]  >>;
	    char D:
	    <<  ChannelWriteSysInteger(Stream,
				       Int2Sys FormatArgs[0],
				       10);
		FormatArgs := &FormatArgs[StackDirection]  >>;
	    char B:
	    <<  ChannelWriteSysInteger(Stream,
				       Int2Sys FormatArgs[0],
				       2);
		FormatArgs := &FormatArgs[StackDirection]  >>;
	    char O:
	    <<  ChannelWriteSysInteger(Stream,
				       Int2Sys FormatArgs[0],
				       8);
		FormatArgs := &FormatArgs[StackDirection]  >>;
	    char X:
	    <<  ChannelWriteSysInteger(Stream,
				       Int2Sys FormatArgs[0],
				       16);
		FormatArgs := &FormatArgs[StackDirection]  >>;
	    char !~:
		ChannelWriteChar(Stream, char !~);
	    char !%:
		ChannelWriteChar(Stream, char EOL);
	    char '!&:
	        format!-freshline Stream;
	    default:
		StdError BldMsg('"Unknown character code for Format: %r",
								  MkID Ch);
	    end;
	end;
    I := I + 1 >>;
    if Stream eq LispVar string!-write!-channel then return
	return!-string!-write();
end;

off SysLisp;

lisp procedure format!-freshline Stream;
(lambda out!*;
    if IGreaterP(Posn(), 0) then
	ChannelWriteChar(Stream, char EOL))(Stream);


lisp procedure Ferror(Condition, FMT, A1, A2, A3, A4, A5, A6,
					 A7, A8, A9, A10, A11, A12, A13);
    Error(Condition, Format(NIL, FMT, A1, A2, A3, A4, A5, A6,
					 A7, A8, A9, A10, A11, A12, A13));

lisp procedure string!-write!-char(stream, ch);
    if IGEQ(next!-string!-write!-char, 5000) then
	StdError "String overflow in FORMAT"
    else
    <<  next!-string!-write!-char := iadd1 next!-string!-write!-char;
	iputs(string!-write!-buffer, next!-string!-write!-char, ch) >>;

lisp procedure clear!-string!-write();
<<  channelwritechar(string!-write!-channel, char EOL);
    next!-string!-write!-char := -1 >>;

lisp procedure return!-string!-write();
begin scalar x, y;
    y := 0;
    next!-string!-write!-char := iadd1 next!-string!-write!-char;
    x := make!-string(next!-string!-write!-char, char NULL);
    while ILEQ(y, next!-string!-write!-char) do
    <<  iputs(x, y, igets(string!-write!-buffer, y));
	y := iadd1 y >>;
    return x;
end;

string!-write!-buffer := make!-string(5000, char NULL);
specialreadfunction!* := 'WriteOnlyChannel;
specialwritefunction!* := 'string!-write!-char;
specialclosefunction!* := 'IllegalStandardChannelClose;
string!-write!-channel := open("", 'special);
(lambda (x);
<<  LineLength 10000;
    WRS x >> )(WRS string!-write!-channel);

END;