Forgot your password?
Document Actions
INCLUDE/RLISP/LISP.sqd_m is the main portion of the Standard LISP interpreter/runtime, written in RLISP.
INCLUDE/RLISP/LISP.sqd_m is the main portion of the Standard LISP interpreter/runtime, written in RLISP.
Size 57.5 kB - File type text/plain
Click here to get the file
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