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 <>$ 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 <>; 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 <> >> ELSE 00020600 <> >>; 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 <>; 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 <>; 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 <>; 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 <>; 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 <>; 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 <>; 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 <> ELSE 00047800 IF S = 'GO THEN 00047900 <> 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 <> 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 <> 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 <> 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 <> 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