home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / utils / case.utf (.txt) next >
Encoding:
Null Bytes Alternating  |  1995-05-19  |  6.5 KB  |  124 lines
  1. \ case.utf ..
  2. \ implement CORE EXTENSIONS construct CASE .. OF .. ENDOF .. ENDCASE
  3. \ ANS Forth compliant source code is Copyright (c)1994 by
  4. \ Jack J. Woehr, P.O. Box 51, Golden, Colorado 80402-0051
  5. \ jax@well.sf.ca.us 72203.1320@compuserve.com
  6. \ SYSOP RCFB (303) 278-0364 2400/9600/14400
  7. \ All Rights Reserved
  8. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  9. \ This is free software and can be modified and redistributed under
  10. \ certain conditions described in the file COPYING.TXT. The
  11. \ Disclaimer of Warranty and License for this free software are also
  12. \ contained in the file COPYING.TXT.
  13. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  14.  
  15. \
  16. \ $Revision: 1.3 $
  17. \
  18.  
  19. \   There persists a standard system after loading CASE.UTF.
  20. MARKER case.utf
  21.  
  22. \ Dependencies:
  23. \   For infotext display while loading this file, and for its particular handling
  24. \   of the compilation vocabulary into which non-Standard factors are deposited,
  25. \   but for no algorithm of substance, this file is dependent upon the material
  26. \   in //jax4th/utils/.
  27.  
  28. \ ~~~~~~~~~~~~~~~~~~~~
  29. \ Conditional INCLUDED
  30. \ ~~~~~~~~~~~~~~~~~~~~
  31.  
  32. : PROVIDES ( c-addr u "ccc< >" --)
  33.     BL WORD FIND NIP 0=
  34.     IF INCLUDED ELSE 2DROP THEN ;
  35.  
  36. S" UTILS\UTILS.UTF" PROVIDES USEFUL
  37.  
  38. .( Now loading CASE construct.) CR
  39.  
  40. \ ifdef (wordlists to hide thingies like \vvvv/) {
  41. USEFUL
  42. NONSTANDARD-WORDLIST SET-CURRENT
  43. \ }endif
  44.  
  45. \ A factoring of how CASE handles the case selector.
  46. : TRUTH|DARE ( x1 x2 -- [x1 FALSE] | TRUE)
  47.     OVER =      \ --  x1 flag
  48.     IF          \ -- x1
  49.         DROP TRUE   \ -- TRUE
  50.     ELSE        \ -- x1
  51.         FALSE       \ -- x1 FALSE
  52.     THEN
  53. ;
  54.  
  55. \  ... ['] THEN ... is not a legal construct: xt's returned
  56. \ by ticking Standard words possessing special compilation
  57. \ semantics aren't guaranteed to be useful in any particular context.
  58. : ]THEN[ POSTPONE THEN ;
  59. \ See ENDOF
  60.  
  61. \ ifdef (wordlists to hide thingies like /^^^^\) {
  62. FORTH-WORDLIST SET-CURRENT
  63. \ }endif
  64.  
  65. : OF ( C: -- of-sys)  ( Runtime: x1 x2 -- |x1)
  66.     POSTPONE TRUTH|DARE POSTPONE IF ; IMMEDIATE
  67.  
  68. : ENDOF ( C: case-sys1 of-sys  -- case-sys2) ( Runtime: --)
  69.     POSTPONE EXIT
  70.     ['] ]THEN[  \ but this is legal, see ]THEN[ 
  71.     CATCH   \ This is not terribly useful yet in Jax4th
  72.     ?DUP    \ but this is the correct way this should
  73.     IF      \ be done in Standard Forth.
  74.         DUP \ In general the caller of a POSTPONE'd control
  75.         ." ENDOF THROWs " . 
  76.     THEN    \ construct should intercept any compile-time errors
  77. ; IMMEDIATE \ incurred in the course of such special handling.
  78.  
  79. : ENDCASE ( C: case-sys --) ( Runtime: x --)
  80.      POSTPONE DROP ; IMMEDIATE
  81.  
  82. : CASE ( C: -- case-sys) ; IMMEDIATE
  83.  
  84. \ ifdef wordlists {
  85. USEFUL
  86. \ } endif
  87.  
  88. \ ~~~~~~~~~~~~
  89. \   An example
  90. \ ~~~~~~~~~~~~
  91.  
  92. BASE @ DECIMAL
  93.  
  94. : ((CASE-TEST)) ( x -- )
  95.     CASE
  96.         0<
  97.         TRUE OF ." (negative)" ENDOF
  98.         ." (positive)"
  99.     ENDCASE
  100. ;
  101.  
  102. : (CASE-TEST) ( x -- )
  103.     CASE
  104.         0 OF ." Zero" ENDOF
  105.         DUP ((CASE-TEST))
  106.     ENDCASE
  107. ;
  108.  
  109. : CASE-TEST ( x -- )
  110.     CASE
  111.         DUP .
  112.         1 OF ." ONE " ENDOF
  113.         2 OF ." TWO " ENDOF
  114.         DUP (CASE-TEST) \ default
  115.     ENDCASE ( x --)
  116. ;
  117.  
  118. BASE !
  119.  
  120. \ ~~~~~~~~~~~~~~~~~
  121. \   End of CASE.UTF
  122. \ ~~~~~~~~~~~~~~~~~
  123.  
  124.