QForj is an experimental stack-based array programming language with the goal of giving the programmer the granular control over hardware that comes with assembly, while being just extensible enough for comfortable operating system programming. It's intended to be compiled to a custom RISC architecture (see the 16 instructions qforj.c:76-83), which has vector and tensor operations as well as built-in stack operations that all synergize with this language. The processor is being designed for the ecp5 lattice fpga using the SpinalHDL scala library. It will be uploaded when the pipelining behavior is complete. TODO: > Strict & pure zero-overhead "object-oriented" (inheritance and co/contravariant functionality) type system > Self-host (re-write the language in itself). Currently it runs JIT, machinecode isn't being emitted, but this should be easier to write in qforj than C.

qforj.c

#include "qlist.c"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

Node* R, *D;
int linenum = 0;
Node* transcend(Node* N, Node* d) {
    R = prepend(R, retrack);
    R->c = N;
    R->v = (word) D;
    N = prepend(0, head);
    N->d = D = d;
    return N;
}
// [
Node* ascend(Node* N) {return transcend(N, dictprepend(D));}
// ]
Node* descend(Node* N) {
    R->c = prepend(R->c, retrack);
    R->c->c = N;
    N = R->c;
    D = (Node*) R->v;
    R = pop(R);
    return N;
}

Node* npush(Node* N, word v) {
    (N = prepend(N, value))->v = v;
    return N;
}
#define npop (N = pop(N))

// asrt, iwgz, idgz, swap,
// mcmp, mrot, madd, msub,
// mmul, mdiv, mnnd, morr,
//       itsl, immr, push,
#define basicop(s, n) \
Node* s (Node* N) { \
    word a, b, c, d; \
    a = npop->v; b = npop->v; c = npop->v; d = npop->v; \
    npop; \
    return npush(N, n | (d << 4) |(c << 6) | (a << 8) | (b << 12)); \
} \

basicop(asrt, 0x0000) basicop(iwgz, 0x0001) basicop(idgz, 0x0002) basicop(swap, 0x0003)
basicop(mcmp, 0x0004) basicop(mrot, 0x0005) basicop(madd, 0x0006) basicop(msub, 0x0007)
basicop(mmul, 0x0008) basicop(mdiv, 0x0009) basicop(mnnd, 0x000a) basicop(morr, 0x000b)
basicop(xxxx, 0x000c) basicop(itsl, 0x000d) basicop(immr, 0x000e) basicop(push, 0x000f)
Node* echo(Node* N) {printf("x%llx\n", (npop)->v); return npop;}

// is c contained in s
bool within(char c, char* s) {
    while (*s) {if (c == *s) {return true;} s++;}
    return false;
}
// is the char whitespace
bool whitespace(char c) {return within(c, " \t\n");}
// get the next token at t
// n->str is the pointer, n->v is the strlen
Node* maketok(char** s, word i) {
    Node* n = initnode(token);
    n->str = (char*) memcpy(malloc(i+1), *s, i);
    n->str[i] = 0;
    n->v = i;
    *s += i;
    return n;
}
Node* gettok(char** t) {
    while (whitespace(**t)) {(*t)++;}
    if (!**t) {return 0;}
    int i = 1;
    if (**t == '!') {
        while ((*t)[i] == '!') {i++;}
        return maketok(t, i);
    }
    if (!(**t == '[' || **t == ']')) {
    while ((*t)[i] && !within((*t)[i], " \t\n[]!\"")) {i++;}
    }
    if ((*t)[i] == '\n') {linenum++;}
    if ((*t)[i+1] == '\n') {linenum++;}
    return maketok(t, i);
}
// is the string numeric
bool isnum(char* s) {
    if (!*s) {return 0;}
    if (s[0] == '0') {
        if (s[1] == 'x') {s += 2;}
        if (s[1] == 'b') {s += 2;}
    }
    while (*s) {
        if ('0' > *s || *s > '9') {return 0;}
        s++;
    }
    return 1;
}
// convert string to int.  Works with decimal, hex, and binary.
word toint(char* s) {
    int n, b = 10;
    if (s[0] == '0') {
        if (s[1] == 'x') {s += 2; b = 0x10;}
        if (s[1] == 'b') {s += 2; b = 2;}
    }
    n = 0;
    while (*s) {
        n *= b;
        if ('0' <= *s && *s <= '9') {n += *s-'0';}
        else if (b == 0x10) {
            if ('a' <= *s && *s <= 'f') {n += *s-'a'+0x0a;}
            if ('A' <= *s && *s <= 'F') {n += *s-'A'+0x0a;}
            else {printf("ln:[%d] invalid character in number %s", linenum, s); break;}
        }
        else {return n;}
        s++;
    }
    return n;
}

