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