/fth/misc1.fth

https://github.com/philburk/pforth · Forth · 180 lines · 158 code · 22 blank · 0 comment · 2 complexity · 406157f43b54fab874a2ab4eacd4dfaa MD5 · raw file

  1. \ @(#) misc1.fth 98/01/26 1.2
  2. \ miscellaneous words
  3. \
  4. \ Author: Phil Burk
  5. \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
  6. \
  7. \ Permission to use, copy, modify, and/or distribute this
  8. \ software for any purpose with or without fee is hereby granted.
  9. \
  10. \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  11. \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  12. \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  13. \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  14. \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  15. \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  16. \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  17. \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  18. anew task-misc1.fth
  19. decimal
  20. : >> rshift ;
  21. : << lshift ;
  22. : (WARNING") ( flag $message -- )
  23. swap
  24. IF count type
  25. ELSE drop
  26. THEN
  27. ;
  28. : WARNING" ( flag <message> -- , print warning if true. )
  29. [compile] " ( compile message )
  30. state @
  31. IF compile (warning")
  32. ELSE (warning")
  33. THEN
  34. ; IMMEDIATE
  35. : (ABORT") ( flag $message -- )
  36. swap
  37. IF
  38. count type cr
  39. err_abortq throw
  40. ELSE drop
  41. THEN
  42. ;
  43. : ABORT" ( flag <message> -- , print warning if true. )
  44. [compile] " ( compile message )
  45. state @
  46. IF compile (abort")
  47. ELSE (abort")
  48. THEN
  49. ; IMMEDIATE
  50. : ?PAUSE ( -- , Pause if key hit. )
  51. ?terminal
  52. IF key drop cr ." Hit space to continue, any other key to abort:"
  53. key dup emit BL = not abort" Terminated"
  54. THEN
  55. ;
  56. 60 constant #cols
  57. : CR? ( -- , do CR if near end )
  58. OUT @ #cols 16 - 10 max >
  59. IF cr
  60. THEN
  61. ;
  62. : CLS ( -- clear screen )
  63. 40 0 do cr loop
  64. ;
  65. : PAGE ( -- , clear screen, compatible with Brodie )
  66. cls
  67. ;
  68. : $ ( <number> -- N , convert next number as hex )
  69. base @ hex
  70. bl lword number? num_type_single = not
  71. abort" Not a single number!"
  72. swap base !
  73. state @
  74. IF [compile] literal
  75. THEN
  76. ; immediate
  77. : .HX ( nibble -- )
  78. dup 9 >
  79. IF $ 37
  80. ELSE $ 30
  81. THEN + emit
  82. ;
  83. variable TAB-WIDTH 8 TAB-WIDTH !
  84. : TAB ( -- , tab over to next stop )
  85. out @ tab-width @ mod
  86. tab-width @ swap - spaces
  87. ;
  88. \ Vocabulary listing
  89. : WORDS ( -- )
  90. 0 latest
  91. BEGIN dup 0<>
  92. WHILE dup id. tab cr? ?pause
  93. prevname
  94. swap 1+ swap
  95. REPEAT drop
  96. cr . ." words" cr
  97. ;
  98. : VLIST words ;
  99. variable CLOSEST-NFA
  100. variable CLOSEST-XT
  101. : >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
  102. 0 closest-nfa !
  103. 0 closest-xt !
  104. latest
  105. BEGIN dup 0<>
  106. IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
  107. IF true ( addr below this cfa, can't be it)
  108. ELSE ( -- addr nfa )
  109. 2dup name> ( addr nfa addr xt ) =
  110. IF ( found it ! ) dup closest-nfa ! false
  111. ELSE dup name> closest-xt @ >
  112. IF dup closest-nfa ! dup name> closest-xt !
  113. THEN
  114. true
  115. THEN
  116. THEN
  117. ELSE false
  118. THEN
  119. WHILE
  120. prevname
  121. REPEAT ( -- cfa nfa )
  122. 2drop
  123. closest-nfa @
  124. ;
  125. : @EXECUTE ( addr -- , execute if non-zero )
  126. x@ ?dup
  127. IF execute
  128. THEN
  129. ;
  130. : TOLOWER ( char -- char_lower )
  131. dup ascii [ <
  132. IF dup ascii @ >
  133. IF ascii A - ascii a +
  134. THEN
  135. THEN
  136. ;
  137. : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
  138. \ save current input state and switch to passed in string
  139. source >r >r
  140. set-source
  141. -1 push-source-id
  142. >in @ >r
  143. 0 >in !
  144. \ interpret the string
  145. interpret
  146. \ restore input state
  147. pop-source-id drop
  148. r> >in !
  149. r> r> set-source
  150. ;
  151. : \S ( -- , comment out rest of file )
  152. source-id
  153. IF
  154. BEGIN \ using REFILL is safer than popping SOURCE-ID
  155. refill 0=
  156. UNTIL
  157. THEN
  158. ;