extend Tiny forth (http://middleriver.chagasi.com/electronics/tforth.html) with Arduino hardware primitives

tiny_forth_nxt.ino

// Tiny Forth NXT
// based on T. NAKAGAWA's Tiny Forth
// added Arduino hardware API and protothreads
// 8/2020



#include <EEPROM.h>

// protothreads library
#include <pt.h>

// add here for more protothreads
static struct pt pt_hw;


// Tiny Forth
#define BUF_SIZE 10  /* 8 - 255 */
#define STACK_SIZE (60) /* 8 - 65536 */
#define DICT_SIZE (500) /* 8 - 8*1024 */
#define R2V(base, ptr) ((unsigned short)((ptr) - (base)))
#define V2R(base, ptr) ((unsigned char *)((base) + (ptr)))


unsigned short stack[STACK_SIZE];
unsigned short *retstk;
unsigned short *parstk;
unsigned char dict[DICT_SIZE];
unsigned char *dictptr;
unsigned char *dict_nxt;

//input token limited to 3-character + space
unsigned char buf[BUF_SIZE];


void setup() {

  //setup Tiny Forth
  Serial.begin(115200);
  // Initialize the stack and dictionary
  retstk = &(stack[0]);
  parstk = &(stack[STACK_SIZE]);

  dictptr = dict;
  dict_nxt = V2R(dict, 0xffffU); //end of dict marker

  putmsg("Tiny FORTH NXT V1.0");

  //setup hardware GPIO
  pinMode(LED_BUILTIN, OUTPUT);

  //setup protothreads
  PT_INIT(&pt_hw);

}

//main loop
void loop() {
  if (gettkn()) {
    txtEval();
  }
}


//serial input/output interface + kick protothreads
unsigned char getchr(void) {
  int c;

  while (!Serial.available()) {
    PT_SCHEDULE(proto_hw(&pt_hw));  //run protothreads here
  }
  c = Serial.read();
  return (unsigned char)c;
}




void putchr(unsigned char c) {
  Serial.write(c);
}

// Put a Number
void putnum(short num) {
  if (num < 0) {
    num = -num;
    putchr('-');
  }
  if (num / (unsigned short)10 != 0)
    putnum(num / (unsigned short)10);
  putchr((char)(num % (unsigned short)10) + '0');
}

//  Put a message
void putmsg(char *msg) {
  Serial.println(msg);
}


//input buf to token terminated with SPACE
bool gettkn(void) {
  unsigned char * ptr = buf;
  unsigned char ch;
  unsigned char i = 0;

  for (; ; ) {
    ch = getchr();
    if (i >= BUF_SIZE) {
      putmsg("INPUT BUFFER OVF");
      return false;
    }
    if (ch == ' ' || ch == '\r' || ch == '\n') //split on space and RETURN
    {
      if (R2V(buf, ptr) < 1) { //escape empty token
        continue;
      } else {
        break; //go for processing
      }
    } else {
      *ptr ++ = ch;
      ++i;
    }
  }
  *ptr = ' '; //terminate input string
  return true;
}


#define PFX_EXTENDED 0xfdU
#define PFX_UDJ 0x80U
#define PFX_CDJ 0xa0U
#define PFX_CALL 0xc0U
#define PFX_PRIMITIVE 0xe0U
#define PFX_LIT 0xffU
#define PRX_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)

// primitives
#define KEY_EXTENDED "\x05" "LED" "DLY" "LST" "SAV" "LD " 
#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" "@  " "@@ " "!  " "!! " ".  "



bool literal(unsigned char *str, unsigned short *num);
bool lookup_in_dict(unsigned char *key, unsigned short *adrs);
bool find_in_list(unsigned char *key, char *list, unsigned char *id);
void compile(void);
void variable(void);
void forget(void);
void execute(unsigned short adrs);
void primitive(unsigned char ic);
void run_extended(unsigned char ic);

void txtEval() {
  unsigned char tmp8;
  unsigned short tmp16;
  if (literal(buf, &tmp16)) {   //push number literal on stack; $A..F for hex
    *(--parstk) = tmp16;
  } else if (lookup_in_dict(buf, &tmp16)) {
    execute(tmp16 + 2 + 3);  // header: 2-byte pointer to next + 3-byte NAME
  } else if (find_in_list(buf, KEY_PRIMITIVE, &tmp8)) {
    primitive(tmp8);
  } else if (find_in_list(buf, KEY_RUNMODE, &tmp8)) {
    switch (tmp8) {
      case 0:  /* : */
        compile();
        break;
      case 1: /* VAR */
        variable();
        break;
      case 2: /* FORGET */
        forget();
        break;
    }
  } else if (find_in_list(buf, KEY_EXTENDED, &tmp8)) {
    run_extended(tmp8);
  }
  else {
    putmsg(strcat(buf, "?"));
  }
  if (parstk > & (stack[STACK_SIZE])) {
    putmsg("OVF");
    parstk = &(stack[STACK_SIZE]);
  }
}




#define PT_YIELD_TIME_msec(delay_time)  \
  do { static unsigned long time_thread ;\
    time_thread = millis() + (unsigned int)delay_time ; \
    PT_YIELD_UNTIL(pt, (millis() >= time_thread)); \
  } while(0);


static PT_THREAD (proto_hw(struct pt *pt)) {
  PT_BEGIN(pt);
  unsigned char tmp8;
  unsigned short tmp16;
  // LOAD DIC
  find_in_list("LD ", KEY_EXTENDED, &tmp8);
  run_extended(tmp8);  
  // RUN "INI"  
  if(lookup_in_dict("INI", &tmp16)) {
    execute(tmp16 + 2 + 3);  // header: 2-byte pointer to next + 3-byte NAME
  }  
  while (1) {
   // digitalWrite(LED_BUILTIN, HIGH);
    PT_YIELD_TIME_msec(1000);
//    digitalWrite(LED_BUILTIN, LOW);
//    PT_YIELD_TIME_msec(1000);
  }
  PT_END(pt);
}







// Process a Literal
bool 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 true;
  } else if ('0' <= *str && *str <= '9') {
    unsigned short n = 0;
    for (; *str != ' '; str++) {
      n *= 10;
      n += *str - '0';
    }
    *num = n;
    return true;
  } else {
    return false;
  }
}