// run the list as code, assuming it was compiled already.
Node* execute(Node* N);
Node* runnodes(Node* N) {
    while (N->p) {
        N = N->p;
        if (N->t == func && !N->v && !--N->r) {
            N = execute(pop(N));
        }
    }
    return N;
}
// the '!' operator.
// higher '!!', '!!!' etc, require more execute calls
// on them to actually take effect.  Each '!'
// "peels away" one layer ie: '!!! !' = '!!'
Node* execute(Node* N) {
    if (N->t == func) {return ((Func) N->v)(N);}
    if (N->c) {
        Node* n;
        shallowcopytail(&n, N->c);
        N->c = runnodes(n);
    }
    return N;
}
// run just in time script from the provided string
typedef enum chartype {
    Error, Opens, Close, Bang,
    Space, Quote,
    Digit, Alpha
} chartype;
chartype gettype(char c) {
    switch (c) {
    case '[': return Opens;
    case ']': return Close;
    case '!': return Bang;
    case '"': return Quote;
    default:
        if ('0' <= c && c <= '9') {return Digit;}
        return Alpha;
    break;
    }
    return Error;
}

Node* captureQuote(Node* N, char* w, char** t) {
    int i, j; // counting chars to allocate
    j = i = 0;
    while (!*w || whitespace(*w)) {w++;}
    for (; w[i] && w[i] != '"'; i++, j++) {
        if (w[i] == '\\') {i++;}
        else if (w[i] == '\n') {linenum++;}
    }
    *t = w+i+1;
    while (whitespace(w[i-1])) {i--; j--;}
    Node* n = initnode(str);
    n->str = (char*) malloc(j+1);
    n->str[j] = 0;
    n->v = j;
    N = npush(N, (word) n->str);
    for (i = j = 0; j < n->v; i++, j++) {
        if (w[i] == '\\') {i++;}
        n->str[j] = w[i];
    }
    while (whitespace(*++(*t)));
    return N;
}
Node* runscript(Node* N, char* t) {
    Node* m;
    Node* W;
    chartype type;
    while ((W = gettok(&t))) {
    type = gettype(*W->str);
    switch (type) {
    case Opens: N = ascend(N); break;
    case Close: N = descend(N); break;
    case Bang :
        if (scmp(W->str, "!")) {N = execute(N);}
        else {
            int i = 0;
            while (i < W->v && W->str[i] == '!') {i++;}
            N = npush(N, 0);
            N->r = i-1;
            N->t = func;
        }
        break;
    case Quote: N = captureQuote(N, t-W->v+1, &t); break;
    case Digit: if (isnum(W->str)) {N = npush(N, toint(W->str));} break;
    case Alpha:
        if (scmp(W->str, "///")) {
            while ((W = gettok(&t)) && !scmp(W->str, "///")) {
                freeward(wards);
            }
        }
        else if (within(W->str[W->v-1], ":;")) {
            Node* w = W;
            w->str[w->v-1] = 0;
            W = gettok(&t);
            if (scmp(W->str, "[")) {
                N = transcend(N, searchtree(D, w->str)->c->p);
            }
        }
        // if this word is defined, add its value to the stack
        else if ((m = searchtree(D, W->str))) {
            if (!m->v) {N = npush(N, 0); continue;}
            Node* n = copy((Node*) m->v);
            n->n = N;
            N = n;
        }
        else {
            printf("Couldn't locate object %s\n", W->str);
        }
        break;
    default: printf("Couldn't locate object %s\n", W->str); break;
    }
    }
    return N;
}
// 'script' builtin jit command
Node* script(Node* N) {
    npop; char* s = (char*) N->v; npop;
    return runscript(N, s);
}

