home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 12 / forth.bas < prev    next >
Encoding:
BASIC Source File  |  1986-02-05  |  10.3 KB  |  213 lines
  1. 10    ' * * *   BASIC - FORTH   * * *
  2. 20    '    BIRKEMEYER & PASCAL International
  3. 30    '
  4. 40    GOSUB 1980 : ' Initialisieren
  5. 50    '
  6. 60    M=0 : N=0
  7. 70    K=1 : VIEW=0 : FORGET=0
  8. 80    '
  9. 90    PRINT : INPUT F$ : F$ = F$+" "
  10. 100   L1=0
  11. 110   L(K)=L1 : LO(K)=LEN(F$) : L1=LO(K)
  12. 120   IF N<0 THEN PRINT "EMPTY - STACK " : GOTO 60
  13. 130   L(K) = L(K)+1
  14. 140   IF L(K) > LO(K) THEN GOTO 240
  15. 150   B$ = MID$(F$,L(K),1)
  16. 160   IF L(K) > LO(K) THEN GOTO 240
  17. 170   IF B$=" " THEN GOTO 130
  18. 180   A$ = B$
  19. 190   L(K) = L(K)+1
  20. 200   B$ = MID$(F$,L(K),1)
  21. 210   IF B$=" " THEN GOTO 310
  22. 220   A$ = A$+B$ : GOTO 190
  23. 230   GOTO 380
  24. 240   IF K<2 THEN GOTO 70
  25. 250   K=K-1
  26. 260   F$=MID$(F$,1,LO(K)) : L1=LO(K) : GOTO 130
  27. 270   '
  28. 280   PRINT "EMPTY - STACK " : GOTO 60
  29. 290   '
  30. 300   ' COLON-DEFINITION, KONSTANTEN & VARIABLEN
  31. 310   FOR Z=C TO KERNEL+1 STEP -1 
  32. 320   IF A$<>WORT$(Z) THEN GOTO 360
  33. 330   IF VIEW THEN PRINT WORT$(Z),DEF$(Z) : VIEW=0 : GOTO 120
  34. 340   IF FORGET THEN C=Z-1 : FORGET=0 : GOTO 120
  35. 350   F$=F$+DEF$(Z) : K=K+1 :   GOTO 110
  36. 360   NEXT Z
  37. 370   '
  38. 380   FOR Z=1 TO KERNEL           ' FORTH-DEFINITIONEN  ( KERNEL )
  39. 390   IF A$<>WORT$(Z) THEN GOTO 420
  40. 400   IF VIEW THEN PRINT "PROTECTED " : VIEW=0 : GOTO 120
  41. 410   IF FORGET THEN PRINT "PROTECTED " : FORGET=0 : GOTO 120 ELSE GOTO 440
  42. 420   NEXT Z
  43. 430   '
  44. 440   ON Z GOTO 610,620,630,640,650,660,670,680,700,710,730,740,750,770
  45. 450   ON Z-14 GOTO 790,800,820,840,860,880,900,920,940,960,970
  46. 460   ON Z-25 GOTO 980,990,1000,1010,1020,1030,1040,1060,1070,1080,1090
  47. 470   ON Z-36 GOTO 1100,1110,1130,1140,1170,1210,1220,1230,1240,1270,1280
  48. 480   ON Z-47 GOTO 1290,1300,1310,1320,1380,1390,1400,1590,1600,1610,1620
  49. 490   ON Z-58 GOTO 1630,1640,1650,1660,1680,1690,1700,1720,1740,1750,1800
  50. 500   ON Z-69 GOTO 1840,1860,1910,1930,1940,1950
  51. 510   '
  52. 520   NUM=1
  53. 530   FOR I=1 TO LEN(A$)
  54. 540   IF MID$(A$,I,1) < "0" OR MID$(A$,I,1) > "9" THEN NUM=0
  55. 550   IF I=1 AND MID$(A$,1,1) = "-" THEN NUM=1
  56. 560   NEXT I
  57. 570   IF NUM=0 THEN PRINT A$, "NICHT DEFINIERT" : GOTO 60
  58. 580   N=N+1 : S(N)=VAL(A$) : GOTO 120
  59. 590   '
  60. 600   '              D  I  C  T  I  O  N  A  R  Y
  61. 610   FOR Z=C TO 1 STEP -1 : PRINT WORT$(Z), :NEXT Z:GOTO 120 ' WORDS
  62. 620   VIEW=1 : GOTO 120                                       ' VIEW
  63. 630   N=N-1 : S(N)=S(N)+S(N+1) : GOTO 120                     ' +
  64. 640   N=N-1 : S(N)=S(N)-S(N+1) : GOTO 120                     ' -
  65. 650   N=N-1 : S(N)=S(N)*S(N+1) : GOTO 120                     ' *
  66. 660   N=N-1 : S(N)=INT(S(N)/S(N+1)) : GOTO 120                ' /
  67. 670   N=N-1 : S(N)=S(N)-(S(N+1)*INT(S(N)/S(N+1))) : GOTO 120  ' MOD
  68. 680   A=S(N-1):S(N-1)=A-(S(N)*INT(A/S(N)))
  69. 690   S(N)=INT(A/S(N)):GOTO 120                               ' /MOD
  70. 700   N=N-2 : S(N)=INT(S(N)*S(N+1)/S(N+2)) : GOTO 120         ' */
  71. 710   S(N-2)=S(N-2)*S(N-1) : S(N-1)=S(N): N=N-1 : A=S(N-1)    ' */MOD
  72. 720   S(N-1)=A-(S(N)*INT(A/S(N))):S(N)=INT(A/S(N)):GOTO 120
  73. 730   S(N)=ABS(S(N)) : GOTO 120                               ' ABS
  74. 740   S(N)=S(N)*-1 : GOTO 120                                 ' MINUS
  75. 750   IF N<1 THEN GOTO 280                                    ' .S
  76. 760   FOR I=1 TO N : PRINT S(N-I+1) : NEXT I : GOTO 120
  77. 770   IF N<1 THEN GOTO 280                                    ' .
  78. 780   PRINT S(N); : N=N-1 : GOTO 120
  79. 790   N=0 : GOTO 120                                          ' CLS
  80. 800   IF S(N)<S(N-1) THEN S(N-1)=S(N)                         ' MIN
  81. 810   N=N-1 : GOTO 120
  82. 820   IF S(N)>S(N-1) THEN S(N-1)=S(N)                         ' MAX
  83. 830   N=N-1 : GOTO 120
  84. 840   N=N-1 : IF S(N)=S(N+1) THEN S(N)=1 ELSE S(N)=0          ' =
  85. 850   GOTO 120
  86. 860   N=N-1 : IF S(N)>S(N+1) THEN S(N)=1 ELSE S(N)=0          ' >
  87. 870   GOTO 120
  88. 880   N=N-1 : IF S(N)<S(N+1) THEN S(N)=1 ELSE S(N)=0          ' <
  89. 890   GOTO 120
  90. 900   N=N-1 : IF S(N)<>S(N+1) THEN S(N)=1 ELSE S(N)=0         ' <>
  91. 910   GOTO 120
  92. 920   N=N-1 : IF S(N)<=S(N+1) THEN S(N)=1 ELSE S(N)=0         ' <=
  93. 930   GOTO 120
  94. 940   N=N-1 : IF S(N)>=S(N+1) THEN S(N)=1 ELSE S(N)=0         ' >=
  95. 950   GOTO 120
  96. 960   S(N-1)=S(N) AND S(N-1) : N=N-1 : GOTO 120               ' AND
  97. 970   S(N-1)=S(N) OR S(N-1) : N=N-1 : GOTO 120                ' OR
  98. 980   S(N-1)=S(N) NOT S(N-1) : N=N-1 : GOTO 120               ' NOT
  99. 990   N=N+1 : S(N)=S(N-1) : GOTO 120                          ' DUP
  100. 1000  IF S(N)<>0 THEN S(N+1)=S(N) : N=N+1 : GOTO 120          ' -DUP
  101. 1010  N=N-1 : GOTO 120                                        ' DROP
  102. 1020  S(N+1)=S(N-1) : S(N-1)=S(N) : S(N)=S(N+1) : GOTO 120    ' SWAP
  103. 1030  N=N+1 : S(N)=S(N-2) : GOTO 120                          ' OVER
  104. 1040  A=S(N) : S(N)=S(N-2) : S(N-2)=S(N-1) 
  105. 1050  S(N-1)=A : GOTO 120                                     ' ROT
  106. 1060  S(N)=S(N-S(N)) : GOTO 120                               ' PICK
  107. 1070  N=N+1 : S(N)=R(M) : GOTO 120                            ' R
  108. 1080  M=M+1 : R(M)=S(N) : N=N-1 : GOTO 120                    ' >R
  109. 1090  N=N+1 : S(N)=R(M) : M=M-1 : GOTO 120                    ' R>
  110. 1100  N=N+1 : S(N)=R(M) : GOTO 120                            ' I
  111. 1110  M=M+1 : R(M)=L(K) : M=M+1 : R(M)=S(N-1) : M=M+1         ' DO
  112. 1120  R(M)=S(N) : N=N-2 : GOTO 120
  113. 1130  N=N+1 : S(N)=1                                          ' LOOP
  114. 1140  R(M)=R(M)+S(N) : N=N-1                                  ' +LOOP
  115. 1150  IF R(M-1) > R(M) THEN L(K)=R(M-2) ELSE M=M-3
  116. 1160  GOTO 120
  117. 1170  N=N-1 : IF S(N+1) THEN GOTO 120                         ' IF
  118. 1180  FOR I=L(K) TO LO(K) : B$=MID$(F$,I,4)
  119. 1190  IF B$="ELSE" OR B$="THEN" THEN L(K)=I+4 : GOTO 120
  120. 1200  NEXT I : PRINT "  IF ? " : GOTO 60
  121. 1210  GOTO 1180                                               ' ELSE
  122. 1220  GOTO 120                                                ' THEN
  123. 1230  M=M+1 : R(M)=L(K) : GOTO 120                            ' BEGIN
  124. 1240  N=N-1                                                   ' UNTIL
  125. 1250  IF S(N+1) THEN M=M-1 : GOTO 120
  126. 1260  L(K)=R(M) : GOTO 120
  127. 1270  END                                                     ' END
  128. 1280  PRINT : GOTO 120                                        ' CR
  129. 1290  PRINT CHR$(32); : N=N-1 : GOTO 120                      ' SPACE
  130. 1300  PRINT SPC(S(N)); : N=N-1 : GOTO 120                     ' SPACES
  131. 1310  PRINT CHR$(S(N)); : N=N-1 : GOTO 120                    ' EMIT
  132. 1320  I=0 
  133. 1330  GOTO 1360 : ' WHILE                                       ." &
  134. 1340  I=I+1
  135. 1350  PRINT CHR$(ASC(MID$(F$,L(K)+I,1)));
  136. 1360  IF ASC(MID$(F$,L(K)+I+1,1))<>34 GOTO 1340 : ' WEND
  137. 1370  L(K)=L(K)+I+1 : GOTO 120
  138. 1380  CON=1 : GOTO 1400                                       ' CONSTANT
  139. 1390  VAR=1                                                   ' VARIABLE
  140. 1400  C=C+1 : WORT$(C)="" : DEF$(C)=""                        ' : & ;
  141. 1410  I=0 
  142. 1420  GOTO 1440 : ' WHILE 
  143. 1430  I=I+1 : WORT$(C)=WORT$(C)+MID$(F$,L(K)+I,1)
  144. 1440  IF ASC(MID$(F$,L(K)+I+1,1))<>32 GOTO 1430 : ' WEND
  145. 1450  L(K)=L(K)+I+1
  146. 1460  IF CON THEN DEF$(C)=STR$(S(N))+" ":CON=0:N=N-1:GOTO 1540
  147. 1470  IF VAR THEN DEF$(C)=STR$(RAM)+" " : POKE RAM,S(N)
  148. 1480  IF VAR THEN RAM=RAM+2 : N=N-1 : VAR=0 : GOTO 1540
  149. 1490  I=0 
  150. 1500  GOTO 1520 : ' WHILE
  151. 1510  I=I+1 : DEF$(C)=DEF$(C)+MID$(F$,L(K)+I,1)
  152. 1520  IF ASC(MID$(F$,L(K)+I+1,1))<>59 GOTO 1510 : ' WEND
  153. 1530  L(K)=L(K)+I+1
  154. 1540  FOR Z=1 TO C-1
  155. 1550  IF WORT$(C)=WORT$(Z) THEN PRINT WORT$(C),"ISN'T UNIQUE"
  156. 1560  NEXT Z
  157. 1570  IF LEFT$(DEF$(C),7)<>"<BUILDS" THEN GOTO 120             ' <BUILDS
  158. 1580  F$=F$+RIGHT$(DEF$(C),(LEN(DEF$(C))-7)) : K=K+1 : GOTO 110
  159. 1590  DEF$(C)=RIGHT$(DEF$(C),LO(K)-L(K)) : GOTO 70            ' DOES>
  160. 1600  FORGET=1 : GOTO 120                                      ' FORGET
  161. 1610  C=KERNEL : GOTO 120                                      ' NEW
  162. 1620  S(N)=PEEK(S(N)) : GOTO 120                               ' @
  163. 1630  PRINT PEEK(S(N)) : N=N-1 : GOTO 120                      ' ?
  164. 1640  POKE S(N),S(N-1) : N=N-2 : GOTO 120                      ' !
  165. 1650  POKE S(N),(PEEK(S(N))+S(N-1)) : N=N-2 : GOTO 120         ' +!
  166. 1660  FOR Z=0 TO S(N)-1                                        ' MOVE
  167. 1670  POKE S(N-1)+2*Z,PEEK(S(N-2)+2*Z) : NEXT Z : N=N-3 : GOTO 120
  168. 1680  X=S(N) : N=N-1 : GOTO 1700                               ' FILL
  169. 1690  X=0                                                      ' ERASE
  170. 1700  FOR Z=S(N-1) TO S(N-1)+2*S(N)-2 STEP 2                   ' BLANKS
  171. 1710  POKE Z,X : NEXT Z : N=N-2 : X=32 : GOTO 120
  172. 1720  FOR Z=S(N-1) TO S(N-1)+2*S(N)-2 STEP 2                   ' DUMP
  173. 1730  PRINT PEEK(Z); " " ; :NEXT Z : N=N-2 : GOTO 120
  174. 1740  X$=INPUT$(1) : N=N+1 : S(N)=ASC(X$) : GOTO 120           ' KEY
  175. 1750  X$=" " : TIB$="" : X=0                                   ' QUERY
  176. 1760  GOTO 1780 : ' WHILE
  177. 1770  X=X+1 : X$=INPUT$(1) : POKE TIB+2*X,ASC(X$)
  178. 1780  IF ASC(X$)<>13 GOTO 1770 : ' WEND 
  179. 1790  POKE TIB,X : SPAN=X-1 : GOTO 120
  180. 1800  X$=" " : FOR Z=1 TO S(N) : X$=INPUT$(1)                  ' EXPECT
  181. 1810  IF ASC(X$)=13 THEN GOTO 1830
  182. 1820  POKE S(N-1)+(2*Z-2),ASC(X$) : NEXT Z
  183. 1830  N=N-2 : SPAN=Z-1 : GOTO 120
  184. 1840  FOR Z=S(N-1) TO S(N-1)+2*S(N)-2 STEP 2                   ' TYPE
  185. 1850  PRINT CHR$(PEEK(Z)); : NEXT Z : N=N-2 : GOTO 120
  186. 1860  I=0 : 
  187. 1870  GOTO 1890 : ' WHILE                                        WORD
  188. 1880  I=I+1 : POKE TIB+2*I,ASC(MID$(F$,L(K-1)+I,1))
  189. 1890  IF ASC(MID$(F$,L(K-1)+I+1,1)) <> S(N) GOTO 1880 : ' WEND
  190. 1900  SPAN=I : POKE TIB,I : N=N-1 : L(K-1)=L(K-1)+I+1 : GOTO 120
  191. 1910  N$="" : FOR Z=1 TO PEEK(S(N))                             ' NUMBER
  192. 1920  N$=N$+CHR$(PEEK(S(N)+2*Z)) : NEXT Z : S(N)=VAL(N$) : GOTO 120
  193. 1930  N=N+1 : S(N)=TIB : GOTO 120                               ' TIB
  194. 1940  N=N+1 : S(N)=SPAN : GOTO 120                              ' SPAN
  195. 1950  N=N+1 : S(N)=32 : GOTO 120                                ' BL
  196. 1960  '
  197. 1970  '      I  N  I  T  I  A  L  I  S  I  E  R  U  N  G
  198. 1980  CLEAR
  199. 1990  DIM S(100),R(100),L(100),LO(100),WORT$(100),DEF$(100)
  200. 2000  PRINT : PRINT "BASIC - FORTH"
  201. 2010  OPTION BASE 0
  202. 2020  KERNEL=75 : C=KERNEL : FORGET=0 : X=32 : RAM=300000 : TIB=350000
  203. 2030  FOR Z=1 TO KERNEL : READ WORT$(Z) : NEXT Z
  204. 2040  '
  205. 2050  DATA WORDS,VIEW,+,-,*,/,MOD,/MOD,*/,*/MOD,ABS,MINUS,.S,.
  206. 2060  DATA CLS,MIN,MAX,=,>,<,<>,<=,>=,AND,OR,NOT,DUP,-DUP,DROP
  207. 2070  DATA SWAP,OVER,ROT,PICK,R,>R,R>,I,DO,LOOP,+LOOP,IF,ELSE,THEN
  208. 2080  DATA BEGIN,UNTIL,END,CR,SPACE,SPACES,EMIT,.",CONSTANT,VARIABLE
  209. 2090  DATA :,DOES>,FORGET,NEW,@,?,!,+!,MOVE,FILL,ERASE,BLANKS,DUMP
  210. 2100  DATA KEY,QUERY,EXPECT,TYPE,WORD,NUMBER,TIB,SPAN,BL
  211. 2110  ' !!! ALLE BEFEHLE IN GROSSBUCHSTABEN !!!
  212. 2120  RETURN
  213.