From ef65b7aa8aa9801818dfe1de1f4a434719cc62e1 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Thu, 5 Jun 2008 17:41:06 -0600 Subject: [PATCH 1/1] Imported Upstream version 0.1beta --- Makefile | 30 + README | 130 +++++ block.c | 135 +++++ block.h | 81 +++ blocke.c | 62 +++ blocke.h | 51 ++ config.h | 109 ++++ core.c | 1426 ++++++++++++++++++++++++++++++++++++++++++++++++ core.h | 258 +++++++++ coree.c | 341 ++++++++++++ coree.h | 89 +++ defaults.h | 15 + division.c | 2 + double.c | 174 ++++++ double.h | 58 ++ doublee.c | 33 ++ doublee.h | 40 ++ errors.h | 29 + exceptio.c | 64 +++ exceptio.h | 49 ++ facility.c | 31 ++ facility.h | 41 ++ file.c | 237 ++++++++ file.h | 70 +++ filee.c | 59 ++ filee.h | 41 ++ float.c | 203 +++++++ float.h | 69 +++ floate.c | 210 +++++++ floate.h | 79 +++ locals.c | 143 +++++ locals.h | 55 ++ localse.c | 31 ++ localse.h | 39 ++ macro.h | 15 + memall.c | 40 ++ memall.h | 42 ++ search.c | 105 ++++ search.h | 53 ++ searche.c | 45 ++ searche.h | 43 ++ string.c | 105 ++++ string.h | 45 ++ tools.c | 76 +++ tools.h | 42 ++ toolse.c | 76 +++ toolse.h | 44 ++ udio.c | 134 +++++ udio.h | 21 + ver.h | 14 + vm.c | 93 ++++ ycore.c | 70 +++ ycore.h | 41 ++ yfinit.c | 131 +++++ yforth.c | 194 +++++++ yforth.h | 204 +++++++ yforthlogo.gif | Bin 0 -> 2398 bytes yfvinit.c | 192 +++++++ 58 files changed, 6309 insertions(+) create mode 100644 Makefile create mode 100644 README create mode 100644 block.c create mode 100644 block.h create mode 100644 blocke.c create mode 100644 blocke.h create mode 100644 config.h create mode 100644 core.c create mode 100644 core.h create mode 100644 coree.c create mode 100644 coree.h create mode 100644 defaults.h create mode 100644 division.c create mode 100644 double.c create mode 100644 double.h create mode 100644 doublee.c create mode 100644 doublee.h create mode 100644 errors.h create mode 100644 exceptio.c create mode 100644 exceptio.h create mode 100644 facility.c create mode 100644 facility.h create mode 100644 file.c create mode 100644 file.h create mode 100644 filee.c create mode 100644 filee.h create mode 100644 float.c create mode 100644 float.h create mode 100644 floate.c create mode 100644 floate.h create mode 100644 locals.c create mode 100644 locals.h create mode 100644 localse.c create mode 100644 localse.h create mode 100644 macro.h create mode 100644 memall.c create mode 100644 memall.h create mode 100644 search.c create mode 100644 search.h create mode 100644 searche.c create mode 100644 searche.h create mode 100644 string.c create mode 100644 string.h create mode 100644 tools.c create mode 100644 tools.h create mode 100644 toolse.c create mode 100644 toolse.h create mode 100644 udio.c create mode 100644 udio.h create mode 100644 ver.h create mode 100644 vm.c create mode 100644 ycore.c create mode 100644 ycore.h create mode 100644 yfinit.c create mode 100644 yforth.c create mode 100644 yforth.h create mode 100644 yforthlogo.gif create mode 100644 yfvinit.c 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 0000000000000000000000000000000000000000..0cc814a3be36be0435675ea7cb604f853047b814 GIT binary patch literal 2398 zcmdUt30qQ$0zfa99WF+wh`3#p6ipM&eGAAEwHh<+({i~kx#v<@RL+FpzJ--aN{ME? z@>!wjjAi9TeU929I@YtsX|UC5@}qf8)AoGt&Cht}7o6`qCoFukpKl5RYydt00FTF8 zyLPR+ySt~Sr;m@1zrTNQaIioi2n`Jl3k!>kjNG>;}a4R5)%^< z1W8LvOHWVF%*@Qm$;r*l&Cky-Dk|EyZ(nh7u|y&{eE4ulNy)Ke$D~rJTrRJusHm*0 ztf{G~udi=tXlQI~Jay_+Q&W>tscdU&Q>j$#?d|8zozrME-QC@nE?w&F?d|XH9~c-I z92^`P8X6uR9vK-KA0MBboSd4Px_kGoUay~-nVFlLo1dQt{-1IEOa8AG0C7bM%j9L{ z6_r)hHMMp14aXIYCr+MfYHm@UZf#SYIoq!8=seeTUh}sL7nL?FQ^u7m=4{)R9*e8+ z_k-0vmwSiKvS>sCahwP-VNUZ1WPbae{!XQhDTPFyr!cJ4rbH}>uC;P>acnk_Eu9_T zynR*ifC!Qp7OQAe+&LA4Ku^zF?A%n#@=op2;uM%_mJ2&1ridg5F~p$3LZNJ96@w?1 zoG1iDwRS=I3uqB`oGiS_o#^zQcu?NP_KCCBqh*mKBDeoS$`j^Rp($iGfsFoGZ?Q(K ziYpySc1R5CJ#oq)3!};1;#4f%Yaxgwm<0`LOErA_N@077gb$!Hle9Ikr0}vxM##(d ziCM&k)tXwnN|1M=v*&0Gd)_%m8qTl7cb8e8MlC2EHswVjweJB8Zdz0ZNDz?3bPI5e zGYH4Z2&R0*NazIRG*1Z%=Q2lY*=BZoB?fea)Y!aA8(F#tBwN7W9iBg|2Fd0wA_P8T z^A^Wgm)>uLb>6j2j%;3B$w*l>-AaqjFS6esi*fo2QQW-?Z8mib6aXVEq^hLLSeSNN4eYs8Ksr(F;TPO z&X*2g$y6`3tfg(22F1HC0HUZ1ITqBF(zLXhp3;`L0&ms-ASeY z5UG^$N8K`h8V@A>;ARLc7?3Au0i4TkQSdbd>xhnI8-xfU`RhP2p0Y(Psw!J4-0eR6 zB_p@s;3JbxA)Yg#wbxyb)=%L$a|riGD{3ka&ykXMUt93=n7pP%& z%_l#jbhFQ?*IL*%0qKJ;iTMx+&jWj=Lvrih%|2ah0w>Euj9aLF^9b_bcS@gb>!)xv z;6W0!VO4QY-xz02LkqQOO%g#V*6NONbn526nevo!iNcOVN`_5IGY?RZP~otys=&(n zG5Df2IqBLBa{>0TOGdUpUf8z$&tH#KDbRVU8;WdfZ0%nD^&vdJ(!QMeuVoLS^Pu$T znyqXjce($)-+KMaeC8HYuYrM$V>j_T8c^ zYYIX>KRY|^)bab!F!VLbS1%xNQ=@etQzA5pI8PCyqc%!oBF0V!6NTcPO%unzX|8N) zts`2P_p7(NE>TYdX|@(Y5$_r*t1q81r0UX8c*p) zm@)3LIke97ngu(pP)6pW0d`0-MTBDLiV2rJThdN~YJgEfK7LXU7|RY_Is5QZ{=BC! z(>8s;>W&)E6$!;q#}zV+0*s~YX*ny4H&;swG6Q$Be-P0XtLD{fQv7FQx}!-Y9$D5L z2?k2iDl(RiAJYqW^HztuV|lglk6Y1HpLmbG-p-iX)l_O6ASQ&MK)*1I<9l$TIUdTr zcOfVub^x8iD_?Wt=sv!6CoIzQClAe8IN*D)-Z@&QiH znHRW9MODnLq3qjd-uG>z@O-Ye{^A-k#vcbjw26HH*%j~VT ztPwFEwfUogRSY|YqNax_T_5u>-s8k03x#-1i+{3Pv}-G zs|(8CY_LK(UL$iD#vU~$(-|O?Tra)8u*Y@3hZG?3<8Cxe#7D$SNjURu^e&j-qB9|< z8$k$HD6RilK;hoM6Z#u}hXcRUCftCbWdT@z8wT=|&aU-z=t<>w$JDd}uYYCuxTGpw9uf$It z3DP@QElG+J7Lz<>KJf(q z^|`bb8N)LF$ReUyRWt#vZn)q{{ +#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++; + } +} + -- 2.30.2