Artifact 9633c0402a011e2d9b8f84b9e08465dfcfdd3e6646ed054adde3f10ae3b6f818:

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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		PASCAL BASED MINI-LISP
%
% File: 	PAS2.RED - Basic LISP Functions
% ChangeDate: 	10:42pm  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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

SYMBOLIC PROCEDURE PAIRP X;
  IF PAIRP X THEN T ELSE NIL;

SMACRO PROCEDURE NOTNULL(X);	%For readability.
  X;

SYMBOLIC PROCEDURE NOT X; 
 X EQ NIL;

SYMBOLIC PROCEDURE CODEP X; 
  IF CODEP X THEN T ELSE NIL;

SYMBOLIC PROCEDURE CONSTANTP X; 
   NULL (PAIRP X OR IDP X);

SYMBOLIC PROCEDURE EQN(A,B); 
   A EQ B;

%.  List entries (+ CONS, NCONS, XCONS)

SYMBOLIC PROCEDURE LIST2(R1,R2);
 R1 . NCONS R2;

SYMBOLIC PROCEDURE LIST3(R1,R2,R3);
 R1 .  LIST2(R2,R3);

SYMBOLIC PROCEDURE LIST4(R1,R2,R3,R4);
 R1 .  LIST3(R2,R3,R4);

SYMBOLIC PROCEDURE LIST5(R1,R2,R3,R4,R5);
 R1 .  LIST4(R2,R3,R4,R5);

SYMBOLIC PROCEDURE REVERSE U;
 REV U;

SYMBOLIC PROCEDURE APPEND(U,V);
 BEGIN  U:=REVERSE U;
        WHILE PAIRP U DO <<V :=CAR U . V; U:=CDR U>>;
	RETURN V
 END;

%. procedures to support GET and PUT, FLAG, etc.


SYMBOLIC PROCEDURE MEMBER(A,B); 
   IF NULL B THEN A ELSE IF A EQ CAR B THEN B ELSE A MEMBER CDR B;

