/*
  C BASED FORTH-83 MULTI-TASKING KERNEL DEFINITIONS

  Copyright (C) 1988-1990 by Mikael R.K. Patel

*/


/* INCLUDED SYSTEM FUNCTIONS */

#include <strings.h>


/* TYPING SYSTEM AND MISC. STRING MACROS */

#define VOID void

typedef char*  PTR8;
typedef short* PTR16;
typedef long*  PTR32;

typedef VOID (*SUBR)();

#define NIL 0

typedef long BOOL;

#define TRUE  ((BOOL) -1)
#define FALSE ((BOOL)  0)

typedef unsigned       NUM;
typedef unsigned char  NUM8;
typedef unsigned short NUM16;
typedef unsigned long  NUM32;

typedef int   INT;
typedef char  INT8;
typedef short INT16;
typedef long  INT32;

typedef float  FLOAT32;
typedef double FLOAT64;

typedef char  CHAR;
typedef char* CSTR;
typedef char* PSTR;

#define STREQ(s1, s2) ((*(CSTR) s1 == *(CSTR) s2) && \
		       (*(CSTR) s1 + 1 == *(CSTR) s2 + 1) && \
		       !(strcmp((CSTR) s1, (CSTR) s2)))


/* QUEUE DEFINITION */

typedef struct _queue {
    struct _queue *succ, *pred;
} queue, *QUEUE;


/* TASK DEFINITION */

typedef struct {
    queue queue;
    INT32 status;
    PTR32 sp;
    PTR32 s0;
    PTR32 ip;
    PTR32 rp;
    PTR32 r0;
    PTR32 fp;
    PTR32 ep;
} task_header;

typedef struct {
    queue queue;
    INT32 status;
    PTR32 sp;
    PTR32 s0;
    PTR32 ip;
    PTR32 rp;
    PTR32 r0;
    PTR32 fp;
    PTR32 ep;
    INT32 users[1];
} task, *TASK;


/* TASK STATUS FIELD VALUES: ENUMERATE */

#define TERMINATED 0
#define READY      1
#define RUNNING    2
#define IOWAITING  3
#define WAITING    4
#define DELAYED    5


/* VOCABULARY ENTRY DEFINITION, TYPES, AND MODES */

typedef struct _entry {
    struct _entry *link;
    CSTR  name;
    INT32 mode;
    INT32 code;
    INT32 parameter;
} entry, *ENTRY;


/* ENTRY MODE VALUES: SET */

#define NORMAL      0
#define IMMEDIATE   1
#define EXECUTION   2
#define COMPILATION 4
#define HIDDEN      6
#define PRIVATE     8


/* ENTRY CODE VALUES: ENUMERATES */

#define CODE       0
#define COLON      1
#define VARIABLE   2
#define CONSTANT   3
#define VOCABULARY 4
#define CREATE     5
#define USER       6
#define LOCAL      7
#define FORWARD    8
#define FIELD      9
#define EXCEPTION  10


/* ENTRY VISIBILITY MACRO */

#define visible(e, v) \
    (!(((e -> mode & COMPILATION) && (!state.parameter)) || \
       ((e -> mode & EXECUTION) && (state.parameter))  || \
       ((e -> mode & PRIVATE) && (v != current))))


/* NORMAL ENTRY GENERATORS */

#define NORMAL_CONSTANT(v, l, n, p) \
    static entry v = \
       {(ENTRY) &l, n, NORMAL, CONSTANT, p};

#define NORMAL_VARIABLE(v, l, n, p) \
    static entry v = \
       {(ENTRY) &l, n, NORMAL, VARIABLE, p};


/* VOCABULARY ENTRY DEFINITION */

typedef struct {
    ENTRY link;
    CSTR  name;
    INT32 mode;
    INT32 code;
    ENTRY last;
    ENTRY recognizer;
} vocabulary_entry, *VOCABULARY_ENTRY;

#define NORMAL_VOCABULARY(v, l, n, p, r) \
    static vocabulary_entry v = \
       {(ENTRY) &l, n, NORMAL, VOCABULARY, (ENTRY) p, (ENTRY) r};


