Home | History | Annotate | Download | only in engine
      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, Version 1.0 only
      6  * (the "License").  You may not use this file except in compliance
      7  * with the License.
      8  *
      9  * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
     10  * or http://www.opensolaris.org/os/licensing.
     11  * See the License for the specific language governing permissions
     12  * and limitations under the License.
     13  *
     14  * When distributing Covered Code, include this CDDL HEADER in each
     15  * file and include the License file at usr/src/OPENSOLARIS.LICENSE.
     16  * If applicable, add the following below this CDDL HEADER, with the
     17  * fields enclosed by brackets "[]" replaced with your own identifying
     18  * information: Portions Copyright [yyyy] [name of copyright owner]
     19  *
     20  * CDDL HEADER END
     21  */
     22 /*
     23  * Copyright (c) 2000 by Sun Microsystems, Inc.
     24  * All rights reserved.
     25  */
     26 
     27 #pragma ident	"%Z%%M%	%I%	%E% SMI"
     28 
     29 #include <stdio.h>
     30 #include <stdlib.h>
     31 #include <string.h>
     32 #include <ctype.h>
     33 
     34 #include <fcode/private.h>
     35 #include <fcode/log.h>
     36 
     37 int fcode_impl_count = 0;
     38 
     39 void (*crash_ptr)(fcode_env_t *env) = do_crash;
     40 
     41 uchar_t
     42 next_bytecode(fcode_env_t *env)
     43 {
     44 	uchar_t	byte;
     45 
     46 	byte = *env->fcode_ptr;
     47 	env->fcode_ptr += env->fcode_incr;
     48 	return (byte);
     49 }
     50 
     51 ushort_t
     52 get_next_token(fcode_env_t *env)
     53 {
     54 	ushort_t token = next_bytecode(env);
     55 	if ((token) && (token < 0x10)) {
     56 		token = (token << 8) | next_bytecode(env);
     57 	}
     58 	env->last_fcode = token;
     59 	return (token);
     60 }
     61 
     62 ushort_t
     63 get_short(fcode_env_t *env)
     64 {
     65 	ushort_t u;
     66 
     67 	/*
     68 	 * Logical or DOES NOT guarantee left to right evaluation...
     69 	 */
     70 	u = next_bytecode(env) << 8;
     71 	return (u | next_bytecode(env));
     72 }
     73 
     74 uint_t
     75 get_int(fcode_env_t *env)
     76 {
     77 	uint_t u;
     78 
     79 	/*
     80 	 * Logical or DOES NOT guarantee left to right evaluation...
     81 	 */
     82 	u = get_short(env) << 16;
     83 	return (u | get_short(env));
     84 }
     85 
     86 void
     87 expose_acf(fcode_env_t *env, char *name)
     88 {
     89 	if (name == NULL)
     90 		name = "<unknown>";
     91 	EXPOSE_ACF;
     92 	debug_msg(DEBUG_CONTEXT, "CONTEXT:expose_acf: acf: %p/'%s' %p\n",
     93 	    LINK_TO_ACF(env->lastlink), name, env->current);
     94 }
     95 
     96 void
     97 do_code(fcode_env_t *env, int token, char *name, void (*fn)(fcode_env_t *))
     98 {
     99 	env->table[token].name = name;
    100 	if (fn == NULL) {
    101 		env->table[token].apf = NULL;
    102 		env->table[token].name = name;
    103 	} else {
    104 		header(env, name, strlen(name), 0);
    105 		env->table[token].apf = (acf_t)HERE;
    106 		COMPILE_TOKEN(fn);
    107 		expose_acf(env, name);
    108 	}
    109 }
    110 
    111 void
    112 define_word(fcode_env_t *env, int flag, char *name, void (*fn)(fcode_env_t *))
    113 {
    114 	header(env, name, strlen(name), flag);
    115 	COMPILE_TOKEN(fn);
    116 	expose_acf(env, name);
    117 }
    118 
    119 void
    120 end0(fcode_env_t *env)
    121 {
    122 	env->interpretting = 0;
    123 }
    124 
    125 static void
    126 end1(fcode_env_t *env)
    127 {
    128 	env->interpretting = 0;
    129 }
    130 
    131 void
    132 blit(fcode_env_t *env)
    133 {
    134 	fstack_t d = (int)get_int(env);
    135 	PUSH(DS, d);
    136 	literal(env);
    137 }
    138 
    139 void (*bbranch_ptrs[3])(fcode_env_t *env) = {
    140 	do_bbranch,
    141 	do_bqbranch,
    142 	do_bofbranch
    143 };
    144 
    145 void
    146 branch_common(fcode_env_t *env, short direction, fstack_t which, int doswap)
    147 {
    148 	fstack_t *sp;
    149 	token_t *branch_loc;
    150 
    151 	ASSERT((which < 3) && (which >= 0));
    152 	which = (fstack_t)&bbranch_ptrs[which];
    153 	set_temporary_compile(env);
    154 	COMPILE_TOKEN(which);
    155 	if (direction >= 0) {
    156 		bmark(env);
    157 		if (doswap)
    158 			swap(env);
    159 		PUSH(DS, 0);
    160 		compile_comma(env);
    161 	} else {
    162 
    163 		/*
    164 		 * We look down the stack for a branch location
    165 		 * that isn't pointing to zero (i.e. a forward branch label).
    166 		 * We move the first one we find to the top of the stack,
    167 		 * which is what gets compiled in with 'compile_comma'.
    168 		 * Not finding a valid branch label is bad.
    169 		 */
    170 		for (sp = env->ds; sp >= env->ds0; sp--) {
    171 			branch_loc = (token_t *)*sp;
    172 			if (branch_loc && *branch_loc) {
    173 				break;
    174 			}
    175 		}
    176 		if (sp < env->ds0)
    177 			log_message(MSG_ERROR, "branch_common: back: "
    178 			    "no branch loc on stack\n");
    179 		else {
    180 			/* Move branch_loc to top of data stack */
    181 			for (; sp < env->ds; sp++)
    182 				*sp = sp[1];
    183 			*sp = (fstack_t)branch_loc;
    184 		}
    185 		env->level--;
    186 		compile_comma(env);
    187 		temporary_execute(env);
    188 	}
    189 }
    190 
    191 void
    192 bbranch(fcode_env_t *env)
    193 {
    194 	short offset = (short)get_short(env);
    195 
    196 	branch_common(env, offset, 0, 1);
    197 }
    198 
    199 void
    200 bqbranch(fcode_env_t *env)
    201 {
    202 	short offset = (short)get_short(env);
    203 
    204 	branch_common(env, offset, 1, 0);
    205 }
    206 
    207 void
    208 do_quote(fcode_env_t *env)
    209 {
    210 	int len;
    211 	uchar_t *strptr;
    212 
    213 	strptr = (uchar_t *)IP;
    214 	len = *strptr;
    215 	PUSH(DS, (fstack_t)strptr+1);
    216 	PUSH(DS, len);
    217 	strptr += TOKEN_ROUNDUP(len+2);
    218 	IP = (token_t *)strptr;
    219 }
    220 
    221 void
    222 bquote(fcode_env_t *env)
    223 {
    224 	char stringbuff[256];
    225 	int len, count;
    226 	char *strptr;
    227 
    228 	count = len = next_bytecode(env);
    229 	if (env->state) {
    230 		COMPILE_TOKEN(&quote_ptr);
    231 		strptr = (char *)HERE;
    232 		*strptr++ = len;
    233 		while (count--)
    234 			*strptr++ = next_bytecode(env);
    235 		*strptr++ = 0;
    236 		set_here(env, (uchar_t *)strptr, "bquote");
    237 		token_roundup(env, "bquote");
    238 	} else {
    239 		strptr = stringbuff;
    240 		while (count--)
    241 			*strptr++ = next_bytecode(env);
    242 		*strptr = 0;
    243 		push_string(env, stringbuff, len);
    244 	}
    245 }
    246 
    247 char *
    248 get_name(token_t *linkp)
    249 {
    250 	char *name, *p;
    251 	flag_t *fptr = LINK_TO_FLAGS(linkp);
    252 	int len;
    253 	char *cptr;
    254 
    255 	if (*fptr & FLAG_NONAME)
    256 		return (NULL);
    257 
    258 	cptr = (char *)fptr;
    259 	len = cptr[-1];
    260 	if (len <= 0 || len > 64 || cptr[-2] != '\0')
    261 		return (NULL);
    262 
    263 	name = cptr - (len+2);
    264 
    265 	for (p = name; *p != '\0'; p++)
    266 		if (!isprint(*p))
    267 			return (NULL);
    268 
    269 	if ((p - name) != len)
    270 		return (NULL);
    271 
    272 	return (name);
    273 }
    274 
    275 void
    276 header(fcode_env_t *env, char *name, int len, flag_t flag)
    277 {
    278 	char *strptr;
    279 	flag_t *fptr;
    280 	acf_t dptr;
    281 	extern void add_debug_acf(fcode_env_t *, acf_t);
    282 
    283 	/* Now form the entry in the dictionary */
    284 	token_roundup(env, "header");
    285 	dptr = (acf_t)HERE;
    286 	if (len) {
    287 		int bytes = len+2+sizeof (flag_t);
    288 		dptr = (acf_t)(TOKEN_ROUNDUP(HERE+bytes));
    289 		fptr = LINK_TO_FLAGS(dptr);
    290 		strptr = (char *)fptr - 1;
    291 		*strptr-- = len;
    292 		*strptr-- = 0;
    293 		while (len)
    294 			*strptr-- = name[--len];
    295 	} else {
    296 		dptr++;
    297 		fptr = LINK_TO_FLAGS(dptr);
    298 		flag |= FLAG_NONAME;
    299 	}
    300 	*fptr = flag;
    301 	*dptr = *((acf_t)env->current);
    302 	env->lastlink = dptr++;
    303 	set_here(env, (uchar_t *)dptr, "header");
    304 
    305 	if (name_is_debugged(env, name)) {
    306 		log_message(MSG_INFO, "Turning debug on for %s\n", name);
    307 		add_debug_acf(env, LINK_TO_ACF(env->lastlink));
    308 	}
    309 	debug_msg(DEBUG_HEADER, "Define: '%s' @ %p\n", name, HERE);
    310 }
    311 
    312 void
    313 token_common(fcode_env_t *env, int headered, int visible)
    314 {
    315 	char namebuff[32];
    316 	int len, count, token;
    317 	char *strptr, c;
    318 
    319 	strptr = namebuff;
    320 	if (headered) {
    321 		len = next_bytecode(env);
    322 		for (count = 0; count < len; count++) {
    323 			c = next_bytecode(env);
    324 			if (count < sizeof (namebuff))
    325 				*strptr++ = c;
    326 		}
    327 	}
    328 
    329 	if (!visible)
    330 		len = 0;
    331 	*strptr = 0;
    332 	token = get_short(env);
    333 	env->last_token = token;
    334 
    335 	debug_msg(DEBUG_NEW_TOKEN, "Define %s token: '%s' (%x)\n",
    336 	    (visible ? "named" : "headerless"), namebuff, token);
    337 
    338 	header(env, namebuff, len, 0);
    339 	env->table[token].flags = 0;
    340 	if (len) {
    341 		env->table[token].name = MALLOC(len+1);
    342 		strncpy(env->table[token].name, namebuff, len);
    343 	} else {
    344 		env->table[token].name = NULL;
    345 	}
    346 	env->last_token = token;
    347 }
    348 
    349 void
    350 named_token(fcode_env_t *env)
    351 {
    352 	token_common(env, 1, env->fcode_debug);
    353 }
    354 
    355 void
    356 external_token(fcode_env_t *env)
    357 {
    358 	token_common(env, 1, 1);
    359 }
    360 
    361 void
    362 new_token(fcode_env_t *env)
    363 {
    364 	token_common(env, 0, 0);
    365 }
    366 
    367 void
    368 offset16(fcode_env_t *env)
    369 {
    370 	env->offset_incr = 2;
    371 }
    372 
    373 void
    374 minus_one(fcode_env_t *env)
    375 {
    376 	PUSH(DS, -1);
    377 }
    378 
    379 void
    380 zero(fcode_env_t *env)
    381 {
    382 	PUSH(DS, 0);
    383 }
    384 
    385 void
    386 one(fcode_env_t *env)
    387 {
    388 	PUSH(DS, 1);
    389 }
    390 
    391 void
    392 two(fcode_env_t *env)
    393 {
    394 	PUSH(DS, 2);
    395 }
    396 
    397 void
    398 three(fcode_env_t *env)
    399 {
    400 	PUSH(DS, 3);
    401 }
    402 
    403 void
    404 version1(fcode_env_t *env)
    405 {
    406 	env->fcode_incr = 1;
    407 }
    408 
    409 static void
    410 start0(fcode_env_t *env)
    411 {
    412 	env->fcode_incr = 1;
    413 }
    414 
    415 static void
    416 start1(fcode_env_t *env)
    417 {
    418 	env->fcode_incr = 1;
    419 }
    420 
    421 void
    422 start2(fcode_env_t *env)
    423 {
    424 	env->fcode_incr = 2;
    425 }
    426 
    427 static void
    428 start4(fcode_env_t *env)
    429 {
    430 	env->fcode_incr = 4;
    431 }
    432 
    433 int
    434 check_fcode_header(char *fname, uchar_t *header, int len)
    435 {
    436 	uint32_t length;
    437 	static char func_name[] = "check_fcode_header";
    438 
    439 	if (len <= 8) {
    440 		log_message(MSG_ERROR, "%s: '%s' fcode size (%d) <= 8\n",
    441 		    func_name, fname, len);
    442 		return (0);
    443 	}
    444 	if (header[0] != 0xf1 && header[0] != 0xfd) {
    445 		log_message(MSG_ERROR, "%s: '%s' header[0] is 0x%02x not"
    446 		    " 0xf1/0xfd\n", func_name, fname, header[0]);
    447 		return (0);
    448 	}
    449 	length = (header[4] << 24) | (header[5] << 16) | (header[6] << 8) |
    450 	    header[7];
    451 	if (length > len) {
    452 		log_message(MSG_ERROR, "%s: '%s' length (%d) >"
    453 		    " fcode size (%d)\n", func_name, fname, length, len);
    454 		return (0);
    455 	}
    456 	if (length < len) {
    457 		log_message(MSG_WARN, "%s: '%s' length (%d) <"
    458 		    " fcode size (%d)\n", func_name, fname, length, len);
    459 	}
    460 	return (1);
    461 }
    462 
    463 void
    464 byte_load(fcode_env_t *env)
    465 {
    466 	uchar_t	*fcode_buffer;
    467 	uchar_t	*fcode_ptr;
    468 	int	fcode_incr;
    469 	int	offset_incr;
    470 	int	fcode_xt;
    471 	int	interpretting;
    472 	int	depth;
    473 	int	length;
    474 	int	past_eob = 0;
    475 	int db;
    476 
    477 	/* save any existing interpret state */
    478 	fcode_buffer = env->fcode_buffer;
    479 	fcode_ptr = env->fcode_ptr;
    480 	fcode_incr = env->fcode_incr;
    481 	offset_incr  = env->offset_incr;
    482 	interpretting = env->interpretting;
    483 	depth = DEPTH-2;
    484 
    485 	/* Now init them */
    486 	CHECK_DEPTH(env, 2, "byte-load");
    487 	fcode_xt = POP(DS);
    488 	env->fcode_ptr = env->fcode_buffer = (uchar_t *)POP(DS);
    489 	if (fcode_xt != 1) {
    490 		log_message(MSG_WARN, "byte-load: ignoring xt\n");
    491 	}
    492 
    493 	length = (env->fcode_buffer[4] << 24) | (env->fcode_buffer[5] << 16) |
    494 	    (env->fcode_buffer[6] << 8) | env->fcode_buffer[7];
    495 	if (!check_fcode_header("byte-load", env->fcode_ptr, length))
    496 		log_message(MSG_WARN, "byte-load: header NOT OK\n");
    497 
    498 	env->fcode_incr = 1;
    499 	env->offset_incr = 1;
    500 	env->interpretting = 1;
    501 	env->level = 0;
    502 
    503 	db = get_interpreter_debug_level() &
    504 	    (DEBUG_BYTELOAD_DS|DEBUG_BYTELOAD_RS|DEBUG_BYTELOAD_TOKENS);
    505 	debug_msg(db, "byte_load: %p, %d\n", env->fcode_buffer, fcode_xt);
    506 	debug_msg(db, "   header: %x, %x\n",
    507 	    env->fcode_buffer[0], env->fcode_buffer[1]);
    508 	debug_msg(db, "      crc: %x\n",
    509 	    (env->fcode_buffer[2]<<8)|(env->fcode_buffer[3]));
    510 	debug_msg(db, "   length: %x\n", length);
    511 	env->fcode_ptr += 8;
    512 
    513 	debug_msg(db, "Interpretting: %d\n", env->interpretting);
    514 
    515 	while (env->interpretting) {
    516 		int token;
    517 		fcode_token *entry;
    518 		acf_t apf;
    519 
    520 		if (!past_eob && env->fcode_ptr >= env->fcode_buffer + length) {
    521 			log_message(MSG_WARN, "byte-load: past EOB\n");
    522 			past_eob = 1;
    523 		}
    524 
    525 		env->last_fcode_ptr = env->fcode_ptr;
    526 		token = get_next_token(env);
    527 
    528 		entry = &env->table[token];
    529 		apf   = entry->apf;
    530 
    531 		DEBUGF(BYTELOAD_DS, output_data_stack(env, MSG_FC_DEBUG));
    532 		DEBUGF(BYTELOAD_RS, output_return_stack(env, 1, MSG_FC_DEBUG));
    533 		DEBUGF(BYTELOAD_TOKENS, log_message(MSG_FC_DEBUG,
    534 		    "%s: %04x %03x %s (%x)",
    535 		    ((env->state && (entry->flags & IMMEDIATE) == 0)) ?
    536 		    "Compile" : "Execute",
    537 		    env->last_fcode_ptr - env->fcode_buffer, token,
    538 		    entry->name ? entry->name : "???", entry->flags));
    539 		if (db)
    540 			log_message(MSG_FC_DEBUG, "\n");
    541 		if (apf) {
    542 			DEBUGF(TOKEN_USAGE, entry->usage++);
    543 			PUSH(DS, (fstack_t)apf);
    544 			if ((env->state) &&
    545 				((entry->flags & IMMEDIATE) == 0)) {
    546 				/* Compile in references */
    547 				compile_comma(env);
    548 			} else {
    549 				execute(env);
    550 			}
    551 		}
    552 	}
    553 	if (DEPTH != depth) {
    554 		log_message(MSG_ERROR, "FCODE has net stack change of %d\n",
    555 		    DEPTH-depth);
    556 	}
    557 	/* restore old state */
    558 	env->fcode_ptr		= fcode_ptr;
    559 	env->fcode_buffer	= fcode_buffer;
    560 	env->fcode_incr		= fcode_incr;
    561 	env->offset_incr	= offset_incr;
    562 	env->interpretting	= interpretting;
    563 }
    564 
    565 void
    566 btick(fcode_env_t *env)
    567 {
    568 	int token = get_next_token(env);
    569 
    570 	PUSH(DS, (fstack_t)env->table[token].apf);
    571 	tick_literal(env);
    572 }
    573 
    574 static void
    575 show_fcode_def(fcode_env_t *env, char *type)
    576 {
    577 	int i = env->last_token;
    578 
    579 	if (get_interpreter_debug_level() & DEBUG_DUMP_TOKENS) {
    580 		if (env->table[i].name)
    581 			log_message(MSG_INFO, "%s: %s %03x %p\n", type,
    582 			    env->table[i].name, i, env->table[i].apf);
    583 		else
    584 			log_message(MSG_INFO, "%s: <noname> %03x %p\n", type, i,
    585 			    env->table[i].apf);
    586 	}
    587 }
    588 
    589 void
    590 bcolon(fcode_env_t *env)
    591 {
    592 	if (env->state == 0) {
    593 		env->table[env->last_token].apf = (acf_t)HERE;
    594 		env->table[env->last_token].flags = 0;
    595 		show_fcode_def(env, "bcolon");
    596 	}
    597 	env->state |= 1;
    598 	COMPILE_TOKEN(&do_colon);
    599 }
    600 
    601 void
    602 bcreate(fcode_env_t *env)
    603 {
    604 	env->table[env->last_token].apf = (acf_t)HERE;
    605 	show_fcode_def(env, "bcreate");
    606 	COMPILE_TOKEN(&do_create);
    607 	expose_acf(env, "<bcreate>");
    608 }
    609 
    610 void
    611 get_token_name(fcode_env_t *env, int token, char **name, int *len)
    612 {
    613 	*name = env->table[token].name;
    614 	if (*name) {
    615 		*len = strlen(*name);
    616 	} else
    617 		*len = 0;
    618 }
    619 
    620 void
    621 bvalue(fcode_env_t *env)
    622 {
    623 	env->table[env->last_token].apf = (acf_t)HERE;
    624 	show_fcode_def(env, "bvalue");
    625 	make_common_access(env, 0, 0, 1,
    626 	    env->instance_mode, &noop, &noop, &set_value_actions);
    627 }
    628 
    629 void
    630 bvariable(fcode_env_t *env)
    631 {
    632 	env->table[env->last_token].apf = (acf_t)HERE;
    633 	show_fcode_def(env, "bvariable");
    634 	PUSH(DS, 0);
    635 	make_common_access(env, 0, 0, 1,
    636 	    env->instance_mode, &instance_variable, &do_create, NULL);
    637 }
    638 
    639 void
    640 bconstant(fcode_env_t *env)
    641 {
    642 	env->table[env->last_token].apf = (acf_t)HERE;
    643 	show_fcode_def(env, "bconstant");
    644 	make_common_access(env, 0, 0, 1,
    645 	    env->instance_mode, &do_constant, &do_constant, NULL);
    646 }
    647 
    648 void
    649 bdefer(fcode_env_t *env)
    650 {
    651 	env->table[env->last_token].apf = (acf_t)HERE;
    652 	show_fcode_def(env, "bdefer");
    653 
    654 	PUSH(DS, (fstack_t)&crash_ptr);
    655 	make_common_access(env, 0, 0, 1, env->instance_mode,
    656 	    &noop, &noop, &set_defer_actions);
    657 }
    658 
    659 void
    660 bbuffer_colon(fcode_env_t *env)
    661 {
    662 	env->table[env->last_token].apf = (acf_t)HERE;
    663 	show_fcode_def(env, "buffer:");
    664 	PUSH(DS, 0);
    665 	make_common_access(env, 0, 0, 2, env->instance_mode,
    666 	    &noop, &noop, &set_buffer_actions);
    667 }
    668 
    669 void
    670 do_field(fcode_env_t *env)
    671 {
    672 	fstack_t *d;
    673 
    674 	d = (fstack_t *)WA;
    675 	TOS += *d;
    676 }
    677 
    678 void
    679 bfield(fcode_env_t *env)
    680 {
    681 	env->table[env->last_token].apf = (acf_t)HERE;
    682 	show_fcode_def(env, "bfield");
    683 	COMPILE_TOKEN(&do_field);
    684 	over(env);
    685 	compile_comma(env);
    686 	add(env);
    687 	expose_acf(env, "<bfield>");
    688 }
    689 
    690 void
    691 bto(fcode_env_t *env)
    692 {
    693 	btick(env);
    694 
    695 	if (env->state) {
    696 		COMPILE_TOKEN(&to_ptr);
    697 	} else {
    698 		do_set_action(env);
    699 	}
    700 }
    701 
    702 void
    703 get_token(fcode_env_t *env)
    704 {
    705 	fstack_t tok;
    706 	fstack_t immediate = 0;
    707 
    708 	CHECK_DEPTH(env, 1, "get-token");
    709 	tok = POP(DS);
    710 	tok &= MAX_FCODE;
    711 	PUSH(DS, (fstack_t)env->table[tok].apf);
    712 	if (env->table[tok].flags & IMMEDIATE) 	immediate = 1;
    713 	PUSH(DS, immediate);
    714 }
    715 
    716 void
    717 set_token(fcode_env_t *env)
    718 {
    719 	fstack_t tok;
    720 	fstack_t immediate;
    721 	acf_t acf;
    722 
    723 	CHECK_DEPTH(env, 3, "set-token");
    724 	tok = POP(DS);
    725 	tok &= MAX_FCODE;
    726 	immediate = POP(DS);
    727 	acf = (acf_t)POP(DS);
    728 	if (immediate)
    729 		env->table[tok].flags |= IMMEDIATE;
    730 	else
    731 		env->table[tok].flags &= ~IMMEDIATE;
    732 	env->table[tok].apf = acf;
    733 	immediate = env->last_token;
    734 	env->last_token = tok;
    735 	show_fcode_def(env, "set_token");
    736 	env->last_token = immediate;
    737 }
    738 
    739 void
    740 bof(fcode_env_t *env)
    741 {
    742 	short offset = get_short(env);
    743 	branch_common(env, offset, 2, 0);
    744 }
    745 
    746 void
    747 bcase(fcode_env_t *env)
    748 {
    749 	env->level++;
    750 	set_temporary_compile(env);
    751 	PUSH(DS, 0);
    752 }
    753 
    754 void
    755 bendcase(fcode_env_t *env)
    756 {
    757 	COMPILE_TOKEN(env->table[0x46].apf);	/* Hack for now... */
    758 	while (TOS) {
    759 		bresolve(env);
    760 	}
    761 	(void) POP(DS);
    762 	env->level--;
    763 	temporary_execute(env);
    764 }
    765 
    766 void
    767 bendof(fcode_env_t *env)
    768 {
    769 	short offset = get_short(env);
    770 	branch_common(env, offset, 0, 1);
    771 	bresolve(env);
    772 }
    773 
    774 void
    775 fcode_revision(fcode_env_t *env)
    776 {
    777 	/* We are Version 3.0 */
    778 	PUSH(DS, 0x30000);
    779 }
    780 
    781 void
    782 alloc_mem(fcode_env_t *env)
    783 {
    784 	CHECK_DEPTH(env, 1, "alloc-mem");
    785 	TOS = (fstack_t)MALLOC((size_t)TOS);
    786 	if (!TOS) {
    787 		throw_from_fclib(env, 1, "alloc-mem failed");
    788 	}
    789 }
    790 
    791 void
    792 free_mem(fcode_env_t *env)
    793 {
    794 	void *p;
    795 
    796 	CHECK_DEPTH(env, 2, "free-mem");
    797 	(void) POP(DS);
    798 	p = (void *) POP(DS);
    799 	FREE(p);
    800 }
    801 
    802 void
    803 parse_two_int(fcode_env_t *env)
    804 {
    805 	uint_t lo, hi;
    806 	char *str;
    807 	int len;
    808 
    809 	CHECK_DEPTH(env, 2, "parse-2int");
    810 	lo = 0;
    811 	hi = 0;
    812 	str = pop_a_string(env, &len);
    813 	if (len) {
    814 		if (sscanf(str, "%x,%x", &hi, &lo) != 2) {
    815 			throw_from_fclib(env, 1, "parse_2int");
    816 		}
    817 	}
    818 	PUSH(DS, lo);
    819 	PUSH(DS, hi);
    820 }
    821 
    822 void
    823 left_parse_string(fcode_env_t *env)
    824 {
    825 	char sep, *cptr, *lstr, *rstr;
    826 	int len, llen, rlen;
    827 
    828 	CHECK_DEPTH(env, 3, "left-parse-string");
    829 	sep = (char)POP(DS);
    830 	if (TOS == 0) {
    831 		two_dup(env);
    832 		return;
    833 	}
    834 	lstr = pop_a_string(env, &llen);
    835 	len = 0;
    836 	cptr = NULL;
    837 	while (len < llen) {
    838 		if (lstr[len] == sep) {
    839 			cptr = lstr+len;
    840 			break;
    841 		}
    842 		len++;
    843 	}
    844 	if (cptr != NULL) {
    845 		rstr = cptr+1;
    846 		rlen = lstr + llen - rstr;
    847 		llen = len;
    848 	} else {
    849 		rlen = 0;
    850 		rstr = lstr;
    851 	}
    852 	PUSH(DS, (fstack_t)rstr);
    853 	PUSH(DS, rlen);
    854 	PUSH(DS, (fstack_t)lstr);
    855 	PUSH(DS, llen);
    856 }
    857 
    858 /*
    859  * (is-user-word)  ( name-str name-len xt -- )
    860  */
    861 void
    862 is_user_word(fcode_env_t *env)
    863 {
    864 	fstack_t xt;
    865 	char *name;
    866 	int len;
    867 
    868 	CHECK_DEPTH(env, 3, "(is-user-word)");
    869 	xt = POP(DS);
    870 	name = pop_a_string(env, &len);
    871 	header(env, name, len, 0);
    872 	COMPILE_TOKEN(&do_alias);
    873 	COMPILE_TOKEN(xt);
    874 	expose_acf(env, name);
    875 }
    876 
    877 void
    878 f_error(fcode_env_t *env)
    879 {
    880 #if 0
    881 	env->interpretting = 0;
    882 	log_message(MSG_ERROR, "Uniplemented FCODE token encountered %x\n",
    883 	    env->last_fcode);
    884 #else
    885 	forth_abort(env, "Unimplemented FCODE token: 0x%x\n", env->last_fcode);
    886 #endif
    887 }
    888 
    889 static void
    890 fcode_buffer_addr(fcode_env_t *env)
    891 {
    892 	PUSH(DS, (fstack_t)(env->fcode_buffer));
    893 }
    894 
    895 #pragma init(_init)
    896 
    897 static void
    898 _init(void)
    899 {
    900 	fcode_env_t *env = initial_env;
    901 
    902 	ASSERT(env);
    903 	NOTICE;
    904 
    905 	P1275(0x000, DEFINER,	"end0",			end0);
    906 	P1275(0x010, DEFINER,	"b(lit)",		blit);
    907 	P1275(0x011, DEFINER,	"b(')",			btick);
    908 	P1275(0x012, DEFINER,	"b(\")",		bquote);
    909 	P1275(0x013, DEFINER,	"bbranch",		bbranch);
    910 	P1275(0x014, DEFINER,	"b?branch",		bqbranch);
    911 	P1275(0x015, DEFINER,	"b(loop)",		bloop);
    912 	P1275(0x016, DEFINER,	"b(+loop)",		bplusloop);
    913 	P1275(0x017, DEFINER,	"b(do)",		bdo);
    914 	P1275(0x018, DEFINER,	"b(?do)",		bqdo);
    915 	P1275(0x01b, DEFINER,	"b(leave)",		bleave);
    916 	P1275(0x01c, DEFINER,	"b(of)",		bof);
    917 
    918 	P1275(0x087, 0,		"fcode-revision",	fcode_revision);
    919 
    920 	P1275(0x08b, 0,		"alloc-mem",		alloc_mem);
    921 	P1275(0x08c, 0,		"free-mem",		free_mem);
    922 
    923 	P1275(0x0a4, 0,		"-1",			minus_one);
    924 	P1275(0x0a5, 0,		"0",			zero);
    925 	P1275(0x0a6, 0,		"1",			one);
    926 	P1275(0x0a7, 0,		"2",			two);
    927 	P1275(0x0a8, 0,		"3",			three);
    928 
    929 	P1275(0x0ae, 0,		"aligned",		aligned);
    930 	P1275(0x0b1, DEFINER,	"b(<mark)",		bmark);
    931 	P1275(0x0b2, DEFINER,	"b(>resolve)",		bresolve);
    932 	FCODE(0x0b3, 0,		"set-token-table",	fc_historical);
    933 	FCODE(0x0b4, 0,		"set-table",		fc_historical);
    934 	P1275(0x0b5, 0,		"new-token",		new_token);
    935 	P1275(0x0b6, 0,		"named-token",		named_token);
    936 	P1275(0x0b7, DEFINER,	"b(:)",			bcolon);
    937 	P1275(0x0b8, DEFINER,	"b(value)",		bvalue);
    938 	P1275(0x0b9, DEFINER,	"b(variable)",		bvariable);
    939 	P1275(0x0ba, DEFINER,	"b(constant)",		bconstant);
    940 	P1275(0x0bb, DEFINER,	"b(create)",		bcreate);
    941 	P1275(0x0bc, DEFINER,	"b(defer)",		bdefer);
    942 	P1275(0x0bd, 0,		"b(buffer:)",		bbuffer_colon);
    943 	P1275(0x0be, 0,		"b(field)",		bfield);
    944 	FCODE(0x0bf, 0,		"b(code)",		fc_historical);
    945 	P1275(0x0c0, IMMEDIATE,	"instance",		instance);
    946 
    947 	P1275(0x0c2, DEFINER,	"b(;)",			semi);
    948 	P1275(0x0c3, DEFINER,	"b(to)",		bto);
    949 	P1275(0x0c4, DEFINER,	"b(case)",		bcase);
    950 	P1275(0x0c5, DEFINER,	"b(endcase)",		bendcase);
    951 	P1275(0x0c6, DEFINER,	"b(endof)",		bendof);
    952 
    953 	P1275(0x0ca, 0,		"external-token",	external_token);
    954 	P1275(0x0cc, 0,		"offset16",		offset16);
    955 	P1275(0x0cd, 0,		"evaluate",		evaluate);
    956 
    957 	P1275(0x0da, 0,		"get-token",		get_token);
    958 	P1275(0x0db, 0,		"set-token",		set_token);
    959 
    960 	P1275(0x0f0, 0,		"start0",		start0);
    961 	P1275(0x0f1, 0,		"start1",		start1);
    962 	P1275(0x0f2, 0,		"start2",		start2);
    963 	P1275(0x0f3, 0,		"start4",		start4);
    964 
    965 	P1275(0x0fd, 0,		"version1",		version1);
    966 	FCODE(0x0fe, 0,		"4-byte-id",		fc_historical);
    967 
    968 	P1275(0x0ff, 0,		"end1",			end1);
    969 
    970 	/* Call it "old-dma-alloc" so no one gets confused */
    971 	FCODE(0x101, 0,		"old-dma-alloc",	fc_historical);
    972 
    973 	FCODE(0x104, 0,		"memmap",		fc_historical);
    974 	FCODE(0x105, 0,		"free-virtual",		fc_unimplemented);
    975 
    976 	FCODE(0x106, 0,		">physical",		fc_historical);
    977 
    978 	FCODE(0x10f, 0,		"my-params",		fc_historical);
    979 
    980 	P1275(0x11b, 0,		"parse-2int",		parse_two_int);
    981 
    982 	FCODE(0x122, 0,		"memory-test-suite",	fc_unimplemented);
    983 	FCODE(0x123, 0,		"group-code",		fc_historical);
    984 	FCODE(0x124, 0,		"mask",			fc_unimplemented);
    985 
    986 	FCODE(0x130, 0,		"map-low",		fc_unimplemented);
    987 	FCODE(0x131, 0,		"sbus-intr>cpu",	fc_unimplemented);
    988 
    989 	FCODE(0x170, 0,		"fb1-draw-character",	fc_historical);
    990 	FCODE(0x171, 0,		"fb1-reset-screen",	fc_historical);
    991 	FCODE(0x172, 0,		"fb1-toggle-cursor",	fc_historical);
    992 	FCODE(0x173, 0,		"fb1-erase-screen",	fc_historical);
    993 	FCODE(0x174, 0,		"fb1-blink-screen",	fc_historical);
    994 	FCODE(0x175, 0,		"fb1-invert-screen",	fc_historical);
    995 	FCODE(0x176, 0,		"fb1-insert-characters",	fc_historical);
    996 	FCODE(0x177, 0,		"fb1-delete-characters",	fc_historical);
    997 	FCODE(0x178, 0,		"fb1-insert-lines",	fc_historical);
    998 	FCODE(0x179, 0,		"fb1-delete-lines",	fc_historical);
    999 	FCODE(0x17a, 0,		"fb1-draw-logo",	fc_historical);
   1000 	FCODE(0x17b, 0,		"fb1-install",		fc_historical);
   1001 	FCODE(0x17c, 0,		"fb1-slide-up",		fc_historical);
   1002 
   1003 	FCODE(0x190, 0,		"VME-bus Support",	fc_obsolete);
   1004 	FCODE(0x191, 0,		"VME-bus Support",	fc_obsolete);
   1005 	FCODE(0x192, 0,		"VME-bus Support",	fc_obsolete);
   1006 	FCODE(0x193, 0,		"VME-bus Support",	fc_obsolete);
   1007 	FCODE(0x194, 0,		"VME-bus Support",	fc_obsolete);
   1008 	FCODE(0x195, 0,		"VME-bus Support",	fc_obsolete);