home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / forth / fifth.arc / ASSIGN.FIV < prev    next >
Text File  |  1986-03-18  |  13KB  |  412 lines
  1. CREATE X
  2. CREATE ^
  3. EDIT
  4. \ This exponent program does not work well on numbers close to zero.
  5. \ For example, .01 2. ^  yields:  .0000709  (It should be .0001)
  6. \
  7. \ We wrote a ^ module that works fine, but I don't have it. Put yours
  8. \ in instead of this one.
  9.  
  10. : ^
  11.   swap flog f* fexp
  12. ;
  13. ~UP
  14. CREATE STACK
  15. CREATE BUFF
  16. EDIT
  17. create buff 1024 allot
  18. ~UP
  19. CREATE TOP
  20. EDIT
  21. variable top
  22. ~UP
  23. CREATE WORDST
  24. EDIT
  25. variable wordst
  26. ~UP
  27. EDIT
  28. : stack
  29. \ This is a universal stack word. I will explain by example:
  30. \    stack  A|AA        \ is the same as DUP
  31. \    stack  abc|bca     \ is the same as ROT
  32. \    stack  ABCD|       \ is the same as 2DROP 2DROP
  33. \    stack  ab|ababba   \ is the same as 2DUP 2DUP SWAP
  34. \    stack  ABCD|CDBA   \ is the same as 3 ROLL 3 ROLL SWAP
  35. \    stack  abc|abcabc  \ is the same as 2 PICK 2 PICK 2 PICK
  36. \ Notice that the stack expects the Specification of action to be in all
  37. \ caps or all lower case.  Mixing the cases is not checked for, and will
  38. \ likely crash your system.  Also on the left of the `|',  number the stack
  39. \ ABCD... where A is the deepest element on the stack. On the right, you
  40. \ get to do whatever you want. The left side is limited to 26 characters,
  41. \ the right is not really limited at all. (You can overflow the stack...)
  42.  
  43. state c@ 0= if
  44.   124 word
  45.   dup c@ 0= if 0 23 gotoxy ." You got an error with stack!" abort endif
  46.   dup c@ 64 + top !
  47.   c@ 4 * 0 do
  48.     r@ buff + !
  49.   4 +loop
  50.   32 word dup 1+ wordst !
  51.   dup c@ 1 = if drop else
  52.     c@ 1 do
  53.      wordst @ i + c@ top @ - abs 2 shl        \ get offset
  54.      buff +                                   \ Abs addr
  55.      @
  56.     loop
  57.   endif
  58. else
  59.   124 word
  60.   dup c@ 0= if 0 23 gotoxy ." You got an error with stack!" abort endif
  61.   dup c@ 64 + top !
  62.   [compile] buff [compile] drop            \ insure buff's compilation.
  63.   c@ 4 * 0 do
  64.     i buff + ['] literal execute [compile] !
  65.   4 +loop
  66.   32 word dup 1+ wordst !
  67.   dup c@ 1 = if drop else
  68.     c@ 1 do
  69.       wordst @ i + c@ top @ - abs 2 shl        \ get offset
  70.       buff + ['] literal execute               \ Abs addr
  71.       [compile] @
  72.     loop
  73.   endif
  74. endif
  75. ;
  76. immediate
  77. ~UP
  78. CREATE :=
  79. CREATE PP
  80. EDIT
  81. \ This is a debugging print routine.
  82.  
  83.  
  84. : pp    1    \ <<<--- If this is a 1, run time trace occurs on expressions.
  85.              \                is a 2, the postfix expression is printed.
  86.              \                is none of the above, nothing happens.
  87.  
  88.  dup 1 = if                  \ Run time debugging.
  89.     drop
  90.     ['] literal execute    [compile] count   [compile] type
  91.     [compile] key          [compile] drop
  92.  else
  93.     2 = if                  \ Compile time debugging
  94.       count type
  95.     else
  96.       drop                  \ No debugging.
  97.     endif
  98.  endif
  99. ;
  100. ~UP
  101. CREATE BUFF
  102. EDIT
  103. create buff 200 allot
  104. ~UP
  105. CREATE OPLIST
  106. CREATE DEFINE
  107. CREATE STR=
  108. EDIT
  109. ( str1 str2 -> flag )
  110. \ flag = -1 if str1 = str2
  111. \      otherwise flag = 0
  112. : str=
  113. over c@ 1+ 0 do                    \ For 0 to character count do:
  114.   over c@ over c@ =
  115.   if else 2drop 0 exit endif
  116.   1+ swap 1+
  117. loop
  118. 2drop -1
  119. ;
  120. ~UP
  121. EDIT
  122. : define
  123.   create           \ Create the module.
  124.   here             \ Address of number of entries.
  125.   0 ,              \ Number of entries spot.
  126.   here             \ Addr of beginning of list.
  127.   " +" ,   ['] f+ ,      \ All arithmetic is done in floating point.
  128.   " -" ,   ['] f- ,
  129.   " *" ,   ['] f* ,
  130.   " /" ,   ['] f/ ,
  131.   " (" ,   ['] abort ,   \ Left paren.
  132.   " )" ,   ['] abort ,   \ Right paren.
  133.   " ;" ,   ['] abort ,   \ End of statement marker.
  134.   " [" ,   ['] abort ,   \ Begin subscript (or function) marker.
  135.   " ]" ,   ['] abort ,   \ Close subscript (or function) marker.
  136.   " ^" ,   ['] ^ ,       \ You must supply exponent routine.
  137.   here swap -      \ Compute length of list.
  138.   swap !           \ Save this away. (Number of entries = length/8)
  139. does>
  140.   dup 4 + swap @ 0 do
  141.     2dup @ str= if
  142.       swap drop 4 + @ i 16 + exit
  143.     endif
  144.     8 +
  145.   8 +loop
  146.   drop dup find
  147.   dup -1 = if drop swap drop 8 exit endif
  148.   dup  2 = if drop swap drop 0 exit endif
  149.        3 = if      swap drop 0 exit endif
  150.   0 24 gotoxy cr cr buff count type cr
  151.   ." Token Not Found error in := statement:  " count type cr cr abort
  152. ;
  153. ~UP
  154. EDIT
  155. \ ( string -> addr num )
  156. \ Returns the address and number of the operator or identifier.
  157. \       Operator   Num
  158. \       --------------
  159. \       constant   0
  160. \       variable   8
  161. \       +          16
  162. \       -          24
  163. \       *          32
  164. \       /          40
  165. \       (          48
  166. \       )          56
  167. \       ;          64
  168. \       [          72
  169. \       ]          80
  170. \       ^          88
  171. define oplist
  172. ~UP
  173. CREATE PREC
  174. CREATE DEFINE
  175. EDIT
  176. : define
  177.   create
  178. \       0     8     16    24    32    40    48    56    64   72     80    88
  179. \       lit   var   +     -     *     /     (     )     ;    [      ]     ^
  180. \    +----------------------------------------------------------------------
  181. ( lit) 15 c, 15 c,  0 c,  0 c,  0 c,  0 c, 15 c,  1 c,  1 c, 15 c,  1 c,  0 c,
  182. ( var) 15 c, 15 c,  0 c,  0 c,  0 c,  0 c, 15 c,  1 c,  1 c, 15 c,  1 c,  0 c,
  183. ( +  )  1 c,  1 c,  1 c,  1 c,  0 c,  0 c, 15 c,  1 c,  1 c, 15 c,  1 c,  0 c,
  184. ( -  )  1 c,  1 c,  1 c,  1 c,  0 c,  0 c, 15 c,  1 c,  1 c, 15 c,  1 c,  0 c,
  185. ( *  )  1 c,  1 c,  1 c,  1 c,  1 c,  1 c, 15 c,  1 c,  1 c, 15 c,  1 c,  0 c,
  186. ( /  )  1 c,  1 c,  1 c,  1 c,  1 c,  1 c, 15 c,  1 c,  1 c, 15 c,  1 c,  0 c,
  187. ( {  )  1 c,  1 c,  0 c,  0 c,  0 c,  0 c,  0 c,  2 c, 15 c, 15 c, 15 c,  0 c,
  188. ( }  ) 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c,
  189. ( ;  )  0 c,  0 c,  0 c,  0 c,  0 c,  0 c,  0 c, 15 c,  3 c, 15 c, 15 c,  0 c,
  190. ( [  )  1 c,  1 c,  0 c,  0 c,  0 c,  0 c,  0 c, 15 c, 15 c, 15 c,  4 c,  0 c,
  191. ( ]  ) 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c, 15 c,
  192. ( ^  )  1 c,  1 c,  1 c,  1 c,  1 c,  1 c,  0 c,  1 c,  1 c, 15 c,  1 c,  0 c,
  193. does>
  194.   rot 8 / rot 8 /
  195.   swap 12 * + dup 144 u< if else
  196.     0 24 gotoxy cr
  197.     buff count type
  198.     ." You have an ill eagle in your := statement " abort
  199.   endif
  200.   + c@
  201. ;
  202. ~UP
  203. EDIT
  204. define prec
  205. ~UP
  206. CREATE EXPRESS
  207. CREATE ARRAY?
  208. EDIT
  209. \ Check to see if we are dealing with an array. If so, evaluate the subscripts.
  210. : array?
  211.   >in @ 32 word oplist dup 72 = if   \ Is it an array?
  212.     "  [" pp
  213.     rot drop                         \  If so, get rid of the text pointer.
  214.     express                          \ Evaluate the subscript expression.
  215.   else
  216.     2drop >in !                      \ Restore the text pointer if it's not
  217.   endif                              \   an array.
  218. ;
  219. ~UP
  220. CREATE REDUCE
  221. EDIT
  222. \ Reduces an operator.
  223. : reduce
  224.   stack ABCD|ABCDBD
  225.   prec                                       \ Get precedence code.
  226.   dup 1 = if                                 \ 1 = Reduce an operator.
  227.     stack ABCDE|CDA
  228.     "  &" pp
  229.     ['] literal execute [compile] execute
  230.     reduce exit
  231.   endif
  232.   dup 4 = if                                 \ End a subscript.
  233.     "  ]" pp
  234.     drop 2drop 2drop                         \ Drop brackets, and
  235.     array? exit                              \  check for more subscripts.
  236.   endif
  237.   dup 2 = if drop 2drop 2drop exit endif     \ Remove paren's from stack.
  238.   dup 15 = if                                \ An ill eagle state found.
  239.     0 24 gotoxy cr cr buff count type cr
  240.     ." I can't figure out your := statement.  Sorry." cr cr abort
  241.   endif
  242.   3 = if exit endif                          \ End of statement found.
  243.   express
  244. ;
  245. ~UP
  246. EDIT
  247. \ ( -> ) Compiles an expression pointed to by >in.
  248. : express
  249.   32 word oplist                           \ Get a token.
  250.   dup 0 = if drop "  c" pp ['] literal execute else \ Compile a constant.
  251.     dup 8 = if drop                        \ This is a variable or array.
  252.       array?                               \ Compile subscripts if an array.
  253.       "  a" pp
  254.       ['] literal execute                  \ Compile execution address.
  255.       [compile] execute [compile] @ else   \ Compile an EXECUTE and a Fetch.
  256.       dup 48 = if express else
  257.         dup 56 = if reduce express else    \ End of parenthesis?
  258.           0 24 gotoxy cr cr buff count type cr
  259.           ." Something is out of order in your := statement! " cr cr abort
  260.         endif
  261.       endif
  262.     endif
  263.   endif
  264.   32 word oplist reduce                    \ Reduce operators.
  265. ;
  266. ~UP
  267. EDIT
  268. ( addr -> )
  269. \ Compiles the following expression storing the results at addr. The expression
  270. \ is terminated by a semicolon. If any thing is not in the operator list, it is
  271. \ considered a variable.  You can easily die if you mess up and put a module in
  272. \ as a variable.
  273.  
  274. : :=
  275.   state c@ 0 = if
  276.     0 24 gotoxy cr cr
  277.     ." Assignment statments are only allowed in compile mode."
  278.     cr abort
  279.   endif
  280.   >in @ 10 text >in !
  281.   pad 1- buff 150 cmove            \ Save the expression for error messages.
  282.   ['] abort 64
  283.   express
  284.   2drop 2drop
  285.   [compile] swap [compile] !
  286.   1 >in +!
  287. ; immediate
  288. ~UP
  289. CREATE README
  290. CREATE A
  291. EDIT
  292. variable a
  293. ~UP
  294. CREATE B
  295. EDIT
  296. variable b
  297. ~UP
  298. CREATE C
  299. EDIT
  300. variable c
  301. ~UP
  302. CREATE D
  303. CREATE DEFINE
  304. EDIT
  305. \ The execution of this module will create a array which takes a subscript
  306. \ from the stack and returns the address of that element.
  307.  
  308. : define
  309.   create                 \ Create a module.
  310.   10 4 * allot           \ Allot room for 10 elements, 4 bytes each.
  311. does>                    \ Define this module's run time behavior.
  312.                          \  ( Remember that the address of beginning of the 10
  313.                          \    elements allotted above has been pushed on the
  314.                          \    stack prior to this code. )
  315.  
  316.   swap dup 10 u< if else   \ Do range checking.
  317.     ." Out of range" abort
  318.   endif
  319.   4 * +                \ Multiply the subscript by 4, add to beginning address.
  320.  ;
  321. ~UP
  322. EDIT
  323. ( subscript -> address )
  324. \ D is a 10 element array.  See DEFINE below for D's definition.
  325. \ Takes the subscript and returns the address of that element.
  326.  
  327. define d
  328. ~UP
  329. CREATE E
  330. CREATE DEFINE
  331. EDIT
  332. \ The execution of this module will create a array which takes two subscripts
  333. \ from the stack and returns the address of that element.
  334.  
  335. : define
  336.   create                 \ Create a module.
  337.   5 4 * dup * allot      \ Allot room for a 5x5 array, each element is 4 bytes.
  338. does>                    \ Define this module's run time behavior.
  339.                          \  ( Remember that the address of beginning of the
  340.                          \    first element has been pushed on the stack
  341.                          \    on top of the subscripts prior to the execution
  342.                          \    of this code. )
  343.   stack abc|cabab        \ Put subscripts on top of stack, address on bottom.
  344.   5 u< swap 5 u< and     \ Are both subscripts under 5?
  345.   if else                \ If not, you have an error.
  346.     ." Out of range" abort
  347.   endif
  348.   4 * +                \ Multiply the subscript by 4, add to beginning address.
  349.  ;
  350. ~UP
  351. EDIT
  352. ( subscript subscript -> address )
  353. \ Expects two subscripts, returns address of the specified element.
  354. \ E is a 5x5 array.  See DEFINE for the defintion.
  355. define e
  356. ~UP
  357. CREATE K
  358. EDIT
  359. variable k
  360. ~UP
  361. EDIT
  362. : readme
  363.  
  364. \ These are some examples of expressions.
  365.  
  366. a := 3.5 + 1.0 + -6.7 - 8.001 * 3.5 + 7.6 ;
  367.  
  368. \ Every token ( a number, operator, variable ) MUST be seperated by a space.
  369. \ Notice that the numbers MUST be real if they are to be used in
  370. \ arithmetic. (i.e. must have a decimal point.) This could be changed by
  371. \ going into OPLIST under :=, and doing a conversion to floating point if
  372. \ OPLIST finds an integer.  The reason I didn't do the conversion is
  373. \ illistrated in the next example.
  374.  
  375. 5 0 do
  376. i k !
  377.   3 d     := 7.5 ;
  378.   2 k @ e := 9.6 ;
  379.   3 d     := d [ 3 ] + e [ 2 ] [ k ] ;
  380. loop
  381.  
  382. \ Notice that to the left of the := you use Fifth code to get the address
  383. \ the results of the expression are to be stored at.  On the right, notice
  384. \ the subscript of the array must be an integer. (The overhead of converting
  385. \ real subscripts to integers is a bit too much overhead, speed wise.)
  386. \ Notice how pairs of subscripts can be specified.   This is the same as
  387. \ Basic's  e(2,5).  This is the same notation C uses.  The subscripts are
  388. \ handled by the array, NOT by :=.  See E ad D's definition.
  389. \ Another limitation is that I can not be used as a subscript.  Store I in
  390. \ a convienent variable, then use the variable.
  391.  
  392. a := 5. + 2. * 0. ;          \ Same as a := 5. + ( 2. * 0. ) ;
  393. c := a + a * 2. ^ 3. ^ 2. ;  \ Same as a := a + ( a * ( 2. ^ ( 3. ^ 2. ) ) ) ;
  394.  
  395. \ The order of operations between operators hold. A little "behind the scenes"
  396. \ explaination is in order now.  What does the := module do? Given the
  397. \ following:
  398. \
  399. \      := 4. + 3. * 7.
  400. \
  401. \ The := module compiles the code to do:
  402. \
  403. \      4. 3. 7. f* f+ swap !
  404. \
  405. \ Thus If you neglect to leave a valid address on the stack, := is going to
  406. \ blow up.  Also, if you specify a procedure instead of a variable, your
  407. \ system will most likely crash.
  408. ;
  409. ~UP
  410. EDIT
  411. ~UP
  412. ABORT