/* vim: set ft=cpp showbreak=»\ noexpandtab fileencoding=utf-8 nomodified wrap textwidth=0 foldmethod=marker foldmarker={{{,}}} foldcolumn=4 ruler showcmd list: lcs=tab\:|- tabstop=8 linebreak */

// ,,g = gcc, exactly one space after "set"

#include <stdint.h>

#include <stddef.h>

#include <string.h>

#include <stdbool.h>

#include <stdlib.h>

#ifdef __PC__

#include "itoa.h"

#endif

#include "flags.h"

#include "ptr24.h"

#include "io.h"

#include "debug.h"

#ifdef __PC__

#include "memdump.h"

#include <stdio.h>

#define PEDANT

#include <unistd.h>

#endif

extern uint8_t B1at(uint32_t p); // asm.S read 1 byte at address p (somewhere), return 1 byte

extern uint16_t B2at(uint32_t p); // asm.S read 2 bytes at address p (somewhere), return 2 bytes

extern uint32_t B3at(uint32_t p); // asm.S read 3 bytes at address p (somewhere), return 4 bytes (top cleared)

extern uint32_t B4at(uint32_t p); // asm.S read 4 bytes at address p (somewhere), return 4 bytes

extern const __memx void * B3PTR(uint32_t p); // asm.S typecast, get 3 bytes, return 4 bytes (top cleared)

extern uint32_t B3U32(const __memx void * p); // asm.S typecast, get 3 bytes, return 4 bytes (top cleared)

extern void jmp_indirect_24(uint32_t p); // asm.S call function, which byte_address is at address p (somewhere) (converts bytes to words)

/*

* Decision:

* cell = uint16_t

* pointer = uint32_t, but only 3B used, 4.B always zero

*/

_Static_assert(sizeof(uint32_t) == 4, "uint32_t must be 32 bits");

#if defined(__AVR_ATmega328P__) || defined(__AVR_ATmega2560__)

_Static_assert(sizeof(const __memx void *) == 3, "const __memx void * must be 24 bits");

#elif defined(__PC__)

_Static_assert(sizeof(const __memx void *) == 4, "const __memx void * must be 32 bits");

void do_traceback(); // forward

extern char a_read_char();

char read_char() {

char c=a_read_char();

if (c==0x7E) do_traceback();

return c;

}

#else

#error undefined

#endif

void write_num8(uint8_t n) { // {{{

if (n>99) {

write_char('0'+ n/100);

n=n % 100;

};

if (n>9) {

write_char('0'+ n/10);

n=n % 10;

};

write_char('0'+n);

} // }}}

char buf[32]; // temporary buffer - stack eating structures cannot be in NEXT-chained functions, or stack will overflow !!!

/** {{{ Intro

* Lets start programming FORTH

* My idea is

* * Indirect Threading

* * long names for words

* * well, possibly more than just 3 (of nano Forth)

* * strictly less then 32 (so Pascal Length can be found backward)

* * only ASCII chars allowed (from space=0x20 upt to tilda=0x7F)

* *

* * some FORTH words will be in FLASH

* * so 3+ bytes pointers are needed

* * 3 bytes pointers are problematic and __memx is tricky, so let use uint32_t instead and few asm utils

* the header is divided into two parts, first is for dictionary, followed second, which is for runing words

* C discourse

* * first we need 3bytes pointer to something

* * it will be memory, but maybe RAM, maybe FLASH

* * it will be

* * byte in memory - uint8_t (just the memory itself after all)

* * 3bytes pointer in memory (usually pointer to some other word)

* * const char (for easy string manipulation)

* * 3B pointer to function in FLASH (well it could be 2B on 328, but not on 2560, and we will use it together with other 3B pointers, so make ++/-- easy)

* * anything else, which can be (type casted) at will

* */ // }}}

/*

typedef const __memx void(*CodeWord_t)(); // CodeWord_t is 2B pointer to function (in FLASH) (*CodeWord_t)() calls the function.

typedef const __memx CodeWord_t (*Data_t); // Data_t is 3B pointer to CodeWord_t "somewhere"

typedef const __memx Data_t (* InstrPoint_t); // InstrPoint_t is 3B pointer to Data_t "somewhere"

typedef void const __memx *PTR_t; // universal 3B pointer to any data "somewhere"

typedef uint16_t CELL_t; // cell on data stack 2B

typedef const __memx char *xpC; // 3B pointer 1B target pointer "somewhere" to char "somewhere"

typedef const __memx uint8_t *xpB; // 3B pointer 1B target pointer "somewhere" to byte "somewhere"

typedef const __memx uint32_t *xpD;

typedef struct head1_t { // {{{

const __memx struct head1_t *next; // 3B: pointer to next header "somewhere"

uint8_t fill; // to 4B pointer

uint8_t flags; // 1B:

uint8_t len; // 1B: up to 31 (=5bits)

const char name[]; // len B:name of WORD

} head1_t; // }}}

typedef const __memx head1_t *xpHead1; // 3B pointer to head1 "somewhere"

*/