// '~' builtin
Node* declare(Node* N) {
    npop;
    if (getmap(D, (char*) N->v)) {
        printf("ln:[%d] '%s' already defined.\n", linenum, (char*) N->v);
        return 0;
    }
    Node* n = prepend(N, unset);
    n->str = (char*) N->v;
    addmap(D, (char*) N->v, (word) n);
    return pop(N);
}
// '=' builtin
Node* assign(Node* N) {
    npop;
    Node* m;
    if ((m = searchtree(D, (char*) N->n->v))) {
        m->v = (word) N;
        return pop(N->n);
    }
    setstr(N, (char*) N->n->v);
    Node* n = copynode(N);
    n->n = 0;
    n->c = copy(N->c);
    addmap(D, (char*) N->n->v, (word) n);
    setstr(n, (char*) N->n->v);
    return pop(N->n);
}
// '$' builtin
Node* typecheck(Node* N) {
    npop;
    int b = checkshape(N, N->n);
    N = pop(pop(N));
    return npush(N, b);
}
// math builtins
Node* addop(Node* N) {Node* a = npop; npop->v += a->v; return N;}
Node* subop(Node* N) {Node* a = npop; npop->v -= a->v; return N;}
Node* mulop(Node* N) {Node* a = npop; npop->v *= a->v; return N;}
Node* divop(Node* N) {Node* a = npop; npop->v /= a->v; return N;}
// '@' builtin
Node* reference(Node* N) {
    npop;
    N = npush(N, (word) N);
    N->r = N->n->r+1;
    N->n = N->n->n;
    return N;
}
// '#' builtin
Node* dereference(Node* N) {
    npop;
    Node* n = copynode((Node*) N->v);
    n->c = ((Node*) N->v)->c;
    npop;
    n->n = N; n->p = 0;
    return n;
}

// add a variable to the current dict level
void addglobal(char* name, Func v) {
    Node* n = initnode(func);
    n->str = name;
    n->v = (word) v;
    addmap(D, name, (word) n);
}
#define addg(s) addglobal(#s, s)
int main() {
    FILE* fp = fopen("test.qfj", "r");
    fseek(fp, 0, SEEK_END);
    int fs = ftell(fp);
    rewind(fp);
    char t[fs+1]; t[fs] = 0; t[fs+1] = 0;
    fread(t, 1, fs, fp);
    fclose(fp);

    R = 0;
    Node* D = dictprepend(0);
    Node* N = ascend(0);
    // adding some basic builtins
    addglobal("$", typecheck);
    addglobal("+", addop);
    addglobal("-", subop);
    addglobal("*", mulop);
    addglobal("/", divop);
    addglobal("~", declare);
    addglobal("=", assign);
    addglobal("@", reference);
    addglobal("#", dereference);
    addg(echo);
    addg(script);
    N = npush(N, (word) "asm");
    N = ascend(N);
        addg(asrt); addg(iwgz); addg(idgz); addg(swap);
        addg(mcmp); addg(mrot); addg(madd); addg(msub);
        addg(mmul); addg(mdiv); addg(mnnd); addg(morr);
        addg(xxxx); addg(itsl); addg(immr); addg(push);
    N = descend(N);
    N = npush(N, 0);
    N = assign(N);

    N = runscript(N, t);
    N = descend(N);

    printlist(N);
    printf("\n");

    freewards();

    return 0;
}

test.qfj

///                                      ///
///    ______  __________  ____  ______  ///
///   ╱ ____ ╲╱   __╱    ╲╱    ╲╱_    ╱  ///
///  ╱ ╱╲ ╲╱ ╱   __╱     ╱   __╱_╱   ╱   ///
///  ╲___╲_╲╱___╱  ╲____╱╲_╱__╱╲____╱    ///
///                                      ///
///                                      ///

9 [ 
    [ 8 ] 
] 7 [ 2 [ 4 ] ] 5 1 2 3 [ [ [ 4 ] ] 5 ] 6 7
/// just testing simple pushing and arrays on the stack ///

/// this is a comment ///
/// ///
/// 
multi
line /// ///
comments
///
/// multiline syntax highlighting is broken in browser ///

/// untyped variable declaration ///
7 pod $ !
1 2 3 4 pod pod pod
/// outputs 1 2 3 4 7 7 7 ///

/// run the code as a script similar to python's "eval" ///
" pod 1 pod " script !
" 1 " script !
/// outputs 7 1 7 1 ///

2 pid $ !
pid 1 pid pid pid 8

100 2 + !
[ 10 pod + ! ]
/// adding two numbers together.
numbers can be added at declaration-time in arrays no problem. ///