/* CODE ENTRY DEFINITION */

typedef struct {
    ENTRY link;
    CSTR name;
    INT32 mode;
    INT32 code;
    SUBR subr;
} code_entry, *CODE_ENTRY;


#define NORMAL_CODE(v, l, n, s) \
    static code_entry v = \
       {(ENTRY) &l, n, NORMAL, CODE, s};

#define IMMEDIATE_CODE(v, l, n, s) \
    static code_entry v = \
       {(ENTRY) &l, n, IMMEDIATE, CODE, s};

#define COMPILATION_CODE(v, l, n, s) \
    static code_entry v = \
       {(ENTRY) &l, n, COMPILATION, CODE, s};

#define EXECUTION_CODE(v, l, n, s) \
    static code_entry v = \
       {(ENTRY) &l, n, EXECUTION, CODE, s};

#define COMPILATION_IMMEDIATE_CODE(v, l, n, s) \
    static code_entry v = \
       {(ENTRY) &l, n, COMPILATION + IMMEDIATE, CODE, s};


/* UNIVERSAL VALUE */

typedef union {
    BOOL             BOOL;
    NUM32            NUM32;
    INT32            INT32;
    FLOAT32          FLOAT32;
    CSTR             CSTR;
    PTR8             PTR8;
    PTR16            PTR16;
    PTR32            PTR32;
    SUBR             SUBR;
    QUEUE            QUEUE;
    TASK             TASK;
    ENTRY            ENTRY;
    CODE_ENTRY       CODE_ENTRY;
    VOCABULARY_ENTRY VOCABULARY_ENTRY;
} UNIV, *PTR;


/* STACK MACROS */

#define sinit() sp = s0
#define spop(t) tos.t; tos = *sp++
#define spush(e, t) *(--sp) = tos; tos.t = e
#define snth(n) sp[n]
#define sdrop() tos = *sp++
#define sndrop(n) sp += (n); tos = *sp++
#define snip() sp++
#define sdup() *(--sp) = tos
#define sover() { register UNIV t; t = *sp; *(--sp) = tos; tos = t; }
#define stuck() { register UNIV t; t = *sp; *sp = tos; *(--sp) = t; }
#define sswap() { register UNIV t; t = tos; tos = sp[0]; sp[0] = t; }
#define srot()  { register UNIV t; t = tos; tos = sp[1]; sp[1] = sp[0]; sp[0] = t; }
#define sdashrot() { register UNIV t; t = tos; tos = sp[0]; sp[0] = sp[1]; sp[1] = t; }

#define coerce(f, t) tos.t = (t) tos.f
#define unary(o, t) tos.t = o tos.t
#define binary(o, t) tos.t = sp++ -> t o tos.t
#define compare(o, t) tos.BOOL = (tos.t o ? TRUE : FALSE)
#define relation(o, t) tos.INT32 = (sp++ -> t o tos.t ? TRUE : FALSE)

#define rinit() rp = r0
#define rpop() *rp++
#define rpush(e) *(--rp) = (INT32) e
#define rnth(n) rp[n]
#define rndrop(n) rp += n    


/* THREADING ALIGNMENT MACRO */

#define align(p) p = (PTR32) ((INT32) ((PTR8) p + 3) & -4)


/* THREADED BRANCH, RETURN MACRO */

#define fskip() ip++
#define fbranch(d) ip = (PTR32) ((PTR8) ip + (d))
#define fjump(a) ip = (PTR32) (a)
#define fsemicolon() fjump(rpop())
#define fdoes() current -> last -> code = (INT32) ip; fsemicolon()


/* ARGUMENT AND LOCAL VARIABLE FRAME MACRO */

#define flink() \
{ \
    spush(fp, PTR32); \
    fp = (PTR32) sp + *ip++; \
    sp = sp - *ip++; \
    rpush(sp); \
} 