//  Find_in_list the Keyword in a List
bool find_in_list(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 true;
    }
  }
  return false;
}


//  Lookup the Keyword from the Dictionary
bool lookup_in_dict(unsigned char *key, unsigned short *adrs) {
  unsigned char *ptr;
  char temp[10];
  for (ptr = dict_nxt; ptr != V2R(dict, 0xffffU); ptr = V2R(dict, *ptr + * (ptr + 1) * 256U)) {
    if (ptr[2] == key[0] && ptr[3] == key[1] && (ptr[3] == ' ' || ptr[4] == key[2])) {
      *adrs = R2V(dict, ptr);
      return true;
    }
  }
  return false;
}



// Compile Mode
void compile(void) {
  unsigned char tmp8;
  unsigned short tmp16;

  // get the identifier
  gettkn();

  // Write the header
  tmp16 = R2V(dict, dict_nxt);
  dict_nxt = dictptr;
  *(dictptr++) = tmp16 % 256U;
  *(dictptr++) = tmp16 / 256U;
  *(dictptr++) = buf[0];
  *(dictptr++) = buf[1];
  *(dictptr++) = (buf[1] != ' ') ? buf[2] : ' ';

  for (; ; ) {
    gettkn();
    if (find_in_list(buf, KEY_COMPILEMODE, &tmp8)) {
      if (tmp8 == 0) {  /* ; */
        *(dictptr++) = PRX_RET;
        break;
      }
      switch (tmp8) {
          unsigned char *ptr;

        case 1: /* IF */
          *(retstk++) = R2V(dict, dictptr + 1);
          *(dictptr++) = PFX_CDJ;
          dictptr++;    //jump to addr.
          dictptr++;    //jump to addr.
          break;
        case 2: /* ELS */
          tmp16 = *(--retstk);
          ptr = V2R(dict, tmp16);
          tmp16 = R2V(dict, dictptr + 3);
          *(ptr++) = tmp16 / 256U;
          *(ptr++) = tmp16 % 256U;
          *(retstk++) = R2V(dict, dictptr + 1);
          *(dictptr++) = PFX_UDJ;
          dictptr++;
          dictptr++;
          break;
        case 3: /* THN */
          tmp16 = *(--retstk);
          ptr = V2R(dict, tmp16);
          tmp16 = R2V(dict, dictptr);
          *(ptr++) = (tmp16 / 256U);
          *(ptr++) = tmp16 % 256U;
          break;
        case 4: /* BGN */
          *(retstk++) = R2V(dict, dictptr);
          break;
        case 5: /* END */
          tmp16 = *(--retstk);
          *(dictptr++) = PFX_CDJ;
          *(dictptr++) = tmp16 / 256U;
          *(dictptr++) = tmp16 % 256U;
          break;
        case 6: /* WHL */
          *(retstk++) = R2V(dict, dictptr);
          dictptr += 3;
          break;
        case 7: /* RPT */
          tmp16 = *(--retstk);
          ptr = V2R(dict, tmp16);
          tmp16 = R2V(dict, dictptr + 3);
          *(ptr++) = PFX_CDJ;
          *(ptr++) = (tmp16 / 256U);
          *(ptr++) = tmp16 % 256U;
          tmp16 = *(--retstk);
          *(dictptr++) = PFX_UDJ;
          *(dictptr++) = (tmp16 / 256U);
          *(dictptr++) = tmp16 % 256U;
          break;
        case 8: /* DO */
          *(retstk++) = R2V(dict, dictptr + 1);
          *(dictptr++) = I_P2R2;
          break;
        case 9: /* LOP */
          *(dictptr++) = I_LOOP;
          tmp16 = *(--retstk);
          *(dictptr++) = PFX_CDJ;
          *(dictptr++) = (tmp16 / 256U);
          *(dictptr++) = tmp16 % 256U;
          *(dictptr++) = I_RDROP2;
          break;
        case 10:  /* I */
          *(dictptr++) = I_I;
          break;
      }
    } else if (lookup_in_dict(buf, &tmp16)) {
      tmp16 += 2 + 3;
      *(dictptr++) = PFX_CALL;
      *(dictptr++) = tmp16 / 256U;
      *(dictptr++) = tmp16 % 256U;
    } else if (find_in_list(buf, KEY_PRIMITIVE, &tmp8)) {
      *(dictptr++) = PFX_PRIMITIVE | tmp8;
    } else if (find_in_list(buf, KEY_EXTENDED, &tmp8)) {
      *(dictptr++) = PFX_EXTENDED;
      *(dictptr++) = tmp8;
    }
    else if (literal(buf, &tmp16)) {
      if (tmp16 < 128U) {
        *(dictptr++) = (unsigned char)tmp16;
      } else {
        *(dictptr++) = PFX_LIT;
        *(dictptr++) = tmp16 % 256U;
        *(dictptr++) = tmp16 / 256U;
      }
    } else {
      /* error */
      putmsg("!");
      continue;
    }
  }

}