/// '?' operation is a boolean that compares the shape of two
values (outputing a 1 or 0).  Will be used for the future type system ///
pid pod ? !
[ 10 ] [ 11 ] ? !
10 [ 11 ] ? !
[ [ 0 ] 1 ] [ [ 2 ] 9 ] ? !
[ [ 0 8 ] 1 ] [ [ 2 ] 9 ] ? !
/// output 1 1 0 1 0 ///

" + ! " scripttest $ !
/// assigning a variable to a string ///
2 3 scripttest script !
4 3 scripttest script !
/// executing the string as a very primitive function ///

[ 
    " pod 
    \" [ 1 pid pod ] piz $ ! \"
    script ! pod "
    script ! 
] poze $ !
///
n-nested script calls work as well with backslashes
since declaration with '$' destroys the preceding operands,
poze is simply [ 7 7 ]
///

[ [ [ poze ] ] ]
poze:piz
///
':' allows us to access variables from other scopes.
output [ 1 2 7 ]
///

/// more simple assignment tests ///
[ 1 2 3 ] poge $ !
3 1 2 pid poge poge poge
pid
[ 1 2 [ 4 5 6 ] ] pood $ !
pood

/// reference and dereference operators ///
/// pointer arithmetic isn't available yet due to the c implementation
using linked lists instead of contiguous arrays ///
28 @ ! @ ! # ! # !
[ 1 3 [ 99 ] ] @ ! arraddr1 $ !
[ 4 6 [ 88 ] ] @ ! arraddr2 $ !
arraddr1 # !
arraddr1 # !
arraddr2 # !


/// this is the first notable feature. ///
[ ]
[ 2 2 + !! ] !
[ [ 2 2 + !! ] !! ] !
[ [ 2 2 + !!! ] !! ] !
/// this allows us to create n-order functions very easily ///
/// and still use single '!' as a form of compiletime macro ///

/// testing some inbuilts and the asm "library" ///
pid echo !
0 0 1 0 asm:immr ! echo !
0 0 1 2 asm:immr ! echo !

/// assignment tests and inner access tests with ':' ///
[
    pid
    [ pid 6 peeb $ ! ] poody $ !
    poody pid
] pob $ !
pob
pob:poody
pob:poody:peeb

qlist.c

#include <stdlib.h>
#include <string.h>
#include <stdio.h>

#define false 0
#define true 1
#define namelen 0x20
#define maplen 0x10

typedef long long word;
typedef char byte;
typedef char bool;
typedef struct Node Node;
typedef Node* (*Func)(Node*);
typedef Node* Dict[maplen];
typedef enum NodeType {
    unset, dict, map, head, func, value, ward, retrack, str, token
} NodeType;

struct Node {
    unsigned id;
    char* str;
    word v;
    Node* p, *n, *c;
    void* d;
    byte r; // refcount
    NodeType t;
};

// http://www.cse.yorku.ca/~oz/hash.html
unsigned hash(char* s) {
    unsigned hash = 5381;
    char c;
    while ((c = *s++)) {hash = ((hash << 5) + hash) + c;}
    return hash;
}
// print the list
int printdepth = 0;
Node* printlist(Node* n) {
    if (!n) {return 0;}
    printlist(n->n);
    if (n->t == func) {
        if (!n->v) {
            for (int i = 0; i <= n->r; i++) {printf("!");}
            printf(" ");
        }
        if (n->str) {printf("%s ", n->str);}
    }
    else if (n->n && !n->c) {printf("%lld ", n->v);}
    else if (n->c) {
        if (printdepth == 1) {printf("\n");}
        // some indentation.
        // will probably remove this
        printdepth++; 
        printf("[ ");
        printlist(n->c);
        printf("] ");
        printdepth--;
    }
    return n;
}
// print the map/bucket
Node* printmap(Node* m) {
    if (!m) {return 0;}
    printmap(m->n);
    printf("%s ", m->str);
    return m;
}
// print the dictionary
Node* printdict(Node* d) {
    for (int i = 0; i < maplen; i++) {
        printmap((*((Dict*) d->d))[i]);
    }
    return d;
}

