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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
\ @(#) misc1.fth 98/01/26 1.2
\ miscellaneous words
\
\ 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.
anew task-misc1.fth
decimal
: >> rshift ;
: << lshift ;
: CELL* ( n -- n*cell ) 2 lshift ;
: (WARNING") ( flag $message -- )
swap
IF count type
ELSE drop
THEN
;
: WARNING" ( flag <message> -- , print warning if true. )
[compile] " ( compile message )
state @
IF compile (warning")
ELSE (warning")
THEN
; IMMEDIATE
: (ABORT") ( flag $message -- )
swap
IF count type cr abort
ELSE drop
THEN
;
: ABORT" ( flag <message> -- , print warning if true. )
[compile] " ( compile message )
state @
IF compile (abort")
ELSE (abort")
THEN
; IMMEDIATE
: ?PAUSE ( -- , Pause if key hit. )
?terminal
IF key drop cr ." Hit space to continue, any other key to abort:"
key dup emit BL = not abort" Terminated"
THEN
;
60 constant #cols
: CR? ( -- , do CR if near end )
OUT @ #cols 16 - 10 max >
IF cr
THEN
;
: CLS ( -- clear screen )
40 0 do cr loop
;
: PAGE ( -- , clear screen, compatible with Brodie )
cls
;
: $ ( <number> -- N , convert next number as hex )
base @ hex
32 lword number? num_type_single = not
abort" Not a single number!"
swap base !
state @
IF [compile] literal
THEN
; immediate
: .HX ( nibble -- )
dup 9 >
IF $ 37
ELSE $ 30
THEN + emit
;
variable TAB-WIDTH 8 TAB-WIDTH !
: TAB ( -- , tab over to next stop )
out @ tab-width @ mod
tab-width @ swap - spaces
;
\ Vocabulary listing
: WORDS ( -- )
0 latest
BEGIN dup 0<>
WHILE dup id. tab cr? ?pause
prevname
swap 1+ swap
REPEAT drop
cr . ." words" cr
;
variable CLOSEST-NFA
variable CLOSEST-XT
: >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
0 closest-nfa !
0 closest-xt !
latest
BEGIN dup 0<>
IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
IF true ( addr below this cfa, can't be it)
ELSE ( -- addr nfa )
2dup name> ( addr nfa addr xt ) =
IF ( found it ! ) dup closest-nfa ! false
ELSE dup name> closest-xt @ >
IF dup closest-nfa ! dup name> closest-xt !
THEN
true
THEN
THEN
ELSE false
THEN
WHILE
prevname
REPEAT ( -- cfa nfa )
2drop
closest-nfa @
;
: @EXECUTE ( addr -- , execute if non-zero )
x@ ?dup
IF execute
THEN
;
: TOLOWER ( char -- char_lower )
dup ascii [ <
IF dup ascii @ >
IF ascii A - ascii a +
THEN
THEN
;
|