// VARIABLE instruction
void variable(void) {
  unsigned short tmp16;

  // get an identifier
  gettkn();

  // Write the header
  tmp16 = R2V(dict, dict_nxt);
  dict_nxt = dictptr;
  *(dictptr++) = tmp16 % 256U; //lsb addr
  *(dictptr++) = tmp16 / 256U; //msb addr
  *(dictptr++) = buf[0];
  *(dictptr++) = buf[1];
  *(dictptr++) = (buf[1] != ' ') ? buf[2] : ' ';

  tmp16 = R2V(dict, dictptr + 2);
  if (tmp16 < 128U) {
    *(dictptr++) = (unsigned char)tmp16;
  } else {
    tmp16 = R2V(dict, dictptr + 4);
    *(dictptr++) = PFX_LIT;
    *(dictptr++) = tmp16 % 256U;
    *(dictptr++) = tmp16 / 256U;
  }
  *(dictptr++) = PRX_RET;
  *(dictptr++) = 0;  /* data area */
  *(dictptr++) = 0;  /* data area */


}

//  Forget Words in the Dictionary
void forget(void) {
  unsigned short tmp16;
  unsigned char *ptr;
  gettkn();
  // get a word
  if (!lookup_in_dict(buf, &tmp16)) {
    putmsg("??");
    return;
  }

  ptr = V2R(dict, tmp16);
  dict_nxt = V2R(dict, *ptr + * (ptr + 1) * 256U);
  dictptr = ptr;

}

