Artifact 6adb70eef6e6ce7d382be117506f1c70e8c87558a416a02571fb8df36471be8e:

• File perq-pascal-lisp-project/pas1.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: 3898) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		PASCAL BASED MINI-LISP
%
% File: 	PAS1.RED - Basic I/O Functions
% ChangeDate: 	10:48pm  Wednesday, 15 July 1981
% By: 		M. L. Griss
%       	Change to add Features for Schlumberger Demo
% 
% 	    All RIGHTS RESERVED
%           COPYRIGHT (C) - 1981 - M. L. GRISS
%           Computer Science Department
%           University of Utah
%
%           Do Not distribute with out written consent of M. L. Griss
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Additional Support procedures for optimized code;

SYMBOLIC PROCEDURE CAAR(X);
 CAR CAR X;

SYMBOLIC PROCEDURE CADR X;
 CAR CDR X;

SYMBOLIC PROCEDURE CDAR X;
 CDR CAR X;

SYMBOLIC PROCEDURE CDDR X;
 CDR CDR X;

% All Friendly CxxxR's

SYMBOLIC PROCEDURE CAAAAR X; CAR CAR CAR CAR X;

SYMBOLIC PROCEDURE CAAADR X; CAR CAR CAR CDR X;

SYMBOLIC PROCEDURE CAADAR X; CAR CAR CDR CAR X;

SYMBOLIC PROCEDURE CAADDR X; CAR CAR CDR CDR X;

SYMBOLIC PROCEDURE CADAAR X; CAR CDR CAR CAR X;

SYMBOLIC PROCEDURE CADADR X; CAR CDR CAR CDR X;

SYMBOLIC PROCEDURE CADDAR X; CAR CDR CDR CAR X;

SYMBOLIC PROCEDURE CADDDR X; CAR CDR CDR CDR X;

SYMBOLIC PROCEDURE CDAAAR X; CDR CAR CAR CAR X;

SYMBOLIC PROCEDURE CDAADR X; CDR CAR CAR CDR X;

SYMBOLIC PROCEDURE CDADAR X; CDR CAR CDR CAR X;

SYMBOLIC PROCEDURE CDADDR X; CDR CAR CDR CDR X;

SYMBOLIC PROCEDURE CDDAAR X; CDR CDR CAR CAR X;

SYMBOLIC PROCEDURE CDDADR X; CDR CDR CAR CDR X;

SYMBOLIC PROCEDURE CDDDAR X; CDR CDR CDR CAR X;

SYMBOLIC PROCEDURE CDDDDR X; CDR CDR CDR CDR X;

SYMBOLIC PROCEDURE CAAAR X; CAR CAR CAR X;

SYMBOLIC PROCEDURE CAADR X; CAR CAR CDR X;

SYMBOLIC PROCEDURE CADAR X; CAR CDR CAR X;

SYMBOLIC PROCEDURE CADDR X; CAR CDR CDR X;

SYMBOLIC PROCEDURE CDAAR X; CDR CAR CAR X;

SYMBOLIC PROCEDURE CDADR X; CDR CAR CDR X;

SYMBOLIC PROCEDURE CDDAR X; CDR CDR CAR X;

SYMBOLIC PROCEDURE CDDDR X; CDR CDR CDR X;

symbolic procedure prin2(x);
    begin
        if pairp(x) then
        <<  wrtok( '!( );
            while pairp(x) do
            <<  prin2 car(x);
                x := cdr x;
		if not eq(x,NIL) then wrtok('! ); % A space.
            >>;
            if not eq(x,NIL) then
            <<  wrtok( '!.!  ); %Period followed by space.
                prin2(x);
            >>;
            wrtok( '!) );
        >>
        else
            wrtok(x);
    end;

symbolic procedure revx(l1,l2);
   % Non-destructive reverser, adds reverse of l1 to front of l2.
    begin
        while pairp(l1) do
        <<  l2 := (car l1).l2;
            l1 := cdr l1;
        >>;
        if not null (l1) then l2 := l1 . l2;
        return l2;
    end;

symbolic procedure rev(l1);
     revx(l1,NIL);

% EOF code is Ascii Z plus an offset of 1,  much too obscure!.
symbolic procedure eofp(x);
     if atom(x) and (!*inf(x) eq 27) then 'T else 'NIL;

symbolic procedure read();
    begin scalar itm,ii;
        itm := rdtok(); 
	if not(toktype eq 3) or eofp(itm)  then return(itm); % Over cautious;
        if (itm eq '!( ) 
            then return rlist()
        else if (itm eq '!' )         % Treat quote mark as QUOTE.
	    then return <<ii := read();
			  if eofp(ii) then ii
			   else ('QUOTE . ii . NIL)>>
        else return itm;
    end;

symbolic procedure rlist();
% Non destructive READ of S-expr, including ".".
    begin scalar itm,lst,done,last;
        itm := read();
        if eofp(itm) then return itm;
	done := NIL;
        while not done do
	    if itm eq '!) and toktype eq 3 
                  then done :='T
              else if itm = '!. and toktype eq 3 
	          then <<done:='T; last:= car rlist()>>  %CAR cures bug? WFG
              else
	          <<lst := itm.lst; itm := read()>>;
% ???   if pairp last then last:=car last>>;
     	if eofp(itm) then return itm;
        return revx(lst,last);
    end;

END$