[gforth] / gforth / kernel / comp.fs

gforth: gforth/kernel/comp.fs

1 :	pazsan	1.1	\ compiler definitions 14sep97jaw
2 :
3 :	anton	1.92	\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc.
4 :	anton	1.6
5 :			\ This file is part of Gforth.
6 :
7 :			\ Gforth is free software; you can redistribute it and/or
8 :			\ modify it under the terms of the GNU General Public License
9 :	anton	1.93	\ as published by the Free Software Foundation, either version 3
10 :	anton	1.6	\ of the License, or (at your option) any later version.
11 :
12 :			\ This program is distributed in the hope that it will be useful,
13 :			\ but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :			\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :			\ GNU General Public License for more details.
16 :
17 :			\ You should have received a copy of the GNU General Public License
18 :	anton	1.93	\ along with this program. If not, see http://www.gnu.org/licenses/.
19 :	anton	1.6
20 :	pazsan	1.1	\ \ Revisions-Log
21 :
22 :			\ put in seperate file 14sep97jaw
23 :
24 :			\ \ here allot , c, A, 17dec92py
25 :
26 :	jwilke	1.14	[IFUNDEF] allot
27 :			[IFUNDEF] forthstart
28 :			: allot ( n -- ) \ core
29 :			dup unused u> -8 and throw
30 :			dp +! ;
31 :			[THEN]
32 :			[THEN]
33 :
34 :			\ we default to this version if we have nothing else 05May99jaw
35 :			[IFUNDEF] allot
36 :	pazsan	1.1	: allot ( n -- ) \ core
37 :	anton	1.23	\G Reserve @i{n} address units of data space without
38 :			\G initialization. @i{n} is a signed number, passing a negative
39 :			\G @i{n} releases memory. In ANS Forth you can only deallocate
40 :			\G memory from the current contiguous region in this way. In
41 :			\G Gforth you can deallocate anything in this way but named words.
42 :			\G The system does not check this restriction.
43 :	anton	1.12	here +
44 :			dup 1- usable-dictionary-end forthstart within -8 and throw
45 :			dp ! ;
46 :	jwilke	1.14	[THEN]
47 :	pazsan	1.1
48 :	crook	1.22	: c, ( c -- ) \ core c-comma
49 :	crook	1.15	\G Reserve data space for one char and store @i{c} in the space.
50 :	pazsan	1.84	here 1 chars allot [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ;
51 :	pazsan	1.1
52 :	crook	1.22	: , ( w -- ) \ core comma
53 :	crook	1.15	\G Reserve data space for one cell and store @i{w} in the space.
54 :	pazsan	1.84	here cell allot [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ;
55 :	pazsan	1.1
56 :			: 2, ( w1 w2 -- ) \ gforth
57 :	crook	1.15	\G Reserve data space for two cells and store the double @i{w1
58 :	anton	1.24	\G w2} there, @i{w2} first (lower address).
59 :	pazsan	1.84	here 2 cells allot [ has? flash [IF] ] tuck flash! cell+ flash!
60 :			[ [ELSE] ] 2! [ [THEN] ] ;
61 :	pazsan	1.1
62 :			\ : aligned ( addr -- addr' ) \ core
63 :			\ [ cell 1- ] Literal + [ -1 cells ] Literal and ;
64 :
65 :			: align ( -- ) \ core
66 :	crook	1.15	\G If the data-space pointer is not aligned, reserve enough space to align it.
67 :	pazsan	1.1	here dup aligned swap ?DO bl c, LOOP ;
68 :
69 :	crook	1.22	\ : faligned ( addr -- f-addr ) \ float f-aligned
70 :	pazsan	1.1	\ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
71 :
72 :	crook	1.22	: falign ( -- ) \ float f-align
73 :	crook	1.15	\G If the data-space pointer is not float-aligned, reserve
74 :			\G enough space to align it.
75 :	pazsan	1.1	here dup faligned swap
76 :			?DO
77 :			bl c,
78 :			LOOP ;
79 :
80 :	anton	1.9	: maxalign ( -- ) \ gforth
81 :	anton	1.23	\G Align data-space pointer for all alignment requirements.
82 :	pazsan	1.1	here dup maxaligned swap
83 :			?DO
84 :			bl c,
85 :			LOOP ;
86 :
87 :			\ the code field is aligned if its body is maxaligned
88 :			' maxalign Alias cfalign ( -- ) \ gforth
89 :	anton	1.24	\G Align data-space pointer for code field requirements (i.e., such
90 :			\G that the corresponding body is maxaligned).
91 :	pazsan	1.1
92 :			' , alias A, ( addr -- ) \ gforth
93 :
94 :			' NOOP ALIAS const
95 :
96 :			\ \ Header 23feb93py
97 :
98 :			\ input-stream, nextname and noname are quite ugly (passing
99 :			\ information through global variables), but they are useful for dealing
100 :			\ with existing/independent defining words
101 :
102 :			defer (header)
103 :			defer header ( -- ) \ gforth
104 :			' (header) IS header
105 :
106 :			: string, ( c-addr u -- ) \ gforth
107 :			\G puts down string as cstring
108 :	pazsan	1.83	dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c,
109 :	pazsan	1.84	[ has? flash [IF] ]
110 :			bounds ?DO I c@ c, LOOP
111 :			[ [ELSE] ]
112 :			here swap chars dup allot move
113 :			[ [THEN] ] ;
114 :	pazsan	1.1
115 :	anton	1.30	: longstring, ( c-addr u -- ) \ gforth
116 :	anton	1.55	\G puts down string as longcstring
117 :	anton	1.30	dup , here swap chars dup allot move ;
118 :
119 :	pazsan	1.1	: header, ( c-addr u -- ) \ gforth
120 :			name-too-long?
121 :	anton	1.53	dup max-name-length @ max max-name-length !
122 :	pazsan	1.1	align here last !
123 :	pazsan	1.84	[ has? flash [IF] ]
124 :	pazsan	1.83	-1 A,
125 :			[ [ELSE] ]
126 :	pazsan	1.1	current @ 1 or A, \ link field; before revealing, it contains the
127 :			\ tagged reveal-into wordlist
128 :	pazsan	1.83	[ [THEN] ]
129 :	pazsan	1.78	[ has? f83headerstring [IF] ]
130 :			string,
131 :			[ [ELSE] ]
132 :	pazsan	1.83	longstring, alias-mask lastflags cset
133 :	pazsan	1.78	[ [THEN] ]
134 :	pazsan	1.83	cfalign ;
135 :	pazsan	1.1
136 :			: input-stream-header ( "name" -- )
137 :	pazsan	1.80	parse-name name-too-short? header, ;
138 :	pazsan	1.1
139 :			: input-stream ( -- ) \ general
140 :			\G switches back to getting the name from the input stream ;
141 :			['] input-stream-header IS (header) ;
142 :
143 :			' input-stream-header IS (header)
144 :
145 :	anton	1.32	2variable nextname-string
146 :	pazsan	1.1
147 :	pazsan	1.33	has? OS [IF]
148 :	pazsan	1.1	: nextname-header ( -- )
149 :	anton	1.32	nextname-string 2@ header,
150 :			nextname-string free-mem-var
151 :	pazsan	1.1	input-stream ;
152 :	pazsan	1.33	[THEN]
153 :	pazsan	1.1
154 :			\ the next name is given in the string
155 :
156 :	pazsan	1.33	has? OS [IF]
157 :	pazsan	1.1	: nextname ( c-addr u -- ) \ gforth
158 :	anton	1.19	\g The next defined word will have the name @var{c-addr u}; the
159 :			\g defining word will leave the input stream alone.
160 :	pazsan	1.1	name-too-long?
161 :	anton	1.32	nextname-string free-mem-var
162 :			save-mem nextname-string 2!
163 :	pazsan	1.1	['] nextname-header IS (header) ;
164 :	pazsan	1.33	[THEN]
165 :	pazsan	1.1
166 :			: noname-header ( -- )
167 :			0 last ! cfalign
168 :			input-stream ;
169 :
170 :			: noname ( -- ) \ gforth
171 :	anton	1.19	\g The next defined word will be anonymous. The defining word will
172 :			\g leave the input stream alone. The xt of the defined word will
173 :	anton	1.56	\g be given by @code{latestxt}.
174 :	pazsan	1.1	['] noname-header IS (header) ;
175 :
176 :	anton	1.56	: latestxt ( -- xt ) \ gforth
177 :	crook	1.15	\G @i{xt} is the execution token of the last word defined.
178 :	crook	1.13	\ The main purpose of this word is to get the xt of words defined using noname
179 :	pazsan	1.1	lastcfa @ ;
180 :
181 :	anton	1.56	' latestxt alias lastxt \ gforth-obsolete
182 :			\G old name for @code{latestxt}.
183 :
184 :			: latest ( -- nt ) \ gforth
185 :			\G @var{nt} is the name token of the last word defined; it is 0 if the
186 :			\G last word has no name.
187 :			last @ ;
188 :
189 :	pazsan	1.1	\ \ literals 17dec92py
190 :
191 :			: Literal ( compilation n -- ; run-time -- n ) \ core
192 :	anton	1.27	\G Compilation semantics: compile the run-time semantics.@*
193 :			\G Run-time Semantics: push @i{n}.@*
194 :			\G Interpretation semantics: undefined.
195 :	jwilke	1.14	[ [IFDEF] lit, ]
196 :			lit,
197 :			[ [ELSE] ]
198 :	anton	1.27	postpone lit ,
199 :	jwilke	1.14	[ [THEN] ] ; immediate restrict
200 :	pazsan	1.1
201 :	anton	1.72	: 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal
202 :			\G Compile appropriate code such that, at run-time, @i{w1 w2} are
203 :			\G placed on the stack. Interpretation semantics are undefined.
204 :			swap postpone Literal postpone Literal ; immediate restrict
205 :
206 :	pazsan	1.1	: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
207 :	jwilke	1.14	[ [IFDEF] alit, ]
208 :			alit,
209 :			[ [ELSE] ]
210 :			postpone lit A,
211 :			[ [THEN] ] ; immediate restrict
212 :	pazsan	1.1
213 :	pazsan	1.70	Defer char@ ( addr u -- char addr' u' )
214 :			:noname over c@ -rot 1 /string ; IS char@
215 :
216 :	crook	1.8	: char ( '<spaces>ccc' -- c ) \ core
217 :	crook	1.15	\G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
218 :			\G display code representing the first character of @i{ccc}.
219 :	pazsan	1.87	parse-name char@ 2drop ;
220 :	pazsan	1.1
221 :	crook	1.8	: [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
222 :	crook	1.10	\G Compilation: skip leading spaces. Parse the string
223 :	crook	1.15	\G @i{ccc}. Run-time: return @i{c}, the display code
224 :			\G representing the first character of @i{ccc}. Interpretation
225 :	crook	1.10	\G semantics for this word are undefined.
226 :	pazsan	1.1	char postpone Literal ; immediate restrict
227 :
228 :			\ \ threading 17mar93py
229 :
230 :			: cfa, ( code-address -- ) \ gforth cfa-comma
231 :			here
232 :			dup lastcfa !
233 :	pazsan	1.84	[ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ]
234 :			code-address! ;
235 :	pazsan	1.1
236 :	jwilke	1.14	[IFUNDEF] compile,
237 :	anton	1.34	defer compile, ( xt -- ) \ core-ext compile-comma
238 :			\G Compile the word represented by the execution token @i{xt}
239 :			\G into the current definition.
240 :
241 :			' , is compile,
242 :	jwilke	1.14	[THEN]
243 :	pazsan	1.1
244 :	pazsan	1.80	has? ec 0= [IF]
245 :	anton	1.40	defer basic-block-end ( -- )
246 :
247 :	anton	1.60	:noname ( -- )
248 :			0 compile-prim1 ;
249 :			is basic-block-end
250 :	pazsan	1.80	[THEN]
251 :	anton	1.40
252 :	pazsan	1.36	has? peephole [IF]
253 :	anton	1.40
254 :			\ dynamic only
255 :	anton	1.49	: peephole-compile, ( xt -- )
256 :			\ compile xt, appending its code to the current dynamic superinstruction
257 :			here swap , compile-prim1 ;
258 :	anton	1.38
259 :	anton	1.35	: compile-to-prims, ( xt -- )
260 :			\G compile xt to use primitives (and their peephole optimization)
261 :			\G instead of ","-ing the xt.
262 :			\ !! all POSTPONEs here postpone primitives; this can be optimized
263 :	pazsan	1.39	dup >does-code if
264 :	anton	1.66	['] does-exec peephole-compile, , EXIT
265 :			\ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
266 :	anton	1.35	then
267 :			dup >code-address CASE
268 :	pazsan	1.91	dovalue: OF >body ['] lit@ peephole-compile, , EXIT ENDOF
269 :			docon: OF >body @ ['] lit peephole-compile, , EXIT ENDOF
270 :	anton	1.66	\ docon: OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF
271 :	anton	1.42	\ docon is also used by VALUEs, so don't @ at compile time
272 :	anton	1.66	docol: OF >body ['] call peephole-compile, , EXIT ENDOF
273 :			dovar: OF >body ['] lit peephole-compile, , EXIT ENDOF
274 :			douser: OF >body @ ['] useraddr peephole-compile, , EXIT ENDOF
275 :			dodefer: OF >body ['] lit-perform peephole-compile, , EXIT ENDOF
276 :			dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF
277 :			\ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF
278 :	anton	1.48	\ code words and ;code-defined words (code words could be optimized):
279 :	anton	1.66	dup in-dictionary? IF drop POSTPONE literal ['] execute peephole-compile, EXIT THEN
280 :	anton	1.35	ENDCASE
281 :	anton	1.49	peephole-compile, ;
282 :	anton	1.35
283 :			' compile-to-prims, IS compile,
284 :	pazsan	1.36	[ELSE]
285 :			' , is compile,
286 :			[THEN]
287 :	anton	1.34
288 :	pazsan	1.1	: !does ( addr -- ) \ gforth store-does
289 :	anton	1.56	latestxt does-code! ;
290 :	pazsan	1.1
291 :	anton	1.65	\ !! unused, but ifdefed/gosted in some places
292 :	pazsan	1.1	: (does>) ( R: addr -- )
293 :	anton	1.62	r> cfaligned /does-handler + !does ; \ !! no gforth-native
294 :	pazsan	1.1
295 :	anton	1.64	: (does>2) ( addr -- )
296 :			cfaligned /does-handler + !does ;
297 :
298 :	pazsan	1.1	: dodoes, ( -- )
299 :			cfalign here /does-handler allot does-handler! ;
300 :
301 :	pazsan	1.61	: (compile) ( -- ) \ gforth-obsolete: dummy
302 :	anton	1.63	true abort" (compile) doesn't work, use POSTPONE instead" ;
303 :	pazsan	1.1
304 :			\ \ ticks
305 :
306 :	anton	1.90	: name>comp ( nt -- w xt ) \ gforth name-to-comp
307 :	crook	1.15	\G @i{w xt} is the compilation token for the word @i{nt}.
308 :	pazsan	1.1	(name>comp)
309 :			1 = if
310 :			['] execute
311 :			else
312 :			['] compile,
313 :			then ;
314 :
315 :			: [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
316 :			(') postpone ALiteral ; immediate restrict
317 :
318 :			: ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick
319 :	crook	1.15	\g @i{xt} represents @i{name}'s interpretation
320 :			\g semantics. Perform @code{-14 throw} if the word has no
321 :	pazsan	1.1	\g interpretation semantics.
322 :			' postpone ALiteral ; immediate restrict
323 :
324 :	anton	1.5	: COMP' ( "name" -- w xt ) \ gforth comp-tick
325 :	crook	1.15	\g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
326 :	pazsan	1.1	(') name>comp ;
327 :
328 :			: [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
329 :	crook	1.15	\g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
330 :	pazsan	1.1	COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
331 :
332 :	jwilke	1.18	: postpone, ( w xt -- ) \ gforth postpone-comma
333 :	anton	1.26	\g Compile the compilation semantics represented by the
334 :			\g compilation token @i{w xt}.
335 :	jwilke	1.18	dup ['] execute =
336 :			if
337 :			drop compile,
338 :			else
339 :	pazsan	1.61	swap POSTPONE aliteral compile,
340 :	jwilke	1.18	then ;
341 :
342 :			: POSTPONE ( "name" -- ) \ core
343 :			\g Compiles the compilation semantics of @i{name}.
344 :	anton	1.48	COMP' postpone, ; immediate
345 :	jwilke	1.18
346 :	pazsan	1.1	\ \ recurse 17may93jaw
347 :
348 :			: recurse ( compilation -- ; run-time ?? -- ?? ) \ core
349 :	crook	1.10	\g Call the current definition.
350 :	anton	1.56	latestxt compile, ; immediate restrict
351 :	pazsan	1.1
352 :			\ \ compiler loop
353 :
354 :	anton	1.72	: compiler1 ( c-addr u -- ... xt )
355 :	pazsan	1.1	2dup find-name dup
356 :			if ( c-addr u nt )
357 :	anton	1.72	nip nip name>comp
358 :	pazsan	1.1	else
359 :			drop
360 :	anton	1.72	2dup 2>r snumber? dup
361 :	pazsan	1.1	IF
362 :			0>
363 :			IF
364 :	anton	1.72	['] 2literal
365 :			ELSE
366 :			['] literal
367 :	pazsan	1.1	THEN
368 :	anton	1.72	2rdrop
369 :	pazsan	1.1	ELSE
370 :	anton	1.72	drop 2r> compiler-notfound1
371 :	pazsan	1.1	THEN
372 :			then ;
373 :
374 :	crook	1.22	: [ ( -- ) \ core left-bracket
375 :	crook	1.8	\G Enter interpretation state. Immediate word.
376 :	anton	1.72	['] interpreter1 IS parser1 state off ; immediate
377 :	pazsan	1.1
378 :			: ] ( -- ) \ core right-bracket
379 :	crook	1.8	\G Enter compilation state.
380 :	anton	1.72	['] compiler1 IS parser1 state on ;
381 :	pazsan	1.1
382 :			\ \ Strings 22feb93py
383 :
384 :	anton	1.44	: S, ( addr u -- )
385 :	anton	1.45	\ allot string as counted string
386 :	pazsan	1.84	[ has? flash [IF] ]
387 :			dup c, bounds ?DO I c@ c, LOOP
388 :			[ [ELSE] ]
389 :			here over char+ allot place align
390 :			[ [THEN] ] ;
391 :	anton	1.45
392 :			: mem, ( addr u -- )
393 :			\ allot the memory block HERE (do alignment yourself)
394 :	pazsan	1.84	[ has? flash [IF] ]
395 :			bounds ?DO I c@ c, LOOP
396 :			[ [ELSE] ]
397 :			here over allot swap move
398 :			[ [THEN] ] ;
399 :	pazsan	1.1
400 :	anton	1.44	: ," ( "string"<"> -- )
401 :			[char] " parse s, ;
402 :	pazsan	1.1
403 :			\ \ Header states 23feb93py
404 :
405 :	pazsan	1.83	\ problematic only for big endian machines
406 :
407 :			has? f83headerstring [IF]
408 :			: cset ( bmask c-addr -- )
409 :			tuck c@ or swap c! ;
410 :
411 :			: creset ( bmask c-addr -- )
412 :			tuck c@ swap invert and swap c! ;
413 :
414 :			: ctoggle ( bmask c-addr -- )
415 :			tuck c@ xor swap c! ;
416 :			[ELSE]
417 :	pazsan	1.1	: cset ( bmask c-addr -- )
418 :	anton	1.30	tuck @ or swap ! ;
419 :	pazsan	1.1
420 :			: creset ( bmask c-addr -- )
421 :	anton	1.30	tuck @ swap invert and swap ! ;
422 :	pazsan	1.1
423 :			: ctoggle ( bmask c-addr -- )
424 :	anton	1.30	tuck @ xor swap ! ;
425 :	pazsan	1.83	[THEN]
426 :	pazsan	1.1
427 :			: lastflags ( -- c-addr )
428 :			\ the address of the flags byte in the last header
429 :			\ aborts if the last defined word was headerless
430 :	anton	1.56	latest dup 0= abort" last word was headerless" cell+ ;
431 :	pazsan	1.1
432 :			: immediate ( -- ) \ core
433 :	crook	1.10	\G Make the compilation semantics of a word be to @code{execute}
434 :			\G the execution semantics.
435 :	pazsan	1.83	immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
436 :	pazsan	1.1
437 :			: restrict ( -- ) \ gforth
438 :	crook	1.10	\G A synonym for @code{compile-only}
439 :	pazsan	1.83	restrict-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
440 :	jwilke	1.18
441 :	pazsan	1.1	' restrict alias compile-only ( -- ) \ gforth
442 :	crook	1.10	\G Remove the interpretation semantics of a word.
443 :	pazsan	1.1
444 :			\ \ Create Variable User Constant 17mar93py
445 :
446 :	crook	1.15	: Alias ( xt "name" -- ) \ gforth
447 :	pazsan	1.1	Header reveal
448 :			alias-mask lastflags creset
449 :			dup A, lastcfa ! ;
450 :
451 :			doer? :dovar [IF]
452 :
453 :			: Create ( "name" -- ) \ core
454 :			Header reveal dovar: cfa, ;
455 :			[ELSE]
456 :
457 :			: Create ( "name" -- ) \ core
458 :			Header reveal here lastcfa ! 0 A, 0 , DOES> ;
459 :			[THEN]
460 :
461 :	pazsan	1.85	has? flash [IF]
462 :	pazsan	1.87	: (variable) dpp @ normal-dp = IF Create dpp @
463 :	pazsan	1.85	ELSE normal-dp @ Constant dpp @ ram THEN ;
464 :			: Variable ( "name" -- ) \ core
465 :			(Variable) 0 , dpp ! ;
466 :
467 :			: AVariable ( "name" -- ) \ gforth
468 :			(Variable) 0 A, dpp ! ;
469 :
470 :			: 2Variable ( "name" -- ) \ double two-variable
471 :			(Variable) 0 , 0 , dpp ! ;
472 :			[ELSE]
473 :	pazsan	1.1	: Variable ( "name" -- ) \ core
474 :			Create 0 , ;
475 :
476 :			: AVariable ( "name" -- ) \ gforth
477 :			Create 0 A, ;
478 :
479 :	crook	1.22	: 2Variable ( "name" -- ) \ double two-variable
480 :	pazsan	1.85	Create 0 , 0 , ;
481 :			[THEN]
482 :	pazsan	1.1
483 :	pazsan	1.75	has? no-userspace 0= [IF]
484 :	crook	1.21	: uallot ( n -- ) \ gforth
485 :			udp @ swap udp +! ;
486 :	pazsan	1.1
487 :			doer? :douser [IF]
488 :
489 :			: User ( "name" -- ) \ gforth
490 :			Header reveal douser: cfa, cell uallot , ;
491 :
492 :			: AUser ( "name" -- ) \ gforth
493 :			User ;
494 :			[ELSE]
495 :
496 :			: User Create cell uallot , DOES> @ up @ + ;
497 :
498 :			: AUser User ;
499 :	pazsan	1.75	[THEN]
500 :	pazsan	1.1	[THEN]
501 :
502 :			doer? :docon [IF]
503 :			: (Constant) Header reveal docon: cfa, ;
504 :			[ELSE]
505 :			: (Constant) Create DOES> @ ;
506 :			[THEN]
507 :
508 :	pazsan	1.76	doer? :dovalue [IF]
509 :			: (Value) Header reveal dovalue: cfa, ;
510 :			[ELSE]
511 :			has? rom [IF]
512 :			: (Value) Create DOES> @ @ ;
513 :			[ELSE]
514 :			: (Value) Create DOES> @ ;
515 :			[THEN]
516 :			[THEN]
517 :
518 :	pazsan	1.1	: Constant ( w "name" -- ) \ core
519 :	crook	1.15	\G Define a constant @i{name} with value @i{w}.
520 :	pazsan	1.1	\G
521 :	crook	1.15	\G @i{name} execution: @i{-- w}
522 :	pazsan	1.1	(Constant) , ;
523 :
524 :			: AConstant ( addr "name" -- ) \ gforth
525 :			(Constant) A, ;
526 :
527 :	pazsan	1.84	has? flash [IF]
528 :			: Value ( w "name" -- ) \ core-ext
529 :			(Value) dpp @ >r here cell allot >r
530 :			ram here >r , r> r> flash! r> dpp ! ;
531 :
532 :			' Value alias AValue
533 :			[ELSE]
534 :	pazsan	1.1	: Value ( w "name" -- ) \ core-ext
535 :	pazsan	1.76	(Value) , ;
536 :	pazsan	1.1
537 :	jwilke	1.37	: AValue ( w "name" -- ) \ core-ext
538 :	pazsan	1.76	(Value) A, ;
539 :	pazsan	1.84	[THEN]
540 :	jwilke	1.37
541 :	crook	1.22	: 2Constant ( w1 w2 "name" -- ) \ double two-constant
542 :	pazsan	1.1	Create ( w1 w2 "name" -- )
543 :			2,
544 :			DOES> ( -- w1 w2 )
545 :			2@ ;
546 :
547 :			doer? :dofield [IF]
548 :			: (Field) Header reveal dofield: cfa, ;
549 :			[ELSE]
550 :			: (Field) Create DOES> @ + ;
551 :			[THEN]
552 :	pazsan	1.39
553 :			\ \ interpret/compile:
554 :
555 :			struct
556 :			>body
557 :			cell% field interpret/compile-int
558 :			cell% field interpret/compile-comp
559 :			end-struct interpret/compile-struct
560 :
561 :			: interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
562 :			Create immediate swap A, A,
563 :			DOES>
564 :			abort" executed primary cfa of an interpret/compile: word" ;
565 :			\ state @ IF cell+ THEN perform ;
566 :
567 :	pazsan	1.1	\ IS Defer What's Defers TO 24feb93py
568 :
569 :	anton	1.68	defer defer-default ( -- )
570 :	anton	1.69	' abort is defer-default
571 :			\ default action for deferred words (overridden by a warning later)
572 :	anton	1.67
573 :	pazsan	1.1	doer? :dodefer [IF]
574 :
575 :			: Defer ( "name" -- ) \ gforth
576 :	anton	1.67	\G Define a deferred word @i{name}; its execution semantics can be
577 :			\G set with @code{defer!} or @code{is} (and they have to, before first
578 :			\G executing @i{name}.
579 :	pazsan	1.1	Header Reveal dodefer: cfa,
580 :	pazsan	1.86	[ has? rom [IF] ] here >r cell allot
581 :			dpp @ ram here r> flash! ['] defer-default A, dpp !
582 :			[ [ELSE] ] ['] defer-default A, [ [THEN] ] ;
583 :	jwilke	1.18
584 :	pazsan	1.1	[ELSE]
585 :
586 :	pazsan	1.77	has? rom [IF]
587 :			: Defer ( "name" -- ) \ gforth
588 :	pazsan	1.86	Create here >r cell allot
589 :			dpp @ ram here r> flash! ['] defer-default A, dpp !
590 :	pazsan	1.77	DOES> @ @ execute ;
591 :			[ELSE]
592 :			: Defer ( "name" -- ) \ gforth
593 :			Create ['] defer-default A,
594 :			DOES> @ execute ;
595 :			[THEN]
596 :	pazsan	1.1	[THEN]
597 :
598 :	anton	1.67	: defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
599 :			\G @i{xt} represents the word currently associated with the deferred
600 :			\G word @i{xt-deferred}.
601 :	pazsan	1.86	>body @ [ has? rom [IF] ] @ [ [THEN] ] ;
602 :	anton	1.67
603 :	anton	1.25	: Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
604 :			\G Compiles the present contents of the deferred word @i{name}
605 :			\G into the current definition. I.e., this produces static
606 :			\G binding as if @i{name} was not deferred.
607 :	anton	1.67	' defer@ compile, ; immediate
608 :	jwilke	1.18
609 :			:noname
610 :			dodoes, here !does ]
611 :			defstart :-hook ;
612 :			:noname
613 :			;-hook ?struc
614 :			[ has? xconds [IF] ] exit-like [ [THEN] ]
615 :	pazsan	1.84	here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
616 :			postpone aliteral postpone (does>2) [compile] exit
617 :	pazsan	1.80	[ has? peephole [IF] ] finish-code [ [THEN] ] dodoes,
618 :	jwilke	1.18	defstart :-hook ;
619 :			interpret/compile: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
620 :
621 :	anton	1.73	: defer! ( xt xt-deferred -- ) \ gforth defer-store
622 :	anton	1.67	\G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
623 :	pazsan	1.86	>body [ has? rom [IF] ] @ [ [THEN] ] ! ;
624 :	anton	1.67
625 :	anton	1.20	: <IS> ( "name" xt -- ) \ gforth
626 :			\g Changes the @code{defer}red word @var{name} to execute @var{xt}.
627 :	anton	1.67	' defer! ;
628 :	anton	1.20
629 :			: [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
630 :			\g At run-time, changes the @code{defer}red word @var{name} to
631 :			\g execute @var{xt}.
632 :	anton	1.67	' postpone ALiteral postpone defer! ; immediate restrict
633 :	jwilke	1.18
634 :	anton	1.20	' <IS>
635 :	jwilke	1.18	' [IS]
636 :	anton	1.67	interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
637 :			\G Changes the @code{defer}red word @var{name} to execute @var{xt}.
638 :			\G Its compilation semantics parses at compile time.
639 :	jwilke	1.18
640 :	anton	1.20	' <IS>
641 :			' [IS]
642 :			interpret/compile: TO ( w "name" -- ) \ core-ext
643 :	jwilke	1.18
644 :			: interpret/compile? ( xt -- flag )
645 :			>does-code ['] DOES> >does-code = ;
646 :	pazsan	1.1
647 :			\ \ : ; 24feb93py
648 :
649 :			defer :-hook ( sys1 -- sys2 )
650 :
651 :			defer ;-hook ( sys2 -- sys1 )
652 :
653 :	jwilke	1.16	0 Constant defstart
654 :
655 :	jwilke	1.14	[IFDEF] docol,
656 :			: (:noname) ( -- colon-sys )
657 :			\ common factor of : and :noname
658 :	anton	1.34	docol, ]comp
659 :	jwilke	1.14	[ELSE]
660 :	anton	1.7	: (:noname) ( -- colon-sys )
661 :			\ common factor of : and :noname
662 :	anton	1.34	docol: cfa,
663 :	jwilke	1.14	[THEN]
664 :	anton	1.40	defstart ] :-hook ;
665 :	anton	1.7
666 :	pazsan	1.1	: : ( "name" -- colon-sys ) \ core colon
667 :	anton	1.7	Header (:noname) ;
668 :
669 :			: :noname ( -- xt colon-sys ) \ core-ext colon-no-name
670 :			0 last !
671 :			cfalign here (:noname) ;
672 :	pazsan	1.1
673 :	jwilke	1.14	[IFDEF] fini,
674 :			: ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
675 :			;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
676 :			[ELSE]
677 :	pazsan	1.1	: ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
678 :	pazsan	1.57	;-hook ?struc [compile] exit
679 :			[ has? peephole [IF] ] finish-code [ [THEN] ]
680 :			reveal postpone [ ; immediate restrict
681 :	jwilke	1.14	[THEN]
682 :	pazsan	1.1
683 :			\ \ Search list handling: reveal words, recursive 23feb93py
684 :
685 :			: last? ( -- false / nfa nfa )
686 :	anton	1.56	latest ?dup ;
687 :	pazsan	1.1
688 :	pazsan	1.83	Variable warnings ( -- addr ) \ gforth
689 :			G -1 warnings T !
690 :
691 :			has? ec [IF]
692 :			: reveal ( -- ) \ gforth
693 :			last?
694 :			if \ the last word has a header
695 :			dup ( name>link ) @ -1 =
696 :			if \ it is still hidden
697 :	pazsan	1.88	forth-wordlist dup >r @ over
698 :	pazsan	1.84	[ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] r> !
699 :	pazsan	1.83	else
700 :			drop
701 :			then
702 :			then ;
703 :			[ELSE]
704 :	pazsan	1.1	: (reveal) ( nt wid -- )
705 :	pazsan	1.3	wordlist-id dup >r
706 :	pazsan	1.1	@ over ( name>link ) !
707 :			r> ! ;
708 :
709 :			\ make entry in wordlist-map
710 :			' (reveal) f83search reveal-method !
711 :
712 :			: check-shadow ( addr count wid -- )
713 :	pazsan	1.2	\G prints a warning if the string is already present in the wordlist
714 :			>r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
715 :			>stderr
716 :			." redefined " name>string 2dup type
717 :	anton	1.43	str= 0= if
718 :	pazsan	1.2	." with " type
719 :			else
720 :			2drop
721 :			then
722 :			space space EXIT
723 :			then
724 :			2drop 2drop ;
725 :	pazsan	1.1
726 :			: reveal ( -- ) \ gforth
727 :			last?
728 :			if \ the last word has a header
729 :			dup ( name>link ) @ 1 and
730 :			if \ it is still hidden
731 :			dup ( name>link ) @ 1 xor ( nt wid )
732 :			2dup >r name>string r> check-shadow ( nt wid )
733 :	pazsan	1.83	dup wordlist-map @ reveal-method perform
734 :	pazsan	1.1	else
735 :			drop
736 :			then
737 :			then ;
738 :
739 :			: rehash ( wid -- )
740 :			dup wordlist-map @ rehash-method perform ;
741 :	pazsan	1.80	[THEN]
742 :	pazsan	1.1
743 :			' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
744 :	crook	1.10	\g Make the current definition visible, enabling it to call itself
745 :	pazsan	1.1	\g recursively.
746 :			immediate restrict

CVS Admin

gforth: gforth/kernel/comp.fs

ViewCVS and CVS Help