home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / crosscom / bas2fort / bas2fort.bas
Encoding:
BASIC Source File  |  1991-05-15  |  21.9 KB  |  553 lines
  1. 1000 DEFINT A-Z
  2. 1050 DEF FNUM (Q$) = ASC(LEFT$(Q$, 1)) > 47 AND ASC(LEFT$(Q$, 1)) < 58
  3. 1100 DEF FNTOGGLE (X$, Y$, FLG) = FLG XOR X$ = Y$
  4. 1150 DEF FNREP$ (X$, Y$, A, B) = LEFT$(X$, A - 1) + Y$ + MID$(X$, B)
  5. 1200 DEF FNINS$ (X$, Y$, A, B) = LEFT$(X$, A) + Y$ + MID$(X$, B)
  6. 1250 TST$(1) = "$"
  7. 1260 TST$(2) = "%"
  8. 1270 TST$(3) = "#"
  9. 1280 TST$(4) = "!"
  10. 1300 DIM REFLIN!(500), REFER!(500), VALPH$(200), VINT$(200), VDBL$(200), VSNGL$(200)
  11. 1350 DIM POINT4!(200, 2), STACK4(25), CSTK$(25), TOKLST$(20), PTLST(20), AA(20), BB(20)
  12. 1400 DATA " ","(",")","^","*","-","+","=","<",">"
  13. 1450 RESTORE 1400
  14. 1460 FOR I = 1 TO 10
  15. 1470   READ DELIM$(I)
  16. 1480 NEXT
  17. 1500 QUOTE$ = CHR$(34)
  18. 1510 BLANK$ = CHR$(32)
  19. 1520 COLON$ = ":"
  20. 1550 NEXTLIN! = 0
  21. 1600 NN = 71
  22. 1601 KEY OFF
  23. 1650 IREF = 0
  24. 1660 JREF = 0
  25. 1670 IINT = 0
  26. 1680 IALPH = 0
  27. 1690 IDBL = 0
  28. 1695 ISNGL = 0
  29. 1700 TRUE = -1
  30. 1710 FALSE = 0
  31. 1720 PT4 = 0
  32. 1750 IMPFLG = FALSE
  33. 1760 XORFLG = FALSE
  34. 1770 EQVFLG = FALSE
  35. 1800 REM
  36. 1850 DIM KFOR$(80), PNTR(1150)
  37. 1900 DIM KBAS$(80), HASH(80), TWOS(6)
  38. 1950 DIM BUF$(10), CP(10)
  39. 2000 DATA ABS,AND,ASC,ATN,BEEP,CDBL,CHR$,CINT,CLOSE,CLS,COMMON
  40. 2050 DATA COS,CSNG,DATA,DEF,DEFSNG,DEFDBL,DEFINT,DEFSTR,DIM,ELSE,END
  41. 2100 DATA EOF,EQV,EXP,FIX,FN,FOR,GOSUB,GOTO,IF,IMP,INKEY$,INPUT
  42. 2150 DATA INPUT#,INPUT$,INT,LET,LOG,LPRINT,MOD,NEXT,NOT,ON,OPEN,OPTION
  43. 2200 DATA OR,PRINT,PRINT#,READ,REM,RESTORE,RETURN,SGN,SIN,SPACE$
  44. 2250 DATA SPC(,SQR,STEP,STOP,SWAP,TAN,THEN,then,TO,USING,WEND,WHILE,WRITE
  45. 2300 DATA WRITE#,XOR
  46. 2305 REM
  47. 2310 REM *---------------------------------------------------------------*
  48. 2350 REM unhandled:data,gosub,inkey$,input$,option,read,restore,space$,spc(
  49. 2400 REM
  50. 2450 DATA 1,2,4,8,16,32
  51. 2500 REM
  52. 2550 REM
  53. 2600 DATA ABS,.AND.,ICHAR,ATAN,*,DBLE,CHAR,ANINT,CLOSE(,*,COMMON
  54. 2650 DATA COS,SNGL,DATA,*,IMPLICIT REAL (,IMPLICIT REAL*8 ( ,IMPLICIT INTEGER ( ,CHARACTER*127,DIMENSION,ELSE,END
  55. 2700 DATA EOF,*,EXP,IFIX,*,DO,CALL,GOTO,IF(,*,*,"READ(*,*)"
  56. 2750 DATA "READ(*,*)",READ,INT,*,ALOG,"WRITE(6,*)",MOD,CONTINUE,.NOT.,ON,OPEN,*
  57. 2800 DATA .OR.,"WRITE(*,*)",WRITE,*,C,*,RETURN,SIGN,SIN,*
  58. 2850 DATA *,SQRT,",",STOP,*,TAN,],] THEN,",",",",*,CONTINUE,"WRITE(*,*)",WRITE,*
  59. 2900 REM
  60. 2950 RESTORE 2000
  61. 3000 FOR I = 1 TO NN
  62. 3010   READ A$
  63. 3020   KBAS$(I) = SPACE$(8)
  64. 3030   LSET KBAS$(I) = A$
  65. 3040 NEXT
  66. 3050 RESTORE 2450
  67. 3060 FOR I = 1 TO 6
  68. 3070   READ TWOS(I)
  69. 3080 NEXT
  70. 3100 RESTORE 2600
  71. 3110 FOR I = 1 TO NN
  72. 3120   READ A$
  73. 3130   KFOR$(I) = A$
  74. 3140 NEXT
  75. 3150 FOR I = 1 TO NN
  76. 3200   TOKEN$ = KBAS$(I)
  77. 3250   GOSUB 6900
  78. 3300   HASH(I) = S
  79. 3350   IF PNTR(HASH(I)) = 0 THEN PNTR(HASH(I)) = I
  80. 3400 NEXT I
  81. 3450 PRINT "Enter name of BASIC   Program "; : INPUT F$
  82. 3500 OPEN F$ FOR INPUT AS #1
  83. 3550 PRINT "Enter name of FORTRAN Program "; : INPUT G$
  84. 3600 OPEN G$ FOR OUTPUT AS #2
  85. 3650 PRINT "Do you wish to have source displayed? "; : INPUT ANS$
  86. 3700 PRINT
  87. 3750 IF LEFT$(ANS$, 1) = "Y" OR LEFT$(ANS$, 1) = "y" THEN SHOW = TRUE ELSE SHOW = FALSE
  88. 3800 IF SHOW THEN CLS
  89. 3850 ON ERROR GOTO 6850
  90. 3900 H$ = "c:WORK"
  91. 3910 OPEN H$ FOR OUTPUT AS #3
  92. 3920 GOTO 4000
  93. 3950 H$ = "b:WORK"
  94. 3960 OPEN H$ FOR OUTPUT AS #3
  95. 4000 ON ERROR GOTO 0
  96. 4001 OLIN = 0
  97. 4002 LOCATE 2, 50
  98. 4005 COLOR 5, 0
  99. 4010 PRINT "PASS 1: PARSING"
  100. 4050 FOR Z! = 1 TO 1000000!
  101. 4051   LINE INPUT #1, BUF$(0)
  102. 4100   IF EOF(1) THEN 6101
  103. 4150   IF INSTR(BUF$(0), "XOR") <> 0 THEN XORFLG = TRUE
  104. 4200   IF INSTR(BUF$(0), "IMP") <> 0 THEN IMPFLG = TRUE
  105. 4250   IF INSTR(BUF$(0), "EQV") <> 0 THEN EQVFLG = TRUE
  106. 4350   FC = INSTR(1, BUF$(0), BLANK$) + 1
  107. 4400   I = 1
  108. 4410   LLINES = 1
  109. 4420   OLIN = OLIN + 1
  110. 4430   QUOTFLG = FALSE
  111. 4450   CM = 0
  112. 4500 REM
  113. 4550 REM fix ELSEs
  114. 4600 REM
  115. 4650   GOSUB 7800
  116. 4670   L = LEN(BUF$(0))
  117. 4690   KP = P: P = 0
  118. 4700   FOR J = I TO L
  119. 4710     X$ = MID$(BUF$(0), J, 1)
  120. 4720     QUOTFLG = FNTOGGLE(X$, QUOTE$, QUOTFLG)
  121. 4730     IF (NOT QUOTFLG) AND X$ = ":" THEN P = J: GOTO 4751
  122. 4750   NEXT J
  123. 4751   REM
  124. 4800   IF P = 0 THEN P = (INSTR(KP + 1, BUF$(0), "'")): IF P > 0 THEN CM = LLINES
  125. 4850   IF P > 0 THEN CP(LLINES) = P: LLINES = LLINES + 1: OLIN = OLIN + 1: I = P + 1 - (CM <> 0): GOTO 4690 ELSE GOTO 4900
  126. 4900   CP(LLINES) = L + 1: CP(0) = 0
  127. 4950 REM
  128. 5000   FOR M = LLINES TO 1 STEP -1
  129. 5005     CC = CM = (M - 1) AND M > 1
  130. 5050     BUF$(M) = MID$(BUF$(0), CP(M - 1) + 1 + (CC), CP(M) - CP(M - 1) - 1 - (CC))
  131. 5100   NEXT
  132. 5150   LINEO! = VAL(BUF$(1))
  133. 5160   IF LINEO! <= NEXTLIN! THEN PRINT "ERROR--not enough space to insert logical lines": BEEP: END
  134. 5200   IF LLINES < 2 THEN 5300
  135. 5250   FOR K = 2 TO LLINES
  136. 5260     NEXTLIN! = LINEO! - 1 + K
  137. 5270     L$ = STRING$(5, " ")
  138. 5280     BUF$(K) = L$ + BLANK$ + BUF$(K)
  139. 5290   NEXT
  140. 5300   IF FC = 7 THEN 5351
  141. 5350   BUF$(1) = LEFT$(BUF$(1), FC - 1) + " " + MID$(BUF$(1), FC): FC = FC + 1: GOTO 5300
  142. 5351   FOR M = 1 TO LLINES
  143. 5352     IF MID$(BUF$(M), FC, 1) = " " THEN BUF$(M) = LEFT$(BUF$(M), FC - 1) + MID$(BUF$(M), FC + 1): GOTO 5352
  144. 5353   NEXT M
  145. 5400   RMFLG = FALSE
  146. 5450   FOR I = 1 TO LLINES         '* for each logical line...
  147. 5500     IF MID$(BUF$(1), FC, 3) = "REM" OR MID$(BUF$(1), FC, 1) = "'" THEN RMFLG = TRUE
  148. 5550     IF (NOT RMFLG) AND MID$(BUF$(I), FC, 1) = "'" THEN BUF$(I) = "C" + BUF$(I)
  149. 5600     IF RMFLG THEN BUF$(I) = "C" + BUF$(I)
  150. 5650   NEXT
  151. 5700   IF RMFLG THEN 5950
  152. 5750   ON ERROR GOTO 13000
  153. 5800   GOSUB 8300   '* BUILD TABLE OF REFERENCED LINES
  154. 5850   GOSUB 9500   '* BUILD TABLE OF CHAR, INT, AND DBL VARS [SINGLE NOT DETECTABLE]
  155. 5900   GOSUB 11950  '* BUILD FOR/NEXT REF TABLE
  156. 5950   FOR I = 1 TO LLINES
  157. 5960     PRINT #3, BUF$(I)
  158. 6000     IF SHOW THEN COLOR 3, 1: PRINT BUF$(I): COLOR 7, 0
  159. 6050     BUF$(I) = ""
  160. 6060   NEXT I
  161. 6100 NEXT Z!
  162. 6101 GOSUB 30000
  163. 6150 CLOSE 1
  164. 6160 CLOSE 3
  165. 6170 OPEN H$ FOR INPUT AS #1
  166. 6200 IF SP <> 0 THEN ERROR 82
  167. 6250 IF SHOW THEN PRINT
  168. 6300 LOCATE 2, 50
  169. 6310 COLOR 3, 0
  170. 6320 PRINT "PASS 2: EDITING "
  171. 6350 GOSUB 13200        '* VAR DEFS
  172. 6351 LOUT = 0
  173. 6400 WHILE NOT EOF(1)
  174. 6450   LINE INPUT #1, BUF$(0)
  175. 6451   LOUT = LOUT + 1
  176. 6452   IF OLIN > 20 AND (LOUT MOD 20) = 0 OR LOUT = 1 THEN CLS : GOSUB 30000: LOCATE 2, 50: COLOR 3, 0: PRINT "PASS 2: EDITING "
  177. 6500   FS = INSTR(BUF$(0), " ")
  178. 6510   LINEO! = VAL(LEFT$(BUF$(0), FS))
  179. 6520   L$ = MID$(STR$(LINEO!), 2)
  180. 6550   X$ = STRING$(6, " ")
  181. 6560   IF LEFT$(BUF$(0), 1) <> "C" THEN MID$(BUF$(0), 1, 6) = X$
  182. 6600   GOSUB 14350
  183. 6610   GOSUB 21150
  184. 6620   PRINT #2, BUF$(0)
  185. 6650   IF SHOW THEN COLOR 1, 3: PRINT BUF$(0): COLOR 7, 0
  186. 6700 WEND
  187. 6750 REM
  188. 6800 END
  189. 6850 RESUME 3950
  190. 6900 S = 0
  191. 6950 FOR J = 8 TO 1 STEP -1
  192. 7000   ZL = J
  193. 7050   W$ = MID$(TOKEN$, J, 1): IF W$ <> " " THEN 7150
  194. 7100 NEXT J
  195. 7150 IF ZL > 6 THEN ZL = 6
  196. 7200 FOR J = 1 TO ZL
  197. 7250   W$ = MID$(TOKEN$, J, 1): X = ASC(W$) - 64
  198. 7300   S = S + X * TWOS(ZL - J + 1)
  199. 7350 NEXT J
  200. 7400 S = S - 23: IF S < 0 OR S > 1134 THEN S = 0
  201. 7450 REM RESOLVE COLLISIONS
  202. 7500 IF TOKEN$ = "EOF     " THEN S = 78: RETURN
  203. 7550 IF TOKEN$ = "SIN     " THEN S = 79: RETURN
  204. 7600 IF TOKEN$ = "TO      " THEN S = 80: RETURN
  205. 7650 IF TOKEN$ = "IMP     " THEN S = 77: RETURN
  206. 7700 IF TOKEN$ = "INT     " THEN S = 76: RETURN
  207. 7750 RETURN
  208. 7800 PE = FC
  209. 7810 ELSC = 0
  210. 7840 IF INSTR(BUF$(0), "ELSE") = 0 THEN RETURN
  211. 7850 ELSP = INSTR(PE, BUF$(0), "ELSE")
  212. 7860 IF ELSP = 0 THEN 8150
  213. 7900 ELSC = ELSC + 1: ND = ELSP + 4
  214. 7950 IF FNUM(MID$(BUF$(0), ND + 1, 1)) THEN BUF$(0) = FNINS$(BUF$(0), "GOTO ", ND, ND + 1)
  215. 8000 BUF$(0) = FNINS$(BUF$(0), ":", ELSP - 1, ELSP)
  216. 8010 BUF$(0) = FNINS$(BUF$(0), ":", ND, ND + 1)
  217. 8050 IF INSTR(MID$(BUF$(0), PE, ELSP - PE), ":") <> 0 THEN BUF$(0) = FNINS$(BUF$(0), ":ENDIF", ELSP - 2, ELSP - 1): ELSP = ELSP + 6
  218. 8100 PE = ELSP + 2
  219. 8110 GOTO 7850
  220. 8150 FOR K = 1 TO ELSC
  221. 8160   BUF$(0) = BUF$(0) + ":ENDIF"
  222. 8170 NEXT
  223. 8200 IT = INSTR(BUF$(0), "THEN")
  224. 8210 BUF$(0) = FNREP$(BUF$(0), "then", IT, IT + 4)
  225. 8220 RETURN
  226. 8250 REM
  227. 8300 T = 1
  228. 8310 FOR I = 1 TO LLINES
  229. 8350   T = 1
  230. 8400   IF INSTR(MID$(BUF$(I), 1), "ON ERROR") = 0 THEN 8500
  231. 8450   BUF$(I) = "C" + BUF$(I)
  232. 8460   GOTO 9400
  233. 8500   Q = INSTR(T, BUF$(I), "GOTO ")
  234. 8510   IF Q = 0 THEN Q = INSTR(T, BUF$(I), "GOSUB ")
  235. 8550   IF Q = 0 THEN Q = INSTR(T, BUF$(I), "then ")
  236. 8600   IF Q <> 0 THEN 9050
  237. 8650   T0 = T: T = INSTR(T, BUF$(I), "THEN ") + 5
  238. 8660 ' IF T = 5 THEN T = INSTR(T0, BUF$(I), "then") + 5 : IF T > 5 THEN IFE = TRUE
  239. 8700   IF T = 5 THEN T = LEN(BUF$(I))
  240. 8750   IF T = LEN(BUF$(I)) THEN 8950
  241. 8800   IF NOT FNUM(MID$(BUF$(I), T)) THEN 8950
  242. 8850   R$ = "GOTO "     '* IF IFE THEN R$=":GOTO "
  243. 8900   BUF$(I) = LEFT$(BUF$(I), T - 1) + R$ + MID$(BUF$(I), T)
  244. 8910   Q = T
  245. 8950   E = INSTR(T, BUF$(I), "ELSE ") + 5
  246. 8960   IF T = LEN(BUF$(I)) AND E = 5 THEN 9400
  247. 9000   IF Q = 0 THEN 9400
  248. 9050   N = INSTR(Q, BUF$(I), " ") + 1
  249. 9100   M! = VAL(MID$(BUF$(I), N))
  250. 9110   IF M! = 0 THEN 9400
  251. 9150   FOR K = 1 TO IREF
  252. 9160    IF REFLIN!(K) = M! THEN 9300
  253. 9151   NEXT
  254. 9200   IREF = IREF + 1
  255. 9210   REFLIN!(IREF) = M!
  256. 9250   JREF = JREF + 1
  257. 9260   REFER!(JREF) = LINEO!
  258. 9300   NN = INSTR(N, BUF$(I), ",") + 1
  259. 9310   IF NN > N + 1 THEN N = NN: GOTO 9100
  260. 9350   IF E > 5 THEN T = E: GOTO 8750
  261. 9400 NEXT I
  262. 9450 RETURN
  263. 9500 FOR K = 1 TO 4
  264. 9550   FOR I = 1 TO LLINES
  265. 9600     P = 1
  266. 9650     P = INSTR(P + 1, BUF$(I), TST$(K))
  267. 9660     IF P = 0 THEN 10950
  268. 9700     T$ = ""
  269. 9710     FOR J = P - 1 TO 1 STEP -1
  270. 9720       X$ = MID$(BUF$(I), J, 1)
  271. 9750       IF (INSTR("=, +*/\()^:<>;-", X$) <> 0) THEN 9900
  272. 9800       T$ = X$ + T$
  273. 9850     NEXT J
  274. 9900     TOKEN$ = T$ + TST$(K)
  275. 9910     IF LEN(TOKEN$) = 1 THEN 9650
  276. 9950     IF LEN(TOKEN$) >= 8 THEN 10000 ELSE TOKEN$ = TOKEN$ + " ": GOTO 9950
  277. 10000     GOSUB 6900
  278. 10010     IF S <> 0 AND TOKEN$ = KBAS$(PNTR(S)) THEN P = P + 1: GOTO 9650
  279. 10050     P = P + 1
  280. 10100     ON K GOTO 10150, 10350, 10500, 10700
  281. 10150 REM ALPHA
  282. 10200     FOR N = 1 TO IALPH
  283. 10210       IF T$ = VALPH$(N) THEN 10650
  284. 10250     NEXT
  285. 10300     IALPH = IALPH + 1
  286. 10310     VALPH$(IALPH) = T$
  287. 10320     GOTO 10650
  288. 10350     FOR N = 1 TO IINT
  289. 10360       IF T$ = VINT$(N) THEN 10650
  290. 10400     NEXT
  291. 10450     IINT = IINT + 1: VINT$(IINT) = T$: GOTO 10650
  292. 10500     FOR N = 1 TO IDBL
  293. 10510       IF T$ = VDBL$(N) THEN 10650
  294. 10550     NEXT
  295. 10600     IDBL = IDBL + 1: VDBL$(IDBL) = T$: GOTO 10650
  296. 10650     GOTO 9650
  297. 10700 REM single
  298. 10750     FOR N = 1 TO ISNGL
  299. 10760       IF T$ = VSNGL$(N) THEN 10900
  300. 10800     NEXT
  301. 10850     ISNGL = ISNGL + 1: VSNGL$(ISNGL) = T$: GOTO 10900
  302. 10900     GOTO 9650
  303. 10950   NEXT I
  304. 11000 NEXT K
  305. 11050 RETURN
  306. 11100 TP = 0
  307. 11150 FOR K = 1 TO 10
  308. 11200   P = 1
  309. 11250   P = INSTR(P, BUF$(0), DELIM$(K)): IF P = 0 THEN P = LEN(BUF$(0)) + 1
  310. 11300   T$ = "": FOR J = P - 1 TO 1 STEP -1: X$ = MID$(BUF$(0), J, 1)
  311. 11350   IF (INSTR("=, +*/\()^:<>;-", X$) <> 0) THEN 11500
  312. 11400   T$ = X$ + T$
  313. 11450 NEXT J
  314. 11500 TOKEN$ = T$'TOKEN$=T$+TST$(K)
  315. 11550 IF LEN(TOKEN$) >= 8 THEN 11600 ELSE TOKEN$ = TOKEN$ + " ": GOTO 11550
  316. 11600 GOSUB 6900: IF S = 0 OR TOKEN$ <> KBAS$(PNTR(S)) THEN P = P + 1: IF P <= LEN(BUF$(0)) THEN 11250 ELSE 11700
  317. 11650 TP = TP + 1: TOKLST$(TP) = TOKEN$: AA(TP) = P - (J - 1): BB(TP) = P: PTLST(TP) = PNTR(S): P = P + 1: IF P <= LEN(BUF$(0)) THEN 11250 ELSE 11750
  318. 11700 NEXT K
  319. 11750 FOR K = 1 TO TP - 1: FOR J = K + 1 TO TP
  320. 11800   IF AA(J) > AA(K) THEN SWAP AA(J), AA(K): SWAP BB(J), BB(K): SWAP TOKLST$(J), TOKLST$(K): SWAP PTLST(J), PTLST(K)
  321. 11850 NEXT J: NEXT K
  322. 11900 RETURN
  323. 11950 FOR I = 1 TO LLINES
  324. 12000   LNO! = LINEO! + I - 1: L2 = LEN(BUF$(I))
  325. 12050   IF MID$(BUF$(I), FC, 4) <> "FOR " THEN 12300
  326. 12100   PT4 = PT4 + 1: POINT4!(PT4, 1) = LNO!: POINT4!(PT4, 2) = -PT4: SP = SP + 1: STACK4(SP) = PT4
  327. 12150   IF SP < 0 THEN ERROR 80 ELSE IF SP > 25 THEN ERROR 81
  328. 12200   IF I = 1 THEN 12300 ELSE L$ = MID$(STR$(LNO!), 2)
  329. 12250   GOSUB 20850: GOTO 12450
  330. 12300   IF MID$(BUF$(I), FC, 5) = "NEXT " OR (L2 = FC + 3 AND MID$(BUF$(I), FC, 4) = "NEXT") THEN POINT4!(STACK4(SP), 2) = LNO!: SP = SP - 1 ELSE 12450
  331. 12350   IF I = 1 THEN 12450 ELSE L$ = MID$(STR$(LNO!), 2)
  332. 12400   GOSUB 20850
  333. 12450 REM WHILE/WEND
  334. 12500   IF MID$(BUF$(I), FC, 6) <> "WHILE " THEN 12750
  335. 12550   PT4 = PT4 + 1: POINT4!(PT4, 1) = LNO!: POINT4!(PT4, 2) = -PT4: SP = SP + 1: STACK4(SP) = PT4: CSTK$(SP) = MID$(BUF$(I), FC + 6)
  336. 12600   IF SP < 0 THEN ERROR 80 ELSE IF SP > 25 THEN ERROR 81
  337. 12650   IF I = 1 THEN 12750 ELSE L$ = MID$(STR$(LNO!), 2)
  338. 12700   GOSUB 20850: GOTO 12900
  339. 12750   IF MID$(BUF$(I), FC, 5) = "WEND " OR (L2 = FC + 3 AND MID$(BUF$(I), FC, 4) = "WEND") THEN POINT4!(STACK4(SP), 2) = LNO!: BUF$(I) = BUF$(I) + " " + CSTK$(SP): SP = SP - 1 ELSE 12900
  340. 12800   IF I = 1 THEN 12900 ELSE L$ = MID$(STR$(LNO!), 2)
  341. 12850   GOSUB 20850
  342. 12900 NEXT I
  343. 12950 RETURN
  344. 13000 IF ERR = 80 THEN PRINT "NEXT OR WEND WITHOUT FOR OR WHILE IN: ": PRINT BUF$(0): STOP
  345. 13050 IF ERR = 81 THEN PRINT "TOO MANY NESTED LOOPS AT: ": PRINT BUF$(0): STOP
  346. 13100 IF ERR = 82 THEN PRINT "FOR WITHOUT NEXT SOMEWHERE IN PROGRAM...": STOP
  347. 13150 PRINT ERR, ERL: STOP
  348. 13200 IF IALPH > 0 THEN PRINT #2, "      CHARACTER*127 ";
  349. 13250 QL = 7: CON = FALSE
  350. 13260 FOR I = 1 TO IALPH - 1: QL = QL + LEN(VALPH$(I)) + 2
  351. 13300   IF QL < 66 THEN PRINT #2, VALPH$(I) + "$" + ",";  ELSE QL = 7: CON = TRUE: PRINT #2, VALPH$(I) + "$"
  352. 13350   IF CON THEN PRINT #2, "     &"; : CON = FALSE
  353. 13400 NEXT I
  354. 13410 IF IALPH > 0 THEN PRINT #2, VALPH$(IALPH) + "$"
  355. 13450 IF IINT > 0 THEN PRINT #2, "      INTEGER ";
  356. 13500 QL = 7: CON = FALSE
  357. 13510 FOR I = 1 TO IINT - 1: QL = QL + LEN(VINT$(I)) + 2
  358. 13550   IF QL < 66 THEN PRINT #2, VINT$(I) + "%" + ",";  ELSE QL = 7: CON = TRUE: PRINT #2, VINT$(I) + "%"
  359. 13600 NEXT I: IF IINT > 0 THEN PRINT #2, VINT$(IINT) + "%"
  360. 13650 IF IDBL > 0 THEN PRINT #2, "      REAL*8 ";
  361. 13700 QL = 7: CON = FALSE
  362. 13710 FOR I = 1 TO IDBL - 1: QL = QL + LEN(VDBL$(I)) + 2
  363. 13750   IF QL < 66 THEN PRINT #2, VDBL$(I) + "#" + ",";  ELSE QL = 7: CON = TRUE: PRINT #2, VDBL$(I) + "#"
  364. 13800 NEXT I
  365. 13810 IF IDBL > 0 THEN PRINT #2, VDBL$(IDBL) + "#"
  366. 13850 IF ISNGL > 0 THEN PRINT #2, "      REAL ";
  367. 13900 QL = 7: CON = FALSE
  368. 13910 FOR I = 1 TO ISNGL - 1: QL = QL + LEN(VSNGL$(I)) + 2
  369. 13950   IF QL < 66 THEN PRINT #2, VSNGL$(I) + "#" + ",";  ELSE QL = 7: CON = TRUE: PRINT #2, VSNGL$(I) + "!"
  370. 14000 NEXT I
  371. 14010 IF ISNGL > 0 THEN PRINT #2, VSNGL$(ISNGL) + "!"
  372. 14050 IF EQVFLG THEN PRINT #2, "      LOGICAL FEQV"
  373. 14100 IF XORFLG THEN PRINT #2, "      LOGICAL FXOR"
  374. 14150 IF IMPFLG THEN PRINT #2, "      LOGICAL FIMP": PRINT #2, "      FIMP(X,Y)=((X .AND. Y) .OR. ((.NOT. X) .AND. Y))"
  375. 14200 IF XORFLG THEN PRINT #2, "      FXOR(X,Y)=((X .OR Y) .AND. (.NOT. (X .AND. Y)))"
  376. 14250 IF EQVFLG THEN PRINT #2, "      FEQV(X,Y)=((X .AND. Y) .OR. (.NOT. X) .AND. (.NOT. Y))"
  377. 14300 RETURN
  378. 14350 L = LEN(BUF$(0))
  379. 14400 GOSUB 11100
  380. 14450 FOR IT = 1 TO TP
  381. 14451   RW = CSRLIN: CL = POS(0)
  382. 14452   LOCATE 25, 1: PRINT SPACE$(78);
  383. 14453   LOCATE 25, 1: COLOR 6, 0: PRINT MID$(BUF$(0), 7); : LOCATE 25, 70: COLOR 2, 0: PRINT TIME$;
  384. 14454   LOCATE RW, CL
  385. 14500   A = AA(IT): B = BB(IT): TOKEN$ = TOKLST$(IT): P = PTLST(IT)
  386. 14550   IF TOKEN$ <> KBAS$(P) THEN S = 0: GOTO 18200
  387. 14600   IF P > 23 THEN 14800
  388. 14650 REM 1 TO 23
  389. 14700   ON P GOSUB 15200, 15250, 15250, 15250, 15300, 15250, 15250, 15250, 19000, 15350, 15200, 15200, 15250, 15250, 15150, 17750, 17750, 17750, 15250, 15250, 15250, 15200, 15200
  390. 14750   GOTO 15650
  391. 14800   IF P > 57 THEN 15000
  392. 14850 REM 24 TO 57
  393. 14900   ON P - 23 GOSUB 21800, 15200, 15250, 15150, 15950, 15200, 17250, 19200, 21600, 15200, 31000, 15400, 15200, 15200, 15150, 15250, 15200, 21750, 19050, 15250, 17350, 16350, 15200, 15250, 15250, 17850, 15200, 15200, 15200, 15200, 15250, 15200, 15200, 15200
  394. 14950   GOTO 15650
  395. 15000   IF P > 71 THEN ERROR 89
  396. 15050   ON P - 57 GOSUB 15250, 15250, 15200, 18300, 15200, 15250, 15800, 15250, 15200, 18600, 19050, 15250, 17850, 21700
  397. 15100   GOTO 15650
  398. 15150   BUF$(0) = FNREP$(BUF$(0), "", A, B): RETURN
  399. 15200   RETURN
  400. 15250   BUF$(0) = FNREP$(BUF$(0), KFOR$(P), A, B): RETURN
  401. 15300   BUF$(0) = LEFT$(BUF$(0), 6) + "WRITE(*,*) CHAR(7)": RETURN
  402. 15350 REM CLS:RETURN
  403. 15351   RETURN
  404. 15400 REM INPUT#
  405. 15401   R$ = MID$(BUF$(0), B + 2)
  406. 15450   Q$ = MID$(BUF$(0), B): Z7 = VAL(MID$(BUF$(0), B)): BUF$(0) = LEFT$(BUF$(0), A - 1) + "READ("
  407. 15500   X$ = STR$(Z7): BUF$(0) = BUF$(0) + X$ + ")" + R$: RETURN
  408. 15550 REM WRITE#
  409. 15600   RETURN
  410. 15650 NEXT IT
  411. 15700 GOSUB 20900
  412. 15750 RETURN
  413. 15800 X$ = KFOR$(P) + CHR$(13) + CHR$(10) + "      "
  414. 15850 IF FNUM(MID$(BUF$(0), B + 1)) THEN X$ = X$ + "GOTO "
  415. 15900 BUF$(0) = FNREP$(BUF$(0), X$, A, B): RETURN
  416. 15950 REM FOR
  417. 16000 IF MID$(BUF$(0), FC, 4) = "OPEN" THEN RETURN
  418. 16050 FOR J = 1 TO PT4
  419. 16051   K = J: IF POINT4!(J, 1) = LINEO! THEN 16200
  420. 16100 NEXT J
  421. 16150 PRINT "error": STOP
  422. 16200 X$ = STR$(POINT4!(K, 2)): X$ = "DO" + X$
  423. 16250 BUF$(0) = FNREP$(BUF$(0), X$, A, B)
  424. 16300 RETURN
  425. 16350 ACC$ = ",ACCESS=" + CHR$(34) + "SEQUENTIAL" + CHR$(34): RL$ = ""
  426. 16400 FM = 1: IF INSTR(BUF$(0), ",") <> 0 THEN 16850
  427. 16450 FS = INSTR(FC, BUF$(0), " "): S2 = INSTR(FS + 1, BUF$(0), " ")
  428. 16500 NAM$ = MID$(BUF$(0), FS + 1, S2 - FS - 1)
  429. 16550 P3 = INSTR(BUF$(0), "#"): IF P3 = 0 THEN P3 = INSTR(BUF$(0), " AS ") + 3
  430. 16600 FIL = VAL(MID$(BUF$(0), P3 + 1))
  431. 16650 P4 = INSTR(BUF$(0), "="): IF P4 = 0 THEN 16750
  432. 16700 RL$ = ",RECL=" + STR$(VAL(MID$(BUF$(0), P4 + 1))): ACC$ = ",ACCESS=" + CHR$(34) + "DIRECT" + CHR$(34)
  433. 16750 BUF$(0) = "      OPEN(" + STR$(FIL) + ",FILE=" + NAM$ + ",STATUS=" + CHR$(34) + "OLD" + CHR$(34) + ACC$ + RL$ + ")"
  434. 16800 RETURN
  435. 16850 P1 = INSTR(FC, BUF$(0), ","): P2 = INSTR(P1 + 1, BUF$(0), ",")
  436. 16900 P3 = INSTR(P2 + 1, BUF$(0), ","): IF P3 = 0 THEN P3 = LEN(BUF$(0))
  437. 16950 NAM$ = MID$(BUF$(0), P2 + 1, P3 - P2 - 1)
  438. 17000 P4 = INSTR(BUF$(0), "#"): IF P4 = 0 THEN P4 = P1
  439. 17050 FIL = VAL(MID$(BUF$(0), P4 + 1))
  440. 17100 IF P3 < LEN(BUF$(0)) THEN RL$ = ",RECL=" + STR$(VAL(MID$(BUF$(0), P3 + 1))): ACC$ = ",ACCESS=" + CHR$(34) + "DIRECT" + CHR$(34)
  441. 17150 GOTO 16750
  442. 17200 RETURN
  443. 17250 REM GOTO
  444. 17300 RETURN
  445. 17350 REM ON
  446. 17400 BL(1) = INSTR(FC, BUF$(0), " ")
  447. 17450 FOR M = 2 TO 3: BL(M) = INSTR(BL(M - 1) + 1, BUF$(0), " "): NEXT
  448. 17500 IF MID$(BUF$(0), BL(2) + 1, BL(3) - BL(2) - 1) <> "GOTO" THEN RETURN
  449. 17550 X$ = MID$(BUF$(0), BL(1) + 1, BL(2) - BL(1) - 1)
  450. 17600 Y$ = "(" + MID$(BUF$(0), BL(3) + 1) + ") "
  451. 17650 BUF$(0) = "      GOTO " + Y$ + X$: RETURN
  452. 17700 RETURN
  453. 17750 REM DEF---
  454. 17800 GOSUB 15250: BUF$(0) = BUF$(0) + ")": RETURN
  455. 17850 REM PRINT#
  456. 17900 P2 = INSTR(BUF$(0), ","): P1 = INSTR(BUF$(0), "#"): FIL$ = STR$(VAL(MID$(BUF$(0), P1 + 1, P2 - P1 - 1)))
  457. 17950 FIL$ = MID$(FIL$, 2)
  458. 18000 BUF$(0) = FNREP$(BUF$(0), "WRITE(" + FIL$ + ",*)", FC, P2 + 1)
  459. 18050 RETURN
  460. 18100 REM
  461. 18150 RETURN
  462. 18200 REM SPECIAL ACTION
  463. 18250 GOTO 15650
  464. 18300 P1 = INSTR(FC, BUF$(0), " "): P2 = INSTR(BUF$(0), ",")
  465. 18350 X$ = MID$(BUF$(0), P1 + 1, P2 - P1 - 1): Y$ = MID$(BUF$(0), P2 + 1)
  466. 18400 Z$ = "TEMP$$=" + X$ + CHR$(13) + CHR$(10) + "      " + X$ + "=" + Y$
  467. 18450 Z$ = Z$ + CHR$(13) + CHR$(10) + "      " + Y$ + "=" + "TEMP$$"
  468. 18500 BUF$(0) = LEFT$(BUF$(0), 6) + Z$: RETURN
  469. 18550 RETURN
  470. 18600 REM WEND
  471. 18650 BUF$(0) = FNREP$(BUF$(0), "IF(", A, B): GOSUB 19300
  472. 18700 FOR J = 1 TO PT4: K = J: IF POINT4!(J, 2) = LINEO! THEN 18850
  473. 18750 NEXT J
  474. 18800 PRINT "ERROR": STOP
  475. 18850 X$ = STR$(POINT4!(K, 1))
  476. 18900 BUF$(0) = BUF$(0) + ")" + " GOTO " + X$
  477. 18950 RETURN
  478. 19000 GOSUB 15250: BUF$(0) = BUF$(0) + ")": RETURN
  479. 19050 BUF$(0) = LEFT$(BUF$(0), 6) + "CONTINUE"
  480. 19150 I = 0: GOSUB 20850: RETURN
  481. 19200 REM
  482. 19250 GOSUB 15250: IFFLG = TRUE
  483. 19300 M = 0: D = INSTR(BUF$(0), "ELSE"): IF D = 0 THEN D = LEN(BUF$(0))
  484. 19350 M = M + 1: IF M > D THEN 20750
  485. 19400 IF MID$(BUF$(0), M, 1) = "]" THEN IFFLG = FALSE: MID$(BUF$(0), M, 1) = ")"
  486. 19450 P = INSTR("<>=", MID$(BUF$(0), M, 1))
  487. 19500 IF MID$(BUF$(0), M, 3) = "IF(" THEN IFFLG = TRUE
  488. 19550 IF P = 0 OR NOT IFFLG THEN 19350
  489. 19600 MM = M + 1
  490. 19650 Q = INSTR("<>=", MID$(BUF$(0), MM, 1)): IF Q = 0 THEN MM = M
  491. 19700 R = 4 * Q + P: ON R + 1 GOTO 20650, 19750, 19900, 20050, 20650, 20650, 20200, 20350, 20650, 20200, 20650, 20500, 20650, 20350, 20500, 20650
  492. 19750 REM <
  493. 19800 BUF$(0) = FNREP$(BUF$(0), ".LT.", M, MM + 1)
  494. 19850 M = MM + 2: GOTO 19400
  495. 19900 REM >
  496. 19950 BUF$(0) = FNREP$(BUF$(0), ".GT.", M, MM + 1)
  497. 20000 M = MM + 2: GOTO 19400
  498. 20050 REM =
  499. 20100 BUF$(0) = FNREP$(BUF$(0), ".EQ.", M, MM + 1)
  500. 20150 M = MM + 2: GOTO 19400
  501. 20200 REM <>
  502. 20250 BUF$(0) = FNREP$(BUF$(0), ".NE.", M, MM + 1)
  503. 20300 M = MM + 2: GOTO 19400
  504. 20350 REM <=
  505. 20400 BUF$(0) = FNREP$(BUF$(0), ".LE.", M, MM + 1)
  506. 20450 M = MM + 2: GOTO 19400
  507. 20500 REM >=
  508. 20550 BUF$(0) = FNREP$(BUF$(0), ".GE.", M, MM + 1)
  509. 20600 M = MM + 2: GOTO 19400
  510. 20650 REM IMPOSSIBLE...?
  511. 20700 GOTO 19400
  512. 20750 RETURN
  513. 20800 RETURN
  514. 20850 IF VAL(L$) > 0 THEN FOR NN = 1 TO LEN(L$): MID$(BUF$(I), NN, 1) = MID$(L$, NN, 1): NEXT NN: RETURN
  515. 20851 RETURN
  516. 20900 REM SEARCH
  517. 20950 FOR J = 1 TO IREF: K = J: IF REFLIN!(J) = LINEO! THEN 21100
  518. 21000 NEXT J
  519. 21050 RETURN
  520. 21100 I = 0: GOSUB 20850: RETURN
  521. 21150 REM
  522. 21200 L = LEN(BUF$(0))
  523. 21250 I = 0
  524. 21300 I = I + 1: IF I > L THEN 21550
  525. 21350 X$ = MID$(BUF$(0), I, 1)
  526. 21400 IF X$ = CHR$(34) THEN MID$(BUF$(0), I, 1) = "'" ELSE IF X$ = "^" THEN BUF$(0) = FNREP$(BUF$(0), "**", I, I + 1)
  527. 21450 L = LEN(BUF$(0))
  528. 21500 GOTO 21300
  529. 21550 RETURN
  530. 21600 REM IMP
  531. 21650 FUN$ = " IMP": FUN2$ = "FIMP(": GOSUB 21850: RETURN
  532. 21700 FUN$ = " XOR": FUN2$ = "FXOR(": GOSUB 21850: RETURN
  533. 21750 FUN$ = " MOD": FUN2$ = "AMOD(": GOSUB 21850: RETURN
  534. 21800 FUN$ = " EQV": FUN2$ = "FEQV(": GOSUB 21850: RETURN
  535. 21850 REM general
  536. 21900 P = INSTR(BUF$(0), FUN$)
  537. 21950 Y$ = "": FOR I = P - 1 TO 1 STEP -1: X$ = MID$(BUF$(0), I, 1)
  538. 22000 IF (INSTR("=, +*/\()^:<>;-", X$) <> 0) THEN 22100
  539. 22050 Y$ = X$ + Y$: NEXT I
  540. 22100 R = P + 5
  541. 22110 FOR Q = R TO LEN(BUF$(0)): X$ = MID$(BUF$(0), Q, 1)
  542. 22150   IF (INSTR("=, +*/\()^:<>;-", X$) <> 0) THEN 22250
  543. 22200 NEXT Q
  544. 22250 X$ = ")": Z$ = MID$(BUF$(0), R, Q - R + 1): IF Z$ = "(" THEN Z$ = "": X$ = ""
  545. 22300 BUF$(0) = FNREP$(BUF$(0), FUN2$ + Y$ + "," + Z$ + X$, I + 1, Q): RETURN
  546. 30000 LOCATE 3, 50: COLOR 4, 0: PRINT "SOURCE LINES:"; Z!
  547. 30001 LOCATE 4, 50: COLOR 6, 0: PRINT "OUTPUT LINES:"; OLIN
  548. 30002 RETURN
  549. 31000 IF MID$(BUF$(0), FC, 4) = "OPEN" THEN RETURN
  550. 31005 IF MID$(BUF$(0), B + 1, 1) = "#" THEN P = P + 1: B = B + 2: GOTO 15400
  551. 31100 GOSUB 15250: RETURN
  552.  
  553.