File r30/redio.red artifact 6da04ab67d part of check-in 46c747b52c


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;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]