/*

* typedef struct head2 { // {{{

* CodeWord_t codepoint; // 3B: pointer to function to interpret data

* Data_t data[]; // 3B: pointer to 2B pointer "somewhere" to function to interpret data - pointer to head2 "somewhere"

* } head2; // }}}

*/

typedef const __memx void(*CodeWord_t)(); // CodeWord_t is 2B pointer to function (in FLASH) (*CodeWord_t)() calls the function.

typedef const __memx CodeWord_t (*Data_t); // Data_t is 3B pointer to CodeWord_t "somewhere"

typedef const __memx char *xpC; // 3B pointer 1B target pointer "somewhere" to char "somewhere"

typedef struct head1_t { // {{{

const __memx struct head1_t *next; // 3B: pointer to next header "somewhere"

#if defined(__AVR_ATmega328P__) || defined(__AVR_ATmega2560__)

uint8_t fill; // to 4B pointer

#endif

uint8_t flags; // 1B:

uint8_t len; // 1B: up to 31 (=5bits)

const char name[]; // len B:name of WORD

} head1_t; // }}}

typedef const __memx head1_t *xpHead1; // 3B pointer to head1 "somewhere"

typedef uint32_t PTR_t; // universal "3B pointer" to any data "somewhere" - use B1at, B3at for dereferencing

typedef uint16_t CELL_t; // cell on data stack 2B

typedef int16_t S_CELL_t; // signed cell on data stack 2B

typedef uint32_t DOUBLE_t; // 2 cell on data stack 4B

typedef int32_t S_DOUBLE_t; // signed 2 cell on data stack 4B

typedef uint8_t BYTE_t; // something for pointers to points to

PTR_t IP; // pointer to element of data[], which should be next

PTR_t DT; // NEXT is **(IP++)() - so DT=*IP as internal step. DT is value of last data pointed by IP before NEXT (= address of codepoint to exec) (used by f_docol to know, from where it was called) - f_docol= { Rpush(IP);IP=DT + x; NEXT} x=sizeof(codeword)

/*

* STACKS:

* for now I will use array and index, as it is easy to check range and only pop/push should be affected

* also lets start with small value, so it can be tested for both under- and over- flow

* also let push grow up and pop go down and 0 is empty stack (so push(x){stck[stack++]=x;}

*/

CELL_t stck[STACK_LEN];

uint16_t stack=0;

PTR_t Rstck[RSTACK_LEN];

uint16_t Rstack=0;

/*

* RAM:

* now let it be just small array too

* and test it until all works

*/

uint8_t RAM[RAM_LEN];

uint32_t HERE;

//const __memx uint8_t *HERE;

/*

* LAST

* pointer to begin of last header

*/

PTR_t LAST;

extern const __memx BYTE_t top_head; // pointer to last header in asm module

extern const __memx BYTE_t w_lit_cw;

extern const __memx BYTE_t w_quit_cw;

extern const __memx BYTE_t w_exit_cw;

extern const __memx BYTE_t w_double;

extern const __memx char w_test_data;

extern const __memx char w_test_cw;

extern const __memx char w_quit_data;

extern const __memx DOUBLE_t val_of_w_exit_cw;

extern const __memx DOUBLE_t val_of_f_docol;

extern const __memx char w_lit2_cw;

extern const __memx char w_firtsbuildinword_head;

extern const __memx char w_lastbuildinword_head;

extern const __memx char w_lastbuildinword_end;

#define NEXT

//#define NEXT f_next()

//void f_next() __attribute__((noreturn));

void f_next(){ // {{{

INFO("f_next");

DT=B3at(IP);

DEBUG_DUMP(IP,"IP old ");

// ERROR("Press ANY key to continue");

// wait_for_char();

IP+=4; // IP++ but 4 bytes everytime

DEBUG_DUMP(IP,"IP new ");

DEBUG_DUMP(DT,"DT new ");

DEBUG_DUMP(B3at(DT),"*DT ");

jmp_indirect_24(DT);

} // }}}

