Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
A Tiny Forth for Arduino - adapted from code from T. NAKAGAWA
// Tiny FORTH by T. NAKAGAWA 2004/07/04-10,7/29,8/5-6
/*
Tiny FORTH
Experimental Forth for Arduino
T. Nakagawa
2004/07/10
*/
#include <stdio.h>
#include <stdlib.h>
#include <avr/io.h>
#define F_CPU 16000000UL // define the clock frequency as 16MHz
#define BAUD 115200*2
#include <util/setbaud.h> // Set up the Uart baud rate generator
#include <uart.h>
// Setup the various arrary and initialisation routines
void setup()
{
// Enable UART
uart_init();
DDRD = DDRD | B11111100; // Sets pins 2 to 7 as outputs without changing the value of pins 0 & 1, which are RX & TX
DDRB = DDRB | B11111111; // Port B (Pin 9 - 13) is also output
PORTB &= B11111110; // Set pin 8 low
// parray = &array[0][0]; // parray is the pointer to the first element
}
#ifndef _SYSTEM_H_
#define _SYSTEM_H_
#define BUF_SIZE 128 /* 8 - 255 */
#define STACK_SIZE (256) /* 8 - 65536 */
#define DIC_SIZE (1024) /* 8 - 8*1024 */
#define R2V(base, ptr) ((unsigned short)((ptr) - (base)))
#define V2R(base, ptr) ((unsigned char *)((base) + (ptr)))
void initl(void);
unsigned char getchr(void);
void putchr(unsigned char c);
#endif
void initl(void) {
return;
}
unsigned char getchr(void) {
int c;
c = u_getchar();
if (c == '\x03') exit(0); /* CTRL+C */
if (c < 0) c = 0;
u_putchar(c);
return (unsigned char)c;
}
void putchr(unsigned char c) {
u_putchar(c);
return;
}
#include <stdio.h>
#include <stdlib.h>
#define KEY_RUNMODE "\x03" ": " "VAR" "FGT"
#define KEY_COMPILEMODE "\x0b" "; " "IF " "ELS" "THN" "BGN" "END" "WHL" "RPT" "DO " "LOP" "I "
#define KEY_PRIMITIVE "\x19" "DRP" "DUP" "SWP" ">R " "R> " "+ " "- " "* " "/ " "MOD" "AND" "OR " "XOR" "= " "< " "> " "<= " ">= " "<> " "NOT" "@ " "@@ " "! " "!! " ". "
#define PFX_UDJ 0x80U
#define PFX_CDJ 0xa0U
#define PFX_CALL 0xc0U
#define PFX_PRIMITIVE 0xe0U
#define I_LIT 0xffU
#define I_RET 0xfeU
#define I_LOOP (PFX_PRIMITIVE | 25U)
#define I_RDROP2 (PFX_PRIMITIVE | 26U)
#define I_I (PFX_PRIMITIVE | 27U)
#define I_P2R2 (PFX_PRIMITIVE | 28U)
static unsigned short stack[STACK_SIZE];
static unsigned short *retstk;
static unsigned short *parstk;
static unsigned char dic[DIC_SIZE];
static unsigned char *dicptr;
static unsigned char *dicent;
static void putmsg(char *msg);
static unsigned char *gettkn(void);
static char literal(unsigned char *str, unsigned short *num);
static char lookup(unsigned char *key, unsigned short *adrs);
static char find(unsigned char *key, char *list, unsigned char *id);
static void compile(void);
static void variable(void);
static void forget(void);
static void execute(unsigned short adrs);
static void primitive(unsigned char ic);
static void putnum(unsigned short num);
int main(void) {
initl();
// Initialize the stack and dictionary
retstk = &(stack[0]);
parstk = &(stack[STACK_SIZE]);
dicptr = dic;
dicent = V2R(dic, 0xffffU);
putmsg("Tiny FORTH");
for (; ; ) {
unsigned char tmp8;
unsigned short tmp16;
unsigned char *tkn;
tkn = gettkn();
// keyword
if (find(tkn, KEY_RUNMODE, &tmp8)) {
switch (tmp8) {
case 0: /* : */
compile();
break;
case 1: /* VAR */
variable();
break;
case 2: /* FORGET */
forget();
break;
}
} else if (lookup(tkn, &tmp16)) {
execute(tmp16 + 2 + 3);
} else if (find(tkn, KEY_PRIMITIVE, &tmp8)) {
primitive(tmp8);
} else if (literal(tkn, &tmp16)) {
*(--parstk) = tmp16;
} else {
// error
putmsg("?");
continue;
}
if (parstk > &(stack[STACK_SIZE])) {
putmsg("OVF");
parstk = &(stack[STACK_SIZE]);
} else {
putmsg("OK");
}
}
}
// Put a message
static void putmsg(char *msg) {
while (*msg != '\0') putchr(*(msg++));
putchr('\r');
putchr('\n');
return;
}
// Get a Token
static unsigned char *gettkn(void) {
static unsigned char buf[BUF_SIZE] = " "; // == " \0\0\0..."
unsigned char ptr;
// remove leading non-delimiters
while (*buf != ' ') {
for (ptr = 0; ptr < BUF_SIZE - 1; ptr++) buf[ptr] = buf[ptr + 1];
buf[ptr] = '\0';
}
for (; ; ) {
// remove leading delimiters
while (*buf == ' ') {
for (ptr = 0; ptr < BUF_SIZE - 1; ptr++) buf[ptr] = buf[ptr + 1];
buf[ptr] = '\0';
}
if (*buf == '\0') {
for (ptr = 0; ; ) {
unsigned char c;
c = getchr();
if (c == '\r') {
putchr('\n');
buf[ptr] = ' ';
break;
} else if (c == '\b') {
if (ptr == 0) continue;
buf[--ptr] = '\0';
putchr(' ');
putchr('\b');
} else if (c <= 0x1fU) {
} else if (ptr < BUF_SIZE - 1) {
buf[ptr++] = c;
} else {
putchr('\b');
putchr(' ');
putchr('\b');
}
}
} else {
return buf;
}
}
}
// Process a Literal
static char literal(unsigned char *str, unsigned short *num) {
if (*str == '$') {
unsigned short n = 0;
for (str++; *str != ' '; str++) {
n *= 16;
if (*str <= '9') n += *str - '0'; else n += *str - 'A' + 10;
}
*num = n;
return 1;
} else if ('0' <= *str && *str <= '9') {
unsigned short n = 0;
for (; *str != ' '; str++) {
n *= 10;
n += *str - '0';
}
*num = n;
return 1;
} else {
return 0;
}
}
// Lookup the Keyword from the Dictionary
static char lookup(unsigned char *key, unsigned short *adrs) {
unsigned char *ptr;
for (ptr = dicent; ptr != V2R(dic, 0xffffU); ptr = V2R(dic, *ptr + *(ptr + 1) * 256U)) {
if (ptr[2] == key[0] && ptr[3] == key[1] && (ptr[3] == ' ' || ptr[4] == key[2])) {
*adrs = R2V(dic, ptr);
return 1;
}
}
return 0;
}
// Find the Keyword in a List
static char find(unsigned char *key, char *list, unsigned char *id) {
unsigned char n, m;
for (n = 0, m = *(list++); n < m; n++, list += 3) {
if (list[0] == key[0] && list[1] == key[1] && (key[1] == ' ' || list[2] == key[2])) {
*id = n;
return 1;
}
}
return 0;
}
// Compile Mode
static void compile(void) {
unsigned char *tkn;
unsigned char tmp8;
unsigned short tmp16;
// get the identifier
tkn = gettkn();
// Write the header
tmp16 = R2V(dic, dicent);
dicent = dicptr;
*(dicptr++) = tmp16 % 256U;
*(dicptr++) = tmp16 / 256U;
*(dicptr++) = tkn[0];
*(dicptr++) = tkn[1];
*(dicptr++) = (tkn[1] != ' ') ? tkn[2] : ' ';
for (; ; ) {
putmsg(">");
tkn = gettkn();
if (find(tkn, KEY_COMPILEMODE, &tmp8)) {
if (tmp8 == 0) { /* ; */
*(dicptr++) = I_RET;
break;
}
switch (tmp8) {
unsigned char *ptr;
case 1: /* IF */
*(retstk++) = R2V(dic, dicptr);
*(dicptr++) = PFX_CDJ;
dicptr++;
break;
case 2: /* ELS */
tmp16 = *(--retstk);
ptr = V2R(dic, tmp16);
tmp8 = *(ptr);
tmp16 = R2V(dic, dicptr + 2) - tmp16 + 4096U;
*(ptr++) = tmp8 | (tmp16 / 256U);
*(ptr++) = tmp16 % 256U;
*(retstk++) = R2V(dic, dicptr);
*(dicptr++) = PFX_UDJ;
dicptr++;
break;
case 3: /* THN */
tmp16 = *(--retstk);
ptr = V2R(dic, tmp16);
tmp8 = *(ptr);
tmp16 = R2V(dic, dicptr) - tmp16 + 4096U;
*(ptr++) = tmp8 | (tmp16 / 256U);
*(ptr++) = tmp16 % 256U;
break;
case 4: /* BGN */
*(retstk++) = R2V(dic, dicptr);
break;
case 5: /* END */
tmp16 = *(--retstk) - R2V(dic, dicptr) + 4096U;
*(dicptr++) = PFX_CDJ | (tmp16 / 256U);
*(dicptr++) = tmp16 % 256U;
break;
case 6: /* WHL */
*(retstk++) = R2V(dic, dicptr);
dicptr += 2;
break;
case 7: /* RPT */
tmp16 = *(--retstk);
ptr = V2R(dic, tmp16);
tmp16 = R2V(dic, dicptr + 2) - tmp16 + 4096U;
*(ptr++) = PFX_CDJ | (tmp16 / 256U);
*(ptr++) = tmp16 % 256U;
tmp16 = *(--retstk) - R2V(dic, dicptr) + 4096U;
*(dicptr++) = PFX_UDJ | (tmp16 / 256U);
*(dicptr++) = tmp16 % 256U;
break;
case 8: /* DO */
*(retstk++) = R2V(dic, dicptr + 1);
*(dicptr++) = I_P2R2;
break;
case 9: /* LOP */
*(dicptr++) = I_LOOP;
tmp16 = *(--retstk) - R2V(dic, dicptr) + 4096U;
*(dicptr++) = PFX_CDJ | (tmp16 / 256U);
*(dicptr++) = tmp16 % 256U;
*(dicptr++) = I_RDROP2;
break;
case 10: /* I */
*(dicptr++) = I_I;
break;
}
} else if (lookup(tkn, &tmp16)) {
tmp16 += 2 + 3 - R2V(dic, dicptr) + 4096U;
*(dicptr++) = PFX_CALL | (tmp16 / 256U);
*(dicptr++) = tmp16 % 256U;
} else if (find(tkn, KEY_PRIMITIVE, &tmp8)) {
*(dicptr++) = PFX_PRIMITIVE | tmp8;
} else if (literal(tkn, &tmp16)) {
if (tmp16 < 128U) {
*(dicptr++) = (unsigned char)tmp16;
} else {
*(dicptr++) = I_LIT;
*(dicptr++) = tmp16 % 256U;
*(dicptr++) = tmp16 / 256U;
}
} else {
/* error */
putmsg("!");
continue;
}
}
return;
}
// VARIABLE instruction
static void variable(void) {
unsigned char *tkn;
unsigned short tmp16;
// get an identifier
tkn = gettkn();
// Write the header
tmp16 = R2V(dic, dicent);
dicent = dicptr;
*(dicptr++) = tmp16 % 256U;
*(dicptr++) = tmp16 / 256U;
*(dicptr++) = tkn[0];
*(dicptr++) = tkn[1];
*(dicptr++) = (tkn[1] != ' ') ? tkn[2] : ' ';
tmp16 = R2V(dic, dicptr + 2);
if (tmp16 < 128U) {
*(dicptr++) = (unsigned char)tmp16;
} else {
tmp16 = R2V(dic, dicptr + 4);
*(dicptr++) = I_LIT;
*(dicptr++) = tmp16 % 256U;
*(dicptr++) = tmp16 / 256U;
}
*(dicptr++) = I_RET;
*(dicptr++) = 0; /* data area */
*(dicptr++) = 0; /* data area */
return;
}
// Forget Words in the Dictionary
static void forget(void) {
unsigned short tmp16;
unsigned char *ptr;
// get a word
if (!lookup(gettkn(), &tmp16)) {
putmsg("??");
return;
}
ptr = V2R(dic, tmp16);
dicent = V2R(dic, *ptr + *(ptr + 1) * 256U);
dicptr = ptr;
return;
}
// Virtual Code Execution
static void execute(unsigned short adrs) {
unsigned char *pc;
*(retstk++) = 0xffffU;
for (pc = V2R(dic, adrs); pc != V2R(dic, 0xffffU); ) {
unsigned char ir; /* instruction register */
ir = *(pc++);
if ((ir & 0x80U) == 0) {
/* literal(0-127) */
*(--parstk) = ir;
} else if (ir == I_LIT) {
/* literal(128-65535) */
unsigned short tmp16;
tmp16 = *(pc++);
tmp16 += *(pc++) * 256U;
*(--parstk) = tmp16;
} else if (ir == I_RET) {
/* RET: return */
pc = V2R(dic, *(--retstk));
} else if ((ir & 0xe0U) == PFX_UDJ) {
/* UDJ: unconditional direct jump */
pc = V2R(dic, R2V(dic, pc - 1) + (ir & 0x1fU) * 256U + *pc - 4096U);
} else if ((ir & 0xe0U) == PFX_CDJ) {
/* CDJ: conditional direct jump */
if (*(parstk++) == 0) pc = V2R(dic, R2V(dic, pc - 1) + (ir & 0x1fU) * 256U + *pc - 4096U); else pc++;
} else if ((ir & 0xe0U) == PFX_CALL) {
/* CALL: subroutine call */
*(retstk++) = R2V(dic, pc + 1);
pc = V2R(dic, R2V(dic, pc - 1) + (ir & 0x1fU) * 256U + *pc - 4096U);
} else {
/* primitive functions */
primitive(ir & 0x1fU);
}
}
return;
}
// Execute a Primitive Instruction
static void primitive(unsigned char ic) {
unsigned short x0, x1;
switch (ic) {
case 0: /* DRP */
parstk++;
break;
case 1: /* DUP */
x0 = *parstk;
*(--parstk) = x0;
break;
case 2: /* SWP */
x1 = *(parstk++);
x0 = *(parstk++);
*(--parstk) = x1;
*(--parstk) = x0;
break;
case 3: /* >R */
*(retstk++) = *(parstk++);
break;
case 4: /* R> */
*(--parstk) = *(--retstk);
break;
case 5: /* + */
x0 = *(parstk++);
*parstk += x0;
break;
case 6: /* - */
x0 = *(parstk++);
*parstk -= x0;
break;
case 7: /* * */
x0 = *(parstk++);
*parstk *= x0;
break;
case 8: /* / */
x0 = *(parstk++);
*parstk /= x0;
break;
case 9: /* MOD */
x0 = *(parstk++);
*parstk %= x0;
break;
case 10: /* AND */
x0 = *(parstk++);
*parstk &= x0;
break;
case 11: /* OR */
x0 = *(parstk++);
*parstk |= x0;
break;
case 12: /* XOR */
x0 = *(parstk++);
*parstk ^= x0;
break;
case 13: /* = */
x1 = *(parstk++);
x0 = *(parstk++);
*(--parstk) = (x0 == x1);
break;
case 14: /* < */
x1 = *(parstk++);
x0 = *(parstk++);
*(--parstk) = (x0 < x1);
break;
case 15: /* > */
x1 = *(parstk++);
x0 = *(parstk++);
*(--parstk) = (x0 > x1);
break;
case 16: /* <= */
x1 = *(parstk++);
x0 = *(parstk++);
*(--parstk) = (x0 <= x1);
break;
case 17: /* >= */
x1 = *(parstk++);
x0 = *(parstk++);
*(--parstk) = (x0 >= x1);
break;
case 18: /* <> */
x1 = *(parstk++);
x0 = *(parstk++);
*(--parstk) = (x0 != x1);
break;
case 19: /* NOT */
*parstk = (*parstk == 0);
break;
case 20: /* @ */
x0 = *(parstk++);
x1 = *(V2R(dic, x0));
x1 += *(V2R(dic, x0 + 1)) * 256U;
*(--parstk) = x1;
break;
case 21: /* @@ */
x0 = *(parstk++);
x1 = *(V2R(dic, x0));
*(--parstk) = x1;
break;
case 22: /* ! */
x1 = *(parstk++);
x0 = *(parstk++);
*(V2R(dic, x1)) = x0 % 256U;
*(V2R(dic, x1 + 1)) = x0 / 256U;
break;
case 23: /* !! */
x1 = *(parstk++);
x0 = *(parstk++);
*(V2R(dic, x1)) = (unsigned char)x0;
break;
case 24: /* . */
putnum(*(parstk++));
putchr(' ');
break;
case 25: /* LOOP */
(*(retstk - 2))++;
x1 = *(retstk - 2);
x0 = *(retstk - 1);
*(--parstk) = (x0 <= x1);
break;
case 26: /* RDROP2 */
retstk -= 2;
break;
case 27: /* I */
*(--parstk) = *(retstk - 2);
break;
case 28: /* P2R2 */
*(retstk++) = *(parstk++);
*(retstk++) = *(parstk++);
break;
}
return;
}
// Put a Number
static void putnum(unsigned short num) {
if (num / (unsigned short)10 != 0) putnum(num / (unsigned short)10);
putchr((char)(num % (unsigned short)10) + '0');
return;
}
/*
void putchr(char)
{
return;
}
char getchr()
{
return;
}
*/
//--------------------------------------------------------------------------------------
// UART Routines
//--------------------------------------------------------------------------------------
void uart_init(void)
{
UBRR0H = UBRRH_VALUE;
UBRR0L = UBRRL_VALUE;
#if USE_2X
UCSR0A |= _BV(U2X0);
#else
UCSR0A &= ~(_BV(U2X0));
#endif
UCSR0C = _BV(UCSZ01) | _BV(UCSZ00); /* 8-bit data */
UCSR0B = _BV(RXEN0) | _BV(TXEN0); /* Enable RX and TX */
}
void u_putchar(char c) {
loop_until_bit_is_set(UCSR0A, UDRE0); /* Wait until data register empty. */
UDR0 = c;
}
char u_getchar(void) {
loop_until_bit_is_set(UCSR0A, RXC0); /* Wait until data exists. */
return UDR0;
}
//-----------------------------------------------------------------------------------------
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment