From: Bdale Garbee Date: Thu, 5 Jun 2008 23:41:06 +0000 (-0600) Subject: Imported Upstream version 0.1beta X-Git-Tag: upstream/0.1beta^0 X-Git-Url: https://git.gag.com/?p=debian%2Fyforth;a=commitdiff_plain;h=ef65b7aa8aa9801818dfe1de1f4a434719cc62e1 Imported Upstream version 0.1beta --- ef65b7aa8aa9801818dfe1de1f4a434719cc62e1 diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..f5d2108 --- /dev/null +++ b/Makefile @@ -0,0 +1,30 @@ +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 diff --git a/README b/README new file mode 100644 index 0000000..95d5713 --- /dev/null +++ b/README @@ -0,0 +1,130 @@ +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? diff --git a/block.c b/block.c new file mode 100644 index 0000000..1d98967 --- /dev/null +++ b/block.c @@ -0,0 +1,135 @@ +/* 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 +#include +#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); + } +} diff --git a/block.h b/block.h new file mode 100644 index 0000000..fbf507b --- /dev/null +++ b/block.h @@ -0,0 +1,81 @@ +/* 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 + diff --git a/blocke.c b/blocke.c new file mode 100644 index 0000000..71c9cbc --- /dev/null +++ b/blocke.c @@ -0,0 +1,62 @@ +/* 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 +#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(); + } +} + + diff --git a/blocke.h b/blocke.h new file mode 100644 index 0000000..8751091 --- /dev/null +++ b/blocke.h @@ -0,0 +1,51 @@ +/* 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 + + + + + diff --git a/config.h b/config.h new file mode 100644 index 0000000..9bae024 --- /dev/null +++ b/config.h @@ -0,0 +1,109 @@ +/* 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 diff --git a/core.c b/core.c new file mode 100644 index 0000000..38a9d8a --- /dev/null +++ b/core.c @@ -0,0 +1,1426 @@ +/* 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 +#include +#include +#include +#include +#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; +} diff --git a/core.h b/core.h new file mode 100644 index 0000000..86994de --- /dev/null +++ b/core.h @@ -0,0 +1,258 @@ +/* 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 diff --git a/coree.c b/coree.c new file mode 100644 index 0000000..8acd708 --- /dev/null +++ b/coree.c @@ -0,0 +1,341 @@ +/* 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 +#include +#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); +} + diff --git a/coree.h b/coree.h new file mode 100644 index 0000000..c43a185 --- /dev/null +++ b/coree.h @@ -0,0 +1,89 @@ +/* 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 + diff --git a/defaults.h b/defaults.h new file mode 100644 index 0000000..917ca3f --- /dev/null +++ b/defaults.h @@ -0,0 +1,15 @@ + +#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 + diff --git a/division.c b/division.c new file mode 100644 index 0000000..2a40498 --- /dev/null +++ b/division.c @@ -0,0 +1,2 @@ +#include +main() { printf("#define FLOORED_DIVISION %d\n", (-10 % 7) > 0 ? 1 : 0); } diff --git a/double.c b/double.c new file mode 100644 index 0000000..631417d --- /dev/null +++ b/double.c @@ -0,0 +1,174 @@ +/* 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 +#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(); +} + + diff --git a/double.h b/double.h new file mode 100644 index 0000000..57e663b --- /dev/null +++ b/double.h @@ -0,0 +1,58 @@ +/* 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 + diff --git a/doublee.c b/doublee.c new file mode 100644 index 0000000..a6de708 --- /dev/null +++ b/doublee.c @@ -0,0 +1,33 @@ +/* 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); +} + diff --git a/doublee.h b/doublee.h new file mode 100644 index 0000000..81845c6 --- /dev/null +++ b/doublee.h @@ -0,0 +1,40 @@ +/* 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 + diff --git a/errors.h b/errors.h new file mode 100644 index 0000000..4df4e47 --- /dev/null +++ b/errors.h @@ -0,0 +1,29 @@ +/* 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") */ diff --git a/exceptio.c b/exceptio.c new file mode 100644 index 0000000..5acaa57 --- /dev/null +++ b/exceptio.c @@ -0,0 +1,64 @@ +/* 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 +#include +#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); + } +} + diff --git a/exceptio.h b/exceptio.h new file mode 100644 index 0000000..219dcd5 --- /dev/null +++ b/exceptio.h @@ -0,0 +1,49 @@ +/* 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 + diff --git a/facility.c b/facility.c new file mode 100644 index 0000000..dd8aed9 --- /dev/null +++ b/facility.c @@ -0,0 +1,31 @@ +/* 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(); +} + diff --git a/facility.h b/facility.h new file mode 100644 index 0000000..d121150 --- /dev/null +++ b/facility.h @@ -0,0 +1,41 @@ +/* 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 + diff --git a/file.c b/file.c new file mode 100644 index 0000000..ec01a2d --- /dev/null +++ b/file.c @@ -0,0 +1,237 @@ +/* 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 +#include +#include +#include +#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(); +} diff --git a/file.h b/file.h new file mode 100644 index 0000000..3f05c47 --- /dev/null +++ b/file.h @@ -0,0 +1,70 @@ +/* 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 +#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 diff --git a/filee.c b/filee.c new file mode 100644 index 0000000..60e151d --- /dev/null +++ b/filee.c @@ -0,0 +1,59 @@ +/* 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 +#include +#include +#include +#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; +} + + diff --git a/filee.h b/filee.h new file mode 100644 index 0000000..f3523a8 --- /dev/null +++ b/filee.h @@ -0,0 +1,41 @@ +/* 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 diff --git a/float.c b/float.c new file mode 100644 index 0000000..cb93112 --- /dev/null +++ b/float.c @@ -0,0 +1,203 @@ +/* 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 +#include +#include +#include +#include +#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); +} + diff --git a/float.h b/float.h new file mode 100644 index 0000000..c192ece --- /dev/null +++ b/float.h @@ -0,0 +1,69 @@ +/* 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 + diff --git a/floate.c b/floate.c new file mode 100644 index 0000000..2e110c1 --- /dev/null +++ b/floate.c @@ -0,0 +1,210 @@ +/* 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 +#include +#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); +} + diff --git a/floate.h b/floate.h new file mode 100644 index 0000000..1352314 --- /dev/null +++ b/floate.h @@ -0,0 +1,79 @@ +/* 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 + diff --git a/locals.c b/locals.c new file mode 100644 index 0000000..94d9e56 --- /dev/null +++ b/locals.c @@ -0,0 +1,143 @@ +/* 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 +#include +#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); +} + diff --git a/locals.h b/locals.h new file mode 100644 index 0000000..d007b14 --- /dev/null +++ b/locals.h @@ -0,0 +1,55 @@ +/* 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 + diff --git a/localse.c b/localse.c new file mode 100644 index 0000000..7e3b821 --- /dev/null +++ b/localse.c @@ -0,0 +1,31 @@ +/* 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; + } +} + diff --git a/localse.h b/localse.h new file mode 100644 index 0000000..f55ea78 --- /dev/null +++ b/localse.h @@ -0,0 +1,39 @@ +/* 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 + diff --git a/macro.h b/macro.h new file mode 100644 index 0000000..785b40c --- /dev/null +++ b/macro.h @@ -0,0 +1,15 @@ + +#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 + diff --git a/memall.c b/memall.c new file mode 100644 index 0000000..2ede4fc --- /dev/null +++ b/memall.c @@ -0,0 +1,40 @@ +/* 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 +#include +#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); +} + + diff --git a/memall.h b/memall.h new file mode 100644 index 0000000..bd4bb92 --- /dev/null +++ b/memall.h @@ -0,0 +1,42 @@ +/* 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 + diff --git a/search.c b/search.c new file mode 100644 index 0000000..04d17ee --- /dev/null +++ b/search.c @@ -0,0 +1,105 @@ +/* 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 +#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; +} diff --git a/search.h b/search.h new file mode 100644 index 0000000..3c8ff4d --- /dev/null +++ b/search.h @@ -0,0 +1,53 @@ +/* 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 diff --git a/searche.c b/searche.c new file mode 100644 index 0000000..7bb57ed --- /dev/null +++ b/searche.c @@ -0,0 +1,45 @@ +/* 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 +#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--; +} + + diff --git a/searche.h b/searche.h new file mode 100644 index 0000000..9f186a8 --- /dev/null +++ b/searche.h @@ -0,0 +1,43 @@ +/* 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 diff --git a/string.c b/string.c new file mode 100644 index 0000000..6979a40 --- /dev/null +++ b/string.c @@ -0,0 +1,105 @@ +/* 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 +#include +#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); +} + diff --git a/string.h b/string.h new file mode 100644 index 0000000..7d600b1 --- /dev/null +++ b/string.h @@ -0,0 +1,45 @@ +/* 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 diff --git a/tools.c b/tools.c new file mode 100644 index 0000000..2a5d110 --- /dev/null +++ b/tools.c @@ -0,0 +1,76 @@ +/* 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 +#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; + } + } +} + diff --git a/tools.h b/tools.h new file mode 100644 index 0000000..f6f5048 --- /dev/null +++ b/tools.h @@ -0,0 +1,42 @@ +/* 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 diff --git a/toolse.c b/toolse.c new file mode 100644 index 0000000..2ea7098 --- /dev/null +++ b/toolse.c @@ -0,0 +1,76 @@ +/* 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 +#include +#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() { +} + diff --git a/toolse.h b/toolse.h new file mode 100644 index 0000000..4c2b060 --- /dev/null +++ b/toolse.h @@ -0,0 +1,44 @@ +/* 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 diff --git a/udio.c b/udio.c new file mode 100644 index 0000000..d3873a2 --- /dev/null +++ b/udio.c @@ -0,0 +1,134 @@ +/* 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 +#elifdef HAVE_CURSES +# include +#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 +} + + + + + + + + + diff --git a/udio.h b/udio.h new file mode 100644 index 0000000..6f150bb --- /dev/null +++ b/udio.h @@ -0,0 +1,21 @@ +/* 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); diff --git a/ver.h b/ver.h new file mode 100644 index 0000000..14fa71b --- /dev/null +++ b/ver.h @@ -0,0 +1,14 @@ +/* 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" + diff --git a/vm.c b/vm.c new file mode 100644 index 0000000..97ec591 --- /dev/null +++ b/vm.c @@ -0,0 +1,93 @@ +/* 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 +#include +#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); +} diff --git a/ycore.c b/ycore.c new file mode 100644 index 0000000..4e37d5e --- /dev/null +++ b/ycore.c @@ -0,0 +1,70 @@ +/* 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 +#include +#include +#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); +} + diff --git a/ycore.h b/ycore.h new file mode 100644 index 0000000..340b122 --- /dev/null +++ b/ycore.h @@ -0,0 +1,41 @@ +/* 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 diff --git a/yfinit.c b/yfinit.c new file mode 100644 index 0000000..b652801 --- /dev/null +++ b/yfinit.c @@ -0,0 +1,131 @@ +/* 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 +#include +#include +#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); +} + diff --git a/yforth.c b/yforth.c new file mode 100644 index 0000000..7ea1513 --- /dev/null +++ b/yforth.c @@ -0,0 +1,194 @@ +/* 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 +#include +#include +#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 Data-Space size -s Data-Stack size\n\ +-r Return-Stack size -f Floating-Stack size\n\ +-t TIB size -p PAD size\n\ +-h,-H This help -q Quiet\n\ +-i 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; +} + diff --git a/yforth.h b/yforth.h new file mode 100644 index 0000000..abdef54 --- /dev/null +++ b/yforth.h @@ -0,0 +1,204 @@ +/* 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 +#include +#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 diff --git a/yforthlogo.gif b/yforthlogo.gif new file mode 100644 index 0000000..0cc814a Binary files /dev/null and b/yforthlogo.gif differ diff --git a/yfvinit.c b/yfvinit.c new file mode 100644 index 0000000..67dc8ad --- /dev/null +++ b/yfvinit.c @@ -0,0 +1,192 @@ +/* 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 +#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++; + } +} +