#define funlink() \
{ \
    register PTR32 t; \
    register PTR32 s; \
    t = (PTR32) rpop(); \
    if (t == (PTR32) sp) { \
	sp = (PTR) fp; \
	fp = tos.PTR32; \
	sdrop(); \
    } \
    else { \
	s = fp; \
	fp = (PTR32) *--t; \
	while (t > (PTR32) sp) *--s = *--t; \
	sp = (PTR) s; \
    } \
}    

#define fcatch() \
{ \
    PTR32 body; \
    body = spop(PTR32); \
    rpush(tos.INT32); \
    rpush(sp); \
    rpush(ip); \
    rpush(fp); \
    rpush(ep); \
    ep = rp; \
    fjump(body); \
}

#define fthrow() \
{ \
    ep = (PTR32) rpop(); \
    rndrop(4); \
    fsemicolon() ; \
}
    
/* EXTERN FORWARD DECLARATIONS */

extern INT32 verbose;
extern INT32 quited;
extern INT32 running;
extern INT32 tasking;

extern TASK tp;
extern TASK foreground;

extern UNIV tos;
extern PTR  sp;
extern PTR  s0;

extern PTR32 ip;
extern PTR32 rp;
extern PTR32 r0;

extern PTR32 fp;
extern PTR32 ep;

extern PTR32 dictionary;
extern PTR32 dp;

extern vocabulary_entry forth;

TASK  make_task();
ENTRY make_entry();

VOID kernel_initiate();
VOID kernel_finish();

VOID doinner();
VOID docommand();
VOID docall();
VOID doappend();

  
/* COMPILER EXTENSIONS */

VOID doparenbranch();
VOID doparenqbranch();
VOID doparendo();
VOID doparenqdo();
VOID doparenloop();
VOID doparenplusloop();
VOID doparenliteral();
VOID doparendotquote();
VOID doparenabortquote();
VOID doparensemicolon();
VOID doparendoes();
VOID dothread();
VOID dounthread();
VOID doforwardmark();
VOID dobackwardmark();
VOID doforwardresolve();
VOID dobackwardresolve();


/* LOCAL VARIABLES AND ARGUMENT BINDING */

VOID dounlinklocals();
VOID doparenlink()  ;
VOID doparenunlink()  ;
VOID doparenunlinksemicolon() ;
VOID doparenunlinkdoes();
VOID doparenlocal();
VOID doparenlocalstore();
VOID doparenlocalfetch();
VOID doassignlocal();
VOID dolocalreturn();
VOID docurlebracket();


/* NULL TERMINATED STRING */

VOID doparenquote();
VOID doquote();
VOID doslength();
VOID dosdup();
VOID dosequal();
VOID doscompare();
VOID doscat();
VOID dosprint();


/* FLOATING POINT NUMBERS */

VOID doitof();
VOID doftoi();
VOID dofplus();
VOID dofminus();
VOID doftimes();
VOID dofdivide();
VOID dofonedivide();
VOID dofnegate();
VOID dofdot();
VOID doqfloat();


/* MEMORY MANAGEMENT */

VOID domalloc();
VOID dorealloc();
VOID dofree();


/* DOUBLE LINKED LISTS */

VOID doqemptyqueue();
VOID doenqueue();
VOID dodequeue();


/* MULTI-TASKING EXTENSIONS */

VOID douser();
VOID dotask();
VOID dofork();
VOID doresume();
VOID doschedule();
VOID dodetach();
VOID doterminate();


/* SIGNAL AND EXCEPTION MANAGEMENT */

VOID donewexception();
VOID doparenexceptionsemicolon();
VOID doparenexceptionunlinksemicolon();
VOID doparenexception();
VOID doexception();
VOID doraise();


/* KERNEL VOCABULARY */

VOID doboolean();
VOID donot();
VOID doand();
VOID door();
VOID doxor();
VOID doqwithin();

VOID dodepth();
VOID dodrop();
VOID donip();
VOID doswap();
VOID dorot();
VOID dodashrot();
VOID doroll();
VOID doqdup();
VOID dodup();
VOID doover();
VOID dotuck();

VOID dotor();
VOID dofromr();
VOID docopyr();

