Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | : FIRST_COLON ; |
2 | ||
3 | : LATEST context @ ; | |
4 | ||
5 | : FLAG_IMMEDIATE 64 ; | |
6 | ||
7 | : IMMEDIATE | |
8 | latest dup c@ flag_immediate OR | |
9 | swap c! | |
10 | ; | |
11 | ||
12 | : ( 41 word drop ; immediate | |
13 | ( That was the definition for the comment word. ) | |
14 | ( Now we can add comments to what we are doing! ) | |
15 | ( Note that we are in decimal numeric input mode. ) | |
16 | ||
17 | : \ ( <line> -- , comment out rest of line ) | |
18 | EOL word drop | |
19 | ; immediate | |
20 | ||
21 | \ 1 echo ! \ Uncomment this line to echo Forth code while compiling. | |
22 | ||
23 | \ ********************************************************************* | |
24 | \ This is another style of comment that is common in Forth. | |
25 | \ pFORTH - Portable Forth System | |
26 | \ Based on HMSL Forth | |
27 | \ | |
28 | \ Author: Phil Burk | |
1a088514 | 29 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom |
8e9db35f PB |
30 | \ |
31 | \ The pForth software code is dedicated to the public domain, | |
32 | \ and any third party may reproduce, distribute and modify | |
33 | \ the pForth software code or any derivative works thereof | |
34 | \ without any compensation or license. The pForth software | |
35 | \ code is provided on an "as is" basis without any warranty | |
36 | \ of any kind, including, without limitation, the implied | |
37 | \ warranties of merchantability and fitness for a particular | |
38 | \ purpose and their equivalents under the laws of any jurisdiction. | |
39 | \ ********************************************************************* | |
40 | ||
41 | : COUNT dup 1+ swap c@ ; | |
42 | ||
43 | \ Miscellaneous support words | |
44 | : ON ( addr -- , set true ) | |
45 | -1 swap ! | |
46 | ; | |
47 | : OFF ( addr -- , set false ) | |
48 | 0 swap ! | |
49 | ; | |
50 | ||
51 | : CELL+ ( n -- n+cell ) cell + ; | |
52 | : CELL- ( n -- n+cell ) cell - ; | |
1cb310e6 | 53 | : CELL* ( n -- n*cell ) cells ; |
8e9db35f PB |
54 | |
55 | : CHAR+ ( n -- n+size_of_char ) 1+ ; | |
56 | : CHARS ( n -- n*size_of_char , don't do anything) ; immediate | |
57 | ||
58 | \ useful stack manipulation words | |
59 | : -ROT ( a b c -- c a b ) | |
60 | rot rot | |
61 | ; | |
62 | : 3DUP ( a b c -- a b c a b c ) | |
63 | 2 pick 2 pick 2 pick | |
64 | ; | |
65 | : 2DROP ( a b -- ) | |
66 | drop drop | |
67 | ; | |
68 | : NIP ( a b -- b ) | |
69 | swap drop | |
70 | ; | |
71 | : TUCK ( a b -- b a b ) | |
72 | swap over | |
73 | ; | |
74 | ||
75 | : <= ( a b -- f , true if A <= b ) | |
76 | > 0= | |
77 | ; | |
78 | : >= ( a b -- f , true if A >= b ) | |
79 | < 0= | |
80 | ; | |
81 | ||
82 | : INVERT ( n -- 1'comp ) | |
83 | -1 xor | |
84 | ; | |
85 | ||
86 | : NOT ( n -- !n , logical negation ) | |
87 | 0= | |
88 | ; | |
89 | ||
90 | : NEGATE ( n -- -n ) | |
91 | 0 swap - | |
92 | ; | |
93 | ||
94 | : DNEGATE ( d -- -d , negate by doing 0-d ) | |
95 | 0 0 2swap d- | |
96 | ; | |
97 | ||
98 | ||
99 | \ -------------------------------------------------------------------- | |
100 | ||
101 | : ID. ( nfa -- ) | |
102 | count 31 and type | |
103 | ; | |
104 | ||
105 | : DECIMAL 10 base ! ; | |
106 | : OCTAL 8 base ! ; | |
107 | : HEX 16 base ! ; | |
108 | : BINARY 2 base ! ; | |
109 | ||
110 | : PAD ( -- addr ) | |
111 | here 128 + | |
112 | ; | |
113 | ||
114 | : $MOVE ( $src $dst -- ) | |
115 | over c@ 1+ cmove | |
116 | ; | |
117 | : BETWEEN ( n lo hi -- flag , true if between lo & hi ) | |
118 | >r over r> > >r | |
119 | < r> or 0= | |
120 | ; | |
121 | : [ ( -- , enter interpreter mode ) | |
122 | 0 state ! | |
123 | ; immediate | |
124 | : ] ( -- enter compile mode ) | |
125 | 1 state ! | |
126 | ; | |
127 | ||
128 | : EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ; | |
129 | : ALIGNED ( addr -- a-addr ) | |
130 | [ cell 1- ] literal + | |
131 | [ cell 1- invert ] literal and | |
132 | ; | |
133 | : ALIGN ( -- , align DP ) dp @ aligned dp ! ; | |
134 | : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ; | |
135 | ||
136 | : C, ( c -- ) here c! 1 chars dp +! ; | |
137 | : W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ; | |
138 | : , ( n -- , lay into dictionary ) align here ! cell allot ; | |
139 | ||
140 | \ Dictionary conversions ------------------------------------------ | |
141 | ||
142 | : N>NEXTLINK ( nfa -- nextlink , traverses name field ) | |
143 | dup c@ 31 and 1+ + aligned | |
144 | ; | |
145 | ||
146 | : NAMEBASE ( -- base-of-names ) | |
147 | Headers-Base @ | |
148 | ; | |
149 | : CODEBASE ( -- base-of-code dictionary ) | |
150 | Code-Base @ | |
151 | ; | |
152 | ||
153 | : NAMELIMIT ( -- limit-of-names ) | |
154 | Headers-limit @ | |
155 | ; | |
156 | : CODELIMIT ( -- limit-of-code, last address in dictionary ) | |
157 | Code-limit @ | |
158 | ; | |
159 | ||
160 | : NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual ) | |
161 | namebase + | |
162 | ; | |
163 | ||
164 | : >CODE ( xt -- secondary_code_address, not valid for primitives ) | |
165 | codebase + | |
166 | ; | |
167 | ||
168 | : CODE> ( secondary_code_address -- xt , not valid for primitives ) | |
169 | codebase - | |
170 | ; | |
171 | ||
172 | : N>LINK ( nfa -- lfa ) | |
173 | 2 CELLS - | |
174 | ; | |
175 | ||
176 | : >BODY ( xt -- pfa ) | |
177 | >code body_offset + | |
178 | ; | |
179 | ||
180 | : BODY> ( pfa -- xt ) | |
181 | body_offset - code> | |
182 | ; | |
183 | ||
184 | \ convert between addresses useable by @, and relocatable addresses. | |
185 | : USE->REL ( useable_addr -- rel_addr ) | |
186 | codebase - | |
187 | ; | |
188 | : REL->USE ( rel_addr -- useable_addr ) | |
189 | codebase + | |
190 | ; | |
191 | ||
192 | \ for JForth code | |
193 | \ : >REL ( adr -- adr ) ; immediate | |
194 | \ : >ABS ( adr -- adr ) ; immediate | |
195 | ||
196 | : X@ ( addr -- xt , fetch execution token from relocatable ) @ ; | |
197 | : X! ( addr -- xt , store execution token as relocatable ) ! ; | |
198 | ||
199 | \ Compiler support ------------------------------------------------ | |
200 | : COMPILE, ( xt -- , compile call to xt ) | |
201 | , | |
202 | ; | |
203 | ||
204 | ( Compiler support , based on FIG ) | |
205 | : [COMPILE] ( <name> -- , compile now even if immediate ) | |
206 | ' compile, | |
207 | ; IMMEDIATE | |
208 | ||
209 | : (COMPILE) ( xt -- , postpone compilation of token ) | |
210 | [compile] literal ( compile a call to literal ) | |
211 | ( store xt of word to be compiled ) | |
212 | ||
213 | [ ' compile, ] literal \ compile call to compile, | |
214 | compile, | |
215 | ; | |
216 | ||
217 | : COMPILE ( <name> -- , save xt and compile later ) | |
218 | ' (compile) | |
219 | ; IMMEDIATE | |
220 | ||
221 | ||
222 | : :NONAME ( -- xt , begin compilation of headerless secondary ) | |
223 | align | |
224 | here code> \ convert here to execution token | |
225 | ] | |
226 | ; | |
227 | ||
228 | \ Error codes defined in ANSI Exception word set. | |
229 | : ERR_ABORT -1 ; \ general abort | |
230 | : ERR_ABORTQ -2 ; \ for abort" | |
231 | : ERR_EXECUTING -14 ; \ compile time word while not compiling | |
232 | : ERR_PAIRS -22 ; \ mismatch in conditional | |
233 | : ERR_DEFER -258 ; \ not a deferred word | |
234 | ||
235 | : ABORT ( i*x -- ) | |
236 | ERR_ABORT throw | |
237 | ; | |
238 | ||
239 | \ Conditionals in '83 form ----------------------------------------- | |
240 | : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ; | |
241 | : ?CONDITION ( f -- ) conditional_key - err_pairs ?error ; | |
242 | : >MARK ( -- addr ) here 0 , ; | |
243 | : >RESOLVE ( addr -- ) here over - swap ! ; | |
244 | : <MARK ( -- addr ) here ; | |
245 | : <RESOLVE ( addr -- ) here - , ; | |
246 | ||
247 | : ?COMP ( -- , error if not compiling ) | |
248 | state @ 0= err_executing ?error | |
249 | ; | |
250 | : ?PAIRS ( n m -- ) | |
251 | - err_pairs ?error | |
252 | ; | |
253 | \ conditional primitives | |
254 | : IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate | |
255 | : THEN ( f orig -- ) swap ?condition >resolve ; immediate | |
256 | : BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate | |
257 | : AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate | |
258 | : UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate | |
259 | : AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate | |
260 | ||
261 | \ conditionals built from primitives | |
262 | : ELSE ( f orig1 -- f orig2 ) | |
263 | [compile] AHEAD 2swap [compile] THEN ; immediate | |
264 | : WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate | |
265 | : REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate | |
266 | ||
267 | : ['] ( <name> -- xt , define compile time tick ) | |
268 | ?comp ' [compile] literal | |
269 | ; immediate | |
270 | ||
271 | \ for example: | |
272 | \ compile time: compile create , (does>) then ; | |
273 | \ execution time: create <name>, ',' data, then patch pi to point to @ | |
274 | \ : con create , does> @ ; | |
275 | \ 345 con pi | |
276 | \ pi | |
277 | \ | |
278 | : (DOES>) ( xt -- , modify previous definition to execute code at xt ) | |
279 | latest name> >code \ get address of code for new word | |
280 | cell + \ offset to second cell in create word | |
281 | ! \ store execution token of DOES> code in new word | |
282 | ; | |
283 | ||
284 | : DOES> ( -- , define execution code for CREATE word ) | |
285 | 0 [compile] literal \ dummy literal to hold xt | |
286 | here cell- \ address of zero in literal | |
287 | compile (does>) \ call (DOES>) from new creation word | |
288 | >r \ move addrz to return stack so ; doesn't see stack garbage | |
289 | [compile] ; \ terminate part of code before does> | |
290 | r> | |
291 | :noname ( addrz xt ) | |
292 | swap ! \ save execution token in literal | |
293 | ; immediate | |
294 | ||
295 | : VARIABLE ( <name> -- ) | |
296 | CREATE 0 , \ IMMEDIATE | |
297 | \ DOES> [compile] aliteral \ %Q This could be optimised | |
298 | ; | |
299 | ||
300 | : 2VARIABLE ( <name> -c- ) ( -x- addr ) | |
301 | create 0 , 0 , | |
302 | ; | |
303 | ||
304 | : CONSTANT ( n <name> -c- ) ( -x- n ) | |
305 | CREATE , ( n -- ) | |
306 | DOES> @ ( -- n ) | |
307 | ; | |
308 | ||
309 | ||
310 | ||
311 | 0 1- constant -1 | |
312 | 0 2- constant -2 | |
313 | ||
314 | : 2! ( x1 x2 addr -- , store x2 followed by x1 ) | |
315 | swap over ! cell+ ! | |
316 | ; | |
317 | : 2@ ( addr -- x1 x2 ) | |
318 | dup cell+ @ swap @ | |
319 | ; | |
320 | ||
321 | ||
322 | : ABS ( n -- |n| ) | |
323 | dup 0< | |
324 | IF negate | |
325 | THEN | |
326 | ; | |
327 | : DABS ( d -- |d| ) | |
328 | dup 0< | |
329 | IF dnegate | |
330 | THEN | |
331 | ; | |
332 | ||
333 | : S>D ( s -- d , extend signed single precision to double ) | |
334 | dup 0< | |
335 | IF -1 | |
336 | ELSE 0 | |
337 | THEN | |
338 | ; | |
339 | ||
340 | : D>S ( d -- s ) drop ; | |
341 | ||
342 | : /MOD ( a b -- rem quo , unsigned version, FIXME ) | |
343 | >r s>d r> um/mod | |
344 | ; | |
345 | ||
346 | : MOD ( a b -- rem ) | |
347 | /mod drop | |
348 | ; | |
349 | ||
350 | : 2* ( n -- n*2 ) | |
351 | 1 lshift | |
352 | ; | |
353 | : 2/ ( n -- n/2 ) | |
354 | 1 arshift | |
355 | ; | |
356 | ||
357 | : D2* ( d -- d*2 ) | |
358 | 2* over | |
359 | cell 8 * 1- rshift or swap | |
360 | 2* swap | |
361 | ; | |
362 | ||
08689895 HE |
363 | : D= ( xd1 xd2 -- flag ) |
364 | rot = -rot = and | |
365 | ; | |
366 | ||
0b1e2489 HE |
367 | : D< ( d1 d2 -- flag ) |
368 | d- nip 0< | |
369 | ; | |
370 | ||
371 | : D> ( d1 d2 -- flag ) | |
372 | 2swap d< | |
373 | ; | |
374 | ||
8e9db35f PB |
375 | \ define some useful constants ------------------------------ |
376 | 1 0= constant FALSE | |
377 | 0 0= constant TRUE | |
378 | 32 constant BL | |
379 | ||
380 | ||
381 | \ Store and Fetch relocatable data addresses. --------------- | |
382 | : IF.USE->REL ( use -- rel , preserve zero ) | |
383 | dup IF use->rel THEN | |
384 | ; | |
385 | : IF.REL->USE ( rel -- use , preserve zero ) | |
386 | dup IF rel->use THEN | |
387 | ; | |
388 | ||
389 | : A! ( dictionary_address addr -- ) | |
390 | >r if.use->rel r> ! | |
391 | ; | |
392 | : A@ ( addr -- dictionary_address ) | |
393 | @ if.rel->use | |
394 | ; | |
395 | ||
396 | : A, ( dictionary_address -- ) | |
397 | if.use->rel , | |
398 | ; | |
399 | ||
400 | \ Stack data structure ---------------------------------------- | |
401 | \ This is a general purpose stack utility used to implement necessary | |
402 | \ stacks for the compiler or the user. Not real fast. | |
403 | \ These stacks grow up which is different then normal. | |
404 | \ cell 0 - stack pointer, offset from pfa of word | |
405 | \ cell 1 - limit for range checking | |
406 | \ cell 2 - first data location | |
407 | ||
408 | : :STACK ( #cells -- ) | |
409 | CREATE 2 cells , ( offset of first data location ) | |
410 | dup , ( limit for range checking, not currently used ) | |
411 | cells cell+ allot ( allot an extra cell for safety ) | |
412 | ; | |
413 | ||
414 | : >STACK ( n stack -- , push onto stack, postincrement ) | |
415 | dup @ 2dup cell+ swap ! ( -- n stack offset ) | |
416 | + ! | |
417 | ; | |
418 | ||
419 | : STACK> ( stack -- n , pop , predecrement ) | |
420 | dup @ cell- 2dup swap ! | |
421 | + @ | |
422 | ; | |
423 | ||
424 | : STACK@ ( stack -- n , copy ) | |
425 | dup @ cell- + @ | |
426 | ; | |
427 | ||
428 | : STACK.PICK ( index stack -- n , grab Nth from top of stack ) | |
429 | dup @ cell- + | |
430 | swap cells - \ offset for index | |
431 | @ | |
432 | ; | |
433 | : STACKP ( stack -- ptr , to next empty location on stack ) | |
434 | dup @ + | |
435 | ; | |
436 | ||
437 | : 0STACKP ( stack -- , clear stack) | |
438 | 8 swap ! | |
439 | ; | |
440 | ||
441 | 32 :stack ustack | |
442 | ustack 0stackp | |
443 | ||
444 | \ Define JForth like words. | |
445 | : >US ustack >stack ; | |
446 | : US> ustack stack> ; | |
447 | : US@ ustack stack@ ; | |
448 | : 0USP ustack 0stackp ; | |
449 | ||
450 | ||
451 | \ DO LOOP ------------------------------------------------ | |
452 | ||
453 | 3 constant do_flag | |
454 | 4 constant leave_flag | |
455 | 5 constant ?do_flag | |
456 | ||
457 | : DO ( -- , loop-back do_flag jump-from ?do_flag ) | |
458 | ?comp | |
459 | compile (do) | |
460 | here >us do_flag >us ( for backward branch ) | |
461 | ; immediate | |
462 | ||
463 | : ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack ) | |
464 | ?comp | |
465 | ( leave address to set for forward branch ) | |
466 | compile (?do) | |
467 | here 0 , | |
468 | here >us do_flag >us ( for backward branch ) | |
469 | >us ( for forward branch ) ?do_flag >us | |
470 | ; immediate | |
471 | ||
472 | : LEAVE ( -- addr leave_flag ) | |
473 | compile (leave) | |
474 | here 0 , >us | |
475 | leave_flag >us | |
476 | ; immediate | |
477 | ||
478 | : LOOP-FORWARD ( -us- jump-from ?do_flag -- ) | |
479 | BEGIN | |
480 | us@ leave_flag = | |
481 | us@ ?do_flag = | |
482 | OR | |
483 | WHILE | |
484 | us> leave_flag = | |
485 | IF | |
486 | us> here over - cell+ swap ! | |
487 | ELSE | |
488 | us> dup | |
489 | here swap - | |
490 | cell+ swap ! | |
491 | THEN | |
492 | REPEAT | |
493 | ; | |
494 | ||
495 | : LOOP-BACK ( loop-addr do_flag -us- ) | |
496 | us> do_flag ?pairs | |
497 | us> here - here | |
498 | ! | |
499 | cell allot | |
500 | ; | |
501 | ||
502 | : LOOP ( -- , loop-back do_flag jump-from ?do_flag ) | |
503 | compile (loop) | |
504 | loop-forward loop-back | |
505 | ; immediate | |
506 | ||
507 | \ : DOTEST 5 0 do 333 . loop 888 . ; | |
508 | \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ; | |
509 | \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ; | |
510 | ||
511 | : +LOOP ( -- , loop-back do_flag jump-from ?do_flag ) | |
512 | compile (+loop) | |
513 | loop-forward loop-back | |
514 | ; immediate | |
515 | ||
516 | : UNLOOP ( loop-sys -r- ) | |
517 | r> \ save return pointer | |
518 | rdrop rdrop | |
519 | >r | |
520 | ; | |
521 | ||
522 | : RECURSE ( ? -- ? , call the word currently being defined ) | |
523 | latest name> compile, | |
524 | ; immediate | |
525 | ||
526 | ||
527 | ||
528 | : SPACE bl emit ; | |
529 | : SPACES 512 min 0 max 0 ?DO space LOOP ; | |
530 | : 0SP depth 0 ?do drop loop ; | |
531 | ||
532 | : >NEWLINE ( -- , CR if needed ) | |
533 | out @ 0> | |
534 | IF cr | |
535 | THEN | |
536 | ; | |
537 | ||
538 | ||
539 | \ Support for DEFER -------------------- | |
540 | : CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type ) | |
541 | >code @ | |
542 | ['] emit >code @ | |
543 | - err_defer ?error | |
544 | ; | |
545 | ||
546 | : >is ( xt -- address_of_vector ) | |
547 | >code | |
548 | cell + | |
549 | ; | |
550 | ||
551 | : (IS) ( xt_do xt_deferred -- ) | |
552 | >is ! | |
553 | ; | |
554 | ||
555 | : IS ( xt <name> -- , act like normal IS ) | |
556 | ' \ xt | |
557 | dup check.defer | |
558 | state @ | |
559 | IF [compile] literal compile (is) | |
560 | ELSE (is) | |
561 | THEN | |
562 | ; immediate | |
563 | ||
564 | : (WHAT'S) ( xt -- xt_do ) | |
565 | >is @ | |
566 | ; | |
567 | : WHAT'S ( <name> -- xt , what will deferred word call? ) | |
568 | ' \ xt | |
569 | dup check.defer | |
570 | state @ | |
571 | IF [compile] literal compile (what's) | |
572 | ELSE (what's) | |
573 | THEN | |
574 | ; immediate | |
575 | ||
576 | : /STRING ( addr len n -- addr' len' ) | |
577 | over min rot over + -rot - | |
578 | ; | |
579 | : PLACE ( addr len to -- , move string ) | |
580 | 3dup 1+ swap cmove c! drop | |
581 | ; | |
582 | ||
583 | : PARSE-WORD ( char -- addr len ) | |
584 | >r source tuck >in @ /string r@ skip over swap r> scan | |
585 | >r over - rot r> dup 0<> + - >in ! | |
586 | ; | |
587 | : PARSE ( char -- addr len ) | |
588 | >r source >in @ /string over swap r> scan | |
589 | >r over - dup r> 0<> - >in +! | |
590 | ; | |
591 | ||
592 | : LWORD ( char -- addr ) | |
593 | parse-word here place here \ 00002 , use PARSE-WORD | |
594 | ; | |
595 | ||
596 | : ASCII ( <char> -- char , state smart ) | |
597 | bl parse drop c@ | |
598 | state @ | |
599 | IF [compile] literal | |
600 | THEN | |
601 | ; immediate | |
602 | ||
603 | : CHAR ( <char> -- char , interpret mode ) | |
604 | bl parse drop c@ | |
605 | ; | |
606 | ||
607 | : [CHAR] ( <char> -- char , for compile mode ) | |
608 | char [compile] literal | |
609 | ; immediate | |
610 | ||
611 | : $TYPE ( $string -- ) | |
612 | count type | |
613 | ; | |
614 | ||
615 | : 'word ( -- addr ) here ; | |
616 | ||
617 | : EVEN ( addr -- addr' ) dup 1 and + ; | |
618 | ||
619 | : (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?) | |
620 | r> dup count + aligned >r | |
621 | ; | |
622 | : (S") ( -- c-addr cnt ) | |
623 | r> count 2dup + aligned >r | |
624 | ; | |
625 | ||
626 | : (.") ( -- , type following string ) | |
627 | r> count 2dup + aligned >r type | |
628 | ; | |
629 | ||
630 | : ", ( adr len -- , place string into dictionary ) | |
631 | tuck 'word place 1+ allot align | |
632 | ; | |
633 | : ," ( -- ) | |
634 | [char] " parse ", | |
635 | ; | |
636 | ||
637 | : .( ( <string> -- , type string delimited by parentheses ) | |
638 | [CHAR] ) PARSE TYPE | |
639 | ; IMMEDIATE | |
640 | ||
641 | : ." ( <string> -- , type string ) | |
642 | state @ | |
643 | IF compile (.") ," | |
644 | ELSE [char] " parse type | |
645 | THEN | |
646 | ; immediate | |
647 | ||
648 | ||
649 | : .' ( <string> -- , type string delimited by single quote ) | |
650 | state @ | |
651 | IF compile (.") [char] ' parse ", | |
652 | ELSE [char] ' parse type | |
653 | THEN | |
654 | ; immediate | |
655 | ||
656 | : C" ( <string> -- addr , return string address, ANSI ) | |
657 | state @ | |
658 | IF compile (c") ," | |
659 | ELSE [char] " parse pad place pad | |
660 | THEN | |
661 | ; immediate | |
662 | ||
663 | : S" ( <string> -- , -- addr , return string address, ANSI ) | |
664 | state @ | |
665 | IF compile (s") ," | |
666 | ELSE [char] " parse pad place pad count | |
667 | THEN | |
668 | ; immediate | |
669 | ||
670 | : " ( <string> -- , -- addr , return string address ) | |
671 | [compile] C" | |
672 | ; immediate | |
673 | : P" ( <string> -- , -- addr , return string address ) | |
674 | [compile] C" | |
675 | ; immediate | |
676 | ||
677 | : "" ( <string> -- addr ) | |
678 | state @ | |
679 | IF | |
680 | compile (C") | |
681 | bl parse-word ", | |
682 | ELSE | |
683 | bl parse-word pad place pad | |
684 | THEN | |
685 | ; immediate | |
686 | ||
687 | : SLITERAL ( addr cnt -- , compile string ) | |
688 | compile (S") | |
689 | ", | |
690 | ; IMMEDIATE | |
691 | ||
692 | : $APPEND ( addr count $1 -- , append text to $1 ) | |
693 | over >r | |
694 | dup >r | |
695 | count + ( -- a2 c2 end1 ) | |
696 | swap cmove | |
697 | r> dup c@ ( a1 c1 ) | |
698 | r> + ( -- a1 totalcount ) | |
699 | swap c! | |
700 | ; | |
701 | ||
702 | ||
703 | \ ANSI word to replace [COMPILE] and COMPILE ---------------- | |
704 | : POSTPONE ( <name> -- ) | |
705 | bl word find | |
706 | dup 0= | |
707 | IF | |
708 | ." Postpone could not find " count type cr abort | |
709 | ELSE | |
710 | 0> | |
711 | IF compile, \ immediate | |
712 | ELSE (compile) \ normal | |
713 | THEN | |
714 | THEN | |
715 | ; immediate | |
716 | ||
717 | \ ----------------------------------------------------------------- | |
718 | \ Auto Initialization | |
719 | : AUTO.INIT ( -- ) | |
720 | \ Kernel finds AUTO.INIT and executes it after loading dictionary. | |
721 | \ ." Begin AUTO.INIT ------" cr | |
722 | ; | |
723 | : AUTO.TERM ( -- ) | |
724 | \ Kernel finds AUTO.TERM and executes it on bye. | |
725 | \ ." End AUTO.TERM ------" cr | |
726 | ; | |
727 | ||
728 | \ -------------- INCLUDE ------------------------------------------ | |
729 | variable TRACE-INCLUDE | |
730 | ||
3b3c2dec | 731 | : INCLUDE.MARK.START ( c-addr u -- , mark start of include for FILE?) |
5a305613 HE |
732 | dup 5 + allocate throw >r |
733 | " ::::" r@ $move | |
734 | r@ $append | |
735 | r@ ['] noop (:) | |
736 | r> free throw | |
8e9db35f PB |
737 | ; |
738 | ||
739 | : INCLUDE.MARK.END ( -- , mark end of include ) | |
740 | " ;;;;" ['] noop (:) | |
741 | ; | |
742 | ||
3b3c2dec HE |
743 | : INCLUDED ( c-addr u -- ) |
744 | \ Print messages. | |
8e9db35f PB |
745 | trace-include @ |
746 | IF | |
3b3c2dec | 747 | >newline ." Include " 2dup type cr |
8e9db35f PB |
748 | THEN |
749 | here >r | |
3b3c2dec HE |
750 | 2dup r/o open-file |
751 | IF ( -- c-addr u bad-fid ) | |
752 | drop ." Could not find file " type cr abort | |
753 | ELSE ( -- c-addr u good-fid ) | |
754 | -rot include.mark.start | |
8e9db35f PB |
755 | depth >r |
756 | include-file \ will also close the file | |
757 | depth 1+ r> - | |
758 | IF | |
759 | ." Warning: stack depth changed during include!" cr | |
760 | .s cr | |
761 | 0sp | |
762 | THEN | |
763 | include.mark.end | |
764 | THEN | |
765 | trace-include @ | |
766 | IF | |
767 | ." include added " here r@ - . ." bytes," | |
768 | codelimit here - . ." left." cr | |
769 | THEN | |
770 | rdrop | |
771 | ; | |
772 | ||
3b3c2dec HE |
773 | : $INCLUDE ( $filename -- ) count included ; |
774 | ||
8e9db35f PB |
775 | create INCLUDE-SAVE-NAME 128 allot |
776 | : INCLUDE ( <fname> -- ) | |
777 | BL lword | |
778 | dup include-save-name $move \ save for RI | |
779 | $include | |
780 | ; | |
781 | ||
782 | : RI ( -- , ReInclude previous file as a convenience ) | |
783 | include-save-name $include | |
784 | ; | |
785 | ||
786 | : INCLUDE? ( <word> <file> -- , load file if word not defined ) | |
787 | bl word find | |
788 | IF drop bl word drop ( eat word from source ) | |
789 | ELSE drop include | |
790 | THEN | |
791 | ; | |
792 | ||
793 | \ desired sizes for dictionary loaded after SAVE-FORTH | |
794 | variable HEADERS-SIZE | |
795 | variable CODE-SIZE | |
796 | ||
797 | : AUTO.INIT | |
798 | auto.init | |
799 | codelimit codebase - code-size ! | |
800 | namelimit namebase - headers-size ! | |
801 | ; | |
802 | auto.init | |
803 | ||
804 | : SAVE-FORTH ( $name -- ) | |
805 | 0 \ Entry point | |
806 | headers-ptr @ namebase - 65536 + \ NameSize | |
807 | headers-size @ MAX | |
808 | here codebase - 131072 + \ CodeSize | |
809 | code-size @ MAX | |
810 | (save-forth) | |
811 | IF | |
812 | ." SAVE-FORTH failed!" cr abort | |
813 | THEN | |
814 | ; | |
815 | ||
816 | : TURNKEY ( $name entry-token-- ) | |
817 | 0 \ NameSize = 0, names not saved in turnkey dictionary | |
818 | here codebase - 131072 + \ CodeSize, remember that base is HEX | |
819 | (save-forth) | |
820 | IF | |
821 | ." TURNKEY failed!" cr abort | |
822 | THEN | |
823 | ; | |
824 | ||
825 | \ Now that we can load from files, load remainder of dictionary. | |
826 | ||
827 | trace-include on | |
828 | \ Turn this OFF if you do not want to see the contents of the stack after each entry. | |
829 | trace-stack off | |
830 | ||
831 | include loadp4th.fth | |
832 | ||
833 | decimal | |
834 | ||
835 | : ;;;; ; \ Mark end of this file so FILE? can find things in here. | |
836 | FREEZE \ prevent forgetting below this point | |
837 | ||
838 | .( Dictionary compiled, save in "pforth.dic".) cr | |
839 | c" pforth.dic" save-forth |