yforth-0.2.1/ 000755 000765 000024 00000000000 12035451737 013123 5 ustar 00luca staff 000000 000000 yforth-0.2.1/block.c 000644 000765 000024 00000010626 12035451727 014365 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
}
yforth-0.2.1/block.h 000644 000765 000024 00000005276 12035451727 014377 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/blocke.c 000644 000765 000024 00000003743 12035451727 014534 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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();
}
}
yforth-0.2.1/blocke.h 000644 000765 000024 00000003351 12035451727 014534 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/config.h 000644 000765 000024 00000011536 12035451727 014546 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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.
*/
#include
#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
# if __BYTE_ORDER == __LITTLE_ENDIAN
# define LITTLE_ENDIAN
# else
# undef LITTLE_ENDIAN
# endif
#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".
*/
/* this might work for other 64 bit architectures, too? */
#if defined(__alpha__)
# define Cell long
#else
# define Cell int
#endif /* __alpha__ */
#define Char char
#define Real float
#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, turn 1s into 0s
*/
#define HAVE_ACOSH 1
#define HAVE_ASINH 1
#define HAVE_ATANH 1
/* Set following define to 1 if you're compiling under Turbo C, Borland C,
* or GCC for DOS.
*/
#define HAVE_CONIO 0
yforth-0.2.1/core.c 000644 000765 000024 00000072445 12035451727 014232 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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;
}
yforth-0.2.1/core.h 000644 000765 000024 00000033477 12035451727 014241 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/coree.c 000644 000765 000024 00000016341 12035451727 014370 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/coree.h 000644 000765 000024 00000010437 12035451727 014375 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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(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
yforth-0.2.1/defaults.h 000644 000765 000024 00000000515 12035451727 015103 0 ustar 00luca staff 000000 000000
#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
yforth-0.2.1/division.c 000644 000765 000024 00000001673 12035451727 015121 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
*/
#include
#include
#include
main() {
FILE *f = fopen("div.h", "wt");
assert(f != NULL);
fprintf(f, "#define FLOORED_DIVISION %d\n", (-10 % 7) > 0 ? 1 : 0);
fclose(f);
return 0;
}
yforth-0.2.1/double.c 000644 000765 000024 00000007372 12035451727 014551 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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();
}
yforth-0.2.1/double.h 000644 000765 000024 00000004141 12035451727 014545 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/doublee.c 000644 000765 000024 00000002750 12035451727 014711 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/doublee.h 000644 000765 000024 00000002726 12035451727 014721 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/errors.h 000644 000765 000024 00000003750 12035451727 014614 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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") */
yforth-0.2.1/exceptio.c 000644 000765 000024 00000004540 12035451727 015111 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
}
yforth-0.2.1/exceptio.h 000644 000765 000024 00000003125 12035451727 015114 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/facility.c 000644 000765 000024 00000002462 12035451727 015076 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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();
}
yforth-0.2.1/facility.h 000644 000765 000024 00000002755 12035451727 015110 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/file.c 000644 000765 000024 00000013574 12035451727 014217 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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 (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();
}
yforth-0.2.1/file.h 000644 000765 000024 00000005006 12035451727 014213 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/filee.c 000644 000765 000024 00000004045 12035451727 014355 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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;
}
yforth-0.2.1/filee.h 000644 000765 000024 00000002764 12035451727 014370 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/float.c 000644 000765 000024 00000007320 12035451727 014375 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/float.h 000644 000765 000024 00000004744 12035451727 014411 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/floate.c 000644 000765 000024 00000010141 12035451727 014535 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/floate.h 000644 000765 000024 00000007636 12035451727 014561 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/hello.yf 000644 000765 000024 00000000125 12035451727 014563 0 ustar 00luca staff 000000 000000 #! /usr/bin/yforth
\
\ a simple example of a yforth script
\
.( Hello World!) cr bye
yforth-0.2.1/LICENSE 000644 000765 000024 00000001267 12035451727 014135 0 ustar 00luca staff 000000 000000 yForth? - A Forth interpreter written in ANSI C
Copyright (C) 2012 Luca Padovani
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
yforth-0.2.1/locals.c 000644 000765 000024 00000012002 12035451727 014536 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/locals.h 000644 000765 000024 00000004004 12035451727 014546 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/localse.c 000644 000765 000024 00000002566 12035451727 014721 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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;
}
}
yforth-0.2.1/localse.h 000644 000765 000024 00000002704 12035451727 014720 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/macro.h 000644 000765 000024 00000000641 12035451727 014375 0 ustar 00luca staff 000000 000000
#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
yforth-0.2.1/Makefile 000644 000765 000024 00000001423 12035451727 014562 0 ustar 00luca staff 000000 000000 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
yforth: div.h $(OBJECTS)
$(CC) -o yforth $(LDFLAGS) $(OBJECTS) $(MATHLIB)
div.h: div
./div
div: division.c
$(CC) -o div $(CFLAGS) $(CPPFLAGS) division.c
.c.o:
$(CC) -c -o $@ $(CFLAGS) $(CPPFLAGS) $<
clean:
rm -f *.o yforth div.h div
yforth-0.2.1/memall.c 000644 000765 000024 00000003103 12035451727 014532 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/memall.h 000644 000765 000024 00000003075 12035451727 014547 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/README 000644 000765 000024 00000013414 12035451727 014005 0 ustar 00luca staff 000000 000000 yForth? v0.2+beta - 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.
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 to 1 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 reset the definitions at the end of "config.h".
The second thing to do now is configuring the "Makefile". 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? 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...).
email: lpadovan@cs.unibo.it
Enjoy yForth?
**********************************************************************
CONTRIBUTORS
**********************************************************************
yforth-0.2.1/search.c 000644 000765 000024 00000006265 12035451727 014544 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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;
}
yforth-0.2.1/search.h 000644 000765 000024 00000003730 12035451727 014543 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/searche.c 000644 000765 000024 00000002707 12035451727 014706 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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--;
}
yforth-0.2.1/searche.h 000644 000765 000024 00000002760 12035451727 014712 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/string.c 000644 000765 000024 00000005602 12035451727 014577 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/string.h 000644 000765 000024 00000003176 12035451727 014610 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/tools.c 000644 000765 000024 00000004053 12035451727 014430 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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;
}
}
}
yforth-0.2.1/tools.h 000644 000765 000024 00000003026 12035451727 014434 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/toolse.c 000644 000765 000024 00000004126 12035451727 014576 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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() {
}
yforth-0.2.1/toolse.h 000644 000765 000024 00000003266 12035451727 014607 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/udio.c 000644 000765 000024 00000004474 12035451727 014237 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* Module name: udio.c
* Abstract: User Device Input/Output functions. Here are enclosed all
* non-portable functions.
*/
#include "yforth.h"
#if HAVE_CONIO
# include
#endif
#include "udio.h"
/* d_clrscr: clear the screen */
void d_clrscr() {
#if HAVE_CONIO
clrscr();
#endif
}
/* d_clreol: clear to end of line */
void d_clreol() {
#if HAVE_CONIO
clreol();
#endif
}
/* d_setattr: set default attributes */
void d_setaddr(Cell attr) {
#if HAVE_CONIO
textattr(attr);
#endif
}
/* d_getattr: get default attributes */
Cell d_getattr() {
#if HAVE_CONIO
struct text_info ti;
gettextinfo(&ti);
return (ti.attribute);
#endif
}
/* d_gotoxy: move the cursor to the location (x, y) of the screen */
void d_gotoxy(Cell x, Cell y) {
#if HAVE_CONIO
gotoxy(x, y);
#endif
}
/* d_wherex: current column position of the cursor */
Cell d_wherex() {
#if HAVE_CONIO
return (wherex());
#endif
}
/* d_wherey: current row position of the cursor */
Cell d_wherey() {
#if HAVE_CONIO
return (wherey());
#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() {
#if HAVE_CONIO
return (getch());
#endif
}
/* d_kbhit: return True if a character is available */
Cell d_kbhit() {
#if HAVE_CONIO
return (kbhit());
#endif
}
/* d_open: Initialize the Input/Output device */
void d_open() {
}
/* d_close: make some work when program finish to restore Input/Output device */
void d_close() {
}
yforth-0.2.1/udio.h 000644 000765 000024 00000002157 12035451727 014240 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
yforth-0.2.1/ver.h 000644 000765 000024 00000001666 12035451727 014100 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* Module name: ver.h
* Abstract: yForth? version definition
*/
#define VER_HI 0
#define VER_LO 2
#define VER_TEST ""
yforth-0.2.1/vm.c 000644 000765 000024 00000005213 12035451727 013711 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/ycore.c 000644 000765 000024 00000005101 12035451727 014404 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/ycore.h 000644 000765 000024 00000003056 12035451727 014420 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/yfinit.c 000644 000765 000024 00000011305 12035451727 014570 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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);
}
yforth-0.2.1/yforth.1 000644 000765 000024 00000001137 12035451727 014521 0 ustar 00luca staff 000000 000000 .TH YFORTH 1
.SH NAME
yforth \- a small, free Forth implementation
.SH SYNOPSIS
.B yforth
.SH DESCRIPTION
This is a small implementation of the Forth programming language, somewhat
easier to read than larger Forth implementations like Gforth.
It is not being actively developed or maintained. If you find it useful,
great. If not, don't expect much help. The www.forth.org site is a good
place to get more general information on Forth.
Serious Forth authors would be advised to use Gforth instead of this package.
.SH AUTHOR
This man page was cobbled up for the Debian distribution by Bdale Garbee.
yforth-0.2.1/yforth.c 000644 000765 000024 00000015567 12035451727 014617 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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 Copyright (C) 2012 Luca Padovani\n\
This program comes with ABSOLUTELY NO WARRANTY.\n\
This is free software, and you are welcome to redistribute it\n\
under certain conditions; see LICENSE for details.\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;
}
yforth-0.2.1/yforth.h 000644 000765 000024 00000013100 12035451727 014601 0 ustar 00luca staff 000000 000000 /* yForth? - A Forth interpreter written in ANSI C
* Copyright (C) 2012 Luca Padovani
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see .
* ------------------------------------------------------------------------
* 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
yforth-0.2.1/yforthlogo.gif 000644 000765 000024 00000004536 12035451727 016015 0 ustar 00luca staff 000000 000000 GIF87a` ? (((+++///222666999===@@@DDDGGGKKKNNNRRRUUUVVVYYY\\\]]]```cccdddgggjjjkkknnnqqqrrruuuxxxyyy||| , ` ?
!̇
&*& )&
$ԜdhE5b*>Tq