Ben / Nujel

/* Nujel - Copyright (C) 2020-2022 - Benjamin Vincent Schulenburg
 * This project uses the MIT license, a copy should be included under /LICENSE */
#ifndef NUJEL_AMALGAMATION
#include "../nujel-private.h"
#endif

#include <time.h>
#include <inttypes.h>

static lVal *lTreeAddSymbolsToList(const lTree *t, lVal *list){
	if(unlikely((t == NULL) || (t->key == NULL))){return list;}
	list = lTreeAddSymbolsToList(t->right, list);
	list = lCons(lValSymS(t->key), list);
	return lTreeAddSymbolsToList(t->left, list);
}

static lVal *lSymbolTable(lClosure *c, lVal *ret){
	if(unlikely(c == NULL)){return ret;}
	return lSymbolTable(c->parent, lTreeAddSymbolsToList(c->data, ret));
}

static lVal *lnfSymbolTable(lClosure *c, lVal *v){
	(void)v;
	return lSymbolTable(c, NULL);
}

static lVal *lnfClosureParent(lClosure *c, lVal *v){
	lClosure *cc = requireClosure(c, lCar(v));
	if(cc->parent == NULL){
		return NULL;
	}else{
		lVal *ret = lValAlloc(cc->parent->type == closureObject ? ltEnvironment : ltLambda);
		ret->vClosure = cc->parent;
		return ret;
	}
}

static lVal *lnfClosureCaller(lClosure *c, lVal *v){
	lClosure *cc = requireClosure(c, lCar(v));
	if((cc == NULL) || (cc->caller == NULL)){
		return NULL;
	}else{
		lVal *ret = lValAlloc(cc->caller->type == closureObject ? ltEnvironment : ltLambda);
		ret->vClosure = cc->caller;
		return ret;
	}
}

static lVal *lnfClosureArguments(lClosure *c, lVal *v){
	lVal *cc = requireCallable(c, lCar(v));
	if(cc->type == ltNativeFunc){
		return cc->vNFunc->args;
	}else{
		return cc->vClosure->args;
	}
}

static lVal *lnfClosureCode(lClosure *c, lVal *v){
	lClosure *clo = requireClosure(c, lCar(v));
	lVal *text = lValAlloc(ltBytecodeArr);
	text->vBytecodeArr = clo->text;
	return text;
}

static lVal *lnfClosureData(lClosure *c, lVal *v){
	lClosure *clo = requireClosure(c, lCar(v));
	return clo ? lValTree(clo->data) : NULL;
}

static lVal *lnfClosureName(lClosure *c, lVal *v){
	lVal *cc = requireCallable(c, lCar(v));
	return lValSymS((cc->type == ltNativeFunc) ? cc->vNFunc->name : cc->vClosure->name);
}

static lVal *lnfDefIn(lClosure *c, lVal *v){
	const lSymbol *sym = requireSymbol(c, lCadr(v));
	lVal *env = lCar(v);
	if(!env || ((env->type != ltLambda) && (env->type != ltEnvironment))){
		lExceptionThrowValClo("invalid-environment", "You can only resolve symbols in Lambdas or Objects", env, c);
	}
	lDefineClosureSym(env->vClosure, sym, lCaddr(v));
	return env;
}

static lVal *lnfResolve(lClosure *c, lVal *v){
	const lSymbol *sym = requireSymbol(c, lCar(v));
	lVal *env = lCadr(v);
	if(env && (env->type != ltLambda) && (env->type != ltEnvironment)){
		lExceptionThrowValClo("invalid-environment", "You can only resolve symbols in Lambdas or Objects", env, c);
	}
	return lGetClosureSym(env ? env->vClosure : c, sym);
}

static lVal *lnfResolveOrNull(lClosure *c, lVal *v){
	const lSymbol *sym = requireSymbol(c, lCar(v));
	lVal *env = lCadr(v);
	if(env && (env->type != ltLambda) && (env->type != ltEnvironment)){
		lExceptionThrowValClo("invalid-environment", "You can only resolve symbols in Lambdas or Objects", env, c);
	}
	lVal *ret;
	if(lHasClosureSym(c, sym, &ret)){
		return ret;
	}else{
		return NULL;
	}
}

static lVal *lnfResolvesPred(lClosure *c, lVal *v){
	lVal *car = lCar(v);
	if(!car || (car->type != ltSymbol)){return lValBool(false);}
	const lSymbol *sym = car->vSymbol;
	lVal *env = lCadr(v);
	if(env && (env->type != ltLambda) && (env->type != ltEnvironment)){
		lExceptionThrowValClo("invalid-environment", "You can only resolve symbols in Lambdas or Objects", env, c);
	}
	return lValBool(lHasClosureSym(env ? env->vClosure : c, sym,NULL));
}

