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