--- /dev/null
+includedir = @includedir@/nasal
+
+lib_LIBRARIES = libnasal.a
+
+include_HEADERS = nasal.h
+
+libnasal_a_SOURCES = \
+ code.c \
+ codegen.c \
+ debug.c \
+ gc.c \
+ hash.c \
+ lex.c \
+ lib.c \
+ mathlib.c \
+ misc.c \
+ parse.c \
+ string.c \
+ vector.c
--- /dev/null
+#include "nasal.h"
+#include "code.h"
+
+////////////////////////////////////////////////////////////////////////
+// Debugging stuff. ////////////////////////////////////////////////////
+////////////////////////////////////////////////////////////////////////
+#if !defined(DEBUG_NASAL)
+# define DBG(expr) /* noop */
+#else
+# define DBG(expr) expr
+# include <stdio.h>
+# include <stdlib.h>
+#endif
+char* opStringDEBUG(int op);
+void printOpDEBUG(int ip, int op);
+void printRefDEBUG(naRef r);
+void printStackDEBUG(struct Context* ctx);
+////////////////////////////////////////////////////////////////////////
+
+// FIXME: need to store a list of all contexts
+struct Context globalContext;
+
+#define ERR(c, msg) naRuntimeError((c),(msg))
+void naRuntimeError(struct Context* c, char* msg)
+{
+ c->error = msg;
+ longjmp(c->jumpHandle, 1);
+}
+
+int boolify(struct Context* ctx, naRef r)
+{
+ if(IS_NIL(r)) return 0;
+ if(IS_NUM(r)) return r.num != 0;
+ if(IS_STR(r)) return 1;
+ ERR(ctx, "non-scalar used in boolean context");
+ return 0;
+}
+
+static double numify(struct Context* ctx, naRef o)
+{
+ double n;
+ if(IS_NUM(o)) return o.num;
+ else if(IS_NIL(o)) ERR(ctx, "nil used in numeric context");
+ else if(!IS_STR(o)) ERR(ctx, "non-scalar in numeric context");
+ else if(naStr_tonum(o, &n)) return n;
+ else ERR(ctx, "non-numeric string in numeric context");
+ return 0;
+}
+
+static naRef stringify(struct Context* ctx, naRef r)
+{
+ if(IS_STR(r)) return r;
+ if(IS_NUM(r)) return naStr_fromnum(naNewString(ctx), r.num);
+ ERR(ctx, "non-scalar in string context");
+ return naNil();
+}
+
+static int checkVec(struct Context* ctx, naRef vec, naRef idx)
+{
+ int i = (int)numify(ctx, idx);
+ if(i < 0 || i >= vec.ref.ptr.vec->size)
+ ERR(ctx, "vector index out of bounds");
+ return i;
+}
+
+static naRef containerGet(struct Context* ctx, naRef box, naRef key)
+{
+ naRef result = naNil();
+ if(!IS_SCALAR(key)) ERR(ctx, "container index not scalar");
+ if(IS_HASH(box)) {
+ if(!naHash_get(box, key, &result))
+ ERR(ctx, "undefined value in container");
+ } else if(IS_VEC(box)) {
+ result = naVec_get(box, checkVec(ctx, box, key));
+ } else {
+ ERR(ctx, "extract from non-container");
+ }
+ return result;
+}
+
+static void containerSet(struct Context* ctx, naRef box, naRef key, naRef val)
+{
+ if(!IS_SCALAR(key)) ERR(ctx, "container index not scalar");
+ else if(IS_HASH(box)) naHash_set(box, key, val);
+ else if(IS_VEC(box)) naVec_set(box, checkVec(ctx, box, key), val);
+ else ERR(ctx, "insert into non-container");
+}
+
+static void initContext(struct Context* c)
+{
+ int i;
+ for(i=0; i<NUM_NASAL_TYPES; i++)
+ naGC_init(&(c->pools[i]), i);
+
+ c->fTop = c->opTop = c->markTop = 0;
+
+ naBZero(c->fStack, MAX_RECURSION * sizeof(struct Frame));
+ naBZero(c->opStack, MAX_STACK_DEPTH * sizeof(naRef));
+
+ // Make sure the args vectors (which are static with the context)
+ // are initialized to nil.
+ for(i=0; i<MAX_RECURSION; i++)
+ c->fStack[i].args = naNil();
+
+ c->argPool = naNewVector(c);
+
+ // Note we can't use naNewVector() for this; it requires that
+ // temps exist first.
+ c->temps = naObj(T_VEC, naGC_get(&(c->pools[T_VEC])));
+
+ c->save = naNil();
+
+ // Cache pre-calculated "me", "arg" and "parents" scalars
+ c->meRef = naStr_fromdata(naNewString(c), "me", 2);
+ c->argRef = naStr_fromdata(naNewString(c), "arg", 3);
+ c->parentsRef = naStr_fromdata(naNewString(c), "parents", 7);
+}
+
+struct Context* naNewContext()
+{
+ // FIXME: need more than one!
+ struct Context* c = &globalContext;
+ initContext(c);
+ return c;
+}
+
+void naGarbageCollect()
+{
+ int i;
+ struct Context* c = &globalContext; // FIXME: more than one!
+
+ for(i=0; i < c->fTop; i++) {
+ naGC_mark(c->fStack[i].func);
+ naGC_mark(c->fStack[i].locals);
+ }
+ for(i=0; i < MAX_RECURSION; i++)
+ naGC_mark(c->fStack[i].args); // collect *all* the argument lists
+ for(i=0; i < c->opTop; i++)
+ naGC_mark(c->opStack[i]);
+
+ naGC_mark(c->argPool);
+ naGC_mark(c->temps);
+ naGC_mark(c->save);
+
+ naGC_mark(c->meRef);
+ naGC_mark(c->argRef);
+ naGC_mark(c->parentsRef);
+
+ // Finally collect all the freed objects
+ for(i=0; i<NUM_NASAL_TYPES; i++)
+ naGC_reap(&(c->pools[i]));
+}
+
+void setupFuncall(struct Context* ctx, naRef func, naRef args)
+{
+ struct Frame* f;
+ f = &(ctx->fStack[ctx->fTop++]);
+ f->func = func;
+ f->ip = 0;
+ f->bp = ctx->opTop;
+ f->line = 0;
+
+ DBG(printf("Entering frame %d\n", ctx->fTop-1);)
+
+ if(!IS_REF(func))
+ ERR(ctx, "function/method call invoked on uncallable object");
+
+ f->args = args;
+ if(IS_CCODE(func.ref.ptr.func->code)) {
+ f->locals = naNil();
+ } else if(IS_CODE(func.ref.ptr.func->code)) {
+ f->locals = naNewHash(ctx);
+ naHash_set(f->locals, ctx->argRef, args);
+ } else {
+ ERR(ctx, "function/method call invoked on uncallable object");
+ }
+}
+
+static naRef evalAndOr(struct Context* ctx, int op, naRef ra, naRef rb)
+{
+ int a = boolify(ctx, ra);
+ int b = boolify(ctx, rb);
+ int result;
+ if(op == OP_AND) result = a && b ? 1 : 0;
+ else result = a || b ? 1 : 0;
+ return naNum(result);
+}
+
+static naRef evalEquality(int op, naRef ra, naRef rb)
+{
+ int result = naEqual(ra, rb);
+ return naNum((op==OP_EQ) ? result : !result);
+}
+
+static naRef evalBinaryNumeric(struct Context* ctx, int op, naRef ra, naRef rb)
+{
+ double a = numify(ctx, ra), b = numify(ctx, rb);
+ switch(op) {
+ case OP_PLUS: return naNum(a + b);
+ case OP_MINUS: return naNum(a - b);
+ case OP_MUL: return naNum(a * b);
+ case OP_DIV: return naNum(a / b);
+ case OP_LT: return naNum(a < b ? 1 : 0);
+ case OP_LTE: return naNum(a <= b ? 1 : 0);
+ case OP_GT: return naNum(a > b ? 1 : 0);
+ case OP_GTE: return naNum(a >= b ? 1 : 0);
+ }
+ return naNil();
+}
+
+// When a code object comes out of the constant pool and shows up on
+// the stack, it needs to be bound with the lexical context.
+static naRef bindFunction(struct Context* ctx, struct Frame* f, naRef code)
+{
+ naRef next = f->func.ref.ptr.func->closure;
+ naRef closure = naNewClosure(ctx, f->locals, next);
+ naRef result = naNewFunc(ctx, code);
+ result.ref.ptr.func->closure = closure;
+ return result;
+}
+
+static int getClosure(struct naClosure* c, naRef sym, naRef* result)
+{
+ while(c) {
+ if(naHash_get(c->namespace, sym, result)) return 1;
+ c = c->next.ref.ptr.closure;
+ }
+ return 0;
+}
+
+// Get a local symbol, or check the closure list if it isn't there
+static naRef getLocal(struct Context* ctx, struct Frame* f, naRef sym)
+{
+ naRef result;
+ if(!naHash_get(f->locals, sym, &result)) {
+ naRef c = f->func.ref.ptr.func->closure;
+ if(!getClosure(c.ref.ptr.closure, sym, &result))
+ ERR(ctx, "undefined symbol");
+ }
+ return result;
+}
+
+static int setClosure(naRef closure, naRef sym, naRef val)
+{
+ struct naClosure* c = closure.ref.ptr.closure;
+ if(c == 0) { return 0; }
+ else if(naHash_tryset(c->namespace, sym, val)) { return 1; }
+ else { return setClosure(c->next, sym, val); }
+}
+
+static naRef setLocal(struct Frame* f, naRef sym, naRef val)
+{
+ // Try the locals first, if not already there try the closures in
+ // order. Finally put it in the locals if nothing matched.
+ if(!naHash_tryset(f->locals, sym, val))
+ if(!setClosure(f->func.ref.ptr.func->closure, sym, val))
+ naHash_set(f->locals, sym, val);
+ return val;
+}
+
+// Recursively descend into the parents lists
+static int getMember(struct Context* ctx, naRef obj, naRef fld, naRef* result)
+{
+ naRef p;
+ if(!IS_HASH(obj)) ERR(ctx, "non-objects have no members");
+ if(naHash_get(obj, fld, result)) {
+ return 1;
+ } else if(naHash_get(obj, ctx->parentsRef, &p)) {
+ int i;
+ if(!IS_VEC(p)) ERR(ctx, "parents field not vector");
+ for(i=0; i<p.ref.ptr.vec->size; i++)
+ if(getMember(ctx, p.ref.ptr.vec->array[i], fld, result))
+ return 1;
+ }
+ return 0;
+}
+
+static void PUSH(struct Context* ctx, naRef r)
+{
+ if(ctx->opTop >= MAX_STACK_DEPTH) ERR(ctx, "stack overflow");
+ ctx->opStack[ctx->opTop++] = r;
+}
+
+static naRef POP(struct Context* ctx)
+{
+ if(ctx->opTop == 0) ERR(ctx, "BUG: stack underflow");
+ return ctx->opStack[--ctx->opTop];
+}
+
+static naRef TOP(struct Context* ctx)
+{
+ if(ctx->opTop == 0) ERR(ctx, "BUG: stack underflow");
+ return ctx->opStack[ctx->opTop-1];
+}
+
+static int ARG16(unsigned char* byteCode, struct Frame* f)
+{
+ int arg = byteCode[f->ip]<<8 | byteCode[f->ip+1];
+ f->ip += 2;
+ return arg;
+}
+
+// OP_EACH works like a vector get, except that it leaves the vector
+// and index on the stack, increments the index after use, and pops
+// the arguments and pushes a nil if the index is beyond the end.
+static void evalEach(struct Context* ctx)
+{
+ int idx = (int)(ctx->opStack[ctx->opTop-1].num);
+ naRef vec = ctx->opStack[ctx->opTop-2];
+ if(idx >= vec.ref.ptr.vec->size) {
+ ctx->opTop -= 2; // pop two values
+ PUSH(ctx, naNil());
+ return;
+ }
+ ctx->opStack[ctx->opTop-1].num = idx+1; // modify in place
+ PUSH(ctx, naVec_get(vec, idx));
+}
+
+static void run1(struct Context* ctx, struct Frame* f, naRef code)
+{
+ naRef a, b, c;
+ struct naCode* cd = code.ref.ptr.code;
+ int op, arg;
+
+ if(f->ip >= cd->nBytes) {
+ DBG(printf("Done with frame %d\n", ctx->fTop-1);)
+ ctx->fTop--;
+ if(ctx->fTop <= 0)
+ ctx->done = 1;
+ return;
+ }
+
+ op = cd->byteCode[f->ip++];
+ DBG(printf("Stack Depth: %d\n", ctx->opTop));
+ DBG(printOpDEBUG(f->ip-1, op));
+ switch(op) {
+ case OP_POP:
+ POP(ctx);
+ break;
+ case OP_DUP:
+ PUSH(ctx, ctx->opStack[ctx->opTop-1]);
+ break;
+ case OP_XCHG:
+ a = POP(ctx); b = POP(ctx);
+ PUSH(ctx, a); PUSH(ctx, b);
+ break;
+ case OP_PLUS: case OP_MUL: case OP_DIV: case OP_MINUS:
+ case OP_LT: case OP_LTE: case OP_GT: case OP_GTE:
+ a = POP(ctx); b = POP(ctx);
+ PUSH(ctx, evalBinaryNumeric(ctx, op, b, a));
+ break;
+ case OP_EQ: case OP_NEQ:
+ a = POP(ctx); b = POP(ctx);
+ PUSH(ctx, evalEquality(op, b, a));
+ break;
+ case OP_AND: case OP_OR:
+ a = POP(ctx); b = POP(ctx);
+ PUSH(ctx, evalAndOr(ctx, op, a, b));
+ break;
+ case OP_CAT:
+ a = stringify(ctx, POP(ctx)); b = stringify(ctx, POP(ctx));
+ c = naStr_concat(naNewString(ctx), b, a);
+ PUSH(ctx, c);
+ break;
+ case OP_NEG:
+ a = POP(ctx);
+ PUSH(ctx, naNum(-numify(ctx, a)));
+ break;
+ case OP_NOT:
+ a = POP(ctx);
+ PUSH(ctx, naNum(boolify(ctx, a) ? 0 : 1));
+ break;
+ case OP_PUSHCONST:
+ a = cd->constants[ARG16(cd->byteCode, f)];
+ if(IS_CODE(a)) a = bindFunction(ctx, f, a);
+ PUSH(ctx, a);
+ break;
+ case OP_PUSHONE:
+ PUSH(ctx, naNum(1));
+ break;
+ case OP_PUSHZERO:
+ PUSH(ctx, naNum(0));
+ break;
+ case OP_PUSHNIL:
+ PUSH(ctx, naNil());
+ break;
+ case OP_NEWVEC:
+ PUSH(ctx, naNewVector(ctx));
+ break;
+ case OP_VAPPEND:
+ b = POP(ctx); a = TOP(ctx);
+ naVec_append(a, b);
+ break;
+ case OP_NEWHASH:
+ PUSH(ctx, naNewHash(ctx));
+ break;
+ case OP_HAPPEND:
+ c = POP(ctx); b = POP(ctx); a = TOP(ctx); // a,b,c: hash, key, val
+ naHash_set(a, b, c);
+ break;
+ case OP_LOCAL:
+ a = getLocal(ctx, f, POP(ctx));
+ PUSH(ctx, a);
+ break;
+ case OP_SETLOCAL:
+ a = POP(ctx); b = POP(ctx);
+ PUSH(ctx, setLocal(f, b, a));
+ break;
+ case OP_MEMBER:
+ a = POP(ctx); b = POP(ctx);
+ if(!getMember(ctx, b, a, &c))
+ ERR(ctx, "no such member");
+ PUSH(ctx, c);
+ break;
+ case OP_SETMEMBER:
+ c = POP(ctx); b = POP(ctx); a = POP(ctx); // a,b,c: hash, key, val
+ if(!IS_HASH(a)) ERR(ctx, "non-objects have no members");
+ naHash_set(a, b, c);
+ PUSH(ctx, c);
+ break;
+ case OP_INSERT:
+ c = POP(ctx); b = POP(ctx); a = POP(ctx); // a,b,c: box, key, val
+ containerSet(ctx, a, b, c);
+ PUSH(ctx, c);
+ break;
+ case OP_EXTRACT:
+ b = POP(ctx); a = POP(ctx); // a,b: box, key
+ PUSH(ctx, containerGet(ctx, a, b));
+ break;
+ case OP_JMP:
+ f->ip = ARG16(cd->byteCode, f);
+ DBG(printf(" [Jump to: %d]\n", f->ip);)
+ break;
+ case OP_JIFNIL:
+ arg = ARG16(cd->byteCode, f);
+ a = TOP(ctx);
+ if(IS_NIL(a)) {
+ POP(ctx); // Pops **ONLY** if it's nil!
+ f->ip = arg;
+ DBG(printf(" [Jump to: %d]\n", f->ip);)
+ }
+ break;
+ case OP_JIFNOT:
+ arg = ARG16(cd->byteCode, f);
+ if(!boolify(ctx, POP(ctx))) {
+ f->ip = arg;
+ DBG(printf(" [Jump to: %d]\n", f->ip);)
+ }
+ break;
+ case OP_FCALL:
+ b = POP(ctx); a = POP(ctx); // a,b = func, args
+ setupFuncall(ctx, a, b);
+ break;
+ case OP_MCALL:
+ c = POP(ctx); b = POP(ctx); a = POP(ctx); // a,b,c = obj, func, args
+ setupFuncall(ctx, b, c);
+ naHash_set(ctx->fStack[ctx->fTop-1].locals, ctx->meRef, a);
+ break;
+ case OP_RETURN:
+ a = POP(ctx);
+ ctx->opTop = f->bp; // restore the correct stack frame!
+ ctx->fTop--;
+ ctx->fStack[ctx->fTop].args.ref.ptr.vec->size = 0;
+ naVec_append(ctx->argPool, ctx->fStack[ctx->fTop].args);
+ PUSH(ctx, a);
+ break;
+ case OP_LINE:
+ f->line = ARG16(cd->byteCode, f);
+ break;
+ case OP_EACH:
+ evalEach(ctx);
+ break;
+ case OP_MARK: // save stack state (e.g. "setjmp")
+ ctx->markStack[ctx->markTop++] = ctx->opTop;
+ break;
+ case OP_UNMARK: // pop stack state set by mark
+ ctx->markTop--;
+ break;
+ case OP_BREAK: // restore stack state (FOLLOW WITH JMP!)
+ ctx->opTop = ctx->markStack[--ctx->markTop];
+ break;
+ case OP_NEWARGS: // push a new function arg vector
+ PUSH(ctx, (naVec_size(ctx->argPool) ?
+ naVec_removelast(ctx->argPool) : naNewVector(ctx)));
+ break;
+ default:
+ ERR(ctx, "BUG: bad opcode");
+ }
+
+ if(ctx->fTop <= 0)
+ ctx->done = 1;
+}
+
+static void nativeCall(struct Context* ctx, struct Frame* f, naRef ccode)
+{
+ naCFunction fptr = ccode.ref.ptr.ccode->fptr;
+ naRef result = (*fptr)(ctx, f->args);
+ ctx->fTop--;
+ ctx->fStack[ctx->fTop].args.ref.ptr.vec->size = 0;
+ PUSH(ctx, result);
+}
+
+void naSave(struct Context* ctx, naRef obj)
+{
+ ctx->save = obj;
+}
+
+int naStackDepth(struct Context* ctx)
+{
+ return ctx->fTop;
+}
+
+int naGetLine(struct Context* ctx, int frame)
+{
+ return ctx->fStack[ctx->fTop-1-frame].line;
+}
+
+naRef naGetSourceFile(struct Context* ctx, int frame)
+{
+ naRef f = ctx->fStack[ctx->fTop-1-frame].func;
+ f = f.ref.ptr.func->code;
+ return f.ref.ptr.code->srcFile;
+}
+
+char* naGetError(struct Context* ctx)
+{
+ return ctx->error;
+}
+
+static naRef run(naContext ctx)
+{
+ // Return early if an error occurred. It will be visible to the
+ // caller via naGetError().
+ if(setjmp(ctx->jumpHandle))
+ return naNil();
+
+ ctx->done = 0;
+ while(!ctx->done) {
+ struct Frame* f = &(ctx->fStack[ctx->fTop-1]);
+ naRef code = f->func.ref.ptr.func->code;
+ if(IS_CCODE(code)) nativeCall(ctx, f, code);
+ else run1(ctx, f, code);
+
+ ctx->temps.ref.ptr.vec->size = 0; // Reset the temporaries
+ DBG(printStackDEBUG(ctx);)
+ }
+
+ DBG(printStackDEBUG(ctx);)
+ return ctx->opStack[--ctx->opTop];
+}
+
+naRef naBindFunction(naContext ctx, naRef code, naRef closure)
+{
+ naRef func = naNewFunc(ctx, code);
+ func.ref.ptr.func->closure = naNewClosure(ctx, closure, naNil());
+ return func;
+}
+
+naRef naCall(naContext ctx, naRef func, naRef args, naRef obj, naRef locals)
+{
+ // We might have to allocate objects, which can call the GC. But
+ // the call isn't on the Nasal stack yet, so the GC won't find our
+ // C-space arguments.
+ naVec_append(ctx->temps, func);
+ naVec_append(ctx->temps, args);
+ naVec_append(ctx->temps, obj);
+ naVec_append(ctx->temps, locals);
+
+ if(IS_NIL(args))
+ args = naNewVector(ctx);
+ if(IS_NIL(locals))
+ locals = naNewHash(ctx);
+ if(!IS_FUNC(func)) {
+ // Generate a noop closure for bare code objects
+ naRef code = func;
+ func = naNewFunc(ctx, code);
+ func.ref.ptr.func->closure = naNewClosure(ctx, locals, naNil());
+ }
+ if(!IS_NIL(obj))
+ naHash_set(locals, ctx->meRef, obj);
+
+ ctx->fTop = ctx->opTop = ctx->markTop = 0;
+ setupFuncall(ctx, func, args);
+ ctx->fStack[ctx->fTop-1].locals = locals;
+
+ return run(ctx);
+}
+
--- /dev/null
+#ifndef _CODE_H
+#define _CODE_H
+
+#include <setjmp.h>
+#include "nasal.h"
+#include "data.h"
+
+#define MAX_STACK_DEPTH 1024
+#define MAX_RECURSION 128
+#define MAX_MARK_DEPTH 32
+
+enum {
+ OP_AND, OP_OR, OP_NOT, OP_MUL, OP_PLUS, OP_MINUS, OP_DIV, OP_NEG,
+ OP_CAT, OP_LT, OP_LTE, OP_GT, OP_GTE, OP_EQ, OP_NEQ, OP_EACH,
+ OP_JMP, OP_JIFNOT, OP_JIFNIL, OP_FCALL, OP_MCALL, OP_RETURN,
+ OP_PUSHCONST, OP_PUSHONE, OP_PUSHZERO, OP_PUSHNIL, OP_POP,
+ OP_DUP, OP_XCHG, OP_INSERT, OP_EXTRACT, OP_MEMBER, OP_SETMEMBER,
+ OP_LOCAL, OP_SETLOCAL, OP_NEWVEC, OP_VAPPEND, OP_NEWHASH, OP_HAPPEND,
+ OP_LINE, OP_MARK, OP_UNMARK, OP_BREAK, OP_NEWARGS
+};
+
+struct Frame {
+ naRef func; // naFunc object
+ naRef locals; // local per-call namespace
+ naRef args; // vector of arguments
+ int ip; // instruction pointer into code
+ int bp; // opStack pointer to start of frame
+ int line; // current line number
+};
+
+struct Context {
+ // Garbage collecting allocators:
+ struct naPool pools[NUM_NASAL_TYPES];
+
+ // Stack(s)
+ struct Frame fStack[MAX_RECURSION];
+ int fTop;
+ naRef opStack[MAX_STACK_DEPTH];
+ int opTop;
+ int markStack[MAX_MARK_DEPTH];
+ int markTop;
+ int done;
+
+ // Vector of arguments vectors. A LIFO cache, basically, to avoid
+ // thrashing the GC just for function call arguments.
+ naRef argPool;
+
+ // Constants
+ naRef meRef;
+ naRef argRef;
+ naRef parentsRef;
+
+ // Error handling
+ jmp_buf jumpHandle;
+ char* error;
+
+ // GC-findable reference point for objects that may live on the
+ // processor ("real") stack during execution. naNew() places them
+ // here, and clears the array each time we return from a C
+ // function.
+ naRef temps;
+
+ naRef save;
+};
+
+void printRefDEBUG(naRef r);
+
+#endif // _CODE_H
--- /dev/null
+#include "parse.h"
+#include "code.h"
+
+// These are more sensical predicate names in most contexts in this file
+#define LEFT(tok) ((tok)->children)
+#define RIGHT(tok) ((tok)->lastChild)
+#define BINARY(tok) (LEFT(tok) && RIGHT(tok) && LEFT(tok) != RIGHT(tok))
+
+// Forward references for recursion
+static void genExpr(struct Parser* p, struct Token* t);
+static void genExprList(struct Parser* p, struct Token* t);
+
+static void emit(struct Parser* p, int byte)
+{
+ if(p->cg->nBytes >= p->cg->codeAlloced) {
+ int i, sz = p->cg->codeAlloced * 2;
+ unsigned char* buf = naParseAlloc(p, sz);
+ for(i=0; i<p->cg->codeAlloced; i++) buf[i] = p->cg->byteCode[i];
+ p->cg->byteCode = buf;
+ p->cg->codeAlloced = sz;
+ }
+ p->cg->byteCode[p->cg->nBytes++] = (unsigned char)byte;
+}
+
+static void emitImmediate(struct Parser* p, int byte, int arg)
+{
+ emit(p, byte);
+ emit(p, arg >> 8);
+ emit(p, arg & 0xff);
+}
+
+static void genBinOp(int op, struct Parser* p, struct Token* t)
+{
+ if(!LEFT(t) || !RIGHT(t))
+ naParseError(p, "empty subexpression", t->line);
+ genExpr(p, LEFT(t));
+ genExpr(p, RIGHT(t));
+ emit(p, op);
+}
+
+static int newConstant(struct Parser* p, naRef c)
+{
+ int i = p->cg->nConsts++;
+ if(i > 0xffff) naParseError(p, "too many constants in code block", 0);
+ naHash_set(p->cg->consts, naNum(i), c);
+ return i;
+}
+
+static naRef getConstant(struct Parser* p, int idx)
+{
+ naRef c;
+ naHash_get(p->cg->consts, naNum(idx), &c);
+ return c;
+}
+
+// Interns a scalar (!) constant and returns its index
+static int internConstant(struct Parser* p, naRef c)
+{
+ naRef r;
+ naHash_get(p->cg->interned, c, &r);
+ if(!IS_NIL(r)) {
+ return (int)r.num;
+ } else {
+ int idx = newConstant(p, c);
+ naHash_set(p->cg->interned, c, naNum(idx));
+ return idx;
+ }
+}
+
+static void genScalarConstant(struct Parser* p, struct Token* t)
+{
+ naRef c = (t->str
+ ? naStr_fromdata(naNewString(p->context), t->str, t->strlen)
+ : naNum(t->num));
+ int idx = internConstant(p, c);
+ emitImmediate(p, OP_PUSHCONST, idx);
+}
+
+static int genLValue(struct Parser* p, struct Token* t)
+{
+ if(t->type == TOK_LPAR) {
+ return genLValue(p, LEFT(t)); // Handle stuff like "(a) = 1"
+ } else if(t->type == TOK_SYMBOL) {
+ genScalarConstant(p, t);
+ return OP_SETLOCAL;
+ } else if(t->type == TOK_DOT && RIGHT(t) && RIGHT(t)->type == TOK_SYMBOL) {
+ genExpr(p, LEFT(t));
+ genScalarConstant(p, RIGHT(t));
+ return OP_SETMEMBER;
+ } else if(t->type == TOK_LBRA) {
+ genExpr(p, LEFT(t));
+ genExpr(p, RIGHT(t));
+ return OP_INSERT;
+ } else {
+ naParseError(p, "bad lvalue", t->line);
+ return -1;
+ }
+}
+
+static void genLambda(struct Parser* p, struct Token* t)
+{
+ int idx;
+ struct CodeGenerator* cgSave;
+ naRef codeObj;
+ if(LEFT(t)->type != TOK_LCURL)
+ naParseError(p, "bad function definition", t->line);
+
+ // Save off the generator state while we do the new one
+ cgSave = p->cg;
+ codeObj = naCodeGen(p, LEFT(LEFT(t)));
+ p->cg = cgSave;
+
+ idx = newConstant(p, codeObj);
+ emitImmediate(p, OP_PUSHCONST, idx);
+}
+
+static void genList(struct Parser* p, struct Token* t)
+{
+ if(t->type == TOK_COMMA) {
+ genExpr(p, LEFT(t));
+ emit(p, OP_VAPPEND);
+ genList(p, RIGHT(t));
+ } else if(t->type == TOK_EMPTY) {
+ return;
+ } else {
+ genExpr(p, t);
+ emit(p, OP_VAPPEND);
+ }
+}
+
+static void genHashElem(struct Parser* p, struct Token* t)
+{
+ if(t->type == TOK_EMPTY)
+ return;
+ if(t->type != TOK_COLON)
+ naParseError(p, "bad hash/object initializer", t->line);
+ if(LEFT(t)->type == TOK_SYMBOL) genScalarConstant(p, LEFT(t));
+ else if(LEFT(t)->type == TOK_LITERAL) genExpr(p, LEFT(t));
+ else naParseError(p, "bad hash/object initializer", t->line);
+ genExpr(p, RIGHT(t));
+ emit(p, OP_HAPPEND);
+}
+
+static void genHash(struct Parser* p, struct Token* t)
+{
+ if(t->type == TOK_COMMA) {
+ genHashElem(p, LEFT(t));
+ genHash(p, RIGHT(t));
+ } else if(t->type != TOK_EMPTY) {
+ genHashElem(p, t);
+ }
+}
+
+static void genFuncall(struct Parser* p, struct Token* t)
+{
+ int op = OP_FCALL;
+ if(LEFT(t)->type == TOK_DOT) {
+ genExpr(p, LEFT(LEFT(t)));
+ emit(p, OP_DUP);
+ genScalarConstant(p, RIGHT(LEFT(t)));
+ emit(p, OP_MEMBER);
+ op = OP_MCALL;
+ } else {
+ genExpr(p, LEFT(t));
+ }
+ emit(p, OP_NEWARGS);
+ if(RIGHT(t)) genList(p, RIGHT(t));
+ emit(p, op);
+}
+
+static void pushLoop(struct Parser* p, struct Token* label)
+{
+ int i = p->cg->loopTop;
+ p->cg->loops[i].breakIP = 0xffffff;
+ p->cg->loops[i].contIP = 0xffffff;
+ p->cg->loops[i].label = label;
+ p->cg->loopTop++;
+ emit(p, OP_MARK);
+}
+
+static void popLoop(struct Parser* p)
+{
+ p->cg->loopTop--;
+ if(p->cg->loopTop < 0) naParseError(p, "BUG: loop stack underflow", -1);
+ emit(p, OP_UNMARK);
+}
+
+// Emit a jump operation, and return the location of the address in
+// the bytecode for future fixup in fixJumpTarget
+static int emitJump(struct Parser* p, int op)
+{
+ int ip;
+ emit(p, op);
+ ip = p->cg->nBytes;
+ emit(p, 0xff); // dummy address
+ emit(p, 0xff);
+ return ip;
+}
+
+// Points a previous jump instruction at the current "end-of-bytecode"
+static void fixJumpTarget(struct Parser* p, int spot)
+{
+ p->cg->byteCode[spot] = p->cg->nBytes >> 8;
+ p->cg->byteCode[spot+1] = p->cg->nBytes & 0xff;
+}
+
+static void genShortCircuit(struct Parser* p, struct Token* t)
+{
+ int jumpNext, jumpEnd, isAnd = (t->type == TOK_AND);
+ genExpr(p, LEFT(t));
+ if(isAnd) emit(p, OP_NOT);
+ jumpNext = emitJump(p, OP_JIFNOT);
+ emit(p, isAnd ? OP_PUSHNIL : OP_PUSHONE);
+ jumpEnd = emitJump(p, OP_JMP);
+ fixJumpTarget(p, jumpNext);
+ genExpr(p, RIGHT(t));
+ fixJumpTarget(p, jumpEnd);
+}
+
+
+static void genIf(struct Parser* p, struct Token* tif, struct Token* telse)
+{
+ int jumpNext, jumpEnd;
+ genExpr(p, tif->children); // the test
+ jumpNext = emitJump(p, OP_JIFNOT);
+ genExprList(p, tif->children->next->children); // the body
+ jumpEnd = emitJump(p, OP_JMP);
+ fixJumpTarget(p, jumpNext);
+ if(telse) {
+ if(telse->type == TOK_ELSIF) genIf(p, telse, telse->next);
+ else genExprList(p, telse->children->children);
+ } else {
+ emit(p, OP_PUSHNIL);
+ }
+ fixJumpTarget(p, jumpEnd);
+}
+
+static void genIfElse(struct Parser* p, struct Token* t)
+{
+ genIf(p, t, t->children->next->next);
+}
+
+static int countSemis(struct Token* t)
+{
+ if(!t || t->type != TOK_SEMI) return 0;
+ return 1 + countSemis(RIGHT(t));
+}
+
+static void genLoop(struct Parser* p, struct Token* body,
+ struct Token* update, struct Token* label,
+ int loopTop, int jumpEnd)
+{
+ int cont, jumpOverContinue;
+
+ p->cg->loops[p->cg->loopTop-1].breakIP = jumpEnd-1;
+
+ jumpOverContinue = emitJump(p, OP_JMP);
+ p->cg->loops[p->cg->loopTop-1].contIP = p->cg->nBytes;
+ cont = emitJump(p, OP_JMP);
+ fixJumpTarget(p, jumpOverContinue);
+
+ genExprList(p, body);
+ emit(p, OP_POP);
+ fixJumpTarget(p, cont);
+ if(update) { genExpr(p, update); emit(p, OP_POP); }
+ emitImmediate(p, OP_JMP, loopTop);
+ fixJumpTarget(p, jumpEnd);
+ popLoop(p);
+ emit(p, OP_PUSHNIL); // Leave something on the stack
+}
+
+static void genForWhile(struct Parser* p, struct Token* init,
+ struct Token* test, struct Token* update,
+ struct Token* body, struct Token* label)
+{
+ int loopTop, jumpEnd;
+ if(init) { genExpr(p, init); emit(p, OP_POP); }
+ pushLoop(p, label);
+ loopTop = p->cg->nBytes;
+ genExpr(p, test);
+ jumpEnd = emitJump(p, OP_JIFNOT);
+ genLoop(p, body, update, label, loopTop, jumpEnd);
+}
+
+static void genWhile(struct Parser* p, struct Token* t)
+{
+ struct Token *test=LEFT(t)->children, *body, *label=0;
+ int semis = countSemis(test);
+ if(semis == 1) {
+ label = LEFT(test);
+ if(!label || label->type != TOK_SYMBOL)
+ naParseError(p, "bad loop label", t->line);
+ test = RIGHT(test);
+ }
+ else if(semis != 0)
+ naParseError(p, "too many semicolons in while test", t->line);
+ body = LEFT(RIGHT(t));
+ genForWhile(p, 0, test, 0, body, label);
+}
+
+static void genFor(struct Parser* p, struct Token* t)
+{
+ struct Token *init, *test, *body, *update, *label=0;
+ struct Token *h = LEFT(t)->children;
+ int semis = countSemis(h);
+ if(semis == 3) {
+ if(!LEFT(h) || LEFT(h)->type != TOK_SYMBOL)
+ naParseError(p, "bad loop label", h->line);
+ label = LEFT(h);
+ h=RIGHT(h);
+ } else if(semis != 2) {
+ naParseError(p, "wrong number of terms in for header", t->line);
+ }
+
+ // Parse tree hell :)
+ init = LEFT(h);
+ test = LEFT(RIGHT(h));
+ update = RIGHT(RIGHT(h));
+ body = RIGHT(t)->children;
+ genForWhile(p, init, test, update, body, label);
+}
+
+static void genForEach(struct Parser* p, struct Token* t)
+{
+ int loopTop, jumpEnd, assignOp;
+ struct Token *elem, *body, *vec, *label=0;
+ struct Token *h = LEFT(LEFT(t));
+ int semis = countSemis(h);
+ if(semis == 2) {
+ if(!LEFT(h) || LEFT(h)->type != TOK_SYMBOL)
+ naParseError(p, "bad loop label", h->line);
+ label = LEFT(h);
+ h = RIGHT(h);
+ } else if (semis != 1) {
+ naParseError(p, "wrong number of terms in foreach header", t->line);
+ }
+ elem = LEFT(h);
+ vec = RIGHT(h);
+ body = RIGHT(t)->children;
+
+ pushLoop(p, label);
+ genExpr(p, vec);
+ emit(p, OP_PUSHZERO);
+ loopTop = p->cg->nBytes;
+ emit(p, OP_EACH);
+ jumpEnd = emitJump(p, OP_JIFNIL);
+ assignOp = genLValue(p, elem);
+ emit(p, OP_XCHG);
+ emit(p, assignOp);
+ emit(p, OP_POP);
+ genLoop(p, body, 0, label, loopTop, jumpEnd);
+}
+
+static int tokMatch(struct Token* a, struct Token* b)
+{
+ int i, l = a->strlen;
+ if(!a || !b) return 0;
+ if(l != b->strlen) return 0;
+ for(i=0; i<l; i++) if(a->str[i] != b->str[i]) return 0;
+ return 1;
+}
+
+static void genBreakContinue(struct Parser* p, struct Token* t)
+{
+ int levels = 1, loop = -1, bp, cp, i;
+ if(RIGHT(t)) {
+ if(RIGHT(t)->type != TOK_SYMBOL)
+ naParseError(p, "bad break/continue label", t->line);
+ for(i=0; i<p->cg->loopTop; i++)
+ if(tokMatch(RIGHT(t), p->cg->loops[i].label))
+ loop = i;
+ if(loop == -1)
+ naParseError(p, "no match for break/continue label", t->line);
+ levels = p->cg->loopTop - loop;
+ }
+ bp = p->cg->loops[p->cg->loopTop - levels].breakIP;
+ cp = p->cg->loops[p->cg->loopTop - levels].contIP;
+ for(i=0; i<levels; i++)
+ emit(p, OP_BREAK);
+ if(t->type == TOK_BREAK)
+ emit(p, OP_PUSHNIL); // breakIP is always a JIFNOT/JIFNIL!
+ emitImmediate(p, OP_JMP, t->type == TOK_BREAK ? bp : cp);
+}
+
+static void genExpr(struct Parser* p, struct Token* t)
+{
+ int i;
+ if(t == 0)
+ naParseError(p, "BUG: null subexpression", -1);
+ if(t->line != p->cg->lastLine)
+ emitImmediate(p, OP_LINE, t->line);
+ p->cg->lastLine = t->line;
+ switch(t->type) {
+ case TOK_IF:
+ genIfElse(p, t);
+ break;
+ case TOK_WHILE:
+ genWhile(p, t);
+ break;
+ case TOK_FOR:
+ genFor(p, t);
+ break;
+ case TOK_FOREACH:
+ genForEach(p, t);
+ break;
+ case TOK_BREAK: case TOK_CONTINUE:
+ genBreakContinue(p, t);
+ break;
+ case TOK_TOP:
+ genExprList(p, LEFT(t));
+ break;
+ case TOK_FUNC:
+ genLambda(p, t);
+ break;
+ case TOK_LPAR:
+ if(BINARY(t) || !RIGHT(t)) genFuncall(p, t); // function invocation
+ else genExpr(p, LEFT(t)); // simple parenthesis
+ break;
+ case TOK_LBRA:
+ if(BINARY(t)) {
+ genBinOp(OP_EXTRACT, p, t); // a[i]
+ } else {
+ emit(p, OP_NEWVEC);
+ genList(p, LEFT(t));
+ }
+ break;
+ case TOK_LCURL:
+ emit(p, OP_NEWHASH);
+ genHash(p, LEFT(t));
+ break;
+ case TOK_ASSIGN:
+ i = genLValue(p, LEFT(t));
+ genExpr(p, RIGHT(t));
+ emit(p, i); // use the op appropriate to the lvalue
+ break;
+ case TOK_RETURN:
+ if(RIGHT(t)) genExpr(p, RIGHT(t));
+ else emit(p, OP_PUSHNIL);
+ emit(p, OP_RETURN);
+ break;
+ case TOK_NOT:
+ genExpr(p, RIGHT(t));
+ emit(p, OP_NOT);
+ break;
+ case TOK_SYMBOL:
+ genScalarConstant(p, t);
+ emit(p, OP_LOCAL);
+ break;
+ case TOK_LITERAL:
+ genScalarConstant(p, t);
+ break;
+ case TOK_MINUS:
+ if(BINARY(t)) {
+ genBinOp(OP_MINUS, p, t); // binary subtraction
+ } else if(RIGHT(t)->type == TOK_LITERAL && !RIGHT(t)->str) {
+ RIGHT(t)->num *= -1; // Pre-negate constants
+ genScalarConstant(p, RIGHT(t));
+ } else {
+ genExpr(p, RIGHT(t)); // unary negation
+ emit(p, OP_NEG);
+ }
+ break;
+ case TOK_NEG:
+ genExpr(p, RIGHT(t)); // unary negation (see also TOK_MINUS!)
+ emit(p, OP_NEG);
+ break;
+ case TOK_DOT:
+ genExpr(p, LEFT(t));
+ if(RIGHT(t)->type != TOK_SYMBOL)
+ naParseError(p, "object field not symbol", RIGHT(t)->line);
+ genScalarConstant(p, RIGHT(t));
+ emit(p, OP_MEMBER);
+ break;
+ case TOK_EMPTY: case TOK_NIL:
+ emit(p, OP_PUSHNIL); break; // *NOT* a noop!
+ case TOK_AND: case TOK_OR:
+ genShortCircuit(p, t);
+ break;
+ case TOK_MUL: genBinOp(OP_MUL, p, t); break;
+ case TOK_PLUS: genBinOp(OP_PLUS, p, t); break;
+ case TOK_DIV: genBinOp(OP_DIV, p, t); break;
+ case TOK_CAT: genBinOp(OP_CAT, p, t); break;
+ case TOK_LT: genBinOp(OP_LT, p, t); break;
+ case TOK_LTE: genBinOp(OP_LTE, p, t); break;
+ case TOK_EQ: genBinOp(OP_EQ, p, t); break;
+ case TOK_NEQ: genBinOp(OP_NEQ, p, t); break;
+ case TOK_GT: genBinOp(OP_GT, p, t); break;
+ case TOK_GTE: genBinOp(OP_GTE, p, t); break;
+ default:
+ naParseError(p, "parse error", t->line);
+ };
+}
+
+static void genExprList(struct Parser* p, struct Token* t)
+{
+ if(t->type == TOK_SEMI) {
+ genExpr(p, LEFT(t));
+ if(RIGHT(t) && RIGHT(t)->type != TOK_EMPTY) {
+ emit(p, OP_POP);
+ genExprList(p, RIGHT(t));
+ }
+ } else {
+ genExpr(p, t);
+ }
+}
+
+naRef naCodeGen(struct Parser* p, struct Token* t)
+{
+ int i;
+ naRef codeObj;
+ struct naCode* code;
+ struct CodeGenerator cg;
+
+ cg.lastLine = 0;
+ cg.codeAlloced = 1024; // Start fairly big, this is a cheap allocation
+ cg.byteCode = naParseAlloc(p, cg.codeAlloced);
+ cg.nBytes = 0;
+ cg.consts = naNewHash(p->context);
+ cg.interned = naNewHash(p->context);
+ cg.nConsts = 0;
+ cg.loopTop = 0;
+ p->cg = &cg;
+
+ genExprList(p, t);
+
+ // Now make a code object
+ codeObj = naNewCode(p->context);
+ code = codeObj.ref.ptr.code;
+ code->nBytes = cg.nBytes;
+ code->byteCode = naAlloc(cg.nBytes);
+ for(i=0; i < cg.nBytes; i++)
+ code->byteCode[i] = cg.byteCode[i];
+ code->nConstants = cg.nConsts;
+ code->constants = naAlloc(code->nConstants * sizeof(naRef));
+ code->srcFile = p->srcFile;
+ for(i=0; i<code->nConstants; i++)
+ code->constants[i] = getConstant(p, i);
+
+ return codeObj;
+}
--- /dev/null
+#ifndef _DATA_H
+#define _DATA_H
+
+#include "nasal.h"
+
+// Notes: A CODE object is a compiled set of bytecode instructions.
+// What actually gets executed at runtime is a bound FUNC object,
+// which combines the raw code with a pointer to a CLOSURE chain of
+// namespaces.
+enum { T_STR, T_VEC, T_HASH, T_CODE, T_CLOSURE, T_FUNC, T_CCODE,
+ NUM_NASAL_TYPES }; // V. important that this come last!
+
+#define IS_REF(r) ((r).ref.reftag == NASAL_REFTAG)
+#define IS_NUM(r) ((r).ref.reftag != NASAL_REFTAG)
+#define IS_OBJ(r) (IS_REF((r)) && (r).ref.ptr.obj != 0)
+#define IS_NIL(r) (IS_REF((r)) && (r).ref.ptr.obj == 0)
+#define IS_STR(r) (IS_OBJ((r)) && (r).ref.ptr.obj->type == T_STR)
+#define IS_VEC(r) (IS_OBJ((r)) && (r).ref.ptr.obj->type == T_VEC)
+#define IS_HASH(r) (IS_OBJ((r)) && (r).ref.ptr.obj->type == T_HASH)
+#define IS_CODE(r) (IS_OBJ((r)) && (r).ref.ptr.obj->type == T_CODE)
+#define IS_FUNC(r) (IS_OBJ((r)) && (r).ref.ptr.obj->type == T_FUNC)
+#define IS_CLOSURE(r) (IS_OBJ((r)) && (r).ref.ptr.obj->type == T_CLOSURE)
+#define IS_CCODE(r) (IS_OBJ((r)) && (r).ref.ptr.obj->type == T_CCODE)
+#define IS_CONTAINER(r) (IS_VEC(r)||IS_HASH(r))
+#define IS_SCALAR(r) (IS_NUM((r)) || IS_STR((r)))
+
+// This is a macro instead of a separate struct to allow compilers to
+// avoid padding. GCC on x86, at least, will always padd the size of
+// an embedded struct up to 32 bits. Doing it this way allows the
+// implementing objects to pack in 16 bits worth of data "for free".
+#define GC_HEADER \
+ unsigned char mark; \
+ unsigned char type
+
+struct naObj {
+ GC_HEADER;
+};
+
+struct naStr {
+ GC_HEADER;
+ int len;
+ unsigned char* data;
+};
+
+struct naVec {
+ GC_HEADER;
+ int size;
+ int alloced;
+ naRef* array;
+};
+
+struct HashNode {
+ naRef key;
+ naRef val;
+ struct HashNode* next;
+};
+
+struct naHash {
+ GC_HEADER;
+ int size;
+ int lgalloced;
+ struct HashNode* nodes;
+ struct HashNode** table;
+ int nextnode;
+};
+
+struct naCode {
+ GC_HEADER;
+ unsigned char* byteCode;
+ int nBytes;
+ naRef* constants;
+ int nConstants;
+ naRef srcFile;
+};
+
+struct naFunc {
+ GC_HEADER;
+ naRef code;
+ naRef closure;
+};
+
+struct naClosure {
+ GC_HEADER;
+ naRef namespace;
+ naRef next; // parent closure
+};
+
+struct naCCode {
+ GC_HEADER;
+ naCFunction fptr;
+};
+
+struct naPool {
+ int type;
+ int elemsz;
+ int nblocks;
+ struct Block* blocks;
+ int nfree; // number of entries in the free array
+ int freesz; // size of the free array
+ void** free; // pointers to usable elements
+};
+
+void naFree(void* m);
+void* naAlloc(int n);
+void naBZero(void* m, int n);
+
+int naTypeSize(int type);
+void naGarbageCollect();
+naRef naObj(int type, struct naObj* o);
+naRef naNew(naContext c, int type);
+naRef naNewCode(naContext c);
+naRef naNewClosure(naContext c, naRef namespace, naRef next);
+
+int naStr_equal(naRef s1, naRef s2);
+naRef naStr_fromnum(naRef dest, double num);
+int naStr_numeric(naRef str);
+int naStr_parsenum(char* str, int len, double* result);
+int naStr_tonum(naRef str, double* out);
+
+void naVec_init(naRef vec);
+
+int naHash_tryset(naRef hash, naRef key, naRef val); // sets if exists
+void naHash_init(naRef hash);
+
+void naGC_init(struct naPool* p, int type);
+struct naObj* naGC_get(struct naPool* p);
+int naGC_size(struct naPool* p);
+void naGC_mark(naRef r);
+void naGC_reap(struct naPool* p);
+
+void naStr_gcclean(struct naStr* s);
+void naVec_gcclean(struct naVec* s);
+void naHash_gcclean(struct naHash* s);
+
+#endif // _DATA_H
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "nasal.h"
+#include "parse.h"
+#include "code.h"
+
+// Bytecode operator to string
+char* opStringDEBUG(int op)
+{
+ static char buf[256];
+ switch(op) {
+ case OP_AND: return "AND";
+ case OP_OR: return "OR";
+ case OP_NOT: return "NOT";
+ case OP_MUL: return "MUL";
+ case OP_PLUS: return "PLUS";
+ case OP_MINUS: return "MINUS";
+ case OP_DIV: return "DIV";
+ case OP_NEG: return "NEG";
+ case OP_CAT: return "CAT";
+ case OP_LT: return "LT";
+ case OP_LTE: return "LTE";
+ case OP_GT: return "GT";
+ case OP_GTE: return "GTE";
+ case OP_EQ: return "EQ";
+ case OP_NEQ: return "NEQ";
+ case OP_EACH: return "EACH";
+ case OP_JMP: return "JMP";
+ case OP_JIFNOT: return "JIFNOT";
+ case OP_JIFNIL: return "JIFNIL";
+ case OP_FCALL: return "FCALL";
+ case OP_MCALL: return "MCALL";
+ case OP_RETURN: return "RETURN";
+ case OP_PUSHCONST: return "PUSHCONST";
+ case OP_PUSHONE: return "PUSHONE";
+ case OP_PUSHZERO: return "PUSHZERO";
+ case OP_PUSHNIL: return "PUSHNIL";
+ case OP_POP: return "POP";
+ case OP_DUP: return "DUP";
+ case OP_XCHG: return "XCHG";
+ case OP_INSERT: return "INSERT";
+ case OP_EXTRACT: return "EXTRACT";
+ case OP_MEMBER: return "MEMBER";
+ case OP_SETMEMBER: return "SETMEMBER";
+ case OP_LOCAL: return "LOCAL";
+ case OP_SETLOCAL: return "SETLOCAL";
+ case OP_NEWVEC: return "NEWVEC";
+ case OP_VAPPEND: return "VAPPEND";
+ case OP_NEWHASH: return "NEWHASH";
+ case OP_HAPPEND: return "HAPPEND";
+ case OP_LINE: return "LINE";
+ case OP_MARK: return "MARK";
+ case OP_UNMARK: return "UNMARK";
+ case OP_BREAK: return "BREAK";
+ }
+ sprintf(buf, "<bad opcode: %d>\n", op);
+ return buf;
+}
+
+// Print a bytecode operator
+void printOpDEBUG(int ip, int op)
+{
+ printf("IP: %d OP: %s\n", ip, opStringDEBUG(op));
+}
+
+// Print a naRef
+void printRefDEBUG(naRef r)
+{
+ int i;
+ if(IS_NUM(r)) {
+ printf("%f\n", r.num);
+ } else if(IS_NIL(r)) {
+ printf("<nil>\n");
+ } else if(IS_STR(r)) {
+ printf("\"");
+ for(i=0; i<r.ref.ptr.str->len; i++)
+ printf("%c", r.ref.ptr.str->data[i]);
+ printf("\"\n");
+ } else if(IS_VEC(r)) {
+ printf("<vec>\n");
+ } else if(IS_HASH(r)) {
+ printf("<hash>\n");
+ } else if(IS_FUNC(r)) {
+ printf("<func>\n");
+ } else if(IS_CLOSURE(r)) {
+ printf("DEBUG: closure object on stack!\n");
+ } else if(IS_CODE(r)) {
+ printf("DEBUG: code object on stack!\n");
+ } else printf("DEBUG ACK\n");
+}
+
+// Print the operand stack of the specified context
+void printStackDEBUG(struct Context* ctx)
+{
+ int i;
+ printf("\n");
+ for(i=ctx->opTop-1; i>=0; i--) {
+ printf("] ");
+ printRefDEBUG(ctx->opStack[i]);
+ }
+ printf("\n");
+}
+
+// Token type to string
+char* tokString(int tok)
+{
+ switch(tok) {
+ case TOK_TOP: return "TOK_TOP";
+ case TOK_AND: return "TOK_AND";
+ case TOK_OR: return "TOK_OR";
+ case TOK_NOT: return "TOK_NOT";
+ case TOK_LPAR: return "TOK_LPAR";
+ case TOK_RPAR: return "TOK_RPAR";
+ case TOK_LBRA: return "TOK_LBRA";
+ case TOK_RBRA: return "TOK_RBRA";
+ case TOK_LCURL: return "TOK_LCURL";
+ case TOK_RCURL: return "TOK_RCURL";
+ case TOK_MUL: return "TOK_MUL";
+ case TOK_PLUS: return "TOK_PLUS";
+ case TOK_MINUS: return "TOK_MINUS";
+ case TOK_NEG: return "TOK_NEG";
+ case TOK_DIV: return "TOK_DIV";
+ case TOK_CAT: return "TOK_CAT";
+ case TOK_COLON: return "TOK_COLON";
+ case TOK_DOT: return "TOK_DOT";
+ case TOK_COMMA: return "TOK_COMMA";
+ case TOK_SEMI: return "TOK_SEMI";
+ case TOK_ASSIGN: return "TOK_ASSIGN";
+ case TOK_LT: return "TOK_LT";
+ case TOK_LTE: return "TOK_LTE";
+ case TOK_EQ: return "TOK_EQ";
+ case TOK_NEQ: return "TOK_NEQ";
+ case TOK_GT: return "TOK_GT";
+ case TOK_GTE: return "TOK_GTE";
+ case TOK_IF: return "TOK_IF";
+ case TOK_ELSIF: return "TOK_ELSIF";
+ case TOK_ELSE: return "TOK_ELSE";
+ case TOK_FOR: return "TOK_FOR";
+ case TOK_FOREACH: return "TOK_FOREACH";
+ case TOK_WHILE: return "TOK_WHILE";
+ case TOK_RETURN: return "TOK_RETURN";
+ case TOK_BREAK: return "TOK_BREAK";
+ case TOK_CONTINUE: return "TOK_CONTINUE";
+ case TOK_FUNC: return "TOK_FUNC";
+ case TOK_SYMBOL: return "TOK_SYMBOL";
+ case TOK_LITERAL: return "TOK_LITERAL";
+ case TOK_EMPTY: return "TOK_EMPTY";
+ case TOK_NIL: return "TOK_NIL";
+ }
+ return 0;
+}
+
+// Diagnostic: check all list pointers for sanity
+void ack()
+{
+ printf("Bad token list!\n");
+ exit(1);
+}
+void checkList(struct Token* start, struct Token* end)
+{
+ struct Token* t = start;
+ while(t) {
+ if(t->next && t->next->prev != t) ack();
+ if(t->next==0 && t != end) ack();
+ t = t->next;
+ }
+ t = end;
+ while(t) {
+ if(t->prev && t->prev->next != t) ack();
+ if(t->prev==0 && t != start) ack();
+ t = t->prev;
+ };
+}
+
+
+// Prints a single parser token to stdout
+void printToken(struct Token* t, char* prefix)
+{
+ int i;
+ printf("%sline %d %s ", prefix, t->line, tokString(t->type));
+ if(t->type == TOK_LITERAL || t->type == TOK_SYMBOL) {
+ if(t->str) {
+ printf("\"");
+ for(i=0; i<t->strlen; i++) printf("%c", t->str[i]);
+ printf("\" (len: %d)", t->strlen);
+ } else {
+ printf("%f ", t->num);
+ }
+ }
+ printf("\n");
+}
+
+// Prints a parse tree to stdout
+void dumpTokenList(struct Token* t, int prefix)
+{
+ char prefstr[128];
+ int i;
+
+ prefstr[0] = 0;
+ for(i=0; i<prefix; i++)
+ strcat(prefstr, ". ");
+
+ while(t) {
+ printToken(t, prefstr);
+ dumpTokenList(t->children, prefix+1);
+ t = t->next;
+ }
+}
+
--- /dev/null
+#include "nasal.h"
+#include "data.h"
+
+#define MIN_BLOCK_SIZE 256
+
+// "type" for an object freed by the collector
+#define T_GCFREED 123 // DEBUG
+
+struct Block {
+ int size;
+ char* block;
+};
+
+// Decremented every allocation. When it reaches zero, we do a
+// garbage collection. The value is reset to 1/2 of the total object
+// count each collection, which is sane: it ensures that no more than
+// 50% growth can happen between collections, and ensures that garbage
+// collection work is constant with allocation work (i.e. that O(N)
+// work is done only every O(1/2N) allocations).
+static int GlobalAllocCount = 256;
+
+static void appendfree(struct naPool*p, struct naObj* o)
+{
+ // Need more space?
+ if(p->freesz <= p->nfree) {
+ int i, n = 1+((3*p->nfree)>>1);
+ void** newf = naAlloc(n * sizeof(void*));
+ for(i=0; i<p->nfree; i++)
+ newf[i] = p->free[i];
+ naFree(p->free);
+ p->free = newf;
+ p->freesz = n;
+ }
+
+ p->free[p->nfree++] = o;
+}
+
+static void naCode_gcclean(struct naCode* o)
+{
+ naFree(o->byteCode); o->byteCode = 0;
+ naFree(o->constants); o->constants = 0;
+}
+
+static void freeelem(struct naPool* p, struct naObj* o)
+{
+ // Mark the object as "freed" for debugging purposes
+ o->type = T_GCFREED; // DEBUG
+
+ // Free any intrinsic (i.e. non-garbage collected) storage the
+ // object might have
+ switch(p->type) {
+ case T_STR:
+ naStr_gcclean((struct naStr*)o);
+ break;
+ case T_VEC:
+ naVec_gcclean((struct naVec*)o);
+ break;
+ case T_HASH:
+ naHash_gcclean((struct naHash*)o);
+ break;
+ case T_CODE:
+ naCode_gcclean((struct naCode*)o);
+ break;
+ }
+
+ // And add it to the free list
+ appendfree(p, o);
+}
+
+static void newBlock(struct naPool* p, int need)
+{
+ int i;
+ char* buf;
+ struct Block* newblocks;
+
+ if(need < MIN_BLOCK_SIZE)
+ need = MIN_BLOCK_SIZE;
+
+ newblocks = naAlloc((p->nblocks+1) * sizeof(struct Block));
+ for(i=0; i<p->nblocks; i++) newblocks[i] = p->blocks[i];
+ naFree(p->blocks);
+ p->blocks = newblocks;
+ buf = naAlloc(need * p->elemsz);
+ naBZero(buf, need * p->elemsz);
+ p->blocks[p->nblocks].size = need;
+ p->blocks[p->nblocks].block = buf;
+ p->nblocks++;
+
+ for(i=0; i<need; i++) {
+ struct naObj* o = (struct naObj*)(buf + i*p->elemsz);
+ o->mark = 0;
+ o->type = p->type;
+ appendfree(p, o);
+ }
+}
+
+void naGC_init(struct naPool* p, int type)
+{
+ p->type = type;
+ p->elemsz = naTypeSize(type);
+ p->nblocks = 0;
+ p->blocks = 0;
+ p->nfree = 0;
+ p->freesz = 0;
+ p->free = 0;
+ naGC_reap(p);
+}
+
+int naGC_size(struct naPool* p)
+{
+ int i, total=0;
+ for(i=0; i<p->nblocks; i++)
+ total += ((struct Block*)(p->blocks + i))->size;
+ return total;
+}
+
+struct naObj* naGC_get(struct naPool* p)
+{
+ // Collect every GlobalAllocCount allocations.
+ // This gets set to ~50% of the total object count each
+ // collection (it's incremented in naGC_reap()).
+ if(--GlobalAllocCount < 0) {
+ GlobalAllocCount = 0;
+ naGarbageCollect();
+ }
+
+ // If we're out, then allocate an extra 12.5%
+ if(p->nfree == 0)
+ newBlock(p, naGC_size(p)/8);
+ return p->free[--p->nfree];
+}
+
+// Sets the reference bit on the object, and recursively on all
+// objects reachable from it. Clumsy: uses C stack recursion, which
+// is slower than it need be and may cause problems on some platforms
+// due to the very large stack depths that result.
+void naGC_mark(naRef r)
+{
+ int i;
+
+ if(IS_NUM(r) || IS_NIL(r))
+ return;
+
+ if(r.ref.ptr.obj->mark == 1)
+ return;
+
+ // Verify that the object hasn't been freed incorrectly:
+ if(r.ref.ptr.obj->type == T_GCFREED) *(int*)0=0; // DEBUG
+
+ r.ref.ptr.obj->mark = 1;
+ switch(r.ref.ptr.obj->type) {
+ case T_VEC:
+ for(i=0; i<r.ref.ptr.vec->size; i++)
+ naGC_mark(r.ref.ptr.vec->array[i]);
+ break;
+ case T_HASH:
+ if(r.ref.ptr.hash->table == 0)
+ break;
+ for(i=0; i < (1<<r.ref.ptr.hash->lgalloced); i++) {
+ struct HashNode* hn = r.ref.ptr.hash->table[i];
+ while(hn) {
+ naGC_mark(hn->key);
+ naGC_mark(hn->val);
+ hn = hn->next;
+ }
+ }
+ break;
+ case T_CODE:
+ naGC_mark(r.ref.ptr.code->srcFile);
+ for(i=0; i<r.ref.ptr.code->nConstants; i++)
+ naGC_mark(r.ref.ptr.code->constants[i]);
+ break;
+ case T_CLOSURE:
+ naGC_mark(r.ref.ptr.closure->namespace);
+ naGC_mark(r.ref.ptr.closure->next);
+ break;
+ case T_FUNC:
+ naGC_mark(r.ref.ptr.func->code);
+ naGC_mark(r.ref.ptr.func->closure);
+ break;
+ }
+}
+
+// Collects all the unreachable objects into a free list, and
+// allocates more space if needed.
+void naGC_reap(struct naPool* p)
+{
+ int i, elem, total = 0;
+ p->nfree = 0;
+ for(i=0; i<p->nblocks; i++) {
+ struct Block* b = p->blocks + i;
+ total += b->size;
+ for(elem=0; elem < b->size; elem++) {
+ struct naObj* o = (struct naObj*)(b->block + elem * p->elemsz);
+ if(o->mark == 0)
+ freeelem(p, o);
+ o->mark = 0;
+ }
+ }
+
+ // Add 50% of our total to the global count
+ GlobalAllocCount += total/2;
+
+ // Allocate more if necessary (try to keep 25-50% of the objects
+ // available)
+ if(p->nfree < total/4) {
+ int used = total - p->nfree;
+ int avail = total - used;
+ int need = used/2 - avail;
+ if(need > 0)
+ newBlock(p, need);
+ }
+}
+
--- /dev/null
+#include "nasal.h"
+#include "data.h"
+
+static void realloc(naRef hash)
+{
+ struct naHash* h = hash.ref.ptr.hash;
+ int i, sz, oldsz = h->size;
+ int oldcols = h->table ? 1 << h->lgalloced : 0;
+
+ // Keep a handle to our original objects
+ struct HashNode* oldnodes = h->nodes;
+ struct HashNode** oldtable = h->table;
+
+ // Figure out how big we need to be (start with a minimum size of
+ // 16 entries)
+ for(i=3; 1<<i < oldsz; i++);
+ h->lgalloced = i+1;
+
+ // Allocate new ones (note that all the records are allocated in a
+ // single chunk, to avoid zillions of tiny node allocations)
+ sz = 1<<h->lgalloced;
+ h->nodes = naAlloc(sz * (sizeof(struct HashNode) + sizeof(void*)));
+ h->table = (struct HashNode**)(((char*)h->nodes) + sz*sizeof(struct HashNode));
+ naBZero(h->table, sz * sizeof(void*));
+ h->nextnode = 0;
+ h->size = 0;
+
+ // Re-insert everything from scratch
+ for(i=0; i<oldcols; i++) {
+ struct HashNode* hn = oldtable[i];
+ while(hn) {
+ naHash_set(hash, hn->key, hn->val);
+ hn = hn->next;
+ }
+ }
+
+ // Free the old memory
+ naFree(oldnodes);
+}
+
+// Computes a hash code for a given scalar
+static unsigned int hashcode(naRef r)
+{
+ if(IS_NUM(r))
+ {
+ // Numbers get the number as a hash. Just use the bits and
+ // xor them together. Note assumption that sizeof(double) >=
+ // 2*sizeof(int).
+ unsigned int* p = (unsigned int*)&(r.num);
+ return p[0] ^ p[1];
+ } else {
+ // This is Daniel Bernstein's djb2 hash function that I found
+ // on the web somewhere. It appears to work pretty well.
+ unsigned int i, hash = 5831;
+ for(i=0; i<r.ref.ptr.str->len; i++)
+ hash = (hash * 33) ^ r.ref.ptr.str->data[i];
+ return hash;
+ }
+}
+
+// Which column in a given hash does the key correspond to.
+static unsigned int hashcolumn(struct naHash* h, naRef key)
+{
+ // Multiply by a big number, and take the top N bits. Note
+ // assumption that sizeof(unsigned int) == 4.
+ return (2654435769u * hashcode(key)) >> (32 - h->lgalloced);
+}
+
+struct HashNode* find(struct naHash* h, naRef key)
+{
+ struct HashNode* hn;
+ if(h->table == 0)
+ return 0;
+ hn = h->table[hashcolumn(h, key)];
+ while(hn) {
+ if(naEqual(key, hn->key))
+ return hn;
+ hn = hn->next;
+ }
+ return 0;
+}
+
+void naHash_init(naRef hash)
+{
+ struct naHash* h = hash.ref.ptr.hash;
+ h->size = 0;
+ h->lgalloced = 0;
+ h->table = 0;
+ h->nodes = 0;
+}
+
+// Make a temporary string on the stack
+static naRef tmpStr(struct naStr* str, char* key)
+{
+ char* p = key;
+ while(*p) { p++; }
+ str->len = p - key;
+ str->data = key;
+ return naObj(T_STR, (struct naObj*)str);
+}
+
+naRef naHash_cget(naRef hash, char* key)
+{
+ struct naStr str;
+ naRef result, key2 = tmpStr(&str, key);
+ if(naHash_get(hash, key2, &result))
+ return result;
+ return naNil();
+}
+
+void naHash_cset(naRef hash, char* key, naRef val)
+{
+ struct naStr str;
+ naRef key2 = tmpStr(&str, key);
+ naHash_tryset(hash, key2, val);
+}
+
+int naHash_get(naRef hash, naRef key, naRef* out)
+{
+ struct naHash* h = hash.ref.ptr.hash;
+ struct HashNode* n;
+ if(!IS_HASH(hash)) return 0;
+ n = find(h, key);
+ if(n) {
+ *out = n->val;
+ return 1;
+ } else {
+ *out = naNil();
+ return 0;
+ }
+}
+
+// Simpler version. Don't create a new node if the value isn't there
+int naHash_tryset(naRef hash, naRef key, naRef val)
+{
+ struct HashNode* n;
+ if(!IS_HASH(hash)) return 0;
+ n = find(hash.ref.ptr.hash, key);
+ if(n) n->val = val;
+ return n != 0;
+}
+
+void naHash_set(naRef hash, naRef key, naRef val)
+{
+ struct naHash* h = hash.ref.ptr.hash;
+ unsigned int col;
+ struct HashNode* n;
+
+ if(!IS_HASH(hash)) return;
+
+ n = find(h, key);
+ if(n) {
+ n->val = val;
+ return;
+ }
+
+ if(h->size+1 >= 1<<h->lgalloced)
+ realloc(hash);
+
+ col = hashcolumn(h, key);
+ n = h->nodes + h->nextnode++;
+ n->key = key;
+ n->val = val;
+ n->next = h->table[col];
+ h->table[col] = n;
+ h->size++;
+}
+
+// FIXME: this implementation does a realloc() after each delete, and
+// is therefore needlessly O(N). (The reason is that this avoids the
+// need to keep a free list around for the much more common case of
+// adding a new value. Modifying an existing value is O(1), of
+// course.)
+void naHash_delete(naRef hash, naRef key)
+{
+ struct naHash* h = hash.ref.ptr.hash;
+ int col;
+ struct HashNode *last=0, *hn;
+ if(!IS_HASH(hash)) return;
+ col = hashcolumn(h, key);
+ hn = h->table[col];
+ while(hn) {
+ if(naEqual(hn->key, key)) {
+ if(last == 0) h->table[col] = hn->next;
+ else last->next = hn->next;
+ h->size--;
+ realloc(hash);
+ return;
+ }
+ last = hn;
+ hn = hn->next;
+ }
+}
+
+void naHash_keys(naRef dst, naRef hash)
+{
+ struct naHash* h = hash.ref.ptr.hash;
+ int i;
+ if(!IS_HASH(hash)) return;
+ for(i=0; i<(1<<h->lgalloced); i++) {
+ struct HashNode* hn = h->table[i];
+ while(hn) {
+ naVec_append(dst, hn->key);
+ hn = hn->next;
+ }
+ }
+}
+
+int naHash_size(naRef h)
+{
+ if(!IS_HASH(h)) return 0;
+ return h.ref.ptr.hash->size;
+}
+
+void naHash_gcclean(struct naHash* h)
+{
+ naFree(h->nodes);
+ h->nodes = 0;
+ h->size = 0;
+ h->lgalloced = 0;
+ h->table = 0;
+ h->nextnode = 0;
+}
--- /dev/null
+#include "parse.h"
+
+// Static table of recognized lexemes in the language
+struct Lexeme {
+ char* str;
+ int tok;
+} LEXEMES[] = {
+ {"and", TOK_AND},
+ {"or", TOK_OR},
+ {"!", TOK_NOT},
+ {"(", TOK_LPAR},
+ {")", TOK_RPAR},
+ {"[", TOK_LBRA},
+ {"]", TOK_RBRA},
+ {"{", TOK_LCURL},
+ {"}", TOK_RCURL},
+ {"*", TOK_MUL},
+ {"+", TOK_PLUS},
+ {"-", TOK_MINUS},
+ {"/", TOK_DIV},
+ {"~", TOK_CAT},
+ {":", TOK_COLON},
+ {".", TOK_DOT},
+ {",", TOK_COMMA},
+ {";", TOK_SEMI},
+ {"=", TOK_ASSIGN},
+ {"<", TOK_LT},
+ {"<=", TOK_LTE},
+ {"==", TOK_EQ},
+ {"!=", TOK_NEQ},
+ {">", TOK_GT},
+ {">=", TOK_GTE},
+ {"nil", TOK_NIL},
+ {"if", TOK_IF},
+ {"elsif", TOK_ELSIF},
+ {"else", TOK_ELSE},
+ {"for", TOK_FOR},
+ {"foreach", TOK_FOREACH},
+ {"while", TOK_WHILE},
+ {"return", TOK_RETURN},
+ {"break", TOK_BREAK},
+ {"continue", TOK_CONTINUE},
+ {"func", TOK_FUNC}
+};
+
+// Build a table of where each line ending is
+static int* findLines(struct Parser* p)
+{
+ char* buf = p->buf;
+ int sz = p->len/10 + 16;
+ int* lines = naParseAlloc(p, (sizeof(int) * sz));
+ int i, j, n=0;
+
+ for(i=0; i<p->len; i++) {
+ // Not a line ending at all
+ if(buf[i] != '\n' && buf[i] != '\r')
+ continue;
+
+ // Skip over the \r of a \r\n pair.
+ if(buf[i] == '\r' && (i+1)<p->len && buf[i+1] == '\n') {
+ i++;
+ continue;
+ }
+ // Reallocate if necessary
+ if(n == sz) {
+ int* nl;
+ sz *= 2;
+ nl = naParseAlloc(p, sizeof(int) * sz);
+ for(j=0; j<n; j++) nl[j] = lines[j];
+ lines = nl;
+ }
+ lines[n++] = i;
+ }
+ p->lines = lines;
+ p->nLines = n;
+ return lines;
+}
+
+// What line number is the index on?
+static int getLine(struct Parser* p, int index)
+{
+ int i;
+ for(i=0; i<p->nLines; i++)
+ if(p->lines[i] > index)
+ return (p->firstLine-1) + i+1;
+ return (p->firstLine-1) + p->nLines+1;
+}
+
+static void error(struct Parser* p, char* msg, int index)
+{
+ naParseError(p, msg, getLine(p, index));
+}
+
+// End index (the newline character) of the given line
+static int lineEnd(struct Parser* p, int line)
+{
+ if(line > p->nLines) return p->len;
+ return p->lines[line-1];
+}
+
+static void newToken(struct Parser* p, int pos, int type,
+ char* str, int slen, double num)
+{
+ struct Token* tok;
+
+ tok = naParseAlloc(p, sizeof(struct Token));
+ tok->type = type;
+ tok->line = getLine(p, pos);
+ tok->str = str;
+ tok->strlen = slen;
+ tok->num = num;
+ tok->parent = &p->tree;
+ tok->next = 0;
+ tok->prev = p->tree.lastChild;
+ tok->children = 0;
+ tok->lastChild = 0;
+
+ // Context sensitivity hack: a "-" following a binary operator of
+ // higher precedence (MUL and DIV, basically) must be a unary
+ // negation. Needed to get precedence right in the parser for
+ // expressiong like "a * -2"
+ if(type == TOK_MINUS && tok->prev)
+ if(tok->prev->type == TOK_MUL || tok->prev->type == TOK_DIV)
+ tok->type = type = TOK_NEG;
+
+ if(!p->tree.children) p->tree.children = tok;
+ if(p->tree.lastChild) p->tree.lastChild->next = tok;
+ p->tree.lastChild = tok;
+}
+
+// Parse a hex nibble
+static int hexc(char c, struct Parser* p, int index)
+{
+ if(c >= '0' && c <= '9') return c - '0';
+ if(c >= 'A' && c <= 'F') return c - 'a' + 10;
+ if(c >= 'a' && c <= 'f') return c - 'a' + 10;
+ error(p, "bad hex constant", index);
+ return 0;
+}
+
+// Escape and returns a single backslashed expression in a single
+// quoted string. Trivial, just escape \' and leave everything else
+// alone.
+static void sqEscape(char* buf, int len, int index, struct Parser* p,
+ char* cOut, int* eatenOut)
+{
+ if(len < 2) error(p, "unterminated string", index);
+ if(buf[1] == '\'') {
+ *cOut = '\'';
+ *eatenOut = 2;
+ } else {
+ *cOut = '\\';
+ *eatenOut = 1;
+ }
+}
+
+// Ditto, but more complicated for double quotes.
+static void dqEscape(char* buf, int len, int index, struct Parser* p,
+ char* cOut, int* eatenOut)
+{
+ if(len < 2) error(p, "unterminated string", index);
+ *eatenOut = 2;
+ switch(buf[1]) {
+ case '"': *cOut = '"'; break;
+ case 'r': *cOut = '\r'; break;
+ case 'n': *cOut = '\n'; break;
+ case 't': *cOut = '\t'; break;
+ case '\\': *cOut = '\\'; break;
+ case 'x':
+ if(len < 4) error(p, "unterminated string", index);
+ *cOut = (char)((hexc(buf[2], p, index)<<4) | hexc(buf[3], p, index));
+ *eatenOut = 4;
+ default:
+ // Unhandled, put the backslash back
+ *cOut = '\\';
+ *eatenOut = 1;
+ }
+}
+
+// Read in a string literal
+static int lexStringLiteral(struct Parser* p, int index, int singleQuote)
+{
+ int i, j, len, iteration;
+ char* out = 0;
+ char* buf = p->buf;
+ char endMark = singleQuote ? '\'' : '"';
+
+ for(iteration = 0; iteration<2; iteration++) {
+ i = index+1;
+ j = len = 0;
+ while(i < p->len) {
+ char c = buf[i];
+ int eaten = 1;
+ if(c == endMark)
+ break;
+ if(c == '\\') {
+ if(singleQuote) sqEscape(buf+i, p->len-i, i, p, &c, &eaten);
+ else dqEscape(buf+i, p->len-i, i, p, &c, &eaten);
+ }
+ if(iteration == 1) out[j++] = c;
+ i += eaten;
+ len++;
+ }
+ // Finished stage one -- allocate the buffer for stage two
+ if(iteration == 0) out = naParseAlloc(p, len);
+ }
+ newToken(p, index, TOK_LITERAL, out, len, 0);
+ return i+1;
+}
+
+static int lexNumLiteral(struct Parser* p, int index)
+{
+ int len = p->len, i = index;
+ unsigned char* buf = p->buf;
+ double d;
+
+ while(i<len && buf[i] >= '0' && buf[i] <= '9') i++;
+ if(i<len && buf[i] == '.') {
+ i++;
+ while(i<len && buf[i] >= '0' && buf[i] <= '9') i++;
+ }
+ if(i<len && (buf[i] == 'e' || buf[i] == 'E')) {
+ i++;
+ if(i<len
+ && (buf[i] == '-' || buf[i] == '+')
+ && (i+1<len && buf[i+1] >= '0' && buf[i+1] <= '9')) i++;
+ while(i<len && buf[i] >= '0' && buf[i] <= '9') i++;
+ }
+ naStr_parsenum(p->buf + index, i - index, &d);
+ newToken(p, index, TOK_LITERAL, 0, 0, d);
+ return i;
+}
+
+static int trySymbol(struct Parser* p, int start)
+{
+ int i = start;
+ while((i < p->len) &&
+ ((p->buf[i] >= 'A' && p->buf[i] <= 'Z') ||
+ (p->buf[i] >= 'a' && p->buf[i] <= 'z') ||
+ (p->buf[i] >= '0' && p->buf[i] <= '9')))
+ { i++; }
+ return i-start;
+}
+
+// Returns the length of lexeme l if the buffer prefix matches, or
+// else zero.
+static int matchLexeme(char* buf, int len, char* l)
+{
+ int i;
+ for(i=0; i<len; i++) {
+ if(l[i] == 0) return i;
+ if(l[i] != buf[i]) return 0;
+ }
+ // Ran out of buffer. This is still OK if we're also at the end
+ // of the lexeme.
+ if(l[i] == 0) return i;
+ return 0;
+}
+
+// This is dumb and algorithmically slow. It would be much more
+// elegant to sort and binary search the lexeme list, but that's a lot
+// more code and this really isn't very slow in practice; it checks
+// every byte of every lexeme for each input byte. There are less
+// than 100 bytes of lexemes in the grammar. Returns the number of
+// bytes in the lexeme read (or zero if none was recognized)
+static int tryLexemes(struct Parser* p, int index, int* lexemeOut)
+{
+ int i, n, best, bestIndex=-1;
+ char* start = p->buf + index;
+ int len = p->len - index;
+
+ n = sizeof(LEXEMES) / sizeof(struct Lexeme);
+ best = 0;
+ for(i=0; i<n; i++) {
+ int l = matchLexeme(start, len, LEXEMES[i].str);
+ if(l > best) {
+ best = l;
+ bestIndex = i;
+ }
+ }
+ if(best > 0) *lexemeOut = bestIndex;
+ return best;
+}
+
+void naLex(struct Parser* p)
+{
+ int i = 0;
+ findLines(p);
+ while(i<p->len) {
+ char c = p->buf[i];
+
+ // Whitespace, comments and string literals have obvious
+ // markers and can be handled by a switch:
+ int handled = 1;
+ switch(c) {
+ case ' ': case '\t': case '\n': case '\r': case '\f': case '\v':
+ i++;
+ break;
+ case '#':
+ i = lineEnd(p, getLine(p, i));
+ break;
+ case '\'': case '"':
+ i = lexStringLiteral(p, i, (c=='"' ? 0 : 1));
+ break;
+ default:
+ if(c >= '0' && c <= '9') i = lexNumLiteral(p, i);
+ else handled = 0;
+ }
+
+ // Lexemes and symbols are a little more complicated. Pick
+ // the longest one that matches. Since some lexemes look like
+ // symbols (e.g. "or") they need a higher precedence, but we
+ // don't want a lexeme match to clobber the beginning of a
+ // symbol (e.g. "orchid"). If neither match, we have a bad
+ // character in the mix.
+ if(!handled) {
+ int symlen=0, lexlen=0, lexeme;
+ lexlen = tryLexemes(p, i, &lexeme);
+ if((c>='A' && c<='Z') || (c>='a' && c<='z'))
+ symlen = trySymbol(p, i);
+ if(lexlen && lexlen >= symlen) {
+ newToken(p, i, LEXEMES[lexeme].tok, 0, 0, 0);
+ i += lexlen;
+ } else if(symlen) {
+ newToken(p, i, TOK_SYMBOL, p->buf+i, symlen, 0);
+ i += symlen;
+ } else {
+ error(p, "illegal character", i);
+ }
+ }
+ }
+}
--- /dev/null
+#include "nasal.h"
+
+// No need to include <string.h> just for this:
+static int strlen(char* s)
+{
+ char* s0 = s;
+ while(*s) s++;
+ return s - s0;
+}
+
+static naRef size(naContext c, naRef args)
+{
+ naRef r;
+ if(naVec_size(args) == 0) return naNil();
+ r = naVec_get(args, 0);
+ if(naIsString(r)) return naNum(naStr_len(r));
+ if(naIsVector(r)) return naNum(naVec_size(r));
+ if(naIsHash(r)) return naNum(naHash_size(r));
+ return naNil();
+}
+
+static naRef keys(naContext c, naRef args)
+{
+ naRef v, h = naVec_get(args, 0);
+ if(!naIsHash(h)) return naNil();
+ v = naNewVector(c);
+ naHash_keys(v, h);
+ return v;
+}
+
+static naRef append(naContext c, naRef args)
+{
+ naRef v = naVec_get(args, 0);
+ naRef e = naVec_get(args, 1);
+ if(!naIsVector(v)) return naNil();
+ naVec_append(v, e);
+ return v;
+}
+
+static naRef pop(naContext c, naRef args)
+{
+ naRef v = naVec_get(args, 0);
+ if(!naIsVector(v)) return naNil();
+ return naVec_removelast(v);
+}
+
+static naRef delete(naContext c, naRef args)
+{
+ naRef h = naVec_get(args, 0);
+ naRef k = naVec_get(args, 1);
+ if(naIsHash(h)) naHash_delete(h, k);
+ return naNil();
+}
+
+static naRef intf(naContext c, naRef args)
+{
+ naRef n = naNumValue(naVec_get(args, 0));
+ if(!naIsNil(n)) n.num = (int)n.num;
+ return n;
+}
+
+static naRef num(naContext c, naRef args)
+{
+ return naNumValue(naVec_get(args, 0));
+}
+
+static naRef streq(naContext c, naRef args)
+{
+ int i;
+ naRef a = naVec_get(args, 0);
+ naRef b = naVec_get(args, 1);
+ if(!naIsString(a) || !naIsString(b)) return naNil();
+ if(naStr_len(a) != naStr_len(b)) return naNum(0);
+ for(i=0; i<naStr_len(a); i++)
+ if(naStr_data(a)[i] != naStr_data(b)[i])
+ return naNum(0);
+ return naNum(1);
+}
+
+static naRef substr(naContext c, naRef args)
+{
+ naRef src = naVec_get(args, 0);
+ naRef startR = naVec_get(args, 1);
+ naRef lenR = naVec_get(args, 2);
+ int start, len;
+ if(!naIsString(src)) return naNil();
+ startR = naNumValue(startR);
+ if(naIsNil(startR)) return naNil();
+ start = (int)startR.num;
+ if(naIsNil(lenR)) {
+ len = naStr_len(src) - start;
+ } else {
+ lenR = naNumValue(lenR);
+ if(naIsNil(lenR)) return naNil();
+ len = (int)lenR.num;
+ }
+ return naStr_substr(naNewString(c), src, start, len);
+}
+
+static naRef contains(naContext c, naRef args)
+{
+ naRef hash = naVec_get(args, 0);
+ naRef key = naVec_get(args, 1);
+ if(naIsNil(hash) || naIsNil(key)) return naNil();
+ if(!naIsHash(hash)) return naNil();
+ return naHash_get(hash, key, &key) ? naNum(1) : naNum(0);
+}
+
+static naRef typeOf(naContext c, naRef args)
+{
+ naRef r = naVec_get(args, 0);
+ char* t = "unknown";
+ if(naIsNil(r)) t = "nil";
+ else if(naIsNum(r)) t = "scalar";
+ else if(naIsString(r)) t = "scalar";
+ else if(naIsVector(r)) t = "vector";
+ else if(naIsHash(r)) t = "hash";
+ else if(naIsFunc(r)) t = "func";
+ r = naStr_fromdata(naNewString(c), t, strlen(t));
+ return r;
+}
+
+struct func { char* name; naCFunction func; };
+static struct func funcs[] = {
+ { "size", size },
+ { "keys", keys },
+ { "append", append },
+ { "pop", pop },
+ { "delete", delete },
+ { "int", intf },
+ { "num", num },
+ { "streq", streq },
+ { "substr", substr },
+ { "contains", contains },
+ { "typeof", typeOf },
+};
+
+naRef naStdLib(naContext c)
+{
+ naRef namespace = naNewHash(c);
+ int i, n = sizeof(funcs)/sizeof(struct func);
+ for(i=0; i<n; i++) {
+ naRef code = naNewCCode(c, funcs[i].func);
+ naRef name = naStr_fromdata(naNewString(c),
+ funcs[i].name, strlen(funcs[i].name));
+ naHash_set(namespace, name, naNewFunc(c, code));
+ }
+ return namespace;
+}
--- /dev/null
+#include <math.h>
+#include <string.h>
+
+#include "nasal.h"
+
+static naRef f_sin(naContext c, naRef args)
+{
+ naRef a = naNumValue(naVec_get(args, 0));
+ if(naIsNil(a))
+ naRuntimeError(c, "non numeric argument to sin()");
+ a.num = sin(a.num);
+ return a;
+}
+
+static naRef f_cos(naContext c, naRef args)
+{
+ naRef a = naNumValue(naVec_get(args, 0));
+ if(naIsNil(a))
+ naRuntimeError(c, "non numeric argument to cos()");
+ a.num = cos(a.num);
+ return a;
+}
+
+static naRef f_exp(naContext c, naRef args)
+{
+ naRef a = naNumValue(naVec_get(args, 0));
+ if(naIsNil(a))
+ naRuntimeError(c, "non numeric argument to exp()");
+ a.num = exp(a.num);
+ return a;
+}
+
+static naRef f_ln(naContext c, naRef args)
+{
+ naRef a = naNumValue(naVec_get(args, 0));
+ if(naIsNil(a))
+ naRuntimeError(c, "non numeric argument to ln()");
+ a.num = log(a.num);
+ return a;
+}
+
+static naRef f_sqrt(naContext c, naRef args)
+{
+ naRef a = naNumValue(naVec_get(args, 0));
+ if(naIsNil(a))
+ naRuntimeError(c, "non numeric argument to sqrt()");
+ a.num = sqrt(a.num);
+ return a;
+}
+
+static naRef f_atan2(naContext c, naRef args)
+{
+ naRef a = naNumValue(naVec_get(args, 0));
+ naRef b = naNumValue(naVec_get(args, 1));
+ if(naIsNil(a) || naIsNil(b))
+ naRuntimeError(c, "non numeric argument to atan2()");
+ a.num = atan2(a.num, b.num);
+ return a;
+}
+
+static struct func { char* name; naCFunction func; } funcs[] = {
+ { "sin", f_sin },
+ { "cos", f_cos },
+ { "exp", f_exp },
+ { "ln", f_ln },
+ { "sqrt", f_sqrt },
+ { "atan2", f_atan2 },
+};
+
+naRef naMathLib(naContext c)
+{
+ naRef name, namespace = naNewHash(c);
+ int i, n = sizeof(funcs)/sizeof(struct func);
+ for(i=0; i<n; i++) {
+ naRef code = naNewCCode(c, funcs[i].func);
+ naRef name = naStr_fromdata(naNewString(c),
+ funcs[i].name, strlen(funcs[i].name));
+ naHash_set(namespace, name, naNewFunc(c, code));
+ }
+
+ // Set up constants for math.pi and math.e
+ name = naStr_fromdata(naNewString(c), "pi", 2);
+ naHash_set(namespace, name, naNum(M_PI));
+
+ name = naStr_fromdata(naNewString(c), "e", 1);
+ naHash_set(namespace, name, naNum(M_E));
+
+ return namespace;
+}
--- /dev/null
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#include "nasal.h"
+#include "code.h"
+
+void naFree(void* m) { free(m); }
+void* naAlloc(int n) { return malloc(n); }
+void naBZero(void* m, int n) { memset(m, 0, n); }
+
+naRef naObj(int type, struct naObj* o)
+{
+ naRef r;
+ r.ref.reftag = NASAL_REFTAG;
+ r.ref.ptr.obj = o;
+ o->type = type;
+ return r;
+}
+
+int naTrue(naRef r)
+{
+ if(IS_NIL(r)) return 0;
+ if(IS_NUM(r)) return r.num != 0;
+ if(IS_STR(r)) return 1;
+ return 0;
+}
+
+naRef naNumValue(naRef n)
+{
+ double d;
+ if(IS_NUM(n)) return n;
+ if(IS_NIL(n)) return naNil();
+ if(IS_STR(n) && naStr_tonum(n, &d))
+ return naNum(d);
+ return naNil();
+}
+
+naRef naStringValue(naContext c, naRef r)
+{
+ if(IS_NIL(r) || IS_STR(r)) return r;
+ if(IS_NUM(r)) {
+ naRef s = naNewString(c);
+ naStr_fromnum(s, r.num);
+ return s;
+ }
+ return naNil();
+}
+
+naRef naNew(struct Context* c, int type)
+{
+ naRef result = naObj(type, naGC_get(&(c->pools[type])));
+ naVec_append(c->temps, result);
+ return result;
+}
+
+naRef naNewString(struct Context* c)
+{
+ naRef s = naNew(c, T_STR);
+ s.ref.ptr.str->len = 0;
+ s.ref.ptr.str->data = 0;
+ return s;
+}
+
+naRef naNewVector(struct Context* c)
+{
+ naRef r = naNew(c, T_VEC);
+ naVec_init(r);
+ return r;
+}
+
+naRef naNewHash(struct Context* c)
+{
+ naRef r = naNew(c, T_HASH);
+ naHash_init(r);
+ return r;
+}
+
+naRef naNewCode(struct Context* c)
+{
+ return naNew(c, T_CODE);
+}
+
+naRef naNewCCode(struct Context* c, naCFunction fptr)
+{
+ naRef r = naNew(c, T_CCODE);
+ r.ref.ptr.ccode->fptr = fptr;
+ return r;
+}
+
+naRef naNewFunc(struct Context* c, naRef code)
+{
+ naRef func = naNew(c, T_FUNC);
+ func.ref.ptr.func->code = code;
+ func.ref.ptr.func->closure = naNil();
+ return func;
+}
+
+naRef naNewClosure(struct Context* c, naRef namespace, naRef next)
+{
+ naRef closure = naNew(c, T_CLOSURE);
+ closure.ref.ptr.closure->namespace = namespace;
+ closure.ref.ptr.closure->next = next;
+ return closure;
+}
+
+naRef naNil()
+{
+ naRef r;
+ r.ref.reftag = NASAL_REFTAG;
+ r.ref.ptr.obj = 0;
+ return r;
+}
+
+naRef naNum(double num)
+{
+ naRef r;
+ r.num = num;
+ return r;
+}
+
+int naEqual(naRef a, naRef b)
+{
+ double na=0, nb=0;
+ if(IS_REF(a) && IS_REF(b) && a.ref.ptr.obj == b.ref.ptr.obj)
+ return 1; // Object identity (and nil == nil)
+ if(IS_NIL(a) || IS_NIL(b))
+ return 0;
+ if(IS_NUM(a) && IS_NUM(b) && a.num == b.num)
+ return 1; // Numeric equality
+ if(IS_STR(a) && IS_STR(b) && naStr_equal(a, b))
+ return 1; // String equality
+
+ // Numeric equality after conversion
+ if(IS_NUM(a)) { na = a.num; }
+ else if(!(IS_STR(a) && naStr_tonum(a, &na))) { return 0; }
+
+ if(IS_NUM(b)) { nb = b.num; }
+ else if(!(IS_STR(b) && naStr_tonum(b, &nb))) { return 0; }
+
+ return na == nb ? 1 : 0;
+}
+
+int naTypeSize(int type)
+{
+ switch(type) {
+ case T_STR: return sizeof(struct naStr);
+ case T_VEC: return sizeof(struct naVec);
+ case T_HASH: return sizeof(struct naHash);
+ case T_CODE: return sizeof(struct naCode);
+ case T_FUNC: return sizeof(struct naFunc);
+ case T_CLOSURE: return sizeof(struct naClosure);
+ case T_CCODE: return sizeof(struct naCCode);
+ };
+ return 0x7fffffff; // Make sure the answer is nonsense :)
+}
+
+int naIsNil(naRef r)
+{
+ return IS_NIL(r);
+}
+
+int naIsNum(naRef r)
+{
+ return IS_NUM(r);
+}
+
+int naIsString(naRef r)
+{
+ return (!IS_NIL(r))&&IS_STR(r);
+}
+
+int naIsScalar(naRef r)
+{
+ return IS_SCALAR(r);
+}
+
+int naIsVector(naRef r)
+{
+ return (!IS_NIL(r))&&IS_VEC(r);
+}
+
+int naIsHash(naRef r)
+{
+ return (!IS_NIL(r))&&IS_HASH(r);
+}
+
+int naIsFunc(naRef r)
+{
+ return (!IS_NIL(r))&&IS_FUNC(r);
+}
+
+int naIsCode(naRef r)
+{
+ return IS_CODE(r);
+}
+
+int naIsCCode(naRef r)
+{
+ return IS_CCODE(r);
+}
+
--- /dev/null
+#ifndef _NASAL_H
+#define _NASAL_H
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+// This is a nasal "reference". They are always copied by value, and
+// contain either a pointer to a garbage-collectable nasal object
+// (string, vector, hash) or a floating point number. Keeping the
+// number here is an optimization to prevent the generation of
+// zillions of tiny "number" object that have to be collected. Note
+// sneaky hack: on little endian systems, placing reftag after ptr and
+// putting 1's in the top 13 (except the sign bit) bits makes the
+// double value a NaN, and thus unmistakable (no actual number can
+// appear as a reference, and vice versa). Swap the structure order
+// on 32 bit big-endian systems. On 64 bit sytems of either
+// endianness, reftag and the double won't be coincident anyway.
+#define NASAL_REFTAG 0x7ff56789 // == 2,146,789,257 decimal
+typedef union {
+ double num;
+ struct {
+#ifdef NASAL_BIG_ENDIAN_32_BIT
+ int reftag; // Big-endian systems need this here!
+#endif
+ union {
+ struct naObj* obj;
+ struct naStr* str;
+ struct naVec* vec;
+ struct naHash* hash;
+ struct naCode* code;
+ struct naFunc* func;
+ struct naClosure* closure;
+ struct naCCode* ccode;
+ } ptr;
+#ifndef NASAL_BIG_ENDIAN_32_BIT
+ int reftag; // Little-endian and 64 bit systems need this here!
+#endif
+ } ref;
+} naRef;
+
+typedef struct Context* naContext;
+
+// The function signature for an extension function:
+typedef naRef (*naCFunction)(naContext ctx, naRef args);
+
+// All Nasal code runs under the watch of a naContext:
+naContext naNewContext();
+
+// Save this object in the context, preventing it (and objects
+// referenced by it) from being garbage collected.
+void naSave(naContext ctx, naRef obj);
+
+// Parse a buffer in memory into a code object.
+naRef naParseCode(naContext c, naRef srcFile, int firstLine,
+ char* buf, int len, int* errLine);
+
+// Binds a bare code object (as returned from naParseCode) with a
+// closure object (a hash) to act as the outer scope / namespace.
+// FIXME: this API is weak. It should expose the recursive nature of
+// closures, and allow for extracting the closure and namespace
+// information from function objects.
+naRef naBindFunction(naContext ctx, naRef code, naRef closure);
+
+// Call a code or function object with the specifed arguments "on" the
+// specified object and using the specified hash for the local
+// variables. Any of args, obj or locals may be nil.
+naRef naCall(naContext ctx, naRef func, naRef args, naRef obj, naRef locals);
+
+// Throw an error from the current call stack. This function makes a
+// longjmp call to a handler in naCall() and DOES NOT RETURN. It is
+// intended for use in library code that cannot otherwise report an
+// error via the return value, and MUST be used carefully. If in
+// doubt, return naNil() as your error condition.
+void naRuntimeError(naContext ctx, char* msg);
+
+// Call a method on an object (NOTE: func is a function binding, *not*
+// a code object as returned from naParseCode).
+naRef naMethod(naContext ctx, naRef func, naRef object);
+
+// Returns a hash containing functions from the Nasal standard library
+// Useful for passing as a namespace to an initial function call
+naRef naStdLib(naContext c);
+
+// Ditto, with math functions
+naRef naMathLib(naContext c);
+
+// Current line number & error message
+int naStackDepth(naContext ctx);
+int naGetLine(naContext ctx, int frame);
+naRef naGetSourceFile(naContext ctx, int frame);
+char* naGetError(naContext ctx);
+
+// Type predicates
+int naIsNil(naRef r);
+int naIsNum(naRef r);
+int naIsString(naRef r);
+int naIsScalar(naRef r);
+int naIsVector(naRef r);
+int naIsHash(naRef r);
+int naIsCode(naRef r);
+int naIsFunc(naRef r);
+int naIsCCode(naRef r);
+
+// Allocators/generators:
+naRef naNil();
+naRef naNum(double num);
+naRef naNewString(naContext c);
+naRef naNewVector(naContext c);
+naRef naNewHash(naContext c);
+naRef naNewFunc(naContext c, naRef code);
+naRef naNewCCode(naContext c, naCFunction fptr);
+
+// Some useful conversion/comparison routines
+int naEqual(naRef a, naRef b);
+int naTrue(naRef b);
+naRef naNumValue(naRef n);
+naRef naStringValue(naContext c, naRef n);
+
+// String utilities:
+int naStr_len(naRef s);
+char* naStr_data(naRef s);
+naRef naStr_fromdata(naRef dst, char* data, int len);
+naRef naStr_concat(naRef dest, naRef s1, naRef s2);
+naRef naStr_substr(naRef dest, naRef str, int start, int len);
+
+// Vector utilities:
+int naVec_size(naRef v);
+naRef naVec_get(naRef v, int i);
+void naVec_set(naRef vec, int i, naRef o);
+int naVec_append(naRef vec, naRef o);
+naRef naVec_removelast(naRef vec);
+
+// Hash utilities:
+int naHash_size(naRef h);
+int naHash_get(naRef hash, naRef key, naRef* out);
+naRef naHash_cget(naRef hash, char* key);
+void naHash_set(naRef hash, naRef key, naRef val);
+void naHash_cset(naRef hash, char* key, naRef val);
+void naHash_delete(naRef hash, naRef key);
+void naHash_keys(naRef dst, naRef hash);
+
+#ifdef __cplusplus
+} // extern "C"
+#endif
+#endif // _NASAL_H
--- /dev/null
+#include <setjmp.h>
+
+#include "parse.h"
+
+// Static precedence table, from low (loose binding, do first) to high
+// (tight binding, do last).
+enum { PREC_BINARY, PREC_REVERSE, PREC_PREFIX, PREC_SUFFIX };
+
+#define MAX_PREC_TOKS 5
+struct precedence {
+ int toks[MAX_PREC_TOKS];
+ int rule;
+} PRECEDENCE[] = {
+ { { TOK_SEMI, TOK_COMMA }, PREC_REVERSE },
+ { { TOK_COLON }, PREC_BINARY },
+ { { TOK_RETURN, TOK_BREAK, TOK_CONTINUE }, PREC_PREFIX },
+ { { TOK_ASSIGN }, PREC_REVERSE },
+ { { TOK_OR }, PREC_BINARY },
+ { { TOK_AND }, PREC_BINARY },
+ { { TOK_EQ, TOK_NEQ }, PREC_BINARY },
+ { { TOK_LT, TOK_LTE, TOK_GT, TOK_GTE }, PREC_BINARY },
+ { { TOK_PLUS, TOK_MINUS, TOK_CAT }, PREC_REVERSE },
+ { { TOK_MUL, TOK_DIV }, PREC_BINARY },
+ { { TOK_MINUS, TOK_NEG, TOK_NOT }, PREC_PREFIX },
+ { { TOK_LPAR, TOK_LBRA }, PREC_SUFFIX },
+ { { TOK_DOT }, PREC_BINARY },
+};
+#define PRECEDENCE_LEVELS (sizeof(PRECEDENCE)/sizeof(struct precedence))
+
+void naParseError(struct Parser* p, char* msg, int line)
+{
+ p->err = msg;
+ p->errLine = line;
+ longjmp(p->jumpHandle, 1);
+}
+
+// A "generic" (too obfuscated to describe) parser error
+static void oops(struct Parser* p, struct Token* t)
+{
+ naParseError(p, "parse error", t->line);
+}
+
+void naParseInit(struct Parser* p)
+{
+ p->buf = 0;
+ p->len = 0;
+ p->lines = 0;
+ p->nLines = 0;
+ p->chunks = 0;
+ p->chunkSizes = 0;
+ p->nChunks = 0;
+ p->leftInChunk = 0;
+ p->cg = 0;
+
+ p->tree.type = TOK_TOP;
+ p->tree.line = 1;
+ p->tree.str = 0;
+ p->tree.strlen = 0;
+ p->tree.num = 0;
+ p->tree.next = 0;
+ p->tree.prev = 0;
+ p->tree.children = 0;
+ p->tree.lastChild = 0;
+}
+
+void naParseDestroy(struct Parser* p)
+{
+ int i;
+ for(i=0; i<p->nChunks; i++) naFree(p->chunks[i]);
+ naFree(p->chunks);
+ naFree(p->chunkSizes);
+ p->buf = 0;
+}
+
+void* naParseAlloc(struct Parser* p, int bytes)
+{
+ char* result;
+
+ // Round up to 8 byte chunks for alignment
+ if(bytes & 0x7) bytes = ((bytes>>3) + 1) << 3;
+
+ // Need a new chunk?
+ if(p->leftInChunk < bytes) {
+ void* newChunk;
+ void** newChunks;
+ int* newChunkSizes;
+ int sz, i;
+
+ sz = p->len;
+ if(sz < bytes) sz = bytes;
+ newChunk = naAlloc(sz);
+
+ p->nChunks++;
+
+ newChunks = naAlloc(p->nChunks * sizeof(void*));
+ for(i=1; i<p->nChunks; i++) newChunks[i] = p->chunks[i-1];
+ newChunks[0] = newChunk;
+ naFree(p->chunks);
+ p->chunks = newChunks;
+
+ newChunkSizes = naAlloc(p->nChunks * sizeof(int));
+ for(i=1; i<p->nChunks; i++) newChunkSizes[i] = p->chunkSizes[i-1];
+ newChunkSizes[0] = sz;
+ naFree(p->chunkSizes);
+ p->chunkSizes = newChunkSizes;
+
+ p->leftInChunk = sz;
+ }
+
+ result = p->chunks[0] + p->chunkSizes[0] - p->leftInChunk;
+ p->leftInChunk -= bytes;
+ return (void*)result;
+}
+
+// Remove the child from the list where it exists, and insert it at
+// the end of the parents child list.
+static void addNewChild(struct Token* p, struct Token* c)
+{
+ if(c->prev) c->prev->next = c->next;
+ if(c->next) c->next->prev = c->prev;
+ if(c == c->parent->children)
+ c->parent->children = c->next;
+ if(c == c->parent->lastChild)
+ c->parent->lastChild = c->prev;
+ c->parent = p;
+ c->next = 0;
+ c->prev = p->lastChild;
+ if(p->lastChild) p->lastChild->next = c;
+ if(!p->children) p->children = c;
+ p->lastChild = c;
+}
+
+// Follows the token list from start (which must be a left brace of
+// some type), placing all tokens found into start's child list until
+// it reaches the matching close brace.
+static void collectBrace(struct Parser* p, struct Token* start)
+{
+ struct Token* t;
+ int closer = -1;
+ if(start->type == TOK_LPAR) closer = TOK_RPAR;
+ if(start->type == TOK_LBRA) closer = TOK_RBRA;
+ if(start->type == TOK_LCURL) closer = TOK_RCURL;
+
+ t = start->next;
+ while(t) {
+ struct Token* next;
+ switch(t->type) {
+ case TOK_LPAR: case TOK_LBRA: case TOK_LCURL:
+ collectBrace(p, t);
+ break;
+ case TOK_RPAR: case TOK_RBRA: case TOK_RCURL:
+ if(t->type != closer)
+ naParseError(p, "mismatched closing brace", t->line);
+
+ // Drop this node on the floor, stitch up the list and return
+ if(start->parent->lastChild == t)
+ start->parent->lastChild = t->prev;
+ start->next = t->next;
+ if(t->next) t->next->prev = start;
+ return;
+ }
+ // Snip t out of the existing list, and append it to start's
+ // children.
+ next = t->next;
+ addNewChild(start, t);
+ t = next;
+ }
+ naParseError(p, "unterminated brace", start->line);
+}
+
+// Recursively find the contents of all matching brace pairs in the
+// token list and turn them into children of the left token. The
+// right token disappears.
+static void braceMatch(struct Parser* p, struct Token* start)
+{
+ struct Token* t = start;
+ while(t) {
+ switch(t->type) {
+ case TOK_LPAR: case TOK_LBRA: case TOK_LCURL:
+ collectBrace(p, t);
+ break;
+ case TOK_RPAR: case TOK_RBRA: case TOK_RCURL:
+ if(start->type != TOK_LBRA)
+ naParseError(p, "stray closing brace", t->line);
+ break;
+ }
+ t = t->next;
+ }
+}
+
+// Allocate and return an "empty" token as a parsing placeholder.
+static struct Token* emptyToken(struct Parser* p)
+{
+ struct Token* t = naParseAlloc(p, sizeof(struct Token));
+ t->type = TOK_EMPTY;
+ t->line = -1;
+ t->strlen = 0;
+ t->num = 0;
+ t->str = 0;
+ t->next = t->prev = t->children = t->lastChild = 0;
+ t->parent = 0;
+ return t;
+}
+
+// Fixes up parenting for obvious parsing situations, like code blocks
+// being the child of a func keyword, etc...
+static void fixBlockStructure(struct Parser* p, struct Token* start)
+{
+ struct Token *t, *c;
+ t = start;
+ while(t) {
+ switch(t->type) {
+ case TOK_ELSE: case TOK_FUNC:
+ // These guys precede a single curly block
+ if(!t->next || t->next->type != TOK_LCURL) oops(p, t);
+ c = t->next;
+ addNewChild(t, c);
+ fixBlockStructure(p, c);
+ break;
+ case TOK_FOR: case TOK_FOREACH: case TOK_WHILE:
+ case TOK_IF: case TOK_ELSIF:
+ // Expect a paren and then a curly
+ if(!t->next || t->next->type != TOK_LPAR) oops(p, t);
+ c = t->next;
+ addNewChild(t, c);
+ fixBlockStructure(p, c);
+
+ if(!t->next || t->next->type != TOK_LCURL) oops(p, t);
+ c = t->next;
+ addNewChild(t, c);
+ fixBlockStructure(p, c);
+ break;
+ case TOK_LPAR: case TOK_LBRA: case TOK_LCURL:
+ fixBlockStructure(p, t->children);
+ break;
+ }
+ t = t->next;
+ }
+
+ // Another pass to hook up the elsif/else chains.
+ t = start;
+ while(t) {
+ if(t->type == TOK_IF) {
+ while(t->next && t->next->type == TOK_ELSIF)
+ addNewChild(t, t->next);
+ if(t->next && t->next->type == TOK_ELSE)
+ addNewChild(t, t->next);
+ }
+ t = t->next;
+ }
+
+ // And a final one to add semicolons. Always add one after
+ // for/foreach/while expressions. Add one after a function lambda
+ // if it immediately follows an assignment, and add one after an
+ // if/elsif/else if it is the first token in an expression list
+ // (i.e has no previous token, or is preceded by a ';' or '{').
+ // This mimicks common usage and avoids a conspicuous difference
+ // between this grammar and more common languages. It can be
+ // "escaped" with extra parenthesis if necessary, e.g.:
+ // a = (func { join(" ", arg) })(1, 2, 3, 4);
+ t = start;
+ while(t) {
+ int addSemi = 0;
+ switch(t->type) {
+ case TOK_IF:
+ if(!t->prev
+ || t->prev->type == TOK_SEMI
+ || t->prev->type == TOK_LCURL)
+ addSemi = 1;
+ break;
+ case TOK_FOR: case TOK_FOREACH: case TOK_WHILE:
+ addSemi = 1;
+ break;
+ case TOK_FUNC:
+ if(t->prev && t->prev->type == TOK_ASSIGN)
+ addSemi = 1;
+ break;
+ }
+ if(addSemi) {
+ struct Token* semi = emptyToken(p);
+ semi->type = TOK_SEMI;
+ semi->line = t->line;
+ semi->next = t->next;
+ semi->prev = t;
+ semi->parent = t->parent;
+ if(semi->next) semi->next->prev = semi;
+ t->next = semi;
+ t = semi; // don't bother checking the new one
+ }
+ t = t->next;
+ }
+
+}
+
+// True if the token's type exists in the precedence level.
+static int tokInLevel(struct Token* tok, int level)
+{
+ int i;
+ for(i=0; i<MAX_PREC_TOKS; i++)
+ if(PRECEDENCE[level].toks[i] == tok->type)
+ return 1;
+ return 0;
+}
+
+static int isBrace(int type)
+{
+ return type == TOK_LPAR || type == TOK_LBRA || type == TOK_LCURL;
+}
+
+static int isBlock(int t)
+{
+ return t == TOK_IF || t == TOK_ELSIF || t == TOK_ELSE
+ || t == TOK_FOR || t == TOK_FOREACH || t == TOK_WHILE
+ || t == TOK_FUNC;
+}
+
+static void precChildren(struct Parser* p, struct Token* t);
+static void precBlock(struct Parser* p, struct Token* t);
+
+static struct Token* parsePrecedence(struct Parser* p,
+ struct Token* start, struct Token* end,
+ int level)
+{
+ int rule;
+ struct Token *t, *top, *left, *right;
+ struct Token *a, *b, *c, *d; // temporaries
+
+ // This is an error. No "siblings" are allowed at the bottom level.
+ if(level >= PRECEDENCE_LEVELS && start != end)
+ oops(p, start);
+
+ // Synthesize an empty token if necessary
+ if(end == 0 && start == 0)
+ return emptyToken(p);
+
+ // Sanify the list. This is OK, since we're recursing into the
+ // list structure; stuff to the left and right has already been
+ // handled somewhere above.
+ if(end == 0) end = start;
+ if(start == 0) start = end;
+ if(start->prev) start->prev->next = 0;
+ if(end->next) end->next->prev = 0;
+ start->prev = end->next = 0;
+
+ // Single tokens parse as themselves. Recurse into braces, and
+ // parse children of block structure.
+ if(start == end) {
+ if(isBrace(start->type)) {
+ precChildren(p, start);
+ } else if(isBlock(start->type)) {
+ precBlock(p, start);
+ }
+ return start;
+ }
+
+ // A context-sensitivity: we want to parse ';' and ',' as binary
+ // operators, but want them to be legal at the beginning and end
+ // of a list (unlike, say, '+' where we want a parse error).
+ // Generate empties as necessary.
+ if(start->type == TOK_SEMI || start->type == TOK_COMMA) {
+ t = emptyToken(p);
+ start->prev = t;
+ t->next = start;
+ start = t;
+ }
+ if(end->type == TOK_SEMI || end->type == TOK_COMMA) {
+ t = emptyToken(p);
+ end->next = t;
+ t->prev = end;
+ end = t;
+ }
+
+ // Another one: the "." and (postfix) "[]/()" operators should
+ // really be the same precendence level, but the existing
+ // implementation doesn't allow for it. Bump us up a level if we
+ // are parsing for DOT but find a LPAR/LBRA at the end of the
+ // list.
+ if(PRECEDENCE[level].toks[0] == TOK_DOT)
+ if(end->type == TOK_LPAR || end->type == TOK_LBRA)
+ level--;
+
+ top = left = right = 0;
+ rule = PRECEDENCE[level].rule;
+ switch(rule) {
+ case PREC_PREFIX:
+ if(tokInLevel(start, level) && start->next) {
+ a = start->children;
+ b = start->lastChild;
+ c = start->next;
+ d = end;
+ top = start;
+ if(a) left = parsePrecedence(p, a, b, 0);
+ right = parsePrecedence(p, c, d, level);
+ }
+ break;
+ case PREC_SUFFIX:
+ if(tokInLevel(end, level) && end->prev) {
+ a = start;
+ b = end->prev;
+ c = end->children;
+ d = end->lastChild;
+ top = end;
+ left = parsePrecedence(p, a, b, level);
+ if(c) right = parsePrecedence(p, c, d, 0);
+ }
+ break;
+ case PREC_BINARY:
+ t = end->prev;
+ while(t->prev) {
+ if(tokInLevel(t, level)) {
+ a = t->prev ? start : 0;
+ b = t->prev;
+ c = t->next;
+ d = t->next ? end : 0;
+ top = t;
+ left = parsePrecedence(p, a, b, level);
+ right = parsePrecedence(p, c, d, level+1);
+ break;
+ }
+ t = t->prev;
+ }
+ break;
+ case PREC_REVERSE:
+ t = start->next;
+ while(t->next) {
+ if(tokInLevel(t, level)) {
+ a = t->prev ? start : 0;
+ b = t->prev;
+ c = t->next;
+ d = t->next ? end : 0;
+ top = t;
+ left = parsePrecedence(p, a, b, level+1);
+ right = parsePrecedence(p, c, d, level);
+ break;
+ }
+ t = t->next;
+ }
+ break;
+ }
+
+ // Found nothing, try the next level
+ if(!top)
+ return parsePrecedence(p, start, end, level+1);
+
+ if(left) {
+ left->next = right;
+ left->prev = 0;
+ left->parent = top;
+ }
+ top->children = left;
+
+ if(right) {
+ right->next = 0;
+ right->prev = left;
+ right->parent = top;
+ }
+ top->lastChild = right;
+
+ top->next = top->prev = 0;
+ return top;
+}
+
+static void precChildren(struct Parser* p, struct Token* t)
+{
+ struct Token* top = parsePrecedence(p, t->children, t->lastChild, 0);
+ t->children = top;
+ t->lastChild = top;
+}
+
+// Run a "block structure" node (if/elsif/else/for/while/foreach)
+// through the precedence parser. The funny child structure makes
+// this a little more complicated than it should be.
+static void precBlock(struct Parser* p, struct Token* block)
+{
+ struct Token* t = block->children;
+ while(t) {
+ if(isBrace(t->type))
+ precChildren(p, t);
+ else if(isBlock(t->type))
+ precBlock(p, t);
+ t = t->next;
+ }
+}
+
+naRef naParseCode(struct Context* c, naRef srcFile, int firstLine,
+ char* buf, int len, int* errLine)
+{
+ naRef codeObj;
+ struct Token* t;
+ struct Parser p;
+
+ // Catch parser errors here.
+ *errLine = 0;
+ if(setjmp(p.jumpHandle)) {
+ c->error = p.err;
+ *errLine = p.errLine;
+ return naNil();
+ }
+
+ naParseInit(&p);
+ p.context = c;
+ p.srcFile = srcFile;
+ p.firstLine = firstLine;
+ p.buf = buf;
+ p.len = len;
+
+ // Lexify, match brace structure, fixup if/for/etc...
+ naLex(&p);
+ braceMatch(&p, p.tree.children);
+ fixBlockStructure(&p, p.tree.children);
+
+ // Recursively run the precedence parser, and fixup the treetop
+ t = parsePrecedence(&p, p.tree.children, p.tree.lastChild, 0);
+ t->prev = t->next = 0;
+ p.tree.children = t;
+ p.tree.lastChild = t;
+
+ // Generate code!
+ codeObj = naCodeGen(&p, &(p.tree));
+
+ // Clean up our mess
+ naParseDestroy(&p);
+
+ return codeObj;
+}
+
+
--- /dev/null
+#ifndef _PARSE_H
+#define _PARSE_H
+
+#include <setjmp.h>
+
+#include "nasal.h"
+#include "data.h"
+#include "code.h"
+
+enum {
+ TOK_TOP=1, TOK_AND, TOK_OR, TOK_NOT, TOK_LPAR, TOK_RPAR, TOK_LBRA,
+ TOK_RBRA, TOK_LCURL, TOK_RCURL, TOK_MUL, TOK_PLUS, TOK_MINUS, TOK_NEG,
+ TOK_DIV, TOK_CAT, TOK_COLON, TOK_DOT, TOK_COMMA, TOK_SEMI,
+ TOK_ASSIGN, TOK_LT, TOK_LTE, TOK_EQ, TOK_NEQ, TOK_GT, TOK_GTE,
+ TOK_IF, TOK_ELSIF, TOK_ELSE, TOK_FOR, TOK_FOREACH, TOK_WHILE,
+ TOK_RETURN, TOK_BREAK, TOK_CONTINUE, TOK_FUNC, TOK_SYMBOL,
+ TOK_LITERAL, TOK_EMPTY, TOK_NIL
+};
+
+struct Token {
+ int type;
+ int line;
+ char* str;
+ int strlen;
+ double num;
+ struct Token* parent;
+ struct Token* next;
+ struct Token* prev;
+ struct Token* children;
+ struct Token* lastChild;
+};
+
+struct Parser {
+ // Handle to the Nasal interpreter
+ struct Context* context;
+
+ char* err;
+ int errLine;
+ jmp_buf jumpHandle;
+
+ // The parse tree ubernode
+ struct Token tree;
+
+ // The input buffer
+ char* buf;
+ int len;
+
+ // Input file parameters (for generating pretty stack dumps)
+ naRef srcFile;
+ int firstLine;
+
+ // Chunk allocator. Throw away after parsing.
+ void** chunks;
+ int* chunkSizes;
+ int nChunks;
+ int leftInChunk;
+
+ // Computed line number table for the lexer
+ int* lines;
+ int nLines;
+
+ struct CodeGenerator* cg;
+};
+
+struct CodeGenerator {
+ int lastLine;
+
+ // Accumulated byte code array
+ unsigned char* byteCode;
+ int nBytes;
+ int codeAlloced;
+
+ // Stack of "loop" frames for break/continue statements
+ struct {
+ int breakIP;
+ int contIP;
+ struct Token* label;
+ } loops[MAX_MARK_DEPTH];
+ int loopTop;
+
+ // Dynamic storage for constants, to be compiled into a static table
+ naRef consts; // index -> naRef
+ naRef interned; // naRef -> index (scalars only!)
+ int nConsts;
+};
+
+void naParseError(struct Parser* p, char* msg, int line);
+void naParseInit(struct Parser* p);
+void* naParseAlloc(struct Parser* p, int bytes);
+void naParseDestroy(struct Parser* p);
+void naLex(struct Parser* p);
+naRef naCodeGen(struct Parser* p, struct Token* tok);
+
+void naParse(struct Parser* p);
+
+
+
+#endif // _PARSE_H
--- /dev/null
+#include <math.h>
+#include <string.h>
+
+#include "nasal.h"
+#include "data.h"
+
+// The maximum number of significant (decimal!) figures in an IEEE
+// double.
+#define DIGITS 16
+
+// The minimum size we'll allocate for a string. Since a string
+// structure is already 12 bytes, and each naRef that points to it is
+// 8, there isn't much point in being stingy.
+#define MINLEN 16
+
+static int tonum(unsigned char* s, int len, double* result);
+static int fromnum(double val, unsigned char* s);
+
+int naStr_len(naRef s)
+{
+ if(!IS_STR(s)) return 0;
+ return s.ref.ptr.str->len;
+}
+
+char* naStr_data(naRef s)
+{
+ if(!IS_STR(s)) return 0;
+ return s.ref.ptr.str->data;
+}
+
+static void setlen(struct naStr* s, int sz)
+{
+ int currSz, waste;
+ sz += 1; // Allow for an extra nul terminator
+ currSz = s->len+1 < MINLEN ? MINLEN : s->len+1;
+ waste = currSz - sz; // how much extra if we don't reallocate?
+ if(s->data == 0 || waste < 0 || waste > MINLEN) {
+ naFree(s->data);
+ s->data = naAlloc(sz < MINLEN ? MINLEN : sz);
+ }
+ s->len = sz - 1;
+ s->data[s->len] = 0; // nul terminate
+}
+
+naRef naStr_fromdata(naRef dst, char* data, int len)
+{
+ if(!IS_STR(dst)) return naNil();
+ setlen(dst.ref.ptr.str, len);
+ memcpy(dst.ref.ptr.str->data, data, len);
+ return dst;
+}
+
+naRef naStr_concat(naRef dest, naRef s1, naRef s2)
+{
+ struct naStr* dst = dest.ref.ptr.str;
+ struct naStr* a = s1.ref.ptr.str;
+ struct naStr* b = s2.ref.ptr.str;
+ if(!(IS_STR(s1)&&IS_STR(s2)&&IS_STR(dest))) return naNil();
+ setlen(dst, a->len + b->len);
+ memcpy(dst->data, a->data, a->len);
+ memcpy(dst->data + a->len, b->data, b->len);
+ return dest;
+}
+
+naRef naStr_substr(naRef dest, naRef str, int start, int len)
+{
+ struct naStr* dst = dest.ref.ptr.str;
+ struct naStr* s = str.ref.ptr.str;
+ if(!(IS_STR(dest)&&IS_STR(str))) return naNil();
+ if(start + len > s->len) { dst->len = 0; dst->data = 0; return naNil(); }
+ setlen(dst, len);
+ memcpy(dst->data, s->data + start, len);
+ return dest;
+}
+
+int naStr_equal(naRef s1, naRef s2)
+{
+ struct naStr* a = s1.ref.ptr.str;
+ struct naStr* b = s2.ref.ptr.str;
+ if(a->data == b->data) return 1;
+ if(a->len != b->len) return 0;
+ if(memcmp(a->data, b->data, a->len) == 0) return 1;
+ return 0;
+}
+
+naRef naStr_fromnum(naRef dest, double num)
+{
+ struct naStr* dst = dest.ref.ptr.str;
+ unsigned char buf[DIGITS+8];
+ setlen(dst, fromnum(num, buf));
+ memcpy(dst->data, buf, dst->len);
+ return dest;
+}
+
+int naStr_parsenum(char* str, int len, double* result)
+{
+ return tonum(str, len, result);
+}
+
+int naStr_tonum(naRef str, double* out)
+{
+ return tonum(str.ref.ptr.str->data, str.ref.ptr.str->len, out);
+}
+
+int naStr_numeric(naRef str)
+{
+ double dummy;
+ return tonum(str.ref.ptr.str->data, str.ref.ptr.str->len, &dummy);
+}
+
+void naStr_gcclean(struct naStr* str)
+{
+ if(str->len > MINLEN) {
+ naFree(str->data);
+ str->data = 0;
+ }
+ str->len = 0;
+}
+
+////////////////////////////////////////////////////////////////////////
+// Below is a custom double<->string conversion library. Why not
+// simply use sprintf and atof? Because they aren't acceptably
+// platform independant, sadly. I've seen some very strange results.
+// This works the same way everywhere, although it is tied to an
+// assumption of standard IEEE 64 bit floating point doubles.
+//
+// In practice, these routines work quite well. Testing conversions
+// of random doubles to strings and back, this routine is beaten by
+// glibc on roundoff error 23% of the time, beats glibc in 10% of
+// cases, and ties (usually with an error of exactly zero) the
+// remaining 67%.
+////////////////////////////////////////////////////////////////////////
+
+// Reads an unsigned decimal out of the scalar starting at i, stores
+// it in v, and returns the next index to start at. Zero-length
+// decimal numbers are allowed, and are returned as zero.
+static int readdec(unsigned char* s, int len, int i, double* v)
+{
+ *v = 0;
+ if(i >= len) return len;
+ while(i < len && s[i] >= '0' && s[i] <= '9') {
+ *v= (*v) * 10 + (s[i] - '0');
+ i++;
+ }
+ return i;
+}
+
+// Reads a signed integer out of the string starting at i, stores it
+// in v, and returns the next index to start at. Zero-length
+// decimal numbers (and length-1 strings like '+') are allowed, and
+// are returned as zero.
+static int readsigned(unsigned char* s, int len, int i, double* v)
+{
+ double sgn=1, val;
+ if(i >= len) { *v = 0; return len; }
+ if(s[i] == '+') { i++; }
+ else if(s[i] == '-') { i++; sgn = -1; }
+ i = readdec(s, len, i, &val);
+ *v = sgn*val;
+ return i;
+}
+
+
+// Integer decimal power utility, with a tweak that enforces
+// integer-exactness for arguments where that is possible.
+static double decpow(int exp)
+{
+ double v = 1;
+ int absexp;
+ if(exp < 0 || exp >= DIGITS)
+ return pow(10, exp);
+ else
+ absexp = exp < 0 ? -exp : exp;
+ while(absexp--) v *= 10.0;
+ return v;
+}
+
+static int tonum(unsigned char* s, int len, double* result)
+{
+ int i=0, fraclen=0;
+ double sgn=1, val, frac=0, exp=0;
+
+ // Read the integer part
+ i = readsigned(s, len, i, &val);
+ if(val < 0) { sgn = -1; val = -val; }
+
+ // Read the fractional part, if any
+ if(i < len && s[i] == '.') {
+ i++;
+ fraclen = readdec(s, len, i, &frac) - i;
+ i += fraclen;
+ }
+
+ // Read the exponent, if any
+ if(i < len && (s[i] == 'e' || s[i] == 'E'))
+ i = readsigned(s, len, i+1, &exp);
+
+ // compute the result
+ *result = sgn * (val + frac * decpow(-fraclen)) * decpow(exp);
+
+ // if we didn't use the whole string, return failure
+ if(i < len) return 0;
+ return 1;
+}
+
+// Very simple positive (!) integer print routine. Puts the result in
+// s and returns the number of characters written. Does not null
+// terminate the result.
+static int decprint(int val, unsigned char* s)
+{
+ int p=1, i=0;
+ if(val == 0) { *s = '0'; return 1; }
+ while(p <= val) p *= 10;
+ p /= 10;
+ while(p > 0) {
+ int count = 0;
+ while(val >= p) { val -= p; count++; }
+ s[i++] = '0' + count;
+ p /= 10;
+ }
+ return i;
+}
+
+// Takes a positive (!) floating point numbers, and returns exactly
+// DIGITS decimal numbers in the buffer pointed to by s, and an
+// integer exponent as the return value. For example, printing 1.0
+// will result in "1000000000000000" in the buffer and -15 as the
+// exponent. The caller can then place the floating point as needed.
+static int rawprint(double val, unsigned char* s)
+{
+ int exponent = (int)floor(log10(val));
+ double mantissa = val / pow(10, exponent);
+ int i, c;
+ for(i=0; i<DIGITS-1; i++) {
+ int digit = (int)floor(mantissa);
+ s[i] = '0' + digit;
+ mantissa -= digit;
+ mantissa *= 10.0;
+ }
+ // Round (i.e. don't floor) the last digit
+ c = (int)floor(mantissa);
+ if(mantissa - c >= 0.5) c++;
+ if(c < 0) c = 0;
+ if(c > 9) c = 9;
+ s[i] = '0' + c;
+ return exponent - DIGITS + 1;
+}
+
+static int fromnum(double val, unsigned char* s)
+{
+ unsigned char raw[DIGITS];
+ unsigned char* ptr = s;
+ int exp, digs, i=0;
+
+ // Handle negatives
+ if(val < 0) { *ptr++ = '-'; val = -val; }
+
+ // Exactly an integer is a special case
+ if(val == (int)val) {
+ ptr += decprint(val, ptr);
+ *ptr = 0;
+ return ptr - s;
+ }
+
+ // Get the raw digits
+ exp = rawprint(val, raw);
+
+ // Examine trailing zeros to get a significant digit count
+ for(i=DIGITS-1; i>0; i--)
+ if(raw[i] != '0') break;
+ digs = i+1;
+
+ if(exp > 0 || exp < -(DIGITS+2)) {
+ // Standard scientific notation
+ exp += DIGITS-1;
+ *ptr++ = raw[0];
+ if(digs > 1) {
+ *ptr++ = '.';
+ for(i=1; i<digs; i++) *ptr++ = raw[i];
+ }
+ *ptr++ = 'e';
+ if(exp < 0) { exp = -exp; *ptr++ = '-'; }
+ else { *ptr++ = '+'; }
+ if(exp < 10) *ptr++ = '0';
+ ptr += decprint(exp, ptr);
+ } else if(exp < 1-DIGITS) {
+ // Fraction with insignificant leading zeros
+ *ptr++ = '0'; *ptr++ = '.';
+ for(i=0; i<-(exp+DIGITS); i++) *ptr++ = '0';
+ for(i=0; i<digs; i++) *ptr++ = raw[i];
+ } else {
+ // Integer part
+ for(i=0; i<DIGITS+exp; i++) *ptr++ = raw[i];
+ if(i < digs) {
+ // Fraction, if any
+ *ptr++ = '.';
+ while(i<digs) *ptr++ = raw[i++];
+ }
+ }
+ *ptr = 0;
+ return ptr - s;
+}
--- /dev/null
+#include "nasal.h"
+#include "data.h"
+
+static void realloc(struct naVec* v)
+{
+ int i, newsz = 1 + ((v->size*3)>>1);
+ naRef* na = naAlloc(sizeof(naRef) * newsz);
+ v->alloced = newsz;
+ for(i=0; i<v->size; i++)
+ na[i] = v->array[i];
+ naFree(v->array);
+ v->array = na;
+}
+
+void naVec_init(naRef vec)
+{
+ struct naVec* v = vec.ref.ptr.vec;
+ v->array = 0;
+ v->size = 0;
+ v->alloced = 0;
+}
+
+void naVec_gcclean(struct naVec* v)
+{
+ naFree(v->array);
+ v->size = 0;
+ v->alloced = 0;
+ v->array = 0;
+}
+
+naRef naVec_get(naRef v, int i)
+{
+ if(!IS_VEC(v)) return naNil();
+ if(i >= v.ref.ptr.vec->size) return naNil();
+ return v.ref.ptr.vec->array[i];
+}
+
+void naVec_set(naRef vec, int i, naRef o)
+{
+ struct naVec* v = vec.ref.ptr.vec;
+ if(!IS_VEC(vec) || i >= v->size) return;
+ v->array[i] = o;
+}
+
+int naVec_size(naRef v)
+{
+ if(!IS_VEC(v)) return 0;
+ return v.ref.ptr.vec->size;
+}
+
+int naVec_append(naRef vec, naRef o)
+{
+ struct naVec* v = vec.ref.ptr.vec;
+ if(!IS_VEC(vec)) return 0;
+ if(v->size >= v->alloced)
+ realloc(v);
+ v->array[v->size] = o;
+ return v->size++;
+}
+
+naRef naVec_removelast(naRef vec)
+{
+ naRef o;
+ struct naVec* v = vec.ref.ptr.vec;
+ if(!IS_VEC(vec) || v->size == 0) return naNil();
+ o = v->array[v->size - 1];
+ v->size--;
+ if(v->size < (v->alloced >> 1))
+ realloc(v);
+ return o;
+}
projects / simgear.git / commitdiff