/prods/Cognitive/p4th/forget.fth

https://github.com/createuniverses/praxis · Forth · 97 lines · 86 code · 11 blank · 0 comment · 4 complexity · 94bbaa764f0947146f5373f21b744bb6 MD5 · raw file

  1. \ @(#) forget.fth 98/01/26 1.2
  2. \ forget.fth
  3. \
  4. \ forget part of dictionary
  5. \
  6. \ Author: Phil Burk
  7. \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
  8. \
  9. \ The pForth software code is dedicated to the public domain,
  10. \ and any third party may reproduce, distribute and modify
  11. \ the pForth software code or any derivative works thereof
  12. \ without any compensation or license. The pForth software
  13. \ code is provided on an "as is" basis without any warranty
  14. \ of any kind, including, without limitation, the implied
  15. \ warranties of merchantability and fitness for a particular
  16. \ purpose and their equivalents under the laws of any jurisdiction.
  17. \
  18. \ 19970701 PLB Use unsigned compares for machines with "negative" addresses.
  19. variable RFENCE \ relocatable value below which we won't forget
  20. : FREEZE ( -- , protect below here )
  21. here rfence a!
  22. ;
  23. : FORGET.NFA ( nfa -- , set DP etc. )
  24. dup name> >code dp !
  25. prevname ( dup current ! ) dup context ! n>nextlink headers-ptr !
  26. ;
  27. : VERIFY.FORGET ( nfa -- , ask for verification if below fence )
  28. dup name> >code rfence a@ u< \ 19970701
  29. IF
  30. >newline dup id. ." is below fence!!" cr
  31. drop
  32. ELSE forget.nfa
  33. THEN
  34. ;
  35. : (FORGET) ( <name> -- )
  36. BL word findnfa
  37. IF verify.forget
  38. ELSE ." FORGET - couldn't find " count type cr abort
  39. THEN
  40. ;
  41. variable LAST-FORGET \ contains address of last if.forgotten frame
  42. 0 last-forget !
  43. : IF.FORGOTTEN ( <name> -- , place links in dictionary without header )
  44. bl word find
  45. IF ( xt )
  46. here \ start of frame
  47. last-forget a@ a, \ Cell[0] = rel address of previous frame
  48. last-forget a! \ point to this frame
  49. compile, \ Cell[1] = xt for this frame
  50. ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort
  51. THEN
  52. ;
  53. if.forgotten noop
  54. : [FORGET] ( <name> -- , forget then exec forgotten words )
  55. (forget)
  56. last-forget
  57. BEGIN a@ dup 0<> \ 19970701
  58. IF dup here u> \ 19970701
  59. IF dup cell+ x@ execute false
  60. ELSE dup last-forget a! true
  61. THEN
  62. ELSE true
  63. THEN
  64. UNTIL drop
  65. ;
  66. : FORGET ( <name> -- , execute latest [FORGET] )
  67. " [FORGET]" find
  68. IF execute
  69. ELSE ." FORGET - couldn't find " count type cr abort
  70. THEN
  71. ;
  72. : ANEW ( -- , forget if defined then redefine )
  73. >in @
  74. bl word find
  75. IF over >in ! forget
  76. THEN drop
  77. >in ! variable
  78. ;
  79. : MARKER ( <name> -- , define a word that forgets itself when executed, ANS )
  80. CREATE
  81. latest namebase - \ convert to relocatable
  82. , \ save for DOES>
  83. DOES> ( -- body )
  84. @ namebase + \ convert back to NFA
  85. verify.forget
  86. ;