home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / utils / defer.utf (.txt) < prev    next >
Encoding:
Null Bytes Alternating  |  1995-05-19  |  6.3 KB  |  86 lines
  1. \ defer.utf
  2. \ Modifiable execution vectors
  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. \ Dependencies:
  15. \       CORE EXT
  16. \       <> TRUE
  17. \ A Standard System still exists after this code is loaded.
  18. \
  19. \ $Revision: 1.2 $
  20. \
  21.  
  22. S" UTILS\UTILS.UTF" PROVIDES .(
  23.  
  24. .( Loading DEFER ) CR
  25.  
  26. MARKER defer.utf
  27.  
  28. \ A default vector for DEFERred words
  29. : CRASH ( --) TRUE ABORT" Unitialized execution vector." ;
  30.  
  31. \ A "guard word" to help identify words CREATEd by DEFER 
  32. 0 CONSTANT DEFERRED
  33.  
  34. \ Create a revectorable Forth word for a ROMmable system.
  35. \ This works in Vesta Forth Standard Edition for the SBC332.
  36. \ : ROM-DEFER ( "name" --)
  37. \    MODE? >R ROM        ( Save RAM or ROM data space mode)
  38. \    CREATE                ( CREATE ROM-style)
  39. \    RAM HERE                ( Save this RAM address as pointer to xt)
  40. \    ['] CRASH ,                ( Default init, must re-init if ROMmed)
  41. \    ROM ,               ( Save RAM execution vector pointer from HERE)
  42. \    ['] DEFERRED ,        ( Tagged as a DEFERred word by xt of DEFERRED)
  43. \    R> ?MODE                ( Restore previous mode)
  44. \    DOES> ( self-addr --)
  45. \        @ ( ram addr) @ ( xt) EXECUTE        ( Runtime action: Fetch vector & execute)
  46. \ ;
  47.  
  48. \ DEFER for RAM-only systems.
  49. \ This works in Jax4th and ZENForth.
  50. \ Yes, it would be simpler just to comma in the xt at the base of
  51. \ the CREATEd object. Using the "pointer-to" style is to illustrate
  52. \ how this construct doesn't port easily between RAM and ROM systems.
  53. : DEFER ( "name" --)
  54.         CREATE HERE 2 CELLS + ,
  55.         ['] DEFERRED ,
  56.         ['] CRASH ,
  57.         DOES> ( self-addr --)
  58.                 @ ( ptr to xt) @ ( xt) EXECUTE
  59. ;
  60.  
  61. \ Hilevel state-smart revectorer IS.
  62. \ "name" is ostensibly DEFERred word
  63. \ Verifies that word was created by DEFER
  64. \ A clever application would avoid ABORT" and use CATCH .. THROW
  65. \ Not bulletproof, since the behaviour of >BODY if passed
  66. \ the execution token for a non-CREATE word is "ambiguous",
  67. \ which could mean anything from "who cares" to ABORT.
  68. : IS ( xt "name" | "name" --)
  69.         ' >BODY DUP
  70.         CELL+ @ ['] DEFERRED <>
  71.         ABORT" IS on word not created by defer."
  72.         STATE @ ( Compiling or interpreting?)
  73.         IF      ( Compiling .. at runtime, xt will be on stack)
  74.                 @
  75.                 POSTPONE LITERAL    ( Compile vector holder address)
  76.                 POSTPONE !          ( At runtime, will store new vector)
  77.         ELSE    ( Interpreting, xt is on stack right now)
  78.                 @ !                 ( Right now store new vector) 
  79.         THEN
  80. ; IMMEDIATE
  81.  
  82. \ ~~~~~~~~~~~~~~~~
  83. \ End of DEFER.UTF
  84. \ ~~~~~~~~~~~~~~~~
  85.  
  86.