Category : Miscellaneous Language Source Code
Archive   : ADA.ZIP
Filename : AUGUSTA.BAS

 
Output of file : AUGUSTA.BAS contained in archive : ADA.ZIP

1 ' **************************************
2 ' * *
3 ' * Augusta.bas - a public domain *
4 ' * subset of the US Department of *
5 ' * Defense computer language Ada. *
6 ' * *
7 ' **************************************
8 '
10 '
100 '
1000 DEFINT A-Z:CLS:KEY OFF:PRINT"Augusta(tm) Compiler v1.1A":PRINT"(C) Copyright 1983 by Computer Linguistics":PRINT"All rights reserved."
1003 DIM MAP(26),KEYWD$(33),S$(100),TY(20),B$(3),B(3),S(500)
1010 PRINT:PRINT"Initializing ...":GOSUB 1780:GOSUB 1110:SI=1:PRINT:INPUT"Source file ? ",S$:GOSUB 1230
1020 INPUT"Code file ? ",C$:OPEN"R",#1,C$,128:CLOSE 1:KILL C$
1040 INPUT"Listing (Y/CR)? ",T1$:OPEN"R",#1,C$,128:R0=16:M0=R0:IF T1$="Y" THEN PLST=-1:LPRINT LP$;
1050 GOSUB 1290:GOSUB 1400:PRINT FRE("");" Bytes for symbols":GOSUB 1980
1060 PUT #1,R0:FIELD #1,2 AS T1$,2 AS T2$,2 AS T3$,2 AS D$,2 AS S$
1070 LSET T1$=MKI$(GC):LSET T2$=MKI$(M0):LSET T3$=MKI$(PROC):LSET D$=MKI$(0):LSET S$=MKI$(1113)
1080 PUT #1,1:FIELD #1,128 AS D$:FOR I=1 TO MB:IF B(I)<>0 AND B(I)<>R0 THEN LSET D$=B$(I):PUT #1,B(I)
1090 NEXT I:CLOSE 1:PRINT:PRINT"Compiled OK":PRINT LN;" LINES. ";GC-1920;" bytes":GOTO 32767
1110 ' ********* Init
1120 QUOTE$=CHR$(34):LEXCH$=ALF$+DIG$+" @*+=-<>/:;')(,"+QUOTE$+".#!"+CHR$(3)+CHR$(96)+CHR$(9):CLST=-1
1130 SQUOTE=0:EOL=1:C=2:LP=3:RP=4:MUL=5:DIV=6:ADD=7:SUBT=8:LES=9:LEQ=10:GT=11:GEQ=12:EQ=13:NEQ=14:BAR=15:ID=16
1135 SC=17:COMMA=18:SEMICOLON=19:COLON=20:EQGT=21:COLONEQ=22:DOT=23:DOTDOT=24:CH=25:AT=26
1140 KAND=27:KARRAY=28:KBEGIN=29:KCASE=30:KCONST=31:KDECLARE=32:KELSE=33:KELSEIF=34:KEND=35:KEXIT=36:KFOR=37:KFUNC=38:KIF=39
1145 KIN=40:KIS=41:KLOOP=42:KLAST=43:KLEN=44:KMOD=45:KNOT=46:KNULL=47:KOF=48:KOR=49:KOTHERS=50:KOUT=51
1150 KPRAGMA=52:KPROC=53:KRET=54:KREVERSE=55:KTHEN=56:KWHEN=57:KWHILE=58
1160 ADDOP$=CHR$(ADD)+CHR$(SUBT):MULOP$=CHR$(MUL)+CHR$(DIV)+CHR$(KMOD):LOGICALOP$=CHR$(KAND)+CHR$(KOR)
1165 UNARYOP$=CHR$(ADD)+CHR$(SUBT)+CHR$(KNOT):RELOP$=CHR$(LES)+CHR$(LEQ)+CHR$(GT)+CHR$(GEQ)+CHR$(EQ)+CHR$(NEQ)
1170 DECLPART$=CHR$(ID)+CHR$(KPROC)+CHR$(KFUNC)+CHR$(KPRAGMA)
1180 STMT$=CHR$(KWHILE)+CHR$(KFOR)+CHR$(KLOOP)+CHR$(KDECLARE)+CHR$(KBEGIN)+CHR$(KEXIT)+CHR$(KRET)+CHR$(KIF)
1185 STMT$=STMT$+CHR$(KCASE)+CHR$(KNULL)+CHR$(ID)+CHR$(PRAGMA)
1190 LN=1:EOI=0:LL=0:CPROC=0:PROC=0:GC=1920:VLOC=VARPTR(V):VLOC1=VLOC+1:TSTR=0:TINT=1:TCHR=2:TBOL=4:FMSZ=14
1200 PLDCI=1:PLDL=2:PLLA=3:PLDB=4:PLDO=5:PLAO=6:PDUP=7:PLOD=8:PLDA=9:PPOP=10:PSTO=11:PSINDO=12:PLCA=13:PSAS=14:PAND=16
1205 POR=17:PNOT=18:PADI=19:PNGI=20:PSBI=21:PMPI=22:PDVI=23:PIND=24:PEQUI=25:PNEQI=26:PLEQI=27:PSLDC=61:PINCL=80:PDECL=81
1210 PLESI=28:PGEQI=29:PGTRI=30:PEQUSTR=31:PNEQSTR=32:PLEQSTR=33:PLESSTR=34:PGEQSTR=35:PGTRSTR=36:PUJP=37:PFJP=38:PXJP=39
1215 PCLP=40:PCGP=41:PCSP=42:PRET=43:PMODI=45:PCIP=46:PRNP=47:PEOP=15:PSLDCN1=63:PIXA=48
1217 PSLDO=57:PSLAO=58:PSLLA=59:PSLDLO=49:PSLDL=60
1220 RETURN
1230 '********** Open Source
1240 SI=SI+1:OPEN"I",#SI,S$:RETURN
1250 '********** Convert to UPPERCASE
1260 IF INSTR(LC$,CH$) THEN CH$=CHR$(ASC(CH$)-32)
1270 RETURN
1280 '********** GetLine
1290 LN=LN+1:IF EOF(SI) THEN CLOSE SI:SI=SI-1:IF SI>1 AND PLST THEN LPRINT TAB(26);"* End of INCLUDE"
1300 IF SI=1 THEN EOI=-1:RETURN
1310 LINE INPUT #SI,BUF$
1320 IF PLST=0 THEN GOTO 1330 ELSE LPRINT USING"##### #### ###### ###### ";LN,CPROC,CP,OFST;:LPRINT LEFT$(BUF$,54)
1325 IF (LN MOD 60)=0 THEN LPRINT CHR$(12);:LPRINT:LPRINT
1330 IF CLST<>0 THEN PRINT BUF$ ELSE IF (LN AND 63)=63 THEN PRINT LN;"..."
1340 IF LEN(BUF$)=0 THEN 1290 ELSE BUF$=BUF$+CHR$(3):B=1:WHILE MID$(BUF$,B,1)=" ":B=B+1:WEND:CH$=MID$(BUF$,B,1):B=B+1:RETURN
1360 '********** GetCh
1370 LSET CH$=MID$(BUF$,B,1):B=B+1:RETURN
1380 B=B+1
1390 RETURN
1400 '********** GetSym
1410 OLDB=B:GOSUB 1250:I=INSTR(LEXCH$,CH$):IF I=0 THEN E=1:GOTO 5020
1420 IF I<27 THEN GOSUB 1460:GOTO 1430
1423 IF I<42 THEN ON I-26 GOSUB 1500,1500,1500,1500,1500,1500,1500,1500,1500,1500,1700,1770,1720,1520,1600:GOTO 1430
1427 ON I-41 GOSUB 1530,1620,1640,1660,1680,1540,1750,1570,1560,1550,1730,1580,1695,1710,1450,1440,1775
1430 IF EOI THEN E=12:GOTO 5020 ELSE IF OLDB=B THEN 1410 ELSE LSET TT$=CHR$(T):RETURN
1440 T=SQUOTE:GOSUB 1360:RETURN
1450 GOSUB 1290:OLDB=B:RETURN
1460 S$="":WHILE INSTR(AN$,CH$):IF CH$<>"_" THEN S$=S$+CH$
1470 GOSUB 1370:GOSUB 1260:WEND:IF LEN(S$)>8 THEN S$=LEFT$(S$,8)
1480 ID$=S$+SPACE$(8-LEN(S$)):GOSUB 1890:RETURN
1490 '********** Digits
1500 TN=0:I1=10
1510 WHILE INSTR(HDIG$,CH$):TN=TN*I1+INSTR(HDIG$,CH$)-1:GOSUB 1360:WEND
1515 IF CH$="#" THEN I1=TN:TN=0:GOSUB 1360:GOTO 1510 ELSE T=C:RETURN
1520 T=ADD:GOSUB 1360:RETURN
1530 T=SUBT:GOSUB 1360:IF CH$="-" THEN GOSUB 1280:OLDB=B:RETURN ELSE RETURN
1540 T=SEMICOLON:GOSUB 1360:RETURN
1550 T=COMMA:GOSUB 1360:RETURN
1560 T=LP:GOSUB 1360:RETURN
1570 T=RP:GOSUB 1360:RETURN
1580 T=DOT:GOSUB 1360:IF CH$="." THEN T=DOTDOT:GOSUB 1360
1590 RETURN
1600 GOSUB 1360:IF CH$=">" THEN T=EQGT:GOSUB 1360 ELSE T=EQ
1610 RETURN
1620 GOSUB 1360:IF CH$="=" THEN T=LEQ:GOSUB 1360 ELSE T=LES
1630 RETURN
1640 GOSUB 1360:IF CH$="=" THEN T=GEQ:GOSUB 1360 ELSE T=GT
1650 RETURN
1660 GOSUB 1360:IF CH$="=" THEN T=NEQ:GOSUB 1360 ELSE T=DIV
1670 RETURN
1680 GOSUB 1360:IF CH$="=" THEN T=COLONEQ:GOSUB 1360 ELSE T=COLON
1690 RETURN
1695 T=BAR:GOSUB 1360:RETURN
1700 WHILE CH$=" ":LSET CH$=MID$(BUF$,B,1):B=B+1:WEND:OLDB=B:RETURN
1710 T=BAR:GOSUB 1360:RETURN
1720 T=MUL:GOSUB 1360:RETURN
1730 I1=INSTR(B,BUF$,QUOTE$):IF I1=0 THEN E=10:GOTO 5020
1740 S$=MID$(BUF$,B,I1-B):T=SC:B=I1+1:GOSUB 1360:RETURN
1750 GOSUB 1360:GOSUB 1360:IF CH$<>"'" THEN E=11:GOTO 5020
1760 GOSUB 1360:GOSUB 1930:TN=ASC(MID$(S$,2,1)):T=CH:RETURN
1770 T=AT:GOSUB 1360:RETURN
1775 GOSUB 1360:OLDB=B:RETURN
1780 '********** Read Data
1790 CH$=" ":B=0:LB=0:AN$=CH$:LC$=CH$:S$=CH$:T=0:T0=0:X=0:SP=0:TSP=0:LEXCH$=S$:CP=0:CB=0:W=0:I=0:R2=0:R1=0:T3=0:R0=16
1795 D$=S$:LOC1=0:LOC2=0:V=0:VLOC=0:VLOC1=0:TN=0:TT$=S$:HASH=0:ID$=S$:BUF$=S$:T1=0:T2=0
1800 NKEY=33:SSP=1:MB=3:FOR I=0 TO MB:B$(I)=SPACE$(128):B(I)=0:NEXT I
1820 OPEN"I",#1,"keywords.txt":LINE INPUT #1,LC$:T1=1:WHILE T1>0:INPUT #1,T1:LP$=LP$+CHR$(T1):WEND
1830 INPUT #1,DIG$,HDIG$,ALF$,LC$,AN$
1840 FOR I=1 TO 26:INPUT #1,MAP(I):NEXT I
1850 I=1:INPUT #1,ID$,TYPE,KIND,PINFO,CONST,OBJSZ,ADDR,LL:IF ID$<>"*END*" THEN ID$=ID$+SPACE$(8-LEN(ID$)):GOSUB 3850:GOTO 1850
1860 IF EOF(1) THEN 1880 ELSE INPUT #1,T$:IF LEN(T$)>8 THEN T$=LEFT$(T$,8)
1870 T$=T$+SPACE$(8-LEN(T$)):KEYWD$(I)=T$:I=I+1:GOTO 1860
1880 CLOSE 1:KEYWD$(0)=" ":KEYWD$(NKEY)=" ":RETURN
1890 '********** LookupKeyword
1900 HASH=MAP(INSTR(ALF$,LEFT$(ID$,1)))
1910 IF KEYWD$(HASH)=ID$ THEN T=HASH+26 ELSE IF ASC(KEYWD$(HASH))<>ASC(ID$) THEN T=ID ELSE HASH=HASH+1:GOTO 1910
1920 RETURN
1930 '********** Get S$
1940 S$=MID$(BUF$,OLDB-1,B-OLDB):RETURN
1950 IF T0=T THEN RETURN
1955 E=4:GOSUB 5110:PRINT"Reenter+ ";:LINE INPUT T$:BUF$=LEFT$(BUF$,B-1)+T$+CHR$(3):GOSUB 1360:GOSUB 1400:GOTO 1950
1960 IF T0=T THEN GOSUB 1400:RETURN ELSE GOSUB 1950:GOSUB 1400:RETURN
1970 '********** Compilation
1980 GOSUB 2770
1990 IF T=KPROC THEN GOSUB 1400:GOSUB 2010:T0=SEMICOLON:GOSUB 1950
2000 RETURN
2010 '********** Parse Proc
2020 GOSUB 5200
2030 KIND=2:PROC=PROC+1:CPROC=PROC:ADDR=PROC:X=ADDR:GOSUB 4280:GOSUB 3850:GOSUB 1400
2040 OFST=-FMSZ:IF T=KIS THEN 2060
2050 GOSUB 2100:T0=KIS:GOSUB 1950
2060 '********** Is
2070 X=-(OFST+FMSZ):GOSUB 4280:GOSUB 1400:OFST=0:MXOF=0:GOSUB 2440:W=PRET:GOSUB 3990:GOSUB 5300:RETURN
2100 '********** ProcFormalPart
2110 T2$="":T0=LP:GOSUB 1960
2120 GOSUB 2160:IF T=SEMICOLON THEN GOSUB 1400:GOTO 2120
2130 T0=RP:GOSUB 1960:FOR I=OFST TO-FMSZ-2 STEP 2:T1$=LEFT$(T2$,17):T2$=MID$(T2$,18):IF LEN(S$(SSP))+17)>255 THEN SSP=SSP+1
2140 S$(SSP)=LEFT$(T1$,14)+MKI$(I)+RIGHT$(T1$,1)+S$(SSP):NEXT I
2150 RETURN
2160 '********** ProcParamDecl
2170 T1$=""
2180 T0=ID:GOSUB 1950:T1$=T1$+ID$:GOSUB 1400
2190 IF T=COMMA THEN GOSUB 1400:GOTO 2180
2200 T0=COLON:GOSUB 1960:P1=1:IF T=KOUT THEN P1=2:GOSUB 1400:GOTO 2220
2210 IF T=KIN THEN GOSUB 1400
2220 GOSUB 2250:PINFO=P1
2230 WHILE LEN(T1$)>0:T2$=T2$+LEFT$(T1$,8)+CHR$(TYPE)+CHR$(KIND)+CHR$(PINFO)+MKI$(CONST)+CHR$(OBJSZ)+MKI$(0)+CHR$(LL)
2235 T1$=MID$(T1$,9):OFST=OFST-2:WEND
2240 RETURN
2250 '********** SubtypeIdentificationUnit
2260 GOSUB 3890:IF KIND<>4 THEN E=8:GOTO 5020 ELSE IF PINFO=0 THEN KIND=1 ELSE KIND=5
2280 IF TYPE<>0 THEN GOSUB 1400:RETURN
2285 GOSUB 2300:IF OBJSZ>255 THEN E=15:GOTO 5020 ELSE RETURN
2290 '********** Get C
2293 IF T<>ID THEN GOTO 2297 ELSE T8=TYPE:T3=KIND:T4=PINFO:T5=CONST:T6=OBJSZ:T7=LL
2294 GOSUB 3890:IF KIND=0 AND TYPE=1 THEN T=C:T2=CONST
2295 TYPE=T8:KIND=T3:PINFO=T4:CONST=T5:OBJSZ=T6:LL=T7
2297 T0=C:GOSUB 1960:RETURN
2300 '********** ObjSz
2310 GOSUB 1400:IF T<>LP THEN 2330 ELSE GOSUB 1400
2320 GOSUB 2290:OBJSZ=TN+1:T0=RP:GOSUB 1960
2330 RETURN
2340 '********** ParseFunc
2350 GOSUB 5200:KIND=3:PROC=PROC+1:CPROC=PROC:ADDR=PROC:X=ADDR:GOSUB 4280:GOSUB 3850:X=SSP:GOSUB 4280:X=LEN(S$(SSP))
2355 GOSUB 4280:GOSUB 1400
2370 OFST=-FMSZ:IF T=LP THEN GOSUB 2100
2380 T0=KRET:GOSUB 1960:GOSUB 2250:GOSUB 4300:T2=X:GOSUB 4300:T1=X:T3=LEN(S$(T1)):IF KIND<>5 OR OBJSZ<>2 THEN E=16:GOTO 5020
2385 S$(T1)=LEFT$(S$(T1),T3-T2+8)+CHR$(TYPE)+MID$(S$(T1),T3-T2+10)
2400 T0=KIS:GOSUB 1960
2410 X=-(OFST+FMSZ):GOSUB 4280:OFST=0:MXOF=0:GOSUB 2440:GOSUB 5300:RETURN
2440 '********** BodyPart
2450 IF INSTR(DECLPART$,TT$) THEN GOSUB 2480
2460 CB=GC:CP=0:GOSUB 2790
2470 RETURN
2480 '********** DeclPart
2490 IF T=ID THEN T1$=ID$:K1=5:GOSUB 2560:GOTO 2540
2500 IF T=KPROC THEN GOSUB 1400:GOSUB 2010:GOTO 2540
2510 IF T=KFUNC THEN GOSUB 1400:GOSUB 2340:GOTO 2540
2520 IF T=KPRAGMA THEN GOSUB 2770:GOTO 2550
2530 E=3:GOTO 5020
2540 GOSUB 3420
2550 IF INSTR(DECLPART$,TT$) THEN 2480 ELSE GOSUB 4990:RETURN
2560 '********** ObjDecl
2570 GOSUB 1400
2580 IF T=COMMA THEN GOSUB 1400:T0=ID:GOSUB 1950:T1$=T1$+ID$:GOTO 2570
2590 T0=COLON:GOSUB 1960
2600 IF T=KCONST THEN 2650
2610 IF T=KARRAY THEN 2700
2620 GOSUB 2250:OBJSIZE=OBJSZ
2630 PINFO=0:KIND=K1:WHILE LEN(T1$)>0:ID$=LEFT$(T1$,8):T1$=MID$(T1$,9):ADDR=OFST:OFST=OFST+OBJSIZE:GOSUB 3850:WEND
2640 RETURN
2650 '********** Constant
2670 K1=0:OBJSIZE=0:GOSUB 1400:T0=COLONEQ:GOSUB 1960:IF T=ID THEN GOSUB 3890:GOTO 2690 ELSE IF T=SUBT THEN T1=-1:GOSUB 1400 ELSE T1=1
2680 CONST=TN*T1:IF T=C THEN TYPE=1 ELSE TYPE=2
2690 GOSUB 1400:GOTO 2630
2700 '********** Array
2710 K1=1:GOSUB 1400:T0=LP:GOSUB 1960:T2=TN:GOSUB 2290:T0=RP:GOSUB 1960:T0=KOF:GOSUB 1960
2750 GOSUB 2250:CONST=T2:OBJSIZE=(T2+1)*OBJSZ:IF T2<0 OR T2>16383 THEN E=15:GOTO 5020 ELSE 2630
2770 '********** Pragma
2780 IF T<>KPRAGMA THEN RETURN ELSE GOSUB 4830:GOSUB 1280:GOSUB 1400:GOTO 2780
2790 '********** Stmt
2800 T0=KBEGIN:GOSUB 1960:GOSUB 2810:T0=KEND:GOSUB 1960:RETURN
2810 '********** SeqOfStmts
2820 I=INSTR(STMT$,TT$)
2825 IF I=0 THEN RETURN ELSE ON I GOSUB 4320,4320,4320,2850,2850,2890,2930,2970,4630,2830,3440,2770:GOTO 2820
2830 '********** Null
2840 GOSUB 1400:GOSUB 3420:RETURN
2850 '********** Block
2860 X=OFST:GOSUB 4280:OFST=OFST+2:GOSUB 5400:IF T=KDECLARE THEN GOSUB 1400:GOSUB 2480
2880 GOSUB 2790:GOSUB 5500:GOSUB 5700:GOSUB 4300:OFST=X:GOSUB 3420:RETURN
2890 '********** Exit
2900 IF LPFLG=0 THEN E=14:GOTO 5020
2910 GOSUB 1400:IF T=SEMICOLON THEN W=PUJP:GOSUB 3990:GOTO 2925
2920 T0=KWHEN:GOSUB 1960:GOSUB 3100:GOSUB 4930:W=PNOT:GOSUB 3990:W=PFJP:GOSUB 3990
2925 W=XITJP:XITJP=CP:GOSUB 4030:GOSUB 3420:RETURN
2930 '********** Return
2940 GOSUB 1400
2950 IF T<>SEMICOLON THEN GOSUB 3100:TSP=TSP-1:W=PRNP ELSE W=PRET
2960 GOSUB 3990:GOSUB 3420:RETURN
2970 '********** If
2980 LUJP=0
2990 GOSUB 1400:GOSUB 3100:GOSUB 4930:W=PFJP:GOSUB 3990:X=CP:GOSUB 4280:GOSUB 4030:X=LUJP:GOSUB 4280
2995 T0=KTHEN:GOSUB 1960:GOSUB 2810:GOSUB 4300:LUJP=X
3000 IF T=KEND THEN GOSUB 3040:GOTO 3030
3010 IF T=KELSEIF THEN GOSUB 3060:GOSUB 3040:GOTO 2990
3020 T0=KELSE:GOSUB 1960:GOSUB 3060:GOSUB 3040:X=LUJP:GOSUB 4280:GOSUB 2810:GOSUB 4300:LUJP=X
3030 T0=KEND:GOSUB 1960:T0=KIF:GOSUB 1960:GOSUB 3080:GOSUB 3420:RETURN
3040 '********** Fix FJP
3050 GOSUB 4300:T1=CP:CP=X:W=T1-X-2:GOSUB 4030:CP=T1:RETURN
3060 '********** Gen UJP
3070 W=PUJP:GOSUB 3990:W=LUJP:LUJP=CP:GOSUB 4030:RETURN
3080 '********** Fixup
3090 T2=CP:WHILE LUJP<>0:CP=LUJP:GOSUB 4010:LUJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:RETURN
3100 '********** Expr
3110 GOSUB 3190:LFJP=0:PREV=0
3120 IF INSTR(LOGICALOP$,TT$)=0 THEN IF PREV THEN 3180 ELSE RETURN
3125 X=T:GOSUB 1400:IF (X=KAND AND T=KTHEN) THEN X=KAND+KTHEN ELSE IF (X=KOR AND T=KELSE) THEN X=KOR+KELSE
3130 IF PREV<>0 THEN IF PREV<>X THEN E=10:GOTO 5020
3140 IF X<>KAND AND X<>KOR THEN 3160
3145 GOSUB 4280:GOSUB 3190:IF (TY(TSP)<>TBOL) OR (TY(TSP)<>TY(TSP-1)) THEN E=9:GOTO 5020
3147 TSP=TSP-1:GOSUB 4300:PREV=X:IF X=KAND THEN W=PAND ELSE W=POR
3150 GOSUB 3990:GOTO 3120
3160 GOSUB 4280:T1=X:W=PDUP:GOSUB 3990:IF T1=KAND+KTHEN THEN W=PFJP ELSE W=PNOT:GOSUB 3990:W=PFJP
3170 GOSUB 3990:W=LFJP:LFJP=CP:GOSUB 4030:GOSUB 1400:X=LFJP:GOSUB 4280:GOSUB 3190
3174 IF (TY(TSP)<>TBOL) OR (TY(TSP)<>TY(TSP-1)) THEN E=9:GOTO 5020
3175 TSP=TSP-1:GOSUB 4300:LFJP=X:GOSUB 4300:PREV=X:IF X=KAND+KTHEN THEN W=PAND ELSE W=POR
3178 GOSUB 3990:GOTO 3120
3180 T2=CP:WHILR LFJP<>0:CP=LFJP:GOSUB 4010:LFJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:RETURN
3190 '********** Relation
3200 GOSUB 3300
3210 IF INSTR(RELOP$,TT$)=0 THEN RETURN
3220 X=T:GOSUB 4280:GOSUB 1400
3230 GOSUB 3290:IF TY(TSP)<>TINT AND TY(TSP)<>TCHR AND TY(TSP)<>TBOL THEN 3260
3235 IF TY(TSP)<>TY(TSP-1) THEN E=9:GOTO 5020 ELSE TSP=TSP-1:TY(TSP)=TBOL
3240 GOSUB 4300:IF X=LES THEN W=PLESI ELSE IF X=LEQ THEN W=PLEQI ELSE IF X=GT THEN W=PGTRI
3245 IF X=GEQ THEN W=PGEQI ELSE IF X=EQ THEN W=PEQUI ELSE IF X=NEQ THEN W=PNEQI
3250 GOSUB 3990:GOTO 3210
3260 IF TY(TSP)<>TSTR OR TY(TSP)<>TY(TSP-1) THEN E=9:GOTO 5020 ELSE TSP=TSP-1:TY(TSP)=TBOL
3270 GOSUB 4300:IF X=LES THEN W=PLESSTR ELSE IF X=LEQ THEN W=PLEQSTR ELSE IF X=GT THEN W=PGTRSTR
3275 IF X=GEQ THEN W=PGEQSTR ELSE IF X=EQ THEN W=PEQUSTR ELSE IF X=NEQ THEN W=PNEQSTR
3280 GOSUB 3990:GOTO 3210
3290 '********** SE
3300 IF INSTR(UNARYOP$,TT$) THEN X=T:GOSUB 4280:X=1:GOSUB 4280:GOSUB 1400 ELSE X=0:GOSUB 4280
3310 GOSUB 3350:GOSUB 4300:IF X=1 THEN GOSUB 4300:IF X=SUBT THEN W=PNGI:GOSUB 3990 ELSE W=PNOT:GOSUB 3990
3320 IF INSTR(ADDOP$,TT$)=0 THEN RETURN
3330 X=T:GOSUB 4280:GOSUB 1400:GOSUB 3350:GOSUB 4300:IF X=ADD THEN W=PADI ELSE W=PSBI
3340 IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:GOSUB 3990:GOTO 3320
3350 '********** Term
3360 GOSUB 3610
3370 IF INSTR(MULOP$,TT$)=0 THEN RETURN
3380 X=T:GOSUB 4280:GOSUB 1400:GOSUB 3610
3390 IF TY(TSP)<>TY(TSP-1) OR (TY(TSP)<>TINT) THEN E=9:GOTO 5020 ELSE TSP=TSP-1
3400 GOSUB 4300:IF X=MUL THEN W=PMPI ELSE IF X=DIV THEN W=PDVI ELSE W=PMODI
3410 GOSUB 3990:GOTO 3370
3420 '********** Skip
3430 IF T=SEMICOLON THEN GOSUB 1400:RETURN ELSE E=13:GOSUB 5110:RETURN
3440 '********** ID
3450 GOSUB 3890:IF KIND<>2 THEN X=TYPE:GOSUB 4280:GOSUB 3490:GOTO 3530 ELSE X=ADDR:GOSUB 4280:X=LEX:GOSUB 4280
3460 GOSUB 1400:IF T=SEMICOLON THEN 3480 ELSE T0=LP:GOSUB 1960
3470 GOSUB 3570:T0=RP:GOSUB 1960
3480 GOSUB 4100:GOSUB 3420:RETURN
3490 GOSUB 4060:GOSUB 1400
3500 IF KIND<>1 THEN RETURN ELSE X=OBJSZ:GOSUB 4280
3510 T0=LP:GOSUB 1960:GOSUB 3100:GOSUB 4960:GOSUB 4300:IF X=2 THEN W=PIND ELSE W=PIXA:GOSUB 3990:W=X
3520 GOSUB 3990:T0=RP:GOSUB 1960:RETURN
3530 T0=COLONEQ:GOSUB 1960
3540 GOSUB 3100:GOSUB 4300:IF NOT (X=TY(TSP) OR (X=TINT AND TY(TSP)=TBOL) OR (X=TBOL AND TY(TSP)=TINT)) THEN E=9:GOTO 5020
3550 IF X=TSTR THEN W=PSAS ELSE W=PSTO
3560 TSP=TSP-1:GOSUB 3990:GOSUB 3420:RETURN
3570 '********** ActualParam
3580 IF T=AT THEN GOSUB 1400:T0=ID:GOSUB 1950:GOSUB 3890:GOSUB 3490 ELSE GOSUB 3100:TSP=TSP-1
3590 IF T=COMMA THEN GOSUB 1400:GOTO 3580
3600 RETURN
3610 '********** Primary
3620 IF T=LP THEN GOSUB 1400:GOSUB 3100:T0=RP:GOSUB 1960:RETURN
3630 IF T=C THEN TSP=TSP+1:TY(TSP)=TINT:GOSUB 3640:GOSUB 1400:RETURN
3633 IF T=CH THEN TSP=TSP+1:TY(TSP)=TCHR:GOSUB 3640:GOSUB 1400:RETURN ELSE 3650
3635 '********** LD Cons
3640 IF TN=-1 THEN W=PSLDCN1:GOTO 3645 ELSE IF TN>-1 AND TN<16 THEN W=64+TN:GOTO 3645
3643 IF TN>0 AND TN<256 THEN W=PSLDC:GOSUB 3990:W=TN:GOSUB 3990:RETURN ELSE W=PLDCI:GOSUB 3990:W=TN:GOSUB 4030:RETURN
3645 GOSUB 3990:RETURN
3650 IF T<>SC THEN 3670 ELSE TSP=TSP+1:TY(TSP)=TSTR
3660 W=PLCA:GOSUB 3990:W=LEN(S$):GOSUB 3990:FOR I=1 TO LEN(S$):W=ASC(MID$(S$,I)):GOSUB 3990:NEXT I:GOSUB 1400:RETURN
3670 T0=ID:GOSUB 1950
3680 GOSUB 3890:IF KIND=0 THEN TSP=TSP+1:TY(TSP)=TYPE:TN=CONST:GOSUB 3640:GOSUB 1400:RETURN
3682 GOSUB 1400:IF T=SQUOTE THEN 3780
3685 IF KIND=4 THEN X=TYPE:GOSUB 4280:T0=LP:GOSUB 1960:GOSUB 3100:T0=RP:GOSUB 1960:GOSUB 4300:TY(TSP)=X:RETURN
3690 TSP=TSP+1:TY(TSP)=TYPE:IF TYPE=0 THEN 3800
3700 IF KIND<>1 THEN 3740 ELSE GOSUB 4060
3710 T0=LP:GOSUB 1960
3720 GOSUB 3100:IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:W=PIND:GOSUB 3990:W=PSINDO:GOSUB 3990
3730 T0=RP:GOSUB 1960:RETURN
3740 IF KIND<>3 THEN GOSUB 3760:RETURN ELSE X=ADDR:GOSUB 4280:X=LEX:GOSUB 4280
3745 IF T=LP THEN GOSUB 1400:GOSUB 3570:T0=RP:GOSUB 1960
3750 GOSUB 4100:RETURN
3760 GOSUB 3820:IF PINFO=2 THEN W=PSINDO:GOSUB 3990
3770 RETURN
3780 TSP=TSP+1:TY(TSP)=TINT:GOSUB 1400:IF T=KLAST THEN W=PLDCI:GOSUB 3990:W=CONST:GOSUB 4030:GOTO 3790
3785 IF T=KLEN THEN GOSUB 4060:W=PLDB:GOSUB 3990 ELSE E=7:GOTO 5020
3790 GOSUB 1400:RETURN
3800 IF KIND<>1 THEN 3810 ELSE GOSUB 4060:X=OBJSZ:GOSUB 4280:T0=LP:GOSUB 1960:GOSUB 3100
3805 IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:GOSUB 4300:W=PIXA:GOSUB 3990:W=X:GOSUB 3990:T0=RP:GOSUB 1960:RETURN
3810 GOSUB 4060:RETURN
3820 '********** LD Val
3830 IF LEX=1 THEN 3831 ELSE IF LEX=LL THEN 3834 ELSE W=PLOD:GOSUB 3990:W=LL-LEX:GOTO 3845
3831 '********** Global
3832 IF ADDR<256 THEN W=PSLDO:GOTO 3840 ELSE W=PLDO:GOTO 3845
3834 '********** LDL
3835 IF ADDR>=0 AND ADDR<8 THEN W=PSLDLO+ADDR:GOSUB 3990:RETURN
3836 IF ADDR>0 AND ADDR<8 THEN W=PSLDL:GOTO 3840 ELSE W=PLDL:GOTO 3845
3840 '********** B,B
3842 GOSUB 3990:W=ADDR:GOSUB 3990:RETURN
3845 '********** B,W
3847 GOSUB 3990:W=ADDR:GOSUB 4030:RETURN
3850 '********** Add ID
3860 IF LEN(S$(SSP))+17>255 THEN SSP=SSP+1
3870 S$(SSP)=ID$+CHR$(TYPE)+CHR$(KIND)+CHR$(PINFO)+MKI$(CONST)+CHR$(OBJSZ)+MKI$(ADDR)+CHR$(LL)+S$(SSP)
3880 RETURN
3890 '********** Lookup ID
3900 LOC1=SSP
3910 LOC2=INSTR(S$(LOC1),ID$):IF LOC2 THEN 3920 ELSE LOC1=LOC1-1:IF LOC1 THEN 3910 ELSE E=2::GOTO 5020
3920 T9=VARPTR(S$(LOC1)):POKE VLOC,PEEK(T9+1):POKE VLOC1,PEEK(T9+2):T9=V+LOC2-1
3930 TYPE=PEEK(T9+8):KIND=PEEK(T9+9):PINFO=PEEK(T9+10):POKE VLOC,PEEK(T9+11):POKE VLOC1,PEEK(T9+12):CONST=V
3960 OBJSZ=PEEK(T9+13):LEX=PEEK(T9+16):POKE VLOC,PEEK(T9+14):POKE VLOC1,PEEK(T9+15):ADDR=V:RETURN
3990 '********** GenByte
4000 GOSUB 4140:FIELD #1,R2 AS D$,1 AS D$:LSET D$=CHR$(W):CP=CP+1:RETURN
4010 '********** read wrd
4020 T1=CP:GOSUB 4260:POKE VLOC,W:CP=CP+1:GOSUB 4260:POKE VLOC1,W:W=V:CP=T1:RETURN
4030 '********** GenWord W
4040 GOSUB 4140:IF R2<127 THEN FIELD #1,R2 AS D$,2 AS D$:LSET D$=MKI$(W):CP=CP+2:RETURN
4050 V=W:W=PEEK(VLOC):GOSUB 3990:W=PEEK(VLOC1):GOSUB 3990:RETURN
4060 '********** LD Adr
4070 IF PINFO=2 THEN GOSUB 3820 RETURN
4080 IF LEX=1 THEN 4085 ELSE IF LEX=LL THEN 4090 ELSE W=PLDA:GOSUB 3990:W=LL-LEX:GOTO 3845
4085 '********** GL Adr
4087 IF ADDR<256 THEN W=PSLAO:GOTO 3840 ELSE W=PLAO:GOTO 3845
4090 '********** LDL Adr
4095 IF ADDR>=0 AND ADDR<256 THEN W=PSLLA:GOTO 3840 ELSE W=PLLA:GOTO 3845
4100 '********** Call Proc
4110 GOSUB 4300:LEX=X:GOSUB 4300:ADDR=X
4120 IF LEX=0 THEN W=PCSP ELSE IF LEX=2 THEN W=PCGP ELSE IF LEX=LL+1 THEN W=PCLP ELSE W=PCIP
4130 GOSUB 3990:W=ADDR:GOSUB 3990:RETURN
4140 '********** GetBuf
4150 T9=CP+CB:R1=T9\128+1:R2=T9 AND 127:IF R1=R0 THEN RETURN
4160 FIELD #1,128 AS D$:J=1
4170 IF B(J)=R0 OR B(J)=0 THEN 4190 ELSE J=J+1:IF J<=MB THEN 4170
4180 LSET B$(0)=D$:J=INT(RND*MB)+1:LSET D$=B$(J):PUT #1,B(J):LSET B$(J)=B$(0):B(J)=R0:GOTO 4200
4190 LSET B$(J)=D$:B(J)=R0
4200 J=1
4210 IF B(J)=R1 THEN 4240 ELSE J=J+1:IF J<=MB THEN 4210
4220 GET #1,R1:R0=R1:IF R1>M0 THEN M0=R1
4230 RETURN
4240 LSET D$=B$(J):R0=R1:IF R1>M0 THEN M0=R1
4250 RETURN
4260 '********** ReadByte
4270 GOSUB 4140:FIELD #1,R2 AS D$,1 AS D$:W=ASC(D$):RETURN
4280 '********** Push
4290 S(SP)=X:SP=SP+1:RETURN
4300 '********** Pop
4310 SP=SP-1:X=S(SP):RETURN
4320 '********** Loop
4330 IF T<>KWHILE THEN 4370
4340 GOSUB 1400:X=CP:GOSUB 4280:GOSUB 3100:GOSUB 4930
4350 W=PFJP:GOSUB 3990:X=CP:GOSUB 4280:W=0:GOSUB 4030:GOSUB 4590:GOSUB 4300
4360 T1=CP:CP=X:W=T1-X+1:GOSUB 4030:CP=T1:W=PUJP:GOSUB 3990:GOSUB 4300:W=X-CP-2:GOSUB 4030:GOSUB 4620:RETURN
4370 IF T<>KFOR THEN 4580
4380 GOSUB 1400:T0=ID:GOSUB 1950:X=OFST:GOSUB 4280:GOSUB 5400
4390 ADDR=OFST:TYPE=1:KIND=5:PINFO=0:GOSUB 3850
4400 GOSUB 1400:T0=KIN:GOSUB 1960
4410 IF T=KREVERSE THEN X=-1:GOSUB 1400 ELSE X=1
4420 GOSUB 4280:W=PLLA:GOSUB 3990:W=OFST:GOSUB 4030
4430 GOSUB 3290:GOSUB 4960:W=PSTO:GOSUB 3990
4440 X=CP:GOSUB 4280:W=PLDL:GOSUB 3990:W=OFST:GOSUB 4030
4450 T0=DOTDOT:GOSUB 1960:GOSUB 3290:GOSUB 4960
4460 GOSUB 4300:T1=X:GOSUB 4300:IF X<0 THEN W=PGEQI ELSE W=PLEQI
4470 GOSUB 3990:W=PFJP:GOSUB 3990:GOSUB 4280:X=T1:GOSUB 4280
4480 X=CP:GOSUB 4280:W=0:GOSUB 4030:X=OFST:GOSUB 4280:OFST=OFST+2:GOSUB 4990
4490 GOSUB 4590:GOSUB 4300:T3=X:GOSUB 4300:T1=X:GOSUB 4300:T2=X:GOSUB 4300:IF X<0 THEN W=PDECL ELSE W=PINCL
4500 GOSUB 3990:W=T3:GOSUB 4030
4520 W=PUJP:GOSUB 3990
4530 W=T2-CP-2:GOSUB 4030:T2=CP:CP=T1:W=T2-T1-2:GOSUB 4030:CP=T2
4550 GOSUB 5500:GOSUB 5700
4560 GOSUB 4300:OFST=X
4570 GOSUB 4620:RETURN
4580 X=CP:GOSUB 4280:GOSUB 4590:W=PUJP:GOSUB 3990:GOSUB 4300:W=X-CP-2:GOSUB 4030:GOSUB 4620:RETURN
4590 T0=KLOOP:GOSUB 1960:X=XITJP:GOSUB 4280:XITJP=0:X=LPFLG:GOSUB 4280:LPFLG=-1:GOSUB 2810
4600 T0=KEND:GOSUB 1960
4610 T0=KLOOP:GOSUB 1960:GOSUB 4300:T5=X:GOSUB 4300:T6=X:GOSUB 3420:RETURN
4620 T2=CP:WHILE XITJP<>0:CP=XITJP:GOSUB 4010:XITJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:LPFLG=T5:XITJP=T6:RETURN
4630 '********** Case
4640 GOSUB 1400:GOSUB 3100:IF TY(TSP)<>TINT AND TY(TSP)<>TCHR THEN E=9:GOTO 5020
4645 TSP=TSP-1:W=PXJP:GOSUB 3990:X=CP:GOSUB 4280:GOSUB 4030:GOSUB 4030:GOSUB 4030:CASES=0:LUJP=0:T0=KIS:GOSUB 1960
4650 T0=KWHEN:GOSUB 1960:IF T=KOTHERS THEN 4810 ELSE T1=0
4660 IF T=ID THEN GOSUB 3890:TN=CONST:IF TYPE=1 OR TYPE=2 THEN T=C
4670 IF T<>CH AND T<>C THEN E=5:GOTO 5020 ELSE X=TN:GOSUB 4280:T1=T1+1:GOSUB 1400:IF T=BAR THEN GOSUB 1400:GOTO 4660
4680 GOSUB 4780
4690 IF T=KWHEN THEN 4650 ELSE X=0:GOSUB 4280:GOSUB 4280:X=1:GOSUB 4280:CASES=CASES+1
4700 T0=KEND:GOSUB 1960:T0=KCASE:GOSUB 1960
4710 T1=SP-4:T3=32767:T4=-32767:FOR I=1 TO CASES-1:T2=S(T1):T1=T1-2:FOR J=1 TO T2:IF S(T1) 4715 IF S(T1)>T4 THEN T4=S(T1)
4720 T1=T1-1:NEXT J:NEXT I:W=PUJP:GOSUB 3990:T5=CP:GOSUB 4300:GOSUB 4300:T1=X:GOSUB 4300
4725 IF X=-1 THEN W=T1-CP-2:GOSUB 4030 ELSE W=LUJP:LUJP=CP:GOSUB 4030
4730 FOR I=T3 TO T4:W=T5-CP-3:GOSUB 4030:NEXT I '*** build table
4740 T7=CP:FOR I=1 TO CASES-1:GOSUB 4300:T2=X:GOSUB 4300:T6=X:FOR T8=1 TO T2:GOSUB 4300
4745 CP=T5+(X-T3)*2+2:W=T6-CP-2:GOSUB 4030:NEXT T8:NEXT I:CP=T7
4750 GOSUB 4300:T2=CP:CP=X:W=T3:GOSUB 4030:W=T4:GOSUB 4030:W=T5-CP-2:GOSUB 4030
4760 WHILE LUJP<>0:CP=LUJP:GOSUB 4010:LUJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2
4770 GOSUB 3420:RETURN
4780 T0=EQGT:GOSUB 1960:X=CP:GOSUB 4280:X=T1:GOSUB 4280:X=LUJP:GOSUB 4280:CASES=CASES+1:X=CASES:GOSUB 4280:GOSUB 2810
4790 W=PUJP:GOSUB 3990:GOSUB 4300:CASES=X:GOSUB 4300:LUJP=X
4800 W=LUJP:LUJP=CP:GOSUB 4030:RETURN
4810 '********** Others
4820 GOSUB 1400:X=-1:GOSUB 4280:T1=1:GOSUB 4780:GOTO 4700
4830 '********** Pragma
4840 GOSUB 1400:IF S$<>"LIST" THEN 4850
4845 GOSUB 4880:IF T$="ON" THEN PLST=-1:LPRINT LP$;:RETURN ELSE IF T$="OFF" THEN PLST=0:RETURN ELSE E=6:GOTO 5020
4850 IF S$="CRT" THEN GOSUB 4880:IF T$="ON" THEN CLST=-1:RETURN ELSE CLST=0:RETURN
4860 IF S$<>"INCLUDE" THEN RETURN ELSE GOSUB 1400:T0=LP:GOSUB 1960
4870 IF T<>SC THEN E=9:GOTO 5020 ELSE GOSUB 1230:GOSUB 1400:T0=RP:GOSUB 1960:RETURN
4880 GOSUB 1400:T0=LP:GOSUB 1960:T$=S$:GOSUB 1400:T0=RP:GOSUB 1960:RETURN
4910 '********** WriteProc
4920 T2=CP:T3=CB:CB=0:CP=(ADDR-1)*7+128:W=C1-1920:GOSUB 4030:W=L1:GOSUB 4030:W=P1:GOSUB 4030:W=LL:GOSUB 3990:CP=T2:CB=T3:RETURN
4930 '********** Check Bool
4940 IF TY(TSP)<>TBOL THEN E=9:GOTO 5020
4950 TSP=TSP-1:RETURN
4960 '********** Check Int
4970 IF TY(TSP)<>TINT THEN E=9:GOTO 5020
4980 TSP=TSP-1:RETURN
4990 '********** Max Offst
5000 IF OFST>MXOF THEN MXOF=OFST
5010 RETURN
5020 GOSUB 5100:STOP
5100 PRINT:PRINT"*** Error";E;" in line";LN:PRINT BUF$:PRINT TAB(B-1);"*":RETURN
5110 PRINT:PRINT T0;" expected":GOSUB 5100:RETURN
5200 '********** Proc DEF
5210 LL=LL+1:X=CPROC:GOSUB 4280:X=OFST:GOSUB 4280:X=MXOF:GOSUB 4280:T0=ID:GOSUB 1950
5220 GOSUB 5400:RETURN
5300 '********** Proc END DEF
5310 W=PEOP:GOSUB 3990:GOSUB 4300:P1=X:GOSUB 4300:ADDR=X:CPROC=X:L1=MXOF:C1=GC:GOSUB 4910:GC=GC+CP
5320 LL=LL-1:GOSUB 5500:GOSUB 5600
5330 GOSUB 4300:MXOF=X:GOSUB 4300:OFST=X:GOSUB 4300:CPROC=X:RETURN
5400 '********** Push Syms
5410 X=LEN(S$(SSP)):IF X=255 THEN SSP=SSP+1:X=0
5420 GOSUB 4280:X=SSP:GOSUB 4280:RETURN
5500 '********** Pop Syms
5510 GOSUB 4300:FOR I=X+1 TO SSP:S$(I)="":NEXT I:SSP=X:GOSUB 4300:LOC2=X:RETURN
5520 RETURN
5600 S$(SSP)=RIGHT$(S$(SSP),LOC2+17):RETURN
5700 S$(SSP)=RIGHT$(S$(SSP),LOC2):RETURN
32767 KEY ON: END