int ID = 0;
Node* wards = 0;
Node* mallocnode() {return (Node*) malloc(sizeof(Node));}
Node* connect(Node* n, Node* p) {
    if (p) {p->n = n;}
    if (n) {n->p = p;}
    return p;
}
Node* resetnode(Node* n) {
    memset(n, 0, sizeof(Node));
    n->id = ID++;
    return n;
}
Node* newnode() {
    Node* n = mallocnode();
    Node* w = resetnode(mallocnode());
    w->t = ward;
    return connect(wards, w)->c = n;
}
Node* initnode(NodeType t) {
    Node* n = resetnode(newnode());
    n->t = t;
    return n;
}
Node* setstr(Node* n, char* s) {
    n->str = strcpy(malloc(strlen(s)), s);
    return n;
}
Node* prepend(Node* n, NodeType t) {
    Node* p = initnode(t);
    p->n = n;
    return p;
}
Node* pop(Node* p) {
    Node* n = p->n;
    if (p->p) {p->p->n = n;}
    if (n) {n->p = p->p;}
    return n;
}
Node* dictprepend(Node* n) {
    Node* d = prepend(n, dict);
    if (n) {
        d->c = d->n->p;
        d->n->p = d;
    }
    d->d = (Dict*) malloc(sizeof(Dict));
    memset(d->d, 0, sizeof(Node*)*maplen);
    return d;
}
#define idxmap(i) ((*((Dict*) d->d))[i])
Node* addmap(Node* d, char* k, word v) {
    unsigned h = hash(k)%maplen;
    Node* n = prepend(idxmap(h), map);
    idxmap(h) = n;
    setstr(n, k);
    n->d = d->d;
    n->c = d;
    n->v = v;
    return n;
}
// returns 0 if the strings are not equal, 1 otherwise.
bool scmp(char* a, char* b) {return strcmp(a, b) == 0;}
// get k's value
// assuming k exists in d
Node* getmap(Node* d, char* k) {
    Node* m = idxmap(hash(k)%maplen);
    while (m && !scmp(m->str, k)) {m = m->n;}
    return m;
}
// search dicts with scoping
// ie: 'city:street:house:room'
Node* searchdict(Node* d, char* s) {
    if (!d) {return 0;}
    int i = 0;
    while (s[i] && s[i] != ':') {i++;}
    i = s[i] == ':' ? i : 0;
    if (i) {s[i] = 0;}

    Node* m = getmap(d, s);
    if (!m || !i) {return m;}
    d = d->p; // search each neighboring dict
    while (!(m = searchdict(d, s+i+1))) {d = d->c;}
    return m;
}
// search all parent dicts as well.
Node* searchtree(Node* d, char* s) {
    Node* m;
    while (d && !(m = searchdict(d, s))) {d = d->n;}
    return m;
}

Node* freeward(Node* w) {
    if (!w) {return 0;}
    if (w->c->t == dict) {free(w->c->d);}
    if (w->c->str) {free(w->c->str);}
    free(w->c);
    if (w->p) {w->p->n = w->n;}
    if (w->n) {w->n->p = w->p;}
    Node* n = w->n;
    free(w);
    return n;
}
// frees all ward nodes as well as the nodes
// and dicts they are tracking.
// Effectively frees all mallocs.
void freewards() {while ((wards = freeward(wards)));}

// copies node p to n.
// n->n and n->c are not copied.
Node* copynode(Node* p) {
    Node* n = initnode(p->t);
    n->r = p->r;
    n->v = p->v;
    n->d = p->d;
    n->str = p->str;
    return n;
}
// copies the entire tree and returns it
Node* copy(Node* p) {
    if (!p) {return 0;}
    Node* n = copynode(p);
    if ((n->n = copy(p->n))) {n->n->p = n;}
    n->c = copy(p->c);
    return n;
}
// lazy, neighbor-only copy.
// returns the tail, not the head.
Node* shallowcopytail(Node** m, Node* p) {
    if (!p) {return 0;}
    Node* n = *m = copynode(p);
    if ((n->n = shallowcopytail(m, p->n))) {n->n->p = n;}
    n->c = p->c;
    return n;
}

// verifies that a and b's tree structure is the same.
// also checks reference level of each value
bool checkshape(Node* a, Node* b) {
    if (!a && !b) {return 1;}
    a = a->c; b = b->c;
    while (!a == !b) {
        if (!a) {return 1;}
        if (a->r != b->r) {return 0;}
        if (!checkshape(a, b)) {return 0;}
        a = a->n; b = b->n;
    }
    return 0;
}