static lVal *lnfCurrentClosure(lClosure *c, lVal *v){
	(void)v;
	lVal *ret = lValAlloc(ltEnvironment);
	ret->vClosure = c;
	return ret;
}

static lVal *lnfCurrentLambda(lClosure *c, lVal *v){
	(void)v;
	lVal *ret = lValAlloc(ltLambda);
	ret->vClosure = c;
	return ret;
}

static lVal *lnfApply(lClosure *c, lVal *v){
	return lApply(c, requirePair(c, lCadr(v)), lCar(v));
}

static lVal *lnfMacroApply(lClosure *c, lVal *v){
	lVal *fun = lCar(v);
	if((fun == NULL) || (fun->type != ltMacro)){ lExceptionThrowValClo("type-error", "Can't macro-apply to that", v, c); }
	return lLambda(c, lCadr(v), fun);
}

static lVal *lnfCar(lClosure *c, lVal *v){
	(void)c;
	return lCaar(v);
}

static lVal *lnfCdr(lClosure *c, lVal *v){
	(void)c;
	return lCdar(v);
}

static lVal *lnfCons(lClosure *c, lVal *v){
	if(lCddr(v) != NULL){ lExceptionThrowValClo("too-many-args","Cons should only be called with 2 arguments!", v, c); }
	return lCons(lCar(v),lCadr(v));
}

static lVal *lnfNReverse(lClosure *c, lVal *v){
	(void)c;
	lVal *t = NULL, *l = lCar(v);
	while((l != NULL) && (l->type == ltPair)){
		lVal *next = l->vList->cdr;
		l->vList->cdr = t;
		t = l;
		l = next;
	}
	return t;
}

static lVal *lnfTime(lClosure *c, lVal *v){
	(void)c;(void)v;
	return lValInt(time(NULL));
}

static lVal *lnfTimeMsecs(lClosure *c, lVal *v){
	(void)c; (void)v;
	return lValInt(getMSecs());
}

static lVal *lnfLess(lClosure *c, lVal *v){
	(void)c;
	return lValBool(lValGreater(lCar(v), lCadr(v)) < 0);
}

static lVal *lnfUnequal(lClosure *c, lVal *v){
	(void)c;
	return lValBool(!lValEqual(lCar(v), lCadr(v)));
}

static lVal *lnfEqual(lClosure *c, lVal *v){
	(void)c;
	return lValBool(lValEqual(lCar(v), lCadr(v)));
}

static lVal *lnfLessEqual(lClosure *c, lVal *v){
	(void)c;
	lVal *a = lCar(v);
	lVal *b = lCadr(v);
	return lValBool(lValEqual(a,b) || (lValGreater(a, b) < 0));
}

static lVal *lnfGreater(lClosure *c, lVal *v){
	(void)c;
	return lValBool(lValGreater(lCar(v), lCadr(v)) > 0);
}

static lVal *lnfGreaterEqual(lClosure *c, lVal *v){
	(void)c;
	lVal *a = lCar(v);
	lVal *b = lCadr(v);
	return lValBool(lValEqual(a, b) || (lValGreater(a, b) > 0));
}

static lVal *lnfNilPred(lClosure *c, lVal *v){
	(void)c;
	return lValBool(lCar(v) == NULL);
}

static lVal *lnfZeroPred(lClosure *c, lVal *v){
	(void)c;
	lVal *a = lCar(v);
	bool p = false;
	if(a){
		if(a->type == ltInt){
			p = a->vInt == 0;
		}else if(a->type == ltFloat){
			p = a->vFloat == 0.0;
		}
	}
	return lValBool(p);
}

static lVal *lnfQuote(lClosure *c, lVal *v){
	if(v->type != ltPair){ lExceptionThrowValClo("invalid-quote","Quote needs a second argument to return, maybe you were trying to use a dotted pair instead of a list?", v, c); }
	return lCar(v);
}

static lVal *lnfThrow(lClosure *c, lVal *v){
	(void)c;
	lExceptionThrowRaw(lCar(v));
	return NULL;
}

static lVal *lnfRead(lClosure *c, lVal *v){
	return lRead(c, requireString(c, lCar(v))->data);
}

static lVal *lnfTypeOf(lClosure *c, lVal *v){
	(void)c;
	return lValKeywordS(getTypeSymbol(lCar(v)));
}

static lVal *lnfGarbageCollect(lClosure *c, lVal *v){
	(void)c; (void)v;
	lGarbageCollect();
	return NULL;
}

static lVal *lnfGarbageCollectRuns(lClosure *c, lVal *v){
	(void)c; (void)v;
	return lValInt(lGCRuns);
}

