Personal tools
You are here: Home Projects LISP Utah REDUCE 2 and Standard LISP for Burroughs B6700 INCLUDE/RLISP/LISP.sqd_m is the main portion of the Standard LISP interpreter/runtime, written in RLISP.
Document Actions

INCLUDE/RLISP/LISP.sqd_m is the main portion of the Standard LISP interpreter/runtime, written in RLISP.

by Paul McJones last modified 2022-10-17 10:30

INCLUDE/RLISP/LISP.sqd_m is the main portion of the Standard LISP interpreter/runtime, written in RLISP.

Click here to get the file

Size 57.5 kB - File type text/plain

File contents

SYMBOLIC;                                                               00000100
                                                                        00000200
GLOBAL '(!$SCNVAL !$EOF!$ !$EOL!$ !$LINE!.LENGTH !*COMP THROWBACK!*     00000300
                                                             %PPDMTL99; 00000301
          EMSG!* ERNUM!* !*PROGTRACE !*SETTRACE)$            %PPDMTL99; 00000400
                                                                        00000500
!*RAISE:=!*COMP:=NIL$                                                   00000600
                                                                        00000700
                                                                        00000800
                                                                        00000900
SYMBOLIC PROCEDURE STANDARD!-LISP()$                                    00001000
BEGIN SCALAR VALUE$                                                     00001100
    !$SCNVAL := '(Z Y X W V U T S R Q P O N M L K J I H G F E D C B A   00001200
                  z y x w v u t s r q p o n m l k j i h g f e d c b a)$ 00001300
    COMMENT THIS'S JUST TO GET THE LETTERS IN THE RIGHT.. ;  %PPDMTL99; 00001400
    COMMENT ..ORDER FOR ORDERP ;                             %PPDMTL99; 00001410
    ERRORSET('(BEGIN),T,T);                                             00001500
    VALUE:=PRIN2 "Standard LISP (4/1/79)";                              00001600
LOOP:                                                                   00001700
    IF NOT ATOM VALUE THEN PRINT CAR VALUE;                             00001800
    TERPRI();                                                           00001900
    PRIN2 "EVAL:"$ TERPRI();                                            00002000
    VALUE:=ERRORSET('(EVAL(READ)),T,T)$                                 00002100
    GO TO LOOP                                                          00002200
END$                                                                    00002300
                                                                        00002400
SYMBOLIC PROCEDURE READ()$                                              00002500
BEGIN SCALAR TYP$                                                       00002600
    TYP:=!$SCAN(NIL)$                                                   00002700
    RETURN                                                              00002800
      IF EQ(TYP,0) THEN INTERN !$SCNVAL                                 00002900
      ELSE IF EQ(TYP,1) THEN !$SCNVAL                                   00003000
      ELSE IF EQ(TYP,2) THEN !$SCNVAL                                   00003100
      ELSE IF EQ(TYP,3) THEN                                            00003200
        IF EQ(!$SCNVAL,"(") THEN                                        00003300
          BEGIN SCALAR HPTR,TPTR,VR$                                    00003400
LOOP:       VR:=READ()$                                                 00003500
            IF EQ(VR,")") THEN RETURN HPTR                              00003600
            ELSE IF EQ(VR,".") THEN <<                                  00003700
                VR:=READ()$                                             00003800
                IF NULL TPTR THEN                                       00003900
                    ERROR(107," Misplaced . in dot-notation")$          00004000
                RPLACD(TPTR,VR)$                                        00004100
                VR:=READ()$                                             00004200
                IF NOT EQ(VR,")") THEN                                  00004300
                  ERROR(108," Missing right parenthesis")$              00004400
                RETURN HPTR >>$                                         00004500
            VR:=CONS(VR,NIL)$                                           00004600
            IF NULL HPTR THEN                                           00004700
                HPTR:=TPTR:=VR                                          00004800
            ELSE << RPLACD(TPTR,VR)$ TPTR:=VR >>$                       00004900
            GO TO LOOP                                                  00005000
        END                                                             00005100
    ELSE IF EQ(!$SCNVAL,")") THEN !$SCNVAL                              00005200
    ELSE IF EQ(!$SCNVAL,".") THEN !$SCNVAL                              00005300
    ELSE IF EQ(!$SCNVAL,"'") THEN LIST ('QUOTE,READ())                  00005400
    ELSE INTERN !$SCNVAL                                                00005500
  ELSE IF EQ(TYP,4) THEN !$EOF!$                                        00005600
  ELSE !$SCNVAL                                                         00005700
END$                                                                    00005800
                                                                        00005900
SYMBOLIC PROCEDURE PRIN12(U,ESC)$                                       00006000
  IF PAIRP U THEN BEGIN SCALAR PTR,FIRST$                               00006100
        PTR:=U$                                                         00006200
        !$PATOM2 "("$                                                   00006300
LOOP:   IF NULL PTR THEN << !$PATOM2 ")"$ RETURN PTR>>                  00006400
        ELSE IF NOT PAIRP PTR THEN << !$PATOM2 " . "$                   00006500
                   PRIN12(PTR,ESC)$ !$PATOM2 ")"$ RETURN U>>            00006600
        ELSE IF FIRST THEN !$PATOM2 " "                                 00006700
        ELSE FIRST:=T$                                                  00006800
        PRIN12(CAR PTR,ESC)$                                            00006900
        PTR:=CDR PTR$                                                   00007000
        GO TO LOOP                                                      00007100
      END                                                               00007200
  ELSE IF VECTORP U THEN BEGIN SCALAR I,M$                              00007300
        M:=UPBV U$                                                      00007400
        I:=0$                                                           00007500
        !$PATOM2 "["$                                                   00007600
LOOP:   PRIN12(GETV(U,I),ESC)$                                          00007700
        IF EQN(I,M) THEN << !$PATOM2 "]"$ RETURN U>>$                   00007800
        !$PATOM2 ", "$                                                  00007900
        I:=I+1$ GO TO LOOP                                              00008000
    END                                                                 00008100
  ELSE IF ESC THEN !$PATOM U ELSE !$PATOM2 U$                           00008200
                                                                        00008300
SYMBOLIC PROCEDURE PRIN1 U$ PRIN12(U,T)$                                00008400
SYMBOLIC PROCEDURE PRIN2 U$ PRIN12(U,NIL)$                              00008500
                                                                        00008600
SYMBOLIC PROCEDURE PRINT U$                                             00008700
<<PRIN12(U,T); TERPRI(); U>>$                                           00008800
                                                                        00008900
SYMBOLIC PROCEDURE LINELENGTH N$                                        00009000
  IF NOT N THEN !$LINE!.LENGTH                                          00009100
    ELSE IF NOT NUMBERP N THEN                                          00009200
                  !$T!.MSMTCH(N,"INTEGER",'LINELENGTH)                  00009300
      ELSE IF OR(GREATERP(N,180),LESSP(N,10)) THEN                      00009400
                  ERROR(111,LIST(N," is an invalid line length"))       00009500
      ELSE BEGIN SCALAR M$                                              00009600
        M:=!$LINE!.LENGTH$                                              00009700
        !$LINE!.LENGTH:=N$                                              00009800
        RETURN M                                                        00009900
      END$                                                              00010000
                                                                        00010100
SYMBOLIC PROCEDURE !$ERRPRNT F$                                         00010200
    IF ATOM F THEN IF NULL F THEN NIL ELSE !$PATOM2 F                   00010300
    ELSE <<PRIN2 CAR F; !$ERRPRNT(CDR F)>>;                             00010400
                                                                        00010500
                                                                        00010600
SYMBOLIC PROCEDURE CAAR X$ CAR CAR X$                                   00010700
SYMBOLIC PROCEDURE CADR X$ CAR CDR X$                                   00010800
SYMBOLIC PROCEDURE CDAR X$ CDR CAR X$                                   00010900
SYMBOLIC PROCEDURE CDDR X$ CDR CDR X$                                   00011000
                                                                        00011100
SYMBOLIC PROCEDURE CAAAR X$ CAR CAR CAR X$                              00011200
SYMBOLIC PROCEDURE CAADR X$ CAR CAR CDR X$                              00011300
SYMBOLIC PROCEDURE CADAR X$ CAR CDR CAR X$                              00011400
SYMBOLIC PROCEDURE CADDR X$ CAR CDR CDR X$                              00011500
SYMBOLIC PROCEDURE CDAAR X$ CDR CAR CAR X$                              00011600
SYMBOLIC PROCEDURE CDADR X$ CDR CAR CDR X$                              00011700
SYMBOLIC PROCEDURE CDDAR X$ CDR CDR CAR X$                              00011800
SYMBOLIC PROCEDURE CDDDR X$ CDR CDR CDR X$                              00011900
                                                                        00012000
SYMBOLIC PROCEDURE CAAAAR X$ CAR CAR CAR CAR X$                         00012100
SYMBOLIC PROCEDURE CAAADR X$ CAR CAR CAR CDR X$                         00012200
SYMBOLIC PROCEDURE CAADAR X$ CAR CAR CDR CAR X$                         00012300
SYMBOLIC PROCEDURE CAADDR X$ CAR CAR CDR CDR X$                         00012400
SYMBOLIC PROCEDURE CADAAR X$ CAR CDR CAR CAR X$                         00012500
SYMBOLIC PROCEDURE CADADR X$ CAR CDR CAR CDR X$                         00012600
SYMBOLIC PROCEDURE CADDAR X$ CAR CDR CDR CAR X$                         00012700
SYMBOLIC PROCEDURE CADDDR X$ CAR CDR CDR CDR X$                         00012800
SYMBOLIC PROCEDURE CDAAAR X$ CDR CAR CAR CAR X$                         00012900
SYMBOLIC PROCEDURE CDAADR X$ CDR CAR CAR CDR X$                         00013000
SYMBOLIC PROCEDURE CDADAR X$ CDR CAR CDR CAR X$                         00013100
SYMBOLIC PROCEDURE CDADDR X$ CDR CAR CDR CDR X$                         00013200
SYMBOLIC PROCEDURE CDDAAR X$ CDR CDR CAR CAR X$                         00013300
SYMBOLIC PROCEDURE CDDADR X$ CDR CDR CAR CDR X$                         00013400
SYMBOLIC PROCEDURE CDDDAR X$ CDR CDR CDR CAR X$                         00013500
SYMBOLIC PROCEDURE CDDDDR X$ CDR CDR CDR CDR X$                         00013600
                                                                        00013700
SYMBOLIC PROCEDURE NCONC(U,V)$                                          00013800
BEGIN SCALAR W$                                                         00013900
    IF NULL U THEN RETURN V$                                            00014000
    W:=U$                                                               00014100
LOOP:                                                                   00014200
    IF NULL CDR W THEN GO TO CONC$                                      00014300
    W:=CDR W$                                                           00014400
    GO TO LOOP$                                                         00014500
CONC:                                                                   00014600
    RPLACD(W,V)$                                                        00014700
    RETURN U                                                            00014800
END$                                                                    00014900
                                                                        00015000
SYMBOLIC PROCEDURE APPEND(U,V)$                                         00015100
  IF NULL U THEN V ELSE CONS(CAR U,APPEND(CDR U,V))$                    00015200
                                                                        00015300
SYMBOLIC PROCEDURE PAIR(U,V)$                                           00015400
  IF AND(U,V) THEN CONS(CONS(CAR U,CAR V),PAIR(CDR U,CDR V))            00015500
  ELSE IF OR(U,V) THEN ERROR(202,"Different length lists in PAIR")      00015600
  ELSE NIL$                                                             00015700
                                                                        00015800
SYMBOLIC PROCEDURE REVERSE U$                                           00015900
BEGIN SCALAR W$                                                         00016000
LOOP:                                                                   00016100
    IF NULL U THEN RETURN W$                                            00016200
    W:=CONS(CAR U,W)$                                                   00016300
    U:=CDR U$                                                           00016400
    GO TO LOOP                                                          00016500
END$                                                                    00016600
                                                                        00016700
SYMBOLIC PROCEDURE SASSOC(U,V,FN)$                                      00016800
  IF NULL V THEN FN()                                                   00016900
    ELSE IF EQUAL(U,CAR CAR V) THEN CAR V                               00017000
    ELSE SASSOC(U,CDR V,FN)$                                            00017100
                                                                        00017200
SYMBOLIC PROCEDURE SUBLIS(X,Y)$                                         00017300
  IF NULL X THEN Y                                                      00017400
    ELSE BEGIN SCALAR U$                                                00017500
    U:=ASSOC(Y,X)$                                                      00017600
    RETURN                                                              00017700
        IF U THEN CDR U                                                 00017800
        ELSE IF ATOM Y THEN Y                                           00017900
        ELSE CONS(SUBLIS(X,CAR Y),SUBLIS(X,CDR Y))$                     00018000
END$                                                                    00018100
                                                                        00018200
SYMBOLIC PROCEDURE SUBST(U,V,W)$                                        00018300
  IF NULL W THEN NIL                                                    00018400
    ELSE IF EQUAL(V,W) THEN U                                           00018500
      ELSE IF ATOM W THEN W                                             00018600
        ELSE CONS(SUBST(U,V,CAR W),SUBST(U,V,CDR W))$                   00018700
                                                                        00018800
SYMBOLIC PROCEDURE EXPAND(L,FN)$                                        00018900
  IF NULL CDR L THEN CAR L                                              00019000
        ELSE LIST(FN,CAR L,EXPAND(CDR L,FN))$                           00019100
                                                                        00019200
SYMBOLIC PROCEDURE DELETE(U,V)$                                         00019300
    IF NULL V THEN NIL                                                  00019400
    ELSE IF EQUAL(CAR V,U) THEN CDR V                                   00019500
    ELSE CONS(CAR V,DELETE(U,CDR V))$                                   00019600
                                                                        00019700
                                                                        00019800
SYMBOLIC PROCEDURE ASSOC(U,V);                                          00019900
BEGIN                                                                   00020000
  IF ATOM U AND NOT VECTORP U THEN                                      00020100
  <<WHILE V DO                                                          00020200
    <<IF ATOM CAR V THEN ERROR(200," is poorly formed A-LIST");         00020300
      IF U EQ CAR CAR V THEN RETURN V:=CAR V;                           00020400
      V:=CDR V                                                          00020500
  >> >> ELSE                                                            00020600
  <<WHILE V DO                                                          00020700
    <<IF ATOM CAR V THEN ERROR(200," is poorly formed A-LIST");         00020800
      IF U=CAR CAR V THEN RETURN V:=CAR V;                              00020900
      V:=CDR V                                                          00021000
  >> >>;                                                                00021100
  RETURN V;                                                             00021200
END;                                                                    00021300
                                                                        00021400
SYMBOLIC PROCEDURE ASSOC!*(U,V)$                                        00021500
  BEGIN                                                                 00021600
LOOP:                                                                   00021700
    IF NULL V THEN RETURN NIL$                                          00021800
    IF ATOM CAR V THEN GO TO SKIP$                                      00021900
    IF EQ(U,CAR CAR V) THEN RETURN CAR V$                               00022000
SKIP:                                                                   00022100
    V:=CDR V$ GO TO LOOP                                                00022200
END$                                                                    00022300
                                                                        00022400
                                                                        00022500
SYMBOLIC PROCEDURE FLAG(U,V)$                                           00022600
BEGIN SCALAR X$                                                         00022700
    IF NOT IDP V THEN !$T!.MSMTCH(V,'ID,'FLAG)$                         00022800
LOOP:                                                                   00022900
    IF ATOM U THEN RETURN NIL$                                          00023000
    IF NOT IDP CAR U THEN !$T!.MSMTCH(CAR U,'ID,'FLAG)$                 00023100
    X:=!$GET!.PROP(CAR U)$                                              00023200
    IF NOT MEMQ(V,X) THEN !$PUT!.PROP(CAR U,CONS(V,X))$                 00023300
    U:=CDR U$                                                           00023400
    GO TO LOOP                                                          00023500
END$                                                                    00023600
                                                                        00023700
SYMBOLIC PROCEDURE FLAGP(U, V);                                         00023800
IF NOT(IDP U AND IDP V) THEN NIL                                        00023900
ELSE IF MEMQ(V, !$GET!.PROP U) THEN T ELSE NIL$                         00024000
                                                                        00024100
                                                                        00024200
                                                                        00024300
SYMBOLIC PROCEDURE PUT(U,IND,PROP)$                                     00024400
 IF NOT IDP U THEN !$T!.MSMTCH(U,'ID,'PUT)                              00024500
 ELSE IF NOT IDP IND THEN !$T!.MSMTCH(IND,'ID,'PUT)                     00024600
 ELSE BEGIN SCALAR X$                                                   00024700
    X:=ASSOC!*(IND,!$GET!.PROP U)$                                      00024800
    IF X THEN RPLACD(X,PROP) ELSE !$PUT!.PROP(U,CONS(CONS(IND,PROP),    00024900
                                                     !$GET!.PROP U))    00025000
    RETURN PROP                                                         00025100
END$                                                                    00025200
                                                                        00025300
SYMBOLIC PROCEDURE DEFLIST(U,IND)$                                      00025400
    IF NULL U THEN NIL                                                  00025500
    ELSE CONS( << PUT(CAR CAR U,IND,CAR CDR CAR U)$ CAR CAR U>>,        00025600
               DEFLIST(CDR U,IND) )$                                    00025700
                                                                        00025800
SYMBOLIC PROCEDURE REMFLAG(U,V)$                                        00025900
  BEGIN                                                                 00026000
LOOP: IF ATOM U THEN RETURN NIL$                                        00026100
     !$PUT!.PROP(CAR U, DELETE(V, !$GET!.PROP CAR U))$                  00026200
      U:=CDR U$ GO TO LOOP                                              00026300
END$                                                                    00026400
                                                                        00026500
SYMBOLIC PROCEDURE REMPROP(U,V)$                                        00026600
  IF NOT IDP U THEN NIL                                                 00026700
    ELSE !$PUT!.PROP(U,!$DEL(V,!$GET!.PROP U))$                         00026800
                                                                        00026900
SYMBOLIC PROCEDURE !$DEL(U,V)$                                          00027000
  IF NULL V THEN NIL                                                    00027100
    ELSE IF ATOM CAR V THEN CONS(CAR V,!$DEL(U,CDR V))                  00027200
    ELSE IF EQ(CAAR V,U) THEN CDR V                                     00027300
    ELSE CONS(CAR V,!$DEL(U,CDR V))$                                    00027400
                                                                        00027500
SYMBOLIC FEXPR PROCEDURE DE X$                                          00027600
  PUTD (CAR X,'EXPR,LIST('LAMBDA,CAR CDR X,CAR CDR CDR X))$             00027700
                                                                        00027800
SYMBOLIC FEXPR PROCEDURE DF X$                                          00027900
  PUTD(CAR X,'FEXPR,LIST('LAMBDA,CAR CDR X,CAR CDR CDR X))$             00028000
                                                                        00028100
SYMBOLIC FEXPR PROCEDURE DM X$                                          00028200
  PUTD(CAR X,'MACRO,LIST('LAMBDA,CAR CDR X,CAR CDR CDR X))$             00028300
                                                                        00028400
SYMBOLIC PROCEDURE REMD FN$                                             00028500
BEGIN SCALAR X$                                                         00028600
  IF NOT IDP FN THEN !$T!.MSMTCH(FN, 'ID, 'REMD)$                       00028700
  X := !$GETG FN$                                                       00028800
  IF PAIRP X THEN                                                       00028900
    IF MEMQ(CAR X, '(EXPR SUBR FEXPR FSUBR MACRO)) THEN                 00029000
     << !$PUTG(FN, NIL)$                                                00029100
        RETURN X >>$                                                    00029200
  RETURN NIL                                                            00029300
END REMD$                                                               00029400
                                                                        00029500
                                                                        00029600
SYMBOLIC PROCEDURE PUTD(FNAME,TYPE,BODY)$                    %PPDMTL14; 00029700
  BEGIN                                                      %PPDMTL14; 00029800
   IF MEMQ(TYPE,'(EXPR SUBR FEXPR FSUBR MACRO )) THEN        %PPDMTL14; 00029900
      <<                                                     %PPDMTL14; 00029950
         IF GLOBALP FNAME THEN                               %PPDMTL14; 00030000
            ERROR(20,LIST(FNAME, " is a non-local variable"))$%PPDMTL14;00030100
         IF NOT(!$GETG FNAME EQ !*UNBOUND) THEN              %PPDMTL14; 00030200
            <<                                               %PPDMTL14; 00030220
               !$PATOM2 "*** "$                              %PPDMTL14; 00030240
               !$PATOM FNAME$                                %PPDMTL14; 00030300
               !$PATOM2 " redefined"$                        %PPDMTL14; 00030400
               TERPRI()                                      %PPDMTL14; 00030500
            >> $                                             %PPDMTL14; 00030550
         !$PUTD(FNAME,CONS(TYPE,BODY))$                      %PPDMTL14; 00030600
         IF !*COMP AND (TYPE='EXPR OR TYPE='FEXPR) THEN      %PPDMTL14; 00030700
            COMPILE LIST FNAME$                              %PPDMTL14; 00030800
         RETURN FNAME                                        %PPDMTL14; 00030820
      >>                                                     %PPDMTL14; 00030840
   ELSE IF MEMQ(TYPE,'(EMB PROCEDURE SMACRO NMACRO))         %PPDMTL14; 00030920
        THEN << PUT(FNAME,TYPE,BODY)                         %PPDMTL14; 00030921
                RETURN FNAME                                 %PPDMTL14; 00030923
             >>                                              %PPDMTL14; 00030925
        ELSE << ERROR (129, LIST(TYPE,                       %PPDMTL14; 00030930
                       " is not a defined function type")) $ %PPDMTL14; 00030935
                RETURN NIL                                   %PPDMTL14; 00030940
             >>                                              %PPDMTL14; 00031000
END$                                                         %PPDMTL14; 00031100
                                                                        00031200
SYMBOLIC FEXPR PROCEDURE !%!%AND X$                                     00031300
  BEGIN                                                                 00031400
    IF NULL X THEN RETURN NIL$                                          00031500
LOOP:                                                                   00031600
    IF NULL CDR X THEN RETURN EVAL CAR X                                00031700
    ELSE IF NULL EVAL CAR X THEN RETURN NIL$                            00031800
    X:=CDR X$                                                           00031900
    GO TO LOOP                                                          00032000
END$                                                                    00032100
                                                                        00032200
SYMBOLIC FEXPR PROCEDURE !%!%OR D$                                      00032300
  BEGIN SCALAR X$                                                       00032400
LOOP:                                                                   00032500
    IF NULL D THEN RETURN X                                             00032600
    ELSE IF X:=EVAL CAR D THEN RETURN X$                                00032700
    D:=CDR D$                                                           00032800
    GO TO LOOP                                                          00032900
END$                                                                    00033000
                                                                        00033100
                                                                        00033200
SYMBOLIC FEXPR PROCEDURE !%!%PLUS U;                                    00033300
  BEGIN SCALAR V;                                                       00033400
    V := 0;                                                             00033500
    WHILE PAIRP U DO                                                    00033600
      <<V := (EVAL CAR U) + V; U := CDR U>>;                            00033700
    RETURN V;                                                           00033800
  END;                                                                  00033900
                                                                        00034000
SYMBOLIC FEXPR PROCEDURE !%!%TIMES U;                                   00034100
  BEGIN SCALAR V;                                                       00034200
    V := 1;                                                             00034300
    WHILE PAIRP U DO                                                    00034400
      <<V := (EVAL CAR U) * V; U := CDR U>>;                            00034500
    RETURN V;                                                           00034600
  END;                                                                  00034700
                                                                        00034800
SYMBOLIC PROCEDURE MINUSP U$                                 %PPDMTL13; 00034900
    IF NUMBERP U THEN                                        %PPDMTL13; 00034910
       LESSP (U, 0)                                          %PPDMTL13; 00034920
    ELSE NIL$                                                %PPDMTL13; 00034930
                                                                        00035000
SYMBOLIC PROCEDURE ONEP U; U=1;                                         00035100
                                                                        00035200
SYMBOLIC PROCEDURE ZEROP U; U=0;                                        00035300
                                                                        00035400
SYMBOLIC PROCEDURE FLOATP U; NIL;                                       00035500
                                                                        00035600
SYMBOLIC PROCEDURE ADD1 U; U+1;                                         00035700
                                                                        00035800
SYMBOLIC PROCEDURE SUB1 U; U-1;                                         00035900
                                                                        00036000
SYMBOLIC PROCEDURE ABS U$                                               00036100
    IF LESSP(U,0) THEN MINUS(U) ELSE U$                                 00036200
                                                                        00036300
SYMBOLIC PROCEDURE DIVIDE(U,V)$                                         00036400
    CONS(QUOTIENT(U,V),REMAINDER(U,V))$                                 00036500
                                                                        00036600
SYMBOLIC PROCEDURE MAX2(U,V)$                                           00036700
    IF LESSP(U,V) THEN V ELSE U$                                        00036800
                                                                        00036900
SYMBOLIC PROCEDURE MIN2(U,V)$                                           00037000
    IF GREATERP(U,V) THEN V ELSE U$                                     00037100
                                                                        00037200
SYMBOLIC FEXPR PROCEDURE MAX U;                                         00037300
  BEGIN SCALAR V;                                                       00037400
    V := EVAL CAR U; U := CDR U;                                        00037500
    WHILE PAIRP U DO <<V := MAX2(EVAL CAR U, V); U := CDR U>>;          00037600
    RETURN V;                                                           00037700
  END;                                                                  00037800
                                                                        00037900
SYMBOLIC FEXPR PROCEDURE MIN U;                                         00038000
  BEGIN SCALAR V;                                                       00038100
    V := EVAL CAR U; U := CDR U;                                        00038200
    WHILE PAIRP U DO <<V := MIN2(EVAL CAR U, V); U := CDR U>>;          00038300
    RETURN V;                                                           00038400
  END;                                                                  00038500
                                                                        00038600
SYMBOLIC PROCEDURE MINUS U$ DIFFERENCE(0,U)$                            00038700
                                                                        00038800
SYMBOLIC PROCEDURE LIST2(A, B)$                                         00038900
  CONS(A, CONS(B, NIL))$                                                00039000
SYMBOLIC PROCEDURE LIST3(A, B, C)$                                      00039100
  CONS(A, CONS(B, CONS(C, NIL)))$                                       00039200
SYMBOLIC PROCEDURE LIST4(A, B, C, D)$                                   00039300
  CONS(A, CONS(B, CONS(C, CONS(D, NIL))))$                              00039400
SYMBOLIC PROCEDURE LIST5(A,B,C,D,E)$                                    00039500
  CONS(A,CONS(B,CONS(C,CONS(D,CONS(E,NIL)))))$                          00039600
                                                                        00039700
SYMBOLIC PROCEDURE MAP(X, FNMAP)$                                       00039800
  WHILE X DO << FNMAP X$  X := CDR X >>$                                00039900
                                                                        00040000
SYMBOLIC PROCEDURE MAPC(X, FNMAPC)$                                     00040100
  WHILE X DO << FNMAPC CAR X$  X := CDR X >>$                           00040200
                                                                        00040300
SYMBOLIC PROCEDURE MAPCAN(X, FNMAPCAN)$                                 00040400
  IF NULL X THEN NIL                                                    00040500
    ELSE NCONC(FNMAPCAN CAR X, MAPCAN(CDR X, FNMAPCAN)) $               00040600
                                                                        00040700
SYMBOLIC PROCEDURE MAPCAR(X, FNMAPCAR)$                                 00040800
  IF NULL X THEN NIL                                                    00040900
    ELSE FNMAPCAR CAR X  .  MAPCAR(CDR X, FNMAPCAR)$                    00041000
                                                                        00041100
SYMBOLIC PROCEDURE MAPCON(X, FNMAPCON)$                                 00041200
  IF NULL X THEN NIL                                                    00041300
    ELSE NCONC(FNMAPCON X, MAPCON(CDR X, FNMAPCON))$                    00041400
                                                                        00041500
SYMBOLIC PROCEDURE MAPLIST(X, FNMAPLIST)$                               00041600
  IF NULL X THEN NIL                                                    00041700
    ELSE FNMAPLIST X . MAPLIST(CDR X, FNMAPLIST)$                       00041800
                                                                        00041900
SYMBOLIC PROCEDURE SET(EXP, VALUE)$                                     00042000
<< IF (EXP=NIL) OR (EXP EQ T) THEN ERROR(105,"Cant rebind NIL or T");   00042100
   IF !*SETTRACE THEN <<PRIN2 EXP; PRIN2 " <- "; PRINT VALUE>>;         00042200
   IF GLOBALP EXP OR FLUIDP EXP THEN !$PUTG(EXP, VALUE)                 00042300
     ELSE BEGIN SCALAR XX;                                              00042400
        XX:=!$GETG(EXP) EQ !*UNBOUND;                                   00042500
        !$PUTG(EXP, VALUE)$                                             00042600
        IF XX THEN                                                      00042700
           << FLUID(LIST(EXP));                                         00042800
              PRIN2 "***"; PRIN1 EXP; PRIN2 " declared FLUID";          00042900
              TERPRI()  >> END;                                         00043000
     VALUE >>$                                                          00043100
                                                                        00043200
SYMBOLIC FEXPR PROCEDURE !%!%SETQ U; SET(CAR U,EVAL CAR CDR U);         00043300
                                                                        00043400
FLUID '(TRACEBACK!* !@!@!@U !$!$PROG1 !$!$PROG2)$                       00043500
                                                                        00043600
SYMBOLIC FEXPR PROCEDURE !%!%GO LBL$                                    00043700
IF NOT IDP CAR LBL THEN !$T!.MSMTCH(CAR LBL, 'ID, 'GO)                  00043800
ELSE << THROWBACK!* := CAR LBL$                                         00043900
        !$THROW('GO, NIL) >>$                                           00044000
                                                                        00044100
SYMBOLIC PROCEDURE !%!%RETURN U$                                        00044200
<< THROWBACK!* := U$                                                    00044300
   !$THROW('RETURN, NIL) >>$                                            00044400
                                                                        00044500
SYMBOLIC FEXPR PROCEDURE PROG L$                                        00044600
BEGIN SCALAR GOS, X$                                                    00044700
IF NULL L THEN ERROR(200, "Invalid PROG form")$                         00044800
!$LAMBIND(CAR L, NIL)$                                                  00044900
IF NULL(X := L := CDR L) THEN GO TO RET$                                00045000
WHILE X DO                                                              00045100
  << IF ATOM CAR X THEN GOS := X . GOS$                                 00045200
     X := CDR X >>$                                                     00045300
LOOP:                                                                   00045400
  !$!$PROG1 := L; !$!$PROG2 := GOS;                                     00045500
  X := !$CATCH '(!$PROG !$!$PROG1 !$!$PROG2);                           00045600
  IF PAIRP X THEN <<THROWBACK!* := CAR X; GO TO RET1>>;                 00045700
  IF X EQ 'GO THEN                                                      00045800
      IF NULL(L := ASSOC!*(THROWBACK!*, GOS)) THEN                      00045900
        ERROR(201, LIST(THROWBACK!*, " is not a known label"))          00046000
      ELSE GO TO LOOP                                                   00046100
    ELSE IF X EQ 'RETURN THEN GO TO RET1                                00046200
    ELSE IF X EQ 'ERROR THEN !$THROW('ERROR, TRACEBACK!*)$              00046300
RET: THROWBACK!* := NIL$                                                00046400
RET1: !$POP()$                                                          00046500
  RETURN THROWBACK!*                                                    00046600
END  PROG$                                                              00046700
                                                                        00046800
SYMBOLIC PROCEDURE !$PROG(L,GOS);                                       00046900
  BEGIN SCALAR S;                                                       00047000
    RETURN WHILE PAIRP L DO                                             00047100
      <<IF !*PROGTRACE THEN PRINT CAR L;                                00047200
         IF PAIRP CAR L THEN                                            00047300
         <<S:=CAAR L;                                                   00047400
           IF S = 'COND THEN                                            00047500
             L := (!$COND CDAR L) . CDR L ELSE                          00047600
           IF S='SETQ THEN                                              00047700
             <<SET(CADAR L,EVAL CADDAR L); L:=CDR L>> ELSE              00047800
           IF S = 'GO THEN                                              00047900
             <<IF NULL(L:=ASSOC!*(CADAR L,GOS)) THEN                    00048000
                 ERROR(201,LIST CADAR L, " is not a known label");      00048100
             >> ELSE                                                    00048200
           IF S = 'RETURN THEN                                          00048300
             RETURN EVAL CADAR L ELSE                                   00048400
           IF S='PROGN THEN                                             00048500
             L := (!$PROGN CDAR L) . (CDR L)                            00048600
           ELSE <<EVAL CAR L; L := CDR L>>                              00048700
         >> ELSE L := CDR L                                             00048800
      >>                                                                00048900
  END;                                                                  00049000
                                                                        00049100
SYMBOLIC FEXPR PROCEDURE PROGN X$                                       00049200
BEGIN SCALAR RETVAL$                                                    00049300
LOOP: IF ATOM X THEN RETURN RETVAL$                                     00049400
      IF !*PROGTRACE THEN PRINT CAR X;                                  00049500
      RETVAL := EVAL CAR X$                                             00049600
      X := CDR X$                                                       00049700
      GO TO LOOP                                                        00049800
END PROGN$                                                              00049900
                                                                        00050000
SYMBOLIC PROCEDURE !$PROGN L;                                           00050100
  BEGIN SCALAR S;                                                       00050200
    RETURN WHILE PAIRP L DO                                             00050300
      <<IF !*PROGTRACE THEN PRINT CAR L;                                00050400
         IF PAIRP CAR L THEN                                            00050500
         <<S:=CAAR L;                                                   00050600
           IF S = 'COND THEN                                            00050700
             L := (!$COND CDAR L) . CDR L ELSE                          00050800
           IF S='SETQ THEN                                              00050900
             <<SET(CADAR L,EVAL CADDAR L); L := CDR L>> ELSE            00051000
           IF S = 'GO OR S='RETURN THEN                                 00051100
             RETURN CAR L ELSE                                          00051200
           IF S='PROGN THEN                                             00051300
             L := (!$PROGN CDAR L) . CDR L                              00051400
           ELSE <<EVAL CAR L; L := CDR L>>                              00051500
         >> ELSE L := CDR L                                             00051600
      >>                                                                00051700
  END;                                                                  00051800
                                                                        00051900
SYMBOLIC PROCEDURE PROG2(U,V); V;                                       00052000
                                                                        00052100
SYMBOLIC FEXPR PROCEDURE !%!%COND X$                                    00052200
BEGIN                                                                   00052300
LOOP: IF ATOM X THEN RETURN NIL$                                        00052400
      IF NOT PAIRP CAR X THEN ERROR(118,                                00052500
          "Improper cond-form as argument of COND")$                    00052600
      IF EVAL CAR CAR X THEN                                            00052700
        IF NOT PAIRP CDR CAR X THEN ERROR(118,                          00052800
          "Improper cond-form as argument of COND")                     00052900
        ELSE RETURN EVAL CAR CDR CAR X$                                 00053000
      X := CDR X$                                                       00053100
      GO TO LOOP                                                        00053200
END COND$                                                               00053300
                                                                        00053400
SYMBOLIC PROCEDURE !$COND X$                                            00053500
BEGIN                                                                   00053600
LOOP: IF ATOM X THEN RETURN NIL$                                        00053700
      IF NOT PAIRP CAR X THEN ERROR(118,                                00053800
          "Improper cond-form as argument of COND")$                    00053900
      IF EVAL CAR CAR X THEN                                            00054000
        IF NOT PAIRP CDR CAR X THEN ERROR(118,                          00054100
          "Improper cond-form as argument of COND")                     00054200
        ELSE RETURN CAR CDR CAR X$                                      00054300
      X := CDR X$                                                       00054400
      GO TO LOOP                                                        00054500
END COND$                                                               00054600
                                                                        00054700
                                                                        00054800
SYMBOLIC PROCEDURE ERRORSET(!@!@!@U, MSGP, TRACEBACK!*)$                00054900
BEGIN SCALAR X$                                                         00055000
  X := !$CATCH !@!@!@U$                                                 00055100
  IF ATOM X THEN                                                        00055200
    IF X EQ 'ERROR THEN                                                 00055300
     << IF MSGP THEN !$ERRPRNT ("***** " . EMSG!*)$                     00055400
        RETURN ERNUM!* >>                                               00055500
    ELSE !$THROW(X, TRACEBACK!*)$                                       00055600
  RETURN X                                                              00055700
END ERRORSET$                                                           00055800
                                                                        00055900
UNFLUID '(!@!@!@U)$                                                     00056000
                                                                        00056100
SYMBOLIC PROCEDURE ERROR(NUMBER, MESSAGE)$                              00056200
<< ERNUM!* := NUMBER$                                                   00056300
   EMSG!* := MESSAGE$                                                   00056400
   !$THROW('ERROR, TRACEBACK!*) >>$                                     00056500
                                                                        00056600
SYMBOLIC PROCEDURE !$T!.MSMTCH(A, B, C)$                                00056700
ERROR(106, LIST(A, " not ", B, " for ", C))$                            00056800
                                                                        00056900
SYMBOLIC PROCEDURE APPLY(FN,ARGS)$                                      00057000
  IF CODEP FN THEN !$APPLY(FN,ARGS)                                     00057100
  ELSE IF PAIRP FN THEN                                                 00057200
         IF CAR FN = 'LAMBDA THEN                                       00057300
           << !$LAMBIND(CAR CDR FN,ARGS);                               00057400
              EVAL CAR CDR CDR FN;                                      00057500
              !$POP() >>                                                00057600
         ELSE                                                           00057700
           ERROR(102,LIST(FN," improperly formed LAMBDA expression"))   00057800
  ELSE IF IDP FN THEN                                                   00057900
       APPLY(CDR BEGIN SCALAR LN;                                       00058000
        IF NULL(LN:=!$GETG FN) OR LN EQ !*UNBOUND THEN                  00058100
                ERROR(103,LIST(FN," is undefined"))                     00058200
        ELSE                                                            00058300
        IF PAIRP LN AND (CAR LN EQ 'EXPR OR CAR LN EQ 'SUBR) THEN       00058400
             RETURN LN                                                  00058500
        ELSE ERROR(104,LIST(FN," cant APPLY form"))                     00058600
       END,ARGS)                                                        00058700
  ELSE ERROR(103,LIST(FN," is undefined"));                             00058800
                                                                        00058900
                                                                        00059000
SYMBOLIC PROCEDURE EVAL U$                                              00059100
BEGIN SCALAR FN,Y,Z;                                                    00059200
  IF ATOM U THEN RETURN                                                 00059300
    IF CONSTANTP U THEN U ELSE                                          00059400
    IF (FN := !$GETG U) EQ !*UNBOUND THEN                               00059500
        ERROR(100, LIST("Unbound: ", U))  ELSE FN$                      00059600
  IF IDP(Z:=CAR U) THEN                                                 00059700
  <<FN := !$GETG Z$                                                     00059800
    IF ATOM FN THEN                                                     00059900
            ERROR(103, LIST(Z," is an undefined function"));            00060000
    Y := CAR FN; FN := CDR FN;                                          00060100
    IF Y EQ 'FSUBR THEN                                                 00060200
      RETURN                                                            00060300
        IF Z='QUOTE THEN CADR U ELSE                                    00060400
        IF Z='LIST THEN EVLIS CDR U ELSE                                00060500
        !$FSUBR(CDR U, FN);                                             00060600
    IF Y EQ 'SUBR THEN                                                  00060700
      RETURN !$SUBR(FN, CDR U);                                         00060800
    IF Y EQ 'EXPR THEN                                                  00060900
      RETURN APPLY(FN, EVLIS CDR U);                                    00061000
    IF Y EQ 'FEXPR THEN                                                 00061100
      RETURN APPLY(FN, LIST CDR U);                                     00061200
    IF Y EQ 'MACRO THEN                                                 00061300
      RETURN EVAL APPLY(FN, LIST U);                                    00061400
    ERROR(129, LIST(Y, " is not a defined function type"))              00061500
  >>                                                                    00061600
  ELSE IF PAIRP Z THEN RETURN APPLY(Z,EVLIS CDR U)                      00061700
  ELSE IF CODEP Z THEN RETURN !$SUBR(Z,CDR U)                           00061800
  ELSE ERROR(103,LIST(Z," is an undefined function"));                  00061900
END EVAL$                                                               00062000
                                                                        00062100
                                                                        00062200
SYMBOLIC PROCEDURE FIX U; IF NUMBERP U THEN U                           00062300
        ELSE !$T!.MSMTCH(U,'NUMBER,'FIX);                               00062400
                                                                        00062500
SYMBOLIC PROCEDURE FLOAT U;                                             00062600
           ERROR(99, "Floating point is not implemented");              00062700
                                                                        00062800
SYMBOLIC PROCEDURE FACTORIAL N;                                         00062900
  BEGIN SCALAR P,I;                                                     00063000
    P:=1;                                                               00063100
    FOR I:=2:N DO P:=P*I;                                               00063200
    RETURN P                                                            00063300
  END$                                                                  00063400
                                                                        00063500
                                                                        00063600
END;                                                                    00063700
%                                                                       10000100
%                                                                       10000200
%*********************************************************************  10000300
%**                                                                 **  10000400
%**         COMMENTS ON THE PATCHES WRITTEN BY MONTREAL PPD         **  10000500
%**                                                                 **  10000600
%*********************************************************************  10000700
%                                                                       10000800
%PPDMTL13               08/28/85                       L. SANS CARTIER  10000900
%TO BE CONFORM TO OTHER SIMILAR FUNCTIONS (E.G. ONEP, NUMBERP, ETC),    10001000
%THE PROCEDURE MINUSP HAD BEEN PROGRAMMED DIFFERENTLY. THIS WAY, IT     10001100
%WILL RETURN "NIL" INSTEAD OF GIVING AN ERROR MESSAGE WHENEVER THE      10001200
%PARAMETER IS ANYTHING ELSE THAN AN INTEGER.                            10001300
%                                                                       10001350
%PPDMTL14               08/28/85                       L. SANS CARTIER  10001400
%WHEN THE THIRD PARAMETER OF "PUTD" IS A WRONG FUNCTION TYPE, AN ERROR  10001420
%WILL BE GIVEN.  BEFORE, NO MESSAGE  WAS GIVEN  AT TIME OF  DEFINITION  10001440
%(I.E. WITH  "PUTD" )  EVENTHOUGH THE FUNCTION WAS ACTUALLY UNDEFINED.  10001460
%YOU WILL NOTICE THAT:                                                  10001465
%  1- THE FOLLOWING FUNCTION TYPES: "NMACRO" "SMACRO" "PROCEDURE" "EMB" 10001480
%     ARE INTERNAL FUNCTION TYPES USED WHEN RE-GENERATING "REDUCE" SUB- 10001490
%     SYSTEM. THEY MUST BE PROCESSED THE SAME WAY THAN BEFORE.          10001491
%  2- THE WHOLE PROCEDURE "PUTD" HAD BEEN COMPLETELY RE-ALIGNED AND     10001500
%     RE-INDENTED WHEN WE CORRECTED THIS BUG.                           10001550
%                                                                       10001570
%PPDMTL99               08/28/85                       L. SANS CARTIER  10002000
%THESE ARE ONLY MINOR MODIFICATIONS THAT HAD TO BE MADE WHEN WE DECIDED 10002100
%TO CHANGE THE FILE TYPE FROM "DATA" (80 CHAR./REC.) TO "SEQ" (ONLY     10002200
%72 CHAR./REC.). CHANGING THE FILE TYPE WAS NECESSARY IN ORDER TO BE    10002300
%ABLE TO MANAGE PATCHES.                                                10002400
%                                                                       10002500
« May 2024 »
Su Mo Tu We Th Fr Sa
1 2 3 4
5 6 7 8 9 10 11
12 13 14 15 16 17 18
19 20 21 22 23 24 25
26 27 28 29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: