/*
 * Portable Forth interpreter.
 * Copyright (C) 1990-2012 Serge Vakulenko, <serge@vak.ru>
 *
 * Permission to use, copy, modify, and distribute this software
 * and its documentation for any purpose and without fee is hereby
 * granted, provided that the above copyright notice appear in all
 * copies and that both that the copyright notice and this
 * permission notice and warranty disclaimer appear in supporting
 * documentation, and that the name of the author not be used in
 * advertising or publicity pertaining to distribution of the
 * software without specific, written prior permission.
 *
 * The author disclaim all warranties with regard to this
 * software, including all implied warranties of merchantability
 * and fitness.  In no event shall the author be liable for any
 * special, indirect or consequential damages or any damages
 * whatsoever resulting from loss of use, data or profits, whether
 * in an action of contract, negligence or other tortious action,
 * arising out of or in connection with the use or performance of
 * this software.
 */
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <stdarg.h>
#include "io.h"
#include "forth.h"

#define OKPROMPT        "Ok\n> "
#define ERRPROMPT       "> "
#define COMPILEPROMPT   ": "

value_t     defbuf [DEFSZ];
value_t     *defptr;

value_t     *execstack [NESTSZ];
value_t     *execptr;
int         execcnt;

struct loop loopstack [LOOPSZ];
struct loop *loopptr;

union memory memory;
integer_t   here = 0;
integer_t   lowmem;

integer_t   stack [STACKSZ];
integer_t   *stackptr;

jmp_buf     errjmp;

ident_t     dict [DICTSZ];
ident_t     *dictptr;
ident_t     *lowdictptr;

int         outstack [OUTSZ];
int         outptr;
int         instack [INSZ];
int         inptr;

integer_t   compindex;
integer_t   baseindex;
integer_t   spanindex;
integer_t   hldindex;

int         tty;
int         debug;
int         boln;
int         errorflag;

value_t     _x;

void forthresume (int clrflag)
{
    errorflag = 1;
    if (clrflag)
        stackptr = stack;
    longjmp (errjmp, 1);
}

void error (char *fmt, ...)
{
    va_list ap;

    va_start (ap, fmt);
    vprintf (fmt, ap);
    va_end (ap);
    printf ("\n");
    forthresume (1);
}

void usage ()
{
    printf ("Usage: forth [-d] [files...]\n");
    exit (1);
}

void initdict ()
{
    struct table *t;
    ident_t *w;

    dictptr = dict;
    for (t=func_table; t->name; ++t, ++dictptr) {
        strncpy (dictptr->name, t->name, NAMESZ);
        dictptr->name [NAMESZ-1] = 0;
        dictptr->type = t->type;
        dictptr->val.p = t->func;
        dictptr->immed = t->immed;
    }

    w = enter ("bl");
    ++dictptr;
    w->type = FGENINT;
    w->val.i = ' ';

    w = enter ("pad");
    ++dictptr;
    w->type = FGENINT;
    w->val.i = pad;

    lowmem = here;

    compindex = alloc ((integer_t) 1);
    w = enter ("state");
    ++dictptr;
    w->type = FGENINT;
    w->val.i = compindex;

    baseindex = alloc ((integer_t) 1);
    w = enter ("base");
    ++dictptr;
    w->type = FGENINT;
    w->val.i = baseindex;

    spanindex = alloc ((integer_t) 1);
    w = enter ("span");
    ++dictptr;
    w->type = FGENINT;
    w->val.i = spanindex;

    hldindex = alloc ((integer_t) 1);
    w = enter ("hld");
    ++dictptr;
    w->type = FGENINT;
    w->val.i = hldindex;

    lowdictptr = dictptr;
}

void scompile (ident_t *w)
{
    (defptr++)->i = w->type;
    switch (w->type) {
    case FGENINT:
    case FGENFLT:
    case FSUBR:
    case FHARDWARE:
        *defptr++ = w->val;
        break;
    }
}