static lVal *lnfMetaGet(lClosure *c, lVal *v){
	const lSymbol *key = requireSymbolic(c, lCadr(v));
	lVal *l = lCar(v);
	typeswitch(l){
	case ltNativeFunc:
		return lTreeGet(l->vNFunc->meta, key, NULL);
	case ltLambda:
	case ltEnvironment:
		return lTreeGet(l->vClosure->meta, key, NULL);
	default:
		return NULL;
	}
}

static lVal *lnfMetaSet(lClosure *c, lVal *v){
	const lSymbol *key = requireSymbolic(c, lCadr(v));
	lVal *car = requireCallable(c, lCar(v));

	if(car->type == ltNativeFunc){
		lExceptionThrowValClo("type-error", "Can't add new metadata to native functions", car, c);
	}else{
		car->vClosure->meta = lTreeInsert(car->vClosure->meta, key, lCaddr(v));
	}

	return car;
}

static lVal *lCastFloat(lClosure *c, lVal *v){
	typeswitch(v){
	default:      throwTypeError(c, v, ltFloat);
	case ltFloat: return v;
	case ltInt:   return lValFloat(c, v->vInt);
	}
}
static lVal *lnfFloat(lClosure *c, lVal *v){
	return lCastFloat(c,lCar(v));
}

static lVal *lCastInt(lClosure *c, lVal *v){
	typeswitch(v){
	default:      throwTypeError(c, v, ltInt);
	case ltInt:   return v;
	case ltFloat: return lValInt(v->vFloat);
	}
}
static lVal *lnfInt(lClosure *c, lVal *v){
	return lCastInt(c, lCar(v));
}

static lVal *lnfSymbolToKeyword(lClosure *c, lVal *v){
	return lValKeywordS(requireSymbol(c, lCar(v)));
}

static lVal *lnfKeywordToSymbol(lClosure *c, lVal *v){
	return lValSymS(requireKeyword(c, lCar(v)));
}

static i64 lValToId(lVal *v){
	typeswitch(v){
	default:      return 0;
	case ltEnvironment:
	case ltMacro:
	case ltLambda: return v->vClosure - lClosureList;
	case ltBufferView: return v->vBufferView - lBufferViewList;
	case ltString:
	case ltBuffer: return v->vBuffer - lBufferList;
	case ltArray: return v->vArray - lArrayList;
	case ltTree: return v->vTree - lTreeList;
	case ltBytecodeArr: return v->vBytecodeArr - lBytecodeArrayList;
	case ltKeyword:
	case ltSymbol: return v->vSymbol - lSymbolList;
	case ltFileHandle: return fileno(v->vFileHandle);
	case ltNativeFunc: return v->vNFunc - lNFuncList;
	}
}

static lVal *lnfValToId(lClosure *c, lVal *v){
	(void)c;
	return lValInt(lValToId(lCar(v)));
}

static lVal *lnfString(lClosure *c, lVal *v){
	char buf[64];
	int snret;
	lVal *a = lCar(v);
	typeswitch(a){
	default:
		lExceptionThrowValClo("type-error", "Can't convert that into a string", a, c);
		return NULL;
	case ltNil:
		return lValString("");
	case ltBuffer:
		return lValStringLen(a->vBuffer->data, a->vBuffer->length);
	case ltString:
		return a;
	case ltKeyword:
		snret = snprintf(buf,sizeof(buf),":%s",a->vSymbol->c);
		break;
	case ltSymbol:
		snret = snprintf(buf,sizeof(buf),"%s",a->vSymbol->c);
		break;
	case ltInt:
		snret = snprintf(buf,sizeof(buf),"%" PRId64, a->vInt);
		break;
	case ltFloat: {
		snret = snprintf(buf,sizeof(buf),"%f", a->vFloat);
		if(snret < 0){exit(5);}
		buf[snret--] = 0;
		for(;(snret > 0) && (buf[snret] == '0');snret--){}
		if(buf[snret] == '.'){snret++;}
		snret++;
		break; }
	}
	if(snret < 0){exit(5);}
	buf[snret] = 0;
	return lValStringLen(buf,snret);
}

static lVal *lnfStrSym(lClosure *c, lVal *v){
	return lValSym(requireString(c, lCar(v))->data);
}

