//gser --- Returns the incomplete gamma function P(a,x)
//evaluated by its series representation. Also returns
//natural log of gamma(a)
void Test::gser(float *gamser, float a, float x, float *gln) {
int n;
float sum, del, ap;
*gln = gammln(a);
if (x <= 0.0) {
if (x < 0.0) {
nerror("x less than zero in series expansion gamma function");
}
*gamser = 0.0;
return;
}
else {
ap = a;
del = sum = 1.0 / a;
for (n = 1; n <= ITMAX; n++) {
++ap;
del *= x / ap;
sum += del;
if (fabs(del) < (fabs(sum) * EPS)) {
*gamser = sum * exp(-x + (a * log(x)) - (*gln));
return;
}
}
nerror("a is too large, ITMAX is too small, in series expansion gamma function");
return;
}
}
IR JIT(IR code)
{
SMDiagnostic errors;
string parser_errors;
ParseAssemblyString(code.assembly.c_str(),master.Program,errors,Context);
if(master.debug)
{
cerr << "Code:\n" << code.assembly << endl;
}
llvm::Function* entryfn = master.Engine->FindFunctionNamed("entry");
if(entryfn == NULL)
nerror("ERROR: Couldn't find program entry point.");
if(!errors.getMessage().empty())
{
entryfn->eraseFromParent();
nerror("IR Parsed with errors: ",errors.getMessage(),"\nCode: \n",code.assembly);
}
if(verifyModule(*master.Program,ReturnStatusAction,&parser_errors))
{
entryfn->eraseFromParent();
nerror("IR Parser Error: ",parser_errors);
}
master.Passes.run(*master.Program);
if(master.debug)
{
cerr << "\nIR:" << endl;
master.Program->dump();
}
return code;
}
/*
* get_dnet_socket -- get us a socket connected to the server.
*
* Parameters: "machine" is the machine the server is running on.
* "service" is the name of the service to connect to.
*
* Returns: Socket connected to the news server if
* all is ok, else -1 on error.
*
* Side effects: Connects to server.
*
* Errors: Printed via nerror.
*/
int
get_dnet_socket(
char *machine,
char *service)
{
# ifdef NNTP_ABLE
int s, area, node;
struct sockaddr_dn sdn;
struct nodeent *getnodebyname(), *np;
memset((char *) &sdn, '\0', sizeof(sdn));
switch (s = sscanf(machine, "%d%*[.]%d", &area, &node)) {
case 1:
node = area;
area = 0;
/* FALLTHROUGH */
case 2:
node += area * 1024;
sdn.sdn_add.a_len = 2;
sdn.sdn_family = AF_DECnet;
sdn.sdn_add.a_addr[0] = node % 256;
sdn.sdn_add.a_addr[1] = node / 256;
break;
default:
if ((np = getnodebyname(machine)) == NULL) {
my_fprintf(stderr, _(txt_gethostbyname), "", machine);
return -1;
} else {
memcpy((char *) sdn.sdn_add.a_addr, np->n_addr, np->n_length);
sdn.sdn_add.a_len = np->n_length;
sdn.sdn_family = np->n_addrtype;
}
break;
}
sdn.sdn_objnum = 0;
sdn.sdn_flags = 0;
sdn.sdn_objnamel = strlen("NNTP");
memcpy(&sdn.sdn_objname[0], "NNTP", sdn.sdn_objnamel);
if ((s = socket(AF_DECnet, SOCK_STREAM, 0)) < 0) {
nerror("socket");
return -1;
}
/* And then connect */
if (connect(s, (struct sockaddr *) &sdn, sizeof(sdn)) < 0) {
nerror("connect");
close(s);
return -1;
}
return s;
# else
return -1;
# endif /* NNTP_ABLE */
}
void InitRun(int argc, char** argv)
{
char iniFile[255];
if (argc==1)
sprintf(iniFile,"%s\\pods.ini",_getcwd(NULL,0));
else
sprintf(iniFile,"%s\\%s\\%s.ini",_getcwd(NULL,0),argv[1],argv[1]);
ConfigSDKFromFile(iniFile);
ConfigExperimentFromFile(iniFile);
if (argc>1 && strcmp(gRunBaseName,argv[1])!=0)
//cout<<"WARNING:run-base-name mismatch"<<endl;
nerror("run-base-name mismatch\a");
_mkdir(gRunBaseName); // ok if dir exists, nothing bad will happen.
if (gFrameCounter==0)
{
bFreshRun=true;
}
else
{
char s[255];
sprintf(s,"%s\\dump.%u",gRunBaseName,gFrameCounter);
bFreshRun=!LoadFromFile(s,false);
if (bFreshRun)
printf("Failed to load initial conditions. Starting a fresh run.\n");
}
}
string res_type(string name)
{
Variable* tmp = lookup(name);
if(tmp == NULL)
{ nerror("Can't find register '",name,"'."); }
return tmp->type;
}
void init()
{
InitializeNativeTarget();
master.version = 0.9;
master.Program = new Module("Hylas Lisp",Context);
master.Engine = ExecutionEngine::createJIT(master.Program);
master.Loader = new Linker("Hylas Lisp",master.Program);
master.Loader->addSystemPaths();
master.allow_RedefineMacros = true;
master.allow_RedefineWordMacros = true;
master.allow_RedefinePrePostfixes = true;
master.allow_RedefineFunctions = false;
master.Colorscheme = defaultColorscheme();
master.CSS = defaultCSS();
master.errormode = NormalError;
init_stdlib();
init_types();
init_optimizer();
master.Engine = EngineBuilder(master.Program).create();
try
{
ifstream base("src/base.hylas");
if(!base.good())
nerror("Could not find base.hylas. You will not have print functions for the basic types.");
stringstream file;
file << base.rdbuf();
JIT(Compile(readString(file.str())));
Run();
}
catch(exception except)
{
cerr << getError() << endl;
exit(-1);
}
}
//gcf--- Returns the incomplete gamma function Q(a,x), evaulated by its
//continued fraction representation as gammcf. Also returns natural log
//of gamma as gln
void Test::gcf(float *gammcf, float a, float x, float *gln) {
int i;
float an, b, c, d, del, h;
*gln = gammln(a);
b = x + 1.0 - a;
c = 1.0 / FPMIN;
d = 1.0 / b;
h = d;
for (i = 1; i <= ITMAX; i++) { //iterate to convergence
an = -i * (i - a);
b += 2.0; //Set up for evaluating continued
d = an * d + b; //fraction by modified Lentz's method with b_0 = 0.
if (fabs(d) < FPMIN) {
d = FPMIN;
}
c = b + an / c;
if (fabs(c) < FPMIN) {
c = FPMIN;
}
d = 1.0 / d;
del = d * c;
h *= del;
if (fabs(del - 1.0) < EPS) {
break;
}
}
if (i > ITMAX) {
nerror("a too large, ITMAX too small in continued fraction gamma function");
}
*gammcf = exp(-x + a * log(x) - (*gln)) * h; //Put factors in front
return;
}
void *xmalloc(size_t size)
{
void *addr;
if ((addr = malloc(size)) == NULL)
nerror("malloc");
return (addr);
}
double *dvector(long nl, long nh)
/* Allocate a double vector with subscript range v[nl..nh] */
{
double *v;
v = (double *) malloc((size_t) ((nh-nl+1+NR_END) * sizeof(double)));
if(!v) nerror("allocation failure in dvector()");
return v-nl+NR_END;
}
unsigned short *svector(long nl, long nh)
/* Allocate an unsigned short vector with subscript range v[nl..nh] */
{
unsigned short *v;
v = (unsigned short *) malloc((size_t) ((nh-nl+1+NR_END) * sizeof(unsigned short)));
if(!v) nerror("allocation failure in svector()");
return v-nl+NR_END;
}
long *lvector(long nl, long nh)
/* Allocate an long vector with subscript range v[nl..nh] */
{
long *v;
v = (long *) malloc((size_t) ((nh-nl+1+NR_END) * sizeof(long)));
if(!v) nerror("allocation failure in lvector()");
return v-nl+NR_END;
}
char *cvector(long nl, long nh)
/* Allocate a char vector with subscript range v[nl..nh] */
{
char *v;
v = (char *) malloc((size_t) ((nh-nl+1+NR_END) * sizeof(char)));
if(!v) nerror("allocation failure in cvector()");
return v-nl+NR_END;
}
int *ivector(long nl, long nh)
/* Allocate an int vector with subscript range v[nl..nh] */
{
int *v;
v = (int *) malloc((size_t) ((nh-nl+1+NR_END) * sizeof(int)));
if(!v) nerror("allocation failure in ivector()");
return v-nl+NR_END;
}
string Run()
{
llvm::Function* entryfn = master.Engine->FindFunctionNamed("entry");
if(entryfn == NULL)
nerror("Couldn't find program entry point.");
std::vector<GenericValue> args;
GenericValue retval = master.Engine->runFunction(entryfn,args);
master.Engine->freeMachineCodeForFunction(entryfn);
entryfn->eraseFromParent();
return /*""*/string((char*)(retval.PointerVal));
}
NString NHostAddress::toString(nuint32 ip) {
NString ret;
char addr[32];
memset(addr, 0, sizeof(addr));
if (!inet_ntop(AF_INET, &ip, addr, sizeof(addr))) {
throw NNetworkException(nerror(errno), NString::number((int) ip),
NException::NETWORK);
}
ret = addr;
return ret;
}
IR Compile(Form* form)
{
string out;
string tmp;
if(form == NULL)
error(form,"Can't emit code for the null form.");
else if(isatom(form))
{
if(val(form) == "quit")
exit(0);
else if(val(form) == "IR")
{
master.Program->dump();
nerror("Dumped IR.");
}
else if(val(form) == "debug")
{
master.debug = !master.debug;
nerror("Debug mode is ",(master.debug?"on":"off"),".");
}
else
out = emitCode(form);
}
else
out = emitCode(form/*,Top*/);
/*for(unsigned long i = 0; i < master.Persistent.size(); i++)
tmp += master.Persistent[i] + "\n";*/
for(unsigned long i = 0; i < master.CodeStack.size(); i++)
tmp += master.CodeStack[i] + "\n";
out = "define " + latest_type() + " @entry(){\n" + out + "\nret " + latest_type() + " " + get_current_res() + "\n}";
out = tmp + out;
string type = latest_type();
master.CodeStack.clear();
clear_reader();
return {out,type};
}
string matchKeyword(string in)
{
//Is it a constant?
switch(analyze(in))
{
case BooleanTrue:
in = exportRGB(master.Colorscheme.find("BooleanTrue")->second) + in + "</span>";
break;
case BooleanFalse:
in = exportRGB(master.Colorscheme.find("BooleanFalse")->second) + in + "</span>";
break;
case Integer:
in = exportRGB(master.Colorscheme.find("Integer")->second) + in + "</span>";
break;
case Character:
in = exportRGB(master.Colorscheme.find("Character")->second) + in + "</span>";
break;
case Real:
in = exportRGB(master.Colorscheme.find("Real")->second) + in + "</span>";
break;
case String:
in = exportRGB(master.Colorscheme.find("String")->second) + in + "</span>";
break;
case Symbol:
{
//Is it a TopLevel or Core function?
if(Core.find(in) != Core.end())
in = exportRGB(master.Colorscheme.find("Core")->second) + in + "</span>";
//Is it a symbol?
else if(lookup(in) != NULL)
in = exportRGB(master.Colorscheme.find("Symbol")->second) + in + "</span>";
//Is it a type?
else if(checkTypeExistence(in))
in = exportRGB(master.Colorscheme.find("Type")->second) + in + "</span>";
else if(checkGenericExistence(in,true) ||
checkGenericExistence(in,false))
in = exportRGB(master.Colorscheme.find("Generic")->second) + in + "</span>";
//lol wtf is it just return it
break;
}
case Unidentifiable:
{
nerror("Received an unidentifiable form as input.");
break;
}
}
return in;
}
//gammq ---- returns the incomplete gamma function Q(a,x) = 1 - P(a,x).
float Test::gammq(float a, float x) {
float gamser, gammcf, gln;
//cout <<"a " << a<< " x "<<x<<endl;
if (x < 0.0 || a <= 0.0) {
nerror("Invalid arguments in routine gammq");
}
if (x < (a + 1.0)) { //use the series representation
gser(&gamser, a, x, &gln);
return 1.0 - gamser; //and take its complement
}
else {
gcf(&gammcf, a, x, &gln); //use the continued fraction representation
return gammcf;
}
}
void qroot(float p[], int n, float *b, float *c, float eps)
{
void poldiv(float u[], int n, float v[], int nv, float q[], float r[]);
int iter;
float sc, sb, s, rc, rb, r, dv, delc, delb;
float *q, *qq, *rem;
float d[3];
q = vevtor(0, n);
qq = vector(0, n);
rem(0, n);
d[2] = 1.0;
for (iter = 1; iter <= ITMAX; iter++){
d[1] = (*b);
d[0] = (*c);
poldiv(p, n, d, 2, q, rem);
s = rem[0];
r = rem[1];
poldiv(q, (n - 1), d, 2, qq, rem);
sb = -(*c)*(rc = -rem[1]);
rb = -(*b)*rc + -sc = -rem[0]);
dv = 1.0 / (sb*rc - sc*s)*dv;
delb = (r*sc - s*rb)*dv;
delc = (-r*sb + s*rb)*dv;
*b = += (delb = (r*sc - s*rc)*dv);
*c += (delc = (-r*sb + s*rb)*dv);
if ((fabs(delb) <= eps*fabs(*b) || fabs(*b) < TINY)
&& (fabs(delc) <= eps*fabs(*c) || fabs(*c) < TINY)) {
free_vector(rem, 0, n);
free_vector(qq, 0, n);
free_vector(q, 0, n);
return;
}
}
nerror("Too many iterations in routine qroot");
}
/* getwloc - get a word from the word table */
int getwloc(int n)
{
if (n < 1 || n > wcount)
nerror("word number out of range: %d",n);
return (getdword(wtable+n+n));
}
/* setvalue - set the value of a variable in the variable table */
int setvalue(int n, int v)
{
if (n < 1 || n > vcount)
nerror("variable number out of range: %d",n);
return (putdword(vtable+n+n,v));
}
/* getvalue - get the value of a variable from the variable table */
int getvalue(int n)
{
if (n < 1 || n > vcount)
nerror("variable number out of range: %d",n);
return (getdword(vtable+n+n));
}
/* getaloc - get an action from the action table */
int getaloc(int n)
{
if (n < 1 || n > acount)
nerror("action number out of range: %d",n);
return (getdword(atable+n+n));
}
/* getoloc - get an object from the object table */
int getoloc(int n)
{
if (n < 1 || n > ocount)
nerror("object number out of range: %d",n);
return (getdword(otable+n+n));
}
