--- /dev/null
+OPTIMIZE = -O2
+CC = gcc
+MATHLIB = -lm
+
+OBJECTS = block.o blocke.o core.o coree.o double.o doublee.o exceptio.o \
+ facility.o file.o filee.o float.o floate.o locals.o localse.o \
+ memall.o search.o searche.o string.o tools.o toolse.o \
+ udio.o vm.o ycore.o yfinit.o yforth.o yfvinit.o
+
+INCLUDES = block.h blocke.h config.h core.h coree.h defaults.h double.h \
+ doublee.h errors.h exceptio.h facility.h file.h filee.h float.h \
+ floate.h locals.h localse.h macro.h memall.h search.h searche.h \
+ string.h tools.h toolse.h udio.h ver.h ycore.h yforth.h
+
+all:
+ make div
+ make yforth
+
+yforth: $(OBJECTS)
+ $(CC) $(MATHLIB) -o yforth $(OBJECTS)
+
+div: division.c
+ $(CC) -o div division.c
+ div > div.h
+
+.c.o:
+ $(CC) -c -o $@ $(OPTIMIZE) $<
+
+clean:
+ rm -f *.o yforth div.h div
--- /dev/null
+yForth? v0.1beta - READ THIS (AND ONLY THIS) TO GET yForth? RUNNING.
+
+0) Hello world!
+Here's a little file which will help you having yForth? running in few
+minutes on your system.
+
+1) What's yForth? ?
+yForth? is a Forth environment written entirely in ANSI C, making it
+extremely portable. The first thing I want to tell you about yForth? is
+that it seems a joke compared to other systems such as gForth or PFE.
+The only things it has in common with PFE are that it's written in C, and
+it's been written for fun.
+It's rude, it hasn't anything odd, there's no reason to choose yForth? instead
+of other Forth environments.
+Nevertheless, you could find yForth? nice, in this case you're invited to
+explore yForth? in the following lines.
+yForth? is based on the draft of ANS Forth, but it's NOT complete.
+The reason is very simple: not all the words included in ANS Forth can be
+written using only ANSI C. In particular, those words which interact with
+system hardware almost directly, such as words which control the terminal,
+can't be written using solely ANSI C (and related libraries).
+In fact, you'll find that all the device dependent routines are grouped
+together in the file "udio.c". If you're using Turbo C, Borland C, or any
+compiler which supplies the "conio.h", you can define HAVE_CONIO in
+your "config.h" file and go.
+Note that even if in file "udio.c" you'll see some lines telling you:
+#ifdef HAVE_CURSES
+or similar, yForth? actually doesn't support CURSES library. I've decided to
+stop my work as soon as something machine depended that was too messy has
+came around.
+
+2) Where does the name yForth? came from?
+I've been charmed by Forth since the first time I "played" with it, but
+I've never been able to find some book (here in Italy, obviously) to learn it.
+When I've put my hands on the draft of ANS Forth I thought that
+the best way to learn it was to write an environment. I was wondering what
+features made Forth so popular. I asked myself: Why Forth?
+
+3) How do I compile yForth? for my system?
+It's simple. First of all you'll have to modify "config.h" accordingly with
+your system AND compiler requirements. In order:
+- modules
+You can exclude some modules to make a smaller environment, but keep
+in mind that all the modules will be compiled anyway. You must rely on
+your compiler "smart-linking" to cut off unused functions.
+- big/little endian
+Define LITTLE_ENDIAN if your machine "is" little-endian (e.g. Intel),
+undefine it if it's big-endian (e.g. Motorola, SPARC).
+- double-cell transfer
+You can choose two ways for moving a DCell data from data stack to C internal
+variables. If DCELL_MEM is defined moving is performed via memory copy,
+if it's undefined moving is performed via shift operators (<< and >>).
+- data types
+The most important thing is choosing what C types will identify Cells and
+Double Cells in yForth?. Be sure that 2 * sizeof(Cell) == sizeof(DCell).
+Note that using GCC makes this things trivial, since it has a "long long"
+type which allows having 32bit Cells. Using Turbo C that's not possible.
+Below data definition you'll have to change the maximum values of your
+system. See "limits.h".
+- terminal
+Finally, define HAVE_CONIO if you're using Turbo C, Borland C or GCC for DOS.
+You'll have some nice words such as "page"...
+- special functions
+"asinh", "acosh", "atanh" aren't provided by all the libraries, if you don't
+have them delete the definitions at the end of "config.h".
+
+The second thing to do now is configuring the "Makefile". I know, it's rude,
+but yForth? is drifting on my system for too long, I want to finish it
+within 1996.
+At the moment "Makefile" is ready for GCC (under Linux), it's simple and
+you won't find any problem modifying it.
+
+Third, type "make all". Yes, that's all.
+
+4) I have yForth? running, and now?
+It's your, you can make anything you want with. If you want an explanation
+of the words provided by yForth? please refer to the draft of ANS Forth or
+something equivalent. The Net will help you.
+Do not expect the prompt "ok" to come up when you run yForth?, the standard
+says that "ok" shall be printed AFTER every succesful command execution...
+
+5) What about yForth? in 1997?
+Well, I think yForth? will be available since January 1997, and at the moment
+I've no idea of some future developlment. I've learned a lot writing it, both
+Forth and C, but I can't say I've learned programming in Forth.
+Ideas come and go, now they're all gone. But don't despair, if you have some
+fantastic intuition you want to share, email me, I'll listen to you!
+Furthermore, this package is still incomplete. The source code can be better
+organized, more documentation could be written, and so on. If you want to
+work on it, you can, and I'd be happy to work together to make some improvement.
+
+6) Hey, just a moment!
+Don't forget:
+ - yForth? is a "beta" release, I think it has bugs, but, most
+ important, I'm afraid that some words don't behave as the
+ standard says they have to.
+ - yForth? comes with no warranty, I don't make any warranty about it.
+ - yForth? is completely free. You can use, modify, doing anything
+ you want with it. If you're going to use it in any project,
+ I would be grateful if you cite me, but you're no obliged.
+ - yForth? is NOT a complete ANS Forth.
+ - yForth? is written in ANSI C. Ok, you could see some warning while
+ compiling it, and I've to check it with lint, but it
+ doesn't make use of any capability other than those provided
+ by the standard (well, "long long" doesn't belong to the
+ standard, but you're anxious to work whit 32bit Cells,
+ aren't you?).
+ - yForth? comes with it's nice logo (yforthlogo.gif).
+ - yForth? comes with some word not included in ANS Forth. The most
+ useful ones are those you find in "ycore.c". Each comes with
+ a short description just before its implementation.
+ - yForth? may not support "page" on systems where "conio.h" is unknown.
+ Since I love clearing screens, here's a little tip, define:
+ : page s" clear" system drop ;
+ And you'll have "page" working on your Unix system.
+
+7) Please report bugs
+I'll be very happy if you report me some bug. Obviously I'll be happy even
+more if you tell me how fo fix it, but I can't pretend so much, even 'cause
+my C is not very readable (few comments...).
+
+8) Who am I?
+Luca Padovani
+v. Cormons, 12
+48100 Ravenna (RA)
+Italy
+
+email: lpadovan@cs.unibo.it
+
+Enjoy yForth?
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: block.c
+ * Abstract: Block word set implementation
+ */
+
+#include <stdio.h>
+#include <malloc.h>
+#include "yforth.h"
+#include "core.h"
+#include "block.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+UCell _b_l_k;
+UCell current_block;
+
+FILE *block_file; /* FILE used to implement blocks */
+
+struct _block_data *block_data;
+struct _block_buffer *block_buffer;
+
+static int block_clock; /* Used to select the next block to
+ deallocate. Based on the "clock
+ algorithm
+ */
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _block() {
+ register UCell u = (UCell) *sp;
+ register int b = search_block(u);
+ if (b < 0) b = allocate_block(u, 1);
+ current_block = b;
+ sp[0] = (Cell) &block_buffer[b].buffer;
+}
+
+void _buffer() {
+ register UCell u = (UCell) *sp;
+ register int b = search_block(u);
+ if (b < 0) b = allocate_block(u, 0);
+ current_block = b;
+ sp[0] = (Cell) &block_buffer[b].buffer;
+}
+
+void _flush() {
+ register int i;
+ _save_buffers();
+ for (i = 0; i < NUM_BLOCKS; i++) block_data[i].block_no = 0;
+}
+
+void _load() {
+ register UCell block_no = (UCell) *sp;
+ save_input_specification();
+ _block();
+ _input_buffer = (Char *) *sp++;
+ _in_input_buffer = BLOCK_SIZE;
+ _to_in = 0;
+ _b_l_k = block_no;
+ _interpret();
+ restore_input_specification();
+}
+
+void _save_buffers() {
+ register int i;
+ for (i = 0; i < NUM_BLOCKS; i++) if (block_data[i].dirty) save_block(i);
+}
+
+void _update() {
+ block_data[current_block].dirty = 1;
+}
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS ****************************************************/
+/**************************************************************************/
+
+int search_block(UCell block_no) {
+ register int i;
+ for (i = 0; i < NUM_BLOCKS && block_data[i].block_no != block_no; i++) ;
+ return (i < NUM_BLOCKS ? i : -1);
+}
+
+int allocate_block(UCell block_no, int load) {
+ register int i;
+ register int b = search_block(0);
+ if (b < 0) {
+ if (block_data[block_clock].dirty) save_block(block_clock);
+ b = block_clock;
+ block_clock = (block_clock + 1) % NUM_BLOCKS;
+ }
+ if (load) load_block(block_no, b);
+ return (b);
+}
+
+void load_block(UCell block_no, int b) {
+ block_data[b].block_no = block_no;
+ block_data[b].dirty = 0;
+ fseek(block_file, ((long) (block_no - 1)) * BLOCK_SIZE, SEEK_SET);
+ fread(&block_buffer[b].buffer, BLOCK_SIZE, 1, block_file);
+}
+
+void save_block(int b) {
+ fseek(block_file, ((long) (block_data[b].block_no - 1)) * BLOCK_SIZE, SEEK_SET);
+ fwrite(&block_buffer[b].buffer, BLOCK_SIZE, 1, block_file);
+ block_data[b].dirty = 0;
+}
+
+int open_block_file(char *name) {
+ block_file = fopen(name, "r+b");
+ if (!block_file) block_file = fopen(name, "r+b");
+ if (block_file) {
+ block_data = (struct _block_data *) malloc(NUM_BLOCKS * sizeof(struct _block_data));
+ block_buffer = (struct _block_buffer *) malloc(NUM_BLOCKS * sizeof(struct _block_buffer));
+ if (block_data && block_buffer) {
+ int i;
+ for (i = 0; i < NUM_BLOCKS; i++) block_data[i].block_no = 0;
+ } else block_file = NULL;
+ }
+ return (block_file ? 0 : -1);
+}
+
+void close_block_file() {
+ if (block_file) {
+ _save_buffers();
+ fclose(block_file);
+ }
+}
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: block.h
+ * Abstract: Block word set header file
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __BLOCK_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __BLOCK_H__
+#define __BLOCK_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+#ifdef PROTOTYPES
+
+struct _block_data { /* Entry in the table of blocks */
+ UCell block_no; /* Block number */
+ Cell dirty; /* Block updated */
+};
+
+struct _block_buffer { /* Simply an array of Char */
+ Char buffer[BLOCK_SIZE];
+};
+
+extern FILE *block_file;
+
+extern struct _block_data *block_data;
+extern struct _block_buffer *block_buffer;
+
+extern UCell current_block;
+
+#endif
+
+variable(UCell, b_l_k, "blk")
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(block, "block", 0)
+code(buffer, "buffer", 0)
+code(flush, "flush", 0)
+code(load, "load", 0)
+code(save_buffers, "save-buffers", 0)
+code(update, "update", 0)
+
+#ifdef PROTOTYPES
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS PROTOTYPES *****************************************/
+/**************************************************************************/
+
+int search_block(UCell block_no);
+int allocate_block(UCell block_no, int load);
+void load_block(UCell block_no, int b);
+void save_block(int b);
+int open_block_file(char *name);
+void close_block_file(void);
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: blocke.c
+ * Abstract: Block extension word set
+ */
+
+#include <stdio.h>
+#include "yforth.h"
+#include "core.h"
+#include "coree.h"
+#include "block.h"
+#include "blocke.h"
+
+/**************************************************************************/
+/* VARIABLES ************** ***********************************************/
+/**************************************************************************/
+
+UCell _s_c_r;
+
+/**************************************************************************/
+/* WORDS ****************** ***********************************************/
+/**************************************************************************/
+
+void _empty_buffers() {
+ register int i;
+ for (i = 0; i < NUM_BLOCKS; i++) block_data[i].block_no = 0;
+}
+
+void _list() {
+ register Char *buffer;
+ register int i;
+ _block();
+ buffer = (Char *) *sp++;
+ for (i = 0; i < BLOCK_SIZE; i += 64) {
+ *--sp = i / 64;
+ *--sp = 2;
+ _dot_r();
+ *--sp = ':';
+ _emit();
+ _b_l();
+ _emit();
+ *--sp = (Cell) buffer + i;
+ *--sp = 64;
+ _type();
+ _c_r();
+ }
+}
+
+void _thru() {
+ register UCell u2 = (UCell) *sp++;
+ register UCell u1 = (UCell) *sp++;
+ for (; u1 <= u2; u1++) {
+ *--sp = u1;
+ _load();
+ }
+}
+
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: blocke.h
+ * Abstract: Block extension include file
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __BLOCKE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __BLOCKE_H__
+#define __BLOCKE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+variable(UCell, s_c_r, "scr")
+
+/**************************************************************************/
+/* PORTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(empty_buffers, "empty-buffers", 0)
+code(list, "list", 0)
+code(thru, "thru", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
+
+
+
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: config.h
+ * Abstract: configuration file. Before any compilation please check
+ * that actual configuration is consistent with your
+ * hardware AND your compiler.
+ */
+
+/* module definition: 1 indicates that a module should be included in the
+ * base vocabulary, 0 excludes a module. Note however that some words in
+ * excluded word lists may be linked to final code if used by other words.
+ */
+
+#define COREE_DEF 1L
+#define DOUBLE_DEF 1L
+#define DOUBLEE_DEF 1L
+#define FLOAT_DEF 1L
+#define FLOATE_DEF 1L
+#define MEMALL_DEF 1L
+#define MEMALLE_DEF 0L
+#define SEARCH_DEF 1L
+#define SEARCHE_DEF 1L
+#define TOOLS_DEF 1L
+#define TOOLSE_DEF 1L
+#define LOCALS_DEF 1L
+#define LOCALSE_DEF 1L
+#define FACILITY_DEF 1L
+#define FACILITYE_DEF 0L
+#define BLOCK_DEF 1L
+#define BLOCKE_DEF 1L
+#define EXCEPTION_DEF 1L
+#define EXCEPTIONE_DEF 0L
+#define FILE_DEF 1L
+#define FILEE_DEF 1L
+#define STRING_DEF 1L
+#define STRINGE_DEF 0L
+
+#define VERSION_PATTERN (COREE_DEF | (DOUBLE_DEF << 1) |\
+ (DOUBLEE_DEF << 2) | (FLOAT_DEF << 3) |\
+ (FLOATE_DEF << 4) | (MEMALL_DEF << 5) |\
+ (MEMALLE_DEF << 6) | (SEARCH_DEF << 7) |\
+ (SEARCHE_DEF << 8) | (TOOLS_DEF << 9) |\
+ (TOOLSE_DEF << 10) | (LOCALS_DEF << 11) |\
+ (LOCALSE_DEF << 12) | (FACILITY_DEF << 13) |\
+ (FACILITYE_DEF << 14) | (BLOCK_DEF << 15) |\
+ (BLOCKE_DEF << 16) | (EXCEPTION_DEF << 17) |\
+ (EXCEPTIONE_DEF << 18) | (FILE_DEF << 19) |\
+ (FILEE_DEF << 20) | (STRING_DEF << 21) |\
+ (STRINGE_DEF << 22)\
+ )
+
+/************************************************************************/
+/* compilation and machine dependent definitions */
+/************************************************************************/
+
+/* Define LITTLE_ENDIAN if you machine is little-endian (e.g. Intel), undefine
+ * it if your machine is big-endian (e.g. Motorola, Sparc...)
+ * Note that some compilers have LITTLE_ENDIAN yet defined.
+ */
+#ifndef LITTLE_ENDIAN
+# define LITTLE_ENDIAN
+#endif
+
+/* When DCELL_MEM is defined, double cell transfer is realized by memory
+ * copy, if not defined shift and logical operators are used to combine
+ * or isolate cell values
+ */
+#define DCELL_MEM
+
+/* DATA TYPES: please modify this list accordingly to your system. Note that
+ * sizeof(DCell) == 2 * sizeof(Cell) MUST BE satisfied.
+ * For example, using Borland C for DOS Cell may be "int" and DCell "long int".
+ * Under Linux, Cell may be "int" and DCell "long long".
+ */
+
+#define Cell int
+#define Char char
+#define Real long double
+
+#define UCell unsigned Cell
+#define DCell long long
+#define UDCell unsigned DCell
+#define UChar unsigned Char
+
+#define CellBits (sizeof(Cell) * 8)
+#define CellLog (sizeof(Cell) - 1)
+#define RealLog (sizeof(Real) - 1)
+
+#define FFLAG(n) (-(n))
+
+/* Please modify this definitions accordingly with your data types */
+
+#define MAX_CHAR UCHAR_MAX
+#define MAX_D LONG_MAX
+#define MAX_N INT_MAX
+#define MAX_U UINT_MAX
+#define MAX_UD ULONG_MAX
+#define MAX_F 0.0
+
+/* Some compilers doesn't provide some functions in the standard library.
+ * If you don't have, undefine them
+ */
+#define HAVE_ACOSH
+#define HAVE_ASINH
+#define HAVE_ATANH
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: core.c
+ * Abstract: Core word set
+ */
+
+#include <string.h>
+#include <setjmp.h>
+#include <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "yforth.h"
+#include "udio.h"
+#include "core.h"
+#include "coree.h"
+#include "float.h"
+#include "double.h"
+#include "toolse.h"
+#include "locals.h"
+#include "block.h"
+#include "exceptio.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+Char s_tmp_buffer[TMP_BUFFER_SIZE]; /* used by s" */
+
+Cell _to_in; /* ptr to parse area */
+Cell _source_id; /* input source device */
+Char * _tib; /* ptr to terminal input buffer */
+Char * _input_buffer; /* current input buffer */
+Cell _in_input_buffer; /* # of chars in input buffer */
+Cell _base; /* base is base */
+Char * _dp; /* dictionary pointer */
+Cell _error; /* error code */
+struct word_def * _last; /* ptr to last defined word */
+Cell _state; /* state of the interpreter */
+Cell _check_system = 1; /* 1 => check stacks overflow & underflow */
+ /* Some variables used by environment? follows... */
+Cell _env_slash_counted_string;
+Cell _env_slash_hold;
+Cell _env_slash_pad;
+Cell _env_address_unit_bits;
+Cell _env_core;
+Cell _env_core_ext;
+Cell _env_floored;
+Cell _env_max_char;
+Cell _env_max_d;
+Cell _env_max_n;
+Cell _env_max_u;
+Cell _env_max_ud;
+Cell _env_return_stack_cells;
+Cell _env_stack_cells;
+Cell _env_double;
+Cell _env_double_ext;
+Cell _env_floating;
+Cell _env_floating_stack;
+Cell _env_max_float;
+Cell _env_floating_ext;
+Cell _env_memory_alloc;
+Cell _env_memory_alloc_ext;
+Cell _env_search_order;
+Cell _env_search_order_ext;
+Cell _env_wordlists;
+Cell _env_tools;
+Cell _env_tools_ext;
+Cell _env_number_locals;
+Cell _env_locals;
+Cell _env_locals_ext;
+Cell _env_facility;
+Cell _env_facility_ext;
+Cell _env_block;
+Cell _env_block_ext;
+Cell _env_exception;
+Cell _env_exception_ext;
+Cell _env_file;
+Cell _env_file_ext;
+Cell _env_string;
+Cell _env_string_ext;
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _dot_quote() {
+ compile_cell((Cell) _paren_dot_quote_paren);
+ *--sp = '"';
+ _word();
+ _dp = (Char *) WORD_PTR(_dp);
+ sp++;
+}
+
+void _paren_dot_quote_paren() {
+ register Char *addr = (Char *) ip;
+ *--sp = (Cell) (addr + 1);
+ *--sp = (Cell) *addr;
+ _type();
+ ip = (pfp *) WORD_PTR((Char *) ip);
+}
+
+void _type() {
+ register Cell u = *sp++;
+ register Char *addr = (Char *) *sp++;
+ while (u--) putchar(*addr++);
+}
+
+void _u_dot() {
+ *--sp = 0;
+ _less_number_sign();
+ _number_sign_s();
+ _number_sign_greater();
+ _type();
+ putchar(' ');
+}
+
+void _c_r() {
+ putchar('\n');
+}
+
+void _emit() {
+ putchar(*sp++);
+}
+
+#ifdef DOUBLE_DEF
+void _dot() {
+ _s_to_d();
+ _d_dot();
+}
+#else
+void _dot() {
+ register DCell u = *sp;
+ register int usign = u < 0;
+ if (usign) u = -u;
+ sp--;
+ PUT_DCELL(sp, u);
+ _less_number_sign();
+ _number_sign_s();
+ if (usign) {
+ *--sp = '-';
+ _hold();
+ }
+ _number_sign_greater();
+ _type();
+ putchar(' ');
+}
+#endif
+
+void _space() {
+ putchar(' ');
+}
+
+void _spaces() {
+ register UCell u = *sp++;
+ while (u--) putchar(' ');
+}
+
+void _less_number_sign() {
+ in_pnos = 0;
+ p_pnos = pnos + pnos_size;
+}
+
+void _number_sign() {
+ register UDCell ud1 = GET_DCELL(sp);
+ register int rem = ud1 % _base;
+ ud1 /= _base;
+ PUT_DCELL(sp, ud1);
+ if (rem < 10) *--p_pnos = rem + '0';
+ else *--p_pnos = rem - 10 + 'a';
+ in_pnos++;
+}
+
+void _hold() {
+ register Char ch = (Char) *sp++;
+ *--p_pnos = ch;
+ in_pnos++;
+}
+
+void _number_sign_s() {
+ do _number_sign();
+ while (sp[0] || sp[1]);
+}
+
+void _number_sign_greater() {
+ sp[1] = (Cell) p_pnos;
+ sp[0] = in_pnos;
+}
+
+void _store() {
+ register Cell *addr = (Cell *) *sp++;
+ *addr = *sp++;
+}
+
+void _star() {
+ sp[1] *= *sp;
+ sp++;
+}
+
+void _star_slash() {
+ register DCell d = (DCell) sp[1] * (DCell) sp[2];
+ sp[2] = d / (DCell) sp[0];
+ sp += 2;
+}
+
+void _star_slash_mod() {
+ register DCell d = (DCell) sp[1] * (DCell) sp[2];
+ sp[2] = d % (DCell) sp[0];
+ sp[1] = d / (DCell) sp[0];
+ sp++;
+}
+
+void _plus() {
+ sp[1] += sp[0];
+ sp++;
+}
+
+void _plus_store() {
+ register Cell *addr = (Cell *) *sp++;
+ *addr += *sp++;
+}
+
+void _minus() {
+ sp[1] -= sp[0];
+ sp++;
+}
+
+void _slash() {
+ sp[1] /= sp[0];
+ sp++;
+}
+
+void _slash_mod() {
+ register Cell n1 = sp[1];
+ register Cell n2 = sp[0];
+ sp[1] = n1 % n2;
+ sp[0] = n1 / n2;
+}
+
+void _zero_less() {
+ sp[0] = FFLAG(sp[0] < 0);
+}
+
+void _zero_equals() {
+ sp[0] = FFLAG(sp[0] == 0);
+}
+
+void _one_plus() {
+ sp[0]++;
+}
+
+void _one_minus() {
+ sp[0]--;
+}
+
+void _two_store() {
+ register Cell *addr = (Cell *) *sp++;
+ *addr++ = *sp++;
+ *addr = *sp++;
+}
+
+void _two_star() {
+ sp[0] <<= 1;
+}
+
+void _two_slash() {
+ sp[0] >>= 1;
+}
+
+void _two_fetch() {
+ register Cell *addr = (Cell *) *sp;
+ *sp-- = *(addr + 1);
+ *sp = *addr;
+}
+
+void _two_drop() {
+ sp += 2;
+}
+
+void _two_dupe() {
+ sp -= 2;
+ sp[0] = sp[2];
+ sp[1] = sp[3];
+}
+
+void _two_over() {
+ sp -= 2;
+ sp[0] = sp[4];
+ sp[1] = sp[5];
+}
+
+void _two_swap() {
+ register Cell x4 = sp[0];
+ register Cell x3 = sp[1];
+ sp[0] = sp[2];
+ sp[1] = sp[3];
+ sp[2] = x4;
+ sp[3] = x3;
+}
+
+void _less_than() {
+ sp[1] = FFLAG(sp[1] < sp[0]);
+ sp++;
+}
+
+void _equals() {
+ sp[1] = FFLAG(sp[1] == sp[0]);
+ sp++;
+}
+
+void _greater_than() {
+ sp[1] = FFLAG(sp[1] > sp[0]);
+ sp++;
+}
+
+void _to_r() {
+ *--rp = *sp++;
+}
+
+void _question_dupe() {
+ if (sp[0]) sp--, sp[0] = sp[1];
+}
+
+void _fetch() {
+ sp[0] = *((Cell *) sp[0]);
+}
+
+void _abs() {
+ register Cell n = sp[0];
+ sp[0] = n >= 0 ? n : -n;
+}
+
+void _align() {
+ _dp = (Char *) ALIGN_PTR(_dp);
+}
+
+void _aligned() {
+ sp[0] = ALIGN_PTR((Cell *) sp[0]);
+}
+
+void _and() {
+ sp[1] &= sp[0];
+ sp++;
+}
+
+void _b_l() {
+ *--sp = ' ';
+}
+
+void _c_store() {
+ register Char *addr = (Char *) *sp++;
+ *addr = (Char) *sp++;
+}
+
+void _c_fetch() {
+ register Char *addr = (Char *) *sp;
+ *sp = (Cell) *addr;
+}
+
+void _cell_plus() {
+ sp[0] += sizeof(Cell);
+}
+
+void _cells() {
+ sp[0] *= sizeof(Cell);
+}
+
+void _char_plus() {
+ sp[0] += sizeof(Char);
+}
+
+void _chars() {
+ sp[0] *= sizeof(Char);
+}
+
+void _depth() {
+ register Cell dep = sp_top - sp;
+ *--sp = dep;
+}
+
+void _drop() {
+ sp++;
+}
+
+void _dupe() {
+ sp--;
+ sp[0] = sp[1];
+}
+
+void _f_m_slash_mod() {
+ register Cell n1 = *sp++;
+ register DCell d1 = GET_DCELL(sp);
+ sp[0] = d1 / n1;
+ sp[1] = d1 % n1;
+#if !FLOORED_DIVISION
+ if (*sp < 0) {
+ sp[0]--;
+ if (sp[1] > 0) sp[1]++;
+ else sp[1]--;
+ sp[1] = -sp[1];
+ }
+#endif
+}
+
+void _invert() {
+ sp[0] = ~sp[0];
+}
+
+void _l_shift() {
+ register UCell u = (UCell) *sp++;
+ sp[0] <<= u;
+}
+
+void _m_star() {
+ register DCell d = (DCell) sp[1] * (DCell) sp[0];
+ PUT_DCELL(sp, d);
+}
+
+void _max() {
+ register Cell n2 = *sp++;
+ sp[0] = sp[0] > n2 ? sp[0] : n2;
+}
+
+void _min() {
+ register Cell n2 = *sp++;
+ sp[0] = sp[0] < n2 ? sp[0] : n2;
+}
+
+void _mod() {
+ sp[1] %= sp[0];
+ sp++;
+}
+
+void _negate() {
+ sp[0] = -sp[0];
+}
+
+void _or() {
+ sp[1] |= sp[0];
+ sp++;
+}
+
+void _over() {
+ sp--;
+ sp[0] = sp[2];
+}
+
+void _r_from() {
+ *--sp = *rp++;
+}
+
+void _r_fetch() {
+ *--sp = *rp;
+}
+
+void _rote() {
+ register Cell x3 = sp[0];
+ register Cell x2 = sp[1];
+ register Cell x1 = sp[2];
+ sp[0] = x1;
+ sp[1] = x3;
+ sp[2] = x2;
+}
+
+void _r_shift() {
+ register UCell u = (UCell) *sp++;
+ ((UCell *) sp)[0] >>= u;
+}
+
+void _s_to_d() {
+ register DCell d = (DCell) (*sp--);
+ PUT_DCELL(sp, d);
+}
+
+void _s_m_slash_rem() {
+ register Cell n1 = *sp++;
+ register DCell d1 = GET_DCELL(sp);
+ sp[0] = d1 / n1;
+ sp[1] = d1 % n1;
+#if FLOORED_DIVISION
+ if (*sp < 0) {
+ sp[0]++;
+ if (sp[1] > 0) sp[1]--;
+ else sp[1]++;
+ sp[1] = -sp[1];
+ }
+#endif
+}
+
+void _swap() {
+ register Cell temp = sp[0];
+ sp[0] = sp[1];
+ sp[1] = temp;
+}
+
+void _u_less_than() {
+ sp[1] = FFLAG((UCell) sp[1] < (UCell) sp[0]);
+ sp++;
+}
+
+void _u_m_star() {
+ register UDCell ud = (UDCell) sp[1] * (UDCell) sp[0];
+ PUT_DCELL(sp, ud);
+}
+
+void _u_m_slash_mod() {
+ register UCell u1 = *sp++;
+ register UDCell ud = GET_DCELL(sp);
+ sp[1] = ud % u1;
+ sp[0] = ud / u1;
+}
+
+void _xor() {
+ sp[1] ^= sp[0];
+ sp++;
+}
+
+void _do_literal() {
+ *--sp = (Cell) *ip++;
+}
+
+void _do_fliteral() {
+ *--fp = (Real) *((Real *) ip);
+ ip += sizeof(Real) / sizeof(Cell);
+}
+
+void _word() {
+ register Char *addr;
+ register Char delim = (Char) *sp;
+ register int i, j;
+ while (_to_in < _in_input_buffer && _input_buffer[_to_in] == delim) _to_in++;
+ _parse();
+ i = *_dp = *sp++;
+ addr = (Char *) *sp;
+ for (j = 0; j < i; j++) *(_dp + j + 1) = *addr++;
+ *(_dp + i + 1) = ' ';
+ *sp = (Cell) _dp;
+}
+
+void _to_number() {
+ register UCell u1 = (UCell) *sp;
+ register Char *addr = (Char *) *(sp + 1);
+ register UDCell ud1 = GET_DCELL(sp + 2);
+ while (is_base_digit(*addr) && u1) {
+ ud1 *= _base;
+ if (*addr <= '9') ud1 += *addr - '0';
+ else ud1 += toupper(*addr) - 'A' + 10;
+ addr++;
+ u1--;
+ }
+ PUT_DCELL(sp + 2, ud1);
+ *(sp + 1) = (Cell) addr;
+ *sp = u1;
+}
+
+void _read_const() {
+ register Cell n;
+ register Cell usign = 1;
+ register UDCell num;
+ register const_type = 1;
+ register Char *orig = (Char *) sp[1];
+ register Cell orig_len = sp[0];
+ if (sp[0] && *((Char *) sp[1]) == '-') {
+ usign = -1;
+ sp[1] += sizeof(Char);
+ sp[0]--;
+ }
+ while (sp[0]) {
+ _to_number();
+ if (sp[0] && *((Char *) sp[1]) == '.') {
+ const_type = 2;
+ sp[0]--;
+ sp[1] += sizeof(Char);
+ } else break;
+ }
+ n = *sp++;
+ num = GET_DCELL(sp + 1);
+ if (usign < 0) {
+ num = -num;
+ PUT_DCELL(sp + 1, num);
+ }
+ if (!n) *sp = const_type;
+#ifdef FLOAT_DEF
+ else {
+ if (_base == 10) {
+ sp++;
+ sp[1] = (Cell) orig;
+ sp[0] = orig_len;
+ _to_float();
+ if (*sp) sp[0] = 3;
+ } else *sp = 0;
+ }
+#else
+ else *sp = 0;
+#endif
+}
+
+void _interpret() {
+ register struct word_def *xt;
+ while (!_error && _to_in < _in_input_buffer) {
+ *--sp = ' ';
+ _word();
+ sp++;
+ if (!(*_dp)) continue; /* Please forget this! */
+ xt = search_word(_dp + 1, *_dp);
+ if (xt) {
+ if (_state == INTERPRET) {
+ if (xt->class & COMP_ONLY) _error = E_NOCOMP;
+ else exec_word(xt);
+ } else /* _state == COMPILE */ {
+ if (xt->class & IMMEDIATE) exec_word(xt);
+ else compile_word(xt);
+ }
+ } else /* xt == 0 */ {
+ register UDCell num;
+ *--sp = 0;
+ *--sp = 0;
+ *--sp = (Cell) (_dp + sizeof(Char));
+ *--sp = (Cell) *_dp;
+ _read_const();
+ if (!(*sp)) {
+ sp++;
+ _error = E_NOWORD;
+ } else {
+ switch (*sp++) {
+ case 1:
+ num = GET_DCELL(sp);
+ if (_state == INTERPRET) sp++;
+ else {
+ sp += 2;
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) num);
+ }
+ break;
+ case 2:
+ num = GET_DCELL(sp);
+ if (_state == COMPILE) {
+ sp += 2;
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) num);
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) (num >> CellBits));
+ }
+ break;
+ case 3:
+ if (_state == COMPILE) {
+ compile_cell((Cell) _do_fliteral);
+ compile_real(*fp);
+ fp++;
+ }
+ break;
+ }
+ }
+ }
+ }
+}
+
+void _accept() {
+ register Cell n1 = *sp++;
+ register Char *addr = (Char *) *sp;
+ register int i = 0;
+ register char ch;
+ do {
+ ch = getchar();
+ i = process_char(addr, n1, i, ch);
+ } while (ch != '\n');
+ *sp = i;
+}
+
+void _source() {
+ *--sp = (Cell) _input_buffer;
+ *--sp = _in_input_buffer;
+}
+
+void _paren() {
+ register Cell eof = 1;
+ do {
+ while (_to_in < _in_input_buffer && _input_buffer[_to_in] != ')') _to_in++;
+ if (_source_id != 0 && _source_id != -1 && _to_in == _in_input_buffer) {
+ _refill();
+ eof = !(*sp++);
+ }
+ } while (_to_in == _in_input_buffer && !eof);
+ if (_to_in < _in_input_buffer) _to_in++;
+}
+
+void _evaluate() {
+ register Cell u = *sp++;
+ register Char *addr = (Char *) *sp++;
+ save_input_specification();
+ _source_id = -1;
+ _in_input_buffer = u;
+ _input_buffer = addr;
+ _to_in = 0;
+ _b_l_k = 0;
+ _interpret();
+ restore_input_specification();
+}
+
+void _view_error_msg() {
+ static struct an_error {
+ char *msg;
+ char please_abort;
+ char print_word;
+ } err_msg[] = {
+ { "everything allright", 0, 0 },
+ { "no input avaliable", 0, 0 },
+ { "unknown word", 0, 1 },
+ { "word must be compiled", 0, 1 },
+ { "corrupted dictionary", 1, 0 },
+ { "not enough memory", 0, 0 },
+ { "data-stack underflow", 1, 0 },
+ { "data-stack overflow", 1, 0 },
+ { "return-stack underflow", 1, 0 },
+ { "return-stack overflow", 1, 0 },
+ { "floating-stack underflow", 1, 0 },
+ { "floating-stack overflow", 1, 0 },
+ { "data-space corrupted", 1, 0 },
+ { "data-space exhausted", 1, 0 },
+ { "unable to access image file", 0, 0 },
+ { "primitive not implemented", 0, 1 },
+ { "floating-point/math exception", 0, 0 },
+ { "segmentation fault", 0, 0 },
+ { "file not found", 0, 0 },
+ };
+ if (err_msg[-_error].print_word) {
+ putchar('[');
+ *--sp = (Cell) _dp;
+ _count();
+ _type();
+ printf("] ");
+ }
+ printf("error(%d): %s.\n", -_error, err_msg[-_error].msg);
+ if (err_msg[-_error].please_abort) {
+ printf("Aborting...\n");
+ _abort();
+ }
+}
+
+void _quit() {
+ while (1) {
+ rp = rp_top;
+ _source_id = 0;
+ _input_buffer = _tib;
+ _state = INTERPRET;
+ _error = E_OK;
+ while (_error == E_OK) {
+ _refill();
+ if (*sp++) {
+ _to_in = 0;
+ _interpret();
+ if (_state == INTERPRET && !_error) printf("ok\n");
+ else if (_state == COMPILE) printf("ko ");
+ } else _error = E_NOINPUT;
+ if (_error == E_OK && _check_system) check_system();
+ }
+ _view_error_msg();
+ }
+}
+
+void _comma() {
+ *((Cell *) _dp) = *sp++;
+ _dp += sizeof(Cell);
+}
+
+void _allot() {
+ _dp += *sp++;
+}
+
+void _c_comma() {
+ *_dp++ = (Char) *sp++;
+}
+
+void _here() {
+ *--sp = (Cell) _dp;
+}
+
+void _do_exit() {
+ ip = 0;
+}
+
+void _exit_imm() {
+ clear_locals();
+ compile_cell((Cell) _do_exit);
+}
+
+void _paren_do_colon_paren() {
+ *--rp = (Cell) (ip + 1);
+ ip = (pfp *) *ip;
+ while (ip) (*ip++)();
+ ip = (pfp *) *rp++;
+}
+
+void _colon() {
+ create_definition(A_COLON);
+ _state = COMPILE;
+ init_locals();
+}
+
+void _variable() {
+ create_definition(A_VARIABLE);
+ compile_cell(0);
+ mark_word(_last);
+}
+
+void _constant() {
+ register Cell x = *sp++;
+ create_definition(A_CONSTANT);
+ compile_cell(x);
+ mark_word(_last);
+}
+
+void _create() {
+ create_definition(A_CREATE);
+ compile_cell(0);
+ mark_word(_last);
+}
+
+void _does() {
+ compile_cell((Cell) _paren_does_paren);
+ _exit_imm();
+ mark_word(_last);
+ init_locals();
+}
+
+void _paren_does_paren() {
+ _last->func[0] = (pfp) (ip + 1);
+}
+
+void _semi_colon() {
+ _exit_imm();
+ _state = INTERPRET;
+ mark_word(_last);
+}
+
+void _zero_branch() {
+ if (*sp++) ip++;
+ else ip += 1 + (Cell) *ip;
+}
+
+void _branch() {
+ ip += 1 + (Cell) *ip;
+}
+
+void _if() {
+ compile_cell((Cell) _zero_branch);
+ *--sp = (Cell) _dp;
+ compile_cell(0);
+}
+
+void _then() {
+ register Cell *patch = (Cell *) *sp++;
+ *patch = ((Cell *) _dp) - patch - 1;
+}
+
+void _else() {
+ _ahead();
+ *--sp = 1;
+ _roll();
+ _then();
+}
+
+void _begin() {
+ *--sp = (Cell) _dp;
+}
+
+void _do() {
+ compile_cell((Cell) _paren_do_paren);
+ *--sp = (Cell) _dp;
+ *--sp = 0; /* Non e' un ?do */
+}
+
+void _paren_do_paren() {
+ *--rp = *sp++;
+ *--rp = *sp++;
+ /* R: index limit --- */
+}
+
+void _loop() {
+ register Cell q_do = *sp++;
+ register Cell *dest = (Cell *) *sp++;
+ compile_cell((Cell) _paren_loop_paren);
+ compile_cell(dest - ((Cell *) _dp) - 1);
+ if (q_do) {
+ register Cell *patch = (Cell *) *sp++;
+ *patch = ((Cell *) _dp) - patch - 1;
+ }
+}
+
+void _paren_loop_paren() {
+ if (rp[0] == ++rp[1]) {
+ ip++;
+ rp += 2;
+ } else ip += 1 + (Cell) *ip;
+}
+
+void _i() {
+ *--sp = rp[1];
+}
+
+void _j() {
+ *--sp = rp[3];
+}
+
+void _plus_loop() {
+ register Cell q_do = *sp++;
+ register Cell *dest = (Cell *) *sp++;
+ compile_cell((Cell) _paren_plus_loop_paren);
+ compile_cell(dest - ((Cell *) _dp) - 1);
+ if (q_do) {
+ register Cell *patch = (Cell *) *sp++;
+ *patch = ((Cell *) _dp) - patch - 1;
+ }
+}
+
+void _paren_plus_loop_paren() {
+ register Cell old_index = *rp;
+ rp[1] += *sp++;
+ if (old_index < rp[1] && rp[0] >= rp[1]) {
+ ip++;
+ rp += 2;
+ } else ip += 1 + (Cell) *ip;
+}
+
+void _find() {
+ register Char *addr = (Char *) *sp;
+ register Cell len = (Cell) *addr++;
+ register struct word_def *xt = search_word(addr, len);
+ set_find_stack(addr, xt);
+}
+
+void _recurse() {
+ compile_cell((Cell) _paren_do_colon_paren);
+ compile_cell((Cell) &_last->func[0]);
+}
+
+void _tick() {
+ register Char *addr;
+ *--sp = ' ';
+ _word();
+ addr = (Char *) *sp;
+ if (!(*sp = (Cell) search_word(addr + 1, *addr))) _error = E_NOWORD;
+}
+
+void _to_body() {
+ *sp = (Cell) &((struct word_def *) *sp)->func[0];
+}
+
+void _abort() {
+ *--sp = -1;
+ _throw();
+}
+
+void _abort_quote() {
+ _if();
+ _s_quote();
+ compile_cell((Cell) _do_literal);
+ compile_cell(-2);
+ compile_cell((Cell) _throw);
+ _then();
+}
+
+void _count() {
+ register Char *addr = (Char *) *sp;
+ sp--;
+ sp[0] = (Cell) *addr;
+ sp[1]++;
+}
+
+void _decimal() {
+ _base = 10;
+}
+
+void _environment_query() {
+ register Cell len = *sp++;
+ register Char *addr = (Char *) *sp++;
+ static struct {
+ Char *name;
+ Cell *var;
+ } kw[] = {
+ { "/COUNTED-STRING", &_env_slash_counted_string },
+ { "/HOLD", &_env_slash_hold },
+ { "/PAD", &_env_slash_pad },
+ { "ADDRESS-UNIT-BITS", &_env_address_unit_bits },
+ { "CORE", &_env_core },
+ { "CORE-EXT", &_env_core_ext },
+ { "FLOORED", &_env_floored },
+ { "MAX-CHAR", &_env_max_char },
+ { "MAX-D", &_env_max_d },
+ { "MAX-N", &_env_max_n },
+ { "MAX-U", &_env_max_u },
+ { "MAX-UD", &_env_max_ud },
+ { "RETURN-STACK-CELLS", &_env_return_stack_cells },
+ { "STACK-CELLS", &_env_stack_cells },
+ { "DOUBLE", &_env_double },
+ { "DOUBLE-EXT", &_env_double_ext },
+ { "FLOATING", &_env_floating },
+ { "FLOATING-STACK", &_env_floating_stack },
+ { "MAX-FLOAT", &_env_max_float },
+ { "FLOATING-EXT", &_env_floating_ext },
+ { "MEMORY-ALLOC", &_env_memory_alloc },
+ { "MEMORY-ALLOC-EXT", &_env_memory_alloc_ext },
+ { "SEARCH-ORDER", &_env_search_order },
+ { "WORDLISTS", &_env_wordlists },
+ { "SEARCH-ORDER-EXT", &_env_search_order_ext },
+ { "TOOLS", &_env_tools },
+ { "TOOLS-EXT", &_env_tools_ext },
+ { "#LOCALS", &_env_number_locals },
+ { "LOCALS", &_env_locals },
+ { "LOCALS-EXT", &_env_locals_ext },
+ { "FACILITY", &_env_facility },
+ { "FACILITY-EXT", &_env_facility_ext },
+ { "BLOCK", &_env_block },
+ { "BLOCK-EXT", &_env_block_ext },
+ { "EXCEPTION", &_env_exception },
+ { "EXCEPTION-EXT", &_env_exception_ext },
+ { "FILE", &_env_file },
+ { "FILE-EXT", &_env_file_ext },
+ { "STRING", &_env_string },
+ { "STRING-EXT", &_env_string_ext },
+ { NULL, NULL },
+ };
+ register int i = 0;
+ for (i = 0; i < len; i++) addr[i] = toupper(addr[i]);
+ i = 0;
+ while (kw[i].name && memcmp(addr, kw[i].name, len)) i++;
+ if (kw[i].name) {
+ if (!strcmp(kw[i].name + 1, "MAX-UD")) {
+ sp -= 2;
+ PUT_DCELL(sp, MAX_UD);
+ } else if (!strcmp(kw[i].name + 1, "MAX-FLOAT"))
+ *--fp = MAX_F;
+ else *--sp = *kw[i].var;
+ *--sp = FFLAG(1);
+ } else *--sp = FFLAG(0);
+}
+
+void _execute() {
+ exec_word((struct word_def *) *sp++);
+}
+
+void _fill() {
+ register int c = (int) *sp++;
+ register UCell u = (UCell) *sp++;
+ register Char *addr = (Char *) *sp++;
+ if (u) memset(addr, c, u);
+}
+
+void _immediate() {
+ _last->class |= IMMEDIATE;
+}
+
+void _key() {
+ *--sp = d_getch();
+}
+
+void _leave() {
+ rp += 2;
+ while (*ip != _paren_loop_paren && *ip != _paren_plus_loop_paren) ip++;
+ ip += 2;
+}
+
+void _literal() {
+ compile_cell((Cell) _do_literal);
+ compile_cell(sp[0]);
+ sp++;
+}
+
+void _move() {
+ register UCell u = (UCell) *sp++;
+ register Char *dest = (Char *) *sp++;
+ register Char *source = (Char *) *sp++;
+ if (u) memmove(dest, source, u);
+}
+
+void _postpone() {
+ *--sp = ' ';
+ _word();
+ _find();
+ if (*sp++ > 0) /* IMMEDIATE word */
+ compile_word((struct word_def *) *sp++);
+ else {
+ compile_cell((Cell) _paren_compile_paren);
+ compile_cell(sp[0]);
+ sp++;
+ }
+}
+
+void _paren_compile_paren() {
+ compile_word((struct word_def *) *sp++);
+}
+
+void _s_quote() {
+ if (_state == INTERPRET) {
+ *--sp = '"';
+ _word();
+ memcpy(s_tmp_buffer, _dp, *_dp + 1);
+ sp[0] = (Cell) s_tmp_buffer;
+ _count();
+ } else {
+ _c_quote();
+ compile_cell((Cell) _count);
+ }
+}
+
+void _sign() {
+ if (*sp++ < 0) {
+ *p_pnos-- = '-';
+ in_pnos++;
+ }
+}
+
+void _unloop() {
+ rp += 2;
+}
+
+void _left_bracket() {
+ _state = INTERPRET;
+}
+
+void _bracket_tick() {
+ _tick();
+ _literal();
+}
+
+void _char() {
+ *--sp = ' ';
+ _word();
+ sp[0] = _dp[1];
+}
+
+void _bracket_char() {
+ _char();
+ _literal();
+}
+
+void _right_bracket() {
+ _state = COMPILE;
+}
+
+void _while() {
+ _if();
+ *--sp = 1;
+ _roll();
+}
+
+void _repeat() {
+ _again();
+ _then();
+}
+
+void _do_value() {
+ *--sp = (Cell) *((Cell *) *ip++);
+}
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS ****************************************************/
+/**************************************************************************/
+
+/* strmatch: compare two strings, the first is expressed as (s1, len), while
+ * the second is a counted string pointed by "s2". If the two strings are
+ * identical return 0, 1 otherwise. The comparison is case INsensitive
+ */
+int strmatch(const Char *s1, const Char *s2, int len1) {
+ if (len1 != *s2++) return (1);
+ else {
+ while (len1--) if (toupper(*s1++) != toupper(*s2++)) return (1);
+ return (0);
+ }
+}
+
+/* search_wordlist: search a word (name, len) within the selected vocabulary.
+ * Called by "search_word"
+ */
+struct word_def *search_wordlist(Char *name, Cell len, struct vocabulary *wid) {
+ register struct word_def *p = wid->voc[hash_func(name, len)];
+ while (p && strmatch(name, p->name, len)) p = p->link;
+ return (p);
+}
+
+/* search_word: search the word (name, len) into the vocabularies, starting
+ * with the vocabulary on the top of the vocabularies stack. If found,
+ * return the word's execution token, which is a pointer to the structure
+ * "word_def" of the word. If not found, return NULL.
+ */
+struct word_def *search_word(Char *name, Cell len) {
+ register struct word_def *p;
+ register Cell ttop = top;
+ if (locals_defined()) {
+ p = get_first_local();
+ while (p && strmatch(name, p->name, len)) p = p->link;
+ if (p) return (p);
+ }
+ while (ttop >= 0) {
+ p = search_wordlist(name, len, ttop >= 0 ? list[ttop] : forth_wid);
+ if (p) return (p);
+ ttop--;
+ }
+ return (0);
+}
+
+/* ins_word: add the word with execution token "p" in the current
+ * compilation vocabulary
+ */
+void ins_word(struct word_def *p) {
+ register int hash = hash_func(p->name + 1, *p->name);
+ p->link = voc->voc[hash];
+}
+
+/* mark_word: make the word with execution token "p" visible, by updating
+ * the compilation vocabulary head pointer
+ */
+void mark_word(struct word_def *p) {
+ register int hash = hash_func(p->name + 1, *p->name);
+ voc->voc[hash] = p;
+}
+
+/* set_find_stack: setup the data stack after a search in the vocabularies
+ * as reuired by the word "find"
+ */
+void set_find_stack(Char *addr, struct word_def *xt) {
+ if (xt) {
+ *sp = (Cell) xt;
+ if (xt->class & IMMEDIATE) *--sp = 1;
+ else *--sp = (Cell) -1;
+ } else {
+ *sp = (Cell) addr;
+ *--sp = 0;
+ }
+}
+
+/* is_base_digit: return true if the digit "ch" is valid in the current base
+ * stored in the variable "base".
+ */
+int is_base_digit(Char ch) {
+ ch = toupper(ch);
+ if (ch >= '0' && ch <= '9') {
+ if (ch - '0' < _base) return (1);
+ else return (0);
+ }
+ if (ch >= 'A' && ch <= 'Z') {
+ if (ch - 'A' + 10 < _base) return (1);
+ else return (0);
+ }
+ return (0);
+}
+
+/* process_char: do the work when a key is stroken on the keyboard.
+ * "addr" is a base pointer to the buffer where the characters are to be
+ * stored, "max_len" is the size of the buffer, "cur_pos" the current
+ * position within the buffer, and "ch" the character to be processed.
+ */
+int process_char(Char *addr, int max_len, int cur_pos, char ch) {
+ switch (ch) {
+ case '\b':
+ if (cur_pos) cur_pos--;
+ else putchar('\a');
+ break;
+ case 0:
+ case EOF:
+ default:
+ if (ch >= 32) {
+ if (cur_pos < max_len) addr[cur_pos++] = ch;
+ else putchar('\a');
+ }
+ break;
+ }
+ return cur_pos;
+}
+
+/* create_definition: create a new word in the dictionary allocating the
+ * space for the name, which is stored yet by the call to "word", then
+ * allocating a structure "word_def" and setting the "class" field to the
+ * value passed to the function.
+ */
+void create_definition(Cell class) {
+ register struct word_def *def;
+ register Char *name;
+ *--sp = (Cell) ' ';
+ name = _dp;
+ _word();
+ sp++;
+ _dp = (Char *) WORD_PTR(_dp);
+ _align();
+ def = (struct word_def *) _dp;
+ _last = def;
+ def->name = name;
+ def->class = class;
+ ins_word(def);
+ _dp += sizeof(struct word_def) - sizeof(Cell);
+}
+
+/* exec_colon: execute a colon definition, with the first instruction pointed
+ * by "ip0"
+ */
+void exec_colon(pfp *ip0) {
+ register pfp *old_ip = ip;
+ ip = ip0;
+ while (ip) (*ip++)();
+ ip = old_ip;
+}
+
+/* exec_word: execute the word with execution token "xt" when interpreting
+ */
+void exec_word(struct word_def *xt) {
+ switch (xt->class & A_WORD) {
+ case A_PRIMITIVE: xt->func[0](); break;
+ case A_FVARIABLE:
+ case A_2VARIABLE:
+ case A_VARIABLE: *--sp = (Cell) &xt->func[0]; break;
+ case A_COLON: exec_colon(&xt->func[0]); break;
+ case A_VALUE:
+ case A_USER:
+ case A_CONSTANT: *--sp = (Cell) xt->func[0]; break;
+ case A_2CONSTANT:
+ *--sp = (Cell) xt->func[0];
+ *--sp = (Cell) xt->func[1];
+ break;
+ case A_FCONSTANT: *--fp = *((Real *) &xt->func[0]); break;
+ case A_CREATE:
+ *--sp = (Cell) &xt->func[1];
+ if (xt->func[0]) exec_colon((pfp *) xt->func[0]);
+ break;
+ case A_MARKER:
+ exec_marker((struct voc_marker *) &xt->func[0]);
+ break;
+ case A_LOCAL:
+ default: _error = E_NOVOC; break;
+ }
+}
+
+/* compile_word: compile word with execution token "xt" within the dictionary
+ */
+void compile_word(struct word_def *xt) {
+ switch (xt->class & A_WORD) {
+ case A_PRIMITIVE:
+ compile_cell((Cell) xt->func[0]);
+ break;
+ case A_VARIABLE:
+ case A_2VARIABLE:
+ case A_FVARIABLE:
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) &xt->func[0]);
+ break;
+ case A_VALUE:
+ compile_cell((Cell) _do_value);
+ compile_cell((Cell) &xt->func[0]);
+ break;
+ case A_USER:
+ case A_CONSTANT:
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) xt->func[0]);
+ break;
+ case A_2CONSTANT:
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) xt->func[0]);
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) xt->func[1]);
+ break;
+ case A_FCONSTANT:
+ compile_cell((Cell) _do_fliteral);
+ compile_real(*((Real *) &xt->func[0]));
+ break;
+ case A_COLON:
+ compile_cell((Cell) _paren_do_colon_paren);
+ compile_cell((Cell) &xt->func[0]);
+ break;
+ case A_CREATE:
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) &xt->func[1]);
+ if (xt->func[0]) {
+ compile_cell((Cell) _paren_do_colon_paren);
+ compile_cell((Cell) xt->func[0]);
+ }
+ break;
+ case A_LOCAL:
+ compile_cell((Cell) _paren_read_local_paren);
+ compile_cell((Cell) xt->func[0]);
+ break;
+ case A_MARKER:
+ compile_cell((Cell) _paren_marker_paren);
+ compile_cell((Cell) &xt->func[0]);
+ break;
+ default: _error = E_NOVOC; break;
+ }
+}
+
+/* save_input_specification: save all the information needed to restore the
+ * state of current input later. First the word "save-input" is called, and
+ * then each Cell on the stack is copied in the return stack
+ */
+void save_input_specification() {
+ register int dim, dim1;
+ _save_input();
+ dim1 = dim = *sp++;
+ while (dim--) _to_r();
+ *--sp = (Cell) dim1;
+ _to_r();
+}
+
+/* restore_input_specification: restore the input source by calling
+ * "restore-input" after that the Cells on the return stack has been moved
+ * on the data stack
+ */
+void restore_input_specification() {
+ register int dim = *rp++, dim1 = dim;
+ while (dim--) _r_from();
+ *--sp = (Cell) dim1;
+ _restore_input();
+ sp++;
+}
+
+/* check_system: perform some tests to verify that's everything ok */
+void check_system() {
+ if (sp > sp_top) _error = E_DSTK_UNDER;
+ else if (sp < sp_base) _error = E_DSTK_OVER;
+ else if (rp > rp_top) _error = E_RSTK_UNDER;
+ else if (rp < rp_base) _error = E_RSTK_OVER;
+ else if (fstack_size && fp > fp_top) _error = E_FSTK_UNDER;
+ else if (fstack_size && fp < fp_base) _error = E_FSTK_OVER;
+ else if (_dp < dp0) _error = E_DSPACE_UNDER;
+ else if (_dp > dp0 + dspace_size) _error = E_DSPACE_OVER;
+}
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: core.h
+ * Abstract: include file for "core" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __CORE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __CORE_H__
+#define __CORE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+variable(Cell, to_in, ">in")
+variable(Cell, source_id, "source-id")
+variable(Char *, tib, "tib")
+variable(Char *, input_buffer, "input-buffer")
+variable(Cell, in_input_buffer, "in-input-buffer")
+variable(Cell, base, "base")
+variable(Char *, dp, "dp")
+variable(Cell, error, "error")
+variable(struct word_def *, last, "last")
+variable(Cell, state, "state")
+variable(Cell, env_slash_counted_string, "&counted-string")
+variable(Cell, env_slash_hold, "&hold")
+variable(Cell, env_slash_pad, "&pad")
+variable(Cell, env_address_unit_bits, "&address-unit-bits")
+variable(Cell, env_core, "&core")
+variable(Cell, env_core_ext, "&core-ext")
+variable(Cell, env_floored, "&floored")
+variable(Cell, env_max_char, "&max-char")
+variable(Cell, env_max_d, "&max-d")
+variable(Cell, env_max_n, "&max-n")
+variable(Cell, env_max_u, "&max-u")
+variable(Cell, env_max_ud, "&max-ud")
+variable(Cell, env_return_stack_cells, "&return-stack-cells")
+variable(Cell, env_stack_cells, "&stack-cells")
+variable(Cell, env_double, "&double")
+variable(Cell, env_double_ext, "&double-ext")
+variable(Cell, env_floating, "&floating")
+variable(Cell, env_floating_stack, "&floating-stack")
+variable(Cell, env_max_float, "&max-float")
+variable(Cell, env_floating_ext, "&floating-ext")
+variable(Cell, env_memory_alloc, "&memory-alloc")
+variable(Cell, env_memory_alloc_ext, "&memory-alloc-ext")
+variable(Cell, env_search_order, "&search-order")
+variable(Cell, env_wordlists, "&wordlists")
+variable(Cell, env_search_order_ext, "&search-order-ext")
+variable(Cell, env_tools, "&tools")
+variable(Cell, env_tools_ext, "&tools-ext")
+variable(Cell, env_number_locals, "&#locals")
+variable(Cell, env_locals, "&locals")
+variable(Cell, env_locals_ext, "&locals-ext")
+variable(Cell, env_facility, "&facility")
+variable(Cell, env_facility_ext, "&facility-ext")
+variable(Cell, env_block, "&block")
+variable(Cell, env_block_ext, "&block-ext")
+variable(Cell, env_exception, "&exception")
+variable(Cell, env_exception_ext, "&exception-ext")
+variable(Cell, env_file, "&file")
+variable(Cell, env_file_ext, "&file-ext")
+variable(Cell, env_string, "&string")
+variable(Cell, env_string_ext, "&string-ext")
+variable(Cell, check_system, "(check-system)")
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(store, "!", 0)
+code(star, "*", 0)
+code(star_slash, "*/", 0)
+code(star_slash_mod, "*/mod", 0)
+code(plus, "+", 0)
+code(plus_store, "+!", 0)
+code(minus, "-", 0)
+code(slash, "/", 0)
+code(slash_mod, "/mod", 0)
+code(zero_less, "0<", 0)
+code(zero_equals, "0=", 0)
+code(one_plus, "1+", 0)
+code(one_minus, "1-", 0)
+code(two_store, "2!", 0)
+code(two_star, "2*", 0)
+code(two_slash, "2/", 0)
+code(two_fetch, "2@", 0)
+code(two_drop, "2drop", 0)
+code(two_dupe, "2dup", 0)
+code(two_over, "2over", 0)
+code(two_swap, "2swap", 0)
+code(less_than, "<", 0)
+code(equals, "=", 0)
+code(greater_than, ">", 0)
+code(to_r, ">r", COMP_ONLY)
+code(question_dupe, "?dup", 0)
+code(fetch, "@", 0)
+code(abs, "abs", 0)
+code(align, "align", 0)
+code(aligned, "aligned", 0)
+code(and, "and", 0)
+code(b_l, "bl", 0)
+code(c_store, "c!", 0)
+code(c_fetch, "c@", 0)
+code(cell_plus, "cell+", 0)
+code(cells, "cells", 0)
+code(char_plus, "char+", 0)
+code(chars, "chars", 0)
+code(depth, "depth", 0)
+code(drop, "drop", 0)
+code(dupe, "dup", 0)
+code(f_m_slash_mod, "fm/mod", 0)
+code(invert, "invert", 0)
+code(l_shift, "lshift", 0)
+code(m_star, "m*", 0)
+code(max, "max", 0)
+code(min, "min", 0)
+code(mod, "mod", 0)
+code(negate, "negate", 0)
+code(or, "or", 0)
+code(over, "over", 0)
+code(r_from, "r>", COMP_ONLY)
+code(r_fetch, "r@", COMP_ONLY)
+code(rote, "rot", 0)
+code(r_shift, "rshift", 0)
+code(s_to_d, "s>d", 0)
+code(s_m_slash_rem, "sm/rem", 0)
+code(swap, "swap", 0)
+code(u_less_than, "u<", 0)
+code(u_m_star, "um*", 0)
+code(u_m_slash_mod, "um/mod", 0)
+code(xor, "xor", 0)
+code(word, "word", 0)
+code(to_number, ">number", 0)
+code(interpret, "interpret", 0)
+code(accept, "accept", 0)
+code(source, "source", 0)
+code(paren, "(", 0)
+code(evaluate, "evaluate", 0)
+code(quit, "quit", 0)
+code(comma, ",", 0)
+code(allot, "allot", 0)
+code(c_comma, "c,", 0)
+code(here, "here", 0)
+code(exit_imm, "exit", COMP_ONLY | IMMEDIATE)
+code(colon, ":", 0)
+code(variable, "variable", 0)
+code(constant, "constant", 0)
+code(create, "create", 0)
+code(does, "does>", COMP_ONLY | IMMEDIATE)
+code(semi_colon, ";", COMP_ONLY | IMMEDIATE)
+code(if, "if", COMP_ONLY | IMMEDIATE)
+code(then, "then", COMP_ONLY | IMMEDIATE)
+code(else, "else", COMP_ONLY | IMMEDIATE)
+code(begin, "begin", COMP_ONLY | IMMEDIATE)
+code(do, "do", COMP_ONLY | IMMEDIATE)
+code(loop, "loop", COMP_ONLY | IMMEDIATE)
+code(i, "i", COMP_ONLY)
+code(j, "j", COMP_ONLY)
+code(plus_loop, "+loop", COMP_ONLY | IMMEDIATE)
+code(recurse, "recurse", COMP_ONLY | IMMEDIATE)
+code(find, "find", 0)
+code(less_number_sign, "<#", 0)
+code(number_sign, "#", 0)
+code(hold, "hold", 0)
+code(number_sign_s, "#s", 0)
+code(number_sign_greater, "#>", 0)
+code(dot, ".", 0)
+code(c_r, "cr", 0)
+code(emit, "emit", 0)
+code(space, "space", 0)
+code(spaces, "spaces", 0)
+code(type, "type", 0)
+code(u_dot, "u.", 0)
+code(dot_quote, ".\"", COMP_ONLY | IMMEDIATE)
+code(tick, "'", 0)
+code(to_body, ">body", 0)
+code(abort, "abort", 0)
+code(abort_quote, "abort\"", COMP_ONLY | IMMEDIATE)
+code(count, "count", 0)
+code(decimal, "decimal", 0)
+code(environment_query, "environment?", 0)
+code(execute, "execute", 0)
+code(fill, "fill", 0)
+code(immediate, "immediate", 0)
+code(key, "key", 0)
+code(leave, "leave", COMP_ONLY)
+code(literal, "literal", COMP_ONLY | IMMEDIATE)
+code(move, "move", 0)
+code(postpone, "postpone", COMP_ONLY | IMMEDIATE)
+code(s_quote, "s\"", IMMEDIATE)
+code(sign, "sign", 0)
+code(unloop, "unloop", COMP_ONLY)
+code(left_bracket, "[", COMP_ONLY | IMMEDIATE)
+code(bracket_tick, "[']", COMP_ONLY | IMMEDIATE)
+code(char, "char", 0)
+code(bracket_char, "[char]", COMP_ONLY | IMMEDIATE)
+code(right_bracket, "]", 0)
+code(while, "while", COMP_ONLY | IMMEDIATE)
+code(repeat, "repeat", COMP_ONLY | IMMEDIATE)
+code(paren_does_paren, "(does)", 0)
+code(paren_compile_paren, "(compile)", 0)
+code(paren_do_paren, "(do)", 0)
+code(paren_loop_paren, "(loop)", 0)
+code(paren_plus_loop_paren, "(+loop)", 0)
+code(paren_dot_quote_paren, "(.\")", 0)
+code(paren_do_colon_paren, "(doCol)", 0)
+code(zero_branch, "(0branch)", 0)
+code(branch, "(branch)", 0)
+code(do_literal, "(doLit)", 0)
+code(do_fliteral, "(doFLit)", 0)
+code(do_exit, "(doExit)", 0)
+code(do_value, "(doValue)", 0)
+code(view_error_msg, "view-error-message", 0)
+code(read_const, "read-const", 0)
+
+#ifdef PROTOTYPES
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS PROTOTYPES *****************************************/
+/**************************************************************************/
+
+struct word_def *search_wordlist(Char *name, Cell len, struct vocabulary *wid);
+struct word_def *search_word(Char *name, Cell len);
+void ins_word(struct word_def *p);
+void mark_word(struct word_def *p);
+void set_find_stack(Char *addr, struct word_def *xt);
+int strmatch(const Char *s1, const Char *s2, int len1);
+int is_base_digit(Char ch);
+int process_char(Char *addr, int max_len, int cur_pos, char ch);
+void create_definition(Cell class);
+void exec_colon(pfp *ip0);
+void exec_word(struct word_def *xt);
+void compile_word(struct word_def *xt);
+void save_input_specification(void);
+void restore_input_specification(void);
+void check_system(void);
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: coree.c
+ * Abstract: Core extension word set
+ */
+
+#include "yforth.h"
+
+#include <string.h>
+#include <stdio.h>
+#include "core.h"
+#include "coree.h"
+#include "double.h"
+#include "locals.h"
+#include "block.h"
+#include "search.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+Char * _pad;
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _dot_paren() {
+ *--sp = ')';
+ _word();
+ _count();
+ _type();
+}
+
+void _dot_r() {
+ register Cell u = *sp++;
+ _s_to_d();
+ *--sp = u;
+ _d_dot_r();
+}
+
+void _zero_not_equals() {
+ sp[0] = FFLAG(sp[0] != 0);
+}
+
+void _zero_greater() {
+ sp[0] = FFLAG(sp[0] > 0);
+}
+
+void _two_to_r() {
+ rp -= 2;
+ rp[0] = *sp++;
+ rp[1] = *sp++;
+}
+
+void _two_r_from() {
+ sp -= 2;
+ sp[0] = *rp++;
+ sp[1] = *rp++;
+}
+
+void _two_r_fetch() {
+ sp -= 2;
+ sp[0] = rp[0];
+ sp[1] = rp[1];
+}
+
+void _colon_no_name() {
+ register struct word_def *def;
+ _align();
+ def = (struct word_def *) _dp;
+ def->name = 0;
+ def->link = 0;
+ def->class = A_COLON;
+ _dp += sizeof(struct word_def) - sizeof(Cell);
+ _state = COMPILE;
+ *--sp = (Cell) def;
+ init_locals();
+}
+
+void _not_equals() {
+ sp[1] = FFLAG(sp[0] != sp[1]);
+ sp++;
+}
+
+void _question_do() {
+ compile_cell((Cell) _paren_question_do_paren);
+ *--sp = (Cell) _dp;
+ compile_cell(0);
+ *--sp = (Cell) _dp;
+ *--sp = 1; /* e' un ?do */
+}
+
+void _paren_question_do_paren() {
+ if (sp[0] == sp[1]) ip += 1 + (Cell) *ip;
+ else {
+ *--rp = *sp++;
+ *--rp = *sp++;
+ ip++;
+ }
+}
+
+void _again() {
+ register Cell *dest = (Cell *) *sp++;
+ compile_cell((Cell) _branch);
+ compile_cell(dest - ((Cell *) _dp) - 1);
+}
+
+void _c_quote() {
+ register Char *cur;
+ register Cell *patch;
+ compile_cell((Cell) _branch);
+ patch = (Cell *) _dp;
+ compile_cell(0);
+ cur = _dp;
+ *--sp = '"';
+ _word();
+ sp++;
+ _dp = (Char *) WORD_PTR(_dp);
+ *patch = ((Cell *) _dp) - patch - 1;
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) cur);
+}
+
+void _compile_comma() {
+ compile_word((struct word_def *) *sp++);
+}
+
+void _erase() {
+ register UCell u = (UCell) *sp++;
+ register Char *addr = (Char *) *sp++;
+ if (u) memset(addr, 0, u);
+}
+
+void _false() {
+ *--sp = FFLAG(0);
+}
+
+void _hex() {
+ _base = 16;
+}
+
+void _marker() {
+ struct voc_marker vm;
+ save_vocabulary(&vm);
+ create_definition(A_MARKER);
+ memcpy(_dp, &vm, sizeof(struct voc_marker));
+ _dp += ALIGN_PTR(sizeof(struct voc_marker));
+ mark_word(_last);
+}
+
+void _nip() {
+ sp[1] = sp[0];
+ sp++;
+}
+
+void _parse() {
+ register Char delim = (Char) *sp;
+ register Char *orig = &_input_buffer[_to_in];
+ register int i = 0;
+ while (_to_in < _in_input_buffer && _input_buffer[_to_in] != delim) {
+ _to_in++;
+ i++;
+ }
+ *sp = (Cell) orig;
+ *--sp = i;
+ if (_to_in < _in_input_buffer) _to_in++;
+}
+
+void _pick() {
+ sp[0] = sp[sp[0] + 1];
+}
+
+void _refill() {
+ if (_b_l_k != 0) {
+ current_block = _b_l_k++;
+ _to_in = 0;
+ *--sp = _b_l_k;
+ _block();
+ _input_buffer = (Char *) *sp++;
+ _in_input_buffer = BLOCK_SIZE;
+ *sp = FFLAG(_b_l_k && _input_buffer != NULL);
+ } else if (_source_id == 0) {
+ *--sp = (Cell) _tib;
+ *--sp = tib_size;
+ _accept();
+ _input_buffer = _tib;
+ _in_input_buffer = *sp;
+ _to_in = 0;
+ *sp = FFLAG(1);
+ } else if (_source_id == -1) {
+ *--sp = FFLAG(0);
+ } else if (_env_file) {
+ if (fgets(_input_buffer, FILE_BUFFER_SIZE, (FILE *) _source_id)) {
+ _in_input_buffer = strlen(_input_buffer);
+ if (_in_input_buffer && _input_buffer[_in_input_buffer - 1] == '\n')
+ _in_input_buffer--;
+ _to_in = 0;
+ *--sp = FFLAG(1);
+ } else *--sp = FFLAG(0);
+ } else *--sp = FFLAG(0);
+}
+
+void _restore_input() {
+ sp++;
+ _b_l_k = *sp++;
+ _to_in = *sp++;
+ _in_input_buffer = *sp++;
+ _input_buffer = (Char *) *sp++;
+ _source_id = *sp++;
+ if (_source_id == 0) {
+ } else if (_source_id == -1) {
+ } else {
+ }
+ *--sp = FFLAG(1);
+}
+
+void _roll() {
+ register Cell u = *sp++;
+ register Cell xu = sp[u];
+ register int i;
+ for (i = u; i > 0; i--) sp[i] = sp[i - 1];
+ sp[0] = xu;
+}
+
+void _save_input() {
+ if (_source_id == 0) {
+ } else if (_source_id == -1) {
+ } else {
+ }
+ *--sp = _source_id;
+ *--sp = (Cell) _input_buffer;
+ *--sp = _in_input_buffer;
+ *--sp = _to_in;
+ *--sp = _b_l_k;
+ *--sp = 5;
+}
+
+void _true() {
+ *--sp = FFLAG(1);
+}
+
+void _tuck() {
+ sp--;
+ sp[0] = sp[1];
+ sp[1] = sp[2];
+ sp[2] = sp[0];
+}
+
+void _u_dot_r() {
+ register Cell r = *sp++;
+ *--sp = 0;
+ _less_number_sign();
+ _number_sign_s();
+ _number_sign_greater();
+ if (sp[0] < r) {
+ sp--;
+ sp[0] = r - sp[1];
+ _spaces();
+ }
+ _type();
+ putchar(' ');
+}
+
+void _u_greater_than() {
+ sp[1] = FFLAG((UCell) sp[1] > (UCell) sp[0]);
+ sp++;
+}
+
+void _unused() {
+ *--sp = (dspace_size - (_dp - dp0)) * sizeof(Cell);
+}
+
+void _within() {
+ register Cell n3 = *sp++;
+ register Cell n2 = *sp++;
+ register Cell n1 = *sp;
+ sp[0] = FFLAG((n2 < n3 && (n2 <= n1 && n1 < n3)) ||
+ (n2 > n3 && (n2 <= n1 || n1 < n3)));
+}
+
+void _backslash() {
+ _to_in = _in_input_buffer;
+}
+
+void _bracket_compile() {
+ *--sp = ' ';
+ _word();
+ sp++;
+ compile_word(search_word(_dp + 1, *_dp));
+}
+
+void _value() {
+ create_definition(A_VALUE);
+ compile_cell((Cell) sp[0]);
+ sp++;
+ mark_word(_last);
+}
+
+void _paren_write_value_paren() {
+ register Cell *p = (Cell *) (*ip++);
+ *p = *sp++;
+}
+
+void _to() {
+ _b_l();
+ _word();
+ _find();
+ if (*sp++) {
+ register struct word_def *xt = (struct word_def *) *sp++;
+ if ((xt->class & A_WORD) == A_VALUE) {
+ if (_state == INTERPRET) xt->func[0] = (pfp) *sp++;
+ else {
+ compile_cell((Cell) _paren_write_value_paren);
+ compile_cell((Cell) &xt->func[0]);
+ }
+ } else if (xt->class & A_WORD == A_LOCAL && _state == COMPILE) {
+ compile_cell((Cell) _paren_write_local_paren);
+ compile_cell((Cell) xt->func[0]);
+ } else {
+ /* ... */
+ }
+ } else sp++;
+}
+
+void _paren_marker_paren() {
+ exec_marker((struct voc_marker *) ip++);
+}
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS ****************************************************/
+/**************************************************************************/
+
+void exec_marker(struct voc_marker *vm) {
+ load_vocabulary(vm);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: coree.h
+ * Abstract: Include file for "core-extension" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __COREE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __COREE_H__
+#define __COREE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+variable(Char *, pad, "pad")
+variable(Cell, source_id, "source-id")
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(dot_paren, ".(", IMMEDIATE)
+code(dot_r, ".r", 0)
+code(zero_not_equals, "0<>", 0)
+code(zero_greater, "0>", 0)
+code(two_to_r, "2>r", COMP_ONLY)
+code(two_r_from, "2r>", COMP_ONLY)
+code(two_r_fetch, "2r@", COMP_ONLY)
+code(colon_no_name, ":noname", 0)
+code(not_equals, "<>", 0)
+code(question_do, "?do", COMP_ONLY | IMMEDIATE)
+code(again, "again", COMP_ONLY | IMMEDIATE)
+code(c_quote, "c\"", COMP_ONLY | IMMEDIATE)
+code(compile_comma, "compile,", COMP_ONLY)
+code(erase, "erase", 0)
+code(false, "false", 0)
+code(hex, "hex", 0)
+code(marker, "marker", 0)
+code(nip, "nip", 0)
+code(parse, "parse", 0)
+code(pick, "pick", 0)
+code(refill, "refill", 0)
+code(restore_input, "restore-input", 0)
+code(roll, "roll", 0)
+code(save_input, "save-input", 0)
+code(true, "true", 0)
+code(tuck, "tuck", 0)
+code(u_dot_r, "u.r", 0)
+code(u_greater_than, "u>", 0)
+code(unused, "unused", 0)
+code(within, "within", 0)
+code(backslash, "\\", IMMEDIATE)
+code(bracket_compile, "[compile]", COMP_ONLY)
+code(value, "value", 0)
+code(to, "to", IMMEDIATE)
+
+code(paren_question_do_paren, "(?do)", 0)
+code(paren_write_value_paren, "(wValue)", 0)
+code(paren_marker_paren, "(marker)", 0)
+
+#ifdef PROTOTYPES
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS PROTOTYPES *****************************************/
+/**************************************************************************/
+
+void exec_marker(struct voc_marker *vm);
+
+#endif
+
+#endif
+
--- /dev/null
+
+#define MIN_DSPACE_SIZE 1024
+#define MIN_DSTACK_SIZE 32
+#define MIN_RSTACK_SIZE 16
+#define MIN_FSTACK_SIZE 0
+#define MIN_TIB_SIZE 80
+#define MIN_PAD_SIZE 80
+
+#define DEF_DSPACE_SIZE 16384
+#define DEF_DSTACK_SIZE 512
+#define DEF_RSTACK_SIZE 64
+#define DEF_FSTACK_SIZE 6
+#define DEF_TIB_SIZE 128
+#define DEF_PAD_SIZE 128
+
--- /dev/null
+#include <stdio.h>
+main() { printf("#define FLOORED_DIVISION %d\n", (-10 % 7) > 0 ? 1 : 0); }
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: double.c
+ * Abstract: double-number word set
+ */
+
+#include <stdio.h>
+#include "yforth.h"
+#include "core.h"
+#include "double.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _two_constant() {
+ register DCell d = GET_DCELL(sp);
+ sp += 2;
+ create_definition(A_2CONSTANT);
+ compile_cell((Cell) d);
+ compile_cell((Cell) (d >> CellBits));
+ mark_word(_last);
+}
+
+void _two_literal() {
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) sp[1]);
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) sp[0]);
+ sp += 2;
+}
+
+void _two_variable() {
+ create_definition(A_2VARIABLE);
+ compile_cell(0);
+ compile_cell(0);
+ mark_word(_last);
+}
+
+void _d_plus() {
+ register DCell d1 = GET_DCELL(sp + 2);
+ register DCell d2 = GET_DCELL(sp);
+ d1 += d2;
+ sp += 2;
+ PUT_DCELL(sp, d1);
+}
+
+void _d_minus() {
+ register DCell d1 = GET_DCELL(sp + 2);
+ register DCell d2 = GET_DCELL(sp);
+ d1 -= d2;
+ sp += 2;
+ PUT_DCELL(sp, d1);
+}
+
+void _d_dot() {
+ register DCell u = GET_DCELL(sp);
+ register int usign = u < 0;
+ if (usign) u = -u;
+ PUT_DCELL(sp, u);
+ _less_number_sign();
+ _number_sign_s();
+ if (usign) {
+ *--sp = '-';
+ _hold();
+ }
+ _number_sign_greater();
+ _type();
+ putchar(' ');
+}
+
+void _d_dot_r() {
+ register Cell r = *sp++;
+ register DCell u = GET_DCELL(sp);
+ register int usign = u < 0;
+ if (usign && _base == 10) u = -u;
+ PUT_DCELL(sp, u);
+ _less_number_sign();
+ _number_sign_s();
+ if (usign) {
+ *--sp = '-';
+ _hold();
+ }
+ _number_sign_greater();
+ if (sp[0] < r) {
+ sp--;
+ sp[0] = r - sp[1];
+ _spaces();
+ }
+ _type();
+ putchar(' ');
+}
+
+void _d_zero_less() {
+ register DCell d = GET_DCELL(sp);
+ sp++;
+ sp[0] = FFLAG(d < 0);
+}
+
+void _d_zero_equals() {
+ register DCell d = GET_DCELL(sp);
+ sp++;
+ sp[0] = FFLAG(d == 0);
+}
+
+void _d_two_star() {
+ register DCell d = GET_DCELL(sp);
+ d <<= 1;
+ PUT_DCELL(sp, d);
+}
+
+void _d_two_slash() {
+ register DCell d = GET_DCELL(sp);
+ d >>= 1;
+ PUT_DCELL(sp, d);
+}
+
+void _d_less_than() {
+ register DCell d1 = GET_DCELL(sp + 2);
+ register DCell d2 = GET_DCELL(sp);
+ sp += 3;
+ sp[0] = FFLAG(d1 < d2);
+}
+
+void _d_equals() {
+ register DCell d1 = GET_DCELL(sp + 2);
+ register DCell d2 = GET_DCELL(sp);
+ sp += 3;
+ sp[0] = FFLAG(d1 == d2);
+}
+
+void _dabs() {
+ register DCell d = GET_DCELL(sp);
+ d = d > 0 ? d : -d;
+ PUT_DCELL(sp, d);
+}
+
+void _dmax() {
+ register DCell d1 = GET_DCELL(sp + 2);
+ register DCell d2 = GET_DCELL(sp);
+ sp += 2;
+ if (d2 > d1) PUT_DCELL(sp, d2);
+}
+
+void _dmin() {
+ register DCell d1 = GET_DCELL(sp + 2);
+ register DCell d2 = GET_DCELL(sp);
+ sp += 2;
+ if (d2 < d1) PUT_DCELL(sp, d2);
+}
+
+void _dnegate() {
+ register DCell d = -GET_DCELL(sp);
+ PUT_DCELL(sp, d);
+}
+
+void _m_star_slash() {
+ register Cell n2 = *sp++;
+ register Cell n1 = *sp++;
+ register DCell d = GET_DCELL(sp);
+ d = (d * n1) / n2;
+ PUT_DCELL(sp, d);
+}
+
+void _m_plus() {
+ _s_to_d();
+ _d_plus();
+}
+
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: double.h
+ * Abstract: include file for "double-numbers" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __DOUBLE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __DOUBLE_H__
+#define __DOUBLE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(two_constant, "2constant", 0)
+code(two_literal, "2literal", COMP_ONLY | IMMEDIATE)
+code(two_variable, "2variable", 0)
+code(d_plus, "d+", 0)
+code(d_minus, "d-", 0)
+code(d_dot, "d.", 0)
+code(d_dot_r, "d.r", 0)
+code(d_zero_less, "d0<", 0)
+code(d_zero_equals, "d0=", 0)
+code(d_two_star, "d2*", 0)
+code(d_two_slash, "d2/", 0)
+code(d_less_than, "d<", 0)
+code(d_equals, "d=", 0)
+code(drop, "d>s", 0)
+code(dabs, "dabs", 0)
+code(dmax, "dmax", 0)
+code(dmin, "dmin", 0)
+code(dnegate, "dnegate", 0)
+code(m_star_slash, "m*/", 0)
+code(m_plus, "m+", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: doublee.c
+ * Abstract: double-extension word set
+ */
+
+#include "yforth.h"
+#include "doublee.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _two_rote() {
+ register DCell d1 = GET_DCELL(sp);
+ register DCell d2 = GET_DCELL(sp + 2);
+ register DCell d3 = GET_DCELL(sp + 4);
+ PUT_DCELL(sp, d3);
+ PUT_DCELL(sp + 2, d1);
+ PUT_DCELL(sp + 4, d2);
+}
+
+void _d_u_less() {
+ register UDCell ud1 = GET_DCELL(sp + 2);
+ register UDCell ud2 = GET_DCELL(sp);
+ sp += 3;
+ sp[0] = FFLAG(ud1 < ud2);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: doublee.h
+ * Abstract: include file for "double-number extension" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __DOUBLEE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __DOUBLEE_H__
+#define __DOUBLEE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(two_rote, "2rot", 0)
+code(d_u_less, "du<", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: errors.h
+ * Abstract: definitions for system error codes
+ */
+
+#define E_OK 0 /* no error */
+#define E_NOINPUT -1 /* no input available */
+#define E_NOWORD -2 /* unknown word */
+#define E_NOCOMP -3 /* word must be compiled */
+#define E_NOVOC -4 /* corrupted dictionary */
+#define E_NOMEM -5 /* not enough memory */
+#define E_DSTK_UNDER -6 /* data-stack underflow */
+#define E_DSTK_OVER -7 /* data-stack overflow */
+#define E_RSTK_UNDER -8 /* return-stack underflow */
+#define E_RSTK_OVER -9 /* return-stack overflow */
+#define E_FSTK_UNDER -10 /* floating-stack undeflow */
+#define E_FSTK_OVER -11 /* floading-stack overflow */
+#define E_DSPACE_UNDER -12 /* dictionary-space underflow */
+#define E_DSPACE_OVER -13 /* dictionary-space overflow */
+#define E_NOFILE -14 /* unable to access image file */
+#define E_NOPRIM -15 /* primitive not implemented */
+#define E_FPE -16 /* floating point exception */
+#define E_SEGV -17 /* segmentation violation */
+#define E_FILENOTFOUND -18 /* file not found (during "included") */
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: exceptio.c
+ * Abstract: exception word set
+ */
+
+#include <malloc.h>
+#include <setjmp.h>
+#include "yforth.h"
+#include "core.h"
+#include "exceptio.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+struct exception_frame *top_frame; /* ptr to the top of exception stack */
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _catch() {
+ register struct exception_frame *frame =
+ (struct exception_frame *) malloc(sizeof(struct exception_frame));
+ if (frame) {
+ register int ret_val;
+ if ((ret_val = setjmp(frame->catch_buf)) == 0) {
+ /* Executed when "catch" is invoked */
+ save_input_specification();
+ frame->sp = sp + 1;
+ frame->rp = rp;
+ frame->bp = bp;
+ frame->fp = fp;
+ frame->last = top_frame;
+ top_frame = frame;
+ exec_word((struct word_def *) *sp++);
+ *--sp = 0;
+ } else *--sp = ret_val;
+ frame = top_frame;
+ sp = frame->sp;
+ rp = frame->rp;
+ bp = frame->bp;
+ top_frame = frame->last;
+ free(frame);
+ restore_input_specification();
+ }
+}
+
+void _throw() {
+ register Cell n = *sp++;
+ if (n) {
+ if (top_frame) longjmp(top_frame->catch_buf, n);
+ else if (n == -1) ;
+ else if (n == -2) _type();
+ sp = sp_top;
+ longjmp(warm_start_jump, 1);
+ }
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: exceptio.h
+ * Abstract: include file for "exception" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __EXCEPTION_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __EXCEPTION_H__
+#define __EXCEPTION_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+#ifdef PROTOTYPES
+struct exception_frame {
+ jmp_buf catch_buf;
+ Cell *sp, *rp, *bp;
+ Real *fp;
+ struct exception_frame *last;
+};
+#endif
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(catch, "catch", 0)
+code(throw, "throw", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: facility.c
+ * Abstract: facility word set
+ */
+
+#include "yforth.h"
+#include "udio.h"
+#include "facility.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _at_x_y() {
+ register Cell y = *sp++;
+ d_gotoxy(*sp++, y);
+}
+
+void _key_question() {
+ *--sp = FFLAG(d_kbhit());
+}
+
+void _page() {
+ d_clrscr();
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: facility.h
+ * Abstract: include file for "facility" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __FACILITY_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __FACILITY_H__
+#define __FACILITY_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(at_x_y, "at-xy", 0)
+code(key_question, "key?", 0)
+code(page, "page", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: file.c
+ * Abstract: File word set
+ */
+
+#include <stdio.h>
+#include <errno.h>
+#include <malloc.h>
+#include <string.h>
+#include "yforth.h"
+#include "core.h"
+#include "block.h"
+#include "file.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+static char *file_mode[] = {
+ "r", /* FILE_R_O */
+ "rb", /* FILE_R_O | FILE_BIN */
+ "w", /* FILE_W_O */
+ "wb", /* FILE_W_O | FILE_BIN */
+ "w+", /* FILE_R_W */
+ "w+b", /* FILE_R_W | FILE_BIN */
+ };
+
+Char file_name[FILE_NAME_SIZE];
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _bin() {
+ sp[0] |= FILE_BIN;
+}
+
+void _close_file() {
+ if (fclose((FILE *) sp[0])) sp[0] = (Cell) errno;
+ else sp[0] = 0;
+}
+
+void _create_file() {
+ register Cell fam = *sp++;
+ register FILE *f;
+ get_file_name();
+ if (fam & (~FILE_BIN) == FILE_R_O) fam = FILE_R_W | (fam & FILE_BIN);
+ f = fopen(file_name, file_mode[fam]);
+ *--sp = (Cell) f;
+ *--sp = (Cell) f ? 0 : errno;
+}
+
+void _delete_file() {
+ get_file_name();
+ if (remove(file_name)) *--sp = (Cell) errno;
+ else *--sp = 0;
+}
+
+void _file_position() {
+ register FILE *f = (FILE *) sp[0];
+ register DCell ud = ftell(f);
+ sp -= 2;
+ if (ud == -1L) sp[0] = (Cell) errno;
+ else {
+ PUT_DCELL(sp + 1, ud);
+ sp[0] = 0;
+ }
+}
+
+void _file_size() {
+ register FILE *f = (FILE *) sp[0];
+ register DCell o_pos = ftell(f);
+ if (o_pos != -1L) {
+ fseek(f, 0, SEEK_END);
+ _file_position();
+ fseek(f, o_pos, SEEK_SET);
+ } else {
+ sp -= 2;
+ sp[0] = (Cell) errno;
+ }
+}
+
+void _include_file() {
+ register FILE *f = (FILE *) *sp++;
+ save_input_specification();
+ _source_id = (Cell) f;
+ _input_buffer = malloc(FILE_BUFFER_SIZE);
+ _in_input_buffer = 0;
+ _b_l_k = 0;
+ if (_input_buffer) {
+ while (!feof(f) && !ferror(f) && !_error) {
+ if (fgets(_input_buffer, FILE_BUFFER_SIZE - 1, f)) {
+ _to_in = 0;
+ _in_input_buffer = strlen(_input_buffer);
+ if (_in_input_buffer && _input_buffer[_in_input_buffer - 1] == '\n')
+ _in_input_buffer--;
+ _interpret();
+ }
+ }
+ fclose(f);
+ free(_input_buffer);
+ }
+ restore_input_specification();
+}
+
+void _included() {
+ _r_o();
+ _open_file();
+ if ((_error = *sp++) == 0) _include_file();
+ else sp++;
+}
+
+void _open_file() {
+ register Cell fam = *sp++;
+ register FILE *f;
+ get_file_name();
+ f = fopen(file_name, file_mode[fam]);
+ *--sp = (Cell) f;
+ *--sp = (Cell) (f ? 0 : E_FILENOTFOUND);
+}
+
+void _r_o() {
+ *--sp = FILE_R_O;
+}
+
+void _r_w() {
+ *--sp = FILE_R_W;
+}
+
+void _read_file() {
+ register FILE *f = (FILE *) *sp++;
+ register UCell u1 = (UCell) *sp++;
+ register Char *buffer = (Char *) *sp++;
+ size_t rd = fread(buffer, 1, (size_t) u1, f);
+ *--sp = (Cell) rd;
+ *--sp = (Cell) ferror(f) ? errno : 0;
+}
+
+void _read_line() {
+ register FILE *f = (FILE *) *sp++;
+ register UCell u1 = (UCell) *sp++;
+ register Char *buffer = (Char *) *sp++;
+ if (fgets(buffer, u1 + 1, f)) {
+ int len = strlen(buffer);
+ if (len && buffer[len - 1] == '\n') len--;
+ *--sp = 0;
+ *--sp = FFLAG(1);
+ *--sp = len;
+ } else {
+ *--sp = (Cell) errno;
+ *--sp = FFLAG(0);
+ *--sp = 0;
+ }
+}
+
+void _reposition_file() {
+ register FILE *f = (FILE *) *sp++;
+ register UDCell ud = GET_DCELL(sp);
+ sp++;
+ if (fseek(f, ud, SEEK_SET)) sp[0] = errno;
+ else sp[0] = 0;
+}
+
+void _resize_file() {
+ register FILE *f = (FILE *) sp[0];
+ register UDCell ud = GET_DCELL(sp + 1), ud1;
+ register Cell ior;
+ _file_size();
+ ior = *sp++;
+ if (!ior) {
+ ud1 = GET_DCELL(sp);
+ if (ud < ud1) ior = truncate_file(f, ud1, ud);
+ else if (ud > ud1) ior = expand_file(f, ud1, ud);
+ }
+ sp += 3;
+ sp[0] = ior;
+}
+
+void _w_o() {
+ *--sp = FILE_W_O;
+}
+
+void _write_file() {
+ register FILE *f = (FILE *) *sp++;
+ register UCell u = (UCell) *sp++;
+ register Char *buffer = (Char *) *sp;
+ if (fwrite(buffer, 1, (size_t) u, f) < u) sp[0] = errno;
+ else sp[0] = 0;
+}
+
+void _write_line() {
+ register FILE *f = (FILE *) *sp++;
+ register UCell u = (UCell) *sp++;
+ register Char *buffer = (Char *) *sp;
+ while (u--) if (fputc(*buffer++, f) == EOF) break;
+ if (!ferror(f)) fputc('\n', f);
+ if (ferror(f)) sp[0] = errno;
+ else sp[0] = 0;
+}
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS ****************************************************/
+/**************************************************************************/
+
+Cell truncate_file(FILE *f, UDCell cur, UDCell ud) {
+ if (cur == cur && fseek(f, ud, SEEK_SET)) return (errno);
+ else return (0);
+}
+
+Cell expand_file(FILE *f, UDCell cur, UDCell ud) {
+ fseek(f, 0, SEEK_END);
+ while (cur < ud && !ferror(f)) {
+ fputc(' ', f);
+ cur++;
+ }
+ if (ferror(f)) return (errno);
+ else return (0);
+}
+
+Char *get_file_name() {
+ register UCell u = (UCell) *sp++;
+ register Char *buffer = (Char *) *sp++;
+ memcpy(file_name, buffer, u);
+ file_name[u] = '\0';
+ return (file_name);
+}
+
+void load_file(Char *name) {
+ *--sp = (Cell) name;
+ *--sp = strlen(name);
+ _included();
+}
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: file.h
+ * Abstract: File word-set include file
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __FILE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __FILE_H__
+#define __FILE_H__
+
+#include <stdio.h>
+#include "yforth.h"
+#include "macro.h"
+
+#define FILE_R_O 0
+#define FILE_W_O 2
+#define FILE_R_W 4
+#define FILE_BIN 1
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(bin, "bin", 0)
+code(close_file, "close-file", 0)
+code(create_file, "create-file", 0)
+code(delete_file, "delete-file", 0)
+code(file_position, "file-position", 0)
+code(file_size, "file-size", 0)
+code(include_file, "include-file", 0)
+code(included, "included", 0)
+code(open_file, "open-file", 0)
+code(r_o, "r/o", 0)
+code(r_w, "r/w", 0)
+code(read_file, "read-file", 0)
+code(read_line, "read-line", 0)
+code(reposition_file, "reposition-file", 0)
+code(resize_file, "resize-file", 0)
+code(w_o, "w/o", 0)
+code(write_file, "write-file", 0)
+code(write_line, "write-line", 0)
+
+#ifdef PROTOTYPES
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS PROTOTYPES *****************************************/
+/**************************************************************************/
+
+Cell truncate_file(FILE *f, UDCell cur, UDCell ud);
+Cell expand_file(FILE *f, UDCell cur, UDCell ud);
+Char *get_file_name(void);
+void load_file(Char *name);
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: filee.c
+ * Abstract: File extension word set
+ */
+
+#include <stdio.h>
+#include <string.h>
+#include <malloc.h>
+#include <errno.h>
+#include "yforth.h"
+#include "file.h"
+#include "filee.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+extern Char file_name[];
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _file_status() {
+ register FILE *f;
+ get_file_name();
+ f = fopen(file_name, "rb");
+ *--sp = 0;
+ if (f) {
+ *--sp = 0;
+ fclose(f);
+ } else *--sp = errno;
+}
+
+void _flush_file() {
+ register FILE *f = (FILE *) *sp;
+ if (fflush(f)) sp[0] = errno;
+ else sp[0] = 0;
+}
+
+void _rename_file() {
+ register Char *file_name2;
+ get_file_name();
+ file_name2 = (Char *) malloc(strlen(file_name) + 1);
+ if (file_name2) {
+ strcpy(file_name2, file_name);
+ get_file_name();
+ if (rename(file_name, file_name2)) *--sp = errno;
+ else *--sp = 0;
+ free(file_name2);
+ } else *--sp = errno;
+}
+
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: filee.h
+ * Abstract: Include file for "File extension" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __FILEE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __FILEE_H__
+#define __FILEE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(file_status, "file-status", 0)
+code(flush_file, "flush-file", 0)
+code(rename_file, "rename-file", 0)
+
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: float.c
+ * Abstract: floating word set
+ */
+
+#include <math.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <ctype.h>
+#include "yforth.h"
+#include "core.h"
+#include "float.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _to_float() {
+ register Cell len = *sp++;
+ register Char *s = (Char *) *sp;
+ extern Char *s_tmp_buffer[];
+ Char *endptr;
+ memcpy(s_tmp_buffer, s, len);
+ if (toupper(s[len - 1]) == 'E' || toupper(s[len - 1]) == 'D') s[len++] = '0';
+ s[len] = '\0';
+ *--fp = (Real) strtod(s, &endptr);
+ if (!*endptr) *sp = FFLAG(1);
+ else {
+ *sp = FFLAG(0);
+ fp++;
+ }
+}
+
+void _d_to_f() {
+ register DCell d = GET_DCELL(sp);
+ *--fp = (Real) d;
+ sp += 2;
+}
+
+void _f_store() {
+ register Real *addr = (Real *) *sp++;
+ *addr = *fp++;
+}
+
+void _f_star() {
+ fp[1] *= fp[0];
+ fp++;
+}
+
+void _f_plus() {
+ fp[1] += fp[0];
+ fp++;
+}
+
+void _f_minus() {
+ fp[1] -= fp[0];
+ fp++;
+}
+
+void _f_slash() {
+ fp[1] /= fp[0];
+ fp++;
+}
+
+void _f_zero_less() {
+ sp--;
+ *sp = FFLAG(*fp < 0.0);
+ fp++;
+}
+
+void _f_zero_equals() {
+ sp--;
+ *sp = FFLAG(*fp == 0.0);
+ fp++;
+}
+
+void _f_less_than() {
+ sp--;
+ *sp = FFLAG(fp[1] < fp[0]);
+ fp += 2;
+}
+
+void _f_to_d() {
+ register DCell d = (DCell) *fp++;
+ sp -= 2;
+ PUT_DCELL(sp, d);
+}
+
+void _f_fetch() {
+ *--fp = *((Real *) *sp++);
+}
+
+void _f_constant() {
+ register Real r = *fp++;
+ create_definition(A_FCONSTANT);
+ compile_real(r);
+ mark_word(_last);
+}
+
+void _f_depth() {
+ *--sp = fp_top - fp;
+}
+
+void _f_drop() {
+ fp++;
+}
+
+void _f_dupe() {
+ fp--;
+ fp[0] = fp[1];
+}
+
+void _f_literal() {
+ compile_cell((Cell) _do_fliteral);
+ compile_real(fp[0]);
+ fp++;
+}
+
+void _float_plus() {
+ sp[0] += sizeof(Real);
+}
+
+void _floats() {
+ sp[0] *= sizeof(Real);
+}
+
+void _floor() {
+ fp[0] = floor(fp[0]);
+}
+
+void _f_max() {
+ if (fp[0] > fp[1]) fp[1] = fp[0];
+ fp++;
+}
+
+void _f_min() {
+ if (fp[0] < fp[1]) fp[1] = fp[0];
+ fp++;
+}
+
+void _f_negate() {
+ fp[0] = -fp[0];
+}
+
+void _f_over() {
+ fp--;
+ fp[0] = fp[2];
+}
+
+void _f_rote() {
+ register Real temp = fp[0];
+ fp[0] = fp[2];
+ fp[2] = fp[1];
+ fp[1] = temp;
+}
+
+void _f_round() {
+ fp[0] = floor(fp[0] + 0.5);
+}
+
+void _f_swap() {
+ register Real temp = fp[0];
+ fp[0] = fp[1];
+ fp[1] = temp;
+}
+
+void _f_variable() {
+ create_definition(A_FVARIABLE);
+ compile_real(0.0);
+ mark_word(_last);
+}
+
+void _represent() {
+ register Real x = *fp++;
+ register int m;
+ register int sign = 0;
+ static char buf[128];
+ if (x < 0.0) {
+ sign = 1;
+ x = -x;
+ }
+ if (x != 0.0) {
+ m = (int) floor(log10(x)) + 1;
+ x /= pow(10, m);
+ if (x >= 1.0) {
+ x /= 10;
+ m++;
+ }
+ } else m = 0;
+ sprintf(buf, "%0.*f", sp[0], x);
+ strncpy((Char *) sp[1], buf + 2, sp[0]);
+ sp--;
+ sp[2] = m;
+ sp[1] = FFLAG(sign);
+ sp[0] = FFLAG(1);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: float.h
+ * Abstract: include file for "floating" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __FLOAT_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __FLOAT_H__
+#define __FLOAT_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(to_float, ">float", 0)
+code(d_to_f, "d>f", 0)
+code(f_store, "f!", 0)
+code(f_star, "f*", 0)
+code(f_plus, "f+", 0)
+code(f_minus, "f-", 0)
+code(f_slash, "f/", 0)
+code(f_zero_less, "f0<", 0)
+code(f_zero_equals, "f0=", 0)
+code(f_less_than, "f<", 0)
+code(f_to_d, "f>d", 0)
+code(f_fetch, "f@", 0)
+code(align, "falign", 0)
+code(aligned, "faligned", 0)
+code(f_constant, "fconstant", 0)
+code(f_depth, "fdepth", 0)
+code(f_drop, "fdrop", 0)
+code(f_dupe, "fdup", 0)
+code(f_literal, "fliteral", COMP_ONLY | IMMEDIATE)
+code(float_plus, "float+", 0)
+code(floats, "floats", 0)
+code(floor, "floor", 0)
+code(f_max, "fmax", 0)
+code(f_min, "fmin", 0)
+code(f_negate, "fnegate", 0)
+code(f_over, "fover", 0)
+code(f_rote, "frot", 0)
+code(f_round, "fround", 0)
+code(f_swap, "fswap", 0)
+code(f_variable, "fvariable", 0)
+code(represent, "represent", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: floate.c
+ * Abstract: floating-extension word set
+ */
+
+#include <stdio.h>
+#include <math.h>
+#include "yforth.h"
+#include "floate.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+static Cell precision = 15;
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _d_f_store() {
+ register double *addr = (double *) *sp++;
+ *addr = (double) *fp++;
+}
+
+void _d_f_fetch() {
+ register double *addr = (double *) *sp++;
+ *--fp = (Real) *addr;
+}
+
+void _d_float_plus() {
+ sp[0] += sizeof(double);
+}
+
+void _d_floats() {
+ sp[0] *= sizeof(double);
+}
+
+void _f_star_star() {
+ fp[1] = pow(fp[1], fp[0]);
+ fp++;
+}
+
+void _f_dot() {
+ printf("%.*f ", precision, (double) *fp++);
+}
+
+void _f_abs() {
+ *fp = fabs(*fp);
+}
+
+void _f_a_cos() {
+ *fp = acos(*fp);
+}
+
+void _f_a_cosh() {
+#ifdef HAVE_ACOSH
+ *fp = acosh(*fp);
+#else
+ *fp = log(*fp + sqrt(*fp * *fp - 1));
+#endif
+}
+
+void _f_a_log() {
+ *fp = pow(10, *fp);
+}
+
+void _f_a_sin() {
+ *fp = asin(*fp);
+}
+
+void _f_a_sinh() {
+#ifdef HAVE_ASINH
+ *fp = asinh(*fp);
+#else
+ *fp = log(*fp + sqrt(*fp * *fp + 1));
+#endif
+}
+
+void _f_a_tan() {
+ *fp = atan(*fp);
+}
+
+void _f_a_tan2() {
+ fp[1] = atan2(fp[1], fp[0]);
+ fp++;
+}
+
+void _f_a_tanh() {
+#ifdef HAVE_ATANH
+ *fp = atanh(*fp);
+#else
+ *fp = 0.5 * log((1 + *fp) / (1 - *fp));
+#endif
+}
+
+void _f_cos() {
+ *fp = cos(*fp);
+}
+
+void _f_cosh() {
+ *fp = cosh(*fp);
+}
+
+void _f_e_dot() {
+ register Real r = *fp++;
+ register int esp = 0;
+ if (r != 0.0)
+ while (r < 1.0 || r > 1000.0) {
+ if (r < 1.0) {
+ r *= 1000.0;
+ esp -= 3;
+ } else {
+ r /= 1000.0;
+ esp += 3;
+ }
+ }
+ printf("%.*fE%d ", precision, (double) r, esp);
+}
+
+void _f_exp() {
+ *fp = exp(*fp);
+}
+
+void _f_exp_m_one() {
+ *fp = exp(*fp) - 1.0;
+}
+
+void _f_ln() {
+ *fp = log(*fp);
+}
+
+void _f_ln_p_one() {
+ *fp = log(*fp) + 1.0;
+}
+
+void _f_log() {
+ *fp = log10(*fp);
+}
+
+void _f_s_dot() {
+ printf("%.*e ", precision, (double) *fp++);
+}
+
+void _f_sin() {
+ *fp = sin(*fp);
+}
+
+void _f_sin_cos() {
+ fp--;
+ fp[0] = cos(fp[1]);
+ fp[1] = sin(fp[1]);
+}
+
+void _f_sinh() {
+ *fp = sinh(*fp);
+}
+
+void _f_sqrt() {
+ *fp = sqrt(*fp);
+}
+
+void _f_tan() {
+ *fp = tan(*fp);
+}
+
+void _f_tanh() {
+ *fp = tanh(*fp);
+}
+
+void _f_proximate() {
+ register Real r3 = *fp++;
+ register Real r2 = *fp++;
+ register Real r1 = *fp++;
+ if (r3 > 0.0) *--sp = FFLAG(fabs(r1 - r2) < r3);
+ else if (r3 < 0.0) *--sp = FFLAG(fabs(r1 - r2) < (-r3) * (fabs(r1) + fabs(r2)));
+ else *--sp = FFLAG(r1 == r2);
+}
+
+void _precision() {
+ *--sp = precision;
+}
+
+void _set_precision() {
+ precision = *sp++;
+}
+
+void _s_f_store() {
+ register float *addr = (float *) *sp++;
+ *addr = (float) *fp++;
+}
+
+void _s_f_fetch() {
+ register float *addr = (float *) *sp++;
+ *--fp = (Real) *addr;
+}
+
+void _s_float_plus() {
+ sp[0] += sizeof(float);
+}
+
+void _s_floats() {
+ sp[0] *= sizeof(float);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: floate.h
+ * Abstract: include file for "floating-extension" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __FLOATE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __FLOATE_H__
+#define __FLOATE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(d_f_store, "df!", 0)
+code(d_f_fetch, "df@", 0)
+code(align, "dfalign", 0)
+code(aligned, "dfaligned", 0)
+code(d_float_plus, "dfloat+", 0)
+code(d_floats, "dfloats", 0)
+code(f_star_star, "f**", 0)
+code(f_dot, "f.", 0)
+code(f_abs, "fabs", 0)
+code(f_a_cos, "facos", 0)
+code(f_a_cosh, "facosh", 0)
+code(f_a_log, "falog", 0)
+code(f_a_sin, "fasin", 0)
+code(f_a_sinh, "fasinh", 0)
+code(f_a_tan, "fatan", 0)
+code(f_a_tan2, "fatan2", 0)
+code(f_a_tanh, "fatanh", 0)
+code(f_cos, "fcos", 0)
+code(f_cosh, "fcosh", 0)
+code(f_e_dot, "fe.", 0)
+code(f_exp, "fexp", 0)
+code(f_exp_m_one, "fexpm1", 0)
+code(f_ln, "fln", 0)
+code(f_ln_p_one, "flnp1", 0)
+code(f_log, "flog", 0)
+code(f_s_dot, "fs.", 0)
+code(f_sin, "fsin", 0)
+code(f_sin_cos, "fsincos", 0)
+code(f_sinh, "fsinh", 0)
+code(f_sqrt, "fsqrt", 0)
+code(f_tan, "ftan", 0)
+code(f_tanh, "ftanh", 0)
+code(f_proximate, "f~", 0)
+code(precision, "precision", 0)
+code(set_precision, "set-precision", 0)
+code(s_f_store, "sf!", 0)
+code(s_f_fetch, "sf@", 0)
+code(align, "sfalign", 0)
+code(aligned, "sfaligned", 0)
+code(s_float_plus, "sfloat+", 0)
+code(s_floats, "sfloats", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: locals.c
+ * Abstract: locals word set
+ */
+
+/* Implementation notes
+ * Local variables make use of the register "bp" of the Virtual Machine,
+ * which stores the location, wihtin the return stack, of the first
+ * local variable. All references to local variables are made relative
+ * to this register. This implies that "bp" must be saved between calls of
+ * words that make use of local variables, and every "exiting word" that
+ * make a word terminate must reset it.
+ * This is achieved by an auxiliary variable, called "local_defined", set
+ * to 1 inside a colon definition when local variables are used.
+ * Local names are stored dinamically by allocating a structure "word_def"
+ * for any name. The function which searches the vocabulary for a particular
+ * word has been modified accordingly so that the first try is always made
+ * in this dynamic vocabulary, pointed by "first_local".
+ */
+
+#include <string.h>
+#include <stdlib.h>
+#include "yforth.h"
+#include "core.h"
+#include "locals.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+static struct word_def *first_local;
+static unsigned int local_defined;
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _paren_local_paren() {
+ register UCell u = (UCell) *sp++;
+ register Char *s = (Char *) *sp++;
+ declare_local(s, u);
+}
+
+/* restore "bp" register from return stack */
+void _paren_bp_restore_paren() {
+ rp += (Cell) *ip++;
+ bp = (Cell *) *rp++;
+}
+
+/* save "bp" register on return stack */
+void _paren_bp_save_paren() {
+ *--rp = (Cell) bp;
+ bp = rp - 1;
+}
+
+/* push on the data stack the value of i-th local variable, where i is the
+ * Cell value pointed to by "ip" when "_paren_read_local_paren" is called.
+ */
+void _paren_read_local_paren() {
+ register UCell offset = (UCell) *ip++;
+ *--sp = *(bp - offset);
+}
+
+/* update the i-th local variable with the Cell value on the data stack.
+ * See "_paren_read_local_paren" for a comment about the value "i"
+ */
+void _paren_write_local_paren() {
+ register UCell offset = (UCell) *ip++;
+ *(bp - offset) = *sp++;
+}
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS ****************************************************/
+/**************************************************************************/
+
+/* clear_locals: called inside the compilation of a colon definition to
+ * compile the code that restore "bp" and free the dynamic vocabulary of
+ * local names
+ */
+void clear_locals() {
+ if (local_defined) {
+ compile_cell((Cell) _paren_bp_restore_paren);
+ compile_cell((Cell) local_defined); /* # di variabili locali */
+ }
+ free_locals();
+ local_defined = 0;
+}
+
+/* free_locals: release the dynamic vocabulary. Called by "clear_locals". */
+void free_locals() {
+ register struct word_def *p = first_local, *p1;
+ while (p) {
+ free(p->name);
+ p1 = p->link;
+ free(p);
+ p = p1;
+ }
+ first_local = NULL;
+}
+
+void init_locals() {
+}
+
+/* declare_local: declare a new local variable. If it's the first local
+ * variable for the current colon definition, compile the code to save
+ * the register "bp"
+ */
+void declare_local(Char *s, UCell u) {
+ struct word_def *p = (struct word_def *) malloc(sizeof(struct word_def));
+ if (p) {
+ p->name = (Char *) malloc(u + 1);
+ if (p->name) {
+ p->name[0] = (Char) u;
+ memcpy(p->name + 1, s, u);
+ p->link = first_local;
+ p->class = A_LOCAL;
+ p->func[0] = (pfp) (local_defined++);
+ if (!first_local) compile_cell((Cell) _paren_bp_save_paren);
+ first_local = p;
+ } else free(p);
+ }
+}
+
+/* get_first_local: interface function that returns a pointer to the first
+ * local name defined (actually is the last name, since names are stored
+ * in reverse order for efficiency, but this doesn't matter)
+ */
+struct word_def *get_first_local() {
+ return (first_local);
+}
+
+/* locals_defined: interface function that returns true if current word
+ * has some local name defined
+ */
+int locals_defined() {
+ return (local_defined);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: locals.h
+ * Abstract: include file for "locals" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __LOCALS_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __LOCALS_H__
+#define __LOCALS_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(paren_local_paren, "(local)", COMP_ONLY)
+
+code(paren_bp_restore_paren, "(bp!)", 0)
+code(paren_bp_save_paren, "(bp@)", 0)
+code(paren_read_local_paren, "(rLocal)", 0)
+code(paren_write_local_paren, "(wLocal)", 0)
+
+#ifdef PROTOTYPES
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS PROTOTYPES *****************************************/
+/**************************************************************************/
+
+void clear_locals(void);
+void free_locals(void);
+void init_locals(void);
+void declare_local(Char *s, UCell u);
+struct word_def *get_first_local(void);
+int locals_defined(void);
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: localse.c
+ * Abstract: locals-extension word set
+ */
+
+#include "yforth.h"
+#include "core.h"
+#include "locals.h"
+#include "localse.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _locals_bar() {
+ while (1) {
+ _b_l();
+ _word();
+ _count();
+ if (sp[0] != 1 || *((Char *) sp[1]) != '|') {
+ _paren_local_paren();
+ compile_cell((Cell) _to_r);
+ } else break;
+ }
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: localse.h
+ * Abstract: include file for "locals-extension" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __LOCALSE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __LOCALSE_H__
+#define __LOCALSE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(locals_bar, "locals|", COMP_ONLY | IMMEDIATE)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+
+#if defined DECLARE_WORDS
+ #ifdef code
+ # undef code
+ #endif
+ #ifdef variable
+ # undef variable
+ #endif
+ #define code(name, cname, class) { cname, _##name, A_PRIMITIVE | class },
+ #define variable(type, name, cname) { cname, (void (*)(void)) &_##name, A_USER },
+#elif defined PROTOTYPES
+ #define code(name, cname, class) void _##name(void);
+ #define variable(type, name, cname) extern type _##name;
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: memall.c
+ * Abstract: Memory allocation word set
+ */
+
+#include <string.h>
+#include <malloc.h>
+#include "yforth.h"
+#include "core.h"
+#include "coree.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _allocate() {
+ register void *addr = malloc(*sp);
+ if (addr == NULL) *sp = 0;
+ else *sp = (Cell) addr;
+ *--sp = FFLAG(addr == NULL);
+}
+
+void _free() {
+ free((void *) *sp);
+ *sp = FFLAG(0);
+}
+
+void _resize() {
+ register void *addr = realloc((void *) sp[1], sp[0]);
+ if (addr == NULL) sp[1] = 0;
+ else sp[1] = (Cell) addr;
+ *sp = FFLAG(addr == NULL);
+}
+
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: memall.h
+ * Abstract: Include file for "Memory Allocation" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __MEMALL_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __MEMALL_H__
+#define __MEMALL_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(allocate, "allocate", 0)
+code(free, "free", 0)
+code(resize, "resize", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name:
+ * Abstract:
+ */
+
+#include <stdlib.h>
+#include "core.h"
+#include "search.h"
+
+/**************************************************************************/
+/* VARIABLES **************************************************************/
+/**************************************************************************/
+
+struct vocabulary *list[WORD_LISTS];
+Cell top; /* indice primo vocabolario sulla pila */
+struct vocabulary *voc; /* ptr al vocabolario usato per le definzioni */
+struct vocabulary *forth_wid;
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _definitions() {
+ voc = list[top];
+}
+
+void _forth_wordlist() {
+ *--sp = (Cell) forth_wid;
+}
+
+void _get_current() {
+ *--sp = (Cell) voc;
+}
+
+void _get_order() {
+ register Cell i;
+ for (i = 0; i <= top; i++) *--sp = (Cell) list[i];
+ *--sp = top;
+}
+
+void _search_wordlist() {
+ register struct vocabulary *wid = (struct vocabulary *) *sp++;
+ register Cell len = *sp++;
+ register Char *addr = (Char *) *sp;
+ register struct word_def *xt = search_wordlist(addr, len, wid);
+ set_find_stack(addr, xt);
+ if (!*sp) *++sp = 0;
+}
+
+void _set_current() {
+ voc = (struct vocabulary *) *sp++;
+}
+
+void _set_order() {
+ register Cell n = *sp++;
+ register int i;
+ for (i = 0; i < n; i++)
+ if (i < WORD_LISTS) list[i] = (struct vocabulary *) *sp++;
+ else sp++;
+ top = n - 1;
+}
+
+void _wordlist() {
+ register struct vocabulary *v;
+ register int i;
+ _align();
+ v = (struct vocabulary *) _dp;
+ _dp += sizeof(struct vocabulary);
+ for (i = 0; i < VOC_HASH; i++) v->voc[i] = NULL;
+ *--sp = (Cell) v;
+}
+
+
+/**************************************************************************/
+/* AUXILIARY FUNCTIONS ****************************************************/
+/**************************************************************************/
+
+void save_vocabulary(struct voc_marker *vm) {
+ register int i;
+ for (i = 0; i < WORD_LISTS; i++) {
+ vm->list[i] = list[i];
+ if (list[i]) vm->v_list[i] = *list[i];
+ }
+ vm->top = top;
+ vm->voc = voc;
+ vm->_dp = _dp;
+ vm->last = _last;
+}
+
+void load_vocabulary(struct voc_marker *vm) {
+ register int i;
+ for (i = 0; i < WORD_LISTS; i++) {
+ list[i] = vm->list[i];
+ if (list[i]) *list[i] = vm->v_list[i];
+ }
+ top = vm->top;
+ voc = vm->voc;
+ _dp = vm->_dp;
+ _last = vm->last;
+}
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name:
+ * Abstract:
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __SEARCH_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __SEARCH_H__
+#define __SEARCH_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(definitions, "definitions", 0)
+code(forth_wordlist, "forth-wordlist", 0)
+code(get_current, "get-current", 0)
+code(get_order, "get-order", 0)
+code(search_wordlist, "search-wordlist", 0)
+code(set_current, "set-current", 0)
+code(set_order, "set-order", 0)
+code(wordlist, "wordlist", 0)
+
+#ifdef PROTOTYPES
+
+/**************************************************************************/
+/* AUXILIARY FUNCSIONS PROTOTYPES *****************************************/
+/**************************************************************************/
+
+void save_vocabulary(struct voc_marker *vm);
+void load_vocabulary(struct voc_marker *vm);
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name:
+ * Abstract:
+ */
+
+#include <stdio.h>
+#include "yforth.h"
+#include "searche.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _also() {
+ if (top < WORD_LISTS) {
+ top++;
+ list[top] = list[top - 1];
+ }
+}
+
+void _forth() {
+ list[top] = forth_wid;
+}
+
+void _only() {
+ top = 0;
+ list[0] = forth_wid;
+}
+
+void _order() {
+ register int i;
+ printf("[%p] ", voc);
+ for (i = 0; i <= top; i++) printf("%d: %p ", i, list[i]);
+}
+
+void _previous() {
+ if (top >= 0) top--;
+}
+
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name:
+ * Abstract:
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __SEARCHE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __SEARCHE_H__
+#define __SEARCHE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(also, "also", 0)
+code(forth, "forth", 0)
+code(only, "only", 0)
+code(order, "order", 0)
+code(previous, "previous", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name:
+ * Abstract:
+ */
+
+#include <string.h>
+#include <ctype.h>
+#include "yforth.h"
+#include "string.h"
+#include "core.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _dash_trailing() {
+ register Char *s = (Char *) sp[1];
+ register int i = sp[0];
+ while (i-- > 0) if (!isspace(s[i])) break;
+ sp[0] = i + 1;
+}
+
+void _slash_string() {
+ register Cell n = *sp++;
+ sp[1] = (Cell) ((Char *) sp[1] + n);
+ sp[0] -= n;
+}
+
+void _blank() {
+ register UCell u = (UCell) *sp++;
+ register Char *s = (Char *) *sp++;
+ if (u) memset(s, ' ', u);
+}
+
+void _c_move() {
+ register UCell u = (UCell) *sp++;
+ register Char *dest = (Char *) *sp++;
+ register Char *source = (Char *) *sp++;
+ while (u--) *dest++ = *source++;
+}
+
+void _c_move_up() {
+ register UCell u = (UCell) *sp++;
+ register Char *dest = (Char *) *sp++ + u;
+ register Char *source = (Char *) *sp++ + u;
+ while (u--) *--dest = *--source;
+}
+
+void _compare() {
+ register UCell u2 = (UCell) *sp++;
+ register Char *s2 = (Char *) *sp++;
+ register UCell u1 = (UCell) *sp++;
+ register Char *s1 = (Char *) *sp;
+ register UCell m = u2 <= u1 ? u2 : u1;
+ while (m) {
+ if (*s1 != *s2) break;
+ s1++;
+ s2++;
+ m--;
+ }
+ if (u1 == u2 && !m) *sp = 0;
+ else if (!m) *sp = u1 < u2 ? -1 : 1;
+ else *sp = *s1 < *s2 ? -1 : 1;
+}
+
+void _search() {
+ register UCell u2 = (UCell) *sp++;
+ register Char *s2 = (Char *) sp[0];
+ register UCell u1 = (UCell) sp[1];
+ register Char *s1 = (Char *) sp[2];
+ if (u2 > u1) *sp = FFLAG(0);
+ else {
+ while (u1 >= u2) {
+ *--sp = (Cell) s1;
+ *--sp = (Cell) u1;
+ *--sp = (Cell) s2;
+ *--sp = (Cell) u2;
+ _compare();
+ if (!(*sp++)) {
+ sp[2] = (Cell) s1;
+ sp[1] = (Cell) u1;
+ sp[0] = FFLAG(1);
+ break;
+ } else {
+ s1++;
+ u1--;
+ }
+ }
+ }
+}
+
+void _s_literal() {
+ register UCell u = (UCell) *sp++;
+ register Char *s = (Char *) *sp++;
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) s);
+ compile_cell((Cell) _do_literal);
+ compile_cell((Cell) u);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name:
+ * Abstract:
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __STRING_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __STRING_H__
+#define __STRING_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(dash_trailing, "-trailing", 0)
+code(slash_string, "/string", 0)
+code(blank, "blank", 0)
+code(c_move, "cmove", 0)
+code(c_move_up, "cmove>", 0)
+code(compare, "compare", 0)
+code(search, "search", 0)
+code(s_literal, "sliteral", COMP_ONLY | IMMEDIATE)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: tools.c
+ * Abstract: Programming Tools word set
+ */
+
+#include <stdio.h>
+#include "yforth.h"
+#include "tools.h"
+#include "core.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _dot_s() {
+ register Cell *p = sp;
+ while (p < sp_top) {
+ *--sp = *p;
+ _dot();
+ p++;
+ }
+}
+
+void _question() {
+ _fetch();
+ _dot();
+}
+
+void _dump() {
+ register UCell u = *sp++;
+ register Char *addr = (Char *) *sp++;
+ while (u) {
+ register int i;
+ printf("%08p: ", addr);
+ for (i = 0; i < 16; i++)
+ if ((int) (u - i) > 0) printf("%02x ", *(addr + i) & 0xff);
+ else printf(" ");
+ for (i = 0; i < 16 && (u - i) > 0; i++)
+ printf("%c", *(addr + i) < 32 ? '.' : *(addr + i));
+ putchar('\n');
+ addr += i;
+ u -= i;
+ }
+}
+
+void _see() {
+ _error = E_NOPRIM;
+}
+
+void _words() {
+ register int i = 0;
+ register struct word_def *p;
+ register Cell col = 1;
+ while (i < VOC_HASH) {
+ p = voc->voc[i++];
+ while (p) {
+ *--sp = (Cell) p->name;
+ _count();
+ if (col + sp[0] > 79) {
+ col = 1;
+ _c_r();
+ }
+ col += sp[0] + 1;
+ _type();
+ _b_l();
+ _emit();
+ p = p->link;
+ }
+ }
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: tools.h
+ * Abstract: Include file for "Programming Tools" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __TOOLS_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __TOOLS_H__
+#define __TOOLS_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(dot_s, ".s", 0)
+code(question, "?", 0)
+code(dump, "dump", 0)
+code(see, "see", 0)
+code(words, "words", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: toolse.c
+ * Abstract: Programming Tools extension word set
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include "yforth.h"
+#include "toolse.h"
+#include "core.h"
+#include "coree.h"
+#include "block.h"
+
+/**************************************************************************/
+/* WORDS ******************************************************************/
+/**************************************************************************/
+
+void _bye() {
+#if BLOCK_DEF
+ close_block_file();
+#endif
+ exit(0);
+}
+
+void _ahead() {
+ compile_cell((Cell) _branch);
+ *--sp = (Cell) _dp;
+ compile_cell(0);
+}
+
+void _bracket_if() {
+ register Cell flag = *sp++;
+ register Cell nest = 1;
+ register Cell ok = FFLAG(1);
+ if (!flag) {
+ do {
+ _b_l();
+ _word();
+ sp++;
+ if (!*_dp) {
+ _refill();
+ ok = *sp++;
+ } else {
+ if (!strmatch("[IF]", _dp, 4)) nest++;
+ else if (!strmatch("[THEN]", _dp, 6) ||
+ (!strmatch("[ELSE]", _dp, 6) && nest == 1)) nest--;
+ }
+ } while (nest && ok);
+ }
+}
+
+void _bracket_else() {
+ register Cell nest = 1;
+ register Cell ok = FFLAG(1);
+ do {
+ _b_l();
+ _word();
+ sp++;
+ if (!*_dp) {
+ _refill();
+ ok = *sp++;
+ } else {
+ if (!strmatch("[IF]", _dp, 4)) nest++;
+ else if (!strmatch("[THEN]", _dp, 6)) nest--;
+ }
+ } while (nest && ok);
+}
+
+void _bracket_then() {
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: toolse.h
+ * Abstract: Include file for "Programming Tools extension" word set
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __TOOLSE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __TOOLSE_H__
+#define __TOOLSE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(ahead, "ahead", COMP_ONLY | IMMEDIATE)
+code(bye, "bye", 0)
+code(pick, "cs-pick", COMP_ONLY)
+code(roll, "cs-roll", COMP_ONLY)
+code(bracket_else, "[else]", IMMEDIATE)
+code(bracket_if, "[if]", IMMEDIATE)
+code(bracket_then, "[then]", IMMEDIATE)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: udio.c
+ * Abstract: User Device Input/Output functions. Here are enclosed all
+ * non-portable functions.
+ */
+
+#include "yforth.h"
+#ifdef HAVE_CONIO
+# include <conio.h>
+#elifdef HAVE_CURSES
+# include <curses.h>
+#endif
+#include "udio.h"
+
+/* d_clrscr: clear the screen */
+void d_clrscr() {
+#ifdef HAVE_CONIO
+ clrscr();
+#elifdef HAVE_CURSES
+ clear();
+#endif
+}
+
+/* d_clreol: clear to end of line */
+void d_clreol() {
+#ifdef HAVE_CONIO
+ clreol();
+#elifdef HAVE_CURSES
+ clrtoeol();
+#endif
+}
+
+/* d_setattr: set default attributes */
+void d_setaddr(Cell attr) {
+#ifdef HAVE_CONIO
+ textattr(attr);
+#elifdef HAVE_CURSES
+#endif
+}
+
+/* d_getattr: get default attributes */
+Cell d_getattr() {
+#ifdef HAVE_CONIO
+ struct text_info ti;
+ gettextinfo(&ti);
+ return (ti.attribute);
+#elifdef HAVE_CURSES
+#endif
+}
+
+/* d_gotoxy: move the cursor to the location (x, y) of the screen */
+void d_gotoxy(Cell x, Cell y) {
+#ifdef HAVE_CONIO
+ gotoxy(x, y);
+#elifdef HAVE_CURSES
+ move(y, x);
+#endif
+}
+
+/* d_wherex: current column position of the cursor */
+Cell d_wherex() {
+#ifdef HAVE_CONIO
+ return (wherex());
+#elifdef HAVE_CURSES
+ int x, y;
+ getyx(stdscr, y, x);
+ return ((Cell) x);
+#endif
+}
+
+/* d_wherey: current row position of the cursor */
+Cell d_wherey() {
+#ifdef HAVE_CONIO
+ return (wherey());
+#elifdef HAVE_CURSES
+ int x, y;
+ getyx(stdscr, y, x);
+ return ((Cell) y);
+#endif
+}
+
+/* d_getch: read a characted from the input device without displaying it and
+ * return as soon as the character is enteres (i.e. no wait for Carriage
+ * Return
+ */
+Char d_getch() {
+#ifdef HAVE_CONIO
+ return (getch());
+#elifdef HAVE_CURSES
+ return (getch());
+#endif
+}
+
+/* d_kbhit: return True if a character is available */
+Cell d_kbhit() {
+#ifdef HAVE_CONIO
+ return (kbhit());
+#elifdef HAVE_CURSES
+ return (1);
+#endif
+}
+
+/* d_open: Initialize the Input/Output device */
+void d_open() {
+#ifdef HAVE_CURSES
+ initscr();
+ cbreak();
+ noecho();
+ nonl();
+ /* intrflush(stdscr, FALSE); */
+ /* keypad(stdscr, TRUE); */
+#endif
+}
+
+/* d_close: make some work when program finish to restore Input/Output device */
+void d_close() {
+#ifdef HAVE_CURSES
+ endwin();
+#endif
+}
+
+
+
+
+
+
+
+
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: udio.h
+ * Abstract: User device Input/Output functions.
+ */
+
+void d_open(void);
+void d_close(void);
+void d_clrscr(void);
+void d_clreol(void);
+void d_setattr(Cell attr);
+Cell d_getattr(void);
+void d_gotoxy(Cell x, Cell y);
+Cell d_wherex(void);
+Cell d_wherey(void);
+Char d_getch(void);
+Cell d_kbhit(void);
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: ver.h
+ * Abstract: yForth? version definition
+ */
+
+#define VER_HI 0
+#define VER_LO 1
+#define VER_TEST "beta"
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: vm.c
+ * Abstract: The Virtual Machine on which is based the whole
+ * forth interpreter.
+ */
+
+#include <stdio.h>
+#include <signal.h>
+#include "yforth.h"
+#include "core.h"
+
+/* "ip" is the Instruction Pointer of the Virtual Machine. "ip" points to
+ * an array of "pfp", which stands for "primitive function pointer",
+ * in other words an array of pointers to primitive functions.
+ * Roughly speaking, primitive functions are the valid instructions of
+ * the Virtual Machine.
+ */
+
+pfp *ip; /* Instruction Pointer */
+
+Cell *sp, *sp_top, *sp_base; /* various stack pointers... */
+Cell *rp, *rp_top, *rp_base;
+Real *fp, *fp_top, *fp_base;
+Cell *bp;
+
+#ifdef DCELL_MEM
+static union double_cell dcell; /* Used for double-cell transfer */
+#endif
+
+/* stacks_recovery: called when an exception occurs, it sets all stack
+ * ptrs to their original value.
+ */
+void
+stacks_recovery (void)
+{
+ sp = sp_top;
+ rp = rp_top;
+ fp = fp_top;
+}
+
+/* If double-cell transfer is realized with memory-copying, the following
+ * auxiliary procedures are needed
+ */
+#ifdef DCELL_MEM
+DCell
+get_dcell (Cell * ptr)
+{
+ dcell.d2.high = *ptr;
+ dcell.d2.low = *(ptr + 1);
+ return (dcell.d1);
+}
+
+void
+put_dcell (Cell * ptr, DCell d)
+{
+ dcell.d1 = d;
+ *ptr = dcell.d2.high;
+ *(ptr + 1) = dcell.d2.low;
+}
+#endif
+
+/* sig_fpe_handler: signal handler for math exceptions */
+void
+sig_fpe_handler (int sig)
+{
+ signal (SIGFPE, sig_fpe_handler);
+ _error = E_FPE;
+ _view_error_msg();
+ longjmp(warm_start_jump, 1);
+}
+
+/* sig_segv_handler: signal handler for segmentation violation */
+void
+sig_segv_handler (int sig)
+{
+ signal (SIGSEGV, sig_segv_handler);
+ _error = E_SEGV;
+ _view_error_msg();
+ longjmp(warm_start_jump, 1);
+}
+
+/* init_signal: initialize signal handlers */
+void
+init_signals ()
+{
+ signal (SIGFPE, sig_fpe_handler);
+ signal (SIGSEGV, sig_segv_handler);
+}
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: ycore.c
+ * Abstract: Words defined for this particular implementation of
+ forth. Do not expect to find these words in other
+ implementations.
+ */
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include "ver.h"
+#include "yforth.h"
+#include "core.h"
+#include "file.h"
+#include "search.h"
+
+/**************************************************************************/
+/* WORDS DEFINITION *******************************************************/
+/**************************************************************************/
+
+/* ( --- ) print current version of yForth? */
+void _yforth_version() {
+ print_version();
+}
+
+/* ( c-addr u --- ) save a snapshot of the current dictionary and vocabulary
+ * search order
+ */
+void _save_image() {
+ FILE *f = fopen(get_file_name(), "wb");
+ struct image_header hd;
+ struct voc_marker vm;
+ if (f) {
+ memset(&hd, 0, sizeof(struct image_header));
+ strcpy(hd.header, "yForth? Image File\n");
+ hd.ver_hi = VER_HI;
+ hd.ver_lo = VER_LO;
+ hd.base = dp0;
+ hd.dspace_size = dspace_size;
+ hd.pattern = VERSION_PATTERN;
+ if (fwrite(&hd, sizeof(struct image_header), 1, f) < 1) _error = E_NOFILE;
+ else {
+ save_vocabulary(&vm);
+ if (fwrite(&vm, sizeof(struct voc_marker), 1, f) < 1) _error = E_NOFILE;
+ else {
+ if (fwrite(dp0, sizeof(Cell), dspace_size, f) < dspace_size)
+ _error = E_NOFILE;
+ }
+ }
+ fclose(f);
+ } else _error = E_NOFILE;
+}
+
+/* ( c-addr u --- n ) execute command pointeb by c-addr via "system", n is
+ * the result of operation as described in the C library manual
+ */
+void _system() {
+ register UCell len = *sp++;
+ register Char *name = (Char *) *sp;
+ extern Char s_tmp_buffer[];
+ memcpy(s_tmp_buffer, name, len);
+ s_tmp_buffer[len] = '\0';
+ *sp = system(s_tmp_buffer);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: ycore.h
+ * Abstract: YCore word set (non-standard words specific to yForth?. Don't
+ * expect to find these words in other envionments).
+ */
+
+#ifdef DECLARE_WORDS
+# ifdef PROTOTYPES
+# undef PROTOTYPES
+# endif
+# undef __YCORE_H__
+#else
+# ifndef PROTOTYPES
+# define PROTOTYPES
+# endif
+#endif
+
+#ifndef __YCORE_H__
+#define __YCORE_H__
+
+#include "yforth.h"
+#include "macro.h"
+
+/**************************************************************************/
+/* PROTOTYPES *************************************************************/
+/**************************************************************************/
+
+code(yforth_version, "ver", 0)
+code(save_image, "save-image", 0)
+code(system, "system", 0)
+
+#ifdef PROTOTYPES
+
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: yfinit.c
+ * Abstract: Allocate memory for the main structures of the
+ * environment and initialize the environment itself.
+ */
+
+#include <stdlib.h>
+#include <malloc.h>
+#include <stdio.h>
+#include "yforth.h"
+#include "core.h"
+#include "coree.h"
+#include "search.h"
+
+/* init_stacks: allocate memory for the stacks */
+void init_stacks(int dstack_size, int rstack_size, int fstack_size) {
+ sp_base = (Cell *) malloc(dstack_size * sizeof(Cell));
+ rp_base = (Cell *) malloc(rstack_size * sizeof(Cell));
+ fp_base = (Real *) malloc(fstack_size * sizeof(Real));
+ if (sp_base && rp_base && (fp_base || !fstack_size)) {
+ sp = sp_top = sp_base + dstack_size;
+ rp = rp_top = rp_base + rstack_size;
+ fp = fp_top = fp_base + fstack_size;
+ } else {
+ fprintf(stderr, "Stack sizes: %d %d %d. Not enough memory.\n", dstack_size,
+ rstack_size, fstack_size);
+ exit(-1);
+ }
+}
+
+/* init_data_space: allocate memory for the data-space dictionary */
+void init_data_space(int dspace_size) {
+ dp0 = _dp = (Char *) malloc(dspace_size * sizeof(Cell));
+ if (!_dp) {
+ printf("Data Space size: %d. Not enough memory.\n", dspace_size);
+ exit(-1);
+ }
+}
+
+/* init_tib: allocate memory for the TIB */
+void init_tib(int size) {
+ _tib = (Char *) malloc(size * sizeof(Char));
+ if (!_tib) {
+ fprintf(stderr, "Tib size: %d. Not enough memory.\n", size);
+ exit(-1);
+ }
+}
+
+/* init_pad: allocate memory for the PAD */
+void init_pad(int size) {
+ _pad = (Char *) malloc(size * sizeof(Char));
+ if (!_pad) {
+ fprintf(stderr, "PAD size: %d. Not enough memory.\n", size);
+ exit(-1);
+ }
+}
+
+/* init_pnos: allocate memory for PNOS, note that the size of PNOS is
+ * determined by the actual size of a double cell.
+ */
+void init_pnos() {
+ pnos_size = sizeof(DCell) * 8 + 2; /* plus a space and eventually a '-' */
+ pnos = (Char *) malloc(pnos_size * sizeof(Char));
+ if (!pnos) {
+ fprintf(stderr, "Can't allocate PNOS.\n");
+ exit(-1);
+ }
+}
+
+/* init_forth_environment: perform actual inizialization of the dictionary
+ * only if "reload" is true, then initialize the value of variables
+ * of the forth environment. This variable must be initialized even in
+ * the case of an image file since they're not inside the dictionary,
+ * but are simply C variables.
+ */
+void init_forth_environment(int reload) {
+ if (reload) {
+ struct vocabulary *v;
+ _wordlist();
+ list[0] = forth_wid = voc = (struct vocabulary *) *sp++;
+ _last = NULL;
+ init_vocabulary(&_dp);
+ }
+ _base = 10;
+ _env_slash_counted_string = (1 << (8 * sizeof(Char))) - 1;
+ _env_slash_hold = pnos_size;
+ _env_slash_pad = pad_size;
+ _env_address_unit_bits = 8 * sizeof(Char);
+ _env_core = FFLAG(1);
+ _env_core_ext = FFLAG(COREE_DEF);
+ _env_floored = FFLAG(FLOORED_DIVISION);
+ _env_max_char = _env_slash_counted_string;
+ _env_max_d = MAX_D;
+ _env_max_n = MAX_N;
+ _env_max_u = MAX_U;
+ _env_max_ud = MAX_UD;
+ _env_return_stack_cells = rstack_size;
+ _env_stack_cells = dstack_size;
+ _env_double = FFLAG(DOUBLE_DEF);
+ _env_double_ext = FFLAG(DOUBLEE_DEF);
+ _env_floating = FFLAG(FLOAT_DEF);
+ _env_floating_stack = fstack_size;
+ _env_max_float = MAX_F;
+ _env_floating_ext = FFLAG(FLOATE_DEF);
+ _env_memory_alloc = FFLAG(MEMALL_DEF);
+ _env_memory_alloc_ext = FFLAG(MEMALLE_DEF);
+ _env_search_order = FFLAG(SEARCH_DEF);
+ _env_search_order_ext = FFLAG(SEARCHE_DEF);
+ _env_wordlists = WORD_LISTS;
+ _env_tools = FFLAG(TOOLS_DEF);
+ _env_tools_ext = FFLAG(TOOLSE_DEF);
+ _env_number_locals = MAX_LOCALS;
+ _env_locals = FFLAG(LOCALS_DEF);
+ _env_locals_ext = FFLAG(LOCALSE_DEF);
+ _env_facility = FFLAG(FACILITY_DEF);
+ _env_facility_ext = FFLAG(FACILITYE_DEF);
+ _env_block = FFLAG(BLOCK_DEF);
+ _env_block_ext = FFLAG(BLOCKE_DEF);
+ _env_exception = FFLAG(EXCEPTION_DEF);
+ _env_exception_ext = FFLAG(EXCEPTIONE_DEF);
+ _env_file = FFLAG(FILE_DEF);
+ _env_file_ext = FFLAG(FILEE_DEF);
+ _env_string = FFLAG(STRING_DEF);
+ _env_string_ext = FFLAG(STRINGE_DEF);
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: yforth.c
+ * Abstract: Main program
+ */
+
+#include <setjmp.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "yforth.h"
+#include "defaults.h"
+#include "core.h"
+#include "block.h"
+#include "search.h"
+#include "ver.h"
+#include "file.h"
+
+jmp_buf warm_start_jump, cold_start_jump;
+
+Char *dp0; /* Data-Space base pointer */
+Cell dspace_size = DEF_DSPACE_SIZE; /* Data-Space size */
+Cell dstack_size = DEF_DSTACK_SIZE, /* Data-Stack size */
+ rstack_size = DEF_RSTACK_SIZE, /* Return-stack size */
+ fstack_size = DEF_FSTACK_SIZE; /* Floating-stack size */
+Cell tib_size = DEF_TIB_SIZE; /* TIB size */
+Cell in_pnos, pnos_size; /* Pictured Numeric Output String */
+Char *pnos, *p_pnos; /* Ptrs inside PNOS */
+Cell pad_size = DEF_PAD_SIZE; /* PAD size */
+
+static char *file_name, /* Ptr to file name on command line, if present */
+ *image_file; /* Ptr to image file name on cmd line, if present */
+
+static int silent,
+ image_file_loaded;
+
+static struct image_header hd;
+
+void print_version() {
+ printf("yForth? v%d.%d%s - Written by Luca Padovani (C) 1996.\n\
+This software is Freeware, use it at your own risk.\n",
+ VER_HI, VER_LO, VER_TEST);
+}
+
+void print_help(void) {
+ print_version();
+ printf("Usage: yForth [options] [file name]\n\
+-d<n> Data-Space size -s<n> Data-Stack size\n\
+-r<n> Return-Stack size -f<n> Floating-Stack size\n\
+-t<n> TIB size -p<n> PAD size\n\
+-h,-H This help -q Quiet\n\
+-i<file> Image file\n\
+All sizes are expressed in cells.\n");
+}
+
+/* do_parameters: processes parameters passed on command line */
+void do_parameters(int argc, char *argv[]) {
+ int i = 1;
+ while (argc-- > 1) {
+ if (argv[i][0] == '-')
+ switch (argv[i][1]) {
+ case 'd': dspace_size = atoi(argv[i] + 2); break;
+ case 's': dstack_size = atoi(argv[i] + 2); break;
+ case 'r': rstack_size = atoi(argv[i] + 2); break;
+ case 'f': fstack_size = atoi(argv[i] + 2); break;
+ case 't': tib_size = atoi(argv[i] + 2); break;
+ case 'p': pad_size = atoi(argv[i] + 2); break;
+ case 'q': silent = 1; break;
+ case 'i': image_file = argv[i] + 2; break;
+ case 'h':
+ case 'H':
+ print_help();
+ exit(0);
+ break;
+ default:
+ fprintf(stderr, "%c unknown option, use -h for help.\n");
+ exit(0);
+ break;
+ }
+ else {
+ file_name = argv[i];
+ break;
+ }
+ }
+}
+
+/* default_parameters: adjust environment parameters in case they do not
+ * fall into required range
+ */
+void default_parameters(void) {
+ dspace_size = max(MIN_DSPACE_SIZE, dspace_size);
+ dstack_size = max(MIN_DSTACK_SIZE, dstack_size);
+ rstack_size = max(MIN_RSTACK_SIZE, rstack_size);
+ fstack_size = max(MIN_FSTACK_SIZE, fstack_size);
+ tib_size = max(MIN_TIB_SIZE, tib_size);
+ pad_size = max(MIN_PAD_SIZE, pad_size);
+}
+
+/* load_image_file: loads image file named "name" into the dictionary. Loading
+ * is divided in two parts: when "header" is set to 1 the file is opened and
+ * the header is loaded into the structure "hd". Then some checks are made
+ * to adjust parameters in case of a corrupted image.
+ * Finally, when "load_image_file" is called with "header" set to 0, the
+ * actual loading is performed. Note that pointers inside the dictionary
+ * are absolute, so an image file can be loaded only if the allocated
+ * memory is placed at the same address when it's been saved. Furthermore,
+ * the same image file cannot be loaded thru different version of the
+ * executable file "yForth".
+ */
+int load_image_file(char *name, int header) {
+ FILE *f = fopen(name, "rb");
+ int res = 1;
+ if (f) {
+ if (header) {
+ if (fread(&hd, sizeof(struct image_header), 1, f)) {
+ if (hd.ver_hi != VER_HI || hd.ver_lo != VER_LO)
+ if (!silent)
+ fprintf(stderr, "Warning: different image file version (%d.%d).\n",
+ hd.ver_hi, hd.ver_lo);
+ if (hd.pattern != VERSION_PATTERN)
+ if (!silent)
+ fprintf(stderr, "Warning: different version pattern (Image: %x).\n",
+ hd.pattern);
+ res = 0;
+ } else fprintf(stderr, "Error: can't read image file header.\n");
+ } else {
+ fseek(f, sizeof(struct image_header), SEEK_SET);
+ if (hd.base == dp0) {
+ struct voc_marker vm;
+ if (fread(&vm, sizeof(struct voc_marker), 1, f) < 1 ||
+ fread(dp0, sizeof(Cell), hd.dspace_size, f) != hd.dspace_size)
+ fprintf(stderr, "Error: can't read image file.\n");
+ else {
+ load_vocabulary(&vm);
+ res = 0;
+ }
+ } else fprintf(stderr, "Error: can't load image file with base %u at %u.\n",
+ hd.base, dp0);
+ }
+ fclose(f);
+ } else fprintf(stderr, "Can't open image file (%s).\n", name);
+ return (res);
+}
+
+main(int argc, char *argv[]) {
+ do_parameters(argc, argv);
+ if (image_file) {
+ if (load_image_file(image_file, 1)) exit(-1);
+ } else fopen(argv[0], "rb");
+ /* !!! WARNING !!! Previous line opens a file even if no image-file
+ * is specified. This is because in some system data space would
+ * result unaligned in subsequent loadings. I have to find a more
+ * smart trick here...
+ */
+
+ default_parameters();
+#if BLOCK_DEF
+ open_block_file("YFORTH.BLK");
+#endif
+ init_stacks(dstack_size, rstack_size, fstack_size);
+ if (image_file && dspace_size < hd.dspace_size) {
+ if (!silent)
+ fprintf(stderr, "Warning: can't restrict dictionary to %u cells, now is %u cells.\n",
+ dspace_size, hd.dspace_size);
+ dspace_size = max(dspace_size, hd.dspace_size);
+ }
+ init_data_space(dspace_size);
+ init_tib(tib_size);
+ init_pad(pad_size);
+ init_pnos();
+ init_signals();
+
+ silent |= setjmp(cold_start_jump);
+ if (image_file)
+ if (load_image_file(image_file, 0)) exit(-1);
+
+ /* Note that after a cold start the vocabulary is reloaded */
+
+ if (!silent) {
+ print_version();
+ /*
+ printf("Cell: %d Double-Cell: %d Char: %d Real: %d\n",
+ sizeof(Cell), sizeof(DCell), sizeof(Char), sizeof(Real));
+ */
+ }
+ init_forth_environment(!image_file);
+ if (!setjmp(warm_start_jump) && file_name) load_file(file_name);
+ _quit();
+ return 0;
+}
+
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: yforth.h
+ * Abstract: definition of constants, data types, prototypes, and so on.
+ */
+
+#ifndef __YFORTH__
+#define __YFORTH__
+
+#include <setjmp.h>
+#include <limits.h>
+#include "errors.h"
+
+#include "config.h"
+
+/* Following definitions may be tuned for a particular system. Note however
+ * that their minimal value is defined by the standard.
+ */
+
+#define TMP_BUFFER_SIZE 80
+#define FILE_BUFFER_SIZE 128
+#define FILE_NAME_SIZE 128
+
+#define MAX_LOCALS 8
+
+#define VOC_HASH 8
+#define WORD_LISTS 8
+
+/* data structures definitions */
+
+typedef void (*pfp)(void);
+
+struct word_def {
+ Char *name;
+ struct word_def *link;
+ Cell class;
+ pfp func[1];
+};
+
+struct vocabulary {
+ struct word_def *voc[VOC_HASH];
+};
+
+struct voc_marker { /* MARKER structure */
+ struct vocabulary *list[WORD_LISTS]; /* vocabulary stack */
+ Cell top; /* top of stack */
+ struct vocabulary *voc; /* definition vocabulary */
+ struct vocabulary v_list[WORD_LISTS]; /* content of vocabularies in stack */
+ struct vocabulary v_voc;
+ Char *_dp; /* dictionary pointer */
+ struct word_def *last; /* ptr to last defined word */
+};
+
+struct raw_voc {
+ char *name;
+ void (*func) (void);
+ int class;
+};
+
+struct image_header { /* header for image file */
+ Char header[24];
+ Cell ver_hi, ver_lo;
+ UCell pattern;
+ Char *base;
+ Cell dspace_size;
+};
+
+#ifdef DCELL_MEM
+union double_cell {
+ DCell d1;
+ struct {
+#ifdef LITTLE_ENDIAN
+ Cell low;
+ Cell high;
+#else
+ Cell high;
+ Cell low;
+#endif
+ } d2;
+};
+DCell get_dcell(Cell *ptr);
+void put_dcell(Cell *ptr, DCell d);
+#endif
+
+/* Some constant definitions. This should not be changed. */
+
+#define INTERPRET 0
+#define COMPILE -1
+
+#define BLOCK_SIZE 1024
+#define NUM_BLOCKS 4
+
+#define COMP_ONLY 0x0100
+#define IMMEDIATE 0x0200
+#define CLASS_MASK (~(COMP_ONLY | IMMEDIATE))
+
+#define A_PRIMITIVE 0
+#define A_USER 1
+#define A_VARIABLE 2
+#define A_COLON 3
+#define A_CONSTANT 4
+#define A_FCONSTANT 5
+#define A_FVARIABLE 6
+#define A_CREATE 7
+#define A_MARKER 8
+#define A_2CONSTANT 9
+#define A_2VARIABLE 10
+#define A_LOCAL 11
+#define A_VALUE 12
+#define A_WORD 15
+
+/* Some macros */
+
+#define ALIGN_PTR(n) (((((Cell) (n)) - 1) | CellLog) + 1)
+#define FALIGN_PTR(n) (((((Cell) (n)) - 1) | RealLog) + 1)
+#define WORD_PTR(ptr) (ALIGN_PTR((ptr) + *(ptr) + sizeof(Char)))
+#define compile_cell(x) *((Cell *) _dp) = x, _dp += sizeof(Cell)
+#define compile_real(x) *((Real *) _dp) = x, _dp += sizeof(Real)
+#define hash_func(name,len) ((len) & (VOC_HASH - 1))
+#ifdef DCELL_MEM
+# ifdef LITTLE_ENDIAN
+# define GET_DCELL(ptr) get_dcell((Cell *) ptr)
+# define PUT_DCELL(ptr, d) put_dcell((Cell *) ptr, (DCell) d)
+# else
+# define GET_DCELL(ptr) *((DCell *) ptr)
+# define PUT_DCELL(ptr, d) *((DCell *) ptr) = d
+# endif
+#else
+# ifdef LITTLE_ENDIAN
+# define GET_DCELL(ptr) ((DCell) (*(((Cell *) ptr) + 1)) + \
+ (((DCell) (*((Cell *) ptr))) << CellBits))
+# define PUT_DCELL(ptr, d) *(((Cell *) ptr) + 1) = (Cell) d, \
+ *((Cell *) ptr) = (Cell) (d >> CellBits)
+# else
+# define GET_DCELL(ptr) ((DCell) (*((Cell *) ptr)) + \
+ (((DCell) (*(((Cell *) ptr) + 1))) << CellBits))
+# define PUT_DCELL(ptr, d) *((Cell *) ptr) = (Cell) d, \
+ *(((Cell *) ptr) + 1) = (Cell) (d >> CellBits)
+# endif
+#endif
+
+#define GET_UDCELL(ptr) ((UDCell) GET_DCELL(ptr))
+#define PUT_UDCELL(ptr, ud) PUT_DCELL(ptr, ud)
+
+/* Global variables */
+
+extern jmp_buf warm_start_jump;
+extern Char * dp0;
+extern Cell dspace_size;
+extern Cell dstack_size, rstack_size, fstack_size;
+extern Cell tib_size;
+extern Cell in_pnos, pnos_size;
+extern Char * pnos, * p_pnos;
+extern Cell pad_size;
+
+extern struct vocabulary *list[WORD_LISTS];
+extern Cell top; /* indice primo vocabolario sulla pila */
+extern struct vocabulary *voc; /* ptr al vocabolario usato per le definzioni */
+extern struct vocabulary *forth_wid;
+
+/* Global functions prototypes */
+
+void init_vocabulary(Char **dp);
+void init_stacks(int dstack_size, int rstack_size, int fstack_size);
+void init_data_space(int dspace_size);
+void init_tib(int size);
+void init_pad(int size);
+void init_pnos(void);
+void init_forth_environment(int reload);
+void init_signals(void);
+void print_version(void);
+
+/* Virtual Machine registers definition */
+
+extern pfp *ip;
+
+extern Cell *sp, *sp_top, *sp_base;
+extern Cell *rp, *rp_top, *rp_base;
+extern Real *fp, *fp_top, *fp_base;
+extern Cell *bp;
+
+/* Some definitions that may be missing under certain systems or compilers */
+
+#ifndef SEEK_SET
+# define SEEK_SET 0
+#endif
+#ifndef SEEK_CUR
+# define SEEK_CUR 1
+#endif
+#ifndef SEEK_END
+# define SEEK_END 2
+#endif
+
+#include "div.h"
+
+#ifndef max
+# define max(a, b) ((a) > (b) ? (a) : (b))
+#endif
+
+#endif
--- /dev/null
+/* yForth? - Written by Luca Padovani (C) 1996/97
+ * ------------------------------------------------------------------------
+ * This software is FreeWare as long as it comes with this header in each
+ * source file, anyway you can use it or any part of it whatever
+ * you want. It comes without any warranty, so use it at your own risk.
+ * ------------------------------------------------------------------------
+ * Module name: yfvinit.c
+ * Abstract: Initialize the vocabulary.
+ */
+
+#include <string.h>
+#include "yforth.h"
+#include "core.h"
+#include "ycore.h"
+#if COREE_DEF
+# include "coree.h"
+#endif
+#if DOUBLE_DEF
+# include "double.h"
+#endif
+#if DOUBLEE_DEF
+# include "doublee.h"
+#endif
+#if FLOAT_DEF
+# if !COREE_DEF
+# include "coree.h"
+# endif
+# include "float.h"
+#endif
+#if FLOATE_DEF
+# include "floate.h"
+#endif
+#if MEMALL_DEF
+# include "memall.h"
+#endif
+#if SEARCH_DEF
+# include "search.h"
+#endif
+#if SEARCHE_DEF
+# include "searche.h"
+#endif
+#if TOOLS_DEF
+# include "tools.h"
+#endif
+#if TOOLSE_DEF
+# if !COREE_DEF
+# include "coree.h"
+# endif
+# include "toolse.h"
+#endif
+#if LOCALS_DEF
+# include "locals.h"
+#endif
+#if LOCALSE_DEF
+# include "localse.h"
+#endif
+#if FACILITY_DEF
+# include "facility.h"
+#endif
+#if FACILITYE_DEF
+# include "facilite.h"
+#endif
+#if STRING_DEF
+# include "string.h"
+#endif
+#if FILE_DEF
+# include "file.h"
+#endif
+#if FILEE_DEF
+# include "filee.h"
+#endif
+#if BLOCK_DEF
+# include "block.h"
+#endif
+#if BLOCKE_DEF
+# include "blocke.h"
+#endif
+#if EXCEPTION_DEF
+# include "exceptio.h"
+#endif
+#if EXCEPTIONE_DEF
+# include "excepte.h"
+#endif
+
+static struct raw_voc iv[] = {
+#define DECLARE_WORDS
+
+#include "core.h"
+#include "ycore.h"
+#if COREE_DEF
+# include "coree.h"
+#endif
+#if DOUBLE_DEF
+# include "double.h"
+#endif
+#if DOUBLEE_DEF
+# include "doublee.h"
+#endif
+#if FLOAT_DEF
+# include "float.h"
+#endif
+#if FLOATE_DEF
+# include "floate.h"
+#endif
+#if MEMALL_DEF
+# include "memall.h"
+#endif
+#if SEARCH_DEF
+# include "search.h"
+#endif
+#if SEARCHE_DEF
+# include "searche.h"
+#endif
+#if TOOLS_DEF
+# include "tools.h"
+#endif
+#if TOOLSE_DEF
+# include "toolse.h"
+#endif
+#if LOCALS_DEF
+# include "locals.h"
+#endif
+#if LOCALSE_DEF
+# include "localse.h"
+#endif
+#if FACILITY_DEF
+# include "facility.h"
+#endif
+#if FACILITYE_DEF
+# include "facilite.h"
+#endif
+#ifdef STRING_DEF
+# include "string.h"
+#endif
+#if FILE_DEF
+# include "file.h"
+#endif
+#if FILEE_DEF
+# include "filee.h"
+#endif
+#if BLOCK_DEF
+# include "block.h"
+#endif
+#if BLOCKE_DEF
+# include "blocke.h"
+#endif
+#if EXCEPTION_DEF
+# include "exceptio.h"
+#endif
+#if EXCEPTIONE_DEF
+# include "excepte.h"
+#endif
+
+ { 0, 0, 0 },
+};
+
+#undef DECLARE_WORDS
+
+/* init_vocabulary: loads words into the real dictionary from the table
+ * builded by including all the header files after the declaration of
+ * DECLARE_WORDS. See the header files such as "core.h" and the macro
+ * file "macro.h" for the implementation of this.
+ * This function returns the dictionary pointer after loading.
+ */
+void init_vocabulary(Char **dp) {
+ struct word_def *w;
+ Char *name;
+ int i = 0;
+ while (iv[i].name) { /* Last name is a NULL (see table above) */
+ name = *dp; /* "name" is a ptr to the name */
+ **dp = strlen(iv[i].name); /* first copy length... */
+ strcpy(*dp + 1, iv[i].name); /* ...and then the actual name */
+ *dp = (Char *) WORD_PTR(*dp); /* advance "dp" */
+ w = (struct word_def *) *dp; /* here begins the structure */
+ w->name = name; /* adjust pointer... */
+ w->class = iv[i].class; /* ...and the class of the word */
+ ins_word(w); /* Finally adjust the link field... */
+ mark_word(w); /* ...accordingly with the hash function
+ and make the word visible */
+ *dp += sizeof(struct word_def); /* advance "dp" */
+ switch (iv[i].class & A_WORD) { /* The last field must be adjusted here */
+ case A_PRIMITIVE:
+ w->func[0] = iv[i].func;
+ break;
+ case A_USER:
+ w->func[0] = (pfp) iv[i].func;
+ break;
+ }
+ i++;
+ }
+}
+
projects / debian / yforth / commitdiff