void lOperationsCore(lClosure *c){
	lAddNativeFuncPure(c,"quote", "(v)",   "Return v as is without evaluating", lnfQuote);
	lAddNativeFuncPure(c,"read",  "(str)", "Read and Parses STR as an S-Expression", lnfRead);
	lAddNativeFunc    (c,"throw", "(v)",   "Throw V to the closest exception handler", lnfThrow);

	lAddNativeFunc(c,"def-in!",        "(environment sym v)", "Define SYM to be V in ENVIRONMENT", lnfDefIn);
	lAddNativeFunc(c,"resolve",        "(sym environment)", "Resolve SYM", lnfResolve);
	lAddNativeFunc(c,"resolve-or-nil","(sym environment)", "Resolve SYM, or return #nil if it's undefined", lnfResolveOrNull);
	lAddNativeFunc(c,"resolves?",      "(sym environment)", "Check if SYM resolves to a value",           lnfResolvesPred);

	lAddNativeFunc(c,"val->id", "(v)",                "Generate some sort of ID value for V, mainly used in [write)", lnfValToId);
	lAddNativeFunc(c,"meta",    "(v key)",            "Retrieve KEY from V's metadata", lnfMetaGet);
	lAddNativeFunc(c,"meta!",   "(v key meta-value)", "Set KEY to META-VALUE in V's metadata", lnfMetaSet);

	lAddNativeFunc(c,"closure/data",     "(clo)",  "Return the data of CLO",                     lnfClosureData);
	lAddNativeFunc(c,"closure/code",     "(clo)",  "Return the code of CLO",                     lnfClosureCode);
	lAddNativeFunc(c,"closure/name",     "(clo)",  "Return the name of CLO",                     lnfClosureName);
	lAddNativeFunc(c,"closure/arguments","(clo)",  "Return the argument list of CLO",            lnfClosureArguments);
	lAddNativeFunc(c,"closure/parent",   "(clo)",  "Return the parent of CLO",                   lnfClosureParent);
	lAddNativeFunc(c,"closure/caller",   "(clo)",  "Return the caller of CLO",                   lnfClosureCaller);

	lAddNativeFunc(c,"current-closure",  "()",     "Return the current closure as an object",    lnfCurrentClosure);
	lAddNativeFunc(c,"current-lambda",   "()",     "Return the current closure as a lambda",     lnfCurrentLambda);

	lAddNativeFunc(c,"symbol-table",  "()",        "Return a list of all symbols defined, accessible from the current closure",lnfSymbolTable);

	lAddNativeFunc(c,"apply",       "(func list)", "Evaluate FUNC with LIST as arguments",  lnfApply);
	lAddNativeFunc(c,"macro-apply", "(macro list)","Evaluate MACRO with LIST as arguments", lnfMacroApply);

	lAddNativeFuncPure(c,"car",     "(list)",       "Return the head of LIST",          lnfCar);
	lAddNativeFuncPure(c,"cdr",     "(list)",       "Return the rest of LIST",          lnfCdr);
	lAddNativeFuncPure(c,"cons",    "(car cdr)",    "Return a new pair of CAR and CDR", lnfCons);
	lAddNativeFunc    (c,"nreverse","(list)",       "Return LIST in reverse order, fast but mutates", lnfNReverse);

	lAddNativeFunc(c,"time",             "()", "Return the current unix time",lnfTime);
	lAddNativeFunc(c,"time/milliseconds","()", "Return monotonic msecs",lnfTimeMsecs);

	lAddNativeFuncPure(c,"<",        "(α β)", "Return true if α is less than β",             lnfLess);
	lAddNativeFuncPure(c,"<=",       "(α β)", "Return true if α is less or equal to β",      lnfLessEqual);
	lAddNativeFuncPure(c,"= ==",     "(α β)", "Return true if α is equal to β",              lnfEqual);
	lAddNativeFuncPure(c,"not=",     "(α β)", "Return true if α is not equal to  β",         lnfUnequal);
	lAddNativeFuncPure(c,">=",       "(α β)", "Return true if α is greater or equal than β", lnfGreaterEqual);
	lAddNativeFuncPure(c,">",        "(α β)", "Return true if α is greater than β",          lnfGreater);
	lAddNativeFuncPure(c,"nil?",     "(α)",   "Return true if α is #nil",                    lnfNilPred);
	lAddNativeFuncPure(c,"zero?",    "(α)",   "Return true if α is 0",                       lnfZeroPred);

	lAddNativeFunc(c,"garbage-collect",         "()", "Force the garbage collector to run", lnfGarbageCollect);
	lAddNativeFunc(c,"garbage-collection-runs", "()", "Return the amount of times the GC ran since runtime startup", lnfGarbageCollectRuns);

	lAddNativeFuncPure(c,"type-of",         "(α)",     "Return a symbol describing the type of α", lnfTypeOf);
	lAddNativeFuncPure(c,"int",             "(α)",     "Convert α into an integer number", lnfInt);
	lAddNativeFuncPure(c,"float",           "(α)",     "Convert α into a floating-point number", lnfFloat);
	lAddNativeFuncPure(c,"string",          "(α)",     "Convert α into a printable and readable string", lnfString);
	lAddNativeFuncPure(c,"symbol->keyword", "(α)",     "Convert symbol α into a keyword", lnfSymbolToKeyword);
	lAddNativeFuncPure(c,"keyword->symbol", "(α)",     "Convert keyword α into a symbol", lnfKeywordToSymbol);
	lAddNativeFuncPure(c,"string->symbol",  "(str)",   "Convert STR to a symbol",         lnfStrSym);
}