/Lua/src/apl-lua.cpp
http://luapl.googlecode.com/ · C++ · 1406 lines · 1213 code · 113 blank · 80 comment · 212 complexity · 0769421ea2492c6cf6b88275c886d45e MD5 · raw file
- //#include "stdafx.h"
- #include <assert.h>
- #include <string>
- #include <string.h>
- #include <sstream>
- #include <vector>
- //#include <dirent.h>
- #include <errno.h>
- #include <a/k.h>
- #include <a/f.h>
- #include <a/fncdcls.h>
- //#include "Aplus.h"
-
- extern "C" {
- #include "lua.h"
- #include "lauxlib.h"
- #include "lualib.h"
- }
-
- using namespace std;
-
- //////////////////////////////////////////////////////////////////////////////
- // Forward function declarations
- //////////////////////////////////////////////////////////////////////////////
-
- extern "C" void checkmem();
- class Tok;
- static A doeval(lua_State *L,E e,bool retdata);
- static A getAObject(lua_State *L, const Tok& atok, bool reverseOrder = true);
- static A doassign(lua_State *L, E e);
- static A table2aobject(lua_State *L, int args);
-
- extern "C" A ep_alsf(A a);
- extern "C" A ep_flat(A a);
- extern "C" I ep_issf(A a);
- extern "C" A ep_imp(A a);
- extern "C" A ep_exp(A a);
- extern "C" A ep_ssr(A s, A t, A r);
- extern "C" A ep_ss(A s, A t);
-
- extern A aplus_nl;
-
- //////////////////////////////////////////////////////////////////////////////
- // A+ operator definitions
- //////////////////////////////////////////////////////////////////////////////
-
- const int op_assign = 0x04;
- const int op_brackets = 0x07;
- const int op_count = 0xA6;
- const int op_each = 0x4C;
- const int op_plus = 0x16;
- const int op_match = 0xEE;
- const int op_minus = 0x36;
- const int op_multiply = 0x1E;
- const int op_rank = 0x44;
- const int op_divide = 0x3E;
- const int op_strand = 0x3C;
-
- const int op_pow = 0x7E;
- const int op_umn = 0x36;
- const int op_le = 0x6E;
- const int op_lt = 0x4E;
-
- struct APL_OPERATOR {
- const char* name;
- unsigned int code;
- } APL_OPTABLE[] = {
- { "assigninto", 0x04 },
- { "_in", 0x116 },
- { "_and", 0x06 },
- { "_or", 0x0E },
- { "_not", 0xBE },
- { "_type", 0x0E },
- { "_unpack", 0xFE },
- { "abs", 0x46 },
- { "bag", 0x11E },
- { "bins", 0xDE },
- { "choose", 0xA6 },
- { "compress", 0x106 },
- { "concat", 0xB6 },
- { "count", 0xA6 },
- { "decode", 0xF6 },
- { "depth", 0xEE },
- { "disclose", 0x56 },
- { "div", 0x3E },
- { "drop", 0xD6 },
- { "each", 0x4C },
- { "enclose", 0x4E },
- { "equals", 0x5E },
- { "exp", 0x7E },
- { "find", 0x9E },
- { "gradeup", 0xDE },
- { "gradedown", 0xE6 },
- { "gt", 0x56 },
- { "gte", 0x76 },
- { "inner", 0x216 },
- { "innermax", 0x226 },
- { "innermin", 0x22E },
- { "laminate", 0xBE },
- { "lt", 0x4E },
- { "lte", 0x6E },
- { "log", 0x86 },
- { "match", 0xEE },
- { "mod", 0x46 },
- { "minus", 0x36 },
- { "mult", 0x1E },
- { "neg", 0x36 },
- { "outermult", 0x1ae },
- { "outerplus", 0x1a6 },
- { "outerdiv", 0x1ce },
- { "outerminus", 0x1c6 },
- { "outerequals", 0x1ee },
- { "outergte", 0x206 },
- { "outergt", 0x1e6 },
- { "outerlt", 0x1de },
- { "outerlte", 0x1fe },
- { "outermax", 0x1b6 },
- { "outermin", 0x1be},
- { "pack", 0xF6 },
- { "pi", 0x13E },
- { "plus", 0x16 },
- { "pick", 0x126 },
- { "pow", 0x7E },
- { "rake", 0x116 },
- { "rand", 0x8E },
- { "rank", 0x44 },
- { "ravel", 0xB6 },
- { "raze" , 0x126 },
- { "replicate", 0x106 },
- { "restructure", 0x136 },
- { "right", 0x24E },
- { "reverse", 0xC6 },
- { "rot", 0xC6 },
- { "shape", 0xAE},
- { "solve", 0x12E },
- { "sum", 0x186 },
- { "take", 0xCE },
- { "til", 0x9E },
- { "iota", 0x9E },
- { "transpose", 0x96 },
- { NULL, 0 }
- };
-
- static void registerOperator(lua_State *L,APL_OPERATOR* op) {
- lua_pushlightuserdata(L, (void*)op->code);
- lua_setglobal(L, op->name);
- }
-
- //////////////////////////////////////////////////////////////////////////////
- // Lua function call parsing
- //////////////////////////////////////////////////////////////////////////////
-
- enum ETokType {
- NotSet, Invalid, Null, Int, Float, Char, Operator, Function, AObject
- };
-
- class Tok
- {
- public:
- Tok();
- void Append(A aobj);
- void Append(lua_State *L, int args);
- bool CanAppend(int luatype);
- int Length() const;
- public:
- int iNumArgs;
- ETokType iType;
- long iOperator;
- vector<double> iNum;
- vector<string> iStr;
- vector<A> iA;
- };
-
- Tok::Tok() {
- // Constructor
- iNumArgs = 0;
- iOperator = 0;
- iType = NotSet;
- }
-
- int Tok::Length() const {
- // Return the number of AObjects held by the tok
- switch(iType) {
- case NotSet: return 0;
- case Invalid: return 0;
- case Null: return 0;
- case Int: return 1;
- case Float: return 1;
- case Char: return iStr.size();
- case Operator: return 1;
- case Function: return 1;
- case AObject: return iA.size();
- default:
- break;
- }
- return 0;
- }
-
- void Tok::Append(A aobj) {
- // Append an aobj
- assert((iType == AObject) || (iType == NotSet));
- if (iType==NotSet) iType = AObject;
- iA.push_back(aobj);
- }
-
- void Tok::Append(lua_State *L, int args) {
- // First arg of a new token - initialize type
- iNumArgs++;
- int luatype = lua_type(L,args);
- switch(luatype) {
- case LUA_TNIL:
- iType = Null;
- break;
- case LUA_TNUMBER: {
- if (iType==NotSet) iType = Int;
- double val = luaL_checknumber(L, args);
- iNum.push_back(val);
- if (fabs(double(int(val))-val)>CT) {
- iType = Float;
- }
-
- break;
- }
- case LUA_TBOOLEAN: {
- if (iType==NotSet) iType = Int;
- double val = lua_toboolean(L, args);
- iNum.push_back(val);
- break;
- }
- case LUA_TSTRING: {
- iType = Char;
- string val = lua_tostring(L, args);
- iStr.push_back(val);
- break;
- }
- break;
- case LUA_TTABLE: {
- iType = AObject;
- A a = table2aobject(L,args);
- iA.push_back(a);
- break;
- }
- case LUA_TFUNCTION: {
- iType = Function;
- lua_pushvalue(L, args);
- iOperator = luaL_ref(L, LUA_REGISTRYINDEX);
- break;
- }
- case LUA_TUSERDATA: {
- iType = AObject;
- void * ud = luaL_checkudata(L,args,"APLOBJ");
- iA.push_back(*(A*)ud);
- break;
- }
- case LUA_TTHREAD: {
- iType = Invalid;
- break;
- }
- case LUA_TLIGHTUSERDATA: {
- iType = Operator;
- void* ud = lua_touserdata(L,args);
- iOperator = reinterpret_cast<long>(ud);
- break;
- }
- };
- }
-
- bool Tok::CanAppend(int luatype) {
- // Return true if we can append arg to the token
- if (iType==NotSet) return true;
- if (iType==Int) return (luatype==LUA_TNUMBER || luatype==LUA_TBOOLEAN);
- if (iType==Float) return (luatype==LUA_TNUMBER || luatype==LUA_TBOOLEAN);
- if (iType==AObject) return (luatype==LUA_TUSERDATA);
- return false;
- }
-
- enum TokArgs { NoGrouping, NoAObjGrouping, Grouping };
-
- static bool tokgrouping(const Tok& tok, TokArgs dogrouping) {
- // Return true if the tok can be grouped
- if (dogrouping==Grouping) return true;
- if (dogrouping==NoGrouping) return false;
- if (dogrouping==NoAObjGrouping && tok.iType==AObject) return false;
- return true;
- }
-
- static A table2slotfiller(lua_State *L) {
- // Loop over table and create slotfiller
- vector<string> syms;
- vector<A> objs;
- int count = 0;
-
- lua_pushnil(L);
- while(lua_next(L, -2)) {
- if(lua_isstring(L,-2)) {
- string key = lua_tostring(L, -2);
- syms.push_back(key);
- } else {
- std::stringstream result;
- result << count;
- syms.push_back(result.str());
- }
- Tok arg;
- arg.Append(L,-1);
- A a = getAObject(L,arg);
- objs.push_back(a);
- count++;
- lua_pop(L, 1);
- }
- A sf = gv(Et,2);
- int size = syms.size();
- A sym = gv(Et,size);
- for(int i=0;i<size;i++) {
- sym->p[i]=MS(si(syms[i].c_str()));
- }
- A obj = gv(Et,size);
- for(int i=0;i<size;i++) {
- obj->p[i]=(I)objs[i];
- }
- sf->p[0] = (I)sym;
- sf->p[1] = (I)obj;
- return sf;
- }
-
- static A table2array(lua_State *L) {
- vector<A> objs;
- Tok tok;
- lua_pushnil(L);
- while(lua_next(L, -2)) {
- int argtype = lua_type(L,-1);
- if (tok.iType==NotSet || (tokgrouping(tok,Grouping) && tok.CanAppend(argtype))) {
- tok.Append(L,-1);
- } else {
- A a = getAObject(L,tok,false);
- objs.push_back(a);
- tok = Tok();
- tok.Append(L,-1);
- }
- lua_pop(L, 1);
- }
- A a = getAObject(L,tok,false);
- objs.push_back(a);
- int size = (int)objs.size();
- if (size==1) return a;
- a = gv(Et,size);
- for(int i=0;i<size;i++) { ((I*)(a->p))[i]=(I)objs[i]; }
- return a;
- }
-
- static A table2aobject(lua_State *L, int args) {
- // Loop over table key/value pairs
- // If first key == string -> create slotfiller
- // else create nested aobject
- lua_pushvalue(L,args);
- lua_pushnil(L);
- lua_next(L, -2);
- int keytype = lua_type(L,-2);
- lua_pop(L,2); // reset stack;
-
- A a = NULL;
- if(keytype==LUA_TSTRING) {
- a = table2slotfiller(L);
- } else {
- a = table2array(L);
-
- }
- lua_pop(L,1);
- return a;
- }
-
- static void tokenizeArgs(lua_State *L, vector<Tok>& toks, TokArgs dogrouping=Grouping) {
- // Loop through the arguments passed from Lua and create a vector of toks
- // eg: group args 1,2,3 into a single A+ int vector.
- int argsInit=lua_gettop(L);
- int args = argsInit;
- Tok tok;
- while(args>0) {
- int argtype = lua_type(L,args);
- if (tok.iType==NotSet || (tokgrouping(tok,dogrouping) && tok.CanAppend(argtype))) {
- tok.Append(L,args);
- } else {
- toks.push_back(tok);
- tok = Tok();
- tok.Append(L,args);
- }
- args--;
- }
- toks.push_back(tok);
- int argsFinal=lua_gettop(L);
- lua_pop(L, argsInit);
- }
-
- //////////////////////////////////////////////////////////////////////////////
- // Lua function call
- //////////////////////////////////////////////////////////////////////////////
- extern "C" I *Y;
- extern C* qs;
-
- extern "C"
- I luaplCallLua(A fnc, I numargs) {
- lua_State *L = (lua_State*)(fnc->i);
- int stacksize=lua_gettop(L);
- long fnref = fnc->d[0];
- lua_rawgeti(L, LUA_REGISTRYINDEX, fnref); /* push stored function */
- stacksize=lua_gettop(L);
-
- A* luaarg = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luaarg) = (A)ic((A)Y[1]);
- if(numargs>1) {
- A* luaarg2 = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luaarg2) = (A)ic((A)Y[2]);
- }
- int numresults = 1;
- stacksize=lua_gettop(L);
- int retcode = lua_pcall(L, numargs, numresults, 0);
- stacksize=lua_gettop(L);
- // luaL_unref(L, LUA_REGISTRYINDEX, fnref);
- A res = 0;
- if(retcode!=0) {
- q = 15; qs = (char*) lua_tostring(L, -1);
- } else {
- Tok tok;
- tok.Append(L,-1);
- stacksize=lua_gettop(L);
- A ret = getAObject(L,tok);
- stacksize=lua_gettop(L);
- if (QV(ret)) {
- V v = XV(ret);
- res = (A)ic((A)(v->a));
- } else {
- res = ret;
- }
- lua_pop(L, 1);
- }
- return (I)res;
- }
-
- //////////////////////////////////////////////////////////////////////////////
- // A(...) function parameter parsing
- //////////////////////////////////////////////////////////////////////////////
-
- static E newExpr(long fncode, int argCount, long a0, long a1)
- // Return an expression structure
- {
- E e=(E)(ma(2+argCount)); // 2+numArgs
- e->n=argCount;
- e->f=fncode;
- switch(argCount){
- case 0:break;
- case 1:e->a[0]=a0;break;
- default:e->a[0]=a0,e->a[1]=a1;break;
- }
- return e;
- }
-
- static A getStrand(lua_State *L, const Tok& atok, bool reverseOrder = true) {
- // Convert a tok into a tuple of A objects
- int args = atok.Length();
- E e=(E)(ma(2+args)); // 2+numArgs
- e->n=args;
- e->f=op_strand; // xli function id
- for(int i=0;i<args;i++) {
- Tok tmp;
- tmp.iType = atok.iType;
- if (tmp.iType==Char) tmp.iStr.push_back(atok.iStr[i]);
- if (tmp.iType==AObject) tmp.iA.push_back(atok.iA[i]);
- A arg = getAObject(L,tmp);
- e->a[reverseOrder ? args-i-1 : i]=(I)arg;
- }
- A res = doeval(L,(E)e,true);
- return res;
- }
-
- static A getAObject(lua_State *L, const Tok& atok, bool reverseOrder) {
- // Convert a Tok into an A object
- checkmem();
- if (atok.Length()>1 && (atok.iType==Char || atok.iType==AObject))
- return getStrand(L,atok);
-
- A a = NULL;
- switch(atok.iType) {
- case Null: {
- a = aplus_nl;
- break;
- }
- case Int: {
- unsigned int size = atok.iNum.size();
- if (size==1) {
- a = gi((I)atok.iNum[0]);
- } else {
- a = gv(It,size);
- for(unsigned int i=0;i<size;i++) { ((I*)(a->p))[(reverseOrder) ? size-i-1 : i]=(I)atok.iNum[i]; }
- }
- break;
- }
- case Float: {
- unsigned int size = atok.iNum.size();
- if (size==1) {
- a = gf(atok.iNum[0]);
- } else {
- a = gv(Ft,size);
- for(unsigned int i=0;i<size;i++) { ((F*)(a->p))[(reverseOrder) ? size-i-1 : i]=(F)atok.iNum[i]; }
- }
- break;
- }
- case Char: {
- assert(atok.iStr.size()==1);
- unsigned int size = atok.iStr[0].size();
- if (size==1) {
- a = gi(atok.iStr[0][0]);
- a->t = Ct;
- } else {
- a = gv(Ct,size);
- for(unsigned int i=0;i<size;i++) { ((C*)(a->p))[i]=(C)atok.iStr[0][i]; }
- }
- break;
- }
- case Operator:
- a = (A)atok.iOperator;
- break;
- case AObject: {
- assert(atok.iA.size()==1);
- a = (A)ic(atok.iA[0]);
- break;
- }
- case Function:
- case NotSet:
- case Invalid:
- default:
- assert(0); // should never reach here
- break;
- }
- checkmem();
- return a;
- }
-
- Tok parseGetArg(lua_State *L, int& index, const vector<Tok>& toks) {
- // Return an AObject or NULL
- Tok empty;
- if (index>=(int)toks.size()) return empty;
- Tok arg = toks[index];
- Tok next;
- if (index+1<(int)toks.size()) next = toks[index+1];
- if ((arg.iType == Operator) || (arg.iType == Function)) return empty;
- if (next.iOperator==op_rank) return empty;
- index++;
- return arg;
- }
-
- A parseGetAObj(lua_State *L, int& index, const vector<Tok>& toks) {
- // Return an AObject or NULL
- if (index>=(int)toks.size()) return NULL;
- Tok arg(parseGetArg(L,index,toks));
- if (arg.iType==NotSet) return NULL;
- A a = getAObject(L,arg);
- return a;
- }
-
- /*A evaleachfn(lua_State *L,long opcode) {
- // Evaluate opcode with each to create an executable A+ object
- E e = newExpr(op_each,1,opcode,0);
- A d = doeval(L,e,true);
- return d;
- }*/
-
- A evalrankfn(lua_State *L, Tok arg, long opcode) {
- // Evaluate opcode with each to create an executable A+ object
- A a = getAObject(L,arg);
- E e = newExpr(op_rank,2,opcode,(I)a);
- A d = doeval(L,e,true);
- return d;
- }
-
- static long getFunction(lua_State *L, const Tok& atok, int numargs) {
- // Convert a tok into a function or operator code
- A a = gv(It,3);
- a->t = 9;
- a->n = 1;
- a->r = 2;
- if (numargs>1) a->r = 3;
- (a->d[0]) = atok.iOperator; (a->d[1]) = 0; (a->d[2]) = 0;
- (a->i) = (I)L; (a->p[0]) = (I)gv(Ct,4); // dummy function name
- (a->p[1]) = 0; (a->p[2]) = 0;
- return (I)a;
- }
-
- Tok parseGetOp(lua_State *L, int& index, const vector<Tok>& toks) {
- // Return an operator or uninitialized token
- Tok arg;
- if (index>=(int)toks.size()) return arg;
- arg = toks[index];
- if ((arg.iType == Operator) || (arg.iType == Function)) {
- index++;
- if (arg.iType == Operator && arg.iOperator==op_each) {
- Tok fn = parseGetOp(L,index,toks);
- if (fn.iType==NotSet) luaL_error(L,"luAPL error: Parse - each must operate on a function");
- if (fn.iType==Function) {
- int peek = index;
- Tok nextarg = parseGetArg(L,peek,toks);
- int numargs = (nextarg.iType==NotSet) ? 1 : 2;
- fn.iOperator = getFunction(L,fn,numargs);
- }
- // arg.iOperator = (I)evaleachfn(L,fn.iOperator);
- A z = gv(Xt,0);
- z->r = 2;
- z->d[0] = op_each;
- z->d[1] = fn.iOperator;
- arg.iOperator = (I)z;
- }
- return arg;
- }
- Tok next;
- if (index+2>=(int)toks.size()) return next;
- if (toks[index+1].iOperator!=op_rank) return next;
- Tok fn = toks[index+2];
- if ((fn.iType != Operator) && (fn.iType != Function)) return next;
- if (fn.iType==Function) {
- int peek = index+3;
- Tok nextarg = parseGetArg(L,peek,toks);
- int numargs = (nextarg.iType==NotSet) ? 1 : 2;
- fn.iOperator = getFunction(L,fn,numargs);
- }
- index+=3;
- fn.iType = Operator;
- fn.iOperator = (I)evalrankfn(L,arg,fn.iOperator);
- return fn;
- }
-
- static E parsetoks(lua_State *L, int& index, const vector<Tok>& toks, E e) {
- // Create an expr from the incoming toks
-
- if (e==NULL) {
- A arg1 = parseGetAObj(L,index,toks);
- if (arg1==NULL) {
- luaL_error(L,"luAPL error: Parse - expected value as first token");
- }
- Tok op = parseGetOp(L,index,toks);
- if (op.iType==NotSet) return (E)arg1;
- A arg2 = parseGetAObj(L,index,toks);
- if (arg2==NULL) { arg2=arg1; arg1=NULL; }
- if (op.iType==Operator && op.iOperator==op_assign) { A tmp=arg2; arg2=arg1; arg1=tmp; }
- if (op.iType==Function) { op.iOperator = getFunction(L,op,(arg1)?2:1); }
- E expr = newExpr(op.iOperator,(arg1)?2:1,(I)arg2,(I)arg1);
- return (E)ME(expr);
- }
-
- Tok op = parseGetOp(L,index,toks);
- if (op.iType==NotSet) luaL_error(L,"luAPL error: Parse - expected operator or function");
- A arg1 = parseGetAObj(L,index,toks);
- if (arg1==NULL) { arg1=(A)e; e=NULL; }
- if (op.iOperator==op_assign) { I tmp=(I)e; e=(E)arg1; arg1=(A)tmp; }
- if (op.iType==Function) { op.iOperator = getFunction(L,op,(e)?2:1); }
- E expr = newExpr(op.iOperator,(e)?2:1,(I)arg1,(I)e);
- return (E)ME(expr);
- }
-
- static E parseargs(lua_State *L) {
- // Parse incoming arguments into an E
- vector<Tok> toks;
- tokenizeArgs(L,toks);
-
- E e = NULL;
- int i=0;
- while(i<(int)toks.size()) {
- e = parsetoks(L,i,toks,e);
- }
- return e;
- }
-
- static A doeval(lua_State *L,E e,bool retdata=true) {
- // Evaluate an A+ expression under a protective "do"
- // Recursively frees the expr structure e
- checkmem();
- E e0=(E)(ma(3));
- e0->n=1;
- e0->f=(I)aplus_pi((char *)"do");
- e0->a[0]=ME(e);
- A result=(A)ez(ME(e0));
- A rc=(A)result->p[0];
- A data=(A)result->p[1];
- checkmem();
- ef(ME(e0));
- checkmem();
- if ( 0 == rc->p[0] )
- {
- if(retdata) ic(data);
- dc(result);
- if(retdata) return data;
- return 0;
- }
- string errname((qs)? qs : (char*)(data->p));
- int errcode = *(int*)rc->p;
- dc(result);
- luaL_error(L,"luAPL error %d: %s",errcode, errname.c_str());
- return 0;
- }
-
- static A doassign(lua_State *L, E e) {
- // Evaluate an A+ expression and assign the result to a new variable
- E e1=(E)(ma(4));
- e1->n=2;
- e1->f=op_assign;
- V v=(V)malloc(sizeof(struct _v));memset(v,0,sizeof(struct _v));
- e1->a[0]=MV(v);
- e1->a[1]=ME(e);
- doeval(L,e1,false);
- return (A)MV(v);
- }
-
- static int assigninto(lua_State *L) {
- // Update the value of a variable
- E e = parseargs(L);
- doeval(L,(E)e,false);
- return 0;
- }
-
- int assign(lua_State *L) {
- // Evaluate an expression and assign the result to a variable
- E e = parseargs(L);
- A res = NULL;
- if (QE(e)) {
- res = doassign(L,e);
- } else if (QV(e)) {
- V v=(V)malloc(sizeof(struct _v));memset(v,0,sizeof(struct _v));
- v->a = ic((A)XV(e)->a);
- res = (A)MV(v);
- } else {
- V v=(V)malloc(sizeof(struct _v));memset(v,0,sizeof(struct _v));
- v->a = (I)e;
- res = (A)MV(v);
- }
- A* luares = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = res;
- return 1;
- }
-
- static A getA(lua_State *L) {
- // Pull an A+ object off the lua stack
- A a = *(A*)luaL_checkudata(L, 1, "APLOBJ");
- if(QV(a)) a = (A)XV(a)->a;
- return a;
- }
-
- static int debug(lua_State *L) {
- // Hit a breakpoint in the debugger
- return 0;
- }
-
- static int sqrBrackets(lua_State *L) {
- // Evaluate x[...] and return a value
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoAObjGrouping);
- A a = getAObject(L,toks[0]); if(QV(a)) a = (A)ic((A)XV(a)->a);
- A x = getAObject(L,toks[1]);
- int n=2;
- if (a->t==Et) n = 1+a->n;
- E e1=newExpr(op_brackets,n,(I)x,(I)a);
- if (a->t==Et) {
- for(int i=0;i<a->n;i++) {
- ((I*)(e1->a))[i+1] = ic((A)(a->p)[i]);
- }
- dc(a);
- }
- A res = doeval(L,e1);
- A* luares = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = res;
- return 1;
- }
-
- static int assign2SqrBrackets(lua_State *L) {
- // Evaluate x[...] and return a value
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- A a = getAObject(L,toks[1]);
- A x = getAObject(L,toks[2]);
- A v = getAObject(L,toks[0]);
- E e1=newExpr(op_brackets,2,(I)x,(I)a);
- E e2=newExpr(op_assign,2,ME(e1),(I)v);
- A res = doeval(L,e2);
- A* luares = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = res;
- return 1;
- }
-
- namespace AFn {
-
- // forward declarations
- static bool pushValue(lua_State *L, A a);
-
- static int type2str(lua_State *L) {
- // Return the type of the A object
- A a = getA(L);
- const char* typestr = NULL;
- switch(a->t) {
- case It: typestr = "INT"; break;
- case Ft: typestr = "FLOAT"; break;
- case Ct: typestr = "CHAR"; break;
- case Et: typestr = sym(a)?"SYMBOL":"NESTED"; break;
- case Xt: typestr = "FUNCTION"; break;
- default: typestr = "UNKNOWN"; break;
- }
- lua_pushstring(L,typestr);
- return 1;
- }
-
- static bool pushNumberRecursive(lua_State *L, int rank, int& index, A a) {
- if (rank<=1) {
- if (index>=a->n) return false;
- if (a->t==It) {
- lua_pushinteger(L,((I*)a->p)[index]);
- } else {
- lua_pushnumber(L,((F*)a->p)[index]);
- }
- index++;
- return true;
- }
- lua_newtable(L);
- int size = a->d[a->r-rank+1];
- rank-=1;
- for(int i=0;i<size;i++) {
- bool dopush = pushNumberRecursive(L,rank,index,a);
- if (dopush) lua_rawseti(L,-2,i+1);
- }
- return true;
- }
-
- static bool pushNumber(lua_State *L, A a) {
- int n = a->n;
- if(n==0) return false;
- if(n==1) {
- if (a->t==It) {
- lua_pushinteger(L,*(I*)a->p);
- } else {
- lua_pushnumber(L,*(F*)a->p);
- }
- return true;
- }
- int rank = a->r;
- int index = 0;
- lua_newtable(L);
- int size = (rank<=1) ? a->n : a->d[0];
- for(int i=0;i<size;i++) {
- bool dopush = pushNumberRecursive(L,rank,index,a);
- if (dopush) lua_rawseti(L,-2,i+1);
- }
- return true;
- }
-
- static bool pushStringRecursive(lua_State *L, int rank, int& index, A a) {
- if (rank<=0) return false;
- if (rank==1) {
- int lim = a->d[a->r-2];
- int step = a->d[a->r-1];
- for(int i=0;i<lim;i++) {
- lua_pushlstring(L,(char*)a->p+index,step);
- index+=step;
- lua_rawseti(L,-2,i+1);
- }
- return false;
- }
-
- lua_newtable(L);
- int size = a->d[a->r-rank];
- rank-=1;
- for(int i=0;i<size;i++) {
- bool dopush = pushStringRecursive(L,rank,index,a);
- if (dopush) lua_rawseti(L,-2,i+1);
- }
- return true;
- }
-
- static bool pushString(lua_State *L, A a) {
- // return a string value to lua
- if (a->n==0) return false;
- if (a->r<=1) {
- lua_pushlstring(L,(char*)a->p,a->n);
- return true;
- }
- int rank = a->r;
- int index = 0;
- lua_newtable(L);
- for(int i=0;i<a->d[0];i++) {
- bool dopush = pushStringRecursive(L,--rank,index,a);
- if (dopush) lua_rawseti(L,-2,i+1);
- }
- return true;
- }
-
- static bool pushNestedRecursive(lua_State *L, int rank, int& index, A a) {
- if (rank<=1) {
- if (index>=a->n) return false;
- return pushValue(L,((A*)a->p)[index++]);
- }
- lua_newtable(L);
- int size = a->d[a->r-rank+1];
- rank-=1;
- for(int i=0;i<size;i++) {
- bool dopush = pushNestedRecursive(L,rank,index,a);
- if (dopush) lua_rawseti(L,-2,i+1);
- }
- return true;
- }
-
- static bool pushNested(lua_State *L, A a) {
- int rank = a->r;
- int index = 0;
- if (a->n==0) return false;
- lua_newtable(L);
- int size = (rank<=1) ? a->n : a->d[0];
- for(int i=0;i<size;i++) {
- bool dopush = pushNestedRecursive(L,rank,index,a);
- if (dopush) lua_rawseti(L,-2,i+1);
- }
- return true;
- }
-
- static bool pushSf(lua_State *L, A a) {
- // loop over syms - push key / value
- lua_newtable(L);
- A syms = (A)a->p[0];
- A vals = (A)a->p[1];
- int n = syms->n;
- for(int i=0;i<n;i++) {
- S s = XS(syms->p[i]);
- lua_pushstring(L,s->n);
- bool dopush = pushValue(L,(A)vals->p[i]);
- assert(dopush);
- lua_rawset(L, -3);
- }
- return true;
- }
-
- static bool pushValue(lua_State *L, A a) {
- if (QV(a)) a = (A)(XV(a)->a);
- switch(a->t) {
- case It: if (a->n==0) break; return pushNumber(L,a);
- case Ft: if (a->n==0) break; return pushNumber(L,a);
- case Ct: if (a->n==0) break; return pushString(L,a);
- case Et: if (a->n==0) break; if (ep_issf(a)) { return pushSf(L,a); } else { return pushNested(L,a); }
- case Xt: break;
- default: break;
- }
- return false;
- }
-
- static int value(lua_State *L) {
- A a = getA(L);
- bool dopush = pushValue(L,a);
- if (dopush) return 1;
- return 0;
- }
-
- static void addnewlines(A ct, string& str, const string& prefix, int offset) {
- // Convert an object to string - add newlines
- I d[9];
- mv(d,ct->d,ct->r);
- int k=ct->r-1;
- while(--k) { d[k]*=d[k+1]; }
-
- int an = ct->n;
- int step = ct->d[ct->r-1];
- int i = offset;
- if(an-i-step>0) {
- for(k=ct->r;--k&&!((an-i-step)%d[k]);) { str.append("\n"); str.append(prefix); }
- }
- }
-
- static string convert2str(A ct, const string& prefix) {
- // Convert an aobject to string
- string str;
- int an = ct->n;
- int step = ct->d[ct->r-1];
- for (int i=0;i<an;i+=step) {
- str.append(((C*)(ct->p))+i,step);
- addnewlines(ct,str,prefix,i);
- }
- return str;
- }
-
- static void nestedobj2string(A a, int& nestLevel, string& str) {
- // Convert a nested A object to a string
- int n = a->n;
- const char* prefix = "< ";
- const char* spaces = " ";
- for (int i=0; i<n; i++) {
- A a1 = (A)(a->p[i]);
- int localnest = nestLevel;
- if(a1->t==Et && !sym(a1)) {
- localnest++;
- nestedobj2string(a1,localnest,str);
- if(a->r>1) addnewlines(a,str,"",i);
- } else {
- A ct = (A)mth(a1);
- if (i==0) {
- for(int jj=0;jj<nestLevel;jj++) str.append(prefix);
- } else {
- for(int jj=0;jj<nestLevel-1;jj++) str.append(spaces);
- str.append(prefix);
- }
- if (ct->r>1) {
- string prefix2;
- for(int jj=0;jj<nestLevel;jj++) prefix2.append(spaces);
- str.append(convert2str(ct,prefix2).c_str());
- } else {
- str.append((C*)ct->p,ct->n);
- }
- str.append("\n");
- dc(ct);
- }
- }
- }
-
- static int collectgarbage(lua_State *L) {
- // Decrement a ref count on the A+ obj
- checkmem();
- void * ud = lua_touserdata(L,1);
- A a = *(A*)ud;
- if (QA(a)) {
- dc(a);
- } else if (QV(a)) {
- V v = XV(*(V*)(ud));
- if (v) {
- if(v->a) dc((A)v->a);
- free(v);
- }
- } else {
- luaL_error(L,"Error - freeing unknown var type");
- }
- checkmem();
- return 0;
- }
-
- static int unaryminus(lua_State *L) {
- // Evaluate fncode on the incoming args
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- Tok tmp = toks[1]; // Only first arg is valid
- toks.clear();
- toks.push_back(tmp);
- E e=(E)(ma(2+toks.size())); // 2+numArgs
- e->n=toks.size();
- e->f=op_umn;
- int size = toks.size();
- for(int i=0; i<size;i++) {
- A arg = getAObject(L,toks[i]);
- e->a[size-i-1]=(I)arg;
- }
- A res = doassign(L,(E)e);
- A* luares = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = res;
- return 1;
- }
-
- static int inlineop(lua_State *L, long fncode) {
- // Evaluate fncode on the incoming args
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- E e=(E)(ma(2+toks.size())); // 2+numArgs
- e->n=toks.size();
- e->f=fncode;
- int size = toks.size();
- for(int i=0; i<size;i++) {
- A arg = getAObject(L,toks[i]);
- e->a[size-i-1]=(I)arg;
- }
- A res = doassign(L,(E)e);
- A* luares = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = res;
- return 1;
- }
-
- static int plus(lua_State *L) { return inlineop(L,op_plus); }
- static int minus(lua_State *L) { return inlineop(L,op_minus); }
- static int multiply(lua_State *L) { return inlineop(L,op_multiply); }
- static int divide(lua_State *L) { return inlineop(L,op_divide); }
- static int power(lua_State *L) { return inlineop(L,op_pow); }
- static int lessthaneq(lua_State *L) { return inlineop(L,op_le); }
- static int lessthan(lua_State *L) { return inlineop(L,op_lt); }
- static int strand(lua_State *L) { return inlineop(L,op_strand); }
-
- static int equals(lua_State *L) {
- // Return the value of the A+ operator "match" - either true or false
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- E e=(E)(ma(2+toks.size())); // 2+numArgs
- e->n=toks.size();
- e->f=op_match;
- int size = toks.size();
- for(int i=0; i<size;i++) {
- A arg = getAObject(L,toks[i]);
- e->a[size-i-1]=(I)arg;
- }
- A res = doeval(L,(E)e);
- lua_pushboolean(L, res->p[0]);
- dc(res);
- return 1;
- }
-
- static int length(lua_State *L) {
- // Count - returns the length of the array
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- E e=(E)(ma(2+1)); // 2+numArgs
- e->n=1;
- e->f=op_count;
- e->a[0] = (I)getAObject(L,toks[1]); // First token passed in is a Null (?)
- A res = doeval(L,(E)e);
- lua_pushinteger(L, res->p[0]);
- dc(res);
- return 1;
- }
-
- static int symbol(lua_State *L) {
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- int size = toks.size();
- A z = gv(Et,size);
- if (size==1) z->r=0;
- for(int i=0;i<size;i++) {
- assert((toks[i].iType==Char) && toks[i].iStr.size()==1);
- z->p[size-i-1]=MS(si(toks[i].iStr[0].c_str()));
- }
- A* luares = (A*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = z;
- return 1;
- }
-
- static int newindex(lua_State *L) {
- if (lua_type(L,2) == LUA_TSTRING) {
- lua_pushnil(L);
- return 1;
- }
- return assign2SqrBrackets(L);
- }
-
- typedef A (*AFnPtr)(A);
-
- static int inlinefunc(lua_State *L, AFnPtr fn) {
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- Tok tuple;
- for(unsigned int i=0; i<toks.size(); i++) {
- if ((fn==ep_alsf) && (i%2!=0) && (toks[i].iType==Char) && (toks[i].iStr.size()==1)) {
- A z = gv(Et,1);
- z->p[0]=MS(si(toks[i].iStr[0].c_str()));
- toks[i].iType = AObject;
- toks[i].iA.push_back(z);
- }
- tuple.Append(getAObject(L,toks[i]));
- }
- A a = getAObject(L,tuple);
- if (QV(a)) a = (A)((V)XV(a))->a;
- A sf = fn(a);
- if (q!=0) {
- string errname((qs)? qs : "");
- int errcode = q;
- luaL_error(L,"luAPL error %d: %s",errcode, errname.c_str());
- return 0;
- }
- V v=(V)malloc(sizeof(struct _v));memset(v,0,sizeof(struct _v));
- v->a = (I)sf;
- I* luares = (I*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = MV(v);
- return 1;
- }
-
- static int alsf(lua_State *L) { return inlinefunc(L,ep_alsf); }
- static int flat(lua_State *L) { return inlinefunc(L,ep_flat); }
- static int sysexp(lua_State *L) { return inlinefunc(L,ep_exp); }
- static int sysimp(lua_State *L) { return inlinefunc(L,ep_imp); }
-
-
- static int ssr(lua_State *L) {
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- A s = getAObject(L,toks[2]);
- A t = getAObject(L,toks[1]);
- A r = getAObject(L,toks[0]);
- if (QV(s)) s = (A)((V)XV(s))->a;
- if (QV(t)) t = (A)((V)XV(t))->a;
- if (QV(r)) r = (A)((V)XV(r))->a;
- A sf = ep_ssr(s,t,r);
- if (q!=0) {
- string errname((qs)? qs : "");
- int errcode = q;
- luaL_error(L,"luAPL error %d: %s",errcode, errname.c_str());
- return 0;
- }
- V v=(V)malloc(sizeof(struct _v));memset(v,0,sizeof(struct _v));
- v->a = (I)sf;
- I* luares = (I*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = MV(v);
- return 1;
- }
-
- static int ss(lua_State *L) {
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- A s = getAObject(L,toks[1]);
- A t = getAObject(L,toks[0]);
- if (QV(s)) s = (A)((V)XV(s))->a;
- if (QV(t)) t = (A)((V)XV(t))->a;
- A sf = ep_ss(s,t);
- if (q!=0) {
- string errname((qs)? qs : "");
- int errcode = q;
- luaL_error(L,"luAPL error %d: %s",errcode, errname.c_str());
- return 0;
- }
- V v=(V)malloc(sizeof(struct _v));memset(v,0,sizeof(struct _v));
- v->a = (I)sf;
- I* luares = (I*) lua_newuserdata(L, sizeof(A));
- luaL_getmetatable(L, "APLOBJ");
- lua_setmetatable(L, -2);
- (*luares) = MV(v);
- return 1;
- }
-
- static int issf(lua_State *L) {
- vector<Tok> toks;
- tokenizeArgs(L,toks,NoGrouping);
- A a = getAObject(L,toks[0]);
- if (QV(a)) a = (A)((V)XV(a))->a;
- I res = ep_issf(a);
- if (q!=0) {
- string errname((qs)? qs : "");
- int errcode = q;
- luaL_error(L,"luAPL error %d: %s",errcode, errname.c_str());
- return 0;
- }
- lua_pushinteger(L,res);
- return 1;
- }
-
- int tostring(lua_State *L) {
- // Convert an A object to a string
- A a = getA(L);
- A ct = NULL;
- if (a->t==Et && !sym(a)) {
- int nestLevel = 1;
- string str="";
- AFn::nestedobj2string(a,nestLevel,str);
- str.resize(str.size()-1); // remove trailing \n
- lua_pushstring(L,str.c_str());
- } else {
- ct = (A)mth(a);
- string str;
- if (ct->r>1) {
- str = AFn::convert2str(ct,"");
- } else {
- str.append((C*)ct->p,ct->n);
- }
-
- lua_pushstring(L,str.c_str());
- dc(ct);
- }
- return 1;
- }
-
- static int index(lua_State *L) {
- // Call a method or evaluate square brackets on an aobject eg: x[0]
- if (lua_type(L,2) == LUA_TSTRING) {
- const char *key;
- size_t ksize;
- key = lua_tolstring(L,2,&ksize);
- if (strcmp(key,"value") == 0) {
- lua_pushcfunction(L,AFn::value);
- return 1;
- }
- if (strcmp(key,"type") == 0) {
- lua_pushcfunction(L,AFn::type2str);
- return 1;
- }
- if (strcmp(key,"tostring") == 0) {
- lua_pushcfunction(L,AFn::tostring);
- return 1;
- }
- }
- return sqrBrackets(L);
- }
-
- } // namespace AFn
-
- extern "C"
- const struct luaL_reg luapl [] = {
- {"export", AFn::sysexp},
- {"import", AFn::sysimp},
- {"assign", assign},
- {"debug", debug},
- {"alsf", AFn::alsf},
- {"assigninto", assigninto},
- {"flat", AFn::flat},
- {"issf", AFn::issf},
- {"strand", AFn::strand},
- {"symbol", AFn::symbol},
- {"ssr",AFn::ssr},
- {"ss",AFn::ss},
- {NULL, NULL} /* sentinel */
- };
-
- #ifdef _WIN32
- #define EXPORT __declspec(dllexport)
- #else
- #define EXPORT
- #endif
-
- extern "C"
- void aplus_main(long argc, char** argv);
-
- #ifndef _WIN32
- void checkmem() {
-
- }
- #endif
-
- extern "C"
- EXPORT int luaopen_luapl (lua_State *L) {
- const char* apldir = "./apl";
- aplus_main(1, (char**)&apldir);
- luaL_newmetatable(L, "APLOBJ");
-
- lua_pushstring(L, "__index");
- lua_pushcfunction(L, AFn::index);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__newindex");
- lua_pushcfunction(L, AFn::newindex);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__gc");
- lua_pushcfunction(L, AFn::collectgarbage);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__add");
- lua_pushcfunction(L, AFn::plus);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__sub");
- lua_pushcfunction(L, AFn::minus);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__mul");
- lua_pushcfunction(L, AFn::multiply);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__div");
- lua_pushcfunction(L, AFn::divide);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__pow");
- lua_pushcfunction(L, AFn::power);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__unm");
- lua_pushcfunction(L, AFn::unaryminus);
- lua_settable(L, -3);
-
- /* - broken only work if both args are userdata and returns a boolean.
- lua_pushstring(L, "__lt");
- lua_pushcfunction(L, AFn::lessthan);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__le");
- lua_pushcfunction(L, AFn::lessthaneq);
- lua_settable(L, -3);
- */
-
- lua_pushstring(L, "__eq");
- lua_pushcfunction(L, AFn::equals);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__len");
- lua_pushcfunction(L, AFn::length);
- lua_settable(L, -3);
-
- lua_pushstring(L, "__tostring");
- lua_pushcfunction(L, AFn::tostring);
- lua_settable(L, -3);
-
- int i = 0;
- while (APL_OPTABLE[i].name != NULL)
- registerOperator(L,&APL_OPTABLE[i++]);
-
- luaL_openlib(L, "luapl", luapl, 0);
- return 1;
- }