xref: /illumos-gate/usr/src/lib/efcode/engine/forth.c (revision 09e6639b)
1 /*
2  * CDDL HEADER START
3  *
4  * The contents of this file are subject to the terms of the
5  * Common Development and Distribution License (the "License").
6  * You may not use this file except in compliance with the License.
7  *
8  * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
9  * or http://www.opensolaris.org/os/licensing.
10  * See the License for the specific language governing permissions
11  * and limitations under the License.
12  *
13  * When distributing Covered Code, include this CDDL HEADER in each
14  * file and include the License file at usr/src/OPENSOLARIS.LICENSE.
15  * If applicable, add the following below this CDDL HEADER, with the
16  * fields enclosed by brackets "[]" replaced with your own identifying
17  * information: Portions Copyright [yyyy] [name of copyright owner]
18  *
19  * CDDL HEADER END
20  */
21 /*
22  * Copyright 2007 Sun Microsystems, Inc.  All rights reserved.
23  * Use is subject to license terms.
24  */
25 
26 #include <stdio.h>
27 #include <stdlib.h>
28 #include <string.h>
29 #include <stdarg.h>
30 #include <ctype.h>
31 
32 #include <fcode/private.h>
33 #include <fcode/log.h>
34 
35 void (*semi_ptr)(fcode_env_t *env) = do_semi;
36 void (*does_ptr)(fcode_env_t *env) = install_does;
37 void (*quote_ptr)(fcode_env_t *env) = do_quote;
38 void (*blit_ptr)(fcode_env_t *env) = do_literal;
39 void (*tlit_ptr)(fcode_env_t *env) = do_literal;
40 void (*do_bdo_ptr)(fcode_env_t *env) = do_bdo;
41 void (*do_bqdo_ptr)(fcode_env_t *env) = do_bqdo;
42 void (*create_ptr)(fcode_env_t *env) = do_creator;
43 void (*do_leave_ptr)(fcode_env_t *env) = do_bleave;
44 void (*do_loop_ptr)(fcode_env_t *env) = do_bloop;
45 void (*do_ploop_ptr)(fcode_env_t *env) = do_bploop;
46 
47 void unaligned_lstore(fcode_env_t *);
48 void unaligned_wstore(fcode_env_t *);
49 void unaligned_lfetch(fcode_env_t *);
50 void unaligned_wfetch(fcode_env_t *);
51 
52 /* start with the simple maths functions */
53 
54 
55 void
add(fcode_env_t * env)56 add(fcode_env_t *env)
57 {
58 	fstack_t d;
59 
60 	CHECK_DEPTH(env, 2, "+");
61 	d = POP(DS);
62 	TOS += d;
63 }
64 
65 void
subtract(fcode_env_t * env)66 subtract(fcode_env_t *env)
67 {
68 	fstack_t d;
69 
70 	CHECK_DEPTH(env, 2, "-");
71 	d = POP(DS);
72 	TOS -= d;
73 }
74 
75 void
multiply(fcode_env_t * env)76 multiply(fcode_env_t *env)
77 {
78 	fstack_t d;
79 
80 	CHECK_DEPTH(env, 2, "*");
81 	d = POP(DS);
82 	TOS *= d;
83 }
84 
85 void
slash_mod(fcode_env_t * env)86 slash_mod(fcode_env_t *env)
87 {
88 	fstack_t d, o, t, rem;
89 	int sign = 1;
90 
91 	CHECK_DEPTH(env, 2, "/mod");
92 	d = POP(DS);
93 	o = t = POP(DS);
94 
95 	if (d == 0) {
96 		throw_from_fclib(env, 1, "/mod divide by zero");
97 	}
98 	sign = ((d ^ t) < 0);
99 	if (d < 0) {
100 		d = -d;
101 		if (sign) {
102 			t += (d-1);
103 		}
104 	}
105 	if (t < 0) {
106 		if (sign) {
107 			t -= (d-1);
108 		}
109 		t = -t;
110 	}
111 	t = t / d;
112 	if ((o ^ sign) < 0) {
113 		rem = (t * d) + o;
114 	} else {
115 		rem = o - (t*d);
116 	}
117 	if (sign) {
118 		t = -t;
119 	}
120 	PUSH(DS, rem);
121 	PUSH(DS, t);
122 }
123 
124 /*
125  * 'u/mod' Fcode implementation.
126  */
127 void
uslash_mod(fcode_env_t * env)128 uslash_mod(fcode_env_t *env)
129 {
130 	u_lforth_t u1, u2;
131 
132 	CHECK_DEPTH(env, 2, "u/mod");
133 	u2 = POP(DS);
134 	u1 = POP(DS);
135 
136 	if (u2 == 0)
137 		forth_abort(env, "u/mod: divide by zero");
138 	PUSH(DS, u1 % u2);
139 	PUSH(DS, u1 / u2);
140 }
141 
142 void
divide(fcode_env_t * env)143 divide(fcode_env_t *env)
144 {
145 	CHECK_DEPTH(env, 2, "/");
146 	slash_mod(env);
147 	nip(env);
148 }
149 
150 void
mod(fcode_env_t * env)151 mod(fcode_env_t *env)
152 {
153 	CHECK_DEPTH(env, 2, "mod");
154 	slash_mod(env);
155 	drop(env);
156 }
157 
158 void
and(fcode_env_t * env)159 and(fcode_env_t *env)
160 {
161 	fstack_t d;
162 
163 	CHECK_DEPTH(env, 2, "and");
164 	d = POP(DS);
165 	TOS &= d;
166 }
167 
168 void
or(fcode_env_t * env)169 or(fcode_env_t *env)
170 {
171 	fstack_t d;
172 
173 	CHECK_DEPTH(env, 2, "or");
174 	d = POP(DS);
175 	TOS |= d;
176 }
177 
178 void
xor(fcode_env_t * env)179 xor(fcode_env_t *env)
180 {
181 	fstack_t d;
182 
183 	CHECK_DEPTH(env, 2, "xor");
184 	d = POP(DS);
185 	TOS ^= d;
186 }
187 
188 void
invert(fcode_env_t * env)189 invert(fcode_env_t *env)
190 {
191 	CHECK_DEPTH(env, 1, "invert");
192 	TOS = ~TOS;
193 }
194 
195 void
lshift(fcode_env_t * env)196 lshift(fcode_env_t *env)
197 {
198 	fstack_t d;
199 
200 	CHECK_DEPTH(env, 2, "lshift");
201 	d = POP(DS);
202 	TOS = TOS << d;
203 }
204 
205 void
rshift(fcode_env_t * env)206 rshift(fcode_env_t *env)
207 {
208 	fstack_t d;
209 
210 	CHECK_DEPTH(env, 2, "rshift");
211 	d = POP(DS);
212 	TOS = ((ufstack_t)TOS) >> d;
213 }
214 
215 void
rshifta(fcode_env_t * env)216 rshifta(fcode_env_t *env)
217 {
218 	fstack_t d;
219 
220 	CHECK_DEPTH(env, 2, ">>a");
221 	d = POP(DS);
222 	TOS = ((s_lforth_t)TOS) >> d;
223 }
224 
225 void
negate(fcode_env_t * env)226 negate(fcode_env_t *env)
227 {
228 	CHECK_DEPTH(env, 1, "negate");
229 	TOS = -TOS;
230 }
231 
232 void
f_abs(fcode_env_t * env)233 f_abs(fcode_env_t *env)
234 {
235 	CHECK_DEPTH(env, 1, "abs");
236 	if (TOS < 0) TOS = -TOS;
237 }
238 
239 void
f_min(fcode_env_t * env)240 f_min(fcode_env_t *env)
241 {
242 	fstack_t d;
243 
244 	CHECK_DEPTH(env, 2, "min");
245 	d = POP(DS);
246 	if (d < TOS)	TOS = d;
247 }
248 
249 void
f_max(fcode_env_t * env)250 f_max(fcode_env_t *env)
251 {
252 	fstack_t d;
253 
254 	CHECK_DEPTH(env, 2, "max");
255 	d = POP(DS);
256 	if (d > TOS)	TOS = d;
257 }
258 
259 void
to_r(fcode_env_t * env)260 to_r(fcode_env_t *env)
261 {
262 	CHECK_DEPTH(env, 1, ">r");
263 	PUSH(RS, POP(DS));
264 }
265 
266 void
from_r(fcode_env_t * env)267 from_r(fcode_env_t *env)
268 {
269 	CHECK_RETURN_DEPTH(env, 1, "r>");
270 	PUSH(DS, POP(RS));
271 }
272 
273 void
rfetch(fcode_env_t * env)274 rfetch(fcode_env_t *env)
275 {
276 	CHECK_RETURN_DEPTH(env, 1, "r@");
277 	PUSH(DS, *RS);
278 }
279 
280 void
f_exit(fcode_env_t * env)281 f_exit(fcode_env_t *env)
282 {
283 	CHECK_RETURN_DEPTH(env, 1, "exit");
284 	IP = (token_t *)POP(RS);
285 }
286 
287 #define	COMPARE(cmp, rhs)	((((s_lforth_t)TOS) cmp((s_lforth_t)(rhs))) ? \
288 				    TRUE : FALSE)
289 #define	UCOMPARE(cmp, rhs)	((((u_lforth_t)TOS) cmp((u_lforth_t)(rhs))) ? \
290 				    TRUE : FALSE)
291 #define	EQUALS		==
292 #define	NOTEQUALS	!=
293 #define	LESSTHAN	<
294 #define	LESSEQUALS	<=
295 #define	GREATERTHAN	>
296 #define	GREATEREQUALS	>=
297 
298 void
zero_equals(fcode_env_t * env)299 zero_equals(fcode_env_t *env)
300 {
301 	CHECK_DEPTH(env, 1, "0=");
302 	TOS = COMPARE(EQUALS, 0);
303 }
304 
305 void
zero_not_equals(fcode_env_t * env)306 zero_not_equals(fcode_env_t *env)
307 {
308 	CHECK_DEPTH(env, 1, "0<>");
309 	TOS = COMPARE(NOTEQUALS, 0);
310 }
311 
312 void
zero_less(fcode_env_t * env)313 zero_less(fcode_env_t *env)
314 {
315 	CHECK_DEPTH(env, 1, "0<");
316 	TOS = COMPARE(LESSTHAN, 0);
317 }
318 
319 void
zero_less_equals(fcode_env_t * env)320 zero_less_equals(fcode_env_t *env)
321 {
322 	CHECK_DEPTH(env, 1, "0<=");
323 	TOS = COMPARE(LESSEQUALS, 0);
324 }
325 
326 void
zero_greater(fcode_env_t * env)327 zero_greater(fcode_env_t *env)
328 {
329 	CHECK_DEPTH(env, 1, "0>");
330 	TOS = COMPARE(GREATERTHAN, 0);
331 }
332 
333 void
zero_greater_equals(fcode_env_t * env)334 zero_greater_equals(fcode_env_t *env)
335 {
336 	CHECK_DEPTH(env, 1, "0>=");
337 	TOS = COMPARE(GREATEREQUALS, 0);
338 }
339 
340 void
less(fcode_env_t * env)341 less(fcode_env_t *env)
342 {
343 	fstack_t d;
344 
345 	CHECK_DEPTH(env, 2, "<");
346 	d = POP(DS);
347 	TOS = COMPARE(LESSTHAN, d);
348 }
349 
350 void
greater(fcode_env_t * env)351 greater(fcode_env_t *env)
352 {
353 	fstack_t d;
354 
355 	CHECK_DEPTH(env, 2, ">");
356 	d = POP(DS);
357 	TOS = COMPARE(GREATERTHAN, d);
358 }
359 
360 void
equals(fcode_env_t * env)361 equals(fcode_env_t *env)
362 {
363 	fstack_t d;
364 
365 	CHECK_DEPTH(env, 2, "=");
366 	d = POP(DS);
367 	TOS = COMPARE(EQUALS, d);
368 }
369 
370 void
not_equals(fcode_env_t * env)371 not_equals(fcode_env_t *env)
372 {
373 	fstack_t d;
374 
375 	CHECK_DEPTH(env, 2, "<>");
376 	d = POP(DS);
377 	TOS = COMPARE(NOTEQUALS, d);
378 }
379 
380 
381 void
unsign_greater(fcode_env_t * env)382 unsign_greater(fcode_env_t *env)
383 {
384 	ufstack_t d;
385 
386 	CHECK_DEPTH(env, 2, "u>");
387 	d = POP(DS);
388 	TOS = UCOMPARE(GREATERTHAN, d);
389 }
390 
391 void
unsign_less_equals(fcode_env_t * env)392 unsign_less_equals(fcode_env_t *env)
393 {
394 	ufstack_t d;
395 
396 	CHECK_DEPTH(env, 2, "u<=");
397 	d = POP(DS);
398 	TOS = UCOMPARE(LESSEQUALS, d);
399 }
400 
401 void
unsign_less(fcode_env_t * env)402 unsign_less(fcode_env_t *env)
403 {
404 	ufstack_t d;
405 
406 	CHECK_DEPTH(env, 2, "u<");
407 	d = POP(DS);
408 	TOS = UCOMPARE(LESSTHAN, d);
409 }
410 
411 void
unsign_greater_equals(fcode_env_t * env)412 unsign_greater_equals(fcode_env_t *env)
413 {
414 	ufstack_t d;
415 
416 	CHECK_DEPTH(env, 2, "u>=");
417 	d = POP(DS);
418 	TOS = UCOMPARE(GREATEREQUALS, d);
419 }
420 
421 void
greater_equals(fcode_env_t * env)422 greater_equals(fcode_env_t *env)
423 {
424 	fstack_t d;
425 
426 	CHECK_DEPTH(env, 2, ">=");
427 	d = POP(DS);
428 	TOS = COMPARE(GREATEREQUALS, d);
429 }
430 
431 void
less_equals(fcode_env_t * env)432 less_equals(fcode_env_t *env)
433 {
434 	fstack_t d;
435 
436 	CHECK_DEPTH(env, 2, "<=");
437 	d = POP(DS);
438 	TOS = COMPARE(LESSEQUALS, d);
439 }
440 
441 void
between(fcode_env_t * env)442 between(fcode_env_t *env)
443 {
444 	u_lforth_t hi, lo;
445 
446 	CHECK_DEPTH(env, 3, "between");
447 	hi = (u_lforth_t)POP(DS);
448 	lo = (u_lforth_t)POP(DS);
449 	TOS = (((u_lforth_t)TOS >= lo) && ((u_lforth_t)TOS <= hi) ? -1 : 0);
450 }
451 
452 void
within(fcode_env_t * env)453 within(fcode_env_t *env)
454 {
455 	u_lforth_t lo, hi;
456 
457 	CHECK_DEPTH(env, 3, "within");
458 	hi = (u_lforth_t)POP(DS);
459 	lo = (u_lforth_t)POP(DS);
460 	TOS = ((((u_lforth_t)TOS >= lo) && ((u_lforth_t)TOS < hi)) ? -1 : 0);
461 }
462 
463 void
do_literal(fcode_env_t * env)464 do_literal(fcode_env_t *env)
465 {
466 	PUSH(DS, *IP);
467 	IP++;
468 }
469 
470 void
literal(fcode_env_t * env)471 literal(fcode_env_t *env)
472 {
473 	if (env->state) {
474 		COMPILE_TOKEN(&blit_ptr);
475 		compile_comma(env);
476 	}
477 }
478 
479 void
do_also(fcode_env_t * env)480 do_also(fcode_env_t *env)
481 {
482 	token_t *d = *ORDER;
483 
484 	if (env->order_depth < (MAX_ORDER - 1)) {
485 		env->order[++env->order_depth] = d;
486 		debug_msg(DEBUG_CONTEXT, "CONTEXT:also: %d/%p/%p\n",
487 		    env->order_depth, CONTEXT, env->current);
488 	} else
489 		log_message(MSG_WARN, "Vocabulary search order exceeds: %d\n",
490 		    MAX_ORDER);
491 }
492 
493 void
do_previous(fcode_env_t * env)494 do_previous(fcode_env_t *env)
495 {
496 	if (env->order_depth) {
497 		env->order_depth--;
498 		debug_msg(DEBUG_CONTEXT, "CONTEXT:previous: %d/%p/%p\n",
499 		    env->order_depth, CONTEXT, env->current);
500 	}
501 }
502 
503 #ifdef DEBUG
504 void
do_order(fcode_env_t * env)505 do_order(fcode_env_t *env)
506 {
507 	int i;
508 
509 	log_message(MSG_INFO, "Order: Depth: %ld: ", env->order_depth);
510 	for (i = env->order_depth; i >= 0 && env->order[i]; i--)
511 		log_message(MSG_INFO, "%p ", (void *)env->order[i]);
512 	log_message(MSG_INFO, "\n");
513 }
514 #endif
515 
516 void
noop(fcode_env_t * env)517 noop(fcode_env_t *env)
518 {
519 	/* what a waste of cycles */
520 }
521 
522 
523 #define	FW_PER_FL	(sizeof (lforth_t)/sizeof (wforth_t))
524 
525 void
lwsplit(fcode_env_t * env)526 lwsplit(fcode_env_t *env)
527 {
528 	union {
529 		u_wforth_t l_wf[FW_PER_FL];
530 		u_lforth_t l_lf;
531 	} d;
532 	int i;
533 
534 	CHECK_DEPTH(env, 1, "lwsplit");
535 	d.l_lf = POP(DS);
536 	for (i = 0; i < FW_PER_FL; i++)
537 		PUSH(DS, d.l_wf[(FW_PER_FL - 1) - i]);
538 }
539 
540 void
wljoin(fcode_env_t * env)541 wljoin(fcode_env_t *env)
542 {
543 	union {
544 		u_wforth_t l_wf[FW_PER_FL];
545 		u_lforth_t l_lf;
546 	} d;
547 	int i;
548 
549 	CHECK_DEPTH(env, FW_PER_FL, "wljoin");
550 	for (i = 0; i < FW_PER_FL; i++)
551 		d.l_wf[i] = POP(DS);
552 	PUSH(DS, d.l_lf);
553 }
554 
555 void
lwflip(fcode_env_t * env)556 lwflip(fcode_env_t *env)
557 {
558 	union {
559 		u_wforth_t l_wf[FW_PER_FL];
560 		u_lforth_t l_lf;
561 	} d, c;
562 	int i;
563 
564 	CHECK_DEPTH(env, 1, "lwflip");
565 	d.l_lf = POP(DS);
566 	for (i = 0; i < FW_PER_FL; i++)
567 		c.l_wf[i] = d.l_wf[(FW_PER_FL - 1) - i];
568 	PUSH(DS, c.l_lf);
569 }
570 
571 void
lbsplit(fcode_env_t * env)572 lbsplit(fcode_env_t *env)
573 {
574 	union {
575 		uchar_t l_bytes[sizeof (lforth_t)];
576 		u_lforth_t l_lf;
577 	} d;
578 	int i;
579 
580 	CHECK_DEPTH(env, 1, "lbsplit");
581 	d.l_lf = POP(DS);
582 	for (i = 0; i < sizeof (lforth_t); i++)
583 		PUSH(DS, d.l_bytes[(sizeof (lforth_t) - 1) - i]);
584 }
585 
586 void
bljoin(fcode_env_t * env)587 bljoin(fcode_env_t *env)
588 {
589 	union {
590 		uchar_t l_bytes[sizeof (lforth_t)];
591 		u_lforth_t l_lf;
592 	} d;
593 	int i;
594 
595 	CHECK_DEPTH(env, sizeof (lforth_t), "bljoin");
596 	for (i = 0; i < sizeof (lforth_t); i++)
597 		d.l_bytes[i] = POP(DS);
598 	PUSH(DS, (fstack_t)d.l_lf);
599 }
600 
601 void
lbflip(fcode_env_t * env)602 lbflip(fcode_env_t *env)
603 {
604 	union {
605 		uchar_t l_bytes[sizeof (lforth_t)];
606 		u_lforth_t l_lf;
607 	} d, c;
608 	int i;
609 
610 	CHECK_DEPTH(env, 1, "lbflip");
611 	d.l_lf = POP(DS);
612 	for (i = 0; i < sizeof (lforth_t); i++)
613 		c.l_bytes[i] = d.l_bytes[(sizeof (lforth_t) - 1) - i];
614 	PUSH(DS, c.l_lf);
615 }
616 
617 void
wbsplit(fcode_env_t * env)618 wbsplit(fcode_env_t *env)
619 {
620 	union {
621 		uchar_t w_bytes[sizeof (wforth_t)];
622 		u_wforth_t w_wf;
623 	} d;
624 	int i;
625 
626 	CHECK_DEPTH(env, 1, "wbsplit");
627 	d.w_wf = POP(DS);
628 	for (i = 0; i < sizeof (wforth_t); i++)
629 		PUSH(DS, d.w_bytes[(sizeof (wforth_t) - 1) - i]);
630 }
631 
632 void
bwjoin(fcode_env_t * env)633 bwjoin(fcode_env_t *env)
634 {
635 	union {
636 		uchar_t w_bytes[sizeof (wforth_t)];
637 		u_wforth_t w_wf;
638 	} d;
639 	int i;
640 
641 	CHECK_DEPTH(env, sizeof (wforth_t), "bwjoin");
642 	for (i = 0; i < sizeof (wforth_t); i++)
643 		d.w_bytes[i] = POP(DS);
644 	PUSH(DS, d.w_wf);
645 }
646 
647 void
wbflip(fcode_env_t * env)648 wbflip(fcode_env_t *env)
649 {
650 	union {
651 		uchar_t w_bytes[sizeof (wforth_t)];
652 		u_wforth_t w_wf;
653 	} c, d;
654 	int i;
655 
656 	CHECK_DEPTH(env, 1, "wbflip");
657 	d.w_wf = POP(DS);
658 	for (i = 0; i < sizeof (wforth_t); i++)
659 		c.w_bytes[i] = d.w_bytes[(sizeof (wforth_t) - 1) - i];
660 	PUSH(DS, c.w_wf);
661 }
662 
663 void
upper_case(fcode_env_t * env)664 upper_case(fcode_env_t *env)
665 {
666 	CHECK_DEPTH(env, 1, "upc");
667 	TOS = toupper(TOS);
668 }
669 
670 void
lower_case(fcode_env_t * env)671 lower_case(fcode_env_t *env)
672 {
673 	CHECK_DEPTH(env, 1, "lcc");
674 	TOS = tolower(TOS);
675 }
676 
677 void
pack_str(fcode_env_t * env)678 pack_str(fcode_env_t *env)
679 {
680 	char *buf;
681 	size_t len;
682 	char *str;
683 
684 	CHECK_DEPTH(env, 3, "pack");
685 	buf = (char *)POP(DS);
686 	len = (size_t)POP(DS);
687 	str = (char *)TOS;
688 	TOS = (fstack_t)buf;
689 	*buf++ = (uchar_t)len;
690 	(void) strncpy(buf, str, (len&0xff));
691 }
692 
693 void
count_str(fcode_env_t * env)694 count_str(fcode_env_t *env)
695 {
696 	uchar_t *len;
697 
698 	CHECK_DEPTH(env, 1, "count");
699 	len = (uchar_t *)TOS;
700 	TOS += 1;
701 	PUSH(DS, *len);
702 }
703 
704 void
to_body(fcode_env_t * env)705 to_body(fcode_env_t *env)
706 {
707 	CHECK_DEPTH(env, 1, ">body");
708 	TOS = (fstack_t)(((acf_t)TOS)+1);
709 }
710 
711 void
to_acf(fcode_env_t * env)712 to_acf(fcode_env_t *env)
713 {
714 	CHECK_DEPTH(env, 1, "body>");
715 	TOS = (fstack_t)(((acf_t)TOS)-1);
716 }
717 
718 /*
719  * 'unloop' Fcode implementation, drop 3 loop ctrl elements off return stack.
720  */
721 static void
unloop(fcode_env_t * env)722 unloop(fcode_env_t *env)
723 {
724 	CHECK_RETURN_DEPTH(env, 3, "unloop");
725 	RS -= 3;
726 }
727 
728 /*
729  * 'um*' Fcode implementation.
730  */
731 static void
um_multiply(fcode_env_t * env)732 um_multiply(fcode_env_t *env)
733 {
734 	ufstack_t u1, u2;
735 	dforth_t d;
736 
737 	CHECK_DEPTH(env, 2, "um*");
738 	u1 = POP(DS);
739 	u2 = POP(DS);
740 	d = u1 * u2;
741 	push_double(env, d);
742 }
743 
744 /*
745  * um/mod (d.lo d.hi u -- urem uquot)
746  */
747 static void
um_slash_mod(fcode_env_t * env)748 um_slash_mod(fcode_env_t *env)
749 {
750 	u_dforth_t d;
751 	uint32_t u, urem, uquot;
752 
753 	CHECK_DEPTH(env, 3, "um/mod");
754 	u = (uint32_t)POP(DS);
755 	d = pop_double(env);
756 	urem = d % u;
757 	uquot = d / u;
758 	PUSH(DS, urem);
759 	PUSH(DS, uquot);
760 }
761 
762 /*
763  * d+ (d1.lo d1.hi d2.lo d2.hi -- dsum.lo dsum.hi)
764  */
765 static void
d_plus(fcode_env_t * env)766 d_plus(fcode_env_t *env)
767 {
768 	dforth_t d1, d2;
769 
770 	CHECK_DEPTH(env, 4, "d+");
771 	d2 = pop_double(env);
772 	d1 = pop_double(env);
773 	d1 += d2;
774 	push_double(env, d1);
775 }
776 
777 /*
778  * d- (d1.lo d1.hi d2.lo d2.hi -- ddif.lo ddif.hi)
779  */
780 static void
d_minus(fcode_env_t * env)781 d_minus(fcode_env_t *env)
782 {
783 	dforth_t d1, d2;
784 
785 	CHECK_DEPTH(env, 4, "d-");
786 	d2 = pop_double(env);
787 	d1 = pop_double(env);
788 	d1 -= d2;
789 	push_double(env, d1);
790 }
791 
792 void
set_here(fcode_env_t * env,uchar_t * new_here,char * where)793 set_here(fcode_env_t *env, uchar_t *new_here, char *where)
794 {
795 	if (new_here < HERE) {
796 		if (strcmp(where, "temporary_execute")) {
797 			/*
798 			 * Other than temporary_execute, no one should set
799 			 * here backwards.
800 			 */
801 			log_message(MSG_WARN, "Warning: set_here(%s) back: old:"
802 			    " %p new: %p\n", where, HERE, new_here);
803 		}
804 	}
805 	if (new_here >= env->base + dict_size)
806 		forth_abort(env, "Here (%p) set past dictionary end (%p)",
807 		    new_here, env->base + dict_size);
808 	HERE = new_here;
809 }
810 
811 static void
unaligned_store(fcode_env_t * env)812 unaligned_store(fcode_env_t *env)
813 {
814 	extern void unaligned_xstore(fcode_env_t *);
815 
816 	if (sizeof (fstack_t) == sizeof (lforth_t))
817 		unaligned_lstore(env);
818 	else
819 		unaligned_xstore(env);
820 }
821 
822 static void
unaligned_fetch(fcode_env_t * env)823 unaligned_fetch(fcode_env_t *env)
824 {
825 	extern void unaligned_xfetch(fcode_env_t *);
826 
827 	if (sizeof (fstack_t) == sizeof (lforth_t))
828 		unaligned_lfetch(env);
829 	else
830 		unaligned_xfetch(env);
831 }
832 
833 void
comma(fcode_env_t * env)834 comma(fcode_env_t *env)
835 {
836 	CHECK_DEPTH(env, 1, ",");
837 	DEBUGF(COMMA, dump_comma(env, ","));
838 	PUSH(DS, (fstack_t)HERE);
839 	unaligned_store(env);
840 	set_here(env, HERE + sizeof (fstack_t), "comma");
841 }
842 
843 void
lcomma(fcode_env_t * env)844 lcomma(fcode_env_t *env)
845 {
846 	CHECK_DEPTH(env, 1, "l,");
847 	DEBUGF(COMMA, dump_comma(env, "l,"));
848 	PUSH(DS, (fstack_t)HERE);
849 	unaligned_lstore(env);
850 	set_here(env, HERE + sizeof (u_lforth_t), "lcomma");
851 }
852 
853 void
wcomma(fcode_env_t * env)854 wcomma(fcode_env_t *env)
855 {
856 	CHECK_DEPTH(env, 1, "w,");
857 	DEBUGF(COMMA, dump_comma(env, "w,"));
858 	PUSH(DS, (fstack_t)HERE);
859 	unaligned_wstore(env);
860 	set_here(env, HERE + sizeof (u_wforth_t), "wcomma");
861 }
862 
863 void
ccomma(fcode_env_t * env)864 ccomma(fcode_env_t *env)
865 {
866 	CHECK_DEPTH(env, 1, "c,");
867 	DEBUGF(COMMA, dump_comma(env, "c,"));
868 	PUSH(DS, (fstack_t)HERE);
869 	cstore(env);
870 	set_here(env, HERE + sizeof (uchar_t), "ccomma");
871 }
872 
873 void
token_roundup(fcode_env_t * env,char * where)874 token_roundup(fcode_env_t *env, char *where)
875 {
876 	if ((((token_t)HERE) & (sizeof (token_t) - 1)) != 0) {
877 		set_here(env, (uchar_t *)TOKEN_ROUNDUP(HERE), where);
878 	}
879 }
880 
881 void
compile_comma(fcode_env_t * env)882 compile_comma(fcode_env_t *env)
883 {
884 	CHECK_DEPTH(env, 1, "compile,");
885 	DEBUGF(COMMA, dump_comma(env, "compile,"));
886 	token_roundup(env, "compile,");
887 	PUSH(DS, (fstack_t)HERE);
888 	unaligned_store(env);
889 	set_here(env, HERE + sizeof (fstack_t), "compile,");
890 }
891 
892 void
unaligned_lfetch(fcode_env_t * env)893 unaligned_lfetch(fcode_env_t *env)
894 {
895 	fstack_t addr;
896 	int i;
897 
898 	CHECK_DEPTH(env, 1, "unaligned-l@");
899 	addr = POP(DS);
900 	for (i = 0; i < sizeof (lforth_t); i++, addr++) {
901 		PUSH(DS, addr);
902 		cfetch(env);
903 	}
904 	bljoin(env);
905 	lbflip(env);
906 }
907 
908 void
unaligned_lstore(fcode_env_t * env)909 unaligned_lstore(fcode_env_t *env)
910 {
911 	fstack_t addr;
912 	int i;
913 
914 	CHECK_DEPTH(env, 2, "unaligned-l!");
915 	addr = POP(DS);
916 	lbsplit(env);
917 	for (i = 0; i < sizeof (lforth_t); i++, addr++) {
918 		PUSH(DS, addr);
919 		cstore(env);
920 	}
921 }
922 
923 void
unaligned_wfetch(fcode_env_t * env)924 unaligned_wfetch(fcode_env_t *env)
925 {
926 	fstack_t addr;
927 	int i;
928 
929 	CHECK_DEPTH(env, 1, "unaligned-w@");
930 	addr = POP(DS);
931 	for (i = 0; i < sizeof (wforth_t); i++, addr++) {
932 		PUSH(DS, addr);
933 		cfetch(env);
934 	}
935 	bwjoin(env);
936 	wbflip(env);
937 }
938 
939 void
unaligned_wstore(fcode_env_t * env)940 unaligned_wstore(fcode_env_t *env)
941 {
942 	fstack_t addr;
943 	int i;
944 
945 	CHECK_DEPTH(env, 2, "unaligned-w!");
946 	addr = POP(DS);
947 	wbsplit(env);
948 	for (i = 0; i < sizeof (wforth_t); i++, addr++) {
949 		PUSH(DS, addr);
950 		cstore(env);
951 	}
952 }
953 
954 /*
955  * 'lbflips' Fcode implementation.
956  */
957 static void
lbflips(fcode_env_t * env)958 lbflips(fcode_env_t *env)
959 {
960 	fstack_t len, addr;
961 	int i;
962 
963 	CHECK_DEPTH(env, 2, "lbflips");
964 	len = POP(DS);
965 	addr = POP(DS);
966 	for (i = 0; i < len; i += sizeof (lforth_t),
967 	    addr += sizeof (lforth_t)) {
968 		PUSH(DS, addr);
969 		unaligned_lfetch(env);
970 		lbflip(env);
971 		PUSH(DS, addr);
972 		unaligned_lstore(env);
973 	}
974 }
975 
976 /*
977  * 'wbflips' Fcode implementation.
978  */
979 static void
wbflips(fcode_env_t * env)980 wbflips(fcode_env_t *env)
981 {
982 	fstack_t len, addr;
983 	int i;
984 
985 	CHECK_DEPTH(env, 2, "wbflips");
986 	len = POP(DS);
987 	addr = POP(DS);
988 	for (i = 0; i < len; i += sizeof (wforth_t),
989 	    addr += sizeof (wforth_t)) {
990 		PUSH(DS, addr);
991 		unaligned_wfetch(env);
992 		wbflip(env);
993 		PUSH(DS, addr);
994 		unaligned_wstore(env);
995 	}
996 }
997 
998 /*
999  * 'lwflips' Fcode implementation.
1000  */
1001 static void
lwflips(fcode_env_t * env)1002 lwflips(fcode_env_t *env)
1003 {
1004 	fstack_t len, addr;
1005 	int i;
1006 
1007 	CHECK_DEPTH(env, 2, "lwflips");
1008 	len = POP(DS);
1009 	addr = POP(DS);
1010 	for (i = 0; i < len; i += sizeof (lforth_t),
1011 	    addr += sizeof (lforth_t)) {
1012 		PUSH(DS, addr);
1013 		unaligned_lfetch(env);
1014 		lwflip(env);
1015 		PUSH(DS, addr);
1016 		unaligned_lstore(env);
1017 	}
1018 }
1019 
1020 void
base(fcode_env_t * env)1021 base(fcode_env_t *env)
1022 {
1023 	PUSH(DS, (fstack_t)&env->num_base);
1024 }
1025 
1026 void
dot_s(fcode_env_t * env)1027 dot_s(fcode_env_t *env)
1028 {
1029 	output_data_stack(env, MSG_INFO);
1030 }
1031 
1032 void
state(fcode_env_t * env)1033 state(fcode_env_t *env)
1034 {
1035 	PUSH(DS, (fstack_t)&env->state);
1036 }
1037 
1038 int
is_digit(char digit,int num_base,fstack_t * dptr)1039 is_digit(char digit, int num_base, fstack_t *dptr)
1040 {
1041 	int error = 0;
1042 	char base;
1043 
1044 	if (num_base < 10) {
1045 		base = '0' + (num_base-1);
1046 	} else {
1047 		base = 'a' + (num_base - 10);
1048 	}
1049 
1050 	*dptr = 0;
1051 	if (digit > '9') digit |= 0x20;
1052 	if (((digit < '0') || (digit > base)) ||
1053 	    ((digit > '9') && (digit < 'a') && (num_base > 10)))
1054 		error = 1;
1055 	else {
1056 		if (digit <= '9')
1057 			digit -= '0';
1058 		else
1059 			digit = digit - 'a' + 10;
1060 		*dptr = digit;
1061 	}
1062 	return (error);
1063 }
1064 
1065 void
dollar_number(fcode_env_t * env)1066 dollar_number(fcode_env_t *env)
1067 {
1068 	char *buf;
1069 	fstack_t value;
1070 	int len, sign = 1, error = 0;
1071 
1072 	CHECK_DEPTH(env, 2, "$number");
1073 	buf = pop_a_string(env, &len);
1074 	if (*buf == '-') {
1075 		sign = -1;
1076 		buf++;
1077 		len--;
1078 	}
1079 	value = 0;
1080 	while (len-- && !error) {
1081 		fstack_t digit;
1082 
1083 		if (*buf == '.') {
1084 			buf++;
1085 			continue;
1086 		}
1087 		value *= env->num_base;
1088 		error = is_digit(*buf++, env->num_base, &digit);
1089 		value += digit;
1090 	}
1091 	if (error) {
1092 		PUSH(DS, -1);
1093 	} else {
1094 		value *= sign;
1095 		PUSH(DS, value);
1096 		PUSH(DS, 0);
1097 	}
1098 }
1099 
1100 void
digit(fcode_env_t * env)1101 digit(fcode_env_t *env)
1102 {
1103 	fstack_t base;
1104 	fstack_t value;
1105 
1106 	CHECK_DEPTH(env, 2, "digit");
1107 	base = POP(DS);
1108 	if (is_digit(TOS, base, &value))
1109 		PUSH(DS, 0);
1110 	else {
1111 		TOS = value;
1112 		PUSH(DS, -1);
1113 	}
1114 }
1115 
1116 void
space(fcode_env_t * env)1117 space(fcode_env_t *env)
1118 {
1119 	PUSH(DS, ' ');
1120 }
1121 
1122 void
backspace(fcode_env_t * env)1123 backspace(fcode_env_t *env)
1124 {
1125 	PUSH(DS, '\b');
1126 }
1127 
1128 void
bell(fcode_env_t * env)1129 bell(fcode_env_t *env)
1130 {
1131 	PUSH(DS, '\a');
1132 }
1133 
1134 void
fc_bounds(fcode_env_t * env)1135 fc_bounds(fcode_env_t *env)
1136 {
1137 	fstack_t lo, hi;
1138 
1139 	CHECK_DEPTH(env, 2, "bounds");
1140 	lo = DS[-1];
1141 	hi = TOS;
1142 	DS[-1] = lo+hi;
1143 	TOS = lo;
1144 }
1145 
1146 void
here(fcode_env_t * env)1147 here(fcode_env_t *env)
1148 {
1149 	PUSH(DS, (fstack_t)HERE);
1150 }
1151 
1152 void
aligned(fcode_env_t * env)1153 aligned(fcode_env_t *env)
1154 {
1155 	ufstack_t a;
1156 
1157 	CHECK_DEPTH(env, 1, "aligned");
1158 	a = (TOS & (sizeof (lforth_t) - 1));
1159 	if (a)
1160 		TOS += (sizeof (lforth_t) - a);
1161 }
1162 
1163 void
instance(fcode_env_t * env)1164 instance(fcode_env_t *env)
1165 {
1166 	env->instance_mode |= 1;
1167 }
1168 
1169 void
semi(fcode_env_t * env)1170 semi(fcode_env_t *env)
1171 {
1172 
1173 	env->state &= ~1;
1174 	COMPILE_TOKEN(&semi_ptr);
1175 
1176 	/*
1177 	 * check if we need to supress expose action;
1178 	 * If so this is an internal word and has no link field
1179 	 * or it is a temporary compile
1180 	 */
1181 
1182 	if (env->state == 0) {
1183 		expose_acf(env, "<semi>");
1184 	}
1185 	if (env->state & 8) {
1186 		env->state ^= 8;
1187 	}
1188 }
1189 
1190 void
do_create(fcode_env_t * env)1191 do_create(fcode_env_t *env)
1192 {
1193 	PUSH(DS, (fstack_t)WA);
1194 }
1195 
1196 void
drop(fcode_env_t * env)1197 drop(fcode_env_t *env)
1198 {
1199 	CHECK_DEPTH(env, 1, "drop");
1200 	(void) POP(DS);
1201 }
1202 
1203 void
f_dup(fcode_env_t * env)1204 f_dup(fcode_env_t *env)
1205 {
1206 	fstack_t d;
1207 
1208 	CHECK_DEPTH(env, 1, "dup");
1209 	d = TOS;
1210 	PUSH(DS, d);
1211 }
1212 
1213 void
over(fcode_env_t * env)1214 over(fcode_env_t *env)
1215 {
1216 	fstack_t d;
1217 
1218 	CHECK_DEPTH(env, 2, "over");
1219 	d = DS[-1];
1220 	PUSH(DS, d);
1221 }
1222 
1223 void
swap(fcode_env_t * env)1224 swap(fcode_env_t *env)
1225 {
1226 	fstack_t d;
1227 
1228 	CHECK_DEPTH(env, 2, "swap");
1229 	d = DS[-1];
1230 	DS[-1] = DS[0];
1231 	DS[0]  = d;
1232 }
1233 
1234 
1235 void
rot(fcode_env_t * env)1236 rot(fcode_env_t *env)
1237 {
1238 	fstack_t d;
1239 
1240 	CHECK_DEPTH(env, 3, "rot");
1241 	d = DS[-2];
1242 	DS[-2] = DS[-1];
1243 	DS[-1] = TOS;
1244 	TOS    = d;
1245 }
1246 
1247 void
minus_rot(fcode_env_t * env)1248 minus_rot(fcode_env_t *env)
1249 {
1250 	fstack_t d;
1251 
1252 	CHECK_DEPTH(env, 3, "-rot");
1253 	d = TOS;
1254 	TOS    = DS[-1];
1255 	DS[-1] = DS[-2];
1256 	DS[-2] = d;
1257 }
1258 
1259 void
tuck(fcode_env_t * env)1260 tuck(fcode_env_t *env)
1261 {
1262 	fstack_t d;
1263 
1264 	CHECK_DEPTH(env, 2, "tuck");
1265 	d = TOS;
1266 	swap(env);
1267 	PUSH(DS, d);
1268 }
1269 
1270 void
nip(fcode_env_t * env)1271 nip(fcode_env_t *env)
1272 {
1273 	CHECK_DEPTH(env, 2, "nip");
1274 	swap(env);
1275 	drop(env);
1276 }
1277 
1278 void
qdup(fcode_env_t * env)1279 qdup(fcode_env_t *env)
1280 {
1281 	fstack_t d;
1282 
1283 	CHECK_DEPTH(env, 1, "?dup");
1284 	d = TOS;
1285 	if (d)
1286 		PUSH(DS, d);
1287 }
1288 
1289 void
depth(fcode_env_t * env)1290 depth(fcode_env_t *env)
1291 {
1292 	fstack_t d;
1293 
1294 	d =  DS - env->ds0;
1295 	PUSH(DS, d);
1296 }
1297 
1298 void
pick(fcode_env_t * env)1299 pick(fcode_env_t *env)
1300 {
1301 	fstack_t p;
1302 
1303 	CHECK_DEPTH(env, 1, "pick");
1304 	p = POP(DS);
1305 	if (p < 0 || p >= (env->ds - env->ds0))
1306 		forth_abort(env, "pick: invalid pick value: %d\n", (int)p);
1307 	p = DS[-p];
1308 	PUSH(DS, p);
1309 }
1310 
1311 void
roll(fcode_env_t * env)1312 roll(fcode_env_t *env)
1313 {
1314 	fstack_t d, r;
1315 
1316 	CHECK_DEPTH(env, 1, "roll");
1317 	r = POP(DS);
1318 	if (r <= 0 || r >= (env->ds - env->ds0))
1319 		forth_abort(env, "roll: invalid roll value: %d\n", (int)r);
1320 
1321 	d = DS[-r];
1322 	while (r) {
1323 		DS[-r] = DS[ -(r-1) ];
1324 		r--;
1325 	}
1326 	TOS = d;
1327 }
1328 
1329 void
two_drop(fcode_env_t * env)1330 two_drop(fcode_env_t *env)
1331 {
1332 	CHECK_DEPTH(env, 2, "2drop");
1333 	DS -= 2;
1334 }
1335 
1336 void
two_dup(fcode_env_t * env)1337 two_dup(fcode_env_t *env)
1338 {
1339 	CHECK_DEPTH(env, 2, "2dup");
1340 	DS[1] = DS[-1];
1341 	DS[2] = TOS;
1342 	DS += 2;
1343 }
1344 
1345 void
two_over(fcode_env_t * env)1346 two_over(fcode_env_t *env)
1347 {
1348 	fstack_t a, b;
1349 
1350 	CHECK_DEPTH(env, 4, "2over");
1351 	a = DS[-3];
1352 	b = DS[-2];
1353 	PUSH(DS, a);
1354 	PUSH(DS, b);
1355 }
1356 
1357 void
two_swap(fcode_env_t * env)1358 two_swap(fcode_env_t *env)
1359 {
1360 	fstack_t a, b;
1361 
1362 	CHECK_DEPTH(env, 4, "2swap");
1363 	a = DS[-3];
1364 	b = DS[-2];
1365 	DS[-3] = DS[-1];
1366 	DS[-2] = TOS;
1367 	DS[-1] = a;
1368 	TOS    = b;
1369 }
1370 
1371 void
two_rot(fcode_env_t * env)1372 two_rot(fcode_env_t *env)
1373 {
1374 	fstack_t a, b;
1375 
1376 	CHECK_DEPTH(env, 6, "2rot");
1377 	a = DS[-5];
1378 	b = DS[-4];
1379 	DS[-5] = DS[-3];
1380 	DS[-4] = DS[-2];
1381 	DS[-3] = DS[-1];
1382 	DS[-2] = TOS;
1383 	DS[-1] = a;
1384 	TOS    = b;
1385 }
1386 
1387 void
two_slash(fcode_env_t * env)1388 two_slash(fcode_env_t *env)
1389 {
1390 	CHECK_DEPTH(env, 1, "2/");
1391 	TOS = TOS >> 1;
1392 }
1393 
1394 void
utwo_slash(fcode_env_t * env)1395 utwo_slash(fcode_env_t *env)
1396 {
1397 	CHECK_DEPTH(env, 1, "u2/");
1398 	TOS = (ufstack_t)((ufstack_t)TOS) >> 1;
1399 }
1400 
1401 void
two_times(fcode_env_t * env)1402 two_times(fcode_env_t *env)
1403 {
1404 	CHECK_DEPTH(env, 1, "2*");
1405 	TOS = (ufstack_t)((ufstack_t)TOS) << 1;
1406 }
1407 
1408 void
slash_c(fcode_env_t * env)1409 slash_c(fcode_env_t *env)
1410 {
1411 	PUSH(DS, sizeof (char));
1412 }
1413 
1414 void
slash_w(fcode_env_t * env)1415 slash_w(fcode_env_t *env)
1416 {
1417 	PUSH(DS, sizeof (wforth_t));
1418 }
1419 
1420 void
slash_l(fcode_env_t * env)1421 slash_l(fcode_env_t *env)
1422 {
1423 	PUSH(DS, sizeof (lforth_t));
1424 }
1425 
1426 void
slash_n(fcode_env_t * env)1427 slash_n(fcode_env_t *env)
1428 {
1429 	PUSH(DS, sizeof (fstack_t));
1430 }
1431 
1432 void
ca_plus(fcode_env_t * env)1433 ca_plus(fcode_env_t *env)
1434 {
1435 	fstack_t d;
1436 
1437 	CHECK_DEPTH(env, 2, "ca+");
1438 	d = POP(DS);
1439 	TOS += d * sizeof (char);
1440 }
1441 
1442 void
wa_plus(fcode_env_t * env)1443 wa_plus(fcode_env_t *env)
1444 {
1445 	fstack_t d;
1446 
1447 	CHECK_DEPTH(env, 2, "wa+");
1448 	d = POP(DS);
1449 	TOS += d * sizeof (wforth_t);
1450 }
1451 
1452 void
la_plus(fcode_env_t * env)1453 la_plus(fcode_env_t *env)
1454 {
1455 	fstack_t d;
1456 
1457 	CHECK_DEPTH(env, 2, "la+");
1458 	d = POP(DS);
1459 	TOS += d * sizeof (lforth_t);
1460 }
1461 
1462 void
na_plus(fcode_env_t * env)1463 na_plus(fcode_env_t *env)
1464 {
1465 	fstack_t d;
1466 
1467 	CHECK_DEPTH(env, 2, "na+");
1468 	d = POP(DS);
1469 	TOS += d * sizeof (fstack_t);
1470 }
1471 
1472 void
char_plus(fcode_env_t * env)1473 char_plus(fcode_env_t *env)
1474 {
1475 	CHECK_DEPTH(env, 1, "char+");
1476 	TOS += sizeof (char);
1477 }
1478 
1479 void
wa1_plus(fcode_env_t * env)1480 wa1_plus(fcode_env_t *env)
1481 {
1482 	CHECK_DEPTH(env, 1, "wa1+");
1483 	TOS += sizeof (wforth_t);
1484 }
1485 
1486 void
la1_plus(fcode_env_t * env)1487 la1_plus(fcode_env_t *env)
1488 {
1489 	CHECK_DEPTH(env, 1, "la1+");
1490 	TOS += sizeof (lforth_t);
1491 }
1492 
1493 void
cell_plus(fcode_env_t * env)1494 cell_plus(fcode_env_t *env)
1495 {
1496 	CHECK_DEPTH(env, 1, "cell+");
1497 	TOS += sizeof (fstack_t);
1498 }
1499 
1500 void
do_chars(fcode_env_t * env)1501 do_chars(fcode_env_t *env)
1502 {
1503 	CHECK_DEPTH(env, 1, "chars");
1504 }
1505 
1506 void
slash_w_times(fcode_env_t * env)1507 slash_w_times(fcode_env_t *env)
1508 {
1509 	CHECK_DEPTH(env, 1, "/w*");
1510 	TOS *= sizeof (wforth_t);
1511 }
1512 
1513 void
slash_l_times(fcode_env_t * env)1514 slash_l_times(fcode_env_t *env)
1515 {
1516 	CHECK_DEPTH(env, 1, "/l*");
1517 	TOS *= sizeof (lforth_t);
1518 }
1519 
1520 void
cells(fcode_env_t * env)1521 cells(fcode_env_t *env)
1522 {
1523 	CHECK_DEPTH(env, 1, "cells");
1524 	TOS *= sizeof (fstack_t);
1525 }
1526 
1527 void
do_on(fcode_env_t * env)1528 do_on(fcode_env_t *env)
1529 {
1530 	variable_t *d;
1531 
1532 	CHECK_DEPTH(env, 1, "on");
1533 	d = (variable_t *)POP(DS);
1534 	*d = -1;
1535 }
1536 
1537 void
do_off(fcode_env_t * env)1538 do_off(fcode_env_t *env)
1539 {
1540 	variable_t *d;
1541 
1542 	CHECK_DEPTH(env, 1, "off");
1543 	d = (variable_t *)POP(DS);
1544 	*d = 0;
1545 }
1546 
1547 void
fetch(fcode_env_t * env)1548 fetch(fcode_env_t *env)
1549 {
1550 	CHECK_DEPTH(env, 1, "@");
1551 	TOS = *((variable_t *)TOS);
1552 }
1553 
1554 void
lfetch(fcode_env_t * env)1555 lfetch(fcode_env_t *env)
1556 {
1557 	CHECK_DEPTH(env, 1, "l@");
1558 	TOS = *((lforth_t *)TOS);
1559 }
1560 
1561 void
wfetch(fcode_env_t * env)1562 wfetch(fcode_env_t *env)
1563 {
1564 	CHECK_DEPTH(env, 1, "w@");
1565 	TOS = *((wforth_t *)TOS);
1566 }
1567 
1568 void
swfetch(fcode_env_t * env)1569 swfetch(fcode_env_t *env)
1570 {
1571 	CHECK_DEPTH(env, 1, "<w@");
1572 	TOS = *((s_wforth_t *)TOS);
1573 }
1574 
1575 void
cfetch(fcode_env_t * env)1576 cfetch(fcode_env_t *env)
1577 {
1578 	CHECK_DEPTH(env, 1, "c@");
1579 	TOS = *((uchar_t *)TOS);
1580 }
1581 
1582 void
store(fcode_env_t * env)1583 store(fcode_env_t *env)
1584 {
1585 	variable_t *dptr;
1586 
1587 	CHECK_DEPTH(env, 2, "!");
1588 	dptr = (variable_t *)POP(DS);
1589 	*dptr = POP(DS);
1590 }
1591 
1592 void
addstore(fcode_env_t * env)1593 addstore(fcode_env_t *env)
1594 {
1595 	variable_t *dptr;
1596 
1597 	CHECK_DEPTH(env, 2, "+!");
1598 	dptr = (variable_t *)POP(DS);
1599 	*dptr = POP(DS) + *dptr;
1600 }
1601 
1602 void
lstore(fcode_env_t * env)1603 lstore(fcode_env_t *env)
1604 {
1605 	lforth_t *dptr;
1606 
1607 	CHECK_DEPTH(env, 2, "l!");
1608 	dptr = (lforth_t *)POP(DS);
1609 	*dptr = (lforth_t)POP(DS);
1610 }
1611 
1612 void
wstore(fcode_env_t * env)1613 wstore(fcode_env_t *env)
1614 {
1615 	wforth_t *dptr;
1616 
1617 	CHECK_DEPTH(env, 2, "w!");
1618 	dptr = (wforth_t *)POP(DS);
1619 	*dptr = (wforth_t)POP(DS);
1620 }
1621 
1622 void
cstore(fcode_env_t * env)1623 cstore(fcode_env_t *env)
1624 {
1625 	uchar_t *dptr;
1626 
1627 	CHECK_DEPTH(env, 2, "c!");
1628 	dptr = (uchar_t *)POP(DS);
1629 	*dptr = (uchar_t)POP(DS);
1630 }
1631 
1632 void
two_fetch(fcode_env_t * env)1633 two_fetch(fcode_env_t *env)
1634 {
1635 	variable_t *d;
1636 
1637 	CHECK_DEPTH(env, 1, "2@");
1638 	d = (variable_t *)POP(DS);
1639 	PUSH(DS, (fstack_t)(d + 1));
1640 	unaligned_fetch(env);
1641 	PUSH(DS, (fstack_t)d);
1642 	unaligned_fetch(env);
1643 }
1644 
1645 void
two_store(fcode_env_t * env)1646 two_store(fcode_env_t *env)
1647 {
1648 	variable_t *d;
1649 
1650 	CHECK_DEPTH(env, 3, "2!");
1651 	d = (variable_t *)POP(DS);
1652 	PUSH(DS, (fstack_t)d);
1653 	unaligned_store(env);
1654 	PUSH(DS, (fstack_t)(d + 1));
1655 	unaligned_store(env);
1656 }
1657 
1658 /*
1659  * 'move' Fcode reimplemented in fcdriver to check for mapped addresses.
1660  */
1661 void
fc_move(fcode_env_t * env)1662 fc_move(fcode_env_t *env)
1663 {
1664 	void *dest, *src;
1665 	size_t len;
1666 
1667 	CHECK_DEPTH(env, 3, "move");
1668 	len  = (size_t)POP(DS);
1669 	dest = (void *)POP(DS);
1670 	src  = (void *)POP(DS);
1671 
1672 	memmove(dest, src, len);
1673 }
1674 
1675 void
fc_fill(fcode_env_t * env)1676 fc_fill(fcode_env_t *env)
1677 {
1678 	void *dest;
1679 	uchar_t val;
1680 	size_t len;
1681 
1682 	CHECK_DEPTH(env, 3, "fill");
1683 	val  = (uchar_t)POP(DS);
1684 	len  = (size_t)POP(DS);
1685 	dest = (void *)POP(DS);
1686 	memset(dest, val, len);
1687 }
1688 
1689 void
fc_comp(fcode_env_t * env)1690 fc_comp(fcode_env_t *env)
1691 {
1692 	char *str1, *str2;
1693 	size_t len;
1694 	int res;
1695 
1696 	CHECK_DEPTH(env, 3, "comp");
1697 	len  = (size_t)POP(DS);
1698 	str1 = (char *)POP(DS);
1699 	str2 = (char *)POP(DS);
1700 	res  = memcmp(str2, str1, len);
1701 	if (res > 0)
1702 		res = 1;
1703 	else if (res < 0)
1704 		res = -1;
1705 	PUSH(DS, res);
1706 }
1707 
1708 void
set_temporary_compile(fcode_env_t * env)1709 set_temporary_compile(fcode_env_t *env)
1710 {
1711 	if (!env->state) {
1712 		token_roundup(env, "set_temporary_compile");
1713 		PUSH(RS, (fstack_t)HERE);
1714 		env->state = 3;
1715 		COMPILE_TOKEN(&do_colon);
1716 	}
1717 }
1718 
1719 void
bmark(fcode_env_t * env)1720 bmark(fcode_env_t *env)
1721 {
1722 	set_temporary_compile(env);
1723 	env->level++;
1724 	PUSH(DS, (fstack_t)HERE);
1725 }
1726 
1727 void
temporary_execute(fcode_env_t * env)1728 temporary_execute(fcode_env_t *env)
1729 {
1730 	uchar_t *saved_here;
1731 
1732 	if ((env->level == 0) && (env->state & 2)) {
1733 		fstack_t d = POP(RS);
1734 
1735 		semi(env);
1736 
1737 		saved_here = HERE;
1738 		/* execute the temporary definition */
1739 		env->state &= ~2;
1740 		PUSH(DS, d);
1741 		execute(env);
1742 
1743 		/* now wind the dictionary back! */
1744 		if (saved_here != HERE) {
1745 			debug_msg(DEBUG_COMMA, "Ignoring set_here in"
1746 			    " temporary_execute\n");
1747 		} else
1748 			set_here(env, (uchar_t *)d, "temporary_execute");
1749 	}
1750 }
1751 
1752 void
bresolve(fcode_env_t * env)1753 bresolve(fcode_env_t *env)
1754 {
1755 	token_t *prev = (token_t *)POP(DS);
1756 
1757 	env->level--;
1758 	*prev = (token_t)HERE;
1759 	temporary_execute(env);
1760 }
1761 
1762 #define	BRANCH_IP(ipp)	((token_t *)(*((token_t *)(ipp))))
1763 
1764 void
do_bbranch(fcode_env_t * env)1765 do_bbranch(fcode_env_t *env)
1766 {
1767 	IP = BRANCH_IP(IP);
1768 }
1769 
1770 void
do_bqbranch(fcode_env_t * env)1771 do_bqbranch(fcode_env_t *env)
1772 {
1773 	fstack_t flag;
1774 
1775 	CHECK_DEPTH(env, 1, "b?branch");
1776 	flag = POP(DS);
1777 	if (flag) {
1778 		IP++;
1779 	} else {
1780 		IP = BRANCH_IP(IP);
1781 	}
1782 }
1783 
1784 void
do_bofbranch(fcode_env_t * env)1785 do_bofbranch(fcode_env_t *env)
1786 {
1787 	fstack_t d;
1788 
1789 	CHECK_DEPTH(env, 2, "bofbranch");
1790 	d = POP(DS);
1791 	if (d == TOS) {
1792 		(void) POP(DS);
1793 		IP++;
1794 	} else {
1795 		IP = BRANCH_IP(IP);
1796 	}
1797 }
1798 
1799 void
do_bleave(fcode_env_t * env)1800 do_bleave(fcode_env_t *env)
1801 {
1802 	CHECK_RETURN_DEPTH(env, 3, "do_bleave");
1803 	(void) POP(RS);
1804 	(void) POP(RS);
1805 	IP = (token_t *)POP(RS);
1806 }
1807 
1808 void
loop_inc(fcode_env_t * env,fstack_t inc)1809 loop_inc(fcode_env_t *env, fstack_t inc)
1810 {
1811 	ufstack_t a;
1812 
1813 	CHECK_RETURN_DEPTH(env, 2, "loop_inc");
1814 
1815 	/*
1816 	 * Note: end condition is when the sign bit of R[0] changes.
1817 	 */
1818 	a = RS[0];
1819 	RS[0] += inc;
1820 	if (((a ^ RS[0]) & SIGN_BIT) == 0) {
1821 		IP = BRANCH_IP(IP);
1822 	} else {
1823 		do_bleave(env);
1824 	}
1825 }
1826 
1827 void
do_bloop(fcode_env_t * env)1828 do_bloop(fcode_env_t *env)
1829 {
1830 	loop_inc(env, 1);
1831 }
1832 
1833 void
do_bploop(fcode_env_t * env)1834 do_bploop(fcode_env_t *env)
1835 {
1836 	fstack_t d;
1837 
1838 	CHECK_DEPTH(env, 1, "+loop");
1839 	d = POP(DS);
1840 	loop_inc(env, d);
1841 }
1842 
1843 void
loop_common(fcode_env_t * env,fstack_t ptr)1844 loop_common(fcode_env_t *env, fstack_t ptr)
1845 {
1846 	short offset = get_short(env);
1847 
1848 	COMPILE_TOKEN(ptr);
1849 	env->level--;
1850 	compile_comma(env);
1851 	bresolve(env);
1852 }
1853 
1854 void
bloop(fcode_env_t * env)1855 bloop(fcode_env_t *env)
1856 {
1857 	loop_common(env, (fstack_t)&do_loop_ptr);
1858 }
1859 
1860 void
bplusloop(fcode_env_t * env)1861 bplusloop(fcode_env_t *env)
1862 {
1863 	loop_common(env, (fstack_t)&do_ploop_ptr);
1864 }
1865 
1866 void
common_do(fcode_env_t * env,fstack_t endpt,fstack_t start,fstack_t limit)1867 common_do(fcode_env_t *env, fstack_t endpt, fstack_t start, fstack_t limit)
1868 {
1869 	ufstack_t i, l;
1870 
1871 	/*
1872 	 * Same computation as OBP, sets up so that loop_inc will terminate
1873 	 * when the sign bit of RS[0] changes.
1874 	 */
1875 	i = (start - limit) - SIGN_BIT;
1876 	l  = limit + SIGN_BIT;
1877 	PUSH(RS, endpt);
1878 	PUSH(RS, l);
1879 	PUSH(RS, i);
1880 }
1881 
1882 void
do_bdo(fcode_env_t * env)1883 do_bdo(fcode_env_t *env)
1884 {
1885 	fstack_t lo, hi;
1886 	fstack_t endpt;
1887 
1888 	CHECK_DEPTH(env, 2, "bdo");
1889 	endpt = (fstack_t)BRANCH_IP(IP);
1890 	IP++;
1891 	lo = POP(DS);
1892 	hi = POP(DS);
1893 	common_do(env, endpt, lo, hi);
1894 }
1895 
1896 void
do_bqdo(fcode_env_t * env)1897 do_bqdo(fcode_env_t *env)
1898 {
1899 	fstack_t lo, hi;
1900 	fstack_t endpt;
1901 
1902 	CHECK_DEPTH(env, 2, "b?do");
1903 	endpt = (fstack_t)BRANCH_IP(IP);
1904 	IP++;
1905 	lo = POP(DS);
1906 	hi = POP(DS);
1907 	if (lo == hi) {
1908 		IP = (token_t *)endpt;
1909 	} else {
1910 		common_do(env, endpt, lo, hi);
1911 	}
1912 }
1913 
1914 void
compile_do_common(fcode_env_t * env,fstack_t ptr)1915 compile_do_common(fcode_env_t *env, fstack_t ptr)
1916 {
1917 	set_temporary_compile(env);
1918 	COMPILE_TOKEN(ptr);
1919 	bmark(env);
1920 	COMPILE_TOKEN(0);
1921 	bmark(env);
1922 }
1923 
1924 void
bdo(fcode_env_t * env)1925 bdo(fcode_env_t *env)
1926 {
1927 	short offset = (short)get_short(env);
1928 	compile_do_common(env, (fstack_t)&do_bdo_ptr);
1929 }
1930 
1931 void
bqdo(fcode_env_t * env)1932 bqdo(fcode_env_t *env)
1933 {
1934 	short offset = (short)get_short(env);
1935 	compile_do_common(env, (fstack_t)&do_bqdo_ptr);
1936 }
1937 
1938 void
loop_i(fcode_env_t * env)1939 loop_i(fcode_env_t *env)
1940 {
1941 	fstack_t i;
1942 
1943 	CHECK_RETURN_DEPTH(env, 2, "i");
1944 	i = RS[0] + RS[-1];
1945 	PUSH(DS, i);
1946 }
1947 
1948 void
loop_j(fcode_env_t * env)1949 loop_j(fcode_env_t *env)
1950 {
1951 	fstack_t j;
1952 
1953 	CHECK_RETURN_DEPTH(env, 5, "j");
1954 	j = RS[-3] + RS[-4];
1955 	PUSH(DS, j);
1956 }
1957 
1958 void
bleave(fcode_env_t * env)1959 bleave(fcode_env_t *env)
1960 {
1961 
1962 	if (env->state) {
1963 		COMPILE_TOKEN(&do_leave_ptr);
1964 	}
1965 }
1966 
1967 void
push_string(fcode_env_t * env,char * str,int len)1968 push_string(fcode_env_t *env, char *str, int len)
1969 {
1970 #define	NSTRINGS	16
1971 	static int string_count = 0;
1972 	static int  buflen[NSTRINGS];
1973 	static char *buffer[NSTRINGS];
1974 	char *dest;
1975 
1976 	if (!len) {
1977 		PUSH(DS, 0);
1978 		PUSH(DS, 0);
1979 		return;
1980 	}
1981 	if (len != buflen[string_count]) {
1982 		if (buffer[string_count]) FREE(buffer[string_count]);
1983 		buffer[ string_count ] = (char *)MALLOC(len+1);
1984 		buflen[ string_count ] = len;
1985 	}
1986 	dest = buffer[ string_count++ ];
1987 	string_count = string_count%NSTRINGS;
1988 	memcpy(dest, str, len);
1989 	*(dest+len) = 0;
1990 	PUSH(DS, (fstack_t)dest);
1991 	PUSH(DS, len);
1992 #undef NSTRINGS
1993 }
1994 
1995 void
parse_word(fcode_env_t * env)1996 parse_word(fcode_env_t *env)
1997 {
1998 	int len = 0;
1999 	char *next, *dest, *here = "";
2000 
2001 	if (env->input) {
2002 		here = env->input->scanptr;
2003 		while (*here == env->input->separator) here++;
2004 		next = strchr(here, env->input->separator);
2005 		if (next) {
2006 			len = next - here;
2007 			while (*next == env->input->separator) next++;
2008 		} else {
2009 			len = strlen(here);
2010 			next = here + len;
2011 		}
2012 		env->input->scanptr = next;
2013 	}
2014 	push_string(env, here, len);
2015 }
2016 
2017 void
install_does(fcode_env_t * env)2018 install_does(fcode_env_t *env)
2019 {
2020 	token_t *dptr;
2021 
2022 	dptr  = (token_t *)LINK_TO_ACF(env->lastlink);
2023 
2024 	log_message(MSG_WARN, "install_does: Last acf at: %p\n", (void *)dptr);
2025 
2026 	*dptr = ((token_t)(IP+1)) | 1;
2027 }
2028 
2029 void
does(fcode_env_t * env)2030 does(fcode_env_t *env)
2031 {
2032 	token_t *dptr;
2033 
2034 	token_roundup(env, "does");
2035 
2036 	if (env->state) {
2037 		COMPILE_TOKEN(&does_ptr);
2038 		COMPILE_TOKEN(&semi_ptr);
2039 	} else {
2040 		dptr  = (token_t *)LINK_TO_ACF(env->lastlink);
2041 		log_message(MSG_WARN, "does: Last acf at: %p\n", (void *)dptr);
2042 		*dptr = ((token_t)(HERE)) | 1;
2043 		env->state |= 1;
2044 	}
2045 	COMPILE_TOKEN(&do_colon);
2046 }
2047 
2048 void
do_current(fcode_env_t * env)2049 do_current(fcode_env_t *env)
2050 {
2051 	debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CURRENT\n");
2052 	PUSH(DS, (fstack_t)&env->current);
2053 }
2054 
2055 void
do_context(fcode_env_t * env)2056 do_context(fcode_env_t *env)
2057 {
2058 	debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CONTEXT\n");
2059 	PUSH(DS, (fstack_t)&CONTEXT);
2060 }
2061 
2062 void
do_definitions(fcode_env_t * env)2063 do_definitions(fcode_env_t *env)
2064 {
2065 	env->current = CONTEXT;
2066 	debug_msg(DEBUG_CONTEXT, "CONTEXT:definitions: %d/%p/%p\n",
2067 	    env->order_depth, CONTEXT, env->current);
2068 }
2069 
2070 void
make_header(fcode_env_t * env,int flags)2071 make_header(fcode_env_t *env, int flags)
2072 {
2073 	int len;
2074 	char *name;
2075 
2076 	name = parse_a_string(env, &len);
2077 	header(env, name, len, flags);
2078 }
2079 
2080 void
do_creator(fcode_env_t * env)2081 do_creator(fcode_env_t *env)
2082 {
2083 	make_header(env, 0);
2084 	COMPILE_TOKEN(&do_create);
2085 	expose_acf(env, "<create>");
2086 }
2087 
2088 void
create(fcode_env_t * env)2089 create(fcode_env_t *env)
2090 {
2091 	if (env->state) {
2092 		COMPILE_TOKEN(&create_ptr);
2093 	} else
2094 		do_creator(env);
2095 }
2096 
2097 void
colon(fcode_env_t * env)2098 colon(fcode_env_t *env)
2099 {
2100 	make_header(env, 0);
2101 	env->state |= 1;
2102 	COMPILE_TOKEN(&do_colon);
2103 }
2104 
2105 void
recursive(fcode_env_t * env)2106 recursive(fcode_env_t *env)
2107 {
2108 	expose_acf(env, "<recursive>");
2109 }
2110 
2111 void
compile_string(fcode_env_t * env)2112 compile_string(fcode_env_t *env)
2113 {
2114 	int len;
2115 	uchar_t *str, *tostr;
2116 
2117 	COMPILE_TOKEN(&quote_ptr);
2118 	len = POP(DS);
2119 	str = (uchar_t *)POP(DS);
2120 	tostr = HERE;
2121 	*tostr++ = len;
2122 	while (len--)
2123 		*tostr++ = *str++;
2124 	*tostr++ = '\0';
2125 	set_here(env, tostr, "compile_string");
2126 	token_roundup(env, "compile_string");
2127 }
2128 
2129 void
run_quote(fcode_env_t * env)2130 run_quote(fcode_env_t *env)
2131 {
2132 	char osep;
2133 
2134 	osep = env->input->separator;
2135 	env->input->separator = '"';
2136 	parse_word(env);
2137 	env->input->separator = osep;
2138 
2139 	if (env->state) {
2140 		compile_string(env);
2141 	}
2142 }
2143 
2144 void
does_vocabulary(fcode_env_t * env)2145 does_vocabulary(fcode_env_t *env)
2146 {
2147 	CONTEXT = WA;
2148 	debug_msg(DEBUG_CONTEXT, "CONTEXT:vocabulary: %d/%p/%p\n",
2149 	    env->order_depth, CONTEXT, env->current);
2150 }
2151 
2152 void
do_vocab(fcode_env_t * env)2153 do_vocab(fcode_env_t *env)
2154 {
2155 	make_header(env, 0);
2156 	COMPILE_TOKEN(does_vocabulary);
2157 	PUSH(DS, 0);
2158 	compile_comma(env);
2159 	expose_acf(env, "<vocabulary>");
2160 }
2161 
2162 void
do_forth(fcode_env_t * env)2163 do_forth(fcode_env_t *env)
2164 {
2165 	CONTEXT = (token_t *)(&env->forth_voc_link);
2166 	debug_msg(DEBUG_CONTEXT, "CONTEXT:forth: %d/%p/%p\n",
2167 	    env->order_depth, CONTEXT, env->current);
2168 }
2169 
2170 acf_t
voc_find(fcode_env_t * env)2171 voc_find(fcode_env_t *env)
2172 {
2173 	token_t *voc;
2174 	token_t *dptr;
2175 	char *find_name, *name;
2176 
2177 	voc = (token_t *)POP(DS);
2178 	find_name = pop_a_string(env, NULL);
2179 
2180 	for (dptr = (token_t *)(*voc); dptr; dptr = (token_t *)(*dptr)) {
2181 		if ((name = get_name(dptr)) == NULL)
2182 			continue;
2183 		if (strcmp(find_name, name) == 0) {
2184 			debug_msg(DEBUG_VOC_FIND, "%s -> %p\n", find_name,
2185 			    LINK_TO_ACF(dptr));
2186 			return (LINK_TO_ACF(dptr));
2187 		}
2188 	}
2189 	debug_msg(DEBUG_VOC_FIND, "%s not found\n", find_name);
2190 	return (NULL);
2191 }
2192 
2193 void
dollar_find(fcode_env_t * env)2194 dollar_find(fcode_env_t *env)
2195 {
2196 	acf_t acf = NULL;
2197 	int i;
2198 
2199 	CHECK_DEPTH(env, 2, "$find");
2200 	for (i = env->order_depth; i >= 0 && env->order[i] && !acf; i--) {
2201 		two_dup(env);
2202 		PUSH(DS, (fstack_t)env->order[i]);
2203 		acf = voc_find(env);
2204 	}
2205 	if (acf) {
2206 		two_drop(env);
2207 		PUSH(DS, (fstack_t)acf);
2208 		PUSH(DS, TRUE);
2209 	} else
2210 		PUSH(DS, FALSE);
2211 }
2212 
2213 void
interpret(fcode_env_t * env)2214 interpret(fcode_env_t *env)
2215 {
2216 	char *name;
2217 
2218 	parse_word(env);
2219 	while (TOS) {
2220 		two_dup(env);
2221 		dollar_find(env);
2222 		if (TOS) {
2223 			flag_t *flags;
2224 
2225 			drop(env);
2226 			nip(env);
2227 			nip(env);
2228 			flags = LINK_TO_FLAGS(ACF_TO_LINK(TOS));
2229 
2230 			if ((env->state) &&
2231 			    ((*flags & IMMEDIATE) == 0)) {
2232 				/* Compile in references */
2233 				compile_comma(env);
2234 			} else {
2235 				execute(env);
2236 			}
2237 		} else {
2238 			int bad;
2239 			drop(env);
2240 			dollar_number(env);
2241 			bad = POP(DS);
2242 			if (bad) {
2243 				two_dup(env);
2244 				name = pop_a_string(env, NULL);
2245 				log_message(MSG_INFO, "%s?\n", name);
2246 				break;
2247 			} else {
2248 				nip(env);
2249 				nip(env);
2250 				literal(env);
2251 			}
2252 		}
2253 		parse_word(env);
2254 	}
2255 	two_drop(env);
2256 }
2257 
2258 void
evaluate(fcode_env_t * env)2259 evaluate(fcode_env_t *env)
2260 {
2261 	input_typ *old_input = env->input;
2262 	input_typ *eval_bufp = MALLOC(sizeof (input_typ));
2263 
2264 	CHECK_DEPTH(env, 2, "evaluate");
2265 	eval_bufp->separator = ' ';
2266 	eval_bufp->maxlen = POP(DS);
2267 	eval_bufp->buffer = (char *)POP(DS);
2268 	eval_bufp->scanptr = eval_bufp->buffer;
2269 	env->input = eval_bufp;
2270 	interpret(env);
2271 	FREE(eval_bufp);
2272 	env->input = old_input;
2273 }
2274 
2275 void
make_common_access(fcode_env_t * env,char * name,int len,int ncells,int instance_mode,void (* acf_instance)(fcode_env_t * env),void (* acf_static)(fcode_env_t * env),void (* set_action)(fcode_env_t * env,int))2276 make_common_access(fcode_env_t *env,
2277     char *name, int len,
2278     int ncells,
2279     int instance_mode,
2280     void (*acf_instance)(fcode_env_t *env),
2281     void (*acf_static)(fcode_env_t *env),
2282     void (*set_action)(fcode_env_t *env, int))
2283 {
2284 	if (instance_mode && !MYSELF) {
2285 		system_message(env, "No instance context");
2286 	}
2287 
2288 	debug_msg(DEBUG_ACTIONS, "make_common_access:%s '%s', %d\n",
2289 	    (instance_mode ? "instance" : ""),
2290 	    (name ? name : ""), ncells);
2291 
2292 	if (len)
2293 		header(env, name, len, 0);
2294 	if (instance_mode) {
2295 		token_t *dptr;
2296 		int offset;
2297 
2298 		COMPILE_TOKEN(acf_instance);
2299 		dptr = alloc_instance_data(env, INIT_DATA, ncells, &offset);
2300 		debug_msg(DEBUG_ACTIONS, "Data: %p, offset %d\n", (char *)dptr,
2301 		    offset);
2302 		PUSH(DS, offset);
2303 		compile_comma(env);
2304 		while (ncells--)
2305 			*dptr++ = MYSELF->data[INIT_DATA][offset++] = POP(DS);
2306 		env->instance_mode = 0;
2307 	} else {
2308 		COMPILE_TOKEN(acf_static);
2309 		while (ncells--)
2310 			compile_comma(env);
2311 	}
2312 	expose_acf(env, name);
2313 	if (set_action)
2314 		set_action(env, instance_mode);
2315 }
2316 
2317 void
do_constant(fcode_env_t * env)2318 do_constant(fcode_env_t *env)
2319 {
2320 	PUSH(DS, (variable_t)(*WA));
2321 }
2322 
2323 void
do_crash(fcode_env_t * env)2324 do_crash(fcode_env_t *env)
2325 {
2326 	forth_abort(env, "Unitialized defer");
2327 }
2328 
2329 /*
2330  * 'behavior' Fcode retrieve execution behavior for a defer word.
2331  */
2332 static void
behavior(fcode_env_t * env)2333 behavior(fcode_env_t *env)
2334 {
2335 	acf_t defer_xt;
2336 	token_t token;
2337 	acf_t contents_xt;
2338 
2339 	CHECK_DEPTH(env, 1, "behavior");
2340 	defer_xt = (acf_t)POP(DS);
2341 	token = *defer_xt;
2342 	contents_xt = (token_t *)(token & ~1);
2343 	if ((token & 1) == 0 || *contents_xt != (token_t)&do_default_action)
2344 		forth_abort(env, "behavior: bad xt: %p indir: %x/%p\n",
2345 		    defer_xt, token & 1, *contents_xt);
2346 	defer_xt++;
2347 	PUSH(DS, *((variable_t *)defer_xt));
2348 }
2349 
2350 void
fc_abort(fcode_env_t * env,char * type)2351 fc_abort(fcode_env_t *env, char *type)
2352 {
2353 	forth_abort(env, "%s Fcode '%s' Executed", type,
2354 	    acf_to_name(env, WA - 1));
2355 }
2356 
2357 void
f_abort(fcode_env_t * env)2358 f_abort(fcode_env_t *env)
2359 {
2360 	fc_abort(env, "Abort");
2361 }
2362 
2363 /*
2364  * Fcodes chosen not to support.
2365  */
2366 void
fc_unimplemented(fcode_env_t * env)2367 fc_unimplemented(fcode_env_t *env)
2368 {
2369 	fc_abort(env, "Unimplemented");
2370 }
2371 
2372 /*
2373  * Fcodes that are Obsolete per P1275-1994.
2374  */
2375 void
fc_obsolete(fcode_env_t * env)2376 fc_obsolete(fcode_env_t *env)
2377 {
2378 	fc_abort(env, "Obsolete");
2379 }
2380 
2381 /*
2382  * Fcodes that are Historical per P1275-1994
2383  */
2384 void
fc_historical(fcode_env_t * env)2385 fc_historical(fcode_env_t *env)
2386 {
2387 	fc_abort(env, "Historical");
2388 }
2389 
2390 void
catch(fcode_env_t * env)2391 catch(fcode_env_t *env)
2392 {
2393 	error_frame *new;
2394 
2395 	CHECK_DEPTH(env, 1, "catch");
2396 	new = MALLOC(sizeof (error_frame));
2397 	new->ds		= DS-1;
2398 	new->rs		= RS;
2399 	new->myself	= MYSELF;
2400 	new->next	= env->catch_frame;
2401 	new->code	= 0;
2402 	env->catch_frame = new;
2403 	execute(env);
2404 	PUSH(DS, new->code);
2405 	env->catch_frame = new->next;
2406 	FREE(new);
2407 }
2408 
2409 void
throw_from_fclib(fcode_env_t * env,fstack_t errcode,char * fmt,...)2410 throw_from_fclib(fcode_env_t *env, fstack_t errcode, char *fmt, ...)
2411 {
2412 	error_frame *efp;
2413 	va_list ap;
2414 	char msg[256];
2415 
2416 	va_start(ap, fmt);
2417 	(void) vsprintf(msg, fmt, ap);
2418 
2419 	if (errcode) {
2420 
2421 		env->last_error = errcode;
2422 
2423 		/*
2424 		 * No catch frame set => fatal error
2425 		 */
2426 		efp = env->catch_frame;
2427 		if (!efp)
2428 			forth_abort(env, "%s: No catch frame", msg);
2429 
2430 		debug_msg(DEBUG_TRACING, "throw_from_fclib: throw: %s\n", msg);
2431 
2432 		/*
2433 		 * Setting IP=0 will force the unwinding of the calls
2434 		 * (see execute) which is how we will return (eventually)
2435 		 * to the test in catch that follows 'execute'.
2436 		 */
2437 		DS		= efp->ds;
2438 		RS		= efp->rs;
2439 		MYSELF		= efp->myself;
2440 		IP		= 0;
2441 		efp->code	= errcode;
2442 	}
2443 }
2444 
2445 void
throw(fcode_env_t * env)2446 throw(fcode_env_t *env)
2447 {
2448 	fstack_t t;
2449 
2450 	CHECK_DEPTH(env, 1, "throw");
2451 	t = POP(DS);
2452 	if (t >= -20 && t <= 20)
2453 		throw_from_fclib(env, t, "throw Fcode errcode: 0x%x", (int)t);
2454 	else {
2455 		if (t)
2456 			log_message(MSG_ERROR, "throw: errcode: 0x%x\n",
2457 			    (int)t);
2458 		throw_from_fclib(env, t, "throw Fcode err: %s", (char *)t);
2459 	}
2460 }
2461 
2462 void
tick_literal(fcode_env_t * env)2463 tick_literal(fcode_env_t *env)
2464 {
2465 	if (env->state) {
2466 		COMPILE_TOKEN(&tlit_ptr);
2467 		compile_comma(env);
2468 	}
2469 }
2470 
2471 void
do_tick(fcode_env_t * env)2472 do_tick(fcode_env_t *env)
2473 {
2474 	parse_word(env);
2475 	dollar_find(env);
2476 	invert(env);
2477 	throw(env);
2478 	tick_literal(env);
2479 }
2480 
2481 void
bracket_tick(fcode_env_t * env)2482 bracket_tick(fcode_env_t *env)
2483 {
2484 	do_tick(env);
2485 }
2486 
2487 #pragma init(_init)
2488 
2489 static void
_init(void)2490 _init(void)
2491 {
2492 	fcode_env_t *env = initial_env;
2493 
2494 	NOTICE;
2495 	ASSERT(env);
2496 
2497 	ANSI(0x019, 0,		"i",			loop_i);
2498 	ANSI(0x01a, 0,		"j",			loop_j);
2499 	ANSI(0x01d, 0,		"execute",		execute);
2500 	ANSI(0x01e, 0,		"+",			add);
2501 	ANSI(0x01f, 0,		"-",			subtract);
2502 	ANSI(0x020, 0,		"*",			multiply);
2503 	ANSI(0x021, 0,		"/",			divide);
2504 	ANSI(0x022, 0,		"mod",			mod);
2505 	FORTH(0,		"/mod",			slash_mod);
2506 	ANSI(0x023, 0,		"and",			and);
2507 	ANSI(0x024, 0,		"or",			or);
2508 	ANSI(0x025, 0,		"xor",			xor);
2509 	ANSI(0x026, 0,		"invert",		invert);
2510 	ANSI(0x027, 0,		"lshift",		lshift);
2511 	ANSI(0x028, 0,		"rshift",		rshift);
2512 	ANSI(0x029, 0,		">>a",			rshifta);
2513 	ANSI(0x02a, 0,		"/mod",			slash_mod);
2514 	ANSI(0x02b, 0,		"u/mod",		uslash_mod);
2515 	ANSI(0x02c, 0,		"negate",		negate);
2516 	ANSI(0x02d, 0,		"abs",			f_abs);
2517 	ANSI(0x02e, 0,		"min",			f_min);
2518 	ANSI(0x02f, 0,		"max",			f_max);
2519 	ANSI(0x030, 0,		">r",			to_r);
2520 	ANSI(0x031, 0,		"r>",			from_r);
2521 	ANSI(0x032, 0,		"r@",			rfetch);
2522 	ANSI(0x033, 0,		"exit",			f_exit);
2523 	ANSI(0x034, 0,		"0=",			zero_equals);
2524 	ANSI(0x035, 0,		"0<>",			zero_not_equals);
2525 	ANSI(0x036, 0,		"0<",			zero_less);
2526 	ANSI(0x037, 0,		"0<=",			zero_less_equals);
2527 	ANSI(0x038, 0,		"0>",			zero_greater);
2528 	ANSI(0x039, 0,		"0>=",			zero_greater_equals);
2529 	ANSI(0x03a, 0,		"<",			less);
2530 	ANSI(0x03b, 0,		">",			greater);
2531 	ANSI(0x03c, 0,		"=",			equals);
2532 	ANSI(0x03d, 0,		"<>",			not_equals);
2533 	ANSI(0x03e, 0,		"u>",			unsign_greater);
2534 	ANSI(0x03f, 0,		"u<=",			unsign_less_equals);
2535 	ANSI(0x040, 0,		"u<",			unsign_less);
2536 	ANSI(0x041, 0,		"u>=",			unsign_greater_equals);
2537 	ANSI(0x042, 0,		">=",			greater_equals);
2538 	ANSI(0x043, 0,		"<=",			less_equals);
2539 	ANSI(0x044, 0,		"between",		between);
2540 	ANSI(0x045, 0,		"within",		within);
2541 	ANSI(0x046, 0,		"drop",			drop);
2542 	ANSI(0x047, 0,		"dup",			f_dup);
2543 	ANSI(0x048, 0,		"over",			over);
2544 	ANSI(0x049, 0,		"swap",			swap);
2545 	ANSI(0x04a, 0,		"rot",			rot);
2546 	ANSI(0x04b, 0,		"-rot",			minus_rot);
2547 	ANSI(0x04c, 0,		"tuck",			tuck);
2548 	ANSI(0x04d, 0,		"nip",			nip);
2549 	ANSI(0x04e, 0,		"pick",			pick);
2550 	ANSI(0x04f, 0,		"roll",			roll);
2551 	ANSI(0x050, 0,		"?dup",			qdup);
2552 	ANSI(0x051, 0,		"depth",		depth);
2553 	ANSI(0x052, 0,		"2drop",		two_drop);
2554 	ANSI(0x053, 0,		"2dup",			two_dup);
2555 	ANSI(0x054, 0,		"2over",		two_over);
2556 	ANSI(0x055, 0,		"2swap",		two_swap);
2557 	ANSI(0x056, 0,		"2rot",			two_rot);
2558 	ANSI(0x057, 0,		"2/",			two_slash);
2559 	ANSI(0x058, 0,		"u2/",			utwo_slash);
2560 	ANSI(0x059, 0,		"2*",			two_times);
2561 	ANSI(0x05a, 0,		"/c",			slash_c);
2562 	ANSI(0x05b, 0,		"/w",			slash_w);
2563 	ANSI(0x05c, 0,		"/l",			slash_l);
2564 	ANSI(0x05d, 0,		"/n",			slash_n);
2565 	ANSI(0x05e, 0,		"ca+",			ca_plus);
2566 	ANSI(0x05f, 0,		"wa+",			wa_plus);
2567 	ANSI(0x060, 0,		"la+",			la_plus);
2568 	ANSI(0x061, 0,		"na+",			na_plus);
2569 	ANSI(0x062, 0,		"char+",		char_plus);
2570 	ANSI(0x063, 0,		"wa1+",			wa1_plus);
2571 	ANSI(0x064, 0,		"la1+",			la1_plus);
2572 	ANSI(0x065, 0,		"cell+",		cell_plus);
2573 	ANSI(0x066, 0,		"chars",		do_chars);
2574 	ANSI(0x067, 0,		"/w*",			slash_w_times);
2575 	ANSI(0x068, 0,		"/l*",			slash_l_times);
2576 	ANSI(0x069, 0,		"cells",		cells);
2577 	ANSI(0x06a, 0,		"on",			do_on);
2578 	ANSI(0x06b, 0,		"off",			do_off);
2579 	ANSI(0x06c, 0,		"+!",			addstore);
2580 	ANSI(0x06d, 0,		"@",			fetch);
2581 	ANSI(0x06e, 0,		"l@",			lfetch);
2582 	ANSI(0x06f, 0,		"w@",			wfetch);
2583 	ANSI(0x070, 0,		"<w@",			swfetch);
2584 	ANSI(0x071, 0,		"c@",			cfetch);
2585 	ANSI(0x072, 0,		"!",			store);
2586 	ANSI(0x073, 0,		"l!",			lstore);
2587 	ANSI(0x074, 0,		"w!",			wstore);
2588 	ANSI(0x075, 0,		"c!",			cstore);
2589 	ANSI(0x076, 0,		"2@",			two_fetch);
2590 	ANSI(0x077, 0,		"2!",			two_store);
2591 	ANSI(0x078, 0,		"move",			fc_move);
2592 	ANSI(0x079, 0,		"fill",			fc_fill);
2593 	ANSI(0x07a, 0,		"comp",			fc_comp);
2594 	ANSI(0x07b, 0,		"noop",			noop);
2595 	ANSI(0x07c, 0,		"lwsplit",		lwsplit);
2596 	ANSI(0x07d, 0,		"wljoin",		wljoin);
2597 	ANSI(0x07e, 0,		"lbsplit",		lbsplit);
2598 	ANSI(0x07f, 0,		"bljoin",		bljoin);
2599 	ANSI(0x080, 0,		"wbflip",		wbflip);
2600 	ANSI(0x081, 0,		"upc",			upper_case);
2601 	ANSI(0x082, 0,		"lcc",			lower_case);
2602 	ANSI(0x083, 0,		"pack",			pack_str);
2603 	ANSI(0x084, 0,		"count",		count_str);
2604 	ANSI(0x085, 0,		"body>",		to_acf);
2605 	ANSI(0x086, 0,		">body",		to_body);
2606 
2607 	ANSI(0x089, 0,		"unloop",		unloop);
2608 
2609 	ANSI(0x09f, 0,		".s",			dot_s);
2610 	ANSI(0x0a0, 0,		"base",			base);
2611 	FCODE(0x0a1, 0,		"convert",		fc_historical);
2612 	ANSI(0x0a2, 0,		"$number",		dollar_number);
2613 	ANSI(0x0a3, 0,		"digit",		digit);
2614 
2615 	ANSI(0x0a9, 0,		"bl",			space);
2616 	ANSI(0x0aa, 0,		"bs",			backspace);
2617 	ANSI(0x0ab, 0,		"bell",			bell);
2618 	ANSI(0x0ac, 0,		"bounds",		fc_bounds);
2619 	ANSI(0x0ad, 0,		"here",			here);
2620 
2621 	ANSI(0x0af, 0,		"wbsplit",		wbsplit);
2622 	ANSI(0x0b0, 0,		"bwjoin",		bwjoin);
2623 
2624 	P1275(0x0cb, 0,		"$find",		dollar_find);
2625 
2626 	ANSI(0x0d0, 0,		"c,",			ccomma);
2627 	ANSI(0x0d1, 0,		"w,",			wcomma);
2628 	ANSI(0x0d2, 0,		"l,",			lcomma);
2629 	ANSI(0x0d3, 0,		",",			comma);
2630 	ANSI(0x0d4, 0,		"um*",			um_multiply);
2631 	ANSI(0x0d5, 0,		"um/mod",		um_slash_mod);
2632 
2633 	ANSI(0x0d8, 0,		"d+",			d_plus);
2634 	ANSI(0x0d9, 0,		"d-",			d_minus);
2635 
2636 	ANSI(0x0dc, 0,		"state",		state);
2637 	ANSI(0x0de, 0,		"behavior",		behavior);
2638 	ANSI(0x0dd, 0,		"compile,",		compile_comma);
2639 
2640 	ANSI(0x216, 0,		"abort",		f_abort);
2641 	ANSI(0x217, 0,		"catch",		catch);
2642 	ANSI(0x218, 0,		"throw",		throw);
2643 
2644 	ANSI(0x226, 0,		"lwflip",		lwflip);
2645 	ANSI(0x227, 0,		"lbflip",		lbflip);
2646 	ANSI(0x228, 0,		"lbflips",		lbflips);
2647 
2648 	ANSI(0x236, 0,		"wbflips",		wbflips);
2649 	ANSI(0x237, 0,		"lwflips",		lwflips);
2650 
2651 	FORTH(0,		"forth",		do_forth);
2652 	FORTH(0,		"current",		do_current);
2653 	FORTH(0,		"context",		do_context);
2654 	FORTH(0,		"definitions",		do_definitions);
2655 	FORTH(0,		"vocabulary",		do_vocab);
2656 	FORTH(IMMEDIATE,	":",			colon);
2657 	FORTH(IMMEDIATE,	";",			semi);
2658 	FORTH(IMMEDIATE,	"create",		create);
2659 	FORTH(IMMEDIATE,	"does>",		does);
2660 	FORTH(IMMEDIATE,	"recursive",		recursive);
2661 	FORTH(0,		"parse-word",		parse_word);
2662 	FORTH(IMMEDIATE,	"\"",			run_quote);
2663 	FORTH(IMMEDIATE,	"order",		do_order);
2664 	FORTH(IMMEDIATE,	"also",			do_also);
2665 	FORTH(IMMEDIATE,	"previous",		do_previous);
2666 	FORTH(IMMEDIATE,	"'",			do_tick);
2667 	FORTH(IMMEDIATE,	"[']",			bracket_tick);
2668 	FORTH(0,		"unaligned-l@",		unaligned_lfetch);
2669 	FORTH(0,		"unaligned-l!",		unaligned_lstore);
2670 	FORTH(0,		"unaligned-w@",		unaligned_wfetch);
2671 	FORTH(0,		"unaligned-w!",		unaligned_wstore);
2672 }
2673