1a1bf3f78SToomas Soome /* 2a1bf3f78SToomas Soome * w o r d s . c 3a1bf3f78SToomas Soome * Forth Inspired Command Language 4a1bf3f78SToomas Soome * ANS Forth CORE word-set written in C 5a1bf3f78SToomas Soome * Author: John Sadler (john_sadler@alum.mit.edu) 6a1bf3f78SToomas Soome * Created: 19 July 1997 7a1bf3f78SToomas Soome * $Id: primitives.c,v 1.4 2010/09/13 18:43:04 asau Exp $ 8a1bf3f78SToomas Soome */ 9a1bf3f78SToomas Soome /* 10a1bf3f78SToomas Soome * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 11a1bf3f78SToomas Soome * All rights reserved. 12a1bf3f78SToomas Soome * 13a1bf3f78SToomas Soome * Get the latest Ficl release at http://ficl.sourceforge.net 14a1bf3f78SToomas Soome * 15a1bf3f78SToomas Soome * I am interested in hearing from anyone who uses Ficl. If you have 16a1bf3f78SToomas Soome * a problem, a success story, a defect, an enhancement request, or 17a1bf3f78SToomas Soome * if you would like to contribute to the Ficl release, please 18a1bf3f78SToomas Soome * contact me by email at the address above. 19a1bf3f78SToomas Soome * 20a1bf3f78SToomas Soome * L I C E N S E and D I S C L A I M E R 21a1bf3f78SToomas Soome * 22a1bf3f78SToomas Soome * Redistribution and use in source and binary forms, with or without 23a1bf3f78SToomas Soome * modification, are permitted provided that the following conditions 24a1bf3f78SToomas Soome * are met: 25a1bf3f78SToomas Soome * 1. Redistributions of source code must retain the above copyright 26a1bf3f78SToomas Soome * notice, this list of conditions and the following disclaimer. 27a1bf3f78SToomas Soome * 2. Redistributions in binary form must reproduce the above copyright 28a1bf3f78SToomas Soome * notice, this list of conditions and the following disclaimer in the 29a1bf3f78SToomas Soome * documentation and/or other materials provided with the distribution. 30a1bf3f78SToomas Soome * 31a1bf3f78SToomas Soome * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 32a1bf3f78SToomas Soome * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 33a1bf3f78SToomas Soome * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 34a1bf3f78SToomas Soome * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 35a1bf3f78SToomas Soome * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 36a1bf3f78SToomas Soome * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 37a1bf3f78SToomas Soome * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 38a1bf3f78SToomas Soome * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 39a1bf3f78SToomas Soome * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 40a1bf3f78SToomas Soome * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 41a1bf3f78SToomas Soome * SUCH DAMAGE. 42a1bf3f78SToomas Soome */ 43a1bf3f78SToomas Soome 44a1bf3f78SToomas Soome #include "ficl.h" 45a1bf3f78SToomas Soome #include <limits.h> 46a1bf3f78SToomas Soome 47a1bf3f78SToomas Soome /* 48a1bf3f78SToomas Soome * Control structure building words use these 49a1bf3f78SToomas Soome * strings' addresses as markers on the stack to 50a1bf3f78SToomas Soome * check for structure completion. 51a1bf3f78SToomas Soome */ 52a1bf3f78SToomas Soome static char doTag[] = "do"; 53a1bf3f78SToomas Soome static char colonTag[] = "colon"; 54a1bf3f78SToomas Soome static char leaveTag[] = "leave"; 55a1bf3f78SToomas Soome 56a1bf3f78SToomas Soome static char destTag[] = "target"; 57a1bf3f78SToomas Soome static char origTag[] = "origin"; 58a1bf3f78SToomas Soome 59a1bf3f78SToomas Soome static char caseTag[] = "case"; 60a1bf3f78SToomas Soome static char ofTag[] = "of"; 61a1bf3f78SToomas Soome static char fallthroughTag[] = "fallthrough"; 62a1bf3f78SToomas Soome 63a1bf3f78SToomas Soome /* 64a1bf3f78SToomas Soome * C O N T R O L S T R U C T U R E B U I L D E R S 65a1bf3f78SToomas Soome * 66a1bf3f78SToomas Soome * Push current dictionary location for later branch resolution. 67a1bf3f78SToomas Soome * The location may be either a branch target or a patch address... 68a1bf3f78SToomas Soome */ 69a1bf3f78SToomas Soome static void 70a1bf3f78SToomas Soome markBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag) 71a1bf3f78SToomas Soome { 72a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here); 73a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, tag); 74a1bf3f78SToomas Soome } 75a1bf3f78SToomas Soome 76a1bf3f78SToomas Soome static void 77a1bf3f78SToomas Soome markControlTag(ficlVm *vm, char *tag) 78a1bf3f78SToomas Soome { 79a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, tag); 80a1bf3f78SToomas Soome } 81a1bf3f78SToomas Soome 82a1bf3f78SToomas Soome static void 83a1bf3f78SToomas Soome matchControlTag(ficlVm *vm, char *wantTag) 84a1bf3f78SToomas Soome { 85a1bf3f78SToomas Soome char *tag; 86a1bf3f78SToomas Soome 87a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 88a1bf3f78SToomas Soome 89a1bf3f78SToomas Soome tag = (char *)ficlStackPopPointer(vm->dataStack); 90a1bf3f78SToomas Soome 91a1bf3f78SToomas Soome /* 92a1bf3f78SToomas Soome * Changed the code below to compare the pointers first 93a1bf3f78SToomas Soome * (by popular demand) 94a1bf3f78SToomas Soome */ 95a1bf3f78SToomas Soome if ((tag != wantTag) && strcmp(tag, wantTag)) { 96a1bf3f78SToomas Soome ficlVmThrowError(vm, 97a1bf3f78SToomas Soome "Error -- unmatched control structure \"%s\"", wantTag); 98a1bf3f78SToomas Soome } 99a1bf3f78SToomas Soome } 100a1bf3f78SToomas Soome 101a1bf3f78SToomas Soome /* 102a1bf3f78SToomas Soome * Expect a branch target address on the param stack, 103a1bf3f78SToomas Soome * FICL_VM_STATE_COMPILE a literal offset from the current dictionary location 104a1bf3f78SToomas Soome * to the target address 105a1bf3f78SToomas Soome */ 106a1bf3f78SToomas Soome static void 107a1bf3f78SToomas Soome resolveBackBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag) 108a1bf3f78SToomas Soome { 109a1bf3f78SToomas Soome ficlCell *patchAddr, c; 110a1bf3f78SToomas Soome 111a1bf3f78SToomas Soome matchControlTag(vm, tag); 112a1bf3f78SToomas Soome 113a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 114a1bf3f78SToomas Soome 115a1bf3f78SToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); 116a1bf3f78SToomas Soome c.i = patchAddr - dictionary->here; 117a1bf3f78SToomas Soome 118a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, c); 119a1bf3f78SToomas Soome } 120a1bf3f78SToomas Soome 121a1bf3f78SToomas Soome /* 122a1bf3f78SToomas Soome * Expect a branch patch address on the param stack, 123a1bf3f78SToomas Soome * FICL_VM_STATE_COMPILE a literal offset from the patch location 124a1bf3f78SToomas Soome * to the current dictionary location 125a1bf3f78SToomas Soome */ 126a1bf3f78SToomas Soome static void 127a1bf3f78SToomas Soome resolveForwardBranch(ficlDictionary *dictionary, ficlVm *vm, char *tag) 128a1bf3f78SToomas Soome { 129a1bf3f78SToomas Soome ficlInteger offset; 130a1bf3f78SToomas Soome ficlCell *patchAddr; 131a1bf3f78SToomas Soome 132a1bf3f78SToomas Soome matchControlTag(vm, tag); 133a1bf3f78SToomas Soome 134a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 135a1bf3f78SToomas Soome 136a1bf3f78SToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); 137a1bf3f78SToomas Soome offset = dictionary->here - patchAddr; 138a1bf3f78SToomas Soome (*patchAddr).i = offset; 139a1bf3f78SToomas Soome } 140a1bf3f78SToomas Soome 141a1bf3f78SToomas Soome /* 142a1bf3f78SToomas Soome * Match the tag to the top of the stack. If success, 143a1bf3f78SToomas Soome * sopy "here" address into the ficlCell whose address is next 144a1bf3f78SToomas Soome * on the stack. Used by do..leave..loop. 145a1bf3f78SToomas Soome */ 146a1bf3f78SToomas Soome static void 147a1bf3f78SToomas Soome resolveAbsBranch(ficlDictionary *dictionary, ficlVm *vm, char *wantTag) 148a1bf3f78SToomas Soome { 149a1bf3f78SToomas Soome ficlCell *patchAddr; 150a1bf3f78SToomas Soome char *tag; 151a1bf3f78SToomas Soome 152a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0); 153a1bf3f78SToomas Soome 154a1bf3f78SToomas Soome tag = ficlStackPopPointer(vm->dataStack); 155a1bf3f78SToomas Soome 156a1bf3f78SToomas Soome /* 157a1bf3f78SToomas Soome * Changed the comparison below to compare the pointers first 158a1bf3f78SToomas Soome * (by popular demand) 159a1bf3f78SToomas Soome */ 160a1bf3f78SToomas Soome if ((tag != wantTag) && strcmp(tag, wantTag)) { 161a1bf3f78SToomas Soome ficlVmTextOut(vm, "Warning -- Unmatched control word: "); 162a1bf3f78SToomas Soome ficlVmTextOut(vm, wantTag); 163a1bf3f78SToomas Soome ficlVmTextOut(vm, "\n"); 164a1bf3f78SToomas Soome } 165a1bf3f78SToomas Soome 166a1bf3f78SToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); 167a1bf3f78SToomas Soome (*patchAddr).p = dictionary->here; 168a1bf3f78SToomas Soome } 169a1bf3f78SToomas Soome 170a1bf3f78SToomas Soome /* 171a1bf3f78SToomas Soome * c o l o n d e f i n i t i o n s 172a1bf3f78SToomas Soome * Code to begin compiling a colon definition 173a1bf3f78SToomas Soome * This function sets the state to FICL_VM_STATE_COMPILE, then creates a 174a1bf3f78SToomas Soome * new word whose name is the next word in the input stream 175a1bf3f78SToomas Soome * and whose code is colonParen. 176a1bf3f78SToomas Soome */ 177a1bf3f78SToomas Soome static void 178a1bf3f78SToomas Soome ficlPrimitiveColon(ficlVm *vm) 179a1bf3f78SToomas Soome { 180a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 181a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 182a1bf3f78SToomas Soome 183a1bf3f78SToomas Soome vm->state = FICL_VM_STATE_COMPILE; 184a1bf3f78SToomas Soome markControlTag(vm, colonTag); 185a1bf3f78SToomas Soome ficlDictionaryAppendWord(dictionary, name, 186a1bf3f78SToomas Soome (ficlPrimitive)ficlInstructionColonParen, 187a1bf3f78SToomas Soome FICL_WORD_DEFAULT | FICL_WORD_SMUDGED); 188a1bf3f78SToomas Soome 189a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 190a1bf3f78SToomas Soome vm->callback.system->localsCount = 0; 191a1bf3f78SToomas Soome #endif 192a1bf3f78SToomas Soome } 193a1bf3f78SToomas Soome 194a1bf3f78SToomas Soome static void 195a1bf3f78SToomas Soome ficlPrimitiveSemicolonCoIm(ficlVm *vm) 196a1bf3f78SToomas Soome { 197a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 198a1bf3f78SToomas Soome 199a1bf3f78SToomas Soome matchControlTag(vm, colonTag); 200a1bf3f78SToomas Soome 201a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 202a1bf3f78SToomas Soome if (vm->callback.system->localsCount > 0) { 203a1bf3f78SToomas Soome ficlDictionary *locals; 204a1bf3f78SToomas Soome locals = ficlSystemGetLocals(vm->callback.system); 205a1bf3f78SToomas Soome ficlDictionaryEmpty(locals, locals->forthWordlist->size); 206a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 207a1bf3f78SToomas Soome ficlInstructionUnlinkParen); 208a1bf3f78SToomas Soome } 209a1bf3f78SToomas Soome vm->callback.system->localsCount = 0; 210a1bf3f78SToomas Soome #endif 211a1bf3f78SToomas Soome 212a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionSemiParen); 213a1bf3f78SToomas Soome vm->state = FICL_VM_STATE_INTERPRET; 214a1bf3f78SToomas Soome ficlDictionaryUnsmudge(dictionary); 215a1bf3f78SToomas Soome } 216a1bf3f78SToomas Soome 217a1bf3f78SToomas Soome /* 218a1bf3f78SToomas Soome * e x i t 219a1bf3f78SToomas Soome * CORE 220a1bf3f78SToomas Soome * This function simply pops the previous instruction 221a1bf3f78SToomas Soome * pointer and returns to the "next" loop. Used for exiting from within 222a1bf3f78SToomas Soome * a definition. Note that exitParen is identical to semiParen - they 223a1bf3f78SToomas Soome * are in two different functions so that "see" can correctly identify 224a1bf3f78SToomas Soome * the end of a colon definition, even if it uses "exit". 225a1bf3f78SToomas Soome */ 226a1bf3f78SToomas Soome static void 227a1bf3f78SToomas Soome ficlPrimitiveExitCoIm(ficlVm *vm) 228a1bf3f78SToomas Soome { 229a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 230a1bf3f78SToomas Soome FICL_IGNORE(vm); 231a1bf3f78SToomas Soome 232a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 233a1bf3f78SToomas Soome if (vm->callback.system->localsCount > 0) { 234a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 235a1bf3f78SToomas Soome ficlInstructionUnlinkParen); 236a1bf3f78SToomas Soome } 237a1bf3f78SToomas Soome #endif 238a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionExitParen); 239a1bf3f78SToomas Soome } 240a1bf3f78SToomas Soome 241a1bf3f78SToomas Soome /* 242a1bf3f78SToomas Soome * c o n s t a n t 243a1bf3f78SToomas Soome * IMMEDIATE 244a1bf3f78SToomas Soome * Compiles a constant into the dictionary. Constants return their 245a1bf3f78SToomas Soome * value when invoked. Expects a value on top of the parm stack. 246a1bf3f78SToomas Soome */ 247a1bf3f78SToomas Soome static void 248a1bf3f78SToomas Soome ficlPrimitiveConstant(ficlVm *vm) 249a1bf3f78SToomas Soome { 250a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 251a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 252a1bf3f78SToomas Soome 253a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 254a1bf3f78SToomas Soome 255a1bf3f78SToomas Soome ficlDictionaryAppendConstantInstruction(dictionary, name, 256a1bf3f78SToomas Soome ficlInstructionConstantParen, ficlStackPopInteger(vm->dataStack)); 257a1bf3f78SToomas Soome } 258a1bf3f78SToomas Soome 259a1bf3f78SToomas Soome static void 260a1bf3f78SToomas Soome ficlPrimitive2Constant(ficlVm *vm) 261a1bf3f78SToomas Soome { 262a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 263a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 264a1bf3f78SToomas Soome 265a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0); 266a1bf3f78SToomas Soome 267a1bf3f78SToomas Soome ficlDictionaryAppend2ConstantInstruction(dictionary, name, 268a1bf3f78SToomas Soome ficlInstruction2ConstantParen, ficlStackPop2Integer(vm->dataStack)); 269a1bf3f78SToomas Soome } 270a1bf3f78SToomas Soome 271a1bf3f78SToomas Soome /* 272a1bf3f78SToomas Soome * d i s p l a y C e l l 273a1bf3f78SToomas Soome * Drop and print the contents of the ficlCell at the top of the param 274a1bf3f78SToomas Soome * stack 275a1bf3f78SToomas Soome */ 276a1bf3f78SToomas Soome static void 277a1bf3f78SToomas Soome ficlPrimitiveDot(ficlVm *vm) 278a1bf3f78SToomas Soome { 279a1bf3f78SToomas Soome ficlCell c; 280a1bf3f78SToomas Soome 281a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 282a1bf3f78SToomas Soome 283a1bf3f78SToomas Soome c = ficlStackPop(vm->dataStack); 284a1bf3f78SToomas Soome ficlLtoa((c).i, vm->pad, vm->base); 285a1bf3f78SToomas Soome strcat(vm->pad, " "); 286a1bf3f78SToomas Soome ficlVmTextOut(vm, vm->pad); 287a1bf3f78SToomas Soome } 288a1bf3f78SToomas Soome 289a1bf3f78SToomas Soome static void 290a1bf3f78SToomas Soome ficlPrimitiveUDot(ficlVm *vm) 291a1bf3f78SToomas Soome { 292a1bf3f78SToomas Soome ficlUnsigned u; 293a1bf3f78SToomas Soome 294a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 295a1bf3f78SToomas Soome 296a1bf3f78SToomas Soome u = ficlStackPopUnsigned(vm->dataStack); 297a1bf3f78SToomas Soome ficlUltoa(u, vm->pad, vm->base); 298a1bf3f78SToomas Soome strcat(vm->pad, " "); 299a1bf3f78SToomas Soome ficlVmTextOut(vm, vm->pad); 300a1bf3f78SToomas Soome } 301a1bf3f78SToomas Soome 302a1bf3f78SToomas Soome static void 303a1bf3f78SToomas Soome ficlPrimitiveHexDot(ficlVm *vm) 304a1bf3f78SToomas Soome { 305a1bf3f78SToomas Soome ficlUnsigned u; 306a1bf3f78SToomas Soome 307a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 308a1bf3f78SToomas Soome 309a1bf3f78SToomas Soome u = ficlStackPopUnsigned(vm->dataStack); 310a1bf3f78SToomas Soome ficlUltoa(u, vm->pad, 16); 311a1bf3f78SToomas Soome strcat(vm->pad, " "); 312a1bf3f78SToomas Soome ficlVmTextOut(vm, vm->pad); 313a1bf3f78SToomas Soome } 314a1bf3f78SToomas Soome 315a1bf3f78SToomas Soome /* 316a1bf3f78SToomas Soome * s t r l e n 317a1bf3f78SToomas Soome * Ficl ( c-string -- length ) 318a1bf3f78SToomas Soome * 319a1bf3f78SToomas Soome * Returns the length of a C-style (zero-terminated) string. 320a1bf3f78SToomas Soome * 321a1bf3f78SToomas Soome * --lch 322a1bf3f78SToomas Soome */ 323a1bf3f78SToomas Soome static void 324a1bf3f78SToomas Soome ficlPrimitiveStrlen(ficlVm *vm) 325a1bf3f78SToomas Soome { 326a1bf3f78SToomas Soome char *address = (char *)ficlStackPopPointer(vm->dataStack); 327a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, strlen(address)); 328a1bf3f78SToomas Soome } 329a1bf3f78SToomas Soome 330a1bf3f78SToomas Soome /* 331a1bf3f78SToomas Soome * s p r i n t f 332a1bf3f78SToomas Soome * Ficl ( i*x c-addr-fmt u-fmt c-addr-buffer u-buffer -- 333a1bf3f78SToomas Soome * c-addr-buffer u-written success-flag ) 334a1bf3f78SToomas Soome * Similar to the C sprintf() function. It formats into a buffer based on 335a1bf3f78SToomas Soome * a "format" string. Each character in the format string is copied verbatim 336a1bf3f78SToomas Soome * to the output buffer, until SPRINTF encounters a percent sign ("%"). 337a1bf3f78SToomas Soome * SPRINTF then skips the percent sign, and examines the next character 338a1bf3f78SToomas Soome * (the "format character"). Here are the valid format characters: 339a1bf3f78SToomas Soome * s - read a C-ADDR U-LENGTH string from the stack and copy it to 340a1bf3f78SToomas Soome * the buffer 341a1bf3f78SToomas Soome * d - read a ficlCell from the stack, format it as a string (base-10, 342a1bf3f78SToomas Soome * signed), and copy it to the buffer 343a1bf3f78SToomas Soome * x - same as d, except in base-16 344a1bf3f78SToomas Soome * u - same as d, but unsigned 345a1bf3f78SToomas Soome * % - output a literal percent-sign to the buffer 346a1bf3f78SToomas Soome * SPRINTF returns the c-addr-buffer argument unchanged, the number of bytes 347a1bf3f78SToomas Soome * written, and a flag indicating whether or not it ran out of space while 348a1bf3f78SToomas Soome * writing to the output buffer (FICL_TRUE if it ran out of space). 349a1bf3f78SToomas Soome * 350a1bf3f78SToomas Soome * If SPRINTF runs out of space in the buffer to store the formatted string, 351a1bf3f78SToomas Soome * it still continues parsing, in an effort to preserve your stack (otherwise 352a1bf3f78SToomas Soome * it might leave uneaten arguments behind). 353a1bf3f78SToomas Soome * 354a1bf3f78SToomas Soome * --lch 355a1bf3f78SToomas Soome */ 356a1bf3f78SToomas Soome static void 357a1bf3f78SToomas Soome ficlPrimitiveSprintf(ficlVm *vm) 358a1bf3f78SToomas Soome { 359a1bf3f78SToomas Soome int bufferLength = ficlStackPopInteger(vm->dataStack); 360a1bf3f78SToomas Soome char *buffer = (char *)ficlStackPopPointer(vm->dataStack); 361a1bf3f78SToomas Soome char *bufferStart = buffer; 362a1bf3f78SToomas Soome 363a1bf3f78SToomas Soome int formatLength = ficlStackPopInteger(vm->dataStack); 364a1bf3f78SToomas Soome char *format = (char *)ficlStackPopPointer(vm->dataStack); 365a1bf3f78SToomas Soome char *formatStop = format + formatLength; 366a1bf3f78SToomas Soome 367a1bf3f78SToomas Soome int base = 10; 368a1bf3f78SToomas Soome int unsignedInteger = 0; /* false */ 369a1bf3f78SToomas Soome 370a1bf3f78SToomas Soome int append = 1; /* true */ 371a1bf3f78SToomas Soome 372a1bf3f78SToomas Soome while (format < formatStop) { 373a1bf3f78SToomas Soome char scratch[64]; 374a1bf3f78SToomas Soome char *source; 375a1bf3f78SToomas Soome int actualLength; 376a1bf3f78SToomas Soome int desiredLength; 377a1bf3f78SToomas Soome int leadingZeroes; 378a1bf3f78SToomas Soome 379a1bf3f78SToomas Soome if (*format != '%') { 380a1bf3f78SToomas Soome source = format; 381a1bf3f78SToomas Soome actualLength = desiredLength = 1; 382a1bf3f78SToomas Soome leadingZeroes = 0; 383a1bf3f78SToomas Soome } else { 384a1bf3f78SToomas Soome format++; 385a1bf3f78SToomas Soome if (format == formatStop) 386a1bf3f78SToomas Soome break; 387a1bf3f78SToomas Soome 388a1bf3f78SToomas Soome leadingZeroes = (*format == '0'); 389a1bf3f78SToomas Soome if (leadingZeroes) { 390a1bf3f78SToomas Soome format++; 391a1bf3f78SToomas Soome if (format == formatStop) 392a1bf3f78SToomas Soome break; 393a1bf3f78SToomas Soome } 394a1bf3f78SToomas Soome 395a1bf3f78SToomas Soome desiredLength = isdigit((unsigned char)*format); 396a1bf3f78SToomas Soome if (desiredLength) { 397a1bf3f78SToomas Soome desiredLength = strtoul(format, &format, 10); 398a1bf3f78SToomas Soome if (format == formatStop) 399a1bf3f78SToomas Soome break; 400a1bf3f78SToomas Soome } else if (*format == '*') { 401a1bf3f78SToomas Soome desiredLength = 402a1bf3f78SToomas Soome ficlStackPopInteger(vm->dataStack); 403a1bf3f78SToomas Soome 404a1bf3f78SToomas Soome format++; 405a1bf3f78SToomas Soome if (format == formatStop) 406a1bf3f78SToomas Soome break; 407a1bf3f78SToomas Soome } 408a1bf3f78SToomas Soome 409a1bf3f78SToomas Soome switch (*format) { 410a1bf3f78SToomas Soome case 's': 411a1bf3f78SToomas Soome case 'S': 412a1bf3f78SToomas Soome actualLength = 413a1bf3f78SToomas Soome ficlStackPopInteger(vm->dataStack); 414a1bf3f78SToomas Soome source = (char *) 415a1bf3f78SToomas Soome ficlStackPopPointer(vm->dataStack); 416a1bf3f78SToomas Soome break; 417a1bf3f78SToomas Soome case 'x': 418a1bf3f78SToomas Soome case 'X': 419a1bf3f78SToomas Soome base = 16; 420*3451cb4fSToomas Soome /* FALLTHROUGH */ 421a1bf3f78SToomas Soome case 'u': 422a1bf3f78SToomas Soome case 'U': 423a1bf3f78SToomas Soome unsignedInteger = 1; /* true */ 424*3451cb4fSToomas Soome /* FALLTHROUGH */ 425a1bf3f78SToomas Soome case 'd': 426a1bf3f78SToomas Soome case 'D': { 427a1bf3f78SToomas Soome int integer; 428a1bf3f78SToomas Soome integer = ficlStackPopInteger(vm->dataStack); 429a1bf3f78SToomas Soome if (unsignedInteger) 430a1bf3f78SToomas Soome ficlUltoa(integer, scratch, base); 431a1bf3f78SToomas Soome else 432a1bf3f78SToomas Soome ficlLtoa(integer, scratch, base); 433a1bf3f78SToomas Soome base = 10; 434a1bf3f78SToomas Soome unsignedInteger = 0; /* false */ 435a1bf3f78SToomas Soome source = scratch; 436a1bf3f78SToomas Soome actualLength = strlen(scratch); 437a1bf3f78SToomas Soome break; 438a1bf3f78SToomas Soome } 439a1bf3f78SToomas Soome case '%': 440a1bf3f78SToomas Soome source = format; 441a1bf3f78SToomas Soome actualLength = 1; 442*3451cb4fSToomas Soome /* FALLTHROUGH */ 443a1bf3f78SToomas Soome default: 444a1bf3f78SToomas Soome continue; 445a1bf3f78SToomas Soome } 446a1bf3f78SToomas Soome } 447a1bf3f78SToomas Soome 448a1bf3f78SToomas Soome if (append) { 449a1bf3f78SToomas Soome if (!desiredLength) 450a1bf3f78SToomas Soome desiredLength = actualLength; 451a1bf3f78SToomas Soome if (desiredLength > bufferLength) { 452a1bf3f78SToomas Soome append = 0; /* false */ 453a1bf3f78SToomas Soome desiredLength = bufferLength; 454a1bf3f78SToomas Soome } 455a1bf3f78SToomas Soome while (desiredLength > actualLength) { 456a1bf3f78SToomas Soome *buffer++ = (char)((leadingZeroes) ? '0' : ' '); 457a1bf3f78SToomas Soome bufferLength--; 458a1bf3f78SToomas Soome desiredLength--; 459a1bf3f78SToomas Soome } 460a1bf3f78SToomas Soome memcpy(buffer, source, actualLength); 461a1bf3f78SToomas Soome buffer += actualLength; 462a1bf3f78SToomas Soome bufferLength -= actualLength; 463a1bf3f78SToomas Soome } 464a1bf3f78SToomas Soome 465a1bf3f78SToomas Soome format++; 466a1bf3f78SToomas Soome } 467a1bf3f78SToomas Soome 468a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, bufferStart); 469a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, buffer - bufferStart); 470a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, FICL_BOOL(!append)); 471a1bf3f78SToomas Soome } 472a1bf3f78SToomas Soome 473a1bf3f78SToomas Soome /* 474a1bf3f78SToomas Soome * d u p & f r i e n d s 475a1bf3f78SToomas Soome */ 476a1bf3f78SToomas Soome static void 477a1bf3f78SToomas Soome ficlPrimitiveDepth(ficlVm *vm) 478a1bf3f78SToomas Soome { 479a1bf3f78SToomas Soome int i; 480a1bf3f78SToomas Soome 481a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 482a1bf3f78SToomas Soome 483a1bf3f78SToomas Soome i = ficlStackDepth(vm->dataStack); 484a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, i); 485a1bf3f78SToomas Soome } 486a1bf3f78SToomas Soome 487a1bf3f78SToomas Soome /* 488a1bf3f78SToomas Soome * e m i t & f r i e n d s 489a1bf3f78SToomas Soome */ 490a1bf3f78SToomas Soome static void 491a1bf3f78SToomas Soome ficlPrimitiveEmit(ficlVm *vm) 492a1bf3f78SToomas Soome { 493a1bf3f78SToomas Soome char buffer[2]; 494a1bf3f78SToomas Soome int i; 495a1bf3f78SToomas Soome 496a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 497a1bf3f78SToomas Soome 498a1bf3f78SToomas Soome i = ficlStackPopInteger(vm->dataStack); 499a1bf3f78SToomas Soome buffer[0] = (char)i; 500a1bf3f78SToomas Soome buffer[1] = '\0'; 501a1bf3f78SToomas Soome ficlVmTextOut(vm, buffer); 502a1bf3f78SToomas Soome } 503a1bf3f78SToomas Soome 504a1bf3f78SToomas Soome static void 505a1bf3f78SToomas Soome ficlPrimitiveCR(ficlVm *vm) 506a1bf3f78SToomas Soome { 507a1bf3f78SToomas Soome ficlVmTextOut(vm, "\n"); 508a1bf3f78SToomas Soome } 509a1bf3f78SToomas Soome 510a1bf3f78SToomas Soome static void 511a1bf3f78SToomas Soome ficlPrimitiveBackslash(ficlVm *vm) 512a1bf3f78SToomas Soome { 513a1bf3f78SToomas Soome char *trace = ficlVmGetInBuf(vm); 514a1bf3f78SToomas Soome char *stop = ficlVmGetInBufEnd(vm); 515a1bf3f78SToomas Soome char c = *trace; 516a1bf3f78SToomas Soome 517a1bf3f78SToomas Soome while ((trace != stop) && (c != '\r') && (c != '\n')) { 518a1bf3f78SToomas Soome c = *++trace; 519a1bf3f78SToomas Soome } 520a1bf3f78SToomas Soome 521a1bf3f78SToomas Soome /* 522a1bf3f78SToomas Soome * Cope with DOS or UNIX-style EOLs - 523a1bf3f78SToomas Soome * Check for /r, /n, /r/n, or /n/r end-of-line sequences, 524a1bf3f78SToomas Soome * and point trace to next char. If EOL is \0, we're done. 525a1bf3f78SToomas Soome */ 526a1bf3f78SToomas Soome if (trace != stop) { 527a1bf3f78SToomas Soome trace++; 528a1bf3f78SToomas Soome 529a1bf3f78SToomas Soome if ((trace != stop) && (c != *trace) && 530a1bf3f78SToomas Soome ((*trace == '\r') || (*trace == '\n'))) 531a1bf3f78SToomas Soome trace++; 532a1bf3f78SToomas Soome } 533a1bf3f78SToomas Soome 534a1bf3f78SToomas Soome ficlVmUpdateTib(vm, trace); 535a1bf3f78SToomas Soome } 536a1bf3f78SToomas Soome 537a1bf3f78SToomas Soome /* 538a1bf3f78SToomas Soome * paren CORE 539a1bf3f78SToomas Soome * Compilation: Perform the execution semantics given below. 540a1bf3f78SToomas Soome * Execution: ( "ccc<paren>" -- ) 541a1bf3f78SToomas Soome * Parse ccc delimited by ) (right parenthesis). ( is an immediate word. 542a1bf3f78SToomas Soome * The number of characters in ccc may be zero to the number of characters 543a1bf3f78SToomas Soome * in the parse area. 544a1bf3f78SToomas Soome */ 545a1bf3f78SToomas Soome static void 546a1bf3f78SToomas Soome ficlPrimitiveParenthesis(ficlVm *vm) 547a1bf3f78SToomas Soome { 548a1bf3f78SToomas Soome ficlVmParseStringEx(vm, ')', 0); 549a1bf3f78SToomas Soome } 550a1bf3f78SToomas Soome 551a1bf3f78SToomas Soome /* 552a1bf3f78SToomas Soome * F E T C H & S T O R E 553a1bf3f78SToomas Soome */ 554a1bf3f78SToomas Soome 555a1bf3f78SToomas Soome /* 556a1bf3f78SToomas Soome * i f C o I m 557a1bf3f78SToomas Soome * IMMEDIATE 558a1bf3f78SToomas Soome * Compiles code for a conditional branch into the dictionary 559a1bf3f78SToomas Soome * and pushes the branch patch address on the stack for later 560a1bf3f78SToomas Soome * patching by ELSE or THEN/ENDIF. 561a1bf3f78SToomas Soome */ 562a1bf3f78SToomas Soome static void 563a1bf3f78SToomas Soome ficlPrimitiveIfCoIm(ficlVm *vm) 564a1bf3f78SToomas Soome { 565a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 566a1bf3f78SToomas Soome 567a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 568a1bf3f78SToomas Soome ficlInstructionBranch0ParenWithCheck); 569a1bf3f78SToomas Soome markBranch(dictionary, vm, origTag); 570a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1); 571a1bf3f78SToomas Soome } 572a1bf3f78SToomas Soome 573a1bf3f78SToomas Soome /* 574a1bf3f78SToomas Soome * e l s e C o I m 575a1bf3f78SToomas Soome * 576a1bf3f78SToomas Soome * IMMEDIATE -- compiles an "else"... 577a1bf3f78SToomas Soome * 1) FICL_VM_STATE_COMPILE a branch and a patch address; 578a1bf3f78SToomas Soome * the address gets patched 579a1bf3f78SToomas Soome * by "endif" to point past the "else" code. 580a1bf3f78SToomas Soome * 2) Pop the the "if" patch address 581a1bf3f78SToomas Soome * 3) Patch the "if" branch to point to the current FICL_VM_STATE_COMPILE 582a1bf3f78SToomas Soome * address. 583a1bf3f78SToomas Soome * 4) Push the "else" patch address. ("endif" patches this to jump past 584a1bf3f78SToomas Soome * the "else" code. 585a1bf3f78SToomas Soome */ 586a1bf3f78SToomas Soome static void 587a1bf3f78SToomas Soome ficlPrimitiveElseCoIm(ficlVm *vm) 588a1bf3f78SToomas Soome { 589a1bf3f78SToomas Soome ficlCell *patchAddr; 590a1bf3f78SToomas Soome ficlInteger offset; 591a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 592a1bf3f78SToomas Soome 593a1bf3f78SToomas Soome /* (1) FICL_VM_STATE_COMPILE branch runtime */ 594a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 595a1bf3f78SToomas Soome ficlInstructionBranchParenWithCheck); 596a1bf3f78SToomas Soome 597a1bf3f78SToomas Soome matchControlTag(vm, origTag); 598a1bf3f78SToomas Soome /* (2) pop "if" patch addr */ 599a1bf3f78SToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); 600a1bf3f78SToomas Soome markBranch(dictionary, vm, origTag); /* (4) push "else" patch addr */ 601a1bf3f78SToomas Soome 602a1bf3f78SToomas Soome /* (1) FICL_VM_STATE_COMPILE patch placeholder */ 603a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1); 604a1bf3f78SToomas Soome offset = dictionary->here - patchAddr; 605a1bf3f78SToomas Soome (*patchAddr).i = offset; /* (3) Patch "if" */ 606a1bf3f78SToomas Soome } 607a1bf3f78SToomas Soome 608a1bf3f78SToomas Soome /* 609a1bf3f78SToomas Soome * e n d i f C o I m 610a1bf3f78SToomas Soome */ 611a1bf3f78SToomas Soome static void 612a1bf3f78SToomas Soome ficlPrimitiveEndifCoIm(ficlVm *vm) 613a1bf3f78SToomas Soome { 614a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 615a1bf3f78SToomas Soome resolveForwardBranch(dictionary, vm, origTag); 616a1bf3f78SToomas Soome } 617a1bf3f78SToomas Soome 618a1bf3f78SToomas Soome /* 619a1bf3f78SToomas Soome * c a s e C o I m 620a1bf3f78SToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY 621a1bf3f78SToomas Soome * 622a1bf3f78SToomas Soome * 623a1bf3f78SToomas Soome * At FICL_VM_STATE_COMPILE-time, a CASE-SYS (see DPANS94 6.2.0873) looks 624a1bf3f78SToomas Soome * like this: 625a1bf3f78SToomas Soome * i*addr i caseTag 626a1bf3f78SToomas Soome * and an OF-SYS (see DPANS94 6.2.1950) looks like this: 627a1bf3f78SToomas Soome * i*addr i caseTag addr ofTag 628a1bf3f78SToomas Soome * The integer under caseTag is the count of fixup addresses that branch 629a1bf3f78SToomas Soome * to ENDCASE. 630a1bf3f78SToomas Soome */ 631a1bf3f78SToomas Soome static void 632a1bf3f78SToomas Soome ficlPrimitiveCaseCoIm(ficlVm *vm) 633a1bf3f78SToomas Soome { 634a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 2); 635a1bf3f78SToomas Soome 636a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, 0); 637a1bf3f78SToomas Soome markControlTag(vm, caseTag); 638a1bf3f78SToomas Soome } 639a1bf3f78SToomas Soome 640a1bf3f78SToomas Soome /* 641a1bf3f78SToomas Soome * e n d c a s eC o I m 642a1bf3f78SToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY 643a1bf3f78SToomas Soome */ 644a1bf3f78SToomas Soome static void 645a1bf3f78SToomas Soome ficlPrimitiveEndcaseCoIm(ficlVm *vm) 646a1bf3f78SToomas Soome { 647a1bf3f78SToomas Soome ficlUnsigned fixupCount; 648a1bf3f78SToomas Soome ficlDictionary *dictionary; 649a1bf3f78SToomas Soome ficlCell *patchAddr; 650a1bf3f78SToomas Soome ficlInteger offset; 651a1bf3f78SToomas Soome 652a1bf3f78SToomas Soome /* 653a1bf3f78SToomas Soome * if the last OF ended with FALLTHROUGH, 654a1bf3f78SToomas Soome * just add the FALLTHROUGH fixup to the 655a1bf3f78SToomas Soome * ENDOF fixups 656a1bf3f78SToomas Soome */ 657a1bf3f78SToomas Soome if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) { 658a1bf3f78SToomas Soome matchControlTag(vm, fallthroughTag); 659a1bf3f78SToomas Soome patchAddr = ficlStackPopPointer(vm->dataStack); 660a1bf3f78SToomas Soome matchControlTag(vm, caseTag); 661a1bf3f78SToomas Soome fixupCount = ficlStackPopUnsigned(vm->dataStack); 662a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, patchAddr); 663a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, fixupCount + 1); 664a1bf3f78SToomas Soome markControlTag(vm, caseTag); 665a1bf3f78SToomas Soome } 666a1bf3f78SToomas Soome 667a1bf3f78SToomas Soome matchControlTag(vm, caseTag); 668a1bf3f78SToomas Soome 669a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 670a1bf3f78SToomas Soome 671a1bf3f78SToomas Soome fixupCount = ficlStackPopUnsigned(vm->dataStack); 672a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, fixupCount, 0); 673a1bf3f78SToomas Soome 674a1bf3f78SToomas Soome dictionary = ficlVmGetDictionary(vm); 675a1bf3f78SToomas Soome 676a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDrop); 677a1bf3f78SToomas Soome 678a1bf3f78SToomas Soome while (fixupCount--) { 679a1bf3f78SToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); 680a1bf3f78SToomas Soome offset = dictionary->here - patchAddr; 681a1bf3f78SToomas Soome (*patchAddr).i = offset; 682a1bf3f78SToomas Soome } 683a1bf3f78SToomas Soome } 684a1bf3f78SToomas Soome 685a1bf3f78SToomas Soome /* 686a1bf3f78SToomas Soome * o f C o I m 687a1bf3f78SToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY 688a1bf3f78SToomas Soome */ 689a1bf3f78SToomas Soome static void 690a1bf3f78SToomas Soome ficlPrimitiveOfCoIm(ficlVm *vm) 691a1bf3f78SToomas Soome { 692a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 693a1bf3f78SToomas Soome ficlCell *fallthroughFixup = NULL; 694a1bf3f78SToomas Soome 695a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 3); 696a1bf3f78SToomas Soome 697a1bf3f78SToomas Soome if (ficlStackGetTop(vm->dataStack).p == fallthroughTag) { 698a1bf3f78SToomas Soome matchControlTag(vm, fallthroughTag); 699a1bf3f78SToomas Soome fallthroughFixup = ficlStackPopPointer(vm->dataStack); 700a1bf3f78SToomas Soome } 701a1bf3f78SToomas Soome 702a1bf3f78SToomas Soome matchControlTag(vm, caseTag); 703a1bf3f78SToomas Soome 704a1bf3f78SToomas Soome markControlTag(vm, caseTag); 705a1bf3f78SToomas Soome 706a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionOfParen); 707a1bf3f78SToomas Soome markBranch(dictionary, vm, ofTag); 708a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2); 709a1bf3f78SToomas Soome 710a1bf3f78SToomas Soome if (fallthroughFixup != NULL) { 711a1bf3f78SToomas Soome ficlInteger offset = dictionary->here - fallthroughFixup; 712a1bf3f78SToomas Soome (*fallthroughFixup).i = offset; 713a1bf3f78SToomas Soome } 714a1bf3f78SToomas Soome } 715a1bf3f78SToomas Soome 716a1bf3f78SToomas Soome /* 717a1bf3f78SToomas Soome * e n d o f C o I m 718a1bf3f78SToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY 719a1bf3f78SToomas Soome */ 720a1bf3f78SToomas Soome static void 721a1bf3f78SToomas Soome ficlPrimitiveEndofCoIm(ficlVm *vm) 722a1bf3f78SToomas Soome { 723a1bf3f78SToomas Soome ficlCell *patchAddr; 724a1bf3f78SToomas Soome ficlUnsigned fixupCount; 725a1bf3f78SToomas Soome ficlInteger offset; 726a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 727a1bf3f78SToomas Soome 728a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 4, 3); 729a1bf3f78SToomas Soome 730a1bf3f78SToomas Soome /* ensure we're in an OF, */ 731a1bf3f78SToomas Soome matchControlTag(vm, ofTag); 732a1bf3f78SToomas Soome 733a1bf3f78SToomas Soome /* grab the address of the branch location after the OF */ 734a1bf3f78SToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); 735a1bf3f78SToomas Soome /* ensure we're also in a "case" */ 736a1bf3f78SToomas Soome matchControlTag(vm, caseTag); 737a1bf3f78SToomas Soome /* grab the current number of ENDOF fixups */ 738a1bf3f78SToomas Soome fixupCount = ficlStackPopUnsigned(vm->dataStack); 739a1bf3f78SToomas Soome 740a1bf3f78SToomas Soome /* FICL_VM_STATE_COMPILE branch runtime */ 741a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 742a1bf3f78SToomas Soome ficlInstructionBranchParenWithCheck); 743a1bf3f78SToomas Soome 744a1bf3f78SToomas Soome /* 745a1bf3f78SToomas Soome * push a new ENDOF fixup, the updated count of ENDOF fixups, 746a1bf3f78SToomas Soome * and the caseTag 747a1bf3f78SToomas Soome */ 748a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here); 749a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, fixupCount + 1); 750a1bf3f78SToomas Soome markControlTag(vm, caseTag); 751a1bf3f78SToomas Soome 752a1bf3f78SToomas Soome /* reserve space for the ENDOF fixup */ 753a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2); 754a1bf3f78SToomas Soome 755a1bf3f78SToomas Soome /* and patch the original OF */ 756a1bf3f78SToomas Soome offset = dictionary->here - patchAddr; 757a1bf3f78SToomas Soome (*patchAddr).i = offset; 758a1bf3f78SToomas Soome } 759a1bf3f78SToomas Soome 760a1bf3f78SToomas Soome /* 761a1bf3f78SToomas Soome * f a l l t h r o u g h C o I m 762a1bf3f78SToomas Soome * IMMEDIATE FICL_VM_STATE_COMPILE-ONLY 763a1bf3f78SToomas Soome */ 764a1bf3f78SToomas Soome static void 765a1bf3f78SToomas Soome ficlPrimitiveFallthroughCoIm(ficlVm *vm) 766a1bf3f78SToomas Soome { 767a1bf3f78SToomas Soome ficlCell *patchAddr; 768a1bf3f78SToomas Soome ficlInteger offset; 769a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 770a1bf3f78SToomas Soome 771a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 4, 3); 772a1bf3f78SToomas Soome 773a1bf3f78SToomas Soome /* ensure we're in an OF, */ 774a1bf3f78SToomas Soome matchControlTag(vm, ofTag); 775a1bf3f78SToomas Soome /* grab the address of the branch location after the OF */ 776a1bf3f78SToomas Soome patchAddr = (ficlCell *)ficlStackPopPointer(vm->dataStack); 777a1bf3f78SToomas Soome /* ensure we're also in a "case" */ 778a1bf3f78SToomas Soome matchControlTag(vm, caseTag); 779a1bf3f78SToomas Soome 780a1bf3f78SToomas Soome /* okay, here we go. put the case tag back. */ 781a1bf3f78SToomas Soome markControlTag(vm, caseTag); 782a1bf3f78SToomas Soome 783a1bf3f78SToomas Soome /* FICL_VM_STATE_COMPILE branch runtime */ 784a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 785a1bf3f78SToomas Soome ficlInstructionBranchParenWithCheck); 786a1bf3f78SToomas Soome 787a1bf3f78SToomas Soome /* push a new FALLTHROUGH fixup and the fallthroughTag */ 788a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here); 789a1bf3f78SToomas Soome markControlTag(vm, fallthroughTag); 790a1bf3f78SToomas Soome 791a1bf3f78SToomas Soome /* reserve space for the FALLTHROUGH fixup */ 792a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2); 793a1bf3f78SToomas Soome 794a1bf3f78SToomas Soome /* and patch the original OF */ 795a1bf3f78SToomas Soome offset = dictionary->here - patchAddr; 796a1bf3f78SToomas Soome (*patchAddr).i = offset; 797a1bf3f78SToomas Soome } 798a1bf3f78SToomas Soome 799a1bf3f78SToomas Soome /* 800a1bf3f78SToomas Soome * h a s h 801a1bf3f78SToomas Soome * hash ( c-addr u -- code) 802a1bf3f78SToomas Soome * calculates hashcode of specified string and leaves it on the stack 803a1bf3f78SToomas Soome */ 804a1bf3f78SToomas Soome static void 805a1bf3f78SToomas Soome ficlPrimitiveHash(ficlVm *vm) 806a1bf3f78SToomas Soome { 807a1bf3f78SToomas Soome ficlString s; 808a1bf3f78SToomas Soome 809a1bf3f78SToomas Soome FICL_STRING_SET_LENGTH(s, ficlStackPopUnsigned(vm->dataStack)); 810a1bf3f78SToomas Soome FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack)); 811a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, ficlHashCode(s)); 812a1bf3f78SToomas Soome } 813a1bf3f78SToomas Soome 814a1bf3f78SToomas Soome /* 815a1bf3f78SToomas Soome * i n t e r p r e t 816a1bf3f78SToomas Soome * This is the "user interface" of a Forth. It does the following: 817a1bf3f78SToomas Soome * while there are words in the VM's Text Input Buffer 818a1bf3f78SToomas Soome * Copy next word into the pad (ficlVmGetWord) 819a1bf3f78SToomas Soome * Attempt to find the word in the dictionary (ficlDictionaryLookup) 820a1bf3f78SToomas Soome * If successful, execute the word. 821a1bf3f78SToomas Soome * Otherwise, attempt to convert the word to a number (isNumber) 822a1bf3f78SToomas Soome * If successful, push the number onto the parameter stack. 823a1bf3f78SToomas Soome * Otherwise, print an error message and exit loop... 824a1bf3f78SToomas Soome * End Loop 825a1bf3f78SToomas Soome * 826a1bf3f78SToomas Soome * From the standard, section 3.4 827a1bf3f78SToomas Soome * Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall 828a1bf3f78SToomas Soome * repeat the following steps until either the parse area is empty or an 829a1bf3f78SToomas Soome * ambiguous condition exists: 830a1bf3f78SToomas Soome * a) Skip leading spaces and parse a name (see 3.4.1); 831a1bf3f78SToomas Soome */ 832a1bf3f78SToomas Soome static void 833a1bf3f78SToomas Soome ficlPrimitiveInterpret(ficlVm *vm) 834a1bf3f78SToomas Soome { 835a1bf3f78SToomas Soome ficlString s; 836a1bf3f78SToomas Soome int i; 837a1bf3f78SToomas Soome ficlSystem *system; 838a1bf3f78SToomas Soome 839a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, vm); 840a1bf3f78SToomas Soome 841a1bf3f78SToomas Soome system = vm->callback.system; 842a1bf3f78SToomas Soome s = ficlVmGetWord0(vm); 843a1bf3f78SToomas Soome 844a1bf3f78SToomas Soome /* 845a1bf3f78SToomas Soome * Get next word...if out of text, we're done. 846a1bf3f78SToomas Soome */ 847a1bf3f78SToomas Soome if (s.length == 0) { 848a1bf3f78SToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_OUT_OF_TEXT); 849a1bf3f78SToomas Soome } 850a1bf3f78SToomas Soome 851a1bf3f78SToomas Soome /* 852a1bf3f78SToomas Soome * Run the parse chain against the incoming token until somebody 853a1bf3f78SToomas Soome * eats it. Otherwise emit an error message and give up. 854a1bf3f78SToomas Soome */ 855a1bf3f78SToomas Soome for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) { 856a1bf3f78SToomas Soome ficlWord *word = system->parseList[i]; 857a1bf3f78SToomas Soome 858a1bf3f78SToomas Soome if (word == NULL) 859a1bf3f78SToomas Soome break; 860a1bf3f78SToomas Soome 861a1bf3f78SToomas Soome if (word->code == ficlPrimitiveParseStepParen) { 862a1bf3f78SToomas Soome ficlParseStep pStep; 863a1bf3f78SToomas Soome pStep = (ficlParseStep)(word->param->fn); 864a1bf3f78SToomas Soome if ((*pStep)(vm, s)) 865a1bf3f78SToomas Soome return; 866a1bf3f78SToomas Soome } else { 867a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, 868a1bf3f78SToomas Soome FICL_STRING_GET_POINTER(s)); 869a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, 870a1bf3f78SToomas Soome FICL_STRING_GET_LENGTH(s)); 871a1bf3f78SToomas Soome ficlVmExecuteXT(vm, word); 872a1bf3f78SToomas Soome if (ficlStackPopInteger(vm->dataStack)) 873a1bf3f78SToomas Soome return; 874a1bf3f78SToomas Soome } 875a1bf3f78SToomas Soome } 876a1bf3f78SToomas Soome 877a1bf3f78SToomas Soome ficlVmThrowError(vm, "%.*s not found", FICL_STRING_GET_LENGTH(s), 878a1bf3f78SToomas Soome FICL_STRING_GET_POINTER(s)); 879a1bf3f78SToomas Soome /* back to inner interpreter */ 880a1bf3f78SToomas Soome } 881a1bf3f78SToomas Soome 882a1bf3f78SToomas Soome /* 883a1bf3f78SToomas Soome * Surrogate precompiled parse step for ficlParseWord 884a1bf3f78SToomas Soome * (this step is hard coded in FICL_VM_STATE_INTERPRET) 885a1bf3f78SToomas Soome */ 886a1bf3f78SToomas Soome static void 887a1bf3f78SToomas Soome ficlPrimitiveLookup(ficlVm *vm) 888a1bf3f78SToomas Soome { 889a1bf3f78SToomas Soome ficlString name; 890a1bf3f78SToomas Soome FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack)); 891a1bf3f78SToomas Soome FICL_STRING_SET_POINTER(name, ficlStackPopPointer(vm->dataStack)); 892a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, ficlVmParseWord(vm, name)); 893a1bf3f78SToomas Soome } 894a1bf3f78SToomas Soome 895a1bf3f78SToomas Soome /* 896a1bf3f78SToomas Soome * p a r e n P a r s e S t e p 897a1bf3f78SToomas Soome * (parse-step) ( c-addr u -- flag ) 898a1bf3f78SToomas Soome * runtime for a precompiled parse step - pop a counted string off the 899a1bf3f78SToomas Soome * stack, run the parse step against it, and push the result flag (FICL_TRUE 900a1bf3f78SToomas Soome * if success, FICL_FALSE otherwise). 901a1bf3f78SToomas Soome */ 902a1bf3f78SToomas Soome void 903a1bf3f78SToomas Soome ficlPrimitiveParseStepParen(ficlVm *vm) 904a1bf3f78SToomas Soome { 905a1bf3f78SToomas Soome ficlString s; 906a1bf3f78SToomas Soome ficlWord *word = vm->runningWord; 907a1bf3f78SToomas Soome ficlParseStep pStep = (ficlParseStep)(word->param->fn); 908a1bf3f78SToomas Soome 909a1bf3f78SToomas Soome FICL_STRING_SET_LENGTH(s, ficlStackPopInteger(vm->dataStack)); 910a1bf3f78SToomas Soome FICL_STRING_SET_POINTER(s, ficlStackPopPointer(vm->dataStack)); 911a1bf3f78SToomas Soome 912a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, (*pStep)(vm, s)); 913a1bf3f78SToomas Soome } 914a1bf3f78SToomas Soome 915a1bf3f78SToomas Soome static void 916a1bf3f78SToomas Soome ficlPrimitiveAddParseStep(ficlVm *vm) 917a1bf3f78SToomas Soome { 918a1bf3f78SToomas Soome ficlWord *pStep; 919a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 920a1bf3f78SToomas Soome 921a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 922a1bf3f78SToomas Soome 923a1bf3f78SToomas Soome pStep = (ficlWord *)(ficlStackPop(vm->dataStack).p); 924a1bf3f78SToomas Soome if ((pStep != NULL) && ficlDictionaryIsAWord(dictionary, pStep)) 925a1bf3f78SToomas Soome ficlSystemAddParseStep(vm->callback.system, pStep); 926a1bf3f78SToomas Soome } 927a1bf3f78SToomas Soome 928a1bf3f78SToomas Soome /* 929a1bf3f78SToomas Soome * l i t e r a l I m 930a1bf3f78SToomas Soome * 931a1bf3f78SToomas Soome * IMMEDIATE code for "literal". This function gets a value from the stack 932a1bf3f78SToomas Soome * and compiles it into the dictionary preceded by the code for "(literal)". 933a1bf3f78SToomas Soome * IMMEDIATE 934a1bf3f78SToomas Soome */ 935a1bf3f78SToomas Soome void 936a1bf3f78SToomas Soome ficlPrimitiveLiteralIm(ficlVm *vm) 937a1bf3f78SToomas Soome { 938a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 939a1bf3f78SToomas Soome ficlInteger value; 940a1bf3f78SToomas Soome 941a1bf3f78SToomas Soome value = ficlStackPopInteger(vm->dataStack); 942a1bf3f78SToomas Soome 943a1bf3f78SToomas Soome switch (value) { 944a1bf3f78SToomas Soome case 1: 945a1bf3f78SToomas Soome case 2: 946a1bf3f78SToomas Soome case 3: 947a1bf3f78SToomas Soome case 4: 948a1bf3f78SToomas Soome case 5: 949a1bf3f78SToomas Soome case 6: 950a1bf3f78SToomas Soome case 7: 951a1bf3f78SToomas Soome case 8: 952a1bf3f78SToomas Soome case 9: 953a1bf3f78SToomas Soome case 10: 954a1bf3f78SToomas Soome case 11: 955a1bf3f78SToomas Soome case 12: 956a1bf3f78SToomas Soome case 13: 957a1bf3f78SToomas Soome case 14: 958a1bf3f78SToomas Soome case 15: 959a1bf3f78SToomas Soome case 16: 960a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, value); 961a1bf3f78SToomas Soome break; 962a1bf3f78SToomas Soome 963a1bf3f78SToomas Soome case 0: 964a1bf3f78SToomas Soome case -1: 965a1bf3f78SToomas Soome case -2: 966a1bf3f78SToomas Soome case -3: 967a1bf3f78SToomas Soome case -4: 968a1bf3f78SToomas Soome case -5: 969a1bf3f78SToomas Soome case -6: 970a1bf3f78SToomas Soome case -7: 971a1bf3f78SToomas Soome case -8: 972a1bf3f78SToomas Soome case -9: 973a1bf3f78SToomas Soome case -10: 974a1bf3f78SToomas Soome case -11: 975a1bf3f78SToomas Soome case -12: 976a1bf3f78SToomas Soome case -13: 977a1bf3f78SToomas Soome case -14: 978a1bf3f78SToomas Soome case -15: 979a1bf3f78SToomas Soome case -16: 980a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 981a1bf3f78SToomas Soome ficlInstruction0 - value); 982a1bf3f78SToomas Soome break; 983a1bf3f78SToomas Soome 984a1bf3f78SToomas Soome default: 985a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 986a1bf3f78SToomas Soome ficlInstructionLiteralParen); 987a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, value); 988a1bf3f78SToomas Soome break; 989a1bf3f78SToomas Soome } 990a1bf3f78SToomas Soome } 991a1bf3f78SToomas Soome 992a1bf3f78SToomas Soome static void 993a1bf3f78SToomas Soome ficlPrimitive2LiteralIm(ficlVm *vm) 994a1bf3f78SToomas Soome { 995a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 996a1bf3f78SToomas Soome 997a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstruction2LiteralParen); 998a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack)); 999a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->dataStack)); 1000a1bf3f78SToomas Soome } 1001a1bf3f78SToomas Soome 1002a1bf3f78SToomas Soome /* 1003a1bf3f78SToomas Soome * D o / L o o p 1004a1bf3f78SToomas Soome * do -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY 1005a1bf3f78SToomas Soome * Compiles code to initialize a loop: FICL_VM_STATE_COMPILE (do), 1006a1bf3f78SToomas Soome * allot space to hold the "leave" address, push a branch 1007a1bf3f78SToomas Soome * target address for the loop. 1008a1bf3f78SToomas Soome * (do) -- runtime for "do" 1009a1bf3f78SToomas Soome * pops index and limit from the p stack and moves them 1010a1bf3f78SToomas Soome * to the r stack, then skips to the loop body. 1011a1bf3f78SToomas Soome * loop -- IMMEDIATE FICL_VM_STATE_COMPILE ONLY 1012a1bf3f78SToomas Soome * +loop 1013a1bf3f78SToomas Soome * Compiles code for the test part of a loop: 1014a1bf3f78SToomas Soome * FICL_VM_STATE_COMPILE (loop), resolve forward branch from "do", and 1015a1bf3f78SToomas Soome * copy "here" address to the "leave" address allotted by "do" 1016a1bf3f78SToomas Soome * i,j,k -- FICL_VM_STATE_COMPILE ONLY 1017a1bf3f78SToomas Soome * Runtime: Push loop indices on param stack (i is innermost loop...) 1018a1bf3f78SToomas Soome * Note: each loop has three values on the return stack: 1019a1bf3f78SToomas Soome * ( R: leave limit index ) 1020a1bf3f78SToomas Soome * "leave" is the absolute address of the next ficlCell after the loop 1021a1bf3f78SToomas Soome * limit and index are the loop control variables. 1022a1bf3f78SToomas Soome * leave -- FICL_VM_STATE_COMPILE ONLY 1023a1bf3f78SToomas Soome * Runtime: pop the loop control variables, then pop the 1024a1bf3f78SToomas Soome * "leave" address and jump (absolute) there. 1025a1bf3f78SToomas Soome */ 1026a1bf3f78SToomas Soome static void 1027a1bf3f78SToomas Soome ficlPrimitiveDoCoIm(ficlVm *vm) 1028a1bf3f78SToomas Soome { 1029a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1030a1bf3f78SToomas Soome 1031a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoParen); 1032a1bf3f78SToomas Soome /* 1033a1bf3f78SToomas Soome * Allot space for a pointer to the end 1034a1bf3f78SToomas Soome * of the loop - "leave" uses this... 1035a1bf3f78SToomas Soome */ 1036a1bf3f78SToomas Soome markBranch(dictionary, vm, leaveTag); 1037a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 0); 1038a1bf3f78SToomas Soome /* 1039a1bf3f78SToomas Soome * Mark location of head of loop... 1040a1bf3f78SToomas Soome */ 1041a1bf3f78SToomas Soome markBranch(dictionary, vm, doTag); 1042a1bf3f78SToomas Soome } 1043a1bf3f78SToomas Soome 1044a1bf3f78SToomas Soome static void 1045a1bf3f78SToomas Soome ficlPrimitiveQDoCoIm(ficlVm *vm) 1046a1bf3f78SToomas Soome { 1047a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1048a1bf3f78SToomas Soome 1049a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionQDoParen); 1050a1bf3f78SToomas Soome /* 1051a1bf3f78SToomas Soome * Allot space for a pointer to the end 1052a1bf3f78SToomas Soome * of the loop - "leave" uses this... 1053a1bf3f78SToomas Soome */ 1054a1bf3f78SToomas Soome markBranch(dictionary, vm, leaveTag); 1055a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 0); 1056a1bf3f78SToomas Soome /* 1057a1bf3f78SToomas Soome * Mark location of head of loop... 1058a1bf3f78SToomas Soome */ 1059a1bf3f78SToomas Soome markBranch(dictionary, vm, doTag); 1060a1bf3f78SToomas Soome } 1061a1bf3f78SToomas Soome 1062a1bf3f78SToomas Soome 1063a1bf3f78SToomas Soome static void 1064a1bf3f78SToomas Soome ficlPrimitiveLoopCoIm(ficlVm *vm) 1065a1bf3f78SToomas Soome { 1066a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1067a1bf3f78SToomas Soome 1068a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionLoopParen); 1069a1bf3f78SToomas Soome resolveBackBranch(dictionary, vm, doTag); 1070a1bf3f78SToomas Soome resolveAbsBranch(dictionary, vm, leaveTag); 1071a1bf3f78SToomas Soome } 1072a1bf3f78SToomas Soome 1073a1bf3f78SToomas Soome static void 1074a1bf3f78SToomas Soome ficlPrimitivePlusLoopCoIm(ficlVm *vm) 1075a1bf3f78SToomas Soome { 1076a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1077a1bf3f78SToomas Soome 1078a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionPlusLoopParen); 1079a1bf3f78SToomas Soome resolveBackBranch(dictionary, vm, doTag); 1080a1bf3f78SToomas Soome resolveAbsBranch(dictionary, vm, leaveTag); 1081a1bf3f78SToomas Soome } 1082a1bf3f78SToomas Soome 1083a1bf3f78SToomas Soome /* 1084a1bf3f78SToomas Soome * v a r i a b l e 1085a1bf3f78SToomas Soome */ 1086a1bf3f78SToomas Soome static void 1087a1bf3f78SToomas Soome ficlPrimitiveVariable(ficlVm *vm) 1088a1bf3f78SToomas Soome { 1089a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1090a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 1091a1bf3f78SToomas Soome 1092a1bf3f78SToomas Soome ficlDictionaryAppendWord(dictionary, name, 1093a1bf3f78SToomas Soome (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT); 1094a1bf3f78SToomas Soome ficlVmDictionaryAllotCells(vm, dictionary, 1); 1095a1bf3f78SToomas Soome } 1096a1bf3f78SToomas Soome 1097a1bf3f78SToomas Soome static void 1098a1bf3f78SToomas Soome ficlPrimitive2Variable(ficlVm *vm) 1099a1bf3f78SToomas Soome { 1100a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1101a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 1102a1bf3f78SToomas Soome 1103a1bf3f78SToomas Soome ficlDictionaryAppendWord(dictionary, name, 1104a1bf3f78SToomas Soome (ficlPrimitive)ficlInstructionVariableParen, FICL_WORD_DEFAULT); 1105a1bf3f78SToomas Soome ficlVmDictionaryAllotCells(vm, dictionary, 2); 1106a1bf3f78SToomas Soome } 1107a1bf3f78SToomas Soome 1108a1bf3f78SToomas Soome /* 1109a1bf3f78SToomas Soome * b a s e & f r i e n d s 1110a1bf3f78SToomas Soome */ 1111a1bf3f78SToomas Soome static void 1112a1bf3f78SToomas Soome ficlPrimitiveBase(ficlVm *vm) 1113a1bf3f78SToomas Soome { 1114a1bf3f78SToomas Soome ficlCell *pBase, c; 1115a1bf3f78SToomas Soome 1116a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 1117a1bf3f78SToomas Soome 1118a1bf3f78SToomas Soome pBase = (ficlCell *)(&vm->base); 1119a1bf3f78SToomas Soome c.p = pBase; 1120a1bf3f78SToomas Soome ficlStackPush(vm->dataStack, c); 1121a1bf3f78SToomas Soome } 1122a1bf3f78SToomas Soome 1123a1bf3f78SToomas Soome static void 1124a1bf3f78SToomas Soome ficlPrimitiveDecimal(ficlVm *vm) 1125a1bf3f78SToomas Soome { 1126a1bf3f78SToomas Soome vm->base = 10; 1127a1bf3f78SToomas Soome } 1128a1bf3f78SToomas Soome 1129a1bf3f78SToomas Soome 1130a1bf3f78SToomas Soome static void 1131a1bf3f78SToomas Soome ficlPrimitiveHex(ficlVm *vm) 1132a1bf3f78SToomas Soome { 1133a1bf3f78SToomas Soome vm->base = 16; 1134a1bf3f78SToomas Soome } 1135a1bf3f78SToomas Soome 1136a1bf3f78SToomas Soome /* 1137a1bf3f78SToomas Soome * a l l o t & f r i e n d s 1138a1bf3f78SToomas Soome */ 1139a1bf3f78SToomas Soome static void 1140a1bf3f78SToomas Soome ficlPrimitiveAllot(ficlVm *vm) 1141a1bf3f78SToomas Soome { 1142a1bf3f78SToomas Soome ficlDictionary *dictionary; 1143a1bf3f78SToomas Soome ficlInteger i; 1144a1bf3f78SToomas Soome 1145a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 1146a1bf3f78SToomas Soome 1147a1bf3f78SToomas Soome dictionary = ficlVmGetDictionary(vm); 1148a1bf3f78SToomas Soome i = ficlStackPopInteger(vm->dataStack); 1149a1bf3f78SToomas Soome 1150a1bf3f78SToomas Soome FICL_VM_DICTIONARY_CHECK(vm, dictionary, i); 1151a1bf3f78SToomas Soome 1152a1bf3f78SToomas Soome ficlVmDictionaryAllot(vm, dictionary, i); 1153a1bf3f78SToomas Soome } 1154a1bf3f78SToomas Soome 1155a1bf3f78SToomas Soome static void 1156a1bf3f78SToomas Soome ficlPrimitiveHere(ficlVm *vm) 1157a1bf3f78SToomas Soome { 1158a1bf3f78SToomas Soome ficlDictionary *dictionary; 1159a1bf3f78SToomas Soome 1160a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 1161a1bf3f78SToomas Soome 1162a1bf3f78SToomas Soome dictionary = ficlVmGetDictionary(vm); 1163a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, dictionary->here); 1164a1bf3f78SToomas Soome } 1165a1bf3f78SToomas Soome 1166a1bf3f78SToomas Soome /* 1167a1bf3f78SToomas Soome * t i c k 1168a1bf3f78SToomas Soome * tick CORE ( "<spaces>name" -- xt ) 1169a1bf3f78SToomas Soome * Skip leading space delimiters. Parse name delimited by a space. Find 1170a1bf3f78SToomas Soome * name and return xt, the execution token for name. An ambiguous condition 1171a1bf3f78SToomas Soome * exists if name is not found. 1172a1bf3f78SToomas Soome */ 1173a1bf3f78SToomas Soome void 1174a1bf3f78SToomas Soome ficlPrimitiveTick(ficlVm *vm) 1175a1bf3f78SToomas Soome { 1176a1bf3f78SToomas Soome ficlWord *word = NULL; 1177a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 1178a1bf3f78SToomas Soome 1179a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 1180a1bf3f78SToomas Soome 1181a1bf3f78SToomas Soome word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name); 1182a1bf3f78SToomas Soome if (!word) 1183a1bf3f78SToomas Soome ficlVmThrowError(vm, "%.*s not found", 1184a1bf3f78SToomas Soome FICL_STRING_GET_LENGTH(name), 1185a1bf3f78SToomas Soome FICL_STRING_GET_POINTER(name)); 1186a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, word); 1187a1bf3f78SToomas Soome } 1188a1bf3f78SToomas Soome 1189a1bf3f78SToomas Soome static void 1190a1bf3f78SToomas Soome ficlPrimitiveBracketTickCoIm(ficlVm *vm) 1191a1bf3f78SToomas Soome { 1192a1bf3f78SToomas Soome ficlPrimitiveTick(vm); 1193a1bf3f78SToomas Soome ficlPrimitiveLiteralIm(vm); 1194a1bf3f78SToomas Soome } 1195a1bf3f78SToomas Soome 1196a1bf3f78SToomas Soome /* 1197a1bf3f78SToomas Soome * p o s t p o n e 1198a1bf3f78SToomas Soome * Lookup the next word in the input stream and FICL_VM_STATE_COMPILE code to 1199a1bf3f78SToomas Soome * insert it into definitions created by the resulting word 1200a1bf3f78SToomas Soome * (defers compilation, even of immediate words) 1201a1bf3f78SToomas Soome */ 1202a1bf3f78SToomas Soome static void 1203a1bf3f78SToomas Soome ficlPrimitivePostponeCoIm(ficlVm *vm) 1204a1bf3f78SToomas Soome { 1205a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1206a1bf3f78SToomas Soome ficlWord *word; 1207a1bf3f78SToomas Soome ficlWord *pComma = ficlSystemLookup(vm->callback.system, ","); 1208a1bf3f78SToomas Soome ficlCell c; 1209a1bf3f78SToomas Soome 1210a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, pComma); 1211a1bf3f78SToomas Soome 1212a1bf3f78SToomas Soome ficlPrimitiveTick(vm); 1213a1bf3f78SToomas Soome word = ficlStackGetTop(vm->dataStack).p; 1214a1bf3f78SToomas Soome if (ficlWordIsImmediate(word)) { 1215a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, 1216a1bf3f78SToomas Soome ficlStackPop(vm->dataStack)); 1217a1bf3f78SToomas Soome } else { 1218a1bf3f78SToomas Soome ficlPrimitiveLiteralIm(vm); 1219a1bf3f78SToomas Soome c.p = pComma; 1220a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, c); 1221a1bf3f78SToomas Soome } 1222a1bf3f78SToomas Soome } 1223a1bf3f78SToomas Soome 1224a1bf3f78SToomas Soome /* 1225a1bf3f78SToomas Soome * e x e c u t e 1226a1bf3f78SToomas Soome * Pop an execution token (pointer to a word) off the stack and 1227a1bf3f78SToomas Soome * run it 1228a1bf3f78SToomas Soome */ 1229a1bf3f78SToomas Soome static void 1230a1bf3f78SToomas Soome ficlPrimitiveExecute(ficlVm *vm) 1231a1bf3f78SToomas Soome { 1232a1bf3f78SToomas Soome ficlWord *word; 1233a1bf3f78SToomas Soome 1234a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 1235a1bf3f78SToomas Soome 1236a1bf3f78SToomas Soome word = ficlStackPopPointer(vm->dataStack); 1237a1bf3f78SToomas Soome ficlVmExecuteWord(vm, word); 1238a1bf3f78SToomas Soome } 1239a1bf3f78SToomas Soome 1240a1bf3f78SToomas Soome /* 1241a1bf3f78SToomas Soome * i m m e d i a t e 1242a1bf3f78SToomas Soome * Make the most recently compiled word IMMEDIATE -- it executes even 1243a1bf3f78SToomas Soome * in FICL_VM_STATE_COMPILE state (most often used for control compiling words 1244a1bf3f78SToomas Soome * such as IF, THEN, etc) 1245a1bf3f78SToomas Soome */ 1246a1bf3f78SToomas Soome static void 1247a1bf3f78SToomas Soome ficlPrimitiveImmediate(ficlVm *vm) 1248a1bf3f78SToomas Soome { 1249a1bf3f78SToomas Soome FICL_IGNORE(vm); 1250a1bf3f78SToomas Soome ficlDictionarySetImmediate(ficlVmGetDictionary(vm)); 1251a1bf3f78SToomas Soome } 1252a1bf3f78SToomas Soome 1253a1bf3f78SToomas Soome static void 1254a1bf3f78SToomas Soome ficlPrimitiveCompileOnly(ficlVm *vm) 1255a1bf3f78SToomas Soome { 1256a1bf3f78SToomas Soome FICL_IGNORE(vm); 1257a1bf3f78SToomas Soome ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_COMPILE_ONLY); 1258a1bf3f78SToomas Soome } 1259a1bf3f78SToomas Soome 1260a1bf3f78SToomas Soome static void 1261a1bf3f78SToomas Soome ficlPrimitiveSetObjectFlag(ficlVm *vm) 1262a1bf3f78SToomas Soome { 1263a1bf3f78SToomas Soome FICL_IGNORE(vm); 1264a1bf3f78SToomas Soome ficlDictionarySetFlags(ficlVmGetDictionary(vm), FICL_WORD_OBJECT); 1265a1bf3f78SToomas Soome } 1266a1bf3f78SToomas Soome 1267a1bf3f78SToomas Soome static void 1268a1bf3f78SToomas Soome ficlPrimitiveIsObject(ficlVm *vm) 1269a1bf3f78SToomas Soome { 1270a1bf3f78SToomas Soome ficlInteger flag; 1271a1bf3f78SToomas Soome ficlWord *word = (ficlWord *)ficlStackPopPointer(vm->dataStack); 1272a1bf3f78SToomas Soome 1273a1bf3f78SToomas Soome flag = ((word != NULL) && (word->flags & FICL_WORD_OBJECT))? 1274a1bf3f78SToomas Soome FICL_TRUE : FICL_FALSE; 1275a1bf3f78SToomas Soome 1276a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, flag); 1277a1bf3f78SToomas Soome } 1278a1bf3f78SToomas Soome 1279a1bf3f78SToomas Soome static void 1280a1bf3f78SToomas Soome ficlPrimitiveCountedStringQuoteIm(ficlVm *vm) 1281a1bf3f78SToomas Soome { 1282a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1283a1bf3f78SToomas Soome 1284a1bf3f78SToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) { 1285a1bf3f78SToomas Soome ficlCountedString *counted = (ficlCountedString *) 1286a1bf3f78SToomas Soome dictionary->here; 1287a1bf3f78SToomas Soome 1288a1bf3f78SToomas Soome ficlVmGetString(vm, counted, '\"'); 1289a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, counted); 1290a1bf3f78SToomas Soome 1291a1bf3f78SToomas Soome /* 1292a1bf3f78SToomas Soome * move HERE past string so it doesn't get overwritten. --lch 1293a1bf3f78SToomas Soome */ 1294a1bf3f78SToomas Soome ficlVmDictionaryAllot(vm, dictionary, 1295a1bf3f78SToomas Soome counted->length + sizeof (ficlUnsigned8)); 1296a1bf3f78SToomas Soome } else { /* FICL_VM_STATE_COMPILE state */ 1297a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1298a1bf3f78SToomas Soome ficlInstructionCStringLiteralParen); 1299a1bf3f78SToomas Soome dictionary->here = 1300a1bf3f78SToomas Soome FICL_POINTER_TO_CELL(ficlVmGetString(vm, 1301a1bf3f78SToomas Soome (ficlCountedString *)dictionary->here, '\"')); 1302a1bf3f78SToomas Soome ficlDictionaryAlign(dictionary); 1303a1bf3f78SToomas Soome } 1304a1bf3f78SToomas Soome } 1305a1bf3f78SToomas Soome 1306a1bf3f78SToomas Soome /* 1307a1bf3f78SToomas Soome * d o t Q u o t e 1308a1bf3f78SToomas Soome * IMMEDIATE word that compiles a string literal for later display 1309a1bf3f78SToomas Soome * FICL_VM_STATE_COMPILE fiStringLiteralParen, then copy the bytes of the 1310a1bf3f78SToomas Soome * string from the 1311a1bf3f78SToomas Soome * TIB to the dictionary. Backpatch the count byte and align the dictionary. 1312a1bf3f78SToomas Soome */ 1313a1bf3f78SToomas Soome static void 1314a1bf3f78SToomas Soome ficlPrimitiveDotQuoteCoIm(ficlVm *vm) 1315a1bf3f78SToomas Soome { 1316a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1317a1bf3f78SToomas Soome ficlWord *pType = ficlSystemLookup(vm->callback.system, "type"); 1318a1bf3f78SToomas Soome ficlCell c; 1319a1bf3f78SToomas Soome 1320a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, pType); 1321a1bf3f78SToomas Soome 1322a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1323a1bf3f78SToomas Soome ficlInstructionStringLiteralParen); 1324a1bf3f78SToomas Soome dictionary->here = 1325a1bf3f78SToomas Soome FICL_POINTER_TO_CELL(ficlVmGetString(vm, 1326a1bf3f78SToomas Soome (ficlCountedString *)dictionary->here, '\"')); 1327a1bf3f78SToomas Soome ficlDictionaryAlign(dictionary); 1328a1bf3f78SToomas Soome c.p = pType; 1329a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, c); 1330a1bf3f78SToomas Soome } 1331a1bf3f78SToomas Soome 1332a1bf3f78SToomas Soome static void 1333a1bf3f78SToomas Soome ficlPrimitiveDotParen(ficlVm *vm) 1334a1bf3f78SToomas Soome { 1335a1bf3f78SToomas Soome char *from = ficlVmGetInBuf(vm); 1336a1bf3f78SToomas Soome char *stop = ficlVmGetInBufEnd(vm); 1337a1bf3f78SToomas Soome char *to = vm->pad; 1338a1bf3f78SToomas Soome char c; 1339a1bf3f78SToomas Soome 1340a1bf3f78SToomas Soome /* 1341a1bf3f78SToomas Soome * Note: the standard does not want leading spaces skipped. 1342a1bf3f78SToomas Soome */ 1343a1bf3f78SToomas Soome for (c = *from; (from != stop) && (c != ')'); c = *++from) 1344a1bf3f78SToomas Soome *to++ = c; 1345a1bf3f78SToomas Soome 1346a1bf3f78SToomas Soome *to = '\0'; 1347a1bf3f78SToomas Soome if ((from != stop) && (c == ')')) 1348a1bf3f78SToomas Soome from++; 1349a1bf3f78SToomas Soome 1350a1bf3f78SToomas Soome ficlVmTextOut(vm, vm->pad); 1351a1bf3f78SToomas Soome ficlVmUpdateTib(vm, from); 1352a1bf3f78SToomas Soome } 1353a1bf3f78SToomas Soome 1354a1bf3f78SToomas Soome /* 1355a1bf3f78SToomas Soome * s l i t e r a l 1356a1bf3f78SToomas Soome * STRING 1357a1bf3f78SToomas Soome * Interpretation: Interpretation semantics for this word are undefined. 1358a1bf3f78SToomas Soome * Compilation: ( c-addr1 u -- ) 1359a1bf3f78SToomas Soome * Append the run-time semantics given below to the current definition. 1360a1bf3f78SToomas Soome * Run-time: ( -- c-addr2 u ) 1361a1bf3f78SToomas Soome * Return c-addr2 u describing a string consisting of the characters 1362a1bf3f78SToomas Soome * specified by c-addr1 u during compilation. A program shall not alter 1363a1bf3f78SToomas Soome * the returned string. 1364a1bf3f78SToomas Soome */ 1365a1bf3f78SToomas Soome static void ficlPrimitiveSLiteralCoIm(ficlVm *vm) 1366a1bf3f78SToomas Soome { 1367a1bf3f78SToomas Soome ficlDictionary *dictionary; 1368a1bf3f78SToomas Soome char *from; 1369a1bf3f78SToomas Soome char *to; 1370a1bf3f78SToomas Soome ficlUnsigned length; 1371a1bf3f78SToomas Soome 1372a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0); 1373a1bf3f78SToomas Soome 1374a1bf3f78SToomas Soome dictionary = ficlVmGetDictionary(vm); 1375a1bf3f78SToomas Soome length = ficlStackPopUnsigned(vm->dataStack); 1376a1bf3f78SToomas Soome from = ficlStackPopPointer(vm->dataStack); 1377a1bf3f78SToomas Soome 1378a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1379a1bf3f78SToomas Soome ficlInstructionStringLiteralParen); 1380a1bf3f78SToomas Soome to = (char *)dictionary->here; 1381a1bf3f78SToomas Soome *to++ = (char)length; 1382a1bf3f78SToomas Soome 1383a1bf3f78SToomas Soome for (; length > 0; --length) { 1384a1bf3f78SToomas Soome *to++ = *from++; 1385a1bf3f78SToomas Soome } 1386a1bf3f78SToomas Soome 1387a1bf3f78SToomas Soome *to++ = 0; 1388a1bf3f78SToomas Soome dictionary->here = FICL_POINTER_TO_CELL(ficlAlignPointer(to)); 1389a1bf3f78SToomas Soome } 1390a1bf3f78SToomas Soome 1391a1bf3f78SToomas Soome /* 1392a1bf3f78SToomas Soome * s t a t e 1393a1bf3f78SToomas Soome * Return the address of the VM's state member (must be sized the 1394a1bf3f78SToomas Soome * same as a ficlCell for this reason) 1395a1bf3f78SToomas Soome */ 1396a1bf3f78SToomas Soome static void ficlPrimitiveState(ficlVm *vm) 1397a1bf3f78SToomas Soome { 1398a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 1399a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, &vm->state); 1400a1bf3f78SToomas Soome } 1401a1bf3f78SToomas Soome 1402a1bf3f78SToomas Soome /* 1403a1bf3f78SToomas Soome * c r e a t e . . . d o e s > 1404a1bf3f78SToomas Soome * Make a new word in the dictionary with the run-time effect of 1405a1bf3f78SToomas Soome * a variable (push my address), but with extra space allotted 1406a1bf3f78SToomas Soome * for use by does> . 1407a1bf3f78SToomas Soome */ 1408a1bf3f78SToomas Soome static void 1409a1bf3f78SToomas Soome ficlPrimitiveCreate(ficlVm *vm) 1410a1bf3f78SToomas Soome { 1411a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1412a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 1413a1bf3f78SToomas Soome 1414a1bf3f78SToomas Soome ficlDictionaryAppendWord(dictionary, name, 1415a1bf3f78SToomas Soome (ficlPrimitive)ficlInstructionCreateParen, FICL_WORD_DEFAULT); 1416a1bf3f78SToomas Soome ficlVmDictionaryAllotCells(vm, dictionary, 1); 1417a1bf3f78SToomas Soome } 1418a1bf3f78SToomas Soome 1419a1bf3f78SToomas Soome static void 1420a1bf3f78SToomas Soome ficlPrimitiveDoesCoIm(ficlVm *vm) 1421a1bf3f78SToomas Soome { 1422a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1423a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 1424a1bf3f78SToomas Soome if (vm->callback.system->localsCount > 0) { 1425a1bf3f78SToomas Soome ficlDictionary *locals = 1426a1bf3f78SToomas Soome ficlSystemGetLocals(vm->callback.system); 1427a1bf3f78SToomas Soome ficlDictionaryEmpty(locals, locals->forthWordlist->size); 1428a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1429a1bf3f78SToomas Soome ficlInstructionUnlinkParen); 1430a1bf3f78SToomas Soome } 1431a1bf3f78SToomas Soome 1432a1bf3f78SToomas Soome vm->callback.system->localsCount = 0; 1433a1bf3f78SToomas Soome #endif 1434a1bf3f78SToomas Soome FICL_IGNORE(vm); 1435a1bf3f78SToomas Soome 1436a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionDoesParen); 1437a1bf3f78SToomas Soome } 1438a1bf3f78SToomas Soome 1439a1bf3f78SToomas Soome /* 1440a1bf3f78SToomas Soome * t o b o d y 1441a1bf3f78SToomas Soome * to-body CORE ( xt -- a-addr ) 1442a1bf3f78SToomas Soome * a-addr is the data-field address corresponding to xt. An ambiguous 1443a1bf3f78SToomas Soome * condition exists if xt is not for a word defined via CREATE. 1444a1bf3f78SToomas Soome */ 1445a1bf3f78SToomas Soome static void 1446a1bf3f78SToomas Soome ficlPrimitiveToBody(ficlVm *vm) 1447a1bf3f78SToomas Soome { 1448a1bf3f78SToomas Soome ficlWord *word; 1449a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1); 1450a1bf3f78SToomas Soome 1451a1bf3f78SToomas Soome word = ficlStackPopPointer(vm->dataStack); 1452a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, word->param + 1); 1453a1bf3f78SToomas Soome } 1454a1bf3f78SToomas Soome 1455a1bf3f78SToomas Soome /* 1456a1bf3f78SToomas Soome * from-body Ficl ( a-addr -- xt ) 1457a1bf3f78SToomas Soome * Reverse effect of >body 1458a1bf3f78SToomas Soome */ 1459a1bf3f78SToomas Soome static void 1460a1bf3f78SToomas Soome ficlPrimitiveFromBody(ficlVm *vm) 1461a1bf3f78SToomas Soome { 1462a1bf3f78SToomas Soome char *ptr; 1463a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1); 1464a1bf3f78SToomas Soome 1465a1bf3f78SToomas Soome ptr = (char *)ficlStackPopPointer(vm->dataStack) - sizeof (ficlWord); 1466a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, ptr); 1467a1bf3f78SToomas Soome } 1468a1bf3f78SToomas Soome 1469a1bf3f78SToomas Soome /* 1470a1bf3f78SToomas Soome * >name Ficl ( xt -- c-addr u ) 1471a1bf3f78SToomas Soome * Push the address and length of a word's name given its address 1472a1bf3f78SToomas Soome * xt. 1473a1bf3f78SToomas Soome */ 1474a1bf3f78SToomas Soome static void 1475a1bf3f78SToomas Soome ficlPrimitiveToName(ficlVm *vm) 1476a1bf3f78SToomas Soome { 1477a1bf3f78SToomas Soome ficlWord *word; 1478a1bf3f78SToomas Soome 1479a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2); 1480a1bf3f78SToomas Soome 1481a1bf3f78SToomas Soome word = ficlStackPopPointer(vm->dataStack); 1482a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, word->name); 1483a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, word->length); 1484a1bf3f78SToomas Soome } 1485a1bf3f78SToomas Soome 1486a1bf3f78SToomas Soome static void 1487a1bf3f78SToomas Soome ficlPrimitiveLastWord(ficlVm *vm) 1488a1bf3f78SToomas Soome { 1489a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1490a1bf3f78SToomas Soome ficlWord *wp = dictionary->smudge; 1491a1bf3f78SToomas Soome ficlCell c; 1492a1bf3f78SToomas Soome 1493a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, wp); 1494a1bf3f78SToomas Soome 1495a1bf3f78SToomas Soome c.p = wp; 1496a1bf3f78SToomas Soome ficlVmPush(vm, c); 1497a1bf3f78SToomas Soome } 1498a1bf3f78SToomas Soome 1499a1bf3f78SToomas Soome /* 1500a1bf3f78SToomas Soome * l b r a c k e t e t c 1501a1bf3f78SToomas Soome */ 1502a1bf3f78SToomas Soome static void 1503a1bf3f78SToomas Soome ficlPrimitiveLeftBracketCoIm(ficlVm *vm) 1504a1bf3f78SToomas Soome { 1505a1bf3f78SToomas Soome vm->state = FICL_VM_STATE_INTERPRET; 1506a1bf3f78SToomas Soome } 1507a1bf3f78SToomas Soome 1508a1bf3f78SToomas Soome static void 1509a1bf3f78SToomas Soome ficlPrimitiveRightBracket(ficlVm *vm) 1510a1bf3f78SToomas Soome { 1511a1bf3f78SToomas Soome vm->state = FICL_VM_STATE_COMPILE; 1512a1bf3f78SToomas Soome } 1513a1bf3f78SToomas Soome 1514a1bf3f78SToomas Soome /* 1515a1bf3f78SToomas Soome * p i c t u r e d n u m e r i c w o r d s 1516a1bf3f78SToomas Soome * 1517a1bf3f78SToomas Soome * less-number-sign CORE ( -- ) 1518a1bf3f78SToomas Soome * Initialize the pictured numeric output conversion process. 1519a1bf3f78SToomas Soome * (clear the pad) 1520a1bf3f78SToomas Soome */ 1521a1bf3f78SToomas Soome static void 1522a1bf3f78SToomas Soome ficlPrimitiveLessNumberSign(ficlVm *vm) 1523a1bf3f78SToomas Soome { 1524a1bf3f78SToomas Soome ficlCountedString *counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); 1525a1bf3f78SToomas Soome counted->length = 0; 1526a1bf3f78SToomas Soome } 1527a1bf3f78SToomas Soome 1528a1bf3f78SToomas Soome /* 1529a1bf3f78SToomas Soome * number-sign CORE ( ud1 -- ud2 ) 1530a1bf3f78SToomas Soome * Divide ud1 by the number in BASE giving the quotient ud2 and the remainder 1531a1bf3f78SToomas Soome * n. (n is the least-significant digit of ud1.) Convert n to external form 1532a1bf3f78SToomas Soome * and add the resulting character to the beginning of the pictured numeric 1533a1bf3f78SToomas Soome * output string. An ambiguous condition exists if # executes outside of a 1534a1bf3f78SToomas Soome * <# #> delimited number conversion. 1535a1bf3f78SToomas Soome */ 1536a1bf3f78SToomas Soome static void 1537a1bf3f78SToomas Soome ficlPrimitiveNumberSign(ficlVm *vm) 1538a1bf3f78SToomas Soome { 1539a1bf3f78SToomas Soome ficlCountedString *counted; 1540a1bf3f78SToomas Soome ficl2Unsigned u; 1541a1bf3f78SToomas Soome ficl2UnsignedQR uqr; 1542a1bf3f78SToomas Soome 1543a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2); 1544a1bf3f78SToomas Soome 1545a1bf3f78SToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); 1546a1bf3f78SToomas Soome u = ficlStackPop2Unsigned(vm->dataStack); 1547a1bf3f78SToomas Soome uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base)); 1548a1bf3f78SToomas Soome counted->text[counted->length++] = ficlDigitToCharacter(uqr.remainder); 1549a1bf3f78SToomas Soome ficlStackPush2Unsigned(vm->dataStack, uqr.quotient); 1550a1bf3f78SToomas Soome } 1551a1bf3f78SToomas Soome 1552a1bf3f78SToomas Soome /* 1553a1bf3f78SToomas Soome * number-sign-greater CORE ( xd -- c-addr u ) 1554a1bf3f78SToomas Soome * Drop xd. Make the pictured numeric output string available as a character 1555a1bf3f78SToomas Soome * string. c-addr and u specify the resulting character string. A program 1556a1bf3f78SToomas Soome * may replace characters within the string. 1557a1bf3f78SToomas Soome */ 1558a1bf3f78SToomas Soome static void 1559a1bf3f78SToomas Soome ficlPrimitiveNumberSignGreater(ficlVm *vm) 1560a1bf3f78SToomas Soome { 1561a1bf3f78SToomas Soome ficlCountedString *counted; 1562a1bf3f78SToomas Soome 1563a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2); 1564a1bf3f78SToomas Soome 1565a1bf3f78SToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); 1566a1bf3f78SToomas Soome counted->text[counted->length] = 0; 1567a1bf3f78SToomas Soome ficlStringReverse(counted->text); 1568a1bf3f78SToomas Soome ficlStackDrop(vm->dataStack, 2); 1569a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, counted->text); 1570a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, counted->length); 1571a1bf3f78SToomas Soome } 1572a1bf3f78SToomas Soome 1573a1bf3f78SToomas Soome /* 1574a1bf3f78SToomas Soome * number-sign-s CORE ( ud1 -- ud2 ) 1575a1bf3f78SToomas Soome * Convert one digit of ud1 according to the rule for #. Continue conversion 1576a1bf3f78SToomas Soome * until the quotient is zero. ud2 is zero. An ambiguous condition exists if 1577a1bf3f78SToomas Soome * #S executes outside of a <# #> delimited number conversion. 1578a1bf3f78SToomas Soome * TO DO: presently does not use ud1 hi ficlCell - use it! 1579a1bf3f78SToomas Soome */ 1580a1bf3f78SToomas Soome static void 1581a1bf3f78SToomas Soome ficlPrimitiveNumberSignS(ficlVm *vm) 1582a1bf3f78SToomas Soome { 1583a1bf3f78SToomas Soome ficlCountedString *counted; 1584a1bf3f78SToomas Soome ficl2Unsigned u; 1585a1bf3f78SToomas Soome ficl2UnsignedQR uqr; 1586a1bf3f78SToomas Soome 1587a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2); 1588a1bf3f78SToomas Soome 1589a1bf3f78SToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); 1590a1bf3f78SToomas Soome u = ficlStackPop2Unsigned(vm->dataStack); 1591a1bf3f78SToomas Soome 1592a1bf3f78SToomas Soome do { 1593a1bf3f78SToomas Soome uqr = ficl2UnsignedDivide(u, (ficlUnsigned16)(vm->base)); 1594a1bf3f78SToomas Soome counted->text[counted->length++] = 1595a1bf3f78SToomas Soome ficlDigitToCharacter(uqr.remainder); 1596a1bf3f78SToomas Soome u = uqr.quotient; 1597a1bf3f78SToomas Soome } while (FICL_2UNSIGNED_NOT_ZERO(u)); 1598a1bf3f78SToomas Soome 1599a1bf3f78SToomas Soome ficlStackPush2Unsigned(vm->dataStack, u); 1600a1bf3f78SToomas Soome } 1601a1bf3f78SToomas Soome 1602a1bf3f78SToomas Soome /* 1603a1bf3f78SToomas Soome * HOLD CORE ( char -- ) 1604a1bf3f78SToomas Soome * Add char to the beginning of the pictured numeric output string. 1605a1bf3f78SToomas Soome * An ambiguous condition exists if HOLD executes outside of a <# #> 1606a1bf3f78SToomas Soome * delimited number conversion. 1607a1bf3f78SToomas Soome */ 1608a1bf3f78SToomas Soome static void 1609a1bf3f78SToomas Soome ficlPrimitiveHold(ficlVm *vm) 1610a1bf3f78SToomas Soome { 1611a1bf3f78SToomas Soome ficlCountedString *counted; 1612a1bf3f78SToomas Soome int i; 1613a1bf3f78SToomas Soome 1614a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 1615a1bf3f78SToomas Soome 1616a1bf3f78SToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); 1617a1bf3f78SToomas Soome i = ficlStackPopInteger(vm->dataStack); 1618a1bf3f78SToomas Soome counted->text[counted->length++] = (char)i; 1619a1bf3f78SToomas Soome } 1620a1bf3f78SToomas Soome 1621a1bf3f78SToomas Soome /* 1622a1bf3f78SToomas Soome * SIGN CORE ( n -- ) 1623a1bf3f78SToomas Soome * If n is negative, add a minus sign to the beginning of the pictured 1624a1bf3f78SToomas Soome * numeric output string. An ambiguous condition exists if SIGN 1625a1bf3f78SToomas Soome * executes outside of a <# #> delimited number conversion. 1626a1bf3f78SToomas Soome */ 1627a1bf3f78SToomas Soome static void 1628a1bf3f78SToomas Soome ficlPrimitiveSign(ficlVm *vm) 1629a1bf3f78SToomas Soome { 1630a1bf3f78SToomas Soome ficlCountedString *counted; 1631a1bf3f78SToomas Soome int i; 1632a1bf3f78SToomas Soome 1633a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 1634a1bf3f78SToomas Soome 1635a1bf3f78SToomas Soome counted = FICL_POINTER_TO_COUNTED_STRING(vm->pad); 1636a1bf3f78SToomas Soome i = ficlStackPopInteger(vm->dataStack); 1637a1bf3f78SToomas Soome if (i < 0) 1638a1bf3f78SToomas Soome counted->text[counted->length++] = '-'; 1639a1bf3f78SToomas Soome } 1640a1bf3f78SToomas Soome 1641a1bf3f78SToomas Soome /* 1642a1bf3f78SToomas Soome * t o N u m b e r 1643a1bf3f78SToomas Soome * to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 1644a1bf3f78SToomas Soome * ud2 is the unsigned result of converting the characters within the 1645a1bf3f78SToomas Soome * string specified by c-addr1 u1 into digits, using the number in BASE, 1646a1bf3f78SToomas Soome * and adding each into ud1 after multiplying ud1 by the number in BASE. 1647a1bf3f78SToomas Soome * Conversion continues left-to-right until a character that is not 1648a1bf3f78SToomas Soome * convertible, including any + or -, is encountered or the string is 1649a1bf3f78SToomas Soome * entirely converted. c-addr2 is the location of the first unconverted 1650a1bf3f78SToomas Soome * character or the first character past the end of the string if the string 1651a1bf3f78SToomas Soome * was entirely converted. u2 is the number of unconverted characters in the 1652a1bf3f78SToomas Soome * string. An ambiguous condition exists if ud2 overflows during the 1653a1bf3f78SToomas Soome * conversion. 1654a1bf3f78SToomas Soome */ 1655a1bf3f78SToomas Soome static void 1656a1bf3f78SToomas Soome ficlPrimitiveToNumber(ficlVm *vm) 1657a1bf3f78SToomas Soome { 1658a1bf3f78SToomas Soome ficlUnsigned length; 1659a1bf3f78SToomas Soome char *trace; 1660a1bf3f78SToomas Soome ficl2Unsigned accumulator; 1661a1bf3f78SToomas Soome ficlUnsigned base = vm->base; 1662a1bf3f78SToomas Soome ficlUnsigned c; 1663a1bf3f78SToomas Soome ficlUnsigned digit; 1664a1bf3f78SToomas Soome 1665a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 4, 4); 1666a1bf3f78SToomas Soome 1667a1bf3f78SToomas Soome length = ficlStackPopUnsigned(vm->dataStack); 1668a1bf3f78SToomas Soome trace = (char *)ficlStackPopPointer(vm->dataStack); 1669a1bf3f78SToomas Soome accumulator = ficlStackPop2Unsigned(vm->dataStack); 1670a1bf3f78SToomas Soome 1671a1bf3f78SToomas Soome for (c = *trace; length > 0; c = *++trace, length--) { 1672a1bf3f78SToomas Soome if (c < '0') 1673a1bf3f78SToomas Soome break; 1674a1bf3f78SToomas Soome 1675a1bf3f78SToomas Soome digit = c - '0'; 1676a1bf3f78SToomas Soome 1677a1bf3f78SToomas Soome if (digit > 9) 1678a1bf3f78SToomas Soome digit = tolower(c) - 'a' + 10; 1679a1bf3f78SToomas Soome /* 1680a1bf3f78SToomas Soome * Note: following test also catches chars between 9 and a 1681a1bf3f78SToomas Soome * because 'digit' is unsigned! 1682a1bf3f78SToomas Soome */ 1683a1bf3f78SToomas Soome if (digit >= base) 1684a1bf3f78SToomas Soome break; 1685a1bf3f78SToomas Soome 1686a1bf3f78SToomas Soome accumulator = ficl2UnsignedMultiplyAccumulate(accumulator, 1687a1bf3f78SToomas Soome base, digit); 1688a1bf3f78SToomas Soome } 1689a1bf3f78SToomas Soome 1690a1bf3f78SToomas Soome ficlStackPush2Unsigned(vm->dataStack, accumulator); 1691a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, trace); 1692a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, length); 1693a1bf3f78SToomas Soome } 1694a1bf3f78SToomas Soome 1695a1bf3f78SToomas Soome /* 1696a1bf3f78SToomas Soome * q u i t & a b o r t 1697a1bf3f78SToomas Soome * quit CORE ( -- ) ( R: i*x -- ) 1698a1bf3f78SToomas Soome * Empty the return stack, store zero in SOURCE-ID if it is present, make 1699a1bf3f78SToomas Soome * the user input device the input source, and enter interpretation state. 1700a1bf3f78SToomas Soome * Do not display a message. Repeat the following: 1701a1bf3f78SToomas Soome * 1702a1bf3f78SToomas Soome * Accept a line from the input source into the input buffer, set >IN to 1703a1bf3f78SToomas Soome * zero, and FICL_VM_STATE_INTERPRET. 1704a1bf3f78SToomas Soome * Display the implementation-defined system prompt if in 1705a1bf3f78SToomas Soome * interpretation state, all processing has been completed, and no 1706a1bf3f78SToomas Soome * ambiguous condition exists. 1707a1bf3f78SToomas Soome */ 1708a1bf3f78SToomas Soome static void 1709a1bf3f78SToomas Soome ficlPrimitiveQuit(ficlVm *vm) 1710a1bf3f78SToomas Soome { 1711a1bf3f78SToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_QUIT); 1712a1bf3f78SToomas Soome } 1713a1bf3f78SToomas Soome 1714a1bf3f78SToomas Soome static void 1715a1bf3f78SToomas Soome ficlPrimitiveAbort(ficlVm *vm) 1716a1bf3f78SToomas Soome { 1717a1bf3f78SToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_ABORT); 1718a1bf3f78SToomas Soome } 1719a1bf3f78SToomas Soome 1720a1bf3f78SToomas Soome /* 1721a1bf3f78SToomas Soome * a c c e p t 1722a1bf3f78SToomas Soome * accept CORE ( c-addr +n1 -- +n2 ) 1723a1bf3f78SToomas Soome * Receive a string of at most +n1 characters. An ambiguous condition 1724a1bf3f78SToomas Soome * exists if +n1 is zero or greater than 32,767. Display graphic characters 1725a1bf3f78SToomas Soome * as they are received. A program that depends on the presence or absence 1726a1bf3f78SToomas Soome * of non-graphic characters in the string has an environmental dependency. 1727a1bf3f78SToomas Soome * The editing functions, if any, that the system performs in order to 1728a1bf3f78SToomas Soome * construct the string are implementation-defined. 1729a1bf3f78SToomas Soome * 1730a1bf3f78SToomas Soome * (Although the standard text doesn't say so, I assume that the intent 1731a1bf3f78SToomas Soome * of 'accept' is to store the string at the address specified on 1732a1bf3f78SToomas Soome * the stack.) 1733a1bf3f78SToomas Soome * 1734a1bf3f78SToomas Soome * NOTE: getchar() is used there as its present both in loader and 1735a1bf3f78SToomas Soome * userland; however, the more correct solution would be to set 1736a1bf3f78SToomas Soome * terminal to raw mode for userland. 1737a1bf3f78SToomas Soome */ 1738a1bf3f78SToomas Soome static void 1739a1bf3f78SToomas Soome ficlPrimitiveAccept(ficlVm *vm) 1740a1bf3f78SToomas Soome { 1741a1bf3f78SToomas Soome ficlUnsigned size; 1742a1bf3f78SToomas Soome char *address; 1743a1bf3f78SToomas Soome int c; 1744a1bf3f78SToomas Soome ficlUnsigned length = 0; 1745a1bf3f78SToomas Soome 1746a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 1); 1747a1bf3f78SToomas Soome 1748a1bf3f78SToomas Soome size = ficlStackPopInteger(vm->dataStack); 1749a1bf3f78SToomas Soome address = ficlStackPopPointer(vm->dataStack); 1750a1bf3f78SToomas Soome 1751a1bf3f78SToomas Soome while (size != length) { 1752a1bf3f78SToomas Soome c = getchar(); 1753a1bf3f78SToomas Soome if (c == '\n' || c == '\r') 1754a1bf3f78SToomas Soome break; 1755a1bf3f78SToomas Soome address[length++] = c; 1756a1bf3f78SToomas Soome } 1757a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, length); 1758a1bf3f78SToomas Soome } 1759a1bf3f78SToomas Soome 1760a1bf3f78SToomas Soome /* 1761a1bf3f78SToomas Soome * a l i g n 1762a1bf3f78SToomas Soome * 6.1.0705 ALIGN CORE ( -- ) 1763a1bf3f78SToomas Soome * If the data-space pointer is not aligned, reserve enough space to 1764a1bf3f78SToomas Soome * align it. 1765a1bf3f78SToomas Soome */ 1766a1bf3f78SToomas Soome static void 1767a1bf3f78SToomas Soome ficlPrimitiveAlign(ficlVm *vm) 1768a1bf3f78SToomas Soome { 1769a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1770a1bf3f78SToomas Soome FICL_IGNORE(vm); 1771a1bf3f78SToomas Soome ficlDictionaryAlign(dictionary); 1772a1bf3f78SToomas Soome } 1773a1bf3f78SToomas Soome 1774a1bf3f78SToomas Soome /* 1775a1bf3f78SToomas Soome * a l i g n e d 1776a1bf3f78SToomas Soome */ 1777a1bf3f78SToomas Soome static void 1778a1bf3f78SToomas Soome ficlPrimitiveAligned(ficlVm *vm) 1779a1bf3f78SToomas Soome { 1780a1bf3f78SToomas Soome void *addr; 1781a1bf3f78SToomas Soome 1782a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1); 1783a1bf3f78SToomas Soome 1784a1bf3f78SToomas Soome addr = ficlStackPopPointer(vm->dataStack); 1785a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, ficlAlignPointer(addr)); 1786a1bf3f78SToomas Soome } 1787a1bf3f78SToomas Soome 1788a1bf3f78SToomas Soome /* 1789a1bf3f78SToomas Soome * b e g i n & f r i e n d s 1790a1bf3f78SToomas Soome * Indefinite loop control structures 1791a1bf3f78SToomas Soome * A.6.1.0760 BEGIN 1792a1bf3f78SToomas Soome * Typical use: 1793a1bf3f78SToomas Soome * : X ... BEGIN ... test UNTIL ; 1794a1bf3f78SToomas Soome * or 1795a1bf3f78SToomas Soome * : X ... BEGIN ... test WHILE ... REPEAT ; 1796a1bf3f78SToomas Soome */ 1797a1bf3f78SToomas Soome static void 1798a1bf3f78SToomas Soome ficlPrimitiveBeginCoIm(ficlVm *vm) 1799a1bf3f78SToomas Soome { 1800a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1801a1bf3f78SToomas Soome markBranch(dictionary, vm, destTag); 1802a1bf3f78SToomas Soome } 1803a1bf3f78SToomas Soome 1804a1bf3f78SToomas Soome static void 1805a1bf3f78SToomas Soome ficlPrimitiveUntilCoIm(ficlVm *vm) 1806a1bf3f78SToomas Soome { 1807a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1808a1bf3f78SToomas Soome 1809a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1810a1bf3f78SToomas Soome ficlInstructionBranch0ParenWithCheck); 1811a1bf3f78SToomas Soome resolveBackBranch(dictionary, vm, destTag); 1812a1bf3f78SToomas Soome } 1813a1bf3f78SToomas Soome 1814a1bf3f78SToomas Soome static void 1815a1bf3f78SToomas Soome ficlPrimitiveWhileCoIm(ficlVm *vm) 1816a1bf3f78SToomas Soome { 1817a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1818a1bf3f78SToomas Soome 1819a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 5); 1820a1bf3f78SToomas Soome 1821a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1822a1bf3f78SToomas Soome ficlInstructionBranch0ParenWithCheck); 1823a1bf3f78SToomas Soome markBranch(dictionary, vm, origTag); 1824a1bf3f78SToomas Soome 1825a1bf3f78SToomas Soome /* equivalent to 2swap */ 1826a1bf3f78SToomas Soome ficlStackRoll(vm->dataStack, 3); 1827a1bf3f78SToomas Soome ficlStackRoll(vm->dataStack, 3); 1828a1bf3f78SToomas Soome 1829a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1); 1830a1bf3f78SToomas Soome } 1831a1bf3f78SToomas Soome 1832a1bf3f78SToomas Soome static void 1833a1bf3f78SToomas Soome ficlPrimitiveRepeatCoIm(ficlVm *vm) 1834a1bf3f78SToomas Soome { 1835a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1836a1bf3f78SToomas Soome 1837a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1838a1bf3f78SToomas Soome ficlInstructionBranchParenWithCheck); 1839a1bf3f78SToomas Soome /* expect "begin" branch marker */ 1840a1bf3f78SToomas Soome resolveBackBranch(dictionary, vm, destTag); 1841a1bf3f78SToomas Soome /* expect "while" branch marker */ 1842a1bf3f78SToomas Soome resolveForwardBranch(dictionary, vm, origTag); 1843a1bf3f78SToomas Soome } 1844a1bf3f78SToomas Soome 1845a1bf3f78SToomas Soome static void 1846a1bf3f78SToomas Soome ficlPrimitiveAgainCoIm(ficlVm *vm) 1847a1bf3f78SToomas Soome { 1848a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 1849a1bf3f78SToomas Soome 1850a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 1851a1bf3f78SToomas Soome ficlInstructionBranchParenWithCheck); 1852a1bf3f78SToomas Soome /* expect "begin" branch marker */ 1853a1bf3f78SToomas Soome resolveBackBranch(dictionary, vm, destTag); 1854a1bf3f78SToomas Soome } 1855a1bf3f78SToomas Soome 1856a1bf3f78SToomas Soome /* 1857a1bf3f78SToomas Soome * c h a r & f r i e n d s 1858a1bf3f78SToomas Soome * 6.1.0895 CHAR CORE ( "<spaces>name" -- char ) 1859a1bf3f78SToomas Soome * Skip leading space delimiters. Parse name delimited by a space. 1860a1bf3f78SToomas Soome * Put the value of its first character onto the stack. 1861a1bf3f78SToomas Soome * 1862a1bf3f78SToomas Soome * bracket-char CORE 1863a1bf3f78SToomas Soome * Interpretation: Interpretation semantics for this word are undefined. 1864a1bf3f78SToomas Soome * Compilation: ( "<spaces>name" -- ) 1865a1bf3f78SToomas Soome * Skip leading space delimiters. Parse name delimited by a space. 1866a1bf3f78SToomas Soome * Append the run-time semantics given below to the current definition. 1867a1bf3f78SToomas Soome * Run-time: ( -- char ) 1868a1bf3f78SToomas Soome * Place char, the value of the first character of name, on the stack. 1869a1bf3f78SToomas Soome */ 1870a1bf3f78SToomas Soome static void 1871a1bf3f78SToomas Soome ficlPrimitiveChar(ficlVm *vm) 1872a1bf3f78SToomas Soome { 1873a1bf3f78SToomas Soome ficlString s; 1874a1bf3f78SToomas Soome 1875a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 1876a1bf3f78SToomas Soome 1877a1bf3f78SToomas Soome s = ficlVmGetWord(vm); 1878a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, (ficlUnsigned)(s.text[0])); 1879a1bf3f78SToomas Soome } 1880a1bf3f78SToomas Soome 1881a1bf3f78SToomas Soome static void 1882a1bf3f78SToomas Soome ficlPrimitiveCharCoIm(ficlVm *vm) 1883a1bf3f78SToomas Soome { 1884a1bf3f78SToomas Soome ficlPrimitiveChar(vm); 1885a1bf3f78SToomas Soome ficlPrimitiveLiteralIm(vm); 1886a1bf3f78SToomas Soome } 1887a1bf3f78SToomas Soome 1888a1bf3f78SToomas Soome /* 1889a1bf3f78SToomas Soome * c h a r P l u s 1890a1bf3f78SToomas Soome * char-plus CORE ( c-addr1 -- c-addr2 ) 1891a1bf3f78SToomas Soome * Add the size in address units of a character to c-addr1, giving c-addr2. 1892a1bf3f78SToomas Soome */ 1893a1bf3f78SToomas Soome static void 1894a1bf3f78SToomas Soome ficlPrimitiveCharPlus(ficlVm *vm) 1895a1bf3f78SToomas Soome { 1896a1bf3f78SToomas Soome char *p; 1897a1bf3f78SToomas Soome 1898a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1); 1899a1bf3f78SToomas Soome 1900a1bf3f78SToomas Soome p = ficlStackPopPointer(vm->dataStack); 1901a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, p + 1); 1902a1bf3f78SToomas Soome } 1903a1bf3f78SToomas Soome 1904a1bf3f78SToomas Soome /* 1905a1bf3f78SToomas Soome * c h a r s 1906a1bf3f78SToomas Soome * chars CORE ( n1 -- n2 ) 1907a1bf3f78SToomas Soome * n2 is the size in address units of n1 characters. 1908a1bf3f78SToomas Soome * For most processors, this function can be a no-op. To guarantee 1909a1bf3f78SToomas Soome * portability, we'll multiply by sizeof (char). 1910a1bf3f78SToomas Soome */ 1911a1bf3f78SToomas Soome #if defined(_M_IX86) 1912a1bf3f78SToomas Soome #pragma warning(disable: 4127) 1913a1bf3f78SToomas Soome #endif 1914a1bf3f78SToomas Soome static void 1915a1bf3f78SToomas Soome ficlPrimitiveChars(ficlVm *vm) 1916a1bf3f78SToomas Soome { 1917a1bf3f78SToomas Soome if (sizeof (char) > 1) { 1918a1bf3f78SToomas Soome ficlInteger i; 1919a1bf3f78SToomas Soome 1920a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1); 1921a1bf3f78SToomas Soome 1922a1bf3f78SToomas Soome i = ficlStackPopInteger(vm->dataStack); 1923a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, i * sizeof (char)); 1924a1bf3f78SToomas Soome } 1925a1bf3f78SToomas Soome /* otherwise no-op! */ 1926a1bf3f78SToomas Soome } 1927a1bf3f78SToomas Soome #if defined(_M_IX86) 1928a1bf3f78SToomas Soome #pragma warning(default: 4127) 1929a1bf3f78SToomas Soome #endif 1930a1bf3f78SToomas Soome 1931a1bf3f78SToomas Soome /* 1932a1bf3f78SToomas Soome * c o u n t 1933a1bf3f78SToomas Soome * COUNT CORE ( c-addr1 -- c-addr2 u ) 1934a1bf3f78SToomas Soome * Return the character string specification for the counted string stored 1935a1bf3f78SToomas Soome * at c-addr1. c-addr2 is the address of the first character after c-addr1. 1936a1bf3f78SToomas Soome * u is the contents of the character at c-addr1, which is the length in 1937a1bf3f78SToomas Soome * characters of the string at c-addr2. 1938a1bf3f78SToomas Soome */ 1939a1bf3f78SToomas Soome static void 1940a1bf3f78SToomas Soome ficlPrimitiveCount(ficlVm *vm) 1941a1bf3f78SToomas Soome { 1942a1bf3f78SToomas Soome ficlCountedString *counted; 1943a1bf3f78SToomas Soome 1944a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2); 1945a1bf3f78SToomas Soome 1946a1bf3f78SToomas Soome counted = ficlStackPopPointer(vm->dataStack); 1947a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, counted->text); 1948a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, counted->length); 1949a1bf3f78SToomas Soome } 1950a1bf3f78SToomas Soome 1951a1bf3f78SToomas Soome /* 1952a1bf3f78SToomas Soome * e n v i r o n m e n t ? 1953a1bf3f78SToomas Soome * environment-query CORE ( c-addr u -- FICL_FALSE | i*x FICL_TRUE ) 1954a1bf3f78SToomas Soome * c-addr is the address of a character string and u is the string's 1955a1bf3f78SToomas Soome * character count. u may have a value in the range from zero to an 1956a1bf3f78SToomas Soome * implementation-defined maximum which shall not be less than 31. The 1957a1bf3f78SToomas Soome * character string should contain a keyword from 3.2.6 Environmental 1958a1bf3f78SToomas Soome * queries or the optional word sets to be checked for correspondence 1959a1bf3f78SToomas Soome * with an attribute of the present environment. If the system treats the 1960a1bf3f78SToomas Soome * attribute as unknown, the returned flag is FICL_FALSE; otherwise, the flag 1961a1bf3f78SToomas Soome * is FICL_TRUE and the i*x returned is of the type specified in the table for 1962a1bf3f78SToomas Soome * the attribute queried. 1963a1bf3f78SToomas Soome */ 1964a1bf3f78SToomas Soome static void 1965a1bf3f78SToomas Soome ficlPrimitiveEnvironmentQ(ficlVm *vm) 1966a1bf3f78SToomas Soome { 1967a1bf3f78SToomas Soome ficlDictionary *environment; 1968a1bf3f78SToomas Soome ficlWord *word; 1969a1bf3f78SToomas Soome ficlString name; 1970a1bf3f78SToomas Soome 1971a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 1); 1972a1bf3f78SToomas Soome 1973a1bf3f78SToomas Soome environment = vm->callback.system->environment; 1974a1bf3f78SToomas Soome name.length = ficlStackPopUnsigned(vm->dataStack); 1975a1bf3f78SToomas Soome name.text = ficlStackPopPointer(vm->dataStack); 1976a1bf3f78SToomas Soome 1977a1bf3f78SToomas Soome word = ficlDictionaryLookup(environment, name); 1978a1bf3f78SToomas Soome 1979a1bf3f78SToomas Soome if (word != NULL) { 1980a1bf3f78SToomas Soome ficlVmExecuteWord(vm, word); 1981a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, FICL_TRUE); 1982a1bf3f78SToomas Soome } else { 1983a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, FICL_FALSE); 1984a1bf3f78SToomas Soome } 1985a1bf3f78SToomas Soome } 1986a1bf3f78SToomas Soome 1987a1bf3f78SToomas Soome /* 1988a1bf3f78SToomas Soome * e v a l u a t e 1989a1bf3f78SToomas Soome * EVALUATE CORE ( i*x c-addr u -- j*x ) 1990a1bf3f78SToomas Soome * Save the current input source specification. Store minus-one (-1) in 1991a1bf3f78SToomas Soome * SOURCE-ID if it is present. Make the string described by c-addr and u 1992a1bf3f78SToomas Soome * both the input source and input buffer, set >IN to zero, and 1993a1bf3f78SToomas Soome * FICL_VM_STATE_INTERPRET. 1994a1bf3f78SToomas Soome * When the parse area is empty, restore the prior input source 1995a1bf3f78SToomas Soome * specification. Other stack effects are due to the words EVALUATEd. 1996a1bf3f78SToomas Soome */ 1997a1bf3f78SToomas Soome static void 1998a1bf3f78SToomas Soome ficlPrimitiveEvaluate(ficlVm *vm) 1999a1bf3f78SToomas Soome { 2000a1bf3f78SToomas Soome ficlCell id; 2001a1bf3f78SToomas Soome int result; 2002a1bf3f78SToomas Soome ficlString string; 2003a1bf3f78SToomas Soome 2004a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0); 2005a1bf3f78SToomas Soome 2006a1bf3f78SToomas Soome FICL_STRING_SET_LENGTH(string, ficlStackPopUnsigned(vm->dataStack)); 2007a1bf3f78SToomas Soome FICL_STRING_SET_POINTER(string, ficlStackPopPointer(vm->dataStack)); 2008a1bf3f78SToomas Soome 2009a1bf3f78SToomas Soome id = vm->sourceId; 2010a1bf3f78SToomas Soome vm->sourceId.i = -1; 2011a1bf3f78SToomas Soome result = ficlVmExecuteString(vm, string); 2012a1bf3f78SToomas Soome vm->sourceId = id; 2013a1bf3f78SToomas Soome if (result != FICL_VM_STATUS_OUT_OF_TEXT) 2014a1bf3f78SToomas Soome ficlVmThrow(vm, result); 2015a1bf3f78SToomas Soome } 2016a1bf3f78SToomas Soome 2017a1bf3f78SToomas Soome /* 2018a1bf3f78SToomas Soome * s t r i n g q u o t e 2019a1bf3f78SToomas Soome * Interpreting: get string delimited by a quote from the input stream, 2020a1bf3f78SToomas Soome * copy to a scratch area, and put its count and address on the stack. 2021a1bf3f78SToomas Soome * Compiling: FICL_VM_STATE_COMPILE code to push the address and count 2022a1bf3f78SToomas Soome * of a string literal, FICL_VM_STATE_COMPILE the string from the input 2023a1bf3f78SToomas Soome * stream, and align the dictionary pointer. 2024a1bf3f78SToomas Soome */ 2025a1bf3f78SToomas Soome static void 2026a1bf3f78SToomas Soome ficlPrimitiveStringQuoteIm(ficlVm *vm) 2027a1bf3f78SToomas Soome { 2028a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2029a1bf3f78SToomas Soome 2030a1bf3f78SToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) { 2031a1bf3f78SToomas Soome ficlCountedString *counted; 2032a1bf3f78SToomas Soome counted = (ficlCountedString *)dictionary->here; 2033a1bf3f78SToomas Soome ficlVmGetString(vm, counted, '\"'); 2034a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, counted->text); 2035a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, counted->length); 2036a1bf3f78SToomas Soome } else { /* FICL_VM_STATE_COMPILE state */ 2037a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2038a1bf3f78SToomas Soome ficlInstructionStringLiteralParen); 2039a1bf3f78SToomas Soome dictionary->here = FICL_POINTER_TO_CELL( 2040a1bf3f78SToomas Soome ficlVmGetString(vm, (ficlCountedString *)dictionary->here, 2041a1bf3f78SToomas Soome '\"')); 2042a1bf3f78SToomas Soome ficlDictionaryAlign(dictionary); 2043a1bf3f78SToomas Soome } 2044a1bf3f78SToomas Soome } 2045a1bf3f78SToomas Soome 2046a1bf3f78SToomas Soome /* 2047a1bf3f78SToomas Soome * t y p e 2048a1bf3f78SToomas Soome * Pop count and char address from stack and print the designated string. 2049a1bf3f78SToomas Soome */ 2050a1bf3f78SToomas Soome static void 2051a1bf3f78SToomas Soome ficlPrimitiveType(ficlVm *vm) 2052a1bf3f78SToomas Soome { 2053a1bf3f78SToomas Soome ficlUnsigned length; 2054a1bf3f78SToomas Soome char *s; 2055a1bf3f78SToomas Soome 2056a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0); 2057a1bf3f78SToomas Soome 2058a1bf3f78SToomas Soome length = ficlStackPopUnsigned(vm->dataStack); 2059a1bf3f78SToomas Soome s = ficlStackPopPointer(vm->dataStack); 2060a1bf3f78SToomas Soome 2061a1bf3f78SToomas Soome if ((s == NULL) || (length == 0)) 2062a1bf3f78SToomas Soome return; 2063a1bf3f78SToomas Soome 2064a1bf3f78SToomas Soome /* 2065a1bf3f78SToomas Soome * Since we don't have an output primitive for a counted string 2066a1bf3f78SToomas Soome * (oops), make sure the string is null terminated. If not, copy 2067a1bf3f78SToomas Soome * and terminate it. 2068a1bf3f78SToomas Soome */ 2069a1bf3f78SToomas Soome if (s[length] != 0) { 2070a1bf3f78SToomas Soome char *here = (char *)ficlVmGetDictionary(vm)->here; 2071a1bf3f78SToomas Soome if (s != here) 2072a1bf3f78SToomas Soome strncpy(here, s, length); 2073a1bf3f78SToomas Soome 2074a1bf3f78SToomas Soome here[length] = '\0'; 2075a1bf3f78SToomas Soome s = here; 2076a1bf3f78SToomas Soome } 2077a1bf3f78SToomas Soome 2078a1bf3f78SToomas Soome ficlVmTextOut(vm, s); 2079a1bf3f78SToomas Soome } 2080a1bf3f78SToomas Soome 2081a1bf3f78SToomas Soome /* 2082a1bf3f78SToomas Soome * w o r d 2083a1bf3f78SToomas Soome * word CORE ( char "<chars>ccc<char>" -- c-addr ) 2084a1bf3f78SToomas Soome * Skip leading delimiters. Parse characters ccc delimited by char. An 2085a1bf3f78SToomas Soome * ambiguous condition exists if the length of the parsed string is greater 2086a1bf3f78SToomas Soome * than the implementation-defined length of a counted string. 2087a1bf3f78SToomas Soome * 2088a1bf3f78SToomas Soome * c-addr is the address of a transient region containing the parsed word 2089a1bf3f78SToomas Soome * as a counted string. If the parse area was empty or contained no 2090a1bf3f78SToomas Soome * characters other than the delimiter, the resulting string has a zero 2091a1bf3f78SToomas Soome * length. A space, not included in the length, follows the string. A 2092a1bf3f78SToomas Soome * program may replace characters within the string. 2093a1bf3f78SToomas Soome * NOTE! Ficl also NULL-terminates the dest string. 2094a1bf3f78SToomas Soome */ 2095a1bf3f78SToomas Soome static void 2096a1bf3f78SToomas Soome ficlPrimitiveWord(ficlVm *vm) 2097a1bf3f78SToomas Soome { 2098a1bf3f78SToomas Soome ficlCountedString *counted; 2099a1bf3f78SToomas Soome char delim; 2100a1bf3f78SToomas Soome ficlString name; 2101a1bf3f78SToomas Soome 2102a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 1); 2103a1bf3f78SToomas Soome 2104a1bf3f78SToomas Soome counted = (ficlCountedString *)vm->pad; 2105a1bf3f78SToomas Soome delim = (char)ficlStackPopInteger(vm->dataStack); 2106a1bf3f78SToomas Soome name = ficlVmParseStringEx(vm, delim, 1); 2107a1bf3f78SToomas Soome 2108a1bf3f78SToomas Soome if (FICL_STRING_GET_LENGTH(name) > FICL_PAD_SIZE - 1) 2109a1bf3f78SToomas Soome FICL_STRING_SET_LENGTH(name, FICL_PAD_SIZE - 1); 2110a1bf3f78SToomas Soome 2111a1bf3f78SToomas Soome counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name); 2112a1bf3f78SToomas Soome strncpy(counted->text, FICL_STRING_GET_POINTER(name), 2113a1bf3f78SToomas Soome FICL_STRING_GET_LENGTH(name)); 2114a1bf3f78SToomas Soome 2115a1bf3f78SToomas Soome /* 2116a1bf3f78SToomas Soome * store an extra space at the end of the primitive... 2117a1bf3f78SToomas Soome * why? dunno yet. Guy Carver did it. 2118a1bf3f78SToomas Soome */ 2119a1bf3f78SToomas Soome counted->text[counted->length] = ' '; 2120a1bf3f78SToomas Soome counted->text[counted->length + 1] = 0; 2121a1bf3f78SToomas Soome 2122a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, counted); 2123a1bf3f78SToomas Soome } 2124a1bf3f78SToomas Soome 2125a1bf3f78SToomas Soome /* 2126a1bf3f78SToomas Soome * p a r s e - w o r d 2127a1bf3f78SToomas Soome * Ficl PARSE-WORD ( <spaces>name -- c-addr u ) 2128a1bf3f78SToomas Soome * Skip leading spaces and parse name delimited by a space. c-addr is the 2129a1bf3f78SToomas Soome * address within the input buffer and u is the length of the selected 2130a1bf3f78SToomas Soome * string. If the parse area is empty, the resulting string has a zero length. 2131a1bf3f78SToomas Soome */ 2132a1bf3f78SToomas Soome static void ficlPrimitiveParseNoCopy(ficlVm *vm) 2133a1bf3f78SToomas Soome { 2134a1bf3f78SToomas Soome ficlString s; 2135a1bf3f78SToomas Soome 2136a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 2); 2137a1bf3f78SToomas Soome 2138a1bf3f78SToomas Soome s = ficlVmGetWord0(vm); 2139a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s)); 2140a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s)); 2141a1bf3f78SToomas Soome } 2142a1bf3f78SToomas Soome 2143a1bf3f78SToomas Soome /* 2144a1bf3f78SToomas Soome * p a r s e 2145a1bf3f78SToomas Soome * CORE EXT ( char "ccc<char>" -- c-addr u ) 2146a1bf3f78SToomas Soome * Parse ccc delimited by the delimiter char. 2147a1bf3f78SToomas Soome * c-addr is the address (within the input buffer) and u is the length of 2148a1bf3f78SToomas Soome * the parsed string. If the parse area was empty, the resulting string has 2149a1bf3f78SToomas Soome * a zero length. 2150a1bf3f78SToomas Soome * NOTE! PARSE differs from WORD: it does not skip leading delimiters. 2151a1bf3f78SToomas Soome */ 2152a1bf3f78SToomas Soome static void 2153a1bf3f78SToomas Soome ficlPrimitiveParse(ficlVm *vm) 2154a1bf3f78SToomas Soome { 2155a1bf3f78SToomas Soome ficlString s; 2156a1bf3f78SToomas Soome char delim; 2157a1bf3f78SToomas Soome 2158a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2); 2159a1bf3f78SToomas Soome 2160a1bf3f78SToomas Soome delim = (char)ficlStackPopInteger(vm->dataStack); 2161a1bf3f78SToomas Soome 2162a1bf3f78SToomas Soome s = ficlVmParseStringEx(vm, delim, 0); 2163a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, FICL_STRING_GET_POINTER(s)); 2164a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, FICL_STRING_GET_LENGTH(s)); 2165a1bf3f78SToomas Soome } 2166a1bf3f78SToomas Soome 2167a1bf3f78SToomas Soome /* 2168a1bf3f78SToomas Soome * f i n d 2169a1bf3f78SToomas Soome * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 2170a1bf3f78SToomas Soome * Find the definition named in the counted string at c-addr. If the 2171a1bf3f78SToomas Soome * definition is not found, return c-addr and zero. If the definition is 2172a1bf3f78SToomas Soome * found, return its execution token xt. If the definition is immediate, 2173a1bf3f78SToomas Soome * also return one (1), otherwise also return minus-one (-1). For a given 2174a1bf3f78SToomas Soome * string, the values returned by FIND while compiling may differ from 2175a1bf3f78SToomas Soome * those returned while not compiling. 2176a1bf3f78SToomas Soome */ 2177a1bf3f78SToomas Soome static void 2178a1bf3f78SToomas Soome do_find(ficlVm *vm, ficlString name, void *returnForFailure) 2179a1bf3f78SToomas Soome { 2180a1bf3f78SToomas Soome ficlWord *word; 2181a1bf3f78SToomas Soome 2182a1bf3f78SToomas Soome word = ficlDictionaryLookup(ficlVmGetDictionary(vm), name); 2183a1bf3f78SToomas Soome if (word) { 2184a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, word); 2185a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 2186a1bf3f78SToomas Soome (ficlWordIsImmediate(word) ? 1 : -1)); 2187a1bf3f78SToomas Soome } else { 2188a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, returnForFailure); 2189a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, 0); 2190a1bf3f78SToomas Soome } 2191a1bf3f78SToomas Soome } 2192a1bf3f78SToomas Soome 2193a1bf3f78SToomas Soome /* 2194a1bf3f78SToomas Soome * f i n d 2195a1bf3f78SToomas Soome * FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 2196a1bf3f78SToomas Soome * Find the definition named in the counted string at c-addr. If the 2197a1bf3f78SToomas Soome * definition is not found, return c-addr and zero. If the definition is 2198a1bf3f78SToomas Soome * found, return its execution token xt. If the definition is immediate, 2199a1bf3f78SToomas Soome * also return one (1), otherwise also return minus-one (-1). For a given 2200a1bf3f78SToomas Soome * string, the values returned by FIND while compiling may differ from 2201a1bf3f78SToomas Soome * those returned while not compiling. 2202a1bf3f78SToomas Soome */ 2203a1bf3f78SToomas Soome static void 2204a1bf3f78SToomas Soome ficlPrimitiveCFind(ficlVm *vm) 2205a1bf3f78SToomas Soome { 2206a1bf3f78SToomas Soome ficlCountedString *counted; 2207a1bf3f78SToomas Soome ficlString name; 2208a1bf3f78SToomas Soome 2209a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 2); 2210a1bf3f78SToomas Soome 2211a1bf3f78SToomas Soome counted = ficlStackPopPointer(vm->dataStack); 2212a1bf3f78SToomas Soome FICL_STRING_SET_FROM_COUNTED_STRING(name, *counted); 2213a1bf3f78SToomas Soome do_find(vm, name, counted); 2214a1bf3f78SToomas Soome } 2215a1bf3f78SToomas Soome 2216a1bf3f78SToomas Soome /* 2217a1bf3f78SToomas Soome * s f i n d 2218a1bf3f78SToomas Soome * Ficl ( c-addr u -- 0 0 | xt 1 | xt -1 ) 2219a1bf3f78SToomas Soome * Like FIND, but takes "c-addr u" for the string. 2220a1bf3f78SToomas Soome */ 2221a1bf3f78SToomas Soome static void 2222a1bf3f78SToomas Soome ficlPrimitiveSFind(ficlVm *vm) 2223a1bf3f78SToomas Soome { 2224a1bf3f78SToomas Soome ficlString name; 2225a1bf3f78SToomas Soome 2226a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2); 2227a1bf3f78SToomas Soome 2228a1bf3f78SToomas Soome name.length = ficlStackPopInteger(vm->dataStack); 2229a1bf3f78SToomas Soome name.text = ficlStackPopPointer(vm->dataStack); 2230a1bf3f78SToomas Soome 2231a1bf3f78SToomas Soome do_find(vm, name, NULL); 2232a1bf3f78SToomas Soome } 2233a1bf3f78SToomas Soome 2234a1bf3f78SToomas Soome /* 2235a1bf3f78SToomas Soome * r e c u r s e 2236a1bf3f78SToomas Soome */ 2237a1bf3f78SToomas Soome static void 2238a1bf3f78SToomas Soome ficlPrimitiveRecurseCoIm(ficlVm *vm) 2239a1bf3f78SToomas Soome { 2240a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2241a1bf3f78SToomas Soome ficlCell c; 2242a1bf3f78SToomas Soome 2243a1bf3f78SToomas Soome FICL_IGNORE(vm); 2244a1bf3f78SToomas Soome c.p = dictionary->smudge; 2245a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, c); 2246a1bf3f78SToomas Soome } 2247a1bf3f78SToomas Soome 2248a1bf3f78SToomas Soome /* 2249a1bf3f78SToomas Soome * s o u r c e 2250a1bf3f78SToomas Soome * CORE ( -- c-addr u ) 2251a1bf3f78SToomas Soome * c-addr is the address of, and u is the number of characters in, the 2252a1bf3f78SToomas Soome * input buffer. 2253a1bf3f78SToomas Soome */ 2254a1bf3f78SToomas Soome static void 2255a1bf3f78SToomas Soome ficlPrimitiveSource(ficlVm *vm) 2256a1bf3f78SToomas Soome { 2257a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 2); 2258a1bf3f78SToomas Soome 2259a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, vm->tib.text); 2260a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, ficlVmGetInBufLen(vm)); 2261a1bf3f78SToomas Soome } 2262a1bf3f78SToomas Soome 2263a1bf3f78SToomas Soome /* 2264a1bf3f78SToomas Soome * v e r s i o n 2265a1bf3f78SToomas Soome * non-standard... 2266a1bf3f78SToomas Soome */ 2267a1bf3f78SToomas Soome static void 2268a1bf3f78SToomas Soome ficlPrimitiveVersion(ficlVm *vm) 2269a1bf3f78SToomas Soome { 2270a1bf3f78SToomas Soome ficlVmTextOut(vm, "Ficl version " FICL_VERSION "\n"); 2271a1bf3f78SToomas Soome } 2272a1bf3f78SToomas Soome 2273a1bf3f78SToomas Soome /* 2274a1bf3f78SToomas Soome * t o I n 2275a1bf3f78SToomas Soome * to-in CORE 2276a1bf3f78SToomas Soome */ 2277a1bf3f78SToomas Soome static void 2278a1bf3f78SToomas Soome ficlPrimitiveToIn(ficlVm *vm) 2279a1bf3f78SToomas Soome { 2280a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 2281a1bf3f78SToomas Soome 2282a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, &vm->tib.index); 2283a1bf3f78SToomas Soome } 2284a1bf3f78SToomas Soome 2285a1bf3f78SToomas Soome /* 2286a1bf3f78SToomas Soome * c o l o n N o N a m e 2287a1bf3f78SToomas Soome * CORE EXT ( C: -- colon-sys ) ( S: -- xt ) 2288a1bf3f78SToomas Soome * Create an unnamed colon definition and push its address. 2289a1bf3f78SToomas Soome * Change state to FICL_VM_STATE_COMPILE. 2290a1bf3f78SToomas Soome */ 2291a1bf3f78SToomas Soome static void 2292a1bf3f78SToomas Soome ficlPrimitiveColonNoName(ficlVm *vm) 2293a1bf3f78SToomas Soome { 2294a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2295a1bf3f78SToomas Soome ficlWord *word; 2296a1bf3f78SToomas Soome ficlString name; 2297a1bf3f78SToomas Soome 2298a1bf3f78SToomas Soome FICL_STRING_SET_LENGTH(name, 0); 2299a1bf3f78SToomas Soome FICL_STRING_SET_POINTER(name, NULL); 2300a1bf3f78SToomas Soome 2301a1bf3f78SToomas Soome vm->state = FICL_VM_STATE_COMPILE; 2302a1bf3f78SToomas Soome word = ficlDictionaryAppendWord(dictionary, name, 2303a1bf3f78SToomas Soome (ficlPrimitive)ficlInstructionColonParen, 2304a1bf3f78SToomas Soome FICL_WORD_DEFAULT | FICL_WORD_SMUDGED); 2305a1bf3f78SToomas Soome 2306a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, word); 2307a1bf3f78SToomas Soome markControlTag(vm, colonTag); 2308a1bf3f78SToomas Soome } 2309a1bf3f78SToomas Soome 2310a1bf3f78SToomas Soome /* 2311a1bf3f78SToomas Soome * u s e r V a r i a b l e 2312a1bf3f78SToomas Soome * user ( u -- ) "<spaces>name" 2313a1bf3f78SToomas Soome * Get a name from the input stream and create a user variable 2314a1bf3f78SToomas Soome * with the name and the index supplied. The run-time effect 2315a1bf3f78SToomas Soome * of a user variable is to push the address of the indexed ficlCell 2316a1bf3f78SToomas Soome * in the running vm's user array. 2317a1bf3f78SToomas Soome * 2318a1bf3f78SToomas Soome * User variables are vm local cells. Each vm has an array of 2319a1bf3f78SToomas Soome * FICL_USER_CELLS of them when FICL_WANT_USER is nonzero. 2320a1bf3f78SToomas Soome * Ficl's user facility is implemented with two primitives, 2321a1bf3f78SToomas Soome * "user" and "(user)", a variable ("nUser") (in softcore.c) that 2322a1bf3f78SToomas Soome * holds the index of the next free user ficlCell, and a redefinition 2323a1bf3f78SToomas Soome * (also in softcore) of "user" that defines a user word and increments 2324a1bf3f78SToomas Soome * nUser. 2325a1bf3f78SToomas Soome */ 2326a1bf3f78SToomas Soome #if FICL_WANT_USER 2327a1bf3f78SToomas Soome static void 2328a1bf3f78SToomas Soome ficlPrimitiveUser(ficlVm *vm) 2329a1bf3f78SToomas Soome { 2330a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2331a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 2332a1bf3f78SToomas Soome ficlCell c; 2333a1bf3f78SToomas Soome 2334a1bf3f78SToomas Soome c = ficlStackPop(vm->dataStack); 2335a1bf3f78SToomas Soome if (c.i >= FICL_USER_CELLS) { 2336a1bf3f78SToomas Soome ficlVmThrowError(vm, "Error - out of user space"); 2337a1bf3f78SToomas Soome } 2338a1bf3f78SToomas Soome 2339a1bf3f78SToomas Soome ficlDictionaryAppendWord(dictionary, name, 2340a1bf3f78SToomas Soome (ficlPrimitive)ficlInstructionUserParen, FICL_WORD_DEFAULT); 2341a1bf3f78SToomas Soome ficlDictionaryAppendCell(dictionary, c); 2342a1bf3f78SToomas Soome } 2343a1bf3f78SToomas Soome #endif 2344a1bf3f78SToomas Soome 2345a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 2346a1bf3f78SToomas Soome /* 2347a1bf3f78SToomas Soome * Each local is recorded in a private locals dictionary as a 2348a1bf3f78SToomas Soome * word that does doLocalIm at runtime. DoLocalIm compiles code 2349a1bf3f78SToomas Soome * into the client definition to fetch the value of the 2350a1bf3f78SToomas Soome * corresponding local variable from the return stack. 2351a1bf3f78SToomas Soome * The private dictionary gets initialized at the end of each block 2352a1bf3f78SToomas Soome * that uses locals (in ; and does> for example). 2353a1bf3f78SToomas Soome */ 2354a1bf3f78SToomas Soome void 2355a1bf3f78SToomas Soome ficlLocalParenIm(ficlVm *vm, int isDouble, int isFloat) 2356a1bf3f78SToomas Soome { 2357a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2358a1bf3f78SToomas Soome ficlInteger nLocal = vm->runningWord->param[0].i; 2359a1bf3f78SToomas Soome 2360a1bf3f78SToomas Soome #if !FICL_WANT_FLOAT 2361a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, !isFloat); 2362a1bf3f78SToomas Soome /* get rid of unused parameter warning */ 2363a1bf3f78SToomas Soome isFloat = 0; 2364a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2365a1bf3f78SToomas Soome 2366a1bf3f78SToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) { 2367a1bf3f78SToomas Soome ficlStack *stack; 2368a1bf3f78SToomas Soome #if FICL_WANT_FLOAT 2369a1bf3f78SToomas Soome if (isFloat) 2370a1bf3f78SToomas Soome stack = vm->floatStack; 2371a1bf3f78SToomas Soome else 2372a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2373a1bf3f78SToomas Soome stack = vm->dataStack; 2374a1bf3f78SToomas Soome 2375a1bf3f78SToomas Soome ficlStackPush(stack, vm->returnStack->frame[nLocal]); 2376a1bf3f78SToomas Soome if (isDouble) 2377a1bf3f78SToomas Soome ficlStackPush(stack, vm->returnStack->frame[nLocal+1]); 2378a1bf3f78SToomas Soome } else { 2379a1bf3f78SToomas Soome ficlInstruction instruction; 2380a1bf3f78SToomas Soome ficlInteger appendLocalOffset; 2381a1bf3f78SToomas Soome #if FICL_WANT_FLOAT 2382a1bf3f78SToomas Soome if (isFloat) { 2383a1bf3f78SToomas Soome instruction = 2384a1bf3f78SToomas Soome (isDouble) ? ficlInstructionGetF2LocalParen : 2385a1bf3f78SToomas Soome ficlInstructionGetFLocalParen; 2386a1bf3f78SToomas Soome appendLocalOffset = FICL_TRUE; 2387a1bf3f78SToomas Soome } else 2388a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2389a1bf3f78SToomas Soome if (nLocal == 0) { 2390a1bf3f78SToomas Soome instruction = (isDouble) ? ficlInstructionGet2Local0 : 2391a1bf3f78SToomas Soome ficlInstructionGetLocal0; 2392a1bf3f78SToomas Soome appendLocalOffset = FICL_FALSE; 2393a1bf3f78SToomas Soome } else if ((nLocal == 1) && !isDouble) { 2394a1bf3f78SToomas Soome instruction = ficlInstructionGetLocal1; 2395a1bf3f78SToomas Soome appendLocalOffset = FICL_FALSE; 2396a1bf3f78SToomas Soome } else { 2397a1bf3f78SToomas Soome instruction = 2398a1bf3f78SToomas Soome (isDouble) ? ficlInstructionGet2LocalParen : 2399a1bf3f78SToomas Soome ficlInstructionGetLocalParen; 2400a1bf3f78SToomas Soome appendLocalOffset = FICL_TRUE; 2401a1bf3f78SToomas Soome } 2402a1bf3f78SToomas Soome 2403a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction); 2404a1bf3f78SToomas Soome if (appendLocalOffset) 2405a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, nLocal); 2406a1bf3f78SToomas Soome } 2407a1bf3f78SToomas Soome } 2408a1bf3f78SToomas Soome 2409a1bf3f78SToomas Soome static void 2410a1bf3f78SToomas Soome ficlPrimitiveDoLocalIm(ficlVm *vm) 2411a1bf3f78SToomas Soome { 2412a1bf3f78SToomas Soome ficlLocalParenIm(vm, 0, 0); 2413a1bf3f78SToomas Soome } 2414a1bf3f78SToomas Soome 2415a1bf3f78SToomas Soome static void 2416a1bf3f78SToomas Soome ficlPrimitiveDo2LocalIm(ficlVm *vm) 2417a1bf3f78SToomas Soome { 2418a1bf3f78SToomas Soome ficlLocalParenIm(vm, 1, 0); 2419a1bf3f78SToomas Soome } 2420a1bf3f78SToomas Soome 2421a1bf3f78SToomas Soome #if FICL_WANT_FLOAT 2422a1bf3f78SToomas Soome static void 2423a1bf3f78SToomas Soome ficlPrimitiveDoFLocalIm(ficlVm *vm) 2424a1bf3f78SToomas Soome { 2425a1bf3f78SToomas Soome ficlLocalParenIm(vm, 0, 1); 2426a1bf3f78SToomas Soome } 2427a1bf3f78SToomas Soome 2428a1bf3f78SToomas Soome static void 2429a1bf3f78SToomas Soome ficlPrimitiveDoF2LocalIm(ficlVm *vm) 2430a1bf3f78SToomas Soome { 2431a1bf3f78SToomas Soome ficlLocalParenIm(vm, 1, 1); 2432a1bf3f78SToomas Soome } 2433a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2434a1bf3f78SToomas Soome 2435a1bf3f78SToomas Soome /* 2436a1bf3f78SToomas Soome * l o c a l P a r e n 2437a1bf3f78SToomas Soome * paren-local-paren LOCAL 2438a1bf3f78SToomas Soome * Interpretation: Interpretation semantics for this word are undefined. 2439a1bf3f78SToomas Soome * Execution: ( c-addr u -- ) 2440a1bf3f78SToomas Soome * When executed during compilation, (LOCAL) passes a message to the 2441a1bf3f78SToomas Soome * system that has one of two meanings. If u is non-zero, 2442a1bf3f78SToomas Soome * the message identifies a new local whose definition name is given by 2443a1bf3f78SToomas Soome * the string of characters identified by c-addr u. If u is zero, 2444a1bf3f78SToomas Soome * the message is last local and c-addr has no significance. 2445a1bf3f78SToomas Soome * 2446a1bf3f78SToomas Soome * The result of executing (LOCAL) during compilation of a definition is 2447a1bf3f78SToomas Soome * to create a set of named local identifiers, each of which is 2448a1bf3f78SToomas Soome * a definition name, that only have execution semantics within the scope 2449a1bf3f78SToomas Soome * of that definition's source. 2450a1bf3f78SToomas Soome * 2451a1bf3f78SToomas Soome * local Execution: ( -- x ) 2452a1bf3f78SToomas Soome * 2453a1bf3f78SToomas Soome * Push the local's value, x, onto the stack. The local's value is 2454a1bf3f78SToomas Soome * initialized as described in 13.3.3 Processing locals and may be 2455a1bf3f78SToomas Soome * changed by preceding the local's name with TO. An ambiguous condition 2456a1bf3f78SToomas Soome * exists when local is executed while in interpretation state. 2457a1bf3f78SToomas Soome */ 2458a1bf3f78SToomas Soome void 2459a1bf3f78SToomas Soome ficlLocalParen(ficlVm *vm, int isDouble, int isFloat) 2460a1bf3f78SToomas Soome { 2461a1bf3f78SToomas Soome ficlDictionary *dictionary; 2462a1bf3f78SToomas Soome ficlString name; 2463a1bf3f78SToomas Soome 2464a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 0); 2465a1bf3f78SToomas Soome 2466a1bf3f78SToomas Soome dictionary = ficlVmGetDictionary(vm); 2467a1bf3f78SToomas Soome FICL_STRING_SET_LENGTH(name, ficlStackPopUnsigned(vm->dataStack)); 2468a1bf3f78SToomas Soome FICL_STRING_SET_POINTER(name, 2469a1bf3f78SToomas Soome (char *)ficlStackPopPointer(vm->dataStack)); 2470a1bf3f78SToomas Soome 2471a1bf3f78SToomas Soome if (FICL_STRING_GET_LENGTH(name) > 0) { 2472a1bf3f78SToomas Soome /* 2473a1bf3f78SToomas Soome * add a local to the **locals** dictionary and 2474a1bf3f78SToomas Soome * update localsCount 2475a1bf3f78SToomas Soome */ 2476a1bf3f78SToomas Soome ficlPrimitive code; 2477a1bf3f78SToomas Soome ficlInstruction instruction; 2478a1bf3f78SToomas Soome ficlDictionary *locals; 2479a1bf3f78SToomas Soome 2480a1bf3f78SToomas Soome locals = ficlSystemGetLocals(vm->callback.system); 2481a1bf3f78SToomas Soome if (vm->callback.system->localsCount >= FICL_MAX_LOCALS) { 2482a1bf3f78SToomas Soome ficlVmThrowError(vm, "Error: out of local space"); 2483a1bf3f78SToomas Soome } 2484a1bf3f78SToomas Soome 2485a1bf3f78SToomas Soome #if !FICL_WANT_FLOAT 2486a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, !isFloat); 2487a1bf3f78SToomas Soome /* get rid of unused parameter warning */ 2488a1bf3f78SToomas Soome isFloat = 0; 2489a1bf3f78SToomas Soome #else /* FICL_WANT_FLOAT */ 2490a1bf3f78SToomas Soome if (isFloat) { 2491a1bf3f78SToomas Soome if (isDouble) { 2492a1bf3f78SToomas Soome code = ficlPrimitiveDoF2LocalIm; 2493a1bf3f78SToomas Soome instruction = ficlInstructionToF2LocalParen; 2494a1bf3f78SToomas Soome } else { 2495a1bf3f78SToomas Soome code = ficlPrimitiveDoFLocalIm; 2496a1bf3f78SToomas Soome instruction = ficlInstructionToFLocalParen; 2497a1bf3f78SToomas Soome } 2498a1bf3f78SToomas Soome } else 2499a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2500a1bf3f78SToomas Soome if (isDouble) { 2501a1bf3f78SToomas Soome code = ficlPrimitiveDo2LocalIm; 2502a1bf3f78SToomas Soome instruction = ficlInstructionTo2LocalParen; 2503a1bf3f78SToomas Soome } else { 2504a1bf3f78SToomas Soome code = ficlPrimitiveDoLocalIm; 2505a1bf3f78SToomas Soome instruction = ficlInstructionToLocalParen; 2506a1bf3f78SToomas Soome } 2507a1bf3f78SToomas Soome 2508a1bf3f78SToomas Soome ficlDictionaryAppendWord(locals, name, code, 2509a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 2510a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(locals, 2511a1bf3f78SToomas Soome vm->callback.system->localsCount); 2512a1bf3f78SToomas Soome 2513a1bf3f78SToomas Soome if (vm->callback.system->localsCount == 0) { 2514a1bf3f78SToomas Soome /* 2515a1bf3f78SToomas Soome * FICL_VM_STATE_COMPILE code to create a local 2516a1bf3f78SToomas Soome * stack frame 2517a1bf3f78SToomas Soome */ 2518a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2519a1bf3f78SToomas Soome ficlInstructionLinkParen); 2520a1bf3f78SToomas Soome 2521a1bf3f78SToomas Soome /* save location in dictionary for #locals */ 2522a1bf3f78SToomas Soome vm->callback.system->localsFixup = dictionary->here; 2523a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2524a1bf3f78SToomas Soome vm->callback.system->localsCount); 2525a1bf3f78SToomas Soome } 2526a1bf3f78SToomas Soome 2527a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction); 2528a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, 2529a1bf3f78SToomas Soome vm->callback.system->localsCount); 2530a1bf3f78SToomas Soome 2531a1bf3f78SToomas Soome vm->callback.system->localsCount += (isDouble) ? 2 : 1; 2532a1bf3f78SToomas Soome } else if (vm->callback.system->localsCount > 0) { 2533a1bf3f78SToomas Soome /* write localsCount to (link) param area in dictionary */ 2534a1bf3f78SToomas Soome *(ficlInteger *)(vm->callback.system->localsFixup) = 2535a1bf3f78SToomas Soome vm->callback.system->localsCount; 2536a1bf3f78SToomas Soome } 2537a1bf3f78SToomas Soome } 2538a1bf3f78SToomas Soome 2539a1bf3f78SToomas Soome static void 2540a1bf3f78SToomas Soome ficlPrimitiveLocalParen(ficlVm *vm) 2541a1bf3f78SToomas Soome { 2542a1bf3f78SToomas Soome ficlLocalParen(vm, 0, 0); 2543a1bf3f78SToomas Soome } 2544a1bf3f78SToomas Soome 2545a1bf3f78SToomas Soome static void 2546a1bf3f78SToomas Soome ficlPrimitive2LocalParen(ficlVm *vm) 2547a1bf3f78SToomas Soome { 2548a1bf3f78SToomas Soome ficlLocalParen(vm, 1, 0); 2549a1bf3f78SToomas Soome } 2550a1bf3f78SToomas Soome #endif /* FICL_WANT_LOCALS */ 2551a1bf3f78SToomas Soome 2552a1bf3f78SToomas Soome /* 2553a1bf3f78SToomas Soome * t o V a l u e 2554a1bf3f78SToomas Soome * CORE EXT 2555a1bf3f78SToomas Soome * Interpretation: ( x "<spaces>name" -- ) 2556a1bf3f78SToomas Soome * Skip leading spaces and parse name delimited by a space. Store x in 2557a1bf3f78SToomas Soome * name. An ambiguous condition exists if name was not defined by VALUE. 2558a1bf3f78SToomas Soome * NOTE: In Ficl, VALUE is an alias of CONSTANT 2559a1bf3f78SToomas Soome */ 2560a1bf3f78SToomas Soome static void 2561a1bf3f78SToomas Soome ficlPrimitiveToValue(ficlVm *vm) 2562a1bf3f78SToomas Soome { 2563a1bf3f78SToomas Soome ficlString name = ficlVmGetWord(vm); 2564a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 2565a1bf3f78SToomas Soome ficlWord *word; 2566a1bf3f78SToomas Soome ficlInstruction instruction = 0; 2567a1bf3f78SToomas Soome ficlStack *stack; 2568a1bf3f78SToomas Soome ficlInteger isDouble; 2569a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 2570a1bf3f78SToomas Soome ficlInteger nLocal; 2571a1bf3f78SToomas Soome ficlInteger appendLocalOffset; 2572a1bf3f78SToomas Soome ficlInteger isFloat; 2573a1bf3f78SToomas Soome #endif /* FICL_WANT_LOCALS */ 2574a1bf3f78SToomas Soome 2575a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 2576a1bf3f78SToomas Soome if ((vm->callback.system->localsCount > 0) && 2577a1bf3f78SToomas Soome (vm->state == FICL_VM_STATE_COMPILE)) { 2578a1bf3f78SToomas Soome ficlDictionary *locals; 2579a1bf3f78SToomas Soome 2580a1bf3f78SToomas Soome locals = ficlSystemGetLocals(vm->callback.system); 2581a1bf3f78SToomas Soome word = ficlDictionaryLookup(locals, name); 2582a1bf3f78SToomas Soome if (!word) 2583a1bf3f78SToomas Soome goto TO_GLOBAL; 2584a1bf3f78SToomas Soome 2585a1bf3f78SToomas Soome if (word->code == ficlPrimitiveDoLocalIm) { 2586a1bf3f78SToomas Soome instruction = ficlInstructionToLocalParen; 2587a1bf3f78SToomas Soome isDouble = isFloat = FICL_FALSE; 2588a1bf3f78SToomas Soome } else if (word->code == ficlPrimitiveDo2LocalIm) { 2589a1bf3f78SToomas Soome instruction = ficlInstructionTo2LocalParen; 2590a1bf3f78SToomas Soome isDouble = FICL_TRUE; 2591a1bf3f78SToomas Soome isFloat = FICL_FALSE; 2592a1bf3f78SToomas Soome } 2593a1bf3f78SToomas Soome #if FICL_WANT_FLOAT 2594a1bf3f78SToomas Soome else if (word->code == ficlPrimitiveDoFLocalIm) { 2595a1bf3f78SToomas Soome instruction = ficlInstructionToFLocalParen; 2596a1bf3f78SToomas Soome isDouble = FICL_FALSE; 2597a1bf3f78SToomas Soome isFloat = FICL_TRUE; 2598a1bf3f78SToomas Soome } else if (word->code == ficlPrimitiveDoF2LocalIm) { 2599a1bf3f78SToomas Soome instruction = ficlInstructionToF2LocalParen; 2600a1bf3f78SToomas Soome isDouble = isFloat = FICL_TRUE; 2601a1bf3f78SToomas Soome } 2602a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2603a1bf3f78SToomas Soome else { 2604a1bf3f78SToomas Soome ficlVmThrowError(vm, 2605a1bf3f78SToomas Soome "to %.*s : local is of unknown type", 2606a1bf3f78SToomas Soome FICL_STRING_GET_LENGTH(name), 2607a1bf3f78SToomas Soome FICL_STRING_GET_POINTER(name)); 2608a1bf3f78SToomas Soome return; 2609a1bf3f78SToomas Soome } 2610a1bf3f78SToomas Soome 2611a1bf3f78SToomas Soome nLocal = word->param[0].i; 2612a1bf3f78SToomas Soome appendLocalOffset = FICL_TRUE; 2613a1bf3f78SToomas Soome 2614a1bf3f78SToomas Soome #if FICL_WANT_FLOAT 2615a1bf3f78SToomas Soome if (!isFloat) { 2616a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2617a1bf3f78SToomas Soome if (nLocal == 0) { 2618a1bf3f78SToomas Soome instruction = 2619a1bf3f78SToomas Soome (isDouble) ? ficlInstructionTo2Local0 : 2620a1bf3f78SToomas Soome ficlInstructionToLocal0; 2621a1bf3f78SToomas Soome appendLocalOffset = FICL_FALSE; 2622a1bf3f78SToomas Soome } else if ((nLocal == 1) && !isDouble) { 2623a1bf3f78SToomas Soome instruction = ficlInstructionToLocal1; 2624a1bf3f78SToomas Soome appendLocalOffset = FICL_FALSE; 2625a1bf3f78SToomas Soome } 2626a1bf3f78SToomas Soome #if FICL_WANT_FLOAT 2627a1bf3f78SToomas Soome } 2628a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2629a1bf3f78SToomas Soome 2630a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction); 2631a1bf3f78SToomas Soome if (appendLocalOffset) 2632a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, nLocal); 2633a1bf3f78SToomas Soome return; 2634a1bf3f78SToomas Soome } 2635a1bf3f78SToomas Soome #endif 2636a1bf3f78SToomas Soome 2637a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 2638a1bf3f78SToomas Soome TO_GLOBAL: 2639a1bf3f78SToomas Soome #endif /* FICL_WANT_LOCALS */ 2640a1bf3f78SToomas Soome word = ficlDictionaryLookup(dictionary, name); 2641a1bf3f78SToomas Soome if (!word) 2642a1bf3f78SToomas Soome ficlVmThrowError(vm, "%.*s not found", 2643a1bf3f78SToomas Soome FICL_STRING_GET_LENGTH(name), 2644a1bf3f78SToomas Soome FICL_STRING_GET_POINTER(name)); 2645a1bf3f78SToomas Soome 2646a1bf3f78SToomas Soome switch ((ficlInstruction)word->code) { 2647a1bf3f78SToomas Soome case ficlInstructionConstantParen: 2648a1bf3f78SToomas Soome instruction = ficlInstructionStore; 2649a1bf3f78SToomas Soome stack = vm->dataStack; 2650a1bf3f78SToomas Soome isDouble = FICL_FALSE; 2651a1bf3f78SToomas Soome break; 2652a1bf3f78SToomas Soome case ficlInstruction2ConstantParen: 2653a1bf3f78SToomas Soome instruction = ficlInstruction2Store; 2654a1bf3f78SToomas Soome stack = vm->dataStack; 2655a1bf3f78SToomas Soome isDouble = FICL_TRUE; 2656a1bf3f78SToomas Soome break; 2657a1bf3f78SToomas Soome #if FICL_WANT_FLOAT 2658a1bf3f78SToomas Soome case ficlInstructionFConstantParen: 2659a1bf3f78SToomas Soome instruction = ficlInstructionFStore; 2660a1bf3f78SToomas Soome stack = vm->floatStack; 2661a1bf3f78SToomas Soome isDouble = FICL_FALSE; 2662a1bf3f78SToomas Soome break; 2663a1bf3f78SToomas Soome case ficlInstructionF2ConstantParen: 2664a1bf3f78SToomas Soome instruction = ficlInstructionF2Store; 2665a1bf3f78SToomas Soome stack = vm->floatStack; 2666a1bf3f78SToomas Soome isDouble = FICL_TRUE; 2667a1bf3f78SToomas Soome break; 2668a1bf3f78SToomas Soome #endif /* FICL_WANT_FLOAT */ 2669a1bf3f78SToomas Soome default: 2670a1bf3f78SToomas Soome ficlVmThrowError(vm, 2671a1bf3f78SToomas Soome "to %.*s : value/constant is of unknown type", 2672a1bf3f78SToomas Soome FICL_STRING_GET_LENGTH(name), 2673a1bf3f78SToomas Soome FICL_STRING_GET_POINTER(name)); 2674a1bf3f78SToomas Soome return; 2675a1bf3f78SToomas Soome } 2676a1bf3f78SToomas Soome 2677a1bf3f78SToomas Soome if (vm->state == FICL_VM_STATE_INTERPRET) { 2678a1bf3f78SToomas Soome word->param[0] = ficlStackPop(stack); 2679a1bf3f78SToomas Soome if (isDouble) 2680a1bf3f78SToomas Soome word->param[1] = ficlStackPop(stack); 2681a1bf3f78SToomas Soome } else { 2682a1bf3f78SToomas Soome /* FICL_VM_STATE_COMPILE code to store to word's param */ 2683a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, &word->param[0]); 2684a1bf3f78SToomas Soome ficlPrimitiveLiteralIm(vm); 2685a1bf3f78SToomas Soome ficlDictionaryAppendUnsigned(dictionary, instruction); 2686a1bf3f78SToomas Soome } 2687a1bf3f78SToomas Soome } 2688a1bf3f78SToomas Soome 2689a1bf3f78SToomas Soome /* 2690a1bf3f78SToomas Soome * f m S l a s h M o d 2691a1bf3f78SToomas Soome * f-m-slash-mod CORE ( d1 n1 -- n2 n3 ) 2692a1bf3f78SToomas Soome * Divide d1 by n1, giving the floored quotient n3 and the remainder n2. 2693a1bf3f78SToomas Soome * Input and output stack arguments are signed. An ambiguous condition 2694a1bf3f78SToomas Soome * exists if n1 is zero or if the quotient lies outside the range of a 2695a1bf3f78SToomas Soome * single-ficlCell signed integer. 2696a1bf3f78SToomas Soome */ 2697a1bf3f78SToomas Soome static void 2698a1bf3f78SToomas Soome ficlPrimitiveFMSlashMod(ficlVm *vm) 2699a1bf3f78SToomas Soome { 2700a1bf3f78SToomas Soome ficl2Integer d1; 2701a1bf3f78SToomas Soome ficlInteger n1; 2702a1bf3f78SToomas Soome ficl2IntegerQR qr; 2703a1bf3f78SToomas Soome 2704a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 3, 2); 2705a1bf3f78SToomas Soome 2706a1bf3f78SToomas Soome n1 = ficlStackPopInteger(vm->dataStack); 2707a1bf3f78SToomas Soome d1 = ficlStackPop2Integer(vm->dataStack); 2708a1bf3f78SToomas Soome qr = ficl2IntegerDivideFloored(d1, n1); 2709a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, qr.remainder); 2710a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 2711a1bf3f78SToomas Soome FICL_2UNSIGNED_GET_LOW(qr.quotient)); 2712a1bf3f78SToomas Soome } 2713a1bf3f78SToomas Soome 2714a1bf3f78SToomas Soome /* 2715a1bf3f78SToomas Soome * s m S l a s h R e m 2716a1bf3f78SToomas Soome * s-m-slash-remainder CORE ( d1 n1 -- n2 n3 ) 2717a1bf3f78SToomas Soome * Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. 2718a1bf3f78SToomas Soome * Input and output stack arguments are signed. An ambiguous condition 2719a1bf3f78SToomas Soome * exists if n1 is zero or if the quotient lies outside the range of a 2720a1bf3f78SToomas Soome * single-ficlCell signed integer. 2721a1bf3f78SToomas Soome */ 2722a1bf3f78SToomas Soome static void 2723a1bf3f78SToomas Soome ficlPrimitiveSMSlashRem(ficlVm *vm) 2724a1bf3f78SToomas Soome { 2725a1bf3f78SToomas Soome ficl2Integer d1; 2726a1bf3f78SToomas Soome ficlInteger n1; 2727a1bf3f78SToomas Soome ficl2IntegerQR qr; 2728a1bf3f78SToomas Soome 2729a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 3, 2); 2730a1bf3f78SToomas Soome 2731a1bf3f78SToomas Soome n1 = ficlStackPopInteger(vm->dataStack); 2732a1bf3f78SToomas Soome d1 = ficlStackPop2Integer(vm->dataStack); 2733a1bf3f78SToomas Soome qr = ficl2IntegerDivideSymmetric(d1, n1); 2734a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, qr.remainder); 2735a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 2736a1bf3f78SToomas Soome FICL_2UNSIGNED_GET_LOW(qr.quotient)); 2737a1bf3f78SToomas Soome } 2738a1bf3f78SToomas Soome 2739a1bf3f78SToomas Soome static void 2740a1bf3f78SToomas Soome ficlPrimitiveMod(ficlVm *vm) 2741a1bf3f78SToomas Soome { 2742a1bf3f78SToomas Soome ficl2Integer d1; 2743a1bf3f78SToomas Soome ficlInteger n1; 2744a1bf3f78SToomas Soome ficlInteger i; 2745a1bf3f78SToomas Soome ficl2IntegerQR qr; 2746a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 1); 2747a1bf3f78SToomas Soome 2748a1bf3f78SToomas Soome n1 = ficlStackPopInteger(vm->dataStack); 2749a1bf3f78SToomas Soome i = ficlStackPopInteger(vm->dataStack); 2750a1bf3f78SToomas Soome FICL_INTEGER_TO_2INTEGER(i, d1); 2751a1bf3f78SToomas Soome qr = ficl2IntegerDivideSymmetric(d1, n1); 2752a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, qr.remainder); 2753a1bf3f78SToomas Soome } 2754a1bf3f78SToomas Soome 2755a1bf3f78SToomas Soome /* 2756a1bf3f78SToomas Soome * u m S l a s h M o d 2757a1bf3f78SToomas Soome * u-m-slash-mod CORE ( ud u1 -- u2 u3 ) 2758a1bf3f78SToomas Soome * Divide ud by u1, giving the quotient u3 and the remainder u2. 2759a1bf3f78SToomas Soome * All values and arithmetic are unsigned. An ambiguous condition 2760a1bf3f78SToomas Soome * exists if u1 is zero or if the quotient lies outside the range of a 2761a1bf3f78SToomas Soome * single-ficlCell unsigned integer. 2762a1bf3f78SToomas Soome */ 2763a1bf3f78SToomas Soome static void 2764a1bf3f78SToomas Soome ficlPrimitiveUMSlashMod(ficlVm *vm) 2765a1bf3f78SToomas Soome { 2766a1bf3f78SToomas Soome ficl2Unsigned ud; 2767a1bf3f78SToomas Soome ficlUnsigned u1; 2768a1bf3f78SToomas Soome ficl2UnsignedQR uqr; 2769a1bf3f78SToomas Soome 2770a1bf3f78SToomas Soome u1 = ficlStackPopUnsigned(vm->dataStack); 2771a1bf3f78SToomas Soome ud = ficlStackPop2Unsigned(vm->dataStack); 2772a1bf3f78SToomas Soome uqr = ficl2UnsignedDivide(ud, u1); 2773a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, uqr.remainder); 2774a1bf3f78SToomas Soome ficlStackPushUnsigned(vm->dataStack, 2775a1bf3f78SToomas Soome FICL_2UNSIGNED_GET_LOW(uqr.quotient)); 2776a1bf3f78SToomas Soome } 2777a1bf3f78SToomas Soome 2778a1bf3f78SToomas Soome /* 2779a1bf3f78SToomas Soome * m S t a r 2780a1bf3f78SToomas Soome * m-star CORE ( n1 n2 -- d ) 2781a1bf3f78SToomas Soome * d is the signed product of n1 times n2. 2782a1bf3f78SToomas Soome */ 2783a1bf3f78SToomas Soome static void 2784a1bf3f78SToomas Soome ficlPrimitiveMStar(ficlVm *vm) 2785a1bf3f78SToomas Soome { 2786a1bf3f78SToomas Soome ficlInteger n2; 2787a1bf3f78SToomas Soome ficlInteger n1; 2788a1bf3f78SToomas Soome ficl2Integer d; 2789a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2); 2790a1bf3f78SToomas Soome 2791a1bf3f78SToomas Soome n2 = ficlStackPopInteger(vm->dataStack); 2792a1bf3f78SToomas Soome n1 = ficlStackPopInteger(vm->dataStack); 2793a1bf3f78SToomas Soome 2794a1bf3f78SToomas Soome d = ficl2IntegerMultiply(n1, n2); 2795a1bf3f78SToomas Soome ficlStackPush2Integer(vm->dataStack, d); 2796a1bf3f78SToomas Soome } 2797a1bf3f78SToomas Soome 2798a1bf3f78SToomas Soome static void 2799a1bf3f78SToomas Soome ficlPrimitiveUMStar(ficlVm *vm) 2800a1bf3f78SToomas Soome { 2801a1bf3f78SToomas Soome ficlUnsigned u2; 2802a1bf3f78SToomas Soome ficlUnsigned u1; 2803a1bf3f78SToomas Soome ficl2Unsigned ud; 2804a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 2, 2); 2805a1bf3f78SToomas Soome 2806a1bf3f78SToomas Soome u2 = ficlStackPopUnsigned(vm->dataStack); 2807a1bf3f78SToomas Soome u1 = ficlStackPopUnsigned(vm->dataStack); 2808a1bf3f78SToomas Soome 2809a1bf3f78SToomas Soome ud = ficl2UnsignedMultiply(u1, u2); 2810a1bf3f78SToomas Soome ficlStackPush2Unsigned(vm->dataStack, ud); 2811a1bf3f78SToomas Soome } 2812a1bf3f78SToomas Soome 2813a1bf3f78SToomas Soome /* 2814a1bf3f78SToomas Soome * 2 r o t 2815a1bf3f78SToomas Soome * DOUBLE ( d1 d2 d3 -- d2 d3 d1 ) 2816a1bf3f78SToomas Soome */ 2817a1bf3f78SToomas Soome static void 2818a1bf3f78SToomas Soome ficlPrimitive2Rot(ficlVm *vm) 2819a1bf3f78SToomas Soome { 2820a1bf3f78SToomas Soome ficl2Integer d1, d2, d3; 2821a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 6, 6); 2822a1bf3f78SToomas Soome 2823a1bf3f78SToomas Soome d3 = ficlStackPop2Integer(vm->dataStack); 2824a1bf3f78SToomas Soome d2 = ficlStackPop2Integer(vm->dataStack); 2825a1bf3f78SToomas Soome d1 = ficlStackPop2Integer(vm->dataStack); 2826a1bf3f78SToomas Soome ficlStackPush2Integer(vm->dataStack, d2); 2827a1bf3f78SToomas Soome ficlStackPush2Integer(vm->dataStack, d3); 2828a1bf3f78SToomas Soome ficlStackPush2Integer(vm->dataStack, d1); 2829a1bf3f78SToomas Soome } 2830a1bf3f78SToomas Soome 2831a1bf3f78SToomas Soome /* 2832a1bf3f78SToomas Soome * p a d 2833a1bf3f78SToomas Soome * CORE EXT ( -- c-addr ) 2834a1bf3f78SToomas Soome * c-addr is the address of a transient region that can be used to hold 2835a1bf3f78SToomas Soome * data for intermediate processing. 2836a1bf3f78SToomas Soome */ 2837a1bf3f78SToomas Soome static void 2838a1bf3f78SToomas Soome ficlPrimitivePad(ficlVm *vm) 2839a1bf3f78SToomas Soome { 2840a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, vm->pad); 2841a1bf3f78SToomas Soome } 2842a1bf3f78SToomas Soome 2843a1bf3f78SToomas Soome /* 2844a1bf3f78SToomas Soome * s o u r c e - i d 2845a1bf3f78SToomas Soome * CORE EXT, FILE ( -- 0 | -1 | fileid ) 2846a1bf3f78SToomas Soome * Identifies the input source as follows: 2847a1bf3f78SToomas Soome * 2848a1bf3f78SToomas Soome * SOURCE-ID Input source 2849a1bf3f78SToomas Soome * --------- ------------ 2850a1bf3f78SToomas Soome * fileid Text file fileid 2851a1bf3f78SToomas Soome * -1 String (via EVALUATE) 2852a1bf3f78SToomas Soome * 0 User input device 2853a1bf3f78SToomas Soome */ 2854a1bf3f78SToomas Soome static void 2855a1bf3f78SToomas Soome ficlPrimitiveSourceID(ficlVm *vm) 2856a1bf3f78SToomas Soome { 2857a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, vm->sourceId.i); 2858a1bf3f78SToomas Soome } 2859a1bf3f78SToomas Soome 2860a1bf3f78SToomas Soome /* 2861a1bf3f78SToomas Soome * r e f i l l 2862a1bf3f78SToomas Soome * CORE EXT ( -- flag ) 2863a1bf3f78SToomas Soome * Attempt to fill the input buffer from the input source, returning 2864a1bf3f78SToomas Soome * a FICL_TRUE flag if successful. 2865a1bf3f78SToomas Soome * When the input source is the user input device, attempt to receive input 2866a1bf3f78SToomas Soome * into the terminal input buffer. If successful, make the result the input 2867a1bf3f78SToomas Soome * buffer, set >IN to zero, and return FICL_TRUE. Receipt of a line containing 2868a1bf3f78SToomas Soome * no characters is considered successful. If there is no input available from 2869a1bf3f78SToomas Soome * the current input source, return FICL_FALSE. 2870a1bf3f78SToomas Soome * When the input source is a string from EVALUATE, return FICL_FALSE and 2871a1bf3f78SToomas Soome * perform no other action. 2872a1bf3f78SToomas Soome */ 2873a1bf3f78SToomas Soome static void 2874a1bf3f78SToomas Soome ficlPrimitiveRefill(ficlVm *vm) 2875a1bf3f78SToomas Soome { 2876a1bf3f78SToomas Soome ficlInteger ret = (vm->sourceId.i == -1) ? FICL_FALSE : FICL_TRUE; 2877a1bf3f78SToomas Soome if (ret && (vm->restart == 0)) 2878a1bf3f78SToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_RESTART); 2879a1bf3f78SToomas Soome 2880a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, ret); 2881a1bf3f78SToomas Soome } 2882a1bf3f78SToomas Soome 2883a1bf3f78SToomas Soome /* 2884a1bf3f78SToomas Soome * freebsd exception handling words 2885a1bf3f78SToomas Soome * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE 2886a1bf3f78SToomas Soome * the word in ToS. If an exception happens, restore the state to what 2887a1bf3f78SToomas Soome * it was before, and pushes the exception value on the stack. If not, 2888a1bf3f78SToomas Soome * push zero. 2889a1bf3f78SToomas Soome * 2890a1bf3f78SToomas Soome * Notice that Catch implements an inner interpreter. This is ugly, 2891a1bf3f78SToomas Soome * but given how Ficl works, it cannot be helped. The problem is that 2892a1bf3f78SToomas Soome * colon definitions will be executed *after* the function returns, 2893a1bf3f78SToomas Soome * while "code" definitions will be executed immediately. I considered 2894a1bf3f78SToomas Soome * other solutions to this problem, but all of them shared the same 2895a1bf3f78SToomas Soome * basic problem (with added disadvantages): if Ficl ever changes it's 2896a1bf3f78SToomas Soome * inner thread modus operandi, one would have to fix this word. 2897a1bf3f78SToomas Soome * 2898a1bf3f78SToomas Soome * More comments can be found throughout catch's code. 2899a1bf3f78SToomas Soome * 2900a1bf3f78SToomas Soome * Daniel C. Sobral Jan 09/1999 2901a1bf3f78SToomas Soome * sadler may 2000 -- revised to follow ficl.c:ficlExecXT. 2902a1bf3f78SToomas Soome */ 2903a1bf3f78SToomas Soome static void 2904a1bf3f78SToomas Soome ficlPrimitiveCatch(ficlVm *vm) 2905a1bf3f78SToomas Soome { 2906a1bf3f78SToomas Soome int except; 2907a1bf3f78SToomas Soome jmp_buf vmState; 2908a1bf3f78SToomas Soome ficlVm vmCopy; 2909a1bf3f78SToomas Soome ficlStack dataStackCopy; 2910a1bf3f78SToomas Soome ficlStack returnStackCopy; 2911a1bf3f78SToomas Soome ficlWord *word; 2912a1bf3f78SToomas Soome 2913a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, vm); 2914a1bf3f78SToomas Soome FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord); 2915a1bf3f78SToomas Soome 2916a1bf3f78SToomas Soome /* 2917a1bf3f78SToomas Soome * Get xt. 2918a1bf3f78SToomas Soome * We need this *before* we save the stack pointer, or 2919a1bf3f78SToomas Soome * we'll have to pop one element out of the stack after 2920a1bf3f78SToomas Soome * an exception. I prefer to get done with it up front. :-) 2921a1bf3f78SToomas Soome */ 2922a1bf3f78SToomas Soome 2923a1bf3f78SToomas Soome FICL_STACK_CHECK(vm->dataStack, 1, 0); 2924a1bf3f78SToomas Soome 2925a1bf3f78SToomas Soome word = ficlStackPopPointer(vm->dataStack); 2926a1bf3f78SToomas Soome 2927a1bf3f78SToomas Soome /* 2928a1bf3f78SToomas Soome * Save vm's state -- a catch will not back out environmental 2929a1bf3f78SToomas Soome * changes. 2930a1bf3f78SToomas Soome * 2931a1bf3f78SToomas Soome * We are *not* saving dictionary state, since it is 2932a1bf3f78SToomas Soome * global instead of per vm, and we are not saving 2933a1bf3f78SToomas Soome * stack contents, since we are not required to (and, 2934a1bf3f78SToomas Soome * thus, it would be useless). We save vm, and vm 2935a1bf3f78SToomas Soome * "stacks" (a structure containing general information 2936a1bf3f78SToomas Soome * about it, including the current stack pointer). 2937a1bf3f78SToomas Soome */ 2938a1bf3f78SToomas Soome memcpy((void*)&vmCopy, (void*)vm, sizeof (ficlVm)); 2939a1bf3f78SToomas Soome memcpy((void*)&dataStackCopy, (void*)vm->dataStack, sizeof (ficlStack)); 2940a1bf3f78SToomas Soome memcpy((void*)&returnStackCopy, (void*)vm->returnStack, 2941a1bf3f78SToomas Soome sizeof (ficlStack)); 2942a1bf3f78SToomas Soome 2943a1bf3f78SToomas Soome /* 2944a1bf3f78SToomas Soome * Give vm a jmp_buf 2945a1bf3f78SToomas Soome */ 2946a1bf3f78SToomas Soome vm->exceptionHandler = &vmState; 2947a1bf3f78SToomas Soome 2948a1bf3f78SToomas Soome /* 2949a1bf3f78SToomas Soome * Safety net 2950a1bf3f78SToomas Soome */ 2951a1bf3f78SToomas Soome except = setjmp(vmState); 2952a1bf3f78SToomas Soome 2953a1bf3f78SToomas Soome switch (except) { 2954a1bf3f78SToomas Soome /* 2955a1bf3f78SToomas Soome * Setup condition - push poison pill so that the VM throws 2956a1bf3f78SToomas Soome * VM_INNEREXIT if the XT terminates normally, then execute 2957a1bf3f78SToomas Soome * the XT 2958a1bf3f78SToomas Soome */ 2959a1bf3f78SToomas Soome case 0: 2960a1bf3f78SToomas Soome /* Open mouth, insert emetic */ 2961a1bf3f78SToomas Soome ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord)); 2962a1bf3f78SToomas Soome ficlVmExecuteWord(vm, word); 2963a1bf3f78SToomas Soome ficlVmInnerLoop(vm, 0); 2964a1bf3f78SToomas Soome break; 2965a1bf3f78SToomas Soome 2966a1bf3f78SToomas Soome /* 2967a1bf3f78SToomas Soome * Normal exit from XT - lose the poison pill, 2968a1bf3f78SToomas Soome * restore old setjmp vector and push a zero. 2969a1bf3f78SToomas Soome */ 2970a1bf3f78SToomas Soome case FICL_VM_STATUS_INNER_EXIT: 2971a1bf3f78SToomas Soome ficlVmPopIP(vm); /* Gack - hurl poison pill */ 2972a1bf3f78SToomas Soome /* Restore just the setjmp vector */ 2973a1bf3f78SToomas Soome vm->exceptionHandler = vmCopy.exceptionHandler; 2974a1bf3f78SToomas Soome /* Push 0 -- everything is ok */ 2975a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 0); 2976a1bf3f78SToomas Soome break; 2977a1bf3f78SToomas Soome 2978a1bf3f78SToomas Soome /* 2979a1bf3f78SToomas Soome * Some other exception got thrown - restore pre-existing VM state 2980a1bf3f78SToomas Soome * and push the exception code 2981a1bf3f78SToomas Soome */ 2982a1bf3f78SToomas Soome default: 2983a1bf3f78SToomas Soome /* Restore vm's state */ 2984a1bf3f78SToomas Soome memcpy((void*)vm, (void*)&vmCopy, sizeof (ficlVm)); 2985a1bf3f78SToomas Soome memcpy((void*)vm->dataStack, (void*)&dataStackCopy, 2986a1bf3f78SToomas Soome sizeof (ficlStack)); 2987a1bf3f78SToomas Soome memcpy((void*)vm->returnStack, (void*)&returnStackCopy, 2988a1bf3f78SToomas Soome sizeof (ficlStack)); 2989a1bf3f78SToomas Soome 2990a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, except); /* Push error */ 2991a1bf3f78SToomas Soome break; 2992a1bf3f78SToomas Soome } 2993a1bf3f78SToomas Soome } 2994a1bf3f78SToomas Soome 2995a1bf3f78SToomas Soome /* 2996a1bf3f78SToomas Soome * t h r o w 2997a1bf3f78SToomas Soome * EXCEPTION 2998a1bf3f78SToomas Soome * Throw -- From ANS Forth standard. 2999a1bf3f78SToomas Soome * 3000a1bf3f78SToomas Soome * Throw takes the ToS and, if that's different from zero, 3001a1bf3f78SToomas Soome * returns to the last executed catch context. Further throws will 3002a1bf3f78SToomas Soome * unstack previously executed "catches", in LIFO mode. 3003a1bf3f78SToomas Soome * 3004a1bf3f78SToomas Soome * Daniel C. Sobral Jan 09/1999 3005a1bf3f78SToomas Soome */ 3006a1bf3f78SToomas Soome static void 3007a1bf3f78SToomas Soome ficlPrimitiveThrow(ficlVm *vm) 3008a1bf3f78SToomas Soome { 3009a1bf3f78SToomas Soome int except; 3010a1bf3f78SToomas Soome 3011a1bf3f78SToomas Soome except = ficlStackPopInteger(vm->dataStack); 3012a1bf3f78SToomas Soome 3013a1bf3f78SToomas Soome if (except) 3014a1bf3f78SToomas Soome ficlVmThrow(vm, except); 3015a1bf3f78SToomas Soome } 3016a1bf3f78SToomas Soome 3017a1bf3f78SToomas Soome /* 3018a1bf3f78SToomas Soome * a l l o c a t e 3019a1bf3f78SToomas Soome * MEMORY 3020a1bf3f78SToomas Soome */ 3021a1bf3f78SToomas Soome static void 3022a1bf3f78SToomas Soome ficlPrimitiveAllocate(ficlVm *vm) 3023a1bf3f78SToomas Soome { 3024a1bf3f78SToomas Soome size_t size; 3025a1bf3f78SToomas Soome void *p; 3026a1bf3f78SToomas Soome 3027a1bf3f78SToomas Soome size = ficlStackPopInteger(vm->dataStack); 3028a1bf3f78SToomas Soome p = ficlMalloc(size); 3029a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, p); 3030a1bf3f78SToomas Soome if (p != NULL) 3031a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 0); 3032a1bf3f78SToomas Soome else 3033a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 1); 3034a1bf3f78SToomas Soome } 3035a1bf3f78SToomas Soome 3036a1bf3f78SToomas Soome /* 3037a1bf3f78SToomas Soome * f r e e 3038a1bf3f78SToomas Soome * MEMORY 3039a1bf3f78SToomas Soome */ 3040a1bf3f78SToomas Soome static void 3041a1bf3f78SToomas Soome ficlPrimitiveFree(ficlVm *vm) 3042a1bf3f78SToomas Soome { 3043a1bf3f78SToomas Soome void *p; 3044a1bf3f78SToomas Soome 3045a1bf3f78SToomas Soome p = ficlStackPopPointer(vm->dataStack); 3046a1bf3f78SToomas Soome ficlFree(p); 3047a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 0); 3048a1bf3f78SToomas Soome } 3049a1bf3f78SToomas Soome 3050a1bf3f78SToomas Soome /* 3051a1bf3f78SToomas Soome * r e s i z e 3052a1bf3f78SToomas Soome * MEMORY 3053a1bf3f78SToomas Soome */ 3054a1bf3f78SToomas Soome static void 3055a1bf3f78SToomas Soome ficlPrimitiveResize(ficlVm *vm) 3056a1bf3f78SToomas Soome { 3057a1bf3f78SToomas Soome size_t size; 3058a1bf3f78SToomas Soome void *new, *old; 3059a1bf3f78SToomas Soome 3060a1bf3f78SToomas Soome size = ficlStackPopInteger(vm->dataStack); 3061a1bf3f78SToomas Soome old = ficlStackPopPointer(vm->dataStack); 3062a1bf3f78SToomas Soome new = ficlRealloc(old, size); 3063a1bf3f78SToomas Soome 3064a1bf3f78SToomas Soome if (new) { 3065a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, new); 3066a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 0); 3067a1bf3f78SToomas Soome } else { 3068a1bf3f78SToomas Soome ficlStackPushPointer(vm->dataStack, old); 3069a1bf3f78SToomas Soome ficlStackPushInteger(vm->dataStack, 1); 3070a1bf3f78SToomas Soome } 3071a1bf3f78SToomas Soome } 3072a1bf3f78SToomas Soome 3073a1bf3f78SToomas Soome /* 3074a1bf3f78SToomas Soome * e x i t - i n n e r 3075a1bf3f78SToomas Soome * Signals execXT that an inner loop has completed 3076a1bf3f78SToomas Soome */ 3077a1bf3f78SToomas Soome static void 3078a1bf3f78SToomas Soome ficlPrimitiveExitInner(ficlVm *vm) 3079a1bf3f78SToomas Soome { 3080a1bf3f78SToomas Soome ficlVmThrow(vm, FICL_VM_STATUS_INNER_EXIT); 3081a1bf3f78SToomas Soome } 3082a1bf3f78SToomas Soome 3083a1bf3f78SToomas Soome #if 0 3084a1bf3f78SToomas Soome static void 3085a1bf3f78SToomas Soome ficlPrimitiveName(ficlVm *vm) 3086a1bf3f78SToomas Soome { 3087a1bf3f78SToomas Soome FICL_IGNORE(vm); 3088a1bf3f78SToomas Soome } 3089a1bf3f78SToomas Soome #endif 3090a1bf3f78SToomas Soome 3091a1bf3f78SToomas Soome /* 3092a1bf3f78SToomas Soome * f i c l C o m p i l e C o r e 3093a1bf3f78SToomas Soome * Builds the primitive wordset and the environment-query namespace. 3094a1bf3f78SToomas Soome */ 3095a1bf3f78SToomas Soome void 3096a1bf3f78SToomas Soome ficlSystemCompileCore(ficlSystem *system) 3097a1bf3f78SToomas Soome { 3098a1bf3f78SToomas Soome ficlWord *interpret; 3099a1bf3f78SToomas Soome ficlDictionary *dictionary = ficlSystemGetDictionary(system); 3100a1bf3f78SToomas Soome ficlDictionary *environment = ficlSystemGetEnvironment(system); 3101a1bf3f78SToomas Soome 3102a1bf3f78SToomas Soome FICL_SYSTEM_ASSERT(system, dictionary); 3103a1bf3f78SToomas Soome FICL_SYSTEM_ASSERT(system, environment); 3104a1bf3f78SToomas Soome 3105a1bf3f78SToomas Soome #define FICL_TOKEN(token, description) 3106a1bf3f78SToomas Soome #define FICL_INSTRUCTION_TOKEN(token, description, flags) \ 3107a1bf3f78SToomas Soome ficlDictionarySetInstruction(dictionary, description, token, flags); 3108a1bf3f78SToomas Soome #include "ficltokens.h" 3109a1bf3f78SToomas Soome #undef FICL_TOKEN 3110a1bf3f78SToomas Soome #undef FICL_INSTRUCTION_TOKEN 3111a1bf3f78SToomas Soome 3112a1bf3f78SToomas Soome /* 3113a1bf3f78SToomas Soome * The Core word set 3114a1bf3f78SToomas Soome * see softcore.c for definitions of: abs bl space spaces abort" 3115a1bf3f78SToomas Soome */ 3116a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "#", ficlPrimitiveNumberSign, 3117a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3118a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "#>", 3119a1bf3f78SToomas Soome ficlPrimitiveNumberSignGreater, FICL_WORD_DEFAULT); 3120a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "#s", ficlPrimitiveNumberSignS, 3121a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3122a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "\'", ficlPrimitiveTick, 3123a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3124a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "(", ficlPrimitiveParenthesis, 3125a1bf3f78SToomas Soome FICL_WORD_IMMEDIATE); 3126a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "+loop", 3127a1bf3f78SToomas Soome ficlPrimitivePlusLoopCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3128a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ".", ficlPrimitiveDot, 3129a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3130a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ".\"", 3131a1bf3f78SToomas Soome ficlPrimitiveDotQuoteCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3132a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ":", ficlPrimitiveColon, 3133a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3134a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ";", ficlPrimitiveSemicolonCoIm, 3135a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3136a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "<#", 3137a1bf3f78SToomas Soome ficlPrimitiveLessNumberSign, FICL_WORD_DEFAULT); 3138a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ">body", ficlPrimitiveToBody, 3139a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3140a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ">in", ficlPrimitiveToIn, 3141a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3142a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ">number", ficlPrimitiveToNumber, 3143a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3144a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "abort", ficlPrimitiveAbort, 3145a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3146a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "accept", ficlPrimitiveAccept, 3147a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3148a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "align", ficlPrimitiveAlign, 3149a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3150a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "aligned", ficlPrimitiveAligned, 3151a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3152a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "allot", ficlPrimitiveAllot, 3153a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3154a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "base", ficlPrimitiveBase, 3155a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3156a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "begin", ficlPrimitiveBeginCoIm, 3157a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3158a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "case", ficlPrimitiveCaseCoIm, 3159a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3160a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "char", ficlPrimitiveChar, 3161a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3162a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "char+", ficlPrimitiveCharPlus, 3163a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3164a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "chars", ficlPrimitiveChars, 3165a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3166a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "constant", 3167a1bf3f78SToomas Soome ficlPrimitiveConstant, FICL_WORD_DEFAULT); 3168a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "count", ficlPrimitiveCount, 3169a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3170a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "cr", ficlPrimitiveCR, 3171a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3172a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "create", ficlPrimitiveCreate, 3173a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3174a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "decimal", ficlPrimitiveDecimal, 3175a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3176a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "depth", ficlPrimitiveDepth, 3177a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3178a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "do", ficlPrimitiveDoCoIm, 3179a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3180a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "does>", ficlPrimitiveDoesCoIm, 3181a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3182a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "else", ficlPrimitiveElseCoIm, 3183a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3184a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "emit", ficlPrimitiveEmit, 3185a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3186a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "endcase", 3187a1bf3f78SToomas Soome ficlPrimitiveEndcaseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3188a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "endof", ficlPrimitiveEndofCoIm, 3189a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3190a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "environment?", 3191a1bf3f78SToomas Soome ficlPrimitiveEnvironmentQ, FICL_WORD_DEFAULT); 3192a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "evaluate", 3193a1bf3f78SToomas Soome ficlPrimitiveEvaluate, FICL_WORD_DEFAULT); 3194a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "execute", ficlPrimitiveExecute, 3195a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3196a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "exit", ficlPrimitiveExitCoIm, 3197a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3198a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "fallthrough", 3199a1bf3f78SToomas Soome ficlPrimitiveFallthroughCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3200a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "find", ficlPrimitiveCFind, 3201a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3202a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "fm/mod", 3203a1bf3f78SToomas Soome ficlPrimitiveFMSlashMod, FICL_WORD_DEFAULT); 3204a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "here", ficlPrimitiveHere, 3205a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3206a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "hold", ficlPrimitiveHold, 3207a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3208a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "if", ficlPrimitiveIfCoIm, 3209a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3210a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "immediate", 3211a1bf3f78SToomas Soome ficlPrimitiveImmediate, FICL_WORD_DEFAULT); 3212a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "literal", 3213a1bf3f78SToomas Soome ficlPrimitiveLiteralIm, FICL_WORD_IMMEDIATE); 3214a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "loop", ficlPrimitiveLoopCoIm, 3215a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3216a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "m*", ficlPrimitiveMStar, 3217a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3218a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "mod", ficlPrimitiveMod, 3219a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3220a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "of", ficlPrimitiveOfCoIm, 3221a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3222a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "postpone", 3223a1bf3f78SToomas Soome ficlPrimitivePostponeCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3224a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "quit", ficlPrimitiveQuit, 3225a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3226a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "recurse", 3227a1bf3f78SToomas Soome ficlPrimitiveRecurseCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3228a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "repeat", 3229a1bf3f78SToomas Soome ficlPrimitiveRepeatCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3230a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "s\"", 3231a1bf3f78SToomas Soome ficlPrimitiveStringQuoteIm, FICL_WORD_IMMEDIATE); 3232a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "sign", ficlPrimitiveSign, 3233a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3234a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "sm/rem", 3235a1bf3f78SToomas Soome ficlPrimitiveSMSlashRem, FICL_WORD_DEFAULT); 3236a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "source", ficlPrimitiveSource, 3237a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3238a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "state", ficlPrimitiveState, 3239a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3240a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "then", ficlPrimitiveEndifCoIm, 3241a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3242a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "type", ficlPrimitiveType, 3243a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3244a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "u.", ficlPrimitiveUDot, 3245a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3246a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "um*", ficlPrimitiveUMStar, 3247a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3248a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "um/mod", 3249a1bf3f78SToomas Soome ficlPrimitiveUMSlashMod, FICL_WORD_DEFAULT); 3250a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "until", 3251a1bf3f78SToomas Soome ficlPrimitiveUntilCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3252a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "variable", 3253a1bf3f78SToomas Soome ficlPrimitiveVariable, FICL_WORD_DEFAULT); 3254a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "while", 3255a1bf3f78SToomas Soome ficlPrimitiveWhileCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3256a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "word", ficlPrimitiveWord, 3257a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3258a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "[", 3259a1bf3f78SToomas Soome ficlPrimitiveLeftBracketCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3260a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "[\']", 3261a1bf3f78SToomas Soome ficlPrimitiveBracketTickCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3262a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "[char]", ficlPrimitiveCharCoIm, 3263a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3264a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "]", ficlPrimitiveRightBracket, 3265a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3266a1bf3f78SToomas Soome /* 3267a1bf3f78SToomas Soome * The Core Extensions word set... 3268a1bf3f78SToomas Soome * see softcore.fr for other definitions 3269a1bf3f78SToomas Soome */ 3270a1bf3f78SToomas Soome /* "#tib" */ 3271a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ".(", ficlPrimitiveDotParen, 3272a1bf3f78SToomas Soome FICL_WORD_IMMEDIATE); 3273a1bf3f78SToomas Soome /* ".r" is in softcore */ 3274a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ":noname", 3275a1bf3f78SToomas Soome ficlPrimitiveColonNoName, FICL_WORD_DEFAULT); 3276a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "?do", ficlPrimitiveQDoCoIm, 3277a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3278a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "again", ficlPrimitiveAgainCoIm, 3279a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3280a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "c\"", 3281a1bf3f78SToomas Soome ficlPrimitiveCountedStringQuoteIm, FICL_WORD_IMMEDIATE); 3282a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "hex", ficlPrimitiveHex, 3283a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3284a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "pad", ficlPrimitivePad, 3285a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3286a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "parse", ficlPrimitiveParse, 3287a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3288a1bf3f78SToomas Soome 3289a1bf3f78SToomas Soome /* 3290a1bf3f78SToomas Soome * query restore-input save-input tib u.r u> unused 3291a1bf3f78SToomas Soome * [FICL_VM_STATE_COMPILE] 3292a1bf3f78SToomas Soome */ 3293a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "refill", ficlPrimitiveRefill, 3294a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3295a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "source-id", 3296a1bf3f78SToomas Soome ficlPrimitiveSourceID, FICL_WORD_DEFAULT); 3297a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "to", ficlPrimitiveToValue, 3298a1bf3f78SToomas Soome FICL_WORD_IMMEDIATE); 3299a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "value", ficlPrimitiveConstant, 3300a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3301a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "\\", ficlPrimitiveBackslash, 3302a1bf3f78SToomas Soome FICL_WORD_IMMEDIATE); 3303a1bf3f78SToomas Soome 3304a1bf3f78SToomas Soome /* 3305a1bf3f78SToomas Soome * Environment query values for the Core word set 3306a1bf3f78SToomas Soome */ 3307a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "/counted-string", 3308a1bf3f78SToomas Soome FICL_COUNTED_STRING_MAX); 3309a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "/hold", FICL_PAD_SIZE); 3310a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "/pad", FICL_PAD_SIZE); 3311a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "address-unit-bits", 8); 3312a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "core", FICL_TRUE); 3313a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "core-ext", FICL_FALSE); 3314a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "floored", FICL_FALSE); 3315a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "max-char", UCHAR_MAX); 3316a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "max-n", LONG_MAX); 3317a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "max-u", ULONG_MAX); 3318a1bf3f78SToomas Soome 3319a1bf3f78SToomas Soome { 3320a1bf3f78SToomas Soome ficl2Integer id; 3321a1bf3f78SToomas Soome ficlInteger low, high; 3322a1bf3f78SToomas Soome 3323a1bf3f78SToomas Soome low = ULONG_MAX; 3324a1bf3f78SToomas Soome high = LONG_MAX; 3325a1bf3f78SToomas Soome FICL_2INTEGER_SET(high, low, id); 3326a1bf3f78SToomas Soome ficlDictionarySet2Constant(environment, "max-d", id); 3327a1bf3f78SToomas Soome high = ULONG_MAX; 3328a1bf3f78SToomas Soome FICL_2INTEGER_SET(high, low, id); 3329a1bf3f78SToomas Soome ficlDictionarySet2Constant(environment, "max-ud", id); 3330a1bf3f78SToomas Soome } 3331a1bf3f78SToomas Soome 3332a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "return-stack-cells", 3333a1bf3f78SToomas Soome FICL_DEFAULT_STACK_SIZE); 3334a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "stack-cells", 3335a1bf3f78SToomas Soome FICL_DEFAULT_STACK_SIZE); 3336a1bf3f78SToomas Soome 3337a1bf3f78SToomas Soome /* 3338a1bf3f78SToomas Soome * The optional Double-Number word set (partial) 3339a1bf3f78SToomas Soome */ 3340a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "2constant", 3341a1bf3f78SToomas Soome ficlPrimitive2Constant, FICL_WORD_IMMEDIATE); 3342a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "2literal", 3343a1bf3f78SToomas Soome ficlPrimitive2LiteralIm, FICL_WORD_IMMEDIATE); 3344a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "2variable", 3345a1bf3f78SToomas Soome ficlPrimitive2Variable, FICL_WORD_IMMEDIATE); 3346a1bf3f78SToomas Soome /* 3347a1bf3f78SToomas Soome * D+ D- D. D.R D0< D0= D2* D2/ in softcore 3348a1bf3f78SToomas Soome * D< D= D>S DABS DMAX DMIN DNEGATE in softcore 3349a1bf3f78SToomas Soome * m-star-slash is TODO 3350a1bf3f78SToomas Soome * M+ in softcore 3351a1bf3f78SToomas Soome */ 3352a1bf3f78SToomas Soome 3353a1bf3f78SToomas Soome /* 3354a1bf3f78SToomas Soome * DOUBLE EXT 3355a1bf3f78SToomas Soome */ 3356a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "2rot", 3357a1bf3f78SToomas Soome ficlPrimitive2Rot, FICL_WORD_DEFAULT); 3358a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "2value", 3359a1bf3f78SToomas Soome ficlPrimitive2Constant, FICL_WORD_IMMEDIATE); 3360a1bf3f78SToomas Soome /* du< in softcore */ 3361a1bf3f78SToomas Soome /* 3362a1bf3f78SToomas Soome * The optional Exception and Exception Extensions word set 3363a1bf3f78SToomas Soome */ 3364a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "catch", ficlPrimitiveCatch, 3365a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3366a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "throw", ficlPrimitiveThrow, 3367a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3368a1bf3f78SToomas Soome 3369a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "exception", FICL_TRUE); 3370a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "exception-ext", FICL_TRUE); 3371a1bf3f78SToomas Soome 3372a1bf3f78SToomas Soome /* 3373a1bf3f78SToomas Soome * The optional Locals and Locals Extensions word set 3374a1bf3f78SToomas Soome * see softcore.c for implementation of locals| 3375a1bf3f78SToomas Soome */ 3376a1bf3f78SToomas Soome #if FICL_WANT_LOCALS 3377a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "doLocal", 3378a1bf3f78SToomas Soome ficlPrimitiveDoLocalIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3379a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "(local)", 3380a1bf3f78SToomas Soome ficlPrimitiveLocalParen, FICL_WORD_COMPILE_ONLY); 3381a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "(2local)", 3382a1bf3f78SToomas Soome ficlPrimitive2LocalParen, FICL_WORD_COMPILE_ONLY); 3383a1bf3f78SToomas Soome 3384a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "locals", FICL_TRUE); 3385a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "locals-ext", FICL_TRUE); 3386a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "#locals", FICL_MAX_LOCALS); 3387a1bf3f78SToomas Soome #endif 3388a1bf3f78SToomas Soome 3389a1bf3f78SToomas Soome /* 3390a1bf3f78SToomas Soome * The optional Memory-Allocation word set 3391a1bf3f78SToomas Soome */ 3392a1bf3f78SToomas Soome 3393a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "allocate", 3394a1bf3f78SToomas Soome ficlPrimitiveAllocate, FICL_WORD_DEFAULT); 3395a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "free", ficlPrimitiveFree, 3396a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3397a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "resize", ficlPrimitiveResize, 3398a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3399a1bf3f78SToomas Soome 3400a1bf3f78SToomas Soome ficlDictionarySetConstant(environment, "memory-alloc", FICL_TRUE); 3401a1bf3f78SToomas Soome 3402a1bf3f78SToomas Soome /* 3403a1bf3f78SToomas Soome * The optional Search-Order word set 3404a1bf3f78SToomas Soome */ 3405a1bf3f78SToomas Soome ficlSystemCompileSearch(system); 3406a1bf3f78SToomas Soome 3407a1bf3f78SToomas Soome /* 3408a1bf3f78SToomas Soome * The optional Programming-Tools and Programming-Tools 3409a1bf3f78SToomas Soome * Extensions word set 3410a1bf3f78SToomas Soome */ 3411a1bf3f78SToomas Soome ficlSystemCompileTools(system); 3412a1bf3f78SToomas Soome 3413a1bf3f78SToomas Soome /* 3414a1bf3f78SToomas Soome * The optional File-Access and File-Access Extensions word set 3415a1bf3f78SToomas Soome */ 3416a1bf3f78SToomas Soome #if FICL_WANT_FILE 3417a1bf3f78SToomas Soome ficlSystemCompileFile(system); 3418a1bf3f78SToomas Soome #endif 3419a1bf3f78SToomas Soome 3420a1bf3f78SToomas Soome /* 3421a1bf3f78SToomas Soome * Ficl extras 3422a1bf3f78SToomas Soome */ 3423a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ".ver", ficlPrimitiveVersion, 3424a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3425a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, ">name", ficlPrimitiveToName, 3426a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3427a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "add-parse-step", 3428a1bf3f78SToomas Soome ficlPrimitiveAddParseStep, FICL_WORD_DEFAULT); 3429a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "body>", ficlPrimitiveFromBody, 3430a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3431a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "compile-only", 3432a1bf3f78SToomas Soome ficlPrimitiveCompileOnly, FICL_WORD_DEFAULT); 3433a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "endif", ficlPrimitiveEndifCoIm, 3434a1bf3f78SToomas Soome FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3435a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "last-word", 3436a1bf3f78SToomas Soome ficlPrimitiveLastWord, FICL_WORD_DEFAULT); 3437a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "hash", ficlPrimitiveHash, 3438a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3439a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "objectify", 3440a1bf3f78SToomas Soome ficlPrimitiveSetObjectFlag, FICL_WORD_DEFAULT); 3441a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "?object", 3442a1bf3f78SToomas Soome ficlPrimitiveIsObject, FICL_WORD_DEFAULT); 3443a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "parse-word", 3444a1bf3f78SToomas Soome ficlPrimitiveParseNoCopy, FICL_WORD_DEFAULT); 3445a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "sfind", ficlPrimitiveSFind, 3446a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3447a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "sliteral", 3448a1bf3f78SToomas Soome ficlPrimitiveSLiteralCoIm, FICL_WORD_COMPILE_ONLY_IMMEDIATE); 3449a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "sprintf", ficlPrimitiveSprintf, 3450a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3451a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "strlen", ficlPrimitiveStrlen, 3452a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3453a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "x.", ficlPrimitiveHexDot, 3454a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3455a1bf3f78SToomas Soome #if FICL_WANT_USER 3456a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "user", ficlPrimitiveUser, 3457a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3458a1bf3f78SToomas Soome #endif 3459a1bf3f78SToomas Soome 3460a1bf3f78SToomas Soome /* 3461a1bf3f78SToomas Soome * internal support words 3462a1bf3f78SToomas Soome */ 3463a1bf3f78SToomas Soome interpret = ficlDictionarySetPrimitive(dictionary, "interpret", 3464a1bf3f78SToomas Soome ficlPrimitiveInterpret, FICL_WORD_DEFAULT); 3465a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "lookup", ficlPrimitiveLookup, 3466a1bf3f78SToomas Soome FICL_WORD_DEFAULT); 3467a1bf3f78SToomas Soome ficlDictionarySetPrimitive(dictionary, "(parse-step)", 3468a1bf3f78SToomas Soome ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT); 3469a1bf3f78SToomas Soome system->exitInnerWord = ficlDictionarySetPrimitive(dictionary, 3470a1bf3f78SToomas Soome "exit-inner", ficlPrimitiveExitInner, FICL_WORD_DEFAULT); 3471a1bf3f78SToomas Soome 3472a1bf3f78SToomas Soome /* 3473a1bf3f78SToomas Soome * Set constants representing the internal instruction words 3474a1bf3f78SToomas Soome * If you want all of 'em, turn that "#if 0" to "#if 1". 3475a1bf3f78SToomas Soome * By default you only get the numbers (fi0, fiNeg1, etc). 3476a1bf3f78SToomas Soome */ 3477a1bf3f78SToomas Soome #define FICL_TOKEN(token, description) \ 3478a1bf3f78SToomas Soome ficlDictionarySetConstant(dictionary, #token, token); 3479a1bf3f78SToomas Soome #if 0 3480a1bf3f78SToomas Soome #define FICL_INSTRUCTION_TOKEN(token, description, flags) \ 3481a1bf3f78SToomas Soome ficlDictionarySetConstant(dictionary, #token, token); 3482a1bf3f78SToomas Soome #else 3483a1bf3f78SToomas Soome #define FICL_INSTRUCTION_TOKEN(token, description, flags) 3484a1bf3f78SToomas Soome #endif /* 0 */ 3485a1bf3f78SToomas Soome #include "ficltokens.h" 3486a1bf3f78SToomas Soome #undef FICL_TOKEN 3487a1bf3f78SToomas Soome #undef FICL_INSTRUCTION_TOKEN 3488a1bf3f78SToomas Soome 3489a1bf3f78SToomas Soome /* 3490a1bf3f78SToomas Soome * Set up system's outer interpreter loop - maybe this should 3491a1bf3f78SToomas Soome * be in initSystem? 3492a1bf3f78SToomas Soome */ 3493a1bf3f78SToomas Soome system->interpreterLoop[0] = interpret; 3494a1bf3f78SToomas Soome system->interpreterLoop[1] = (ficlWord *)ficlInstructionBranchParen; 3495a1bf3f78SToomas Soome system->interpreterLoop[2] = (ficlWord *)(void *)(-2); 3496a1bf3f78SToomas Soome 3497a1bf3f78SToomas Soome FICL_SYSTEM_ASSERT(system, 3498a1bf3f78SToomas Soome ficlDictionaryCellsAvailable(dictionary) > 0); 3499a1bf3f78SToomas Soome } 3500