void sexecute (ident_t *w)
{
    if (w >= dictptr)
        error ("bad execute");
    switch (w->type) {
    case FGENINT:
        push (w->val.i);
        break;
    case FGENFLT:
        fpush (w->val.r);
        break;
    case FSUBR:
        execute (w->val.v);
        break;
    case FHARDWARE:
        (*w->val.p) ();
        break;
    default:
        error ("%s ?", w->name);
    }
}

int valsize (value_t *a)
{
    switch (a->i) {
    default:        return (1);
    case FGENINT:
    case FGENFLT:
    case FSUBR:
    case FHARDWARE: return (2);
    case FSTRING:
    case FCSTRING:
    case FQUOTE:    return (3 + a[1].i / sizeof (value_t));
    }
}

void run ()
{
    int count;
    integer_t c;
    char *p;

    while (execptr) {
        switch ((execptr++)->i) {
        case FGENINT:
            push ((execptr++)->i);
            continue;
        case FGENFLT:
            fpush ((execptr++)->r);
            continue;
        case FSUBR:
            execute ((execptr++)->v);
            continue;
        case FHARDWARE:
            (*(execptr++)->p) ();
            continue;
        case FSTRING:
        case FCSTRING:
            c = (execptr++)->i;
            p = (char*) execptr++;
            execptr += c / sizeof (value_t);
            for (; *p; ++p)
                putc (*p, stdout);
            break;
        case FQUOTE:
            c = (execptr++)->i;
            p = (char*) execptr++;
            execptr += c / sizeof (value_t);
            push (c = here);
            while (*p)
                STOREBYTE (c++, *p++);
            STOREBYTE (c, 0);
            break;
        case FCONDIF:
            if (pop ())
                continue;
            for (count=0; execptr->i; execptr+=valsize(execptr))
                if (execptr->i == FCONDIF)
                    ++count;
                else if (execptr->i == FCONDTHEN) {
                    if (--count < 0) {
                        ++execptr;
                        break;
                    }
                } else if (execptr->i == FCONDELSE)
                    if (count <= 0) {
                        ++execptr;
                        break;
                    }
            continue;
        case FCONDELSE:
            for (count=0; execptr->i; execptr+=valsize(execptr))
                if (execptr->i == FCONDIF)
                    ++count;
                else if (execptr->i == FCONDTHEN)
                    if (--count < 0) {
                        ++execptr;
                        break;
                    }
            continue;
        case FUNTIL:
            if (loopptr <= loopstack)
                error ("until but no begin");
            if (loopptr[-1].type != FBEGIN)
                error ("bad until");
            if (pop ()) {
                --loopptr;
                continue;
            }
            execptr = loopptr[-1].ptr;
            continue;
        case FREPEAT:
            if (loopptr <= loopstack)
                error ("repeat but no begin");
            if (loopptr[-1].type != FBEGIN)
                error ("bad repeat");
            execptr = loopptr[-1].ptr;
            continue;
        case FWHILE:
            if (pop ())
                continue;
            for (count=0; execptr->i; execptr+=valsize(execptr))
                if (execptr->i == FBEGIN)
                    ++count;
                else if (execptr->i==FUNTIL || execptr->i==FREPEAT)
                    if (--count < 0) {
                        ++execptr;
                        break;
                    }
            continue;
        case FLEAVE:
            if (loopptr <= loopstack)
                error ("bad leave");
leave:                  for (count=0; execptr->i; execptr+=valsize (execptr))
                if (execptr->i==FBEGIN || execptr->i==FDO || execptr->i==FIFDO)
                    ++count;
                else if (execptr->i==FUNTIL || execptr->i==FREPEAT ||
                    execptr->i==FLOOP || execptr->i==FPLOOP)
                    if (--count < 0) {
                        ++execptr;
                        break;
                    }
            --loopptr;
            continue;
        case FDO:
            if (loopptr >= loopstack+LOOPSZ)
                error ("too deep do nesting");
            loopptr->cnt = loopptr->low = pop ();
            loopptr->up = pop ();
            loopptr->type = FDO;
            loopptr->ptr = execptr;
            ++loopptr;
            continue;
        case FIFDO:
            if (loopptr >= loopstack+LOOPSZ)
                error ("too deep ?do nesting");
            loopptr->cnt = loopptr->low = pop ();
            loopptr->up = pop ();
            loopptr->type = FIFDO;
            loopptr->ptr = execptr;
            ++loopptr;
            if (loopptr[-1].low == loopptr[-1].up)
                goto leave;
            continue;
        case FLOOP:
            if (loopptr <= loopstack)
                error ("bad loop");
            if (loopptr[-1].type != FDO && loopptr[-1].type != FIFDO)
                error ("invalid loop");
            ++loopptr[-1].cnt;
            if (loopptr[-1].cnt >= loopptr[-1].up) {
                --loopptr;
                continue;
            }
            execptr = loopptr[-1].ptr;
            continue;
        case FPLOOP:
            if (loopptr <= loopstack)
                error ("bad +loop");
            if (loopptr[-1].type != FDO && loopptr[-1].type != FIFDO)
                error ("invalid loop");
            c = pop ();
            if ((c>0 && loopptr[-1].cnt<loopptr[-1].up &&
                loopptr[-1].cnt+c>=loopptr[-1].up) ||
                (c<0 && loopptr[-1].cnt>=loopptr[-1].up &&
                loopptr[-1].cnt+c<loopptr[-1].up))
            {
                --loopptr;
                continue;
            }
            loopptr[-1].cnt += c;
            execptr = loopptr[-1].ptr;
            continue;
        case FCOUNTI:
            if (loopptr <= loopstack)
                error ("bad i");
            push (loopptr[-1].cnt);
            continue;
        case FCOUNTJ:
            if (loopptr <= loopstack+1)
                error ("bad j");
            push (loopptr[-2].cnt);
            continue;
        case FCOUNTK:
            if (loopptr <= loopstack+2)
                error ("bad k");
            push (loopptr[-3].cnt);
            continue;
        case FBEGIN:
            if (loopptr >= loopstack+LOOPSZ)
                error ("too deep begin nesting");
            loopptr->type = FBEGIN;
            loopptr->ptr = execptr;
            ++loopptr;
            continue;
        case FCONDTHEN:
            continue;
        case FEXIT:
        case 0:
doexit:         --execcnt;
            if (execcnt < 0)
                return;
            execptr = execstack [execcnt];
            continue;
        }
    }
    goto doexit;
}

