home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / utils / utils.utf (.txt) < prev    next >
Encoding:
Null Bytes Alternating  |  1995-05-19  |  9.5 KB  |  175 lines
  1. \ utils.utf .. basic utilities for Jax4th
  2. \ Copyright (c)1994 Jack J. Woehr
  3. \ P.O. Box 51, Golden, Colorado 80402-0051
  4. \ jax@well.sf.ca.us 72203.1320@compuserve.com
  5. \ SYSOP RCFB (303) 278-0364 2400/9600/14400
  6. \ All Rights Reserved
  7. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  8. \ This is free software and can be modified and redistributed under
  9. \ certain conditions described in the file COPYING.TXT. The
  10. \ Disclaimer of Warranty and License for this free software are also
  11. \ contained in the file COPYING.TXT.
  12. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  13.  
  14. \
  15. \ $Log: utils.f,v $
  16. \ Revision 1.5  1994/10/11  01:43:01  jax
  17. \ Removed DEFER in favor of one in DEFER.UTF.
  18. \
  19. \ Revision 1.4  1994/08/26  15:30:43  jax
  20. \ Fixed VOCABULARY.
  21. \
  22. \
  23.  
  24. \ Standard information:
  25. \ A lot of the code in this file is very implementation dependent.
  26. \
  27.  
  28. MARKER utils.utf
  29.  
  30. \ ~~~~~~~~~~~~~~~~~
  31. \ General utilities
  32. \ ~~~~~~~~~~~~~~~~~
  33.  
  34. DECIMAL
  35.  
  36. \ This is from the Toolkit wordset.
  37. : .( [CHAR] ) PARSE TYPE ; IMMEDIATE
  38.  
  39. CR .( Loading Utilities) CR
  40.  
  41. \ Usage: INCLUDE path\path\filename.utf
  42. : INCLUDE ( "ccc<>" -- ) BL WORD COUNT INCLUDED ;
  43.  
  44. \ double constant
  45. : DCONSTANT ( Compile: d|ud name --  Name Execute: -- d|ud)
  46.    CREATE , , DOES> 2@ ;
  47.  
  48. \ cell array
  49. : ARRAY ( n --)
  50.    CREATE CELLS ALLOT
  51.    DOES> ( n - i) SWAP CELLS + ;
  52.  
  53. \ Type a possibly null-terminated string
  54. : 0TYPE ( c-addr u --)
  55.     0
  56.     ?DO
  57.         DUP I CHARS +   \ -- c-addr c-addr'
  58.         C@ ?DUP         \ -- c-addr char char|--
  59.         IF              \ -- c-addr char
  60.             EMIT        \ -- c-addr
  61.         ELSE            \ -- c-addr
  62.             LEAVE       \ -- c-addr
  63.         THEN
  64.     LOOP DROP           \ --
  65. ;
  66.  
  67. \ ~~~~~~~~~~~~~~~~~~~~~~~~
  68. \ BLOCK loading extensions
  69. \ ~~~~~~~~~~~~~~~~~~~~~~~~
  70.  
  71. \ Load relative to current contents of BLK
  72. : +LOAD ( n --) BLK @ + LOAD ;                        
  73. : +THRU ( n1 n2 --) BLK @ TUCK + >R + R> THRU ;
  74.  
  75. \ ~~~~~~~~~~~~
  76. \ Search order
  77. \ ~~~~~~~~~~~~
  78.  
  79. \ Set a reasonable order.
  80. : USEFUL ( --)                                        
  81.     SYSTEM-WORDLIST NONSTANDARD-WORDLIST FORTH-WORDLIST
  82.     3 SET-ORDER DEFINITIONS ;
  83.  
  84. \ Analogous to ALSO but takes a wordlist identifier argument.
  85. : ALSO-WID ( wid --)
  86.     >R GET-ORDER R> SWAP 1+ SET-ORDER ;                
  87.  
  88. \ Set the order to include all the Jax4th system wordlists.
  89. : ALL ( --) USEFUL INTERNALS-WORDLIST ALSO-WID ;
  90.     
  91.  
  92. \ ~~~~~~~~~~~~~~~~~~~
  93. \ Some Error Handling
  94. \ ~~~~~~~~~~~~~~~~~~~
  95.  
  96. DECIMAL
  97.  
  98. \ Stick these error codes in the Nonstandard wordlist.
  99. USEFUL NONSTANDARD-WORDLIST SET-CURRENT
  100.  
  101. -03 CONSTANT stack_under_throw
  102. -37 CONSTANT file_io_throw
  103. -50 CONSTANT search_order_underflow_throw
  104. -256 CONSTANT sys_throw_0
  105. -300 CONSTANT invalid_xt
  106.  
  107. \ check for sufficient args
  108. : ?ENOUGH ( i*j n -- i*j | throw)
  109.    DEPTH 1- > stack_under_throw AND THROW ;
  110.  
  111. \ ~~~~~~~~~~~~~~~~~~
  112. \ Named vocabularies
  113. \ ~~~~~~~~~~~~~~~~~~
  114.  
  115. USEFUL
  116.  
  117. : SET-CONTEXT ( wid --)
  118.     >R GET-ORDER
  119.     DUP 0= search_order_underflow_throw AND THROW
  120.     NIP R> SWAP SET-ORDER ; \ /\/\ shd. == 0 THROW normally
  121.  
  122. INTERNALS-WORDLIST ALSO-WID
  123.  
  124. \ Create a named wordlist, then create a word of the same name emulating F83 VOCABULARY
  125. : VOCABULARY ( "ccc< >" --)
  126.     >IN @                           \ -- u, save pointer to input for recreating name
  127.     BL WORD COUNT NAMEWORDLIST      \ -- u wid
  128.     SWAP >IN !                      \ -- wid, restore input pointer for second create of same name
  129.     ABSTODATA DATATOCODE            \ -- adr, this is a code-relative address
  130.     CREATE ,                        \ -- create the named voc and save c-r-addr
  131.     DOES> ( -- wid)
  132.         @ CODETOABS SET-CONTEXT     \ -- at runtime, recalc wid from code-relative addr
  133. ;
  134.  
  135. \ ~~~~~~~~~~~~~~~~~~~~
  136. \ More on ENVIRONMENT?
  137. \ ~~~~~~~~~~~~~~~~~~~~
  138.  
  139. USEFUL HEX
  140.  
  141. \ Create a wordlist in which all the ENVIRONMENT? queries live.
  142. S" ENVIRONMENT" NAMEWORDLIST DROP
  143.  
  144. \ A redefinition of ENVIRONMENT?
  145. \ Maybe this should be moved back into the kernel
  146. : ENVIRONMENT? ( c-addr u -- false | i*x true)
  147.    ENVIRONMENT SEARCH-WORDLIST
  148.    IF EXECUTE TRUE ELSE FALSE THEN ;
  149.  
  150. \ The constants found by the queries.
  151. ENVIRONMENT ALSO-WID DEFINITIONS
  152.  
  153. \ These are all from dpANS-5 3.2.6
  154. FFFD CONSTANT /COUNTED-STRING
  155.   80 CONSTANT /HOLD
  156.   80 CONSTANT /PAD
  157.   08 CONSTANT ADDRESS-UNIT-BITS
  158. TRUE CONSTANT CORE
  159. FALSE CONSTANT CORE-EXT
  160. FALSE CONSTANT FLOORED
  161. FFFD CONSTANT MAX-CHAR
  162. 7FFFFFFFFFFFFFFF. DCONSTANT MAX-D
  163. 7FFFFFFF CONSTANT MAX-N
  164. FFFFFFFF CONSTANT MAX-U
  165. FFFFFFFFFFFFFFFF. DCONSTANT MAX-UD
  166. 1000 CONSTANT RETURN-STACK-CELLS \ may change
  167. 1000 CONSTANT STACK-CELLS   \ ditto
  168.  
  169. DECIMAL PREVIOUS DEFINITIONS
  170.  
  171. \ ~~~~~~~~~~~~~~
  172. \ End of utils.f
  173. \ ~~~~~~~~~~~~~~
  174.  
  175.