reduce-historical/perq-pascal-lisp-project/pas2.red

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		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$