//  Virtual Code Execution
void execute(unsigned short adrs) {
  unsigned char *pc;

  *(retstk++) = 0xffffU;

  for (pc = V2R(dict, adrs); pc != V2R(dict, 0xffffU); ) {
    unsigned char ir; /* instruction register */

    ir = *(pc++);

    if ((ir & 0x80U) == 0) {
      /* literal(0-127) */
      *(--parstk) = ir;
    } else if ( ir == PFX_EXTENDED) {
      run_extended(*(pc++));
    }
    else if (ir == PFX_LIT) {
      /* literal(128-65535) */
      unsigned short tmp16;
      tmp16 = *(pc++);
      tmp16 += *(pc++) * 256U;
      *(--parstk) = tmp16;
    } else if (ir == PRX_RET) {
      /* RET: return */
      pc = V2R(dict, *(--retstk));
    } else if ((ir & 0xe0U) == PFX_UDJ) {
      /* UDJ: unconditional direct jump */
      pc = V2R(dict, (*pc) * 256U + * (pc + 1));
    } else if ((ir & 0xe0U) == PFX_CDJ) {
      /* CDJ: conditional direct jump */
      if (*(parstk++) == 0) pc = V2R(dict, (*pc) * 256U + * (pc + 1)); else pc++;
    } else if ((ir & 0xe0U) == PFX_CALL) {
      /* CALL: subroutine call */
      *(retstk++) = R2V(dict, pc + 2);
      pc = V2R(dict, (*pc) * 256U + * (pc + 1));
    } else {
      /* primitive functions */
      primitive(ir & 0x1fU);
    }
  }
}

void run_extended(unsigned char ic) {
  int i;
  switch (ic) {
    case 0: /* LED */
      if (*(parstk++)) {
        digitalWrite(LED_BUILTIN, HIGH);
      } else {
        digitalWrite(LED_BUILTIN, LOW);
      }
      break;
    case 1: /* delay ms */
      //putmsg(" ... ");
      delay(*(parstk++));
      break;
    case 2: /* LST */
      putmsg("<dict>:");
      unsigned char * ptr;
      int p;
      p = *(parstk++);
      if (p) {
        for(i=0;i<p;i++){
                Serial.print(i);
                Serial.print(' ');
                Serial.println(dict[i]);
        }
      } else {
        for (ptr = dict_nxt; ptr != V2R(dict, 0xffffU); ptr = V2R(dict, *ptr + * (ptr + 1) * 256U)) {
          Serial.write(&ptr[2], 3); // NXT_PT<2-BYTE> + NAME<3-BYTE> + CONTENT
          Serial.print('\n');
        }
      }
      break;
    case 3: /* SAV */
      for (i = 0; i < DICT_SIZE; i++) {
        EEPROM.write(i, dict[i]);        
      }
      EEPROM.write(DICT_SIZE, R2V(dict, dictptr));
      EEPROM.write(DICT_SIZE + 1, R2V(dict, dict_nxt));
      break;
    case 4: /* LD */
      for (i = 0; i < DICT_SIZE; i++) {
        dict[i] = EEPROM.read(i);
      }
      dictptr = V2R(dict, EEPROM.read(DICT_SIZE));
      dict_nxt = V2R(dict, EEPROM.read(DICT_SIZE + 1));
      break;
  }
}
//  Execute a Primitive Instruction
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(dict, x0));
      x1 += *(V2R(dict, x0 + 1)) * 256U;
      *(--parstk) = x1;
      break;
    case 21:  /* @@ */
      x0 = *(parstk++);
      x1 = *(V2R(dict, x0));
      *(--parstk) = x1;
      break;
    case 22:  /* ! */
      x1 = *(parstk++);
      x0 = *(parstk++);
      *(V2R(dict, x1)) = x0 % 256U;
      *(V2R(dict, x1 + 1)) = x0 / 256U;
      break;
    case 23:  /* !! */
      x1 = *(parstk++);
      x0 = *(parstk++);
      *(V2R(dict, 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;
  }


}