VOID dotwotor();
VOID dotwofromr();
VOID dotwodrop();
VOID dotwoswap();
VOID dotworot();
VOID dotwodup();
VOID dotwoover();

VOID dolessthan();
VOID doequals();
VOID dogreaterthan();
VOID dozeroless();
VOID dozeroequals();
VOID dozerogreater();
VOID doulessthan();

VOID doplus();
VOID dominus();
VOID dooneplus();
VOID dooneminus();
VOID dotwoplus();
VOID dotwominus();
VOID dotwotimes();
VOID doleftshift();
VOID dotimes();
VOID doumtimes();
VOID doumdividemod();
VOID dotwodivide();
VOID dorightshift();
VOID dodivide();
VOID domod();
VOID dodividemod();
VOID dotimesdividemod();
VOID dotimesdivide();
VOID domin();
VOID domax();
VOID doabs();
VOID donegate();

VOID dofetch();
VOID dostore();
VOID dowfetch();
VOID dolesswfetch();
VOID dowstore();
VOID docfetch();
VOID doclessfetch();
VOID docstore();
VOID doffetch();
VOID dolessffetch();
VOID dofstore();
VOID dobfetch();
VOID dobstore();
VOID dotwostore();
VOID dotwofetch();
VOID doplusstore();

VOID docmove();
VOID docmoveup();
VOID dofill();
VOID docount();
VOID dobounds();
VOID dodashtrailing();
VOID dodashmatch();

VOID dobinary();
VOID dooctal();
VOID dodecimal();
VOID dohex();
VOID doconvert();
VOID dolesssharp();
VOID dosharp();
VOID dosharps();
VOID dohold();
VOID dosign();
VOID dosharpgreater();
VOID doqnumber();

VOID dodo();
VOID doqdo();
VOID doloop();
VOID doplusloop();
VOID doleave();
VOID doi();
VOID doj();
VOID doif();
VOID doelse();
VOID dothen();
VOID docase();
VOID doof();
VOID doendof();
VOID doendcase();
VOID dobegin();
VOID dountil();
VOID dowhile();
VOID dorepeat();
VOID doagain();
VOID dorecurse();
VOID dotailrecurse();
VOID doexit();
VOID doexecute();
VOID dobye();

VOID dodot();
VOID dodotr();
VOID doudot();
VOID doudotr();
VOID doascii();
VOID dodotquote();
VOID dodotparen();
VOID dodots();
VOID docr();
VOID doemit();
VOID dotype();
VOID dospace();
VOID dospaces();

VOID dokey();
VOID doexpect();
VOID doline();
VOID dosource();

VOID doforth83();
VOID dointerpret();
VOID doquit();
VOID doabort();
VOID doabortquote();

VOID dohere();
VOID dotobody();
VOID dodotname();
VOID docells();
VOID docellplus();
VOID dosharpif();
VOID dosharpelse();
VOID dosharpthen();
VOID dosharpifdef();
VOID dosharpifundef();
VOID dosharpinclude();
VOID dosharppath();
VOID doparen();
VOID dobackslash();

VOID docomma();
VOID doallot();
VOID doalign();
VOID dodoes();
VOID doimmediate();
VOID doexecution();
VOID docompilation();
VOID doprivate();
VOID dorecognizer();
VOID dobracketcompile();
VOID docompile();
VOID doqcompile();
VOID docompiling();
VOID doliteral();
VOID doleftbracket();
VOID dorightbracket();
VOID doword();

VOID dolast();
VOID dodefinitions();
VOID doonly();
VOID doseal();
VOID dorestore();
VOID dotick();
VOID dobrackettick();
VOID dolookup() ;
VOID dofind();
VOID dorecognize();
VOID doforget();
VOID dowords();
VOID doentry();
VOID doforward();
VOID docode();
VOID docolon();
VOID dosemicolon();
VOID docreate();
VOID dovariable();
VOID doconstant();
VOID dovocabulary();
VOID dofield();

#ifdef PROFILE
VOID docollision();
#endif
