Artifact 6da04ab67dbe6c1e4ccbd0c7a70fb859f0dedd93ca7ee9d9b1e7ad89491db3b0:

• File r30/redio.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: 7443) [annotate] [blame] [check-ins using] [more...]

COMMENT General Purpose I/O package ... sorting and positioning;

SYMBOLIC;

!*RAISE := NIL;

GLOBAL '(!*FORMFEED   ORIG!*  RCCNUMS!* BTIME!* 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 RCCBLD();
% Initialises RCC as number 0 to RCCNUMS!*-1 on Plist of all 
% characters;
  BEGIN SCALAR L,N,V;
	N:=0; % digits are now ids;
	L:='(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9
             A B C D E F G H I J K L M N O P Q
	     R S T U V W X Y Z
	     a b c d e f g h i j k l m n o p q
	     r s t u v w x y z
	!{ !! !" !# !; !% !& !' !( !) !_
	!= !} !\ !^ !@ !+ !* !< !> !? ![ 
	!- !] !| !~ !` !; !: !, !. !/ !$
	!  

	  );
    RCCNUMS!*:=1 . NIL;
    FOR I:=1:7 DO RCCNUMS!*:=(CAR(RCCNUMS!*) * 128 ) . RCCNUMS!*;
	WHILE L DO <<V:=CAR L;L:=CDR L;
	 	IF V  THEN PUT(V,'RCC,N);
		N:=N+1>>;
	END;

RCCBLD();

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 PRIN2N E;
% output a list of chars, update POSN();
	 WHILE (E:=CDR E) DO PRIN2 CAR E;

SYMBOLIC PROCEDURE SPACES N;
	FOR I:=1:N DO PRIN2 '!  ;

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 PRIN2 '!- ;
	    NEWLINE(0)>>
	 ELSE BEGIN SCALAR J;
		J:=N-POSN();
		FOR I:=0:J DO PRIN2 '!-;
	      END;

SYMBOLIC PROCEDURE LPRINT(U,N);
% prints a list of atoms within block LINELENGTH(NIL)-n;
   BEGIN SCALAR E; INTEGER 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 PRIN2N E
	      ELSE IF CAR E<L THEN <<NEWLINE N; PRIN2N E>>
	      ELSE BEGIN
		 E := CDR E;
	      A: FOR I := 1:M DO <<PRIN2 CAR E; E := CDR E>>;
		 NEWLINE N;
		 IF NULL E THEN NIL
		  ELSE IF LENGTH E<(M := L) THEN PRIN2N(NIL . E)
		  ELSE GO TO A
		END;
	     PRIN2 '! >>
   END;

SYMBOLIC PROCEDURE REMPROPSS(ATMLST,LST);
 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>>;

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

% ======= Extended IO and ALPHA-SORT package, Needs BIGNUMS;


%Establish RCC (Reduce charactercode) for collating
% and then each atom to be printed will be
% lst of chars stored under 'RCCNAM
% with numeric  collating order under 'RCCORD ;

SYMBOLIC SMACRO PROCEDURE GETRCC CHAR;
	GET(CHAR,'RCC);

SYMBOLIC PROCEDURE GETORD U;
% Given an atom, it is RCCNAM, stored under 'RCCNAM
% and its RCCORD evaluated(essentially packed pname);
   BEGIN SCALAR E,N,NN;
	IF NOT IDP U THEN GOTO L1;
	IF (N:=GET(U,'RCCORD)) THEN RETURN (U .N);
  L1:	E:=GETES U;
	N:=0;
	NN:=RCCNUMS!*;
	WHILE (E:=CDR E) AND NN 
	   DO <<N:=GETRCC(CAR E)*CAR(NN)+N;
		NN:=CDR NN>>;
	IF IDP U THEN PUT(U,'RCCORD,N);
	RETURN (U . N);
  END;

%   ****  SORTING SECTION ******
%  routines modified from funtr for alphabetic sorting
% and i/o...merge of cref,alp RCC etc;
% TREE SORT OF LIST OF ATOMS;
%
% TREE IS  NIL or STRUCT(VAL:value,SONS:node-pair)
%		node-pair=STRUCT(LNODE:tree,RNODE:tree);

SYMBOLIC PROCEDURE NEWNODE(ELEM);
	LIST(ELEM,NIL);

SYMBOLIC SMACRO PROCEDURE VAL NODE;
% will have (ATOM . lst) as elem;
	CAAR NODE;

SYMBOLIC SMACRO PROCEDURE PREPVAL ELEM;
	GETORD ELEM;

SYMBOLIC SMACRO PROCEDURE LNODE NODE;
	CADR NODE;

SYMBOLIC SMACRO PROCEDURE RNODE NODE;
	CDDR NODE;

SYMBOLIC SMACRO PROCEDURE NEWLFT(NODE,ELEM);
	RPLACA(CDR NODE,NEWNODE ELEM);

SYMBOLIC SMACRO PROCEDURE NEWRGT(NODE,ELEM);
	RPLACD(CDR NODE,NEWNODE ELEM);

SYMBOLIC SMACRO PROCEDURE MSORT LST;
% Build tree then collapse;
 TREE2LST(TREESORT(LST),NIL);

SYMBOLIC PROCEDURE TREESORT LST;
% Uses insert of elemnt to tree;
   BEGIN SCALAR TREE;
	IF NULL LST THEN RETURN NIL;
	TREE:=NEWNODE PREPVAL(    CAR LST);
	WHILE (LST:=CDR LST) DO PUTTREE(PREPVAL(CAR LST),TREE);
	RETURN TREE;
   END;

SYMBOLIC SMACRO PROCEDURE TORGT( ELEM,NODE);
% RETURNS T if ELEM to go to right of VAL(NODE);
	CDR(ELEM)>CDAR(NODE);

SYMBOLIC PROCEDURE PUTTREE(ELEM,NODE);
  BEGIN
  DWN:	IF TORGT(ELEM,NODE)  THEN GOTO RGT;
	IF LNODE NODE THEN <<NODE:=LNODE NODE;GO TO DWN>>;
		NEWLFT(NODE,ELEM);
		RETURN;
  RGT:	IF RNODE NODE THEN <<NODE:=RNODE NODE;GO TO DWN>>;
		NEWRGT(NODE,ELEM);
		RETURN;
  END;

SYMBOLIC PROCEDURE TREE2LST(TREE,LST);
  BEGIN
	WHILE TREE DO 
	   <<LST:=VAL(TREE) .TREE2LST(RNODE TREE,LST);
	    TREE:=LNODE TREE>>;
 	RETURN LST;
   END;

SYMBOLIC PROCEDURE UNION(X,Y);
IF NULL X THEN Y
 ELSE UNION(CDR X,IF CAR X MEMBER Y THEN Y ELSE CAR X . Y);

!*RAISE := T;   %system standard?;

% Convert a file specification from lisp format to a string.
% This is essentially the inverse of MKFILE;
SYMBOLIC PROCEDURE FILEMK U;
 BEGIN SCALAR DEV,NAME,FLG,FLG2;
  IF NULL U THEN RETURN NIL
   ELSE IF ATOM U THEN NAME := EXPLODEC U
   ELSE FOR EACH X IN U DO
    IF X EQ 'DIR!: THEN FLG := T
     ELSE IF ATOM X THEN
      IF FLG THEN DEV := '!< . NCONC(EXPLODEC X,LIST '!>)
       ELSE IF X EQ 'DSK!: THEN DEV:=NIL
       ELSE IF !%DEVP X THEN DEV := EXPLODEC X
       ELSE NAME := EXPLODEC X
     ELSE IF ATOM CDR X THEN
      NAME := NCONC(EXPLODEC CAR X,'!. . EXPLODEC CDR X)
     ELSE <<FLG2 := T;
            DEV := '![ . NCONC(EXPLODEC CAR X,
                               '!, . NCONC(EXPLODEC CADR X,LIST '!]))>>;
  U := IF FLG2 THEN NCONC(NAME,DEV)
        ELSE NCONC(DEV,NAME);
  RETURN COMPRESS('!" . NCONC(U,'(!")))
 END;


END;