Artifact 27d408313517870ee4c21aaa4b9093454be568eae243661bfe3cacf624c2b9cf:

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

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

% ===============================================================
% General Purpose I/O package for CREF, adapted to PSL
% MLG, 6:19am  Tuesday, 15 December 1981
% ===============================================================
%==============================================================================
% 11/18/82 - rrk - The function REMPROPSS was being called from RECREF in the
%  redefintion of a procedure with a single procedure name as the first 
%  argument.  This somehow caused the routine to go into an infinite loop.  A
%  quick to turn the ID into a list within REMPROPSS solves the problem.  The
%  reason that the call to REMPROPSS was not changed, is because it is not
%  clear if in some cases the argument will be a list.
%==============================================================================


GLOBAL '(!*FORMFEED   ORIG!* LNNUM!* MAXLN!* TITLE!* PGNUM!*  );

% FLAGS: FORMFEED (ON)  controls ^L or spacer of ====;

SYMBOLIC PROCEDURE INITIO();
% Set-up common defaults;
   BEGIN
	!*FORMFEED:=T;
	ORIG!*:=0;
	LNNUM!*:=0;
	LINELENGTH(75);
	MAXLN!*:=55;
	TITLE!*:=NIL;
	PGNUM!*:=1;
   END;

SYMBOLIC PROCEDURE LPOSN();
   LNNUM!*;

INITIO();

SYMBOLIC PROCEDURE SETPGLN(P,L);
  BEGIN IF P THEN MAXLN!*:=P;
	IF L THEN LINELENGTH(L);
  END;

% We use EXPLODE to produce a list of chars from atomname,
% and TERPRI() to terminate a buffer..all else
% done in package..spaces,tabs,etc. ;

COMMENT Character lists are (length . chars), for FITS;

SYMBOLIC  PROCEDURE GETES U;
% Returns for U , E=(Length . List of char);
   BEGIN SCALAR E;
	IF NOT IDP U THEN RETURN<<E:=EXPLODE U;LENGTH(E).E>>;
   	IF NOT(E:=GET(U,'RCCNAM)) THEN <<E:=EXPLODE(U);
				   E:=LENGTH(E) . E;
				   PUT(U,'RCCNAM,E)>>;
	RETURN E;
   END;

SYMBOLIC SMACRO PROCEDURE PRTWRD U;
   IF NUMBERP U THEN PRTNUM U
    ELSE PRTATM U;

SYMBOLIC PROCEDURE PRTATM U;
	PRIN2 U;	% For a nice print;

SYMBOLIC PROCEDURE PRTLST U;
 IF ATOM U THEN PRIN2 U ELSE FOR EACH X IN U DO PRIN2 X;

SYMBOLIC PROCEDURE PRTNUM N;
	PRIN2 N;

SYMBOLIC PROCEDURE PRINCN E;
% output a list of chars, update POSN();
	 WHILE (E:=CDR E) DO PRINC CAR E;

CommentOutCode <<			% Defined in PSL
SYMBOLIC PROCEDURE SPACES N;
	FOR I:=1:N DO PRINC '!  ;

SYMBOLIC PROCEDURE SPACES2 N;
   BEGIN SCALAR X;
        X := N - POSN();
	IF X<1 THEN NEWLINE N
	 ELSE SPACES X;
   END;
>>;

SYMBOLIC PROCEDURE SETPAGE(TITLE,PAGE);
% Initialise current page and title;
   BEGIN
	TITLE!*:= TITLE ;
	PGNUM!*:=PAGE;
   END;

SYMBOLIC PROCEDURE NEWLINE N;
% Begins a fresh line at posn N;
   BEGIN
	LNNUM!*:=LNNUM!*+1;
	IF LNNUM!*>=MAXLN!* THEN NEWPAGE()
	 ELSE TERPRI();
	SPACES(ORIG!*+N);
   END;

SYMBOLIC PROCEDURE NEWPAGE();
% Start a fresh page, with PGNUM and TITLE, if needed;
   BEGIN SCALAR A;
	A:=LPOSN();
	LNNUM!*:=0;
	IF POSN() NEQ 0 THEN NEWLINE 0;
	IF A NEQ 0 THEN FORMFEED();
	IF TITLE!* THEN
	  <<SPACES2 5; PRTLST TITLE!*>>;
	SPACES2 (LINELENGTH(NIL)-4);
	IF PGNUM!* THEN <<PRTNUM PGNUM!*; PGNUM!*:=PGNUM!*+1>>
	 ELSE PGNUM!*:=2;
	NEWLINE 10;
	NEWLINE 0;
   END;

SYMBOLIC PROCEDURE UNDERLINE2 N;
	IF N>=LINELENGTH(NIL) THEN
	  <<N:=LINELENGTH(NIL)-POSN();
	    FOR I:=0:N DO PRINC '!- ;
	    NEWLINE(0)>>
	 ELSE BEGIN SCALAR J;
		J:=N-POSN();
		FOR I:=0:J DO PRINC '!-;
	      END;

SYMBOLIC PROCEDURE LPRINT(U,N);
% prints a list of atoms within block LINELENGTH(NIL)-n;
   BEGIN SCALAR E, L,M;
	SPACES2 N;
	L := LINELENGTH NIL-POSN();
	IF L<=0 THEN ERROR(13,"WINDOW TOO SMALL FOR LPRINT");
	WHILE U DO
	   <<E:=GETES CAR U; U:=CDR U;
 	     IF LINELENGTH NIL<POSN() THEN NEWLINE N;
	     IF CAR E<(M := LINELENGTH NIL-POSN()) THEN PRINCN E
	      ELSE IF CAR E<L THEN <<NEWLINE N; PRINCN E>>
	      ELSE BEGIN
		 E := CDR E;
	      A: FOR I := 1:M DO <<PRINC CAR E; E := CDR E>>;
		 NEWLINE N;
		 IF NULL E THEN NIL
		  ELSE IF LENGTH E<(M := L) THEN PRINCN(NIL . E)
		  ELSE GO TO A
		END;
	     PRINC '! >>
   END;


% 11/18/82 rrk - Infinite loop caused by calls to this function with an
%  id as the ATMLST instead of a list.  A quick patch to turn the single
%  id into a list is provided, eliminating the infinite loop.
SYMBOLIC PROCEDURE REMPROPSS(ATMLST,LST);
<< IF NOT PAIRP ATMLST THEN
    ATMLST := LIST (ATMLST);
   WHILE ATMLST DO
   <<WHILE LST DO <<REMPROP(CAR ATMLST,CAR LST); LST:=CDR LST>>;
     ATMLST:=CDR ATMLST>> >>;

SYMBOLIC PROCEDURE REMFLAGSS(ATMLST,LST);
	WHILE LST DO <<REMFLAG(ATMLST,CAR LST); LST:=CDR LST>>;

CommentOutCode <<	% These are defined EXPRs in PSL
SMACRO PROCEDURE REMFLAG1(U,V); REMFLAG(LIST U,V);

SMACRO PROCEDURE FLAG1(U,V); FLAG(LIST U,V);
>>;

SYMBOLIC PROCEDURE FORMFEED;
	IF !*FORMFEED THEN EJECT()
	 ELSE <<TERPRI();
		PRIN2 " ========================================= ";
		TERPRI()>>;