File: forget.fth

package info (click to toggle)
pforth 21-12
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, jessie, jessie-kfreebsd, stretch
  • size: 820 kB
  • ctags: 873
  • sloc: ansic: 5,050; makefile: 104
file content (97 lines) | stat: -rw-r--r-- 2,551 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
\ @(#) forget.fth 98/01/26 1.2
\ forget.fth
\
\ forget part of dictionary
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license.  The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.
\
\ 19970701 PLB Use unsigned compares for machines with "negative" addresses.

variable RFENCE    \ relocatable value below which we won't forget

: FREEZE  ( -- , protect below here )
	here rfence a!
;

: FORGET.NFA  ( nfa -- , set DP etc. )
	dup name> >code dp !
	prevname ( dup current ! ) dup context ! n>nextlink headers-ptr !
;

: VERIFY.FORGET  ( nfa -- , ask for verification if below fence )
	dup name> >code rfence a@ u<  \ 19970701
	IF
		>newline dup id. ."  is below fence!!" cr
		drop
	ELSE forget.nfa
	THEN
;

: (FORGET)  ( <name> -- )
	BL word findnfa
	IF	verify.forget
	ELSE ." FORGET - couldn't find " count type cr abort
	THEN
;

variable LAST-FORGET   \ contains address of last if.forgotten frame
0 last-forget !

: IF.FORGOTTEN  ( <name> -- , place links in dictionary without header )
	bl word find
	IF	( xt )
		here                \ start of frame
		last-forget a@ a,   \ Cell[0] = rel address of previous frame
		last-forget a!      \ point to this frame
		compile,            \ Cell[1] = xt for this frame
	ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort
	THEN
;
if.forgotten noop

: [FORGET]  ( <name> -- , forget then exec forgotten words )
	(forget)
	last-forget
	BEGIN a@ dup 0<>   \ 19970701
		IF dup here u>   \ 19970701
			IF dup cell+ x@ execute false
			ELSE dup last-forget a! true
			THEN
		ELSE true
		THEN
	UNTIL drop
;

: FORGET ( <name> -- , execute latest [FORGET] )
	" [FORGET]" find
	IF  execute
	ELSE ." FORGET - couldn't find " count type cr abort
	THEN
;

: ANEW ( -- , forget if defined then redefine )
	>in @
	bl word find
	IF over >in ! forget
	THEN drop
	>in ! variable
;

: MARKER  ( <name> -- , define a word that forgets itself when executed, ANS )
	CREATE
		latest namebase -  \ convert to relocatable
		,                  \ save for DOES>
	DOES>  ( -- body )
		@ namebase +       \ convert back to NFA
		verify.forget
;