! Tiny-FORTH by Arduino 

もとプログラム

http://middleriver.chagasi.com/electronics/tforth.html

https://gist.github.com/monsonite/087218561b11557dd2f8

これ

https://gist.github.com/anonymous/e4f9bad7eefd8b74cceb


そのまま、ではチョット使いずらいので Serial.print / Serial.read で置き換え

ただメモリが足りなくなった（涙）



 //  Tiny FORTH by  T. NAKAGAWA   2004/07/04-10,7/29,8/5-6
 //   Def :: 2016-12-29 :: IDE setup / loop  用に書き換え 
 /*
  Tiny FORTH
  Experimental Forth for Arduino
  T. Nakagawa
  2004/07/10
  ==
  Export
    IDE 1.6.x で書き換え
    main の部分を setup / loop で 書き換え
    getch の部分が不安
    メモリの使用量が問題か？
 */
 
 #include <stdio.h>
 #include <stdlib.h>
 #include <avr/io.h>
 
 void initl(void);
 unsigned char getchr(void);
 void putchr(unsigned char c);
 
 /****************************************************************/ 
 
 #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 STACK_SIZE (128) /* 8 - 65536 */
 #define DIC_SIZE (512) /* 8 - 8*1024 */
 #define R2V(base, ptr) ((unsigned short)((ptr) - (base)))
 #define V2R(base, ptr) ((unsigned char *)((base) + (ptr)))
 
 #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);
 
 //  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((char *)">");
    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((char *)"!");
      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((char *)"??");
    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;
 }
 
 //--------------------------------------------------------------------------------------
 // UART Routines
 //--------------------------------------------------------------------------------------
 
 void u_putchar(char c) {
    Serial.write(c);
 }
 
 char rx_byte = 0;
 char u_getchar(void) {
    // loop_until_bit_is_set(UCSR0A, RXC0); /* Wait until data exists. */
    // return UDR0;
    if (Serial.available() > 0) {    // is a character available?
        rx_byte = Serial.read();       // get the character
    } else {
      rx_byte = '\0';
    }
    return rx_byte;
 }
 
 //-----------------------------------------------------------------------------------------
 
 void loop () {
    
    unsigned char tmp8;
    unsigned short tmp16;
    unsigned char *tkn;
 
    for ( ;; ) {
    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((char *)"?");
      continue;
      // return ;    // GreenTST
    }
 
    if (parstk > &(stack[STACK_SIZE])) {
      putmsg((char *)"OVF");
      parstk = &(stack[STACK_SIZE]);
    } else {
      putmsg((char *)"OK");
    }
  }
 }
 
 // Setup the various arrary and initialisation routines
 void setup() 
 { 
    // Enable UART
    Serial.begin(9600);
 
    initl();
 
    // Initialize the stack and dictionary 
    retstk = &(stack[0]);
    parstk = &(stack[STACK_SIZE]);
    dicptr = dic;
    dicent = V2R(dic, 0xffffU);
    
    putmsg((char *)"Tiny-FORTH");
 
 }