home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / lambda / soundpot / f / nbasic.lbr / NBASIC.BZS / NBASIC.BAS
Encoding:
BASIC Source File  |  1993-10-26  |  9.8 KB  |  289 lines
  1. 1000 '    BASIC PREPROCESSOR  VERSION 2.0, 26 Jan 1984
  2. 1010 '    COPYRIGHT  (c) 1983 by  N.C.Shammas  with  permission 
  3. 1020 '    granted for non-comercial use and distribution only.
  4. 1030 '    Copied from Dr. Dobb's Journal, January 1984 with 
  5. 1040 '  modifications by m. w. hulse, 26 Jan 84.
  6. 1050 OPTION BASE 1
  7. 1060 DEFINT A-Z:LN$="":FF$=CHR$(12)
  8. 1070 DIM L$(500),LSTK(50),LBL$(50),NM$(2,30),VAR(2),B$(2),C$(2)
  9. 1080 GOSUB 11180'CLS
  10. 1090 PRINT:PRINT:PRINT
  11. 1100 DATA "MBASIC  Preprocessor  V1.1A","COPYRIGHT (c) 1983 by N. C. Shammas"
  12. 1110 FOR I=1 TO 2:READ L$(I) : NEXT I
  13. 1120 FOR I=1 TO 2:GOSUB 11100:PRINT K$;L$(I):PRINT:PRINT:NEXT I
  14. 1130 INPUT "Enter Filename ";F$ : PRINT : PRINT
  15. 1140 PTR=INSTR(F$,".")
  16. 1150 IF PTR<>0 AND MID$(F$,PTR+1,3)="BAS" THEN FOUT$=MID$(F$,1,PTR)+"BAZ"
  17.  
  18. :GOTO 1170
  19. 1160 IF PTR=0 THEN FOUT$=F$+".BAS" ELSE FOUT$=LEFT$(F$,PTR)+"BAS"
  20. 1170 OPEN "I",1,F$
  21. 1180 PRINT "Errors found this pass will be displayed. They can also be listed."
  22. 1190 PRINT "Do you want an error printout (Y/N)? ";:PNT$=INPUT$(1):PRINT PNT$:PRINT
  23. 1200 IF PNT$="Y" THEN PRINT:PRINT "Be sure your printer is on then press any key."
  24.  
  25. :I$=INPUT$(1):
  26. 1210 L$(500)="Relax, I'm loading your program and processing it.":I=500
  27. 1220 GOSUB 11180:GOSUB 11100:PRINT K$;L$(500):FOR I= 1 TO 11:PRINT:NEXT'CLS
  28. 1230 L=0
  29. 1240 WHILE EOF(1)<>-1
  30. 1250    L=L+1
  31. 1260    LINE INPUT #1,L$(L)
  32. 1270 WEND
  33. 1280 CLOSE #1
  34. 2000 N=L
  35. 2010 FOR I=1 TO N
  36. 2020    P=INSTR(L$(I),"REM")
  37. 2030    IF P <> 0 THEN L$(I)=MID$(L$(I),1,P-1)+"'"+MID$(L$(I),P+3)
  38. 2040 NEXT
  39. 3000 '->REPEAT . . . UNTIL(test)
  40. 3010 CNT=0
  41. 3020 FOR I=1 TO N
  42. 3030    PTR=INSTR(L$(I),"REPEAT")
  43. 3040    IF PTR=0 GOTO 3110
  44. 3050    P=INSTR(L$(I),"'")
  45. 3060    IF (P<PTR) AND (P>0) GOTO 3110
  46. 3070    CNT=CNT+1
  47. 3080    A$=STR$(CNT)
  48. 3090    I$="I"+RIGHT$(A$,LEN(A$)-1)
  49. 3100    L$(I)=MID$(L$(I),1,PTR-1)+"FOR "+I$+"=0 TO 1"+":' "+MID$(L$(I),PTR)
  50. 3110    PTR=INSTR(L$(I),"UNTIL")
  51. 3120    IF PTR=0 GOTO 3210
  52. 3130    P=INSTR(L$(I),"'")
  53. 3140    IF (P<PTR) AND (P>0) GOTO 3210
  54. 3150    IF CNT<=0 THEN LN$= "UNTIL error in line "+STR$(VAL(L$(I)))
  55.  
  56. :GOSUB 11130:E=1
  57. 3160    A$=STR$(CNT)
  58. 3170    I$="I"+RIGHT$(A$,LEN(A$)-1)
  59. 3180    A$=L$(I)
  60. 3190    L$(I)=MID$(A$,1,PTR-2)+" "+I$+"=-1*"+MID$(A$,PTR+6)+":NEXT "+I$+"' "+MID$(A$,PTR)
  61. 3200    CNT=CNT-1
  62. 3210 NEXT I
  63. 3220 IF CNT<>0 THEN LN$="REPEAT error : More REPEATs than UNTILs."
  64.  
  65. :GOSUB 11130:E=1
  66. 4000 '->Label conventions
  67. 4010 STK=0
  68. 5000 FOR I=1 TO N
  69. 5010    PTR=INSTR(L$(I),"[LBL")
  70. 5020    IF PTR=0 GOTO 5070
  71. 5030    A$=L$(I):STK=STK+1:PTR2=INSTR(A$,"]")
  72. 5040    LSTK(STK)=VAL(A$)
  73. 5050    LBL$(STK)=MID$(A$,PTR+5,PTR2-PTR-5)
  74. 5060    L$(I)=MID$(A$,1,PTR-2)+MID$(A$,PTR2+1)
  75. 5070 NEXT I
  76. 5080 IF STK=0 GOTO 7140
  77. 6000 FOR I=1 TO N
  78. 6010    P=INSTR(L$(I),"'")
  79. 6020    A$=L$(I)
  80. 6030    PTR=INSTR(A$,"THEN [")
  81. 6040    IF PTR<>0 GOTO 6130
  82. 6050    PTR=INSTR(A$,"ELSE [")
  83. 6060    IF PTR<>0 GOTO 6130
  84. 6070    PTR=INSTR(A$,"GOTO [")
  85. 6080    IF PTR<>0 GOTO 6130
  86. 6090    PTR=INSTR(A$,"GOSUB [")
  87. 6100    IF PTR<>0 GOTO 6120
  88. 6110 NEXT I:GOTO 7000
  89. 6120 J=7:GOTO 6140
  90. 6130 J=6
  91. 6140 IF (P<PTR) AND (P>0) GOTO 6110 ELSE PTR2=INSTR(A$,"]")
  92. 6150 A$=MID$(A$,PTR+J,PTR2-J-PTR):FLAG=0
  93. 6160 FOR K=1 TO STK
  94. 6170    IF A$=LBL$(K) THEN FLAG=K:K=STK
  95. 6180 NEXT K
  96. 6190 IF FLAG=0 THEN LN$="Error in line "+STR$(VAL(L$(I)))+
  97.  
  98. ". Label not found.":GOSUB 11130:E=1:GOTO 7000
  99. 6200 L$(I)=MID$(L$(I),1,PTR+J-3)+STR$(LSTK(FLAG))+MID$(L$(I),PTR2+1)
  100. 6210 GOTO 6020
  101. 7000 '->CASE OF(exp)
  102. 7010 '    !(exp1) DO
  103. 7020 '
  104. 7030 '    statements
  105. 7040 '
  106. 7050 '    !(exp2) DO
  107. 7060 '
  108. 7070 '    statements
  109. 7080 '
  110. 7090 '    !ELSE      <-- Optional
  111. 7100 '
  112. 7110 '    statements 
  113. 7120 '
  114. 7130 '    ENDCASE
  115. 7140 DEF FNL$(A$)=RIGHT$(STR$(VAL(A$)),LEN(STR$(VAL(A$)))-1)
  116. 7150    IF LEL>0 THEN LDO(NRDO)=LEL ELSE NRDO=NRDO-1
  117. 7160 FOR I=1 TO N'Look for 'CASE OF'
  118. 7170    EL=0:LDO=0:LEL=0:NRDO=1:CE1=0:CE2=0:CE3=0:CE4=0:CE5=0
  119. 7180    PTR=INSTR(L$(I),"CASE OF")
  120. 7190    IF PTR=0 GOTO 7630
  121. 7200    A$=L$(I)
  122. 7210    P=INSTR(A$,"'")
  123. 7220    PTR=INSTR(A$,"(")
  124. 7230    IF ((P<PTR) AND (P>0)) OR PTR=0 THEN CE1=1:GOTO 7260
  125. 7240    I$=MID$(A$,PTR)
  126. 7250    L$(I)=FNL$(A$)+" I0="+I$
  127. 7260    IF CE1=1 THEN LN$=
  128.  
  129. "Error in 'CASE OF'. No (expression) found in line "+FNL$(A$):GOSUB 11130
  130.  
  131. :E=1
  132. 7270    LCO=J' LCO is line number of 'CASE OF' 
  133. 7280    LEC=N:CO=CO+1:LDO=0
  134. 7290    FOR K=LCO TO LEC'Look for 'ENDCASE' 
  135. 7300        PTR=INSTR(L$(K),"ENDCASE")
  136. 7310        IF PTR=0 THEN IF K<=LEC GOTO 7350 ELSE CE5=1:GOTO 7340
  137. 7320        LEC=K:K=N:EC=EC+1' LECis line # of ENDCASE
  138. 7330        L$(LEC)=FNL$(L$(LEC))+" ' Endcase"
  139. 7340        IF CE5=1 THEN LN$="Error. No 'ENDCASE' for the 'CASE OF' in line "+FNL$(L$(LEC)):GOSUB 11130:E=1
  140. 7350    NEXT K
  141. 7360    FOR L=LCO TO LEC-1' Look for 'ELSEs'
  142. 7370        PEX=INSTR(L$(L),"!("):IF PEX>0 THEN LDO=L
  143. 7380        PEL=INSTR(L$(L),"!ELSE"):IF PEL>0 THEN LEL=L
  144. 7390        P=INSTR(L$(L),"'")
  145. 7400        IF PEL=0 OR PEL>P GOTO 7450
  146. 7410        IF LDO=0 THEN CE4=0:GOTO 7430
  147. 7420        L$(L)=FNL$(L$(L))+" ' Else condition":EL=EL+1
  148. 7430        IF CE4=1 OR EL>1 THEN LN$="Error. No '!() DO' before 'ELSE'/'ENDCASE' or too many 'ELSEs'. See line "+FNL$(L$(L)):GOSUB 11130:E=1
  149. 7440        IF EL=1 THEN LEL1=LEL ELSE IF LEL=0 THEN LEL1=LEC
  150. 7450    NEXT L 
  151. 7460    FOR M=LCO TO LEL-1' Look for 'DOs'
  152. 7470        PEX=INSTR(L$(M),"!(")
  153. 7480        P=INSTR(L$(M),"'")
  154. 7490        IF PEX=0 OR ((PEX>P) AND (P>0)) GOTO 7510 ELSE LDO(NRDO)=M:PEX(NRDO)=PEX
  155. 7500        NRDO=NRDO+1
  156. 7510    NEXT M
  157. 7520    FOR M=NRDO TO 1 STEP-1'Process 'DOs' from highest line # down 
  158. 7530        IF M=NRDO THEN LDO(M)=LEL:IF LEL=0 GOTO 7620 ELSE 
  159.  
  160. LB4=LEL-1:GOTO 7580
  161. 7540        A$=L$(LDO(M)):PDO=INSTR(A$,"DO")
  162. 7550        IF PDO=0 THEN LN$="Error. No 'DO' in line "+FNL$(A$):GOSUB 11130:E=1:GOTO 7620 
  163. 7560        L$(LDO(M))=FNL$(A$)+" IF I0<>"+MID$(A$,PEX(M)+1,
  164.  
  165. PDO-2-PEX(M)+1)+"GOTO "+FNL$(L$(LDO(M+1)))+MID$(A$,PDO+2)
  166. 7570        LB4=LDO(M)-1'Put 'GOTO endcase' on line before 'DOs' except 1st.
  167. 7580        A$=L$(LB4)
  168. 7590        P=INSTR(A$,"'"):IF P=0 THEN P=LEN(A$)+1
  169. 7600        IF P>LEN(FNL$(A$))+2 THEN I$=":" ELSE I$=""
  170. 7610        IF M>1 THEN L$(LB4)=LEFT$(A$,P-1)+I$+"GOTO "+FNL$(L$(LEC))
  171.  
  172. +MID$(A$,P)
  173. 7620    NEXT M
  174. 7630 NEXT I
  175. 7640 IF CO<>EC THEN LN$="Number of CASE OF and ENDCASE statements do not match.":GOSUB 11130
  176. 8000 '  -->1505 CALL "matrix" TAKES A;B;C GIVES E;F 
  177. 8010 '
  178. 8020 '  statements
  179. 8030 '
  180. 8040 '  9000 SUB "matrix" TAKES X;Y;Z GIVES L;M
  181. 8050 '
  182. 8060 '  subroutine body
  183. 8070 '
  184. 8080 '  RETURN
  185. 8090 '
  186. 8100 '  --> The call on line 1505 will become:
  187. 8110 '
  188. 8120 '  1505 X=A : Y=B :  Z=C : GOSUB 9000 : E=L : F=M
  189. 8130 '
  190. 8140 B$(1)="{":B$(2)="[":C$(1)="}":C$(2)="]"
  191. 8150 FOR I = 1 TO N
  192. 8160    P=INSTR(L$(I),"GOSUB")
  193. 8170    IF P<>0 GOTO 9260
  194. 8180    P=INSTR(L$(I),"SUB")
  195. 8190    P1=INSTR(L$(I),"'")
  196. 8200    IF (P=0) OR ((P1<P) AND (P1>0)) GOTO 9260
  197. 8210    A$=L$(I)
  198. 8220    SBLN=VAL(A$)
  199. 8230    P1=INSTR(A$,CHR$(34))
  200. 8240    P2=INSTR(P1+1,A$,CHR$(34))
  201. 8250    IF (P1*P2)=0 THEN LN$="Error in subroutine name @ line "
  202.  
  203. +STR$(SBLN)+".":GOSUB 11130:E=1
  204. 8260    SBNM$=MID$(A$,P1+1,P2-P1-1)
  205. 8270    L$(I)=FNL$(A$)+" '"+MID$(A$,LEN(FNL$(A$))+1)
  206. 8280    VAR(1)=0:VAR(2)=0
  207. 8290    GOSUB 11020:'Insert braces and brackets.
  208. 8300    FOR J=1 TO 2
  209. 8310        P=INSTR(A$,B$(J))
  210. 8320        IF P=0 GOTO 8460 
  211. 8330        P1=P
  212. 8340        P2=INSTR(A$,C$(J))
  213. 8350        P=INSTR(P1+1,A$,";")
  214. 8360        PTR=INSTR(A$,"["):IF PTR=0 THEN PTR=LEN(A$)
  215. 8370        IF (P=0) OR ((P>PTR) AND (J=1)) GOTO 8430
  216. 8380        VAR(J)=VAR(J)+1
  217. 8390        K=VAR(J)
  218. 8400        NM$(J,K)=MID$(A$,P1+1,P-P1-1) 
  219. 8410        P1=P
  220. 8420        GOTO 8350
  221. 8430        VAR(J)=VAR(J)+1
  222. 8440        K=VAR(J)
  223. 8450        NM$(J,K)=MID$(A$,P1+1,P2-P1-1)
  224. 8460    NEXT J
  225. 9000    FOR J=1 TO N' Find "CALLs' using 'SUBs'as targets
  226. 9010        P=INSTR(L$(J),"CALL")    
  227. 9020        IF P=0 GOTO 9250
  228. 9030        A$=L$(J)
  229. 9040        P1=INSTR(A$,CHR$(34))
  230. 9050        P2=INSTR(P1+1,A$,CHR$(34))
  231. 9060        IF (P1*P2)=0 GOTO 9250
  232. 9070        IF SBNM$<>MID$(A$,P1+1,P2-P1-1) GOTO 9250
  233. 9080        GOSUB 11020: 'Insert braces and brackets as markers
  234. 9090        L$=FNL$(A$)
  235. 9100        FOR L=1 TO 2
  236. 9110            IF VAR(L)=0 GOTO 9220
  237. 9120            P1=INSTR(A$,B$(L))
  238. 9130            P2=INSTR(A$,C$(L))
  239. 9140            FOR K=0 TO VAR(L)
  240. 9150                IF K=0 THEN K=K+1
  241. 9160                IF K=VAR(L) THEN P=P2 ELSE P=
  242.  
  243. INSTR(P1+1,A$,";")
  244. 9170            IF P=0 THEN LN$=
  245.  
  246. "Error. Semicolon missing in line "+FNL$(A$)+".":GOSUB 11130:E=1
  247. 9180                IF L=1 THEN L$=L$+" "+NM$(L,K)+"="+
  248.  
  249. MID$(A$,P1+1,P-P1-1)+":"
  250. 9190                IF L=2 THEN L$=L$+" "+MID$(A$,P1+1,P-P1-1)+
  251.  
  252. "="+NM$(L,K)+":"
  253. 9200                P1=P
  254. 9210            NEXT K
  255. 9220            IF L=1 THEN L$=L$+" GOSUB"+STR$(SBLN)+":"
  256. 9230        NEXT L
  257. 9240        L$(J)=L$
  258. 9250 NEXT J
  259. 9260 NEXT I
  260. 10000 I=500:PRINT:PRINT:IF E>0 THEN L$(I)="Unsuccessful run.":GOSUB 11100:PRINT K$;L$(500);CHR$(7):GOTO 11200'End 
  261. 10010 OPEN "O",1,FOUT$
  262. 10020 PRINT CHR$(7):GOSUB 11180:L$(I)= "Conversion is successful!"
  263.  
  264. :GOSUB 11100:PRINT K$;L$(I):FOR I=1 TO 8:PRINT:NEXT
  265. 10030 PRINT:PRINT:PRINT "Do you want a printout of the MBASIC source (Y/N)? ";
  266.  
  267. :PRINT CHR$(7);:PNT$=INPUT$(1)
  268. 10040 PRINT:IF PNT$="Y" THEN PRINT "Prepare printer and press any key.":PRINT
  269.  
  270. :A$=INPUT$(1)
  271. 10050 GOSUB 11180'CLS 
  272. 10060 J=0
  273. 10070 FOR I=1 TO N
  274. 10080    LN$=L$(I):GOSUB 11150
  275. 10090    PRINT #1,LN$
  276. 10100 NEXT I
  277. 10110 CLOSE#1
  278. 10120 PRINT "[Press any key when done.]":I$=INPUT$(1)
  279. 10130 FOR I=1 TO 79:PRINT "_";:NEXT I:PRINT 
  280. 10140 PRINT:PRINT "The above listing is residing in file `;FOUT$;"'."
  281. 10150 GOTO 11200'End
  282. 11000 '--------------------------SUBROUTINES---------------------------
  283. 11010 '->Insert braces and brackets.
  284. 11020    P1=INSTR(A$,"TAKES"):P2=INSTR(A$,"GIVES")
  285. 11030    IF P1=0 GOTO 11060
  286. 11040    MID$(A$,P1+5,1)="{" 
  287. 11050    IF P2=0 THEN A$=A$+"}" ELSE MID$(A$,P2-1,1)="}"
  288. 11060    IF P2=0 GOTO 11090
  289. 11070    MID$(A$,P2+5,1)="["
  290. 11080    A$=A$+"]"
  291. 11090    RETURN
  292. 11100 '->Center text
  293. 11110    K$=SPACE$(40-LEN(L$(I))/2)
  294. 11120    RETURN
  295. 11130 '->Display or display and list lines $ errors
  296. 11140    IF J9=0 THEN PRINT "Error List:":IF PNT$="Y" THEN LPRINT "Error List:"
  297. 11150    PRINT LN$:IF PNT$="Y" THEN LPRINT LN$:J9=J9+1:
  298.  
  299. IF J9=61 THEN PRINT FF$:J9=0
  300. 11160    IF PNT$<>"Y" THEN J9=J9+1:IF J9=22 THEN PRINT "[More]":I$=INPUT$(1)
  301.  
  302. :J9=0 
  303. 11170    RETURN
  304. 11180 '->Generic clear screen
  305. 11190    FOR LNS=1 TO 24:PRINT:NEXT:RETURN
  306. 11200 '->End routine
  307. 11210    IF PNT$="Y" THEN LPRINT FF$
  308. 11220    END
  309. ric clear