Lisp for Tandy TRS-80 Model 100 / ported by Nino

1 REM
** COPYRIGHT 1982 80 MICRO MAGAZINE **
    A DIVISION OF WAYNE GREEN INC.
DOCUMENTATION CONTAINED SOLELY IN 80 MICRO
  CALL 800-258-5473 FOR BACK ISSUES
5 REM     * BASIC LISP VER 1.1 *
10 REM * BY RANDY BEER; AUG., 1981 *
15 CLS:CLEAR325:DEFINTA-E,G-V,X-Z:DEFSTRO:DIMLM(1100),PL(1100),OB(90),PT(90),ST(350),FP(50),T1(15),X1(15):N=3000
22 PRINTTAB(23)"BASIC LISP VER 1.1":PRINT:PRINT"INITIALIZING . . . WAIT":PRINT
24 FORJ=0TO48:READOB(J),PT(J):NEXT:PE=48:FE=1:OB(46)=CHR$(13):FP(1)=MEM
26 FORJ=1TO1099:PL(J)=J+1:NEXT:PL(1100)=N:AS=1
28 T=3001:LP=3043:RP=3044:CC=33:N1=58:N2=44:LB=3031:QU=3030:NB=3032
30 A=0:QT=0:J=0:PRINT:PRINT"$ ";:ONERRORGOTO26000:GOSUB50:GOSUB265:GOSUB210:GOTO30
50 J1=0:PRINTCHR$(01);:GOSUB90
55 GOSUB100:IFX<>LPTHENRETURN
60 J1=J1+1:X1(J1)=AS:T1(J1)=AS:LM(T1(J1))=0:AS=PL(AS):IFQ<>0THENRETURN
65 GOSUB55:IFX=RPTHENGOTO80
70 IFLM(T1(J1))<>0THENPL(T1(J1))=AS:T1(J1)=AS:AS=PL(AS)
75 LM(T1(J1))=X:IFQ<>0THENRETURNELSE65
80 PL(T1(J1))=N:X=X1(J1):IFLM(X)=0ANDPL(X)=NTHENPL(X)=AS:AS=X:X=N
85 J1=J1-1:RETURN
90 A$=INKEY$:IFA$=""THEN90:ELSEPRINTA$;:KK=ASC(A$):RETURN
100 IFKK=40THENX=LP:GOTO200
105 IFKK=41THENX=RP:IFJ1=1ORJ1=2ANDQT<>0THENRETURNELSE200
110 IFKK=39THENQ=-1:QT=QT+1:GOSUB60:LM(T1(J1))=QU:Q=0:GOSUB90:GOSUB55:Q=-1:GOSUB70:Q=0:GOSUB80:QT=QT-1:RETURN
115 IFKK<CCTHENGOSUB90:GOTO100ELSE125
120 IFKK<CCORKK=40ORKK=41ORKK=39THEN130
125 I$=I$+A$:GOSUB90:GOTO120
130 IFASC(I$)<N1ANDASC(I$)>N2THEN150
135 FORJ=0TOPE:IFOB(J)=I$THENX=J+N:I$="":J=0:RETURN:ELSENEXT
145 J=0:PE=PE+1:OB(PE)=I$:X=PE+N:I$="":RETURN
150 WW=VAL(I$):GOSUB10000:I$="":RETURN
200 GOSUB90:RETURN
210 IFA$<>CHR$(13)THENPRINT
215 J1=1:X1(J1)=X:GOSUB225:PRINT:RETURN
225 IFX>5000THENPRINT"; UNPRINTABLE MACHINE CODE";:RETURNELSEIFX>4000THENPRINTFP(X-4000);CHR$(28);:RETURN
230 IFX>=NTHENPRINTOB(X-N);:RETURN
235 IFX=0THENRETURN
237 IFLM(X)=QUTHENPRINT"'";:X=LM(PL(X)):GOSUB225:RETURN
240 J1=J1+1:X1(J1)=X:PRINT"(";
245 X=X1(J1):X=LM(X):GOSUB225
250 X=X1(J1):J1=J1-1:X=PL(X):IFX=NTHENPRINT")";:RETURNELSEIFX>NTHENPRINT" . ";:GOSUB225:PRINT")";:RETURNELSEIFX=0THENX=1/0
255 J1=J1+1:X1(J1)=X:PRINT" ";:GOTO245
265 FP(1)=MEM:IFX>4000ANDX<5001ORX=NORX=TTHENRETURN
270 IFX>NTHENV=X:X=PT(X-N):IFX=0ANDA=0THENER=6:GOTO25000:ELSERETURN
275 ST(A+1)=TT:ST(A+2)=AL:ST(A+3)=C:ST(A+4)=E:A=A+4
280 AL=PL(X):E=X:X=LM(X):GOSUB265
285 IFX>=NANDX<4001THENER=1:GOTO25000
290 IFX>6000THEN320:ELSEIFX>5000THEN315:ELSEIFLM(X)=LBTHEN335:ELSEIFLM(X)=NBTHEN337:ELSEER=1:GOTO25000
315 TT=X:GOSUB500:ONTT-5000GOSUB4000,4010,4025,4035,4060,4070,4295,4290,4085,4095,4130,4170,4200,4220,4230,4245,4255,4300,4315,4310,4450:GOTO330
320 R=X:X=AL:ONR-6000GOSUB4050,50,4120,4150,4190,4285,4265,4275,4399,4500,4600,4650,4700,4750
330 E=ST(A):C=ST(A-1):AL=ST(A-2):TT=ST(A-3):A=A-4:RETURN
335 TT=AL:E=PL(X):AL=LM(E):GOSUB500:AL=TT:GOSUB500:C=LM(E):A=A-ST(A):GOTO340
337 TT=AL:E=PL(X):AL=LM(E):GOSUB500
338 ST(A+1)=TT:ST(A+2)=1:C=LM(E):A=A+1
340 IFC<>NTHENPT(LM(C)-N)=ST(A):A=A+1:C=PL(C):GOTO340
345 A=A-ST(A)-1:TT=PL(E)
350 IFTT<>NTHENX=LM(TT):GOSUB265:TT=PL(TT):GOTO350
355 C=LM(E):A=A-ST(A)
360 IFC<>NTHENPT(LM(C)-N)=ST(A):A=A+1:C=PL(C):GOTO360
365 A=A-ST(A)-1:GOTO330
500 C=0:IFAL=NTHENIFC=0THENA=A+1:ST(A)=0:GOTO510:ELSE510
505 X=LM(AL):GOSUB265:C=C+1:A=A+1:ST(A)=X:IFPL(AL)<>NTHENAL=PL(AL):GOTO505
510 A=A+1:ST(A)=C:RETURN
4000 IFST(A)<>1THENER=2:GOTO25000
4005 A=A-1:IFST(A)=NTHENX=N:A=A-1:RETURN
4006 IFST(A)<2001ANDST(A)>0THENX=LM(ST(A)):A=A-1:RETURN
4007 ER=4:GOTO25000
4010 IFST(A)<>1THENER=2:GOTO25000
4015 A=A-1:IFST(A)=NTHENX=N:A=A-1:RETURN
4017 IFST(A)<2001ANDST(A)>0THENX=PL(ST(A)):A=A-1:RETURN
4020 ER=4:GOTO25000
4025 IFST(A)<>2THENER=2:GOTO25000
4030 A=A-1:T2=AS:AS=PL(AS):LM(T2)=ST(A-1):PL(T2)=ST(A):A=A-2:X=T2:RETURN
4035 IFST(A)<>2THENER=2:GOTO25000
4040 A=A-1:IFST(A-1)<NORST(A-1)>4000THENER=3:GOTO25000
4045 PT(ST(A-1)-N)=ST(A):A=A-2:RETURN
4050 X=LM(AL):RETURN
4060 WW=0:FORJ=1TOST(A):A=A-1:IFST(A)>4000ANDST(A)<5001THENWW=WW+FP(ST(A)-4000):NEXT:ELSEER=5:GOTO25000
4065 A=A-1:GOSUB10000:RETURN
4070 IFST(A)<>2THENER=2:GOTO25000
4075 A=A-1:IFST(A)<4001ORST(A)>5000ORST(A-1)<4001ORST(A-1)>5000THENER=5:GOTO25000
4080 WW=FP(ST(A-1)-4000)-FP(ST(A)-4000):A=A-2:GOSUB10000:RETURN
4085 WW=1:FORJ=1TOST(A):A=A-1:IFST(A)>4000ANDST(A)<5001THENWW=WW*FP(ST(A)-4000):NEXT:ELSEER=5:GOTO25000
4090 A=A-1:GOSUB10000:RETURN
4095 IFST(A)<>2THENER=2:GOTO25000
4100 A=A-1:IFST(A)<4001ORST(A)>5000THENER=5:GOTO25000
4105 A=A-1:IFST(A)<4001ORST(A)>5000THENER=5:GOTO25000
4110 IFFP(ST(A+1)-4000)=0THENER=7:GOTO25000
4115 WW=FP(ST(A)-4000)/FP(ST(A+1)-4000):A=A-1:GOSUB10000:RETURN
4120 IFLM(AL)>=NANDLM(AL)<4000THENX=LM(PL(AL)):GOSUB265:PT(LM(AL)-N)=X:ELSEER=3:GOTO25000
4125 AL=PL(AL):IFAL=NTHENER=2:GOTO25000ELSEAL=PL(AL):IFAL=NTHENRETURNELSE4120
4130 IFST(A)<>1THENER=2:GOTO25000
4135 A=A-1:IFST(A)>=NANDST(A)<5000THENX=T:A=A-1:RETURN:ELSEX=N:A=A-1:RETURN
4150 C=LM(AL):X=LM(C):GOSUB265:IFX=NTHENAL=PL(AL):IFAL=NTHENRETURNELSE4150
4155 AL=PL(C)
4160 X=LM(AL):GOSUB265:IFPL(AL)=NTHENRETURNELSEAL=PL(AL):GOTO4160
4165 AL=PL(C)
4170 IFST(A)<>2THENER=2:GOTO25000
4175 A=A-1:IFST(A)=ST(A-1)THENX=T:ELSEX=N
4180 A=A-2:RETURN
4190 PL(E)=AS:AS=E:X=LM(AL):PT(X-N)=AL:IFLM(PL(AL))=NTHENLM(AL)=LB:RETURN:ELSEIFLM(LM(PL(AL)))=LBORLM(LM(PL(AL)))=NBTHENPT(X-N)=LM(PL(AL)):RETURN:ELSELM(AL)=LB:RETURN
4200 IFST(A)=0THENX=N:A=A-1:RETURN:ELSEX=AS:F=ST(A):A=A-F:FORJ=1TOF:IFST(A)=0THENER=4:GOTO25000:ELSEG=AS:AS=PL(AS):LM(G)=ST(A):A=A+1:NEXT:PL(G)=N:A=A-ST(A)-1:RETURN
4220 A=A-1:IFST(A)=NTHENX=T:ELSEX=N
4225 A=A-1:RETURN
4230 IFST(A)<>1THENER=2:GOTO25000:ELSEA=A-1
4235 IFST(A)>4000ANDST(A)<5000THENX=T:ELSEX=N
4240 A=A-1:RETURN
4245 IFST(A-1)>4000ANDST(A-1)<5000THENFORJ=1TOST(A)-1:A=A-1:IFST(A-1)>4000ANDST(A-1)<5000THENIFFP(ST(A)-4000)<FP(ST(A-1)-4000)THENX=T:NEXT:A=A-2:RETURN:ELSE4252:ELSE4250
4250 ER=5:GOTO25000
4252 X=N:A=A-2:RETURN
4255 IFST(A-1)>4000ANDST(A-1)<5000THENFORJ=1TOST(A)-1:A=A-1:IFST(A-1)>4000ANDST(A-1)<5000THENIFFP(ST(A)-4000)>FP(ST(A-1)-4000)THENX=T:NEXT:A=A-2:RETURN:ELSE4261:ELSE4260
4260 ER=5:GOTO25000
4261 X=N:A=A-2:RETURN
4265 IFAL<>NTHENX=LM(AL):GOSUB265:IFX<>NTHENAL=PL(AL):GOTO4265
4270 RETURN
4275 IFAL<>NTHENX=LM(AL):GOSUB265:IFX=NTHENAL=PL(AL):GOTO4275
4280 RETURN
4285 X=E:RETURN
4290 IFST(A)<>1THENER=2:GOTO25000:ELSEA=A-1:X=ST(A):GOSUB210:X=0:A=A-1:RETURN
4295 IFST(A)<>1THENER=2:GOTO25000:ELSEA=A-1:X=ST(A):GOSUB265:A=A-1:RETURN
4300 IFST(A)<>1THENER=2:GOTO25000
4305 A=A-1:X=ST(A):IFX>=NANDX<5000THENGOSUB225:X=0:A=A-1:RETURNELSEER=3:GOTO25000
4310 IFST(A)=0ORST(A-1)=NTHENX=N:A=A-ST(A)-1:RETURN:ELSEX=AS:FORJ=A-ST(A)TOA-1:Y=ST(J):IFY=0ORY>2000ANDY<>NTHENER=4:ST(A)=Y:GOTO25000
4312 IFY<>NTHENZ=AS:AS=PL(AS):LM(Z)=LM(Y):Y=PL(Y):GOTO4312
4313 NEXT
4314 A=A-ST(A)-1:PL(Z)=N:RETURN
4315 IFST(A)<>2THENER=2:GOTO25000
4320 A=A-1:IFST(A)<4001ORST(A)>5000THENER=5:GOTO25000
4325 A=A-1:IFST(A)<4001ORST(A)>5000THENER=5:GOTO25000
4330 WW=FP(ST(A)-4000)^FP(ST(A+1)-4000):GOSUB10000:A=A-1:RETURN
4399 IFLM(AL)<3000ORLM(AL)>4000THENER=1:GOTO4447:ELSET2=PT(LM(AL)-N):IFT2>2000ORT2=0THENER=1:GOTO4447:ELSEIFLM(T2)<>LBANDLM(T2)<>NBTHENER=1:GOTO4447
4400 PRINT:PRINT:PRINT"(DEFUN ";:X=LM(AL):A$=CHR$(13):GOSUB230:PRINT" (";:X=LM(T2):GOSUB230:PRINT" ";:T2=PL(T2):X=LM(T2):J1=1:X1(J1)=X:GOSUB225:J=0:J2=0
4405 T2=PL(T2):IFT2<>NTHENPRINT:PRINTTAB(3);:X1(J2)=-2:X=LM(T2):GOSUB4410:GOTO4405ELSEPRINT"))";:X=0:RETURN
4410 IFX>4000THENPRINTFP(X-4000);CHR$(28);:RETURN
4415 IFX>=NTHENPRINTOB(X-N);:RETURN
4420 IFLM(X)=QUTHENPRINT"'";:X=LM(PL(X)):GOSUB225:RETURN
4425 J=J+1:T1(J)=X:D=LM(X):B=D-N:IFB=40ORB=41ORB=31THEN4445:ELSEIFB<>6ANDB<>9ANDB<>10ANDB<>14ANDB<>20ANDB<>21PRINT"(";:ELSE4435
4430 X=T1(J):X=LM(X):GOSUB4410:X=T1(J):J=J-1:X=PL(X):IFX=NPRINT")";:RETURN:ELSEJ=J+1:T1(J)=X:PRINT" ";:GOTO4430
4435 T1(J)=PL(T1(J)):PRINTTAB(X1(J2)+2)"(";:J2=J2+1:X1(J2)=POS(0):X=D:GOSUB4415:PRINT
4440 X=LM(T1(J)):PRINTTAB(X1(J2)+2);:GOSUB4410:X=T1(J):J=J-1:X=PL(X):IFX=NTHENJ2=J1-1:PRINT")";:RETURN:ELSEPRINT:J=J+1:T1(J)=X:GOTO4440
4445 T1(J)=PL(T1(J)):PRINTTAB(X1(J2)+2)"(";:J2=J2+1:X1(J2)=POS(0):X=D:GOSUB4415:PRINT" ";:X=LM(T1(J)):GOSUB4410:PRINT:T1(J)=PL(T1(J)):GOTO4440
4447 E=0:LM(E)=LM(AL):GOTO25000
4450 IFST(A)<>2THENER=2:GOTO25000:ELSEA=A-1:IFST(A)>2000THENER=4:GOTO25000:ELSEA=A-1:IFST(A)<NORST(A)>4000THENER=3:GOTO25000:ELSEJ=ST(A+1):D=ST(A):X=AS:Z=N
4455 IFJ<>NTHENIFLM(J)=DGOTO4460:ELSEZ=AS:AS=PL(AS):LM(Z)=LM(J):ELSEIFZ=NTHENX=N:RETURN:ELSEPL(Z)=N:RETURN
4460 J=PL(J):GOTO4455
4500 PRINT:PRINT"; HIT ENTER TO BEGIN";:GOSUB90:PRINT#-1,FE,PE,AS:FORJ=2TOFE:PRINT#-1,FP(J):NEXT:FORJ=49TOPE:PRINT#-1,OB(J),PT(J):NEXT:FORJ=1TOAS:PRINT#-1,LM(J),PL(J):NEXT:X=0:RETURN
4600 PRINT:PRINT"; HIT ENTER TO BEGIN";:GOSUB90:INPUT#-1,FE,PE,AS:FORJ=2TOFE:INPUT#-1,FP(J):NEXT:FORJ=49TOPE:INPUT#-1,OB(J),PT(J):NEXT:FORJ=1TOAS:INPUT#-1,LM(J),PL(J):NEXT:X=0:RETURN
4650 X=0:A=A-1:IFPE>48THENPRINT:PRINT"; ";OB(PE);" DELETED FROM OB LIST";:PT(PE)=0:OB(PE)="":PE=PE-1
4655 RETURN
4700 TT=LM(AL):E=PL(AL):AL=E
4705 X=TT:GOSUB265:IFX<>NTHENAL=E:GOSUB4800:GOTO4705:ELSERETURN
4750 TT=LM(AL):E=PL(AL):AL=E
4755 X=TT:GOSUB265:IFX=NTHENAL=E:GOSUB4800:GOTO4755:ELSERETURN
4800 IFAL<>NTHENX=LM(AL):GOSUB265:AL=PL(AL):GOTO4800
4805 RETURN
10000 FORJ=1TOFE:IFFP(J)=WWTHEN10010
10005 NEXT:FE=FE+1:FP(FE)=WW:X=FE+4000:RETURN
10010 X=J+4000:RETURN
25000 X=ST(A):J1=1:X1(J)=X:IFA$<>CHR$(13)THENPRINT
25001 A$=CHR$(13):ONERGOTO25002,25003,25004,25005,25006,25007,25008
25002 PRINT"; ";:X=LM(E):GOSUB230:PRINT" INVALID FUNCTION NAME";:GOTO25050
25003 PRINT"; IMPROPER NUMBER OF ARGUEMENTS TO SUBR OR NSUBR";:GOTO25050
25004 PRINT"; ";:GOSUB225:PRINT" INVALID ATOM";:GOTO25050
25005 PRINT"; ";:GOSUB225:PRINT" INVALID LIST";:GOTO25050
25006 PRINT"; ";:GOSUB230:PRINT" INVALID NUMBER";:GOTO25050
25007 PRINT"; ";:X=V:GOSUB230:PRINT" UNBOUND ATOM";:GOTO25050
25008 PRINT"; DIVISION BY ZERO";:GOTO25050
25050 X=0:ONERRORGOTO25051:P=1/0
25051 PRINT:RESUME30
26000 IFA$<>CHR$(13)THENPRINT
26001 IFPE>90THENPRINT"; OB LIST FULL":PE=90:I$="":GOTO27100
26005 IFFE>50THENPRINT"; FP FULL":FE=50:I$="":GOTO27100
26010 IFAS=NTHENPRINT"; LIST MEMORY FULL":GOTO27100
26013 IFERR/2+1=9THENIFA>350ORJ1>15ORJ2>15ORJ>15PRINT"; STACK OVERFLOW":GOTO27000
26015 PRINT"; ERROR"
27000 RESUME30
27100 PRINT"; HIT ENTER TO REINTIALIZE, ANY OTHER KEY TO CONTINUE ":GOSUB90:IFA$=CHR$(13)THENPRINTCHR$(02):RUNELSE27000
50000 DATANIL,3000,T,3001,SETQ,6003,EQ,5012,CAR,5001,CDR,5002,COND,6004,DEFUN,6005,ATOM,5011,LIST,5013,APPEND,5020,ADD,5005,SUB,5006,MUL,5009,CONS,5003,NUMBERP,5015,GREATERP,5016,LESSP,5017,EVAL,5007
50001 DATAPRINTF,6009,AND,6007,OR,6008,DELETE,5021,SET,5004,DIV,5010,NOT,5014,POWER,5019,PRINT,5008,PATOM,5018,READ,6002,QUOTE,6001,LAMBDA,6006,NLAMBDA,6006,SAVE,6010,LOAD,6011,RPAREN,3044,LPAREN,3043,QT,3045,CR,3046
50002 DATASP,3047,DOWHILE,6013,DOUNTIL,6014,%,6012,(,0,),0,',0,CR,0," ",0,FREE,4001