/*
 * KCLL -  Ken and Chee's Limey Lisp  
 * All Rights to the code and any products created with this code is 
 * hereby granted. 
 *
 * I.E. You can do whatever the hell you want with this code. 
 * The only restriction is that this copyright notice not be modified.
 */

#include "kcll.h"
#include <math.h>

void llobj_compare(type) 
     LLCompare type; 
{
  LLObj *o1, *o2; 
  o1 = llnextarg() ;
  o2 = llnextarg(); 
  lllastarg() ; 
  llpusharg( llcompare( type, o1, o2));
}

void llequalQ() { llobj_compare(LLEQUAL); }
void lleqQ()    { llobj_compare(LLEQ); }
void lleqvQ()   { llobj_compare(LLEQV);}

void llsin() {
  double num;
  num = llnum_to_double(llnextcheckedarg(llnum_t)); 
  lllastarg();
  llpusharg(lldouble_to_num(sin(num)));
}
void llcos() {
  double num;
  num = llnum_to_double(llnextcheckedarg(llnum_t)); 
  lllastarg();
  llpusharg(lldouble_to_num(cos(num)));
}
void lltan() {
  double num;
  num = llnum_to_double(llnextcheckedarg(llnum_t)); 
  lllastarg();
  llpusharg(lldouble_to_num(tan(num)));
}
void llasin() {
  double num;
  num = llnum_to_double(llnextcheckedarg(llnum_t)); 
  lllastarg();
  llpusharg(lldouble_to_num(asin(num)));
}
void llacos() {
  double num;
  num = llnum_to_double(llnextcheckedarg(llnum_t)); 
  lllastarg();
  llpusharg(lldouble_to_num(acos(num)));
}
void llexit() { 
  llstrprintf(s_stdout, "Come agin, and we'll leave the light on fer ya\n");
  exit(0);
}
/* type checkers (checker? but... ) */


void llatomQ() {
  LLObj *obj; 
  obj = llnextarg();
  lllastarg();
  llpusharg((llis_cons(obj))? NIL : T);
}

void lllistQ() {
  LLObj *obj; 
  obj = llnextarg(); 
  lllastarg();
  llpusharg((obj == NIL || llis_cons(obj))? T : NIL);
}


void llbooleanQ() {
  LLObj *obj;
  obj = llnextarg(); 
  lllastarg(); 
  llpusharg((obj == T || obj == NIL) ? T : NIL);
}

void lltypeQ(tag) 
     LLTag tag; 
{ 
  LLObj *obj;
  obj = llnextarg(); 
  lllastarg();
  llpusharg((llobj_tag(obj) == tag) ? T : NIL);
} 

void llenvQ() {  lltypeQ(llenv_t);}
void llnumQ() {  lltypeQ(llnum_t);}
void llnullQ() {  lltypeQ(llnull_t);}
void llpairQ() {   lltypeQ(llcons_t);}
void llstreamQ() {   lltypeQ(llstream_t);}
void llsymbolQ() {  lltypeQ(llsym_t); }
void llstringQ() {  lltypeQ(llstring_t);}
void llvectorQ() {  lltypeQ(llvector_t); }
void llprocedureQ() {  lltypeQ(llclosure_t); }

void llchdir() {
  LLString *str;
  char *cstr;

  str = (LLString*) llnextcheckedarg(llstring_t);
  
  cstr = (char*)malloc(sizeof(char) * str->length + 1);
  cstr[str->length] = 0;
  bcopy(str->text, cstr, str->length);
  llpusharg(chdir(cstr) ? NIL: T);
  free(cstr);
    
}

void llpwd() {
  char temp[1024];
  int retval;

  lllastarg();
  
  llpusharg(getwd(temp) ? (LLObj*)llchars_to_string(temp, strlen(temp)) : NIL);
}

void llread() {
  LLStream *stream; 
  LLObj *obj; 
  stream = (LLStream *) ((llmoreargs()) ? (LLStream *)llnextcheckedarg(llstream_t) : s_stdin);
  lllastarg();
  obj = llread_obj(stream);
  llpusharg(obj ? obj : NIL);
}

void lleval() {
  LLObj *obj; 
  obj = llnextarg();
  lllastarg();
  llpusharg(lltop_level_form(obj));
}

void llwrite() { 
  LLObj *obj; 
  LLStream *stream; 
  obj = llnextarg();
  stream = (LLStream *) ((llmoreargs()) ? (LLStream *)llnextcheckedarg(llstream_t) : s_stdout);
  llprint_obj(obj, stream);
  lllastarg();
  llpusharg(T); 
}

void llnewline() {
  LLStream *stream; 
  stream = (LLStream *)((llmoreargs()) ? (LLStream *)llnextcheckedarg(llstream_t) : s_stdout);
  lllastarg();
  llwrite_stream('\n', stream);
}  

void llcload(noisy) 
  int noisy;
{
  LLString *string; 
  LLStream *stream; 
  LLObj *obj , *last = NIL;
  char *file; 

  FILE *fptr; 
  string = (LLString *)llnextcheckedarg(llstring_t);
  lllastarg();
  
  file = (char *) malloc(sizeof(char) * string->length + 1);
  bzero(file, string->length + 1);
  bcopy(string->text, file, string->length);
  if ((fptr = fopen(file, "r")) == NULL) {
    free(file);
    llperror(LLCANT_OPEN, file);
  }
  free(file);
  stream = (LLStream *)llmake_stream_to_file(fptr);
  llpush_protected_obj(stream);
  while(obj = llread_obj(stream)) {
    last = lltop_level_form(obj);
    if(noisy) {
      llprint_obj(last, s_stdout);
      llstrprintf(s_stdout, "\n");
    }
  }
  llpop_protected_obj(stream);
  llpusharg(last);
}

void llcscriptload(noisy) 
  int noisy;
{
  LLString *string; 
  LLStream *stream; 
  LLObj *obj , *last = NIL;
  char *file; 
  char buffer[1024]; 

  FILE *fptr; 
  string = (LLString *)llnextcheckedarg(llstring_t);
  lllastarg();
  
  file = (char *) malloc(sizeof(char) * string->length + 1);
  bzero(file, string->length + 1);
  bcopy(string->text, file, string->length);
  if ((fptr = fopen(file, "r")) == NULL) {
    free(file);
    llperror(LLCANT_OPEN, file);
  }
  fgets(buffer, 1024, fptr);
  free(file);
  stream = (LLStream *)llmake_stream_to_file(fptr);
  llpush_protected_obj(stream);
  while(obj = llread_obj(stream)) {
    last = lltop_level_form(obj);
    if(noisy) {
      llprint_obj(last, s_stdout);
    }
  }
  llpop_protected_obj(stream);
  llpusharg(last);
}
void llscriptload() {
  llcscriptload(0);
}
void llload_noisily() {
  llcload(1);
}

void llload() { 
  llcload(0); 
}


void lltoplevel() { longjmp(llerror_toplevel,1); }

void llbang()
{
  LLString *string; 
  char *cmd ;
  int ret;

  string = (LLString *)llnextcheckedarg(llstring_t); 
  cmd = (char *) malloc(sizeof(char) * string->length + 1);
  bzero(cmd, string->length + 1);
  bcopy(string->text,cmd, string->length);
  ret = system(cmd);
  free(cmd);
  llpusharg(lldouble_to_num((double)ret));
}

void llcbang_readwrite(mode)
     char mode;
{
  LLString *string; 
  char *cmd ;
  FILE *fptr;

  string = (LLString *)llnextcheckedarg(llstring_t); 
  cmd = (char *) malloc(sizeof(char) * string->length + 1);
  bzero(cmd, string->length + 1);
  bcopy(string->text,cmd, string->length);
  fptr = popen(cmd, &mode); 
  free(cmd);
  llpusharg(llmake_stream_to_file(fptr));
}

void llbang_read()  { llcbang_readwrite('r'); }
void llbang_write() { llcbang_readwrite('w'); }

llinit_util() 
{
  static int inited = 0; 
  char init_command[256];

  if(inited) return;
  inited = 1;

  llregister_cfunc(llbang_read, "!read");
  llregister_cfunc(llbang_write, "!write");
  llregister_cfunc(llbang, "!");
  llregister_cfunc(llnullQ,"not");
  llregister_cfunc(llnullQ,"null?");
  llregister_cfunc(llatomQ, "atom?");
  llregister_cfunc(lllistQ, "list?");
  llregister_cfunc(llnumQ, "number?");
  llregister_cfunc(llenvQ, "environment?");
  llregister_cfunc(llbooleanQ, "boolean?");
  llregister_cfunc(llpairQ, "pair?");
  llregister_cfunc(llstreamQ, "port?");
  llregister_cfunc(llsymbolQ, "symbol?");
  llregister_cfunc(llstringQ, "string?");
  llregister_cfunc(llvectorQ, "vector?");
  llregister_cfunc(llprocedureQ, "procedure?");
  llregister_cfunc(lleqQ, "eq?");
  llregister_cfunc(lleqvQ, "eqv?");
  llregister_cfunc(llequalQ, "equal?");
  llregister_cfunc(llexit, "exit");
  llregister_cfunc(llnewline, "newline");
  llregister_cfunc(llwrite, "write");
  llregister_cfunc(lleval, "eval");
  llregister_cfunc(llread, "read");
  llregister_cfunc(llload, "load");
  llregister_cfunc(llload_noisily, "load-noisily");
  llregister_cfunc(lltoplevel, "*toplevel*");
  llregister_cfunc(lltoplevel, "reset");
  llregister_cfunc(llsin, "sin");
  llregister_cfunc(llcos, "cos");
  llregister_cfunc(llasin, "asin");
  llregister_cfunc(llacos, "acos");
  llregister_cfunc(lltan, "tan");
  llregister_cfunc(llchdir, "chdir");
  llregister_cfunc(llpwd, "pwd");
  llregister_cfunc(llscriptload, "scriptload");
  sprintf(init_command, "(load \"%s\")", LLINIT_FILE);
  llcexecute_chars(init_command);
}