/*
* Add primitive operator name to environment
* This maps the symbol `sym' to a list
* (PRIM-OP sym), which is recognized as the
* evaluator as a special form which causes
* it to run the routine "do_prim_op()",
* which is defined lower down in this file.
*/
void add_primop(env_t *e, char *sym)
{
list_t *l = new_list();
l->type = LIST;
add_child(l, mksym("PRIM-OP"));
add_child(l, mksym(sym));
env_add(e, sym, l);
}
int main()
{
Value *result;
init();
// List manipulation.
defnative(mksym("CONS"), native_cons);
defnative(mksym("CAR"), native_car);
defnative(mksym("CDR"), native_cdr);
// Arithmetic.
defnative(mksym("PLUS"), native_plus);
defnative(mksym("MINUS"), native_minus);
defnative(mksym("MUL"), native_mul);
defnative(mksym("DIV"), native_div);
// Miscellaneous.
defnative(mksym("EVAL"), native_eval);
defglobal(mksym("NIL"), LISP_NIL);
while (!feof(stdin)) {
setjmp(toplevel_escape);
printf("> ");
result = eval(lread(), global_env);
printf("\n");
lwrite(result);
printf("\n");
}
return 0;
}
Value *lreadsym()
{
char buf[32];
char *p = buf;
char ch;
while (isalpha((ch = getchar()))) {
*p++ = ch;
}
ungetc(ch, stdin);
*p = '\0';
return mksym(buf);
}
void init()
{
int i;
size_t s = 16384;
heap = malloc(s);
heap_end = heap + s;
for (i = 0; i < SYMBOL_TABLE_SIZE; i++) {
syms[i] = LISP_NIL;
}
quote_sym = mksym("QUOTE");
lambda_sym = mksym("LAMBDA");
define_sym = mksym("DEFINE");
if_sym = mksym("IF");
// Set up the global environment as a single, "empty" binding.
// This is done so that we can "splice" global definitions into
// the global environment rather than "extending" the global
// environment in the regular fashion. Otherwise, global mutual
// recursion would not be possible.
global_env = mkpair(mkpair(LISP_NIL, LISP_NIL), LISP_NIL);
}
int main(int argc, char * argv[]){
std::cout<<nil->value<<std::endl;
std::cout<<t->value<<std::endl;
// std::cout<<mkflt(1.2356).value<<std::endl;
// loliObj* c = cons(t, nil);
// loliObj* b = cons(t, c);
// std::cout<<tail(tail(b))->value<<std::endl;
std::cout<<"CREATING TEST:"<<std::endl;
loliObj* test = cons(mksym("a"), cons(mkint(3), cons(mkint(0), nil)));
// std::cout<<"TEST HEAD: "<<head(test).value<<std::endl;
// std::cout<<"SUM (1 2 3): "<<proc_sum(test)->value<<std::endl;
std::cout<<"SUB (\"a\" 3 0): "<<proc_sub(test)->value<<std::endl;
/// std::cout<<"MUL (1 2 3): "<<proc_mul(test)->value<<std::endl;
std::cout<<"DIV (\"a\" 3 0): "<<proc_div(test)->value<<std::endl;
std::cout<<"MOD (\"a\" 3 0): "<<proc_mod(test)->value<<std::endl;
std::cout<<"Length of (\"a\" 3 0) is: "<<prim_length(test)<<std::endl;
loliObj* testSUM = mkproc(proc_sum);
//cleanUp();
//delete test;
exit(0);
}
Nodes *
findpipe(ASTNode *n)
{
Nodes *pipebl, *decls;
Nodes *r;
Symbol *go;
if(n == nil || n->t != ASTPIPEL) return nl(n);
curpipec = n;
go = n->n2 != nil ? n->n2->sym : nil;
stlist.next = stlist.prev = &stlist;
findstages(n, 0);
propsets();
mksym(n->st->up);
stcur = nil;
procvars(go, &pipebl, &decls);
killed = bsnew(stlist.prev->nvars);
r = decls;
if(n->n2 != nil) r = nlcat(nl(n->n2), r);
r = nlcat(r, process(n));
r = nlcat(r, nl(node(ASTBLOCK, pipebl)));
return r;
}
Matrix
make_symmetric(Matrix a)
{
mksym(a);
return a;
}
* * Filename: loli_symbols.cpp * * Description: The Internal Symbols of LoLi * * Version: 1.0 * Created: 04/05/2014 01:23:47 AM * Revision: none * Compiler: gcc * * Author: Z.Shang (), [email protected] * Organization: * * ===================================================================================== */ #include "loli_types.h" loliObj *nil = mksym("nil"); loliObj *t = mksym("t"); loliObj *lambda = mksym(".\\"); loliObj *set = mksym("set!"); loliObj *quote = mksym("quote"); bool nilp(loliObj* o){ if(o->type == SYM && o->value == "nil"){ return true; } return false; }
list_t* do_prim_op(char *name, list_t *args)
{
int i = 0;
int j;
int val = 0;
list_t *l1;
list_t* nl = c_malloc(sizeof(list_t));
char *buf;
if (!strcmp(name, "+")) {
val = 0;
for (i = 0; i < args->cc; ++i) {
if (args->c[i]->type != NUMBER) {
error_msg("+ expects numbers");
code_error();
}
val += args->c[i]->val;
}
nl->type = NUMBER;
nl->val = val;
return nl;
}
if (!strcmp(name, "-")) {
if (args->cc == 1) {
/* single argument: unary minus sign */
if (args->c[0]->type != NUMBER) {
error_msg("- expects numbers");
code_error();
}
val = -args->c[0]->val;
} else {
/* otherwise, standard N-ary subtraction */
for (i = 0; i < args->cc; ++i) {
if (args->c[i]->type != NUMBER) {
error_msg("- expects numbers");
code_error();
}
if (i == 0)
val = args->c[i]->val;
else
val -= args->c[i]->val;
}
}
nl->val = val;
nl->type = NUMBER;
return nl;
}
if (!strcmp(name, "*")) {
val = 1;
for (i = 0; i < args->cc; ++i) {
if (args->c[i]->type != NUMBER) {
error_msg("* expects numbers");
code_error();
}
val *= args->c[i]->val;
}
nl->type = NUMBER;
nl->val = val;
return nl;
}
if (!strcmp(name, "remainder")) {
if (args->cc != 2
|| args->c[0]->type != NUMBER
|| args->c[1]->type != NUMBER) {
error_msg("`remainder' expects two numbers");
code_error();
}
nl->type = NUMBER;
nl->val = args->c[0]->val % args->c[1]->val;
return nl;
}
if (!strcmp(name, "=")) {
if (args->cc != 2
|| args->c[0]->type != NUMBER
|| args->c[1]->type != NUMBER) {
error_msg("= expects two numbers");
code_error();
}
return makebool(args->c[0]->val == args->c[1]->val);
}
if (!strcmp(name, ">")) {
if (args->cc != 2
|| args->c[0]->type != NUMBER
|| args->c[1]->type != NUMBER) {
error_msg("> expects two numbers");
code_error();
}
return makebool(args->c[0]->val > args->c[1]->val);
}
if (!strcmp(name, "<")) {
if (args->cc != 2
|| args->c[0]->type != NUMBER
|| args->c[1]->type != NUMBER) {
error_msg("< expects two numbers");
code_error();
}
return makebool(args->c[0]->val < args->c[1]->val);
}
if (!strcmp(name, "<=")) {
if (args->cc != 2
|| args->c[0]->type != NUMBER
|| args->c[1]->type != NUMBER) {
error_msg("<= expects two numbers");
code_error();
}
return makebool(args->c[0]->val <= args->c[1]->val);
}
if (!strcmp(name, ">=")) {
if (args->cc != 2
|| args->c[0]->type != NUMBER
|| args->c[1]->type != NUMBER) {
error_msg(">= expects two numbers");
code_error();
}
return makebool(args->c[0]->val >= args->c[1]->val);
}
if (!strcmp(name, "not")) {
val = 0;
if (args->cc != 1) {
error_msg("`not' expects one argument");
code_error();
}
/* r6rs.pdf section 11.8, page 47 */
val = args->c[0]->type == BOOL && !args->c[i]->val;
return makebool(val);
}
if (!strcmp(name, "cons")) {
if (args->cc != 2) {
error_msg("`cons' expects 2 arguments");
code_error();
}
/* just return the list as-is for now */
memcpy(nl, args, sizeof(list_t));
nl->type = CONS;
return nl;
}
if (!strcmp(name, "car")) {
if (args->cc != 1) {
error_msg("`car' expects 1 argument");
code_error();
}
if (args->c[0]->type != CONS) {
error_msg("`car' expects a linked-list");
code_error();
}
if (args->c[0]->cc < 1) {
error_msg("`car' has failed");
code_error();
}
return args->c[0]->c[0];
}
if (!strcmp(name, "cdr")) {
if (args->cc != 1) {
error_msg("`cdr' expects 1 argument");
code_error();
}
if (args->c[0]->type != CONS) {
error_msg("`cdr' expects a linked-list");
code_error();
}
if (args->c[0]->cc < 2) {
error_msg("`cdr' has failed");
code_error();
}
return args->c[0]->c[1];
}
if (!strcmp(name, "null?")) {
return makebool(args->cc == 1
&& (
((args->c[0]->type == SYMBOL && !strcmp(args->c[0]->head, "NIL"))
|| (args->c[0]->type == CONS && args->c[0]->cc == 0))));
}
if (!strcmp(name, "display")) {
buf = malloc(LINEBUFSIZ);
if (!buf) {
error_msg("malloc failed");
code_error();
}
*buf = 0;
printout(args->c[0], buf);
#ifdef JS_GUI
c_writeback(buf);
#else
printf("%s", buf);
#endif
free(buf);
return args->c[0];
}
if (!strcmp(name, "pair?")) {
/* check for null first */
j = args->cc == 1
&& (
((args->c[0]->type == SYMBOL && !strcmp(args->c[0]->head, "NIL"))
|| (args->c[0]->type == CONS && args->c[0]->cc == 0)));
return makebool(!j /* not null, then the rest */
&& args->cc == 1 && args->c[0]->type == CONS);
}
/* the following bit deals with (eq? A B) --
* apparently, eq? checks if two things evaluate
* to the same memory pointer. but further hackery
* is sufficient to deal with the case (eq? 'foo 'foo) */
if (!strcmp(name, "eq?")) {
if (args->cc != 2) {
error_msg("`eq?' expects two arguments");
code_error();
}
return makebool(args->c[0] == args->c[1]
|| (args->c[0]->type == SYMBOL
&& args->c[1]->type == SYMBOL
&& !strcmp(args->c[0]->head, args->c[1]->head))
/* (eq? 'NIL '()) => #t */
|| (args->c[0]->type == SYMBOL && !strcmp(args->c[0]->head, "NIL")
&& args->c[1]->type == CONS && args->c[1]->cc == 0)
/* (eq? '() 'NIL) => #t */
|| (args->c[1]->type == SYMBOL && !strcmp(args->c[1]->head, "NIL")
&& args->c[0]->type == CONS && args->c[0]->cc == 0)
/* (eq? '() '()) => #t */
|| (args->c[0]->type == CONS && args->c[0]->cc == 0
&& args->c[1]->type == CONS && args->c[1]->cc == 0));
}
if (!strcmp(name, "symbol?")) {
return makebool(args->cc == 1
&& args->c[0]->type == SYMBOL);
}
if (!strcmp(name, "number?")) {
return makebool(args->cc == 1
&& args->c[0]->type == NUMBER);
}
if (!strcmp(name, "newline")) {
#ifdef JS_GUI
c_writeback_nl("");
#else
puts("");
#endif
return mksym("NIL");
}
if (!strcmp(name, "save-to")) {
if (save_mode) {
return mksym("NIL");
}
save_file = fopen(args->c[0]->head, "w");
if (!save_file) {
error_msg("failed to open file for writing");
code_error();
}
save_mode = 1;
return mksym("savefile-ok");
}
if (!strcmp(name, "load")) {
buf = malloc(strlen(args->c[0]->head) + 1);
if (!buf) {
error_msg("malloc failed");
code_error();
}
strcpy(buf, args->c[0]->head);
load_code_from_file(buf);
free(buf);
return mksym("HERP-DERP");
}
if (!strcmp(name, "cons2list")) {
return cons2list(args->c[0]);
}
if (!strcmp(name, "debuglog")) {
stacktracer_barf();
return mksym("herp-derp");
}
if (!strcmp(name, "reverse")) {
/* r6rs.pdf, page 48 */
if (args->c[0]->type == CONS)
l1 = cons2list(args->c[0]);
else if (args->c[0]->type == LIST)
l1 = args->c[0];
else return mksym("NIL");
if (l1->cc == 0)
return mksym("NIL");
nl = new_list();
nl->type = LIST;
for (i = l1->cc - 1; i >= 0; --i)
add_child(nl, l1->c[i]);
return makelist(nl);
}
return NULL;
}
void loli_init_tl(){
top_env = addToEnv(top_env, cons(mksym("a"), mkflt(10.0011011)));
top_env = addToEnv(top_env, cons(t, t));
top_env = addToEnv(top_env, cons(nil, nil));
top_env = addToEnv(top_env, cons(quote, quote));
top_env = addToEnv(top_env, cons(mksym("top_env"), top_env));
//Creating Primitive Operators
loliObj* loli_sum = mkproc(proc_sum);
loliObj* loli_mul = mkproc(proc_mul);
loliObj* loli_sub = mkproc(proc_sub);
loliObj* loli_div = mkproc(proc_div);
loliObj* loli_add1 = mkproc(proc_add1);
loliObj* loli_sub1 = mkproc(proc_sub1);
loliObj* loli_mod = mkproc(proc_mod);
loliObj* loli_greater = mkproc(proc_greater);
loliObj* loli_lesser = mkproc(proc_lesser);
top_env = addToEnv(top_env, cons(mksym("+"), loli_sum));
top_env = addToEnv(top_env, cons(mksym("*"), loli_mul));
top_env = addToEnv(top_env, cons(mksym("-"), loli_sub));
top_env = addToEnv(top_env, cons(mksym("/"), loli_div));
top_env = addToEnv(top_env, cons(mksym("add1"), loli_add1));
top_env = addToEnv(top_env, cons(mksym("sub1"), loli_sub1));
top_env = addToEnv(top_env, cons(mksym("mod"), loli_mod));
top_env = addToEnv(top_env, cons(mksym(">"), loli_greater));
top_env = addToEnv(top_env, cons(mksym("<"), loli_lesser));
loliObj* test = cons(mkint(1), cons(mkflt(2.5), cons(mkint(5), nil)));
std::cout<<toString(apply(loli_sum, test))<<"\t"<<toString(apply(loli_mul, test))<<"\n"<<toString(apply(loli_sub, test))<<"\t"<<toString(apply(loli_div, test))<<std::endl;
std::cout<<toString(top_env)<<std::endl;
}