void forth_loop(uint32_t cw_addr) { // {{{

INFO("Start of loop");

uint32_t fake[2];

fake[0]=cw_addr;

fake[1]=B3U32(NULL);

IP=B3U32(&fake[0]);

while ( (IP!=B3U32(NULL)) && ( (DT=B4at(IP)) !=B3U32(NULL)) ) {

DT=B4at(IP);

DEBUG_DUMP(IP,"IP: ");

DEBUG_DUMP(DT,"DT: ");

IP+=4;

jmp_indirect_24(DT);

// ((void (*)(void))B4at(DT))();

// ((void (*)(void))B3PTR(B4at(DT)))();

};

INFO("End of loop");

} // }}}

// {{{ pop ...

CELL_t pop() {

if (stack==0) {

ERROR("pop - Stack underflow");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex16(stck[stack-1]);

INFO("pop");

return stck[--stack];

}

void push(CELL_t x) {

if (! noinfo) write_hex16(x);

INFO("push");

if(stack>STACK_LEN-1) {

ERROR("push - Stack owerlow");

#ifdef PEDANT

do_traceback();

#endif

return;

};

stck[stack++]=x;

}

CELL_t peek(){

if (stack<1) {

ERROR("peek - No Stack left");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex16(stck[stack-1]);

INFO("peek");

return stck[stack-1];

}

CELL_t peekX(uint8_t depth){

if (stack<1+depth) {

ERROR("peek - No Stack left");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex16(stck[stack-1-depth]);

INFO("peek");

return stck[stack-1-depth];

}

// }}}

// {{{ pop2 ...

DOUBLE_t pop2() {

if (stack<2) {

ERROR("pop2 - Stack underflow");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex32((stck[stack-2]*(1L<<16))+stck[stack-1]);

INFO("pop2");

DOUBLE_t r=stck[stack-2]*(1L<<16)+stck[stack-1];

stack-=2;

return r;

}

void push2(DOUBLE_t x) {

if(stack>STACK_LEN-2) {

ERROR("push2 - Stack owerlow");

#ifdef PEDANT

do_traceback();

#endif

return;

};

if (! noinfo) write_hex32(x);

INFO("push2");

stck[stack++]=x>>16;

stck[stack++]=x&0xFFFF;

}

DOUBLE_t peek2(){

if (stack<2) {

ERROR("peek2 - No Stack left");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex32(stck[stack-2]*(1L<<16)+stck[stack-1]);

INFO("peek2");

return stck[stack-2]*(1L<<16)+stck[stack-1];

}

DOUBLE_t peek2X(uint8_t depth){

if (stack<2+depth) {

ERROR("peek2 - No Stack left");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex32(stck[stack-2-depth]*(1L<<16)+stck[stack-1-depth]);

INFO("peek2");

return stck[stack-2-depth]*(1L<<16)+stck[stack-1-depth];

}

// }}}

// {{{ Rpop ...

PTR_t Rpop() {

if (Rstack==0) {

ERROR("Rpop - Stack underflow");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex32(Rstck[Rstack-1]);

INFO("Rpop");

return Rstck[--Rstack];

}

void Rpush(PTR_t x) {

if (! noinfo) write_hex32(x);

INFO("Rpush");

if(Rstack>RSTACK_LEN-1) {

ERROR("Rpush - Stack owerlow");

#ifdef PEDANT

do_traceback();

#endif

return;

};

Rstck[Rstack++]=x;

}

PTR_t Rpeek(){

if (Rstack==0) {

ERROR("Rpeek - No Stack left");

#ifdef PEDANT

do_traceback();

#endif

return 0;

};

if (! noinfo) write_hex32(Rstck[Rstack-1]);

INFO("Rpeek");

return Rstck[Rstack-1];

}

// }}}

// {{{ some internal functions

uint8_t word_buf_len=0;

char word_buf[32];

void get_word(){ // {{{ WAITS for word and puts it into word_buf_len + word_buf

uint8_t i=0;

char c=' ';

while (true){

while (strchr(" \t\r\n",c)) c=wait_for_char(); // skip spaces

if (c=='\\') {

while (!strchr("\r\n",c)) c=wait_for_char();

continue;

}; // skip \ comments to the end of line

break;}; // finally word begins

while ((!strchr(" \t\r\n",c)) && (i<sizeof(word_buf)-1)) {word_buf[i++]=c;c=wait_for_char();};

word_buf[i]=0;

word_buf_len=i;

} // }}}

xpHead1 findHead(uint8_t len,const char *wordname, xpHead1 h) { // {{{

if (len==0) return NULL;

while (h) { // internally it ends on .long 0

if (h->flags & FLG_HIDDEN) { h=h->next;continue;};

if (h->len != len) { h=h->next;continue;};

const char *c=wordname;

xpC hc=&(h->name[0]);

int16_t l=len;

while (l--) if(*c++!=*hc++) { break;};

if (l==-1) return h;

h=h->next;

}

return NULL;

} // }}}

uint32_t get_codeword_addr(xpHead1 h){ // {{{ // Data_t

if (!(B3U32(h) & ~0x800000L)) return 0;

if (!h) return 0;

xpC c=&h->name[h->len];

return B3U32(c);

} // }}}

// }}}

void f_docol(); // FORWARD

#if defined(__AVR_ATmega328P__) || defined(__AVR_ATmega2560__)

#define VARfn(name) void push_var_##name(){TRACE(#name);push(0x80);push((CELL_t)((uint16_t)(&name)));NEXT;}

#elif defined(__PC__)

#define VARfn(name) void push_var_##name(){TRACE(#name);push2(((uint32_t)(&name)));NEXT;}

#else

#error undefined

#endif

#define VAR(name,value) CELL_t name=(CELL_t)value;VARfn(name)

#define CONST(name,value) void push_const_##name(){TRACE(#name);push(value); NEXT;}

#define CONST2(name,value) void push_const_##name(){TRACE(#name);push2(value); NEXT;}

typedef enum { st_executing, st_compiling} st_STATE;

VARfn(LAST) // LAST is in RAM, just points "somewhere"

st_STATE STATE=st_executing;

VARfn(STATE)

//uint8_t *HERE;

VARfn(HERE)

VAR(BASE,16)

CONST2(DOCOL,B3U32(f_docol))

CONST2(RAM,B3U32(RAM))

CONST2(RAM_END,B3U32(&RAM[RAM_LEN]))

CONST2(S0,B3U32(stck))

CONST2(S_END,B3U32(&stck[STACK_LEN]))

CONST2(R0,B3U32(Rstck))

CONST2(R_END,B3U32(&Rstck[RSTACK_LEN]))

void print_stack() { // {{{ just simple debug print

for (int8_t p=0;p<stack;p++) {write_char('[');write_hex16(stck[p]);write_char(']');};

} // }}}

void print_Rstack() { // {{{ just simple debug print

for (int8_t p=1;p<Rstack;p++) {write_char('<');write_hex32(Rstck[p]);write_char('>');};

} // }}}

// {{{ dup, plus, ...

void f_dup(){ // {{{

TRACE("DUP");

push(peek());

NEXT;

} // }}}

void f_drop(){ // {{{

TRACE("DROP");

pop();

NEXT;

} // }}}

void f_swap() { // {{{

TRACE("SWAP");

CELL_t a=pop();

CELL_t b=pop();

push(a);

push(b);

NEXT;

} // }}}

void f_xor(){ // {{{

TRACE("XOR");

push(pop()^pop());

NEXT;

} // }}}

void f_or(){ // {{{

TRACE("OR");

push(pop()|pop());

NEXT;

} // }}}

void f_and(){ // {{{

TRACE("AND");

push(pop()&pop());

NEXT;

} // }}}

void f_Lor(){ // {{{

TRACE("LOR");

CELL_t a=pop();

CELL_t b=pop();

push((a||b)?F_TRUE:F_FALSE);

NEXT;

} // }}}

void f_Land(){ // {{{

TRACE("LAND");

CELL_t a=pop();

CELL_t b=pop();

push((a&&b)?F_TRUE:F_FALSE);

NEXT;

} // }}}

void f_plus(){ // {{{

TRACE("+");

push(pop()+pop());

NEXT;

} // }}}

void f_minus(){ // {{{

TRACE("-");

CELL_t c=pop();

push(pop()-c);

NEXT;

} // }}}

void f_times() { // {{{

TRACE("*");

push(pop()*pop());

NEXT;

} // }}}

void f_div() { // {{{

TRACE("/");

CELL_t a=pop();

push(pop()/a);

NEXT;

} // }}}

void f_div2() { // {{{

TRACE("/2");

push(pop()/2);

NEXT;

} // }}}

void f_div4() { // {{{

TRACE("/4");

push(pop()/4);

NEXT;

} // }}}

void f_dup_D() { // {{{

TRACE("DUP2");

push2(peek2());

NEXT;

} // }}}

void f_dup_3() { // {{{

TRACE("DUP3");

push2(peek2X(1));

push(peekX(2));

NEXT;

} // }}}

void f_dup_4() { // {{{

TRACE("DUP4");

push2(peek2X(2));

push2(peek2X(2));

NEXT;

} // }}}

void f_rdrop() { // {{{ // Drop from Rstack

TRACE("RDROP");

Rpop();

NEXT;

} // }}}

void f_drop_D() { // {{{

TRACE("DROP2");

pop2();

NEXT;

} // }}}

void f_swap_D() { // {{{

TRACE("SWAP2");

DOUBLE_t a=pop2();

DOUBLE_t b=pop2();

push2(a);

push2(b);

NEXT;

} // }}}

void f_swap_12() { // {{{ // ( c d -- d c )

TRACE("SWAP12");

DOUBLE_t d=pop2();

CELL_t c=pop();

push2(d);

push(c);

NEXT;

} // }}}

void f_swap_21() { // {{{ // ( d c -- c d )

TRACE("SWAP21");

CELL_t c=pop();

DOUBLE_t d=pop2();

push(c);

push2(d);

NEXT;

} // }}}

void f_plus_D() { // {{{

TRACE("+D");

push2(pop2()+pop2());

NEXT;

} // }}}

void f_minus_D() { // {{{

TRACE("-D");

DOUBLE_t c=pop2();

push2(pop2()-c);

NEXT;

} // }}}

void f_times_D() { // {{{

TRACE("*D");

push2(pop2()*pop2());

NEXT;

} // }}}

void f_div_D() { // {{{

TRACE("/D");

DOUBLE_t a=pop2();

push2(pop2()/a);

NEXT;

} // }}}

void f_div2_D() { // {{{

TRACE("/2D");

push2(pop2()/2);

NEXT;

} // }}}

void f_div4_D() { // {{{

TRACE("/4D");

push2(pop2()/4);

NEXT;

} // }}}

void f_plus21() { // {{{

TRACE("+21");

CELL_t c=pop();

DOUBLE_t d=pop2();

push2(d+c);

NEXT;

} // }}}

void f_minus21() { // {{{

TRACE("-21");

CELL_t c=pop();

DOUBLE_t d=pop2();

push2(d-c);

NEXT;

} // }}}

void f_times21() { // {{{

TRACE("*21");

CELL_t c=pop();

DOUBLE_t d=pop2();

push2(d*c);

NEXT;

} // }}}

void f_div21() { // {{{

TRACE("/21");

CELL_t c=pop();

DOUBLE_t d=pop2();

push2(d/c);

NEXT;

} // }}}

void f_c2C() { // {{{ ; cell -> 2 C

TRACE("c2C");

CELL_t c=pop();

push((c>>8)&0xFF);

push(c&0xFF);

NEXT;

} // }}}

void f_D4C() { // {{{ ; Double -> 4C

TRACE("D4C");

DOUBLE_t d=pop2();

push((d>>24)&0xFF);

push((d>>16)&0xFF);

push((d>>8)&0xFF);

push(d&0xFF);

NEXT;

} // }}}

void f_2Cc() { // {{{ ; 2 C -> cell

TRACE("2Cc");

CELL_t c=pop();

push((pop()<<8)+c);

NEXT;

} // }}}

void f_4CD() { // {{{ ; 4 C -> Double

TRACE("4CD");

DOUBLE_t d=pop();

d+=pop()*0x100;

d+=pop()*0x10000;

d+=pop()*0x1000000;

push2(d);

NEXT;

} // }}}

void f_1minus() { // {{{ ; decrement TOS by 1

TRACE("1-");

stck[stack-1]--;

NEXT;

} // }}}

void f_4minus() { // {{{ ; decrement TOS by 4

TRACE("4-");

stck[stack-1]-=4;

NEXT;

} // }}}

void f_1Dminus() { // {{{ // decrement Double TOS by 1

TRACE("1D-");

push2(pop2()-1);

NEXT;

} // }}}

void f_4Dminus() { // {{{ // decrement Double TOS by 4

TRACE("4D-");

push2(pop2()-4);

NEXT;

} // }}}

void f_1plus() { // {{{ // increment TOS by 1

TRACE("1+");

push(pop()+1);

NEXT;

} // }}}

void f_4plus() { // {{{ // increment TOS by 4

TRACE("4+");

push(pop()+4);

NEXT;

} // }}}

void f_1Dplus() { // {{{ // increment Double TOS by 1

TRACE("1D+");

push2(pop2()+1);

NEXT;

} // }}}

void f_4Dplus() { // {{{ // increment Double TOS by 4

TRACE("4D+");

push2(pop2()+4);

NEXT;

} // }}}

void f_Store(){ // {{{ ! ( cell Daddr -- ) store cell at address(Double)

TRACE("!");

DOUBLE_t d=pop2();

#ifdef PEDANT

if (! is_in_Wrange(d)) { do_traceback(); ERROR("Not in range");return;};

#endif

*(CELL_t*)B3PTR(d)=pop();

NEXT;

} // }}}

void f_StoreChar(){ // {{{ !C ( char Daddr -- ) store char at address(Double)

TRACE("!C");

DOUBLE_t d=pop2();

uint8_t v=pop();

#ifdef PEDANT

if (! is_in_Wrange(d)) { do_traceback(); ERROR("Not in range");return;};

#endif

*(uint8_t*)B3PTR(d)=v;

NEXT;

} // }}}

void f_StoreDouble(){ // {{{ !D ( D Daddr -- ) store Double at address(Double)

TRACE("!D");

DOUBLE_t d=pop2();

#ifdef PEDANT

if (! is_in_Wrange(d)) { do_traceback(); ERROR("Not in range");return;};

#endif

*(uint32_t*)B3PTR(d)=pop2();

NEXT;

} // }}}

void f_At(){ // {{{ @ ( Daddr -- cell ) cell at address(Double)

TRACE("@");

DOUBLE_t d=pop2();

#ifdef PEDANT

if (! is_in_range(d)) { do_traceback(); ERROR("Not in range");return;};

#endif

push(B2at(d));

NEXT;

} // }}}

void f_CharAt(){ // {{{ C@ ( Daddr -- char ) char at address(Double)

TRACE("C@");

DOUBLE_t d=pop2();

#ifdef PEDANT

if (! is_in_range(d)) { do_traceback(); ERROR("Not in range");return;};

#endif

push(B2at(d)&0xFF);

NEXT;

} // }}}

void f_DoubleAt(){ // {{{ D@ ( Daddr -- D ) Double at address(Double)

TRACE("D@");

DOUBLE_t d=pop2();

#ifdef PEDANT

if (! is_in_range(d)) { do_traceback(); ERROR("Not in range");return;};

#endif

push2(B4at(d));

NEXT;

} // }}}

void f_ToR() { // {{{ // ( u -- ; R: -- r ) Move to Rstack

TRACE(">R");

Rpush(pop());

NEXT;

} // }}}

void f_DoubleToR() { // {{{ // ( D -- ; R: -- r ) Move Double to Rstack (still one position on R)

TRACE("D>R");

Rpush(pop2());

NEXT;

} // }}}

void f_FromR() { // {{{ // ( -- u ; R: r -- ) Move from Rstack

TRACE("R>");

push(Rpop());

NEXT;

} // }}}

void f_DoubleFromR() { // {{{ // ( -- D ; R: r -- ) Move Double from Rstack (still one position on R)

TRACE("R>D");

push2(Rpop());

NEXT;

} // }}}

void f_CellAtR() { // {{{ // ( -- u ; R: r -- r ) Peek from Rstack

TRACE("@R");

push(Rpeek());

NEXT;

} // }}}

void f_DoubleAtR() { // {{{ // ( -- D ; R: r -- r ) Peek from Rstack

TRACE("D@R");

push2(Rpeek());

NEXT;

} // }}}

void f_StackAddress() { // {{{ // ( -- D ) Address, where Stack points

TRACE("S?");

push2(B3U32(&stck[stack]));

NEXT;

} // }}}

void f_SetStack() { // {{{ // ( D -- ?? ) Set Stack Address

TRACE("S!");

int32_t S=pop2()-B3U32(&stck[0]);

if ((S<0) || (S>STACK_LEN*sizeof(stck[0]))) { ERROR("Out of stack area"); NEXT; return;};

int32_t s=S/sizeof(stck[0]);

if (s*sizeof(stck[0]) != S) { ERROR("Bad alligned stack"); NEXT; return;};

stack=s;

NEXT;

} // }}}

void f_RStackAddress() { // {{{ // ( -- D ) Address, where Rstack points

TRACE("R?");

push2(B3U32(&Rstck[Rstack]));

NEXT;

} // }}}

void f_SetRStack() { // {{{ // ( D -- R: ?? ) Set Rstack Address

TRACE("R!");

int32_t S=pop2()-B3U32(&Rstck[0]);

if ((S<0) || (S>RSTACK_LEN*sizeof(Rstck[0]))) { ERROR("Out of Rstack area"); NEXT; return;};

int32_t s=S/sizeof(Rstck[0]);

if (s*sizeof(Rstck[0]) != S) { ERROR("Bad alligned Rstack"); NEXT; return;};

Rstack=s;

NEXT;

} // }}}

void f_hex(){ // {{{

TRACE("hex");

BASE=16;

NEXT;

} // }}}

void f_dec(){ // {{{

TRACE("dec");

BASE=10;

NEXT;

} // }}}

void f_bin(){ // {{{

TRACE("bin");

BASE=2;

NEXT;

} // }}}

// }}}

DOUBLE_t cw2h(DOUBLE_t cw) { // {{{ codeword address to head address

// TRACE("cw2h");

if ( ! (

( (B3U32(&w_firtsbuildinword_head) <= cw) && ( cw < B3U32(&w_lastbuildinword_end)) ) ||

( (B3U32(&RAM[0]) <= cw) && ( cw < HERE ) )

) ) { return 0; };

if (!cw) return 0;

if (!is_in_range(cw)) return 0;

uint8_t i =0;

cw--;

while ((i<33 ) && (i!=B1at(cw))) {i++;cw--;};

if (i<33) return cw-5;

return 0;

} // }}}

void f_cw2h() { // {{{ ; ( cw -- h ) convert codeword address to head address

TRACE("f_cw2h");

push2(cw2h(pop2()));

NEXT;

} // }}}

DOUBLE_t h2cw(DOUBLE_t h) { // {{{ convert head address to codeword address

h+=5;

h+=1+B1at(h);

return h;

} // }}}

void f_h2cw() { // {{{ // ( h -- cw ) convert head address to codeword address

TRACE("h2cw");

push2(h2cw(pop2()));

NEXT;

} // }}}

void f_h2da() { // {{{ // ( h -- da ) convert head address to data address

TRACE("h2da");

push2(h2cw(pop2())+4);

NEXT;

} // }}}

bool get_bounds_of_word(DOUBLE_t addr,DOUBLE_t *start, DOUBLE_t *stop) { // {{{ // Find word at addr and returns start&stop, or false

*start=LAST;

*stop=HERE;

// printf("get_bounds_of_word(0x%08x, 0x%p -> 0x%08x, 0x%p -> 0x%08x)\n",addr, start, *start,stop,*stop);

while (*start) {

// printf("get_bounds_of_word loop( 0x%p -> 0x%08x, 0x%p -> 0x%08x)\n", start, *start,stop,*stop);

if ( (*start<=addr) && (addr<*stop)) {

uint8_t len=B1at(*start+5);

// printf("len: %d\n",len);

if (len>31) return false; // misformed word

(*stop)-=4;

return true;

};

*stop=*start;

*start=B4at(*start);

};

// printf("end\n");

return false;

} // }}}

uint8_t name_to_buf(DOUBLE_t cw) { // {{{ fill name into global buf codeword - return flags

DOUBLE_t h=cw2h(cw);

if (!h) {ERROR("Not a word");strcpy_P(buf,F(" Not a word "));return 0;};

uint8_t flags,len;

flags=B1at(h+4);

len=B1at(h+5);

uint8_t i=0;

for (; i<len;i++) buf[i]=B1at(h+6+i);

buf[i]=0;

return flags;

} // }}}

#if defined(__PC__)

void f_memdump() { // {{{ // ( daddr len -- ) dump data to file

INFO("memdump");

DOUBLE_t addr2=pop2();

DOUBLE_t addr=pop2();

const char *fname = "._dump.bin";

memdump(addr,addr2-addr,fname);

NEXT;

} // }}}

void file_do_export(FILE *f, DOUBLE_t h, DOUBLE_t top) { // {{{

DOUBLE_t cw=h2cw(h);

DOUBLE_t val;

uint8_t flags;

if (!h) {fprintf(f," Not a word ");return;};

fprintf(f, ": ");

flags = name_to_buf(cw);

fprintf(f,"%s",buf);

if (val_of_f_docol != B3at(cw)) {

fprintf(f," NOT_DOCOL definition ");

return; // neumim rozepsat

};

do {

cw+=4;

val=B4at(cw);

// if (val == val_of_w_exit_cw) break;

fprintf(f," ");

flags = name_to_buf(val);

fprintf(f,"%s",buf);

if (flags & FLG_ARG) {

cw+=4;

val=B4at(cw);

fprintf(f," ");

DOUBLE_t h1, h2;

if ( get_bounds_of_word(val, &h1, &h2)) { // it MAY be word

if (h2cw(h1)==val) { // it points to cw of existing word

name_to_buf(val);

fprintf(f,"%s ( 0x%08x )",buf,val);

} else {

fprintf(f,"\\'0x%08x ", val);

};

} else {

fprintf(f,"\\'0x%08x ", val);

};

val=0;

}

else if ((flags & FLG_PSTRING) && (B4at(cw+4)<128)) { // too long strings probabely are not arguments

cw+=4;

val=B4at(cw);

fprintf(f," \\'0x%08x", val);

cw+=4;

fprintf(f," \\\"");

while (val--) fprintf(f,"%c",B1at(cw++));

fprintf(f,"\"" );

cw-=4; // we are already at next pos, but loop will add 4 anyway

val=0;

};

} while (cw < top);

} // }}}

void traceback_word(FILE *f, uint16_t depth, DOUBLE_t addr) { // {{{ // Find word and dump actual position in it

for (int8_t d=0;d<=depth;d++) fprintf(f,"\t");

fprintf(f,"0x%08x .. ",addr);

fflush(f);

DOUBLE_t start,stop;

if (get_bounds_of_word(addr,&start,&stop)) {

uint8_t len=B1at(start+5);

for (int8_t i=0;i<len; i++) fprintf(f,"%c",B1at(start+6+i));

fprintf(f," : at data+%d :", (addr-start-10-len));

fflush(f);

file_do_export(f, start, addr);

fprintf(f,"\n");

} else {

fprintf(f,"NOT A WORD, maybe value? %d\n", addr);

};

} // }}}

#ifndef min

#define min(a,b) (((a) < (b)) ? (a) : (b))

#endif

void do_traceback(){ // {{{ dump traceback data to file

FILE *f = fopen("._traceback.log","a");

if (!f) {

perror("fopen");

return;

};

fprintf(f,"\n\n\n<==== traceback ====>\n");

fprintf(f,"IP=0x%08x\nStack (depth: %d) :",IP,stack);

for (int8_t p=0;p<stack;p++) fprintf(f,"[%04x]",stck[p]);

fprintf(f,"\t\t\t and maybe ");

for (int8_t p=0;p<min(STACK_LEN-stack,8);p++) fprintf(f,"[%04x]",stck[stack+p]);

fprintf(f,"\nRStack (depth: %d) :",Rstack);

for (int8_t p=0;p<Rstack;p++) fprintf(f,"[%08x]",Rstck[p]);

fprintf(f,"\t\t\t and maybe ");

for (int8_t p=0;p<min(RSTACK_LEN-Rstack,8);p++) fprintf(f,"[%04x]",Rstck[Rstack+p]);

fprintf(f,"\nRAM: 0x%08x, HERE: 0x%08x, LAST:0x%08x\n",B3U32(RAM),HERE,LAST);

fprintf(f,"\n <==== analyze ====>\n");

fflush(f);

for (int8_t p=0;p<Rstack;p++) traceback_word(f,p,Rstck[p]-4);

traceback_word(f,Rstack+1,IP-4);

fprintf(f,"\n <==== analyze end ====>\n\n\n");

fclose(f);

return;

} // }}}

void f_traceback() { // {{{ // ( -- ) dump traceback data to file

INFO("traceback");

do_traceback();

NEXT;

} // }}}

#endif

uint8_t show_name(DOUBLE_t cw, DOUBLE_t orig) { // {{{ show name and address from codeword - return flags

DEBUG_DUMP(cw,"cw\t");

DOUBLE_t h=cw2h(cw);

if (!h) {ERROR("Not a word");return 0;};

uint8_t flags,len;

flags=B1at(h+4);

len=B1at(h+5);

if (flags & FLG_HIDDEN) write_str(F("HIDDEN "));

// if (flags & FLG_IMMEDIATE) write_str(F("IMMEDIATE "));

// if (flags & FLG_ARG) write_str(F("ARG "));

// write_str(F("len: "));write_hex8(len);write_str(F(", name: "));

write_str(F(STR_2LESS));

for (uint8_t i=0; i<len;i++) write_char(B1at(h+6+i));