SYMBOLIC PROCEDURE PAIR(U,V); 
   IF U AND V THEN (CAR U . CAR V) . PAIR(CDR U,CDR V)
    ELSE IF U OR V THEN ERROR(0,'PAIR)
    ELSE NIL;

SYMBOLIC PROCEDURE SASSOC(U,V,FN); 
   IF NOT PAIRP V THEN APPLY(FN,'(NIL))
    ELSE IF U EQ CAAR V THEN CAR V
    ELSE SASSOC(U,CDR V,FN);

SYMBOLIC PROCEDURE SUBLIS(X,Y); 
   IF NOT PAIRP X THEN Y
    ELSE BEGIN SCALAR U; 
            U := ASSOC(Y,X); 
            RETURN IF U THEN CDR U
                    ELSE IF ATOM Y THEN Y
                    ELSE SUBLIS(X,CAR Y) . SUBLIS(X,CDR Y)
         END;

SYMBOLIC PROCEDURE SUBST(U,V,W); 
   IF NULL V THEN NIL
    ELSE IF V EQ W THEN U
    ELSE IF ATOM W THEN W
    ELSE SUBST(U,V,CAR W) . SUBST(U,V,CDR W);

SYMBOLIC PROCEDURE MEMQ(U,V);
 IF NOT PAIRP V THEN V
  ELSE IF U EQ CAR V THEN V ELSE MEMQ(U,CDR V);

SYMBOLIC PROCEDURE ATSOC(U,V);
 IF NOT PAIRP V THEN V
  ELSE IF (NOT PAIRP CAR V)
	 OR NOT(U EQ CAAR V) THEN ATSOC(U,CDR V)
  ELSE CAR V;

SYMBOLIC PROCEDURE ASSOC(U,V); 
   IF NOT PAIRP V THEN NIL
    ELSE IF ATOM CAR V THEN ERROR(100,LIST(V,'ASSOC))
    ELSE IF U EQ CAAR V THEN CAR V
    ELSE ASSOC(U,CDR V);

SYMBOLIC PROCEDURE DEFLIST(U,IND); 
   IF NOT PAIRP U THEN NIL
    ELSE (<<PUT(CAAR U,IND,CADAR U); CAAR U>>) . DEFLIST(CDR U,IND);

SYMBOLIC PROCEDURE DELETE(U,V); 
   IF NOT PAIRP V THEN NIL 
    ELSE IF U=CAR V THEN CDR V 
    ELSE CAR V . DELETE(U,CDR V);

SYMBOLIC PROCEDURE DELQ(U,V);
   IF NOT PAIRP V THEN V
    ELSE IF U EQ CAR V THEN CDR V
    ELSE CAR V . DELQ(U,CDR V); % Recopy

SYMBOLIC PROCEDURE DELATQ(U,V);
 IF NOT PAIRP V THEN V
  ELSE IF (NOT PAIRP CAR V)
	 OR NOT(U EQ CAAR V) THEN (CAR V . DELATQ(U,CDR V))
  ELSE CDR V;

SYMBOLIC PROCEDURE GET(U,V);
 IF NOT IDP U THEN NIL
 ELSE IF PAIRP (U:=ATSOC(V,PLIST U)) THEN CDR U ELSE NIL;

SYMBOLIC PROCEDURE PUT(U,V,WW);
 BEGIN SCALAR L;
	IF NOT IDP U THEN RETURN WW;
	L:=PLIST U;
	IF ATSOC(V,L) THEN L:=DELATQ(V,L);
	IF NOTNULL WW THEN L:=(V . WW) . L;
	SETPLIST(U,L);
	RETURN WW;
 END;

SYMBOLIC PROCEDURE REMPROP(U,V);
   PUT(U,V,NIL);


SYMBOLIC PROCEDURE LENGTH L;
 IF NOT PAIRP L THEN 0
  ELSE 1+LENGTH CDR L;

SYMBOLIC PROCEDURE ERRPRT L;
 <<PRIN2 '!*!*!*!*! ; PRINT L>>;

SYMBOLIC PROCEDURE MSGPRT L;
 <<PRIN2 '!*!*!*! ; PRINT L>>;

SYMBOLIC PROCEDURE FLAGP(NAM,FLG);
 IDP NAM AND FLG MEMQ PLIST NAM;

SYMBOLIC PROCEDURE FLAG(NAML,FLG);
 IF NOT PAIRP NAML THEN NIL
  ELSE <<FLAG1(CAR NAML,FLG); FLAG(CDR NAML,FLG)>>;

SYMBOLIC PROCEDURE FLAG1(NAM,FLG);
 IF NOT IDP NAM THEN NIL
  ELSE IF FLG MEMQ PLIST NAM THEN NIL
  ELSE SETPLIST(NAM, FLG . PLIST(NAM));

SYMBOLIC PROCEDURE REMFLAG(NAML,FLG);
 IF NOT PAIRP NAML THEN NIL
  ELSE <<REMFLAG1(CAR NAMl,FLG); REMFLAG(CDR NAML,FLG)>>;

SYMBOLIC PROCEDURE REMFLAG1(NAM,FLG);
 IF NOT IDP NAM THEN NIL
  ELSE IF NOT(FLG MEMQ PLIST NAM)THEN NIL
  ELSE SETPLIST(NAM,DELQ(FLG, PLIST(NAM)));

% Interpreter entries for some important OPEN-coded functions;

SYMBOLIC PROCEDURE EQ(U,V);
 IF U EQ V THEN T ELSE NIL; % Careful, only bool-test opencoded

SYMBOLIC PROCEDURE EQCAR(U,V);
 IF  PAIRP  U THEN IF(CAR U EQ V) THEN T ELSE NIL;

SYMBOLIC PROCEDURE NULL U;
 U EQ NIL;

SYMBOLIC PROCEDURE PLIST U;
 PLIST U;

SYMBOLIC PROCEDURE VALUE U;
 VALUE U;

SYMBOLIC PROCEDURE FUNCELL U;
 FUNCELL U;

SYMBOLIC PROCEDURE SETPLIST(U,V);
 SETPLIST(U,V);

SYMBOLIC PROCEDURE SETVALUE(U,V);
 SETVALUE(U,V);

SYMBOLIC PROCEDURE SETFUNCELL(U,V);
 SETFUNCELL(U,V);

%.  Support for ALGebra

SYMBOLIC PROCEDURE ORDERP(X,Y); %.  Compare ID orders
 !*INF(X) <= !*INF(Y);

SYMBOLIC PROCEDURE TOKEN;	%. Renaming
 BEGIN TOK!*:=RDTOK();
       IF CHARP TOK!* THEN TOK!*:=CHAR2ID TOK!*;
       RETURN TOK!*;
 END;

% Can get confused if user changes from non-hashed to hashed cons.

SYMBOLIC PROCEDURE EQUAL(X,Y);
 IF ATOM(X) THEN IF ATOM(Y) THEN X EQ Y ELSE NIL
 ELSE IF ATOM(Y) THEN NIL ELSE EQUAL(CAR X, CAR Y) AND EQUAL(CDR X, CDR Y);

%--------- CATCH/THROW and ERROR handler ---------------

SYMBOLIC PROCEDURE ERROR(X,Y);
 <<PRINT LIST('!*!*!*!*! ERROR! ,X,Y);
   EMSG!* := Y; ENUM!* := X;
   THROW X>>;

SYMBOLIC PROCEDURE ERRORSET(FORM,MSGP,TRACEP);
 BEGIN SCALAR VAL;
   THROWING!* :=NIL;
   VAL:=CATCH FORM;
   IF NOT THROWING!* THEN RETURN LIST VAL;
   THROWING!*:=NIL;
   IF MSGP THEN PRINT LIST('!*!*!*!*,ENUM!*,EMSG!*);
   RETURN VAL
 END;

% More ARITHMETIC
SYMBOLIC PROCEDURE FIXP X; NUMBERP X;

SYMBOLIC PROCEDURE ABS X;
 IF X < 0 THEN (-X) ELSE X;

SYMBOLIC PROCEDURE SUB1 X;
 PLUS2(X,MINUS 1);

SYMBOLIC PROCEDURE ZEROP X;
  X=0;

SYMBOLIC PROCEDURE ONEP X;
  X=1;

SYMBOLIC PROCEDURE IDP X;
 IF IDP X THEN T ELSE NIL;
SYMBOLIC PROCEDURE EXPT(A,B); 
   IF B EQ 0 THEN 1 
    ELSE IF B <0 THEN 0            % Error ?
    ELSE TIMES2(A,A**SUB1 B);

SYMBOLIC PROCEDURE FIX X; X;

SYMBOLIC PROCEDURE FLOAT X; X;
% Should BE MACROS, check problem?

SYMBOLIC MACRO PROCEDURE MAX X; EXPAND(CDR X,'MAX2);

SYMBOLIC MACRO PROCEDURE MIN X; EXPAND(CDR X,'MIN2);

SYMBOLIC MACRO PROCEDURE PLUS X; EXPAND(CDR X,'PLUS2);

SYMBOLIC MACRO PROCEDURE TIMES X;  EXPAND(CDR X,'TIMES2);

SYMBOLIC PROCEDURE MAX2(A,B); IF A>B THEN A ELSE B;

SYMBOLIC PROCEDURE MIN2(A,B); IF A<B THEN A ELSE B;

SYMBOLIC FEXPR PROCEDURE FUNCTION X; CAR X;

SYMBOLIC PROCEDURE EXPAND(L,FN); 
   IF NULL CDR L THEN CAR L ELSE LIST(FN,CAR L,EXPAND(CDR L,FN));

SYMBOLIC PROCEDURE NUMBERP X;
 IF NUMBERP X THEN T ELSE NIL;

SYMBOLIC PROCEDURE ATOM X;
 IF ATOM X THEN T ELSE NIL;

SYMBOLIC PROCEDURE MINUSP X;
 IF NUMBERP X AND X <=(-1) THEN T ELSE NIL;

SYMBOLIC PROCEDURE SET(A,B);
 IF (NOT IDP(A)) OR (A EQ 'T) OR (A EQ 'NIL) THEN
  ('SET .  A . B . NIL) % Error value
  ELSE <<SETVALUE(A,B); B>>;

SYMBOLIC PROCEDURE PRINC X; 
   PRIN2 X;

SYMBOLIC PROCEDURE PRIN1 X;
   PRIN2 X;

SYMBOLIC PROCEDURE PRINT X;
 <<PRIN1 X; TERPRI(); X>>;

SYMBOLIC PROCEDURE PRIN2T X;
  <<PRIN2 X; TERPRI(); X>>;

%. a) Simple Binding for LAMBDA eval
%     Later convert to bstack in PAS0, will need GC hooks

FLUID '(BSTK!*);	% The Binding stack, list of (id . oval)
			% For Special cell model
SYMBOLIC PROCEDURE LBIND1(IDNAME,NVAL); %. For LAMBDA
 <<BSTK!*:=(IDNAME . VALUE(IDNAME)) . BSTK!*;
   SETVALUE(IDNAME,NVAL)>>;

SYMBOLIC PROCEDURE PBIND1(IDNAME);	%. Prog Bind 1 id
 <<BSTK!*:=(IDNAME . VALUE(IDNAME)) . BSTK!*;
   SETVALUE(IDNAME,'NIL)>>;

SYMBOLIC PROCEDURE UNBIND1;		%. Unbind 1 item
  IF PAIRP BSTK!* THEN <<SETVALUE(CAAR BSTK!*,CDAR BSTK!*);
                         BSTK!*:=CDR BSTK!*>>
   ELSE ERROR(99,'BNDUNDERFLOW);

SYMBOLIC PROCEDURE UNBINDN N;		%. Unbind N items
  WHILE N>0 DO <<UNBIND1(); N:=N-1>>;

SYMBOLIC PROCEDURE UNBINDTO(RETVAL,OLDSTK); %. Unbind to CATCH-mark
  <<WHILE PAIRP BSTK!* AND NOT(BSTK!* EQ OLDSTK)
      DO UNBIND1();
    RETVAL>>;

% b) Simple LAMBDA evaluator

SYMBOLIC PROCEDURE EVLAM(LAM,ARGS);	%. Will PAD args NILs
  BEGIN SCALAR VARS,BOD;
	IF NOT (PAIRP LAM AND CAR LAM EQ 'LAMBDA) 
	  THEN RETURN ERROR(99,'Not! defined);
	LAM:=CDR LAM;
	VARS:=CAR LAM; 
	LBINDN(VARS,ARGS);	% Set up BSTK!*
	BOD:=P!.N CDR LAM;	% and do PROGN eval
	UNBINDN LENGTH VARS;	% restore BSTK!*
        RETURN BOD
   END;

SYMBOLIC PROCEDURE LBINDN(VARS,ARGS); %. Bind each element of VARS to ARGS
  IF NOT PAIRP VARS THEN NIL
   ELSE IF NOT PAIRP ARGS THEN PBINDN VARS % rest to NIL
   ELSE <<LBIND1(CAR VARS,CAR ARGS);
          LBINDN(CDR VARS,CDR ARGS)>>;


SYMBOLIC PROCEDURE PBINDN VARS; 	%. Bind each element of VARS to NIL
  IF NOT PAIRP VARS THEN NIL
   ELSE <<PBIND1 CAR VARS;
          PBINDN CDR VARS>>;


END$