int symdigit (int c)
{
    c &= 0377;
    switch (base) {
    case BINARY:
        switch (c) {
        case '0': return (0);
        case '1': return (1);
        }
        return (-1);
    case OCTAL:
        switch (c) {
        case '0': case '1': case '2': case '3': case '4': case '5':
        case '6': case '7':
            return (c - '0');
        }
        return (-1);
    case DECIMAL:
        switch (c) {
        case '0': case '1': case '2': case '3': case '4': case '5':
        case '6': case '7': case '8': case '9':
            return (c - '0');
        }
        return (-1);
    case HEX:
        switch (c) {
        case '0': case '1': case '2': case '3': case '4': case '5':
        case '6': case '7': case '8': case '9':
            return (c - '0');
        }
        switch (c) {
        case 'a': case 'A': return (10);
        case 'b': case 'B': return (11);
        case 'c': case 'C': return (12);
        case 'd': case 'D': return (13);
        case 'e': case 'E': return (14);
        case 'f': case 'F': return (15);
        }
        return (-1);
    }
    return (-1);
}

int integ (char *s, integer_t *i)
{
    integer_t c;
    int neg, d;

    neg = (*s == '-');
    if (neg)
        ++s;
    if (! *s)
        return (0);
    c = 0;
    while ((d = symdigit (*s)) >= 0) {
        c = c*base + d;
        ++s;
    }
    if (*s)
        return (0);
    *i = neg ? -c : c;
    return (1);
}

int realnum (char *s, real_t *r)
{
    int d, e;
    int neg = 0, eneg = 0, ep = 0;
    real_t v;

    if (*s == '-') {
        neg = 1;
        ++s;
    }
    if (! *s)
        return (0);
    v = 0;
    while ((d = symdigit (*s)) >= 0) {
        v = v*base + d;
        ++s;
    }
    if (*s=='.' || *s==',') {
        ++s;
        while ((d = symdigit (*s)) >= 0) {
            v = v*base + d;
            ++s;
            ++ep;
        }
    }
    if (neg)
        v = -v;
    e = 0;
    if (*s=='e' || *s=='E') {
        ++s;
        if (*s == '-') {
            eneg = 1;
            ++s;
        }
        while ((d = symdigit (*s)) >= 0) {
            e = e*base + d;
            ++s;
        }
    }
    if (*s)
        return (0);
    if (eneg)
        e = -e;
    e -= ep;
    if (e < 0) {
        while (++e <= 0)
            v /= base;
    } else {
        while (--e >= 0)
            v *= base;
    }
    *r = v;
    return (1);
}

void forth ()
{
    char *p;
    ident_t *w;
    integer_t i;
    real_t r;

    tty = isatty (fileno (stdin));
    boln = 1;
    compilation = 0;
    base = DECIMAL;
    errorflag = 0;
    stackptr = stack;
    setjmp (errjmp);
    loopptr = loopstack;
    defptr = defbuf;
    execcnt = -1;
    if (inptr) {
        while (--inptr > 0)
            close (instack [inptr]);
        fclose (stdin);
        fdopen (instack [0], "r");
    }
    if (outptr) {
        while (--outptr > 0)
            close (outstack [inptr]);
        fclose (stdout);
        fdopen (outstack [0], "a");
    }
    for (;;) {
        if (! (p = getword (' ', 1)))
            return;
        errorflag = 0;
        w = find (p);
        if (w) {
            if (compilation && ! w->immed) {
                scompile (w);
                continue;
            }
            sexecute (w);
            if (execcnt >= 0)
                run ();
            continue;
        }
        if (integ (p, &i)) {
            if (compilation) {
                (defptr++)->i = FGENINT;
                (defptr++)->i = i;
                continue;
            }
            push (i);
            continue;
        }
        if (realnum (p, &r)) {
            if (compilation) {
                (defptr++)->i = FGENFLT;
                (defptr++)->r = r;
                continue;
            }
            fpush (r);
            continue;
        }
        error ("%s ?", p);
    }
}

int main (int argc, char **argv)
{
    int fdin;

    printf ("Portable Forth, Version 1.4\n");
    printf ("Copyright (C) 1990-2012 Serge Vakulenko\n\n");
    for (++argv, --argc; argc>0 && **argv=='-'; ++argv, --argc) {
        if (! strcmp ("-d", *argv))
            ++debug;
        else
            usage ();
    }
    initdict ();
    fdin = dup (fileno (stdin));
    for (; argc>0; ++argv, --argc) {
        if (strcmp ("-", *argv) == 0) {
            fclose (stdin);
            fdopen (dup (fdin), "r");
        } else {
            FILE *fd = fopen (*argv, "r");
            if (! fd) {
                fprintf (stderr, "Cannot open %s\n", *argv);
                exit (1);
            }
            fclose (stdin);
            fdopen (dup (fileno (fd)), "r");
            fclose (fd);
        }
        forth ();
    }
    fclose (stdin);
    fdopen (dup (fdin), "r");
    close (fdin);
    forth ();
    return (0);
}

char *getword (int delim, int contflag)
{
    static char buf [256];
    char *p;
    int c;

    if (! contflag && boln)
        return (0);
    p = buf;
    for (;;) {
        if (boln) {
            if (tty)
                printf (errorflag ? ERRPROMPT : compilation ?
                    COMPILEPROMPT : OKPROMPT);
            boln = 0;
        }
        switch (c = getc (stdin)) {
        case -1:
            *p = 0;
            if (p <= buf) {
                if (inptr <= 0)
                    return (0);
                fclose (stdin);
                fdopen (dup (instack [--inptr]), "r");
                close (instack [inptr]);
                tty = isatty (fileno (stdin));
                boln = 1;
                continue;
            }
            return (buf);
        case '\n':
            boln = 1;
            goto seedelim;
        case 0:
            c = delim;
            goto seedelim;
        case '\t':
            c = ' ';
        default:
            if (c == delim) {
seedelim:                       *p = 0;
                if (contflag && p<=buf)
                    continue;
                return (buf);
            }
            if (p < buf+sizeof(buf)-1)
                *p++ = c;
            break;
        }
    }
}

int stackerr (int i)
{
    error (i ? "stack overflow" : "stack empty");
    return (0);
}

integer_t alloc (integer_t n)
{
    integer_t p;

    here = (here + sizeof (value_t) - 1) / sizeof (value_t) * sizeof (value_t);
    n *= sizeof (value_t);
    if (here+n > MEMSZ)
        error ("memory overflow");
    p = here;
    here += n;
    return (p);
}

integer_t allot (integer_t n)
{
    integer_t p;

    if (here+n > MEMSZ)
        error ("memory overflow");
    p = here;
    here += n;
    return (p);
}

void execute (value_t *a)
{
    if (execcnt >= 0) {
        if (execcnt >= NESTSZ)
            error ("too deep recursion");
        execstack [execcnt++] = execptr;
        execptr = a;
    } else {
        execptr = a;
        execcnt = 0;
    }
}

ident_t *find (char *name)
{
    ident_t *w;

    for (w=dictptr-1; w>=dict; --w)
        if (name[0]==w->name[0] && !strcmp (name, w->name))
            return (w);
    return (0);
}

ident_t *enter (char *name)
{
    ident_t *w;

    if (dictptr >= dict+DICTSZ)
        error ("dictionary overflow");
    w = dictptr;
    strncpy (w->name, name, NAMESZ);
    w->name [NAMESZ-1] = 0;
    w->type = 0;
    w->immed = 0;
    return (w);
}

char *funcname (funcptr_t p, int type)
{
    ident_t *w;

    for (w=dictptr-1; w>=dict; --w)
        if (type==w->type && p==w->val.p)
            return (w->name);
    return ("???");
}

void decompile (value_t *a)
{
    char *p;
    int c;

    for (; a->i; ++a) {
        switch (a->i) {
        case FSUBR:
            printf ("%s ", funcname ((++a)->p, FSUBR));
            continue;
        case FHARDWARE:
            printf ("%s ", funcname ((++a)->p, FHARDWARE));
            continue;
        case FQUOTE:
            printf ("\" ");
            goto decompstring;
        case FCSTRING:
            printf (".( ");
            c = (++a)->i;
            p = (char*) ++a;
            for (; *p; ++p)
                putc (*p, stdout);
            a += c / sizeof (value_t);
            printf (") ");
            continue;
        case FSTRING:
            printf (".\" ");
decompstring:           c = (++a)->i;
            p = (char*) ++a;
            for (; *p; ++p)
                putc (*p, stdout);
            a += c / sizeof (value_t);
            printf ("\" ");
            continue;
        case FGENINT:   printf ("%ld ", (++a)->i);  continue;
        case FGENFLT:   printf ("%g ", (double) (++a)->r); continue;
        case FCONDIF:   printf ("if ");             continue;
        case FCONDELSE: printf ("else ");           continue;
        case FUNTIL:    printf ("until ");          continue;
        case FREPEAT:   printf ("repeat ");         continue;
        case FWHILE:    printf ("while ");          continue;
        case FLEAVE:    printf ("leave ");          continue;
        case FDO:       printf ("do ");             continue;
        case FIFDO:     printf ("?do ");            continue;
        case FLOOP:     printf ("loop ");           continue;
        case FPLOOP:    printf ("+loop ");          continue;
        case FCOUNTI:   printf ("i ");              continue;
        case FCOUNTJ:   printf ("j ");              continue;
        case FCOUNTK:   printf ("k ");              continue;
        case FBEGIN:    printf ("begin ");          continue;
        case FCONDTHEN: printf ("then ");           continue;
        case FEXIT:     printf ("exit ");           continue;
        default:        printf ("?%ld ", a->i);     continue;
        }
    }
}