Artifact c974fb789354c286be38e9cf0bbef21cb704abd31944e63b5c621791c00ea00a:

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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		PASCAL BASED MINI-LISP
%
% File: 	PAS3.RED - Basic LISP 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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%. Tagged TCATCH and TTHROW In terms of CATCH and THROW

SYMBOLIC PROCEDURE TCATCH(TG,FORM);
 BEGIN SCALAR VAL;
     THROWING!* := NIL;
     VAL:=CATCH(FORM);
     IF NULL TG OR NULL THROWING!* THEN RETURN VAL;	% CatchALL
     IF THROWTAG!* EQ TG THEN RETURN VAL;
     THROW VAL;
 END;

SYMBOLIC PROCEDURE TTHROW(TG,VAL);
 <<THROWING!* := 'T;
   THROWTAG!* := TG;
   THROW VAL>>;

SYMBOLIC PROCEDURE GETD NAM;		%. Return (type.code) if func
  BEGIN SCALAR TY,V;
	IF NOT IDP NAM THEN RETURN NIL;
	TY:=GET(NAM,'TYPE);
	V:=FUNCELL NAM;
	IF NULL TY AND V THEN TY:='EXPR;
        IF V THEN RETURN (TY . V) ELSE RETURN NIL;
  END;

SYMBOLIC PROCEDURE PUTD(NAM,TY,BOD);	%. Make function entry
 IF FLAGP(NAM, 'LOSE) THEN
 <<  ERRPRT LIST(NAM,'not,'flagged,'LOSE); NAM >>
 ELSE BEGIN
	IF GETD(NAM) THEN MSGPRT LIST('Function,NAM,'redefined);
	IF (CODEP BOD OR EQCAR(BOD,'LAMBDA)
          AND TY MEMQ '(EXPR FEXPR NEXPR MACRO) )
 	 THEN <<IF TY EQ 'EXPR THEN TY:=NIL;
                PUT(NAM,'TYPE,TY);
	        SETFUNCELL(NAM,BOD)>>
          ELSE RETURN ERROR(99,LIST(NAM,'Cant,'be,'defined));
	RETURN NAM;
 END;

SYMBOLIC PROCEDURE REMD NAM;		%. Remove function defn
 BEGIN SCALAR PR;
	IF (PR:=GETD NAM) THEN <<SETFUNCELL(NAM,NIL);
				 REMPROP(NAM,'TYPE)>>;
	RETURN PR;
 END;


%. Convenient definitions

SYMBOLIC PROCEDURE PUTL(L,IND,VAL);
 IF NOT PAIRP L THEN NIL
  ELSE <<PUT(CAR L,IND,VAL);
         PUTL(CDR L,IND,VAL)>>;

SYMBOLIC FEXPR PROCEDURE DE L;
   PUTD(CAR L,'EXPR,'LAMBDA . CDR L);

SYMBOLIC FEXPR PROCEDURE DF L;
   PUTD(CAR L,'FEXPR,'LAMBDA . CDR L);

SYMBOLIC FEXPR PROCEDURE DN L;
   PUTD(CAR L,'NEXPR,'LAMBDA . CDR L);

SYMBOLIC FEXPR PROCEDURE DM L;
   PUTD(CAR L,'MACRO,'LAMBDA . CDR L);

%. d) Improved EVAL, with LAMBDA, FEXPR, etc

SYMBOLIC PROCEDURE EVAL(X);
 BEGIN SCALAR FN,A,TY;
 L:IF IDP(X) THEN RETURN VALUE(X)
    ELSE IF NOT PAIRP(X) OR (FN := CAR X) EQ 'LAMBDA THEN
	RETURN X;
    A := CDR X;                         % Arguments
    IF FN EQ 'QUOTE THEN		%Important special Fexprs
	RETURN CAR(A);
    IF FN EQ 'SETQ THEN RETURN SET(CAR A,EVAL CADR A);
    IF IDP FN AND (TY := GET(FN, 'TYPE)) THEN 
     <<IF TY EQ 'FEXPR THEN
           RETURN APPLY1(FN,A);   % No Spread, No EVAL
       IF TY EQ 'NEXPR THEN
        RETURN APPLY1(FN,EVLIS A); % No Spread, EVAL
       IF TY EQ 'MACRO               % Reval full form
          THEN  <<X := APPLY1(FN,X);  GOTO L >> >>;
       A := EVLIS A;
       IF FN EQ 'LIST THEN RETURN A;
       RETURN APPLY(FN,A);
END;

SYMBOLIC PROCEDURE APPLY1(FN,A);
 APPLY(FN, A . NIL);

SYMBOLIC PROCEDURE APPLY(FN,A);
 BEGIN SCALAR EFN;
    EFN := FUNCELL FN;
    IF CODEP EFN THEN RETURN XAPPLY(EFN,A); % Spread args and EXECUTE
    RETURN EVLAM(EFN,A);
END;

SYMBOLIC PROCEDURE EVLIS(L);
IF NOT PAIRP L THEN EVAL L
 ELSE EVAL(CAR L) . EVLIS(CDR L);

%. Some standard FEXPRS and MACROS

SYMBOLIC FEXPR PROCEDURE PROGN ARGS;	%. Evaluate a LIST
  P!.N ARGS;

SYMBOLIC PROCEDURE PROG2(A,B); B;

SYMBOLIC PROCEDURE P!.N ARGS;		%. EVALS elems of list and returns last
BEGIN SCALAR ANS;
   WHILE PAIRP ARGS DO <<ANS := EVAL CAR ARGS; ARGS:=CDR ARGS>>;
  RETURN ANS
END;

%.===== Section 3.7 =====	Program Feature functions

% All this stuff should be rewritten to use the same binding mechanism as
% compiled code, and obey the same constraints on placement of GO/RETURN
% as compiled code.

SYMBOLIC FEXPR PROCEDURE RETURN E;	%. Return From Current PROG
<< P!.P := NIL;
   TTHROW('!$PROG!$,P!.N E) >>;

SYMBOLIC FEXPR PROCEDURE GO E;		%. Go to label in Current PROG
BEGIN SCALAR L;
  E := CAR E;
  REPEAT <<
    WHILE NOT IDP E DO
      ERROR(1100,LIST(E,'Not,'Label));
    L := ATSOC(E,P!.G);
    IF ATOM L THEN
      ERROR(1101,LIST(E,'Not,'a,'label))>>
  UNTIL PAIRP L;
  P!.P := CDR L;
  TTHROW('!$PROG!$,NIL)
END;

SYMBOLIC FEXPR PROCEDURE PROG E;	%. Program feature interpreter
%  P!.P is Next SEXPR to EVAL
BEGIN SCALAR TG,X,V,NVALS,SAVEP,SAVEG;
  SAVEP:=P!.P;
  SAVEG:=P!.G;	% Note FLUIDS not yet working compiled
  NVALS :=LENGTH CAR E;
  PBINDN CAR E;	% Bind each to NIL, putting old value on BSTACK
  P!.P := CDR E; 
% The code body
  X := P!.P;
  P!.G := NIL;
  FOR EACH U ON P!.P DO
    IF IDP CAR U THEN
  P!.G := U . P!.G;
  THROWING!* := NIL;
  TG := '!$PROG!$;
  WHILE P!.P AND TG EQ '!$PROG!$ DO <<
    X := CAR P!.P;
    P!.P := CDR P!.P;
    IF NOT IDP X THEN <<
      X := TCATCH(NIL,X);
      IF THROWING!* THEN
	<<TG := THROWTAG!*; V:=X>>  >> >>;
% UNBIND Even if thrown through
  UNBINDN NVALS;
  P!.P := SAVEP;
  P!.G := SAVEG;
  IF NOT(TG EQ '!$PROG!$) THEN
    TTHROW(TG,V)
  ELSE
    RETURN V
END;


SYMBOLIC FEXPR PROCEDURE WHILE ARGS;	%. Simple WHILE LOOP
% Will do (WHILE bool s1 .. sn)
  BEGIN SCALAR BOOL;
	IF NOT PAIRP ARGS THEN RETURN NIL;
	BOOL:=CAR ARGS;
 L1:	IF NULL EVAL BOOL THEN RETURN NIL;
	P!.N CDR ARGS;
	GOTO L1
 END;


SYMBOLIC FEXPR PROCEDURE AND(X);	%. Xis list of actions
   BEGIN 
     IF NOT PAIRP X THEN RETURN(T);
 L:  IF NULL CDR(X) THEN RETURN(EVAL(CAR X))
      ELSE IF NULL EVAL(CAR X) THEN RETURN(NIL)
      ELSE << X:=CDR X; GOTO L >>
 END;

%/// Add also IF ?

SYMBOLIC FEXPR PROCEDURE COND(E);		%. Conditional eval
   BEGIN SCALAR PR,Y;
 L:  IF NOT PAIRP E THEN RETURN NIL;
     PR:=CAR E; E:=CDR E;
     IF PAIRP PR THEN Y:=CAR PR ELSE Y:=PR;
     IF NULL (Y:=EVAL(Y)) THEN GOTO L;
     IF NULL PAIRP PR OR NULL CDR PR THEN RETURN(Y);
     RETURN P!.N(CDR PR)
   END;

SYMBOLIC FEXPR PROCEDURE  OR(X);	%. Or of action list
   BEGIN SCALAR Y;
 L: IF NOT PAIRP X THEN RETURN(NIL)
     ELSE IF(Y:=EVAL(CAR X)) THEN RETURN(Y)
     ELSE << X:=CDR X;GOTO L >>
 END;

%.===== Section 3.12 =====	MAP composite functions

SYMBOLIC PROCEDURE MAP(X,FN); 		%. Apply FN to each cdr x
   WHILE X DO <<APPLY1(FN,X); X := CDR X>>;

SYMBOLIC PROCEDURE MAPC(X,FN); 		%. Apply FN to each car x
   WHILE X DO <<APPLY1(FN,CAR X); X := CDR X>>;

SYMBOLIC PROCEDURE MAPCAN(X,FN); 	%. Append FN car x
   IF ATOM X THEN NIL ELSE NCONC(APPLY1(FN,CAR X),MAPCAN(CDR X,FN));

SYMBOLIC PROCEDURE MAPCAR(X,FN); 	%. Collect FN car x
   IF ATOM X THEN NIL ELSE APPLY1(FN,CAR X) . MAPCAR(CDR X,FN);

SYMBOLIC PROCEDURE MAPCON(X,FN); 	%. Append FN cdr x
   IF ATOM X THEN NIL ELSE NCONC(APPLY1(FN,X),MAPCON(CDR X,FN));

SYMBOLIC PROCEDURE MAPLIST(X,FN); 	%. Collect FN cdr x
   IF ATOM X THEN NIL ELSE APPLY1(FN,X) . MAPLIST(CDR X,FN);

SYMBOLIC PROCEDURE NCONC(U,V); 		%. Tack V onto end U
   BEGIN SCALAR W; 
      IF ATOM U THEN RETURN V; 
      W := U; 
      WHILE PAIRP CDR W DO W := CDR W; 
      RPLACD(W,V); 
      RETURN U
   END;

%... This procedure drives a simple read/eval/print top loop.

SYMBOLIC PROCEDURE PUTC(X,Y,Z);
  PUT(X,Y,Z);

SYMBOLIC PROCEDURE FLUID L;
  L;

SYMBOLIC PROCEDURE PRIN2TL L;
 IF NOT PAIRP L THEN TERPRI()
  ELSE <<PRIN2 CAR L; PRIN2 '! ; PRIN2TL CDR L>>;
% ... Missing functions to complete Standard LISP set
% ... some dummies developed for PERQ, modified to better use PASLSP


SYMBOLIC PROCEDURE FLOATP X; NIL;

SYMBOLIC PROCEDURE STRINGP X; IDP X;

SYMBOLIC PROCEDURE VECTORP X; NIL;

SYMBOLIC PROCEDURE FLUIDP X; NIL;

SYMBOLIC PROCEDURE INTERN X; X;

SYMBOLIC PROCEDURE REMOB X; NIL;

SYMBOLIC PROCEDURE GLOBAL X; 
   WHILE X DO <<FLAG(X,'GLOBAL); X := CDR X>>;

SYMBOLIC PROCEDURE GLOBALP X; 
   FLAGP(X,'GLOBAL);

SYMBOLIC PROCEDURE UNFLUID X; 
   NIL;


% No vectors yet

SYMBOLIC PROCEDURE GETV(A,B); NIL;

SYMBOLIC PROCEDURE MKVECT X; NIL;

SYMBOLIC PROCEDURE PUTV(A,B,C); NIL;

SYMBOLIC PROCEDURE UPBV X; NIL;

SYMBOLIC PROCEDURE DIGIT X; NIL;

SYMBOLIC PROCEDURE LITER X; NIL;
 
SYMBOLIC PROCEDURE READCH X; NIL;  %/ Needs Interp Mod
 
SYMBOLIC PROCEDURE RDEVPR;
 WHILE T DO PRINT EVAL READ();

SYMBOLIC PROCEDURE DSKIN(FILE);
 BEGIN SCALAR TMP;
   TMP := RDS OPEN(FILE, 'INPUT);
   WHILE NULL EOFP PRINT EVAL READ() DO NIL; %Use RDEVPR ?
   CLOSE RDS TMP;
 END;

SYMBOLIC PROCEDURE !*FIRST!-PROCEDURE;
BEGIN SCALAR X, EOFFLG, OUT;
    PRIN2TL '(Pascal  LISP  V2 !- 15 Feb 1982);
    PRIN2TL '(Copyright (c) 1981 U UTAH);
    PRIN2TL '(All  Rights  Reserved);
    NEXPRS:='(LIST);
    PUTL(NEXPRS,'TYPE,'NEXPR);
    PROCS:='(EXPR FEXPR NEXPR MACRO);
    EOFFLG := NIL;
    % Continue reading Init-File on channel 1;
    WHILE NOT EOFFLG DO
    <<  X := READ();
        EOFFLG := EOFP(X);
	IF NOT EOFFLG THEN
	    EVAL X
    >>;
    RDS(2); % Switch to USER input, THE TTY
    EOFFLG := NIL;
    WHILE NOT EOFFLG DO
      <<OUT := WRS 3; PRIN2 '!>; WRS OUT; % Prompt, OUT holds channel #
        X := READ();
        IF EQCAR(X,'QUIT) THEN EOFFLG := 'T ELSE EOFFLG := EOFP(X);
	IF NOT EOFFLG THEN
	  PRIN2T(CATCH X)
      >>;
    PRIN2T LIST('EXITING,'Top,'Loop);
END;

END;