/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "error/error.hh"
#include "main/main.hh"
#include "init/init.hh"
#include "file/file.hh"
#include "lisp/li_types.hh"
#include "lisp/lisp.hh"
#include "status/status.hh"
#include "threads/threads.hh"

#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>

char li_last_file[150];
int li_last_line=0;

// returns the length of the list
int        li_length(li_object *o, li_environment *env) 
{
  if (o->type()!=LI_LIST)
    return 0;
  else
  {
    int t=0;
    while (o)
    {
      t++;
      o=li_cdr(o, env);
    }
    return t;
  }
    
}

i4_bool li_is_number(li_object *o) 
{ 
  return (i4_bool)(o->type()==LI_INT || o->type()==LI_FLOAT); 
}


float li_get_float(li_object *o, li_environment *env)  // will convert int to float
{
  if (o->type()==LI_INT)
    return (float)(li_int::get(o, env)->value()); // JJ
  else
    return li_float::get(o, env)->value();
}

int li_get_int(li_object *o, li_environment *env)    // will convert float to int
{
  if (o->type()==LI_FLOAT)
    return (int)li_float::get(o, env)->value();
  else
    return li_int::get(o, env)->value();
}

char *li_get_string(li_object *o, li_environment *env)
{
  return li_string::get(o, env)->value();
}


void li_skip_c_comment(char *&s)
{
  s+=2;
  while (*s && (*s!='*' || *(s+1)!='/'))
  {
    if (*s=='/' && *(s+1)=='*')
      li_skip_c_comment(s);
    else s++;
  }
  if (*s) s+=2;
}


int li_read_token(char *&s, char *buffer)
{
  // skip space
  while (*s==' ' || *s=='\t' || *s=='\n' || *s=='\r' || *s==26)
  {
    if (*s=='\n')
      li_last_line++;
    s++;
  }
  
  if (*s==';')  // comment
  {
    while (*s && *s!='\n' && *s!=26)
    {
      if (*s=='\n')
        li_last_line++;
      s++;
    }
    
    return li_read_token(s,buffer);
  } else if  (*s=='/' && *(s+1)=='*')   // c style comment
  {
    li_skip_c_comment(s);
    return li_read_token(s,buffer);    
  }
  else if (*s==0)
    return 0;
  else if (*s==')' || *s=='(' || *s=='\'' || *s=='`' || *s==',' || *s==26)
  {
    *(buffer++)=*(s++);
    *buffer=0;
  } else if (*s=='"')    // string
  {
    *(buffer++)=*(s++);          // don't read off the string because it
    // may be to long to fit in the token buffer
    // so just read the '"' so the compiler knows to scan the rest.
    *buffer=0;
  } else if (*s=='#')
  {
    *(buffer++)=*(s++);      
    if (*s!='\'')
      *(buffer++)=*(s++);      
    *buffer=0;
  } else
  {
    while (*s && *s!=')' && *s!='(' && *s!=' ' && 
           *s!='\n' && *s!='\r' && *s!='\t' && *s!=';' && *s!=26)
      *(buffer++)=*(s++);      
    *buffer=0;
  }
  return 1;    
}

int li_streq(char *s1, char *s2)
{
  return strcmp(s1,s2)==0;
}


long li_str_token_len(char *st)
{
  long x=1;
  while (*st && (*st!='"' || st[1]=='"'))
  {
    if (*st=='\\' || *st=='"') st++;    
    st++; x++;
  }
  return x;
}

static i4_critical_section_class token_buf_lock;
enum {MAX_LISP_TOKEN_LEN=512};
static char li_token[MAX_LISP_TOKEN_LEN];  // assume all tokens will be < 512 characters


li_object *li_locked_get_expression(char *&s, li_environment *env)
{

  li_object *ret=0;

  if (!li_read_token(s,li_token))
    return 0;
  if (li_streq(li_token,"nil"))
    return li_nil;
  else if (li_token[0]=='T' && !li_token[1])
    return li_true_sym;
  else if (li_token[0]=='\'')                    // short hand for quote function
    return new li_list(li_quote, new li_list(li_locked_get_expression(s, env), 0));    
  else if (li_token[0]=='`')                    // short hand for backquote function
    return new li_list(li_backquote, new li_list(li_locked_get_expression(s, env),0));
  else if (li_token[0]==',')              // short hand for comma function
    return new li_list(li_comma, new li_list(li_locked_get_expression(s, env), 0));
  else if (li_token[0]=='(')                     // make a list of everything in ()
  {
    li_list *first=NULL,*cur=NULL,*last=NULL;   

    int done=0;
    do
    {
      char *tmp=s;
      if (!li_read_token(tmp,li_token))           // check for the end of the list
        li_error(env, "unexpected end of program");
      if (li_token[0]==')') 
      {
        done=1;
        li_read_token(s,li_token);                // read off the ')'
      }
      else
      {     
        if (li_token[0]=='.' && !li_token[1])
        {
          if (!first)
            li_error(env, "token '.' not allowed here : %s\n",s);	      
          else 
          {
            li_read_token(s,li_token);              // skip the '.'
            last->set_next(li_locked_get_expression(s, env));          // link the last cdr to 
            last=NULL;
          }
        } else if (!last && first)
          li_error(env, "illegal end of dotted list\n");
        else
        {	
          li_list *p=new li_list(li_locked_get_expression(s, env), 0);
          if (last)
            last->set_next(p);
          else
            first=p;
          last=p;
        }
      } 
    } while (!done);

    if (!first)
      return li_nil;
    else return first;

  } else if (li_token[0]==')')
    li_error(env, "mismatched ) at %s",s);
  else if (isdigit(li_token[0]) || (li_token[0]=='-' && isdigit(li_token[1])))
  {
    int i=0,per=0,hex=0,x;
    
    if (li_token[0]=='0' && li_token[1]=='x')     // hex number
    {
      hex=1;
      i+=2;
    }
        
    for (; li_token[i] && (isdigit(li_token[i]) || li_token[i]=='.' || li_token[i]=='-'); i++)
      if (li_token[i]=='.')
        per=1;

    if (per)
    {
      float y;
      sscanf(li_token,"%f",&y);      
      return new li_float(y);
    }
    else if (hex)
    {
      sscanf(li_token,"%x",&x);
      return new li_int(x);
    }
    else
    {
      sscanf(li_token,"%d",&x);
      return new li_int(x);
    }
  } else if (li_token[0]=='"')
  {
    li_string *r=new li_string(li_str_token_len(s));

    char *start=r->value();

    for (;*s && (*s!='"' || s[1]=='"');s++,start++)
    {
      if (*s=='\\')
      {
        s++;
        if (*s=='n') *start='\n';
        if (*s=='r') *start='\r';
        if (*s=='t') *start='\t';
        if (*s=='\\') *start='\\';
      } else *start=*s;
      if (*s=='"') s++;
    }
    *start=0;
    s++;

    return r;
  } else if (li_token[0]=='#')
  {
    if (li_token[1]=='\\')
    {
      li_read_token(s,li_token);                   // read character name
      if (li_streq(li_token,"newline"))
        ret=new li_character('\n');
      else if (li_streq(li_token,"space"))
        ret=new li_character(' ');       
      else 
        ret=new li_character(li_token[0]);       
    }
    else if (li_token[1]==0)                           // short hand for function
      return new li_list(li_function_symbol, new li_list(li_locked_get_expression(s, env), 0));
    else
    {
      li_error(env, "Unknown #\\ notation : %s\n",li_token);
      exit(0);
    }
  } else 
    return li_get_symbol(li_token);

  return ret;
}

// because we can only allow one thread to use the token buffer at a time
// so we don't have to allocate it on the stack (because it's fairly recursive)
// I lock access to the token buffer per thread
li_object *li_get_expression(char *&s, li_environment *env)
{
  token_buf_lock.lock();
  li_object *ret=li_locked_get_expression(s, env);
  token_buf_lock.unlock();
  return ret;
}


void lip(li_object *o)
{
  if (!o)
  {
    i4_debug->printf("(null object)\n");
    return ;
  }

  if (!li_valid_object(o))
  {
    i4_debug->printf("(invalid object)\n");
    return ;
  }

  li_get_type(o->type())->print(o, i4_debug);
  i4_debug->printf("\n");
}

li_object *li_print(li_object *o, li_environment *env)
{
  li_object *ret=0;
  while (o)
  {
    ret=li_eval(li_car(o,env),env);
    lip(ret);
    o=li_cdr(o,env);
  }
  return ret;
}

li_list *li_make_list(li_object *first, ...)
{
  va_list ap;
  va_start(ap, first);
  
  li_list *ret=new li_list(first,0), *last;
  last=ret;
  
  while (1)
  {
    li_object *o=va_arg(ap, li_object *);
    if (o)
    {
      li_list *next=new li_list(o,0);
      last->set_next(next);
      last=next;
    }
    else
    {
      va_end(ap);
      return ret;
    }
  }
}



li_object *li_get_fun(li_symbol *sym, li_environment *env) 
{ 
  if (env)
    return env->fun(sym);
  else return sym->fun();
}

li_object *li_get_fun(char *sym, li_environment *env)
{
  return li_get_fun(li_get_symbol(sym),env);
}


li_object *li_eval(li_object *expression, li_environment *env)
{
  if (!expression)
    return li_nil;
   
  int type=expression->type();
  switch (type)
  {    
    case LI_SYMBOL : 
    {
      li_object *v=li_get_value(li_symbol::get(expression,env), env);
      if (!v)
        li_error(env, "Symbol '%O' has no value", expression);
      return v;

    } break;

    case LI_LIST :
    {
      li_list *o=li_list::get(expression,env);
      li_symbol *sym=li_symbol::get(o->data(),env);
      return li_call(sym, o->next(), env);
    } break;

    default :
      return expression; 
      break;
  }

  return 0;
}


li_object *li_load(i4_file_class *fp, li_environment *env, i4_status_class *status)
{
  li_object *ret=0;
  li_last_line=0;


  int l=fp->size();

  char *buf=(char *)I4_MALLOC(l+1,"");
  buf[l]=0;
  fp->read(buf,l);

  char *s=buf;
  

  li_object *exp;
  do
  {
    if (status)
      status->update((s-buf)/(float)l);

    exp=li_get_expression(s, env);
    if (exp)
      ret=li_eval(exp, env);    
  } while (exp);

  i4_free(buf);
  return ret;
}

li_object *li_load(li_object *name, li_environment *env)
{
  return li_load(name, env, 0);
}

li_object *li_load(li_object *name, li_environment *env, i4_status_class *status)
{
  li_object *ret=0;

  char old_file[256];
  strcpy(old_file, li_last_file);
  int old_line=li_last_line;
  
  li_gc();

  while (name)
  {
    char *s=li_string::get(li_eval(li_car(name,env),env),env)->value();
    strcpy(li_last_file, s);

    i4_file_class *fp=i4_open(i4_const_str(s));
    if (fp)
    {
      ret=li_load(fp, env, status);
      delete fp;
    }
    else
      i4_warning("li_load : file missing %s", s);

    name=li_cdr(name,env);
  }
  
  strcpy(li_last_file, old_file);
  li_last_line=old_line;
  

  return ret;
}

li_object *li_read_eval(li_object *o, li_environment *env)
{
  char line[1000], *c=line;
  int t=0;
  i4_debug->printf("eval>");
  do
  {
    if (i4_debug->read(c,1)!=1)
      return 0;
    t++;
    c++;
  } while (c[-1]!='\n' && t<998);
  
  *c=0;
  c=line;
  li_object *ret=li_eval(li_get_expression(c, env), env);
  lip(ret);
  return ret;
}

li_object *li_load(char *filename, li_environment *env, i4_status_class *status)
{
  return li_load(new li_list(new li_string(filename), 0), env, status);
}

void li_add_function(li_symbol *sym, 
                     li_function_type fun,
                     li_environment *env)
{
  li_function *f=new li_function(fun);

  if (env)
    env->set_fun(sym, f);
  else
    sym->set_fun(f);
}


void li_add_function(char *sym_name, li_function_type fun, li_environment *env)
{
  li_add_function(li_get_symbol(sym_name), fun, env);
}

i4_bool li_get_bool(li_object *o, li_environment *env)
{ 
  if (!o) return i4_F;

  li_symbol *s=li_symbol::get(o,env);

  if (o==li_nil)
    return i4_F;
  else if (o==li_true_sym)
    return i4_T;
  else
    li_error(env, "expecting T or nil, got %O", o);

  return 0;
}

static inline int fmt_char(char c)
{
  if ((c>='a' && c<='z') || (c>='A' && c<='Z'))
    return 1;
  return 0;
}

static w8 li_recursive_error=0;

void li_vprintf(i4_file_class *fp,
                char *fmt,
                va_list ap)
{
  
  while (*fmt)
  {
    if (*fmt=='%')
    {
      char *fmt_end=fmt;
      while (!fmt_char(*fmt_end) && *fmt_end) fmt_end++;
      char f[10], out[500]; 
      memcpy(f, fmt, fmt_end-fmt+1);
      f[fmt_end-fmt+1]=0;
      out[0]=0;

      switch (*fmt_end)
      {
        case 'O' : 
        {
          li_object *o=va_arg(ap,li_object *);
          li_get_type(o->type())->print(o, fp);
        } break;

        case 'd' :
        case 'i' :
        case 'x' :
        case 'X' :
        case 'o' :
          ::sprintf(out,f,va_arg(ap,int));
          break;

        case 'f' :
        {
          float fl=(float)(va_arg(ap, double)); //JJ
          ::sprintf(out,f,fl);
        } break;

        case 'g' :
          ::sprintf(out,f,va_arg(ap,double));
          break;

        default :
          ::sprintf(out,f,va_arg(ap,void *));
          break;
      }
      fp->write(out, strlen(out));
      fmt=fmt_end;
      if (*fmt)
        fmt++;
    }
    else
    {
      fp->write_8(*fmt);
      fmt++;
    }


  }
}


void li_printf(i4_file_class *fp,
               char *fmt,                   // typical printf format, with %o == li_object
              ...)
{  
  va_list ap;
  va_start(ap, fmt);
  li_vprintf(fp, fmt, ap);
  va_end(ap);

}

void li_error(li_environment *env,
              char *fmt,
              ...)
{
  if (!li_recursive_error)      // error shouldn't call error again!
  {
    li_recursive_error++;
    i4_file_class *fp=i4_open("li_error.txt", I4_WRITE);

    if (fp)
    {
      va_list ap;
      va_start(ap, fmt);
  
      li_vprintf(fp, fmt, ap);
      fp->printf("\nCall stack:\n");
      if (env)
        env->print_call_stack(fp);

      fp->printf("\nlast file %s:%d", li_last_file, li_last_line);
      delete fp;
      

      fp=i4_open("li_error.txt");
      if (fp)
      {
        int size=fp->size();
        char *b=(char *)I4_MALLOC(size+1,"");
        fp->read(b, size);
        b[size]=0;
        delete fp;

        i4_get_error_function_pointer(li_last_file, 0)(b);

        i4_free(b);
      }
    }

    li_recursive_error--;
  }  
}

li_object *li_new(char *type_name, li_object *params, li_environment *env)
{
  li_symbol *s=li_find_symbol(type_name);
  if (!s) return 0;

  li_object *v=li_get_value(s, env);
  if (!v || v->type()!=LI_TYPE) return 0;
  
  li_type_number type=li_type::get(v,env)->value();
  return li_get_type(type)->create(params, env);
}

li_object *li_new(int type, li_object *params, li_environment *env)
{
  return li_get_type(type)->create(params, env);
}

li_object *li_call(li_symbol *val, li_object *params, li_environment *env)
{
  if (val)
  {
    li_symbol *old_fun=0;
    li_object *old_args=0;
    if (env)
    {     
      old_fun=env->current_function();
      old_args=env->current_arguments();
    }
    else
      env=new li_environment(env, i4_F);

    env->current_function()=val;
    env->current_arguments()=params;
    
    
    li_object *ret=0;    
    li_object *f=li_get_fun(val, env);
    if (f)
    {
      li_function_type fun=li_function::get(f,env)->value();
      if (fun)
        ret=fun(params, env);      
    }
    else
      li_error(env, "symbol %O has no function", val);
    
    if (old_fun)
    {
      env->current_function()=old_fun;
      env->current_arguments()=old_args;
    }

    return ret;
  }

  return 0;
}

li_object *li_call(char *fun_name, li_object *params, li_environment *env)
{
  return li_call(li_get_symbol(fun_name), params, env);
}

li_object  *li_first(li_object *o, li_environment *env) { return li_car(o,env); }
li_object  *li_second(li_object *o, li_environment *env) { return li_car(li_cdr(o,env),env); }
li_object  *li_third(li_object *o, li_environment *env) { return li_car(li_cdr(li_cdr(o,env),env),env); }
li_object  *li_fourth(li_object *o, li_environment *env) 
{ return li_car(li_cdr(li_cdr(li_cdr(o,env),env),env),env); }

li_object  *li_fifth(li_object *o, li_environment *env) 
{ return li_car(li_cdr(li_cdr(li_cdr(li_cdr(o,env),env),env),env),env); }

li_object  *li_nth(li_object *o, int x, li_environment *env) 
{ while (x--) o=li_cdr(o,env); return li_car(o,env); }

// lisp/li_alloc.cpp
/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "init/init.hh"
#include "memory/malloc.hh"
#include "lisp/li_types.hh"
#include "lisp/lisp.hh"
#include "main/main.hh"
#include "time/profile.hh"
#include "threads/threads.hh"
#include <setjmp.h>

static i4_critical_section_class syms_lock;
static i4_critical_section_class cell_lock;
static volatile int threads_need_gc=0;

li_object_pointer *li_object_pointer_list=0;
i4_profile_class pf_li_gc("li_gc");


li_object *li_not(li_object *o, li_environment *env)
{
  li_object *v=li_eval(li_car(o,env),env);
  if (!v || v==li_nil)
    return li_true_sym;
  else return li_nil;
}

li_object *li_progn(li_object *o, li_environment *env)
{
  li_object *ret=li_nil;
  while (o)
  {
    ret=li_eval(li_car(o,env),env);
    o=li_cdr(o,env);
  }
  return ret;
}

li_object *li_if(li_object *o, li_environment *env)
{
  li_object *v=li_eval(li_car(o,env), env);

  if (v && v!=li_nil)
    return li_eval(li_second(o,env),env);
  
  o=li_cdr(li_cdr(o,env),env);
  if (o)
    return li_eval(li_car(o,env), env);
  else return li_nil;
}

li_object *li_equal(li_object *o, li_environment *env)
{
  li_object *o1=li_eval(li_first(o,env),env);
  li_object *o2=li_eval(li_second(o,env),env);

  if (o1->type()==o2->type())
    if (li_get_type(o1->type())->equal(o1, o2))
      return li_true_sym;
  
  return li_nil;
}



li_object_pointer::li_object_pointer(li_object *obj)
{
  o=obj;
  next=li_object_pointer_list;
  li_object_pointer_list=this;
}

li_object_pointer::~li_object_pointer()
{
  if (this==li_object_pointer_list)
    li_object_pointer_list=next;
  else
  {
    li_object_pointer *last=0, *p;
    for (p=li_object_pointer_list; p && p!=this;)
    {
      last=p;
      p=p->next;
    }
    if (p!=this) 
      li_error(0, "couldn't find object pointer to unlink");
    last->next=next;
  }
}


// global symbols
li_symbol *li_nil=0, 
  *li_true_sym=0, 
  *li_quote=0, 
  *li_backquote=0,
  *li_comma=0,
  *li_function_symbol=0;

static li_gc_object_marker_class *gc_helpers=0;

li_gc_object_marker_class::li_gc_object_marker_class()
{
  next=gc_helpers;
  gc_helpers=this;
}

li_gc_object_marker_class::~li_gc_object_marker_class()
{
  if (gc_helpers==this)
    gc_helpers=gc_helpers->next;
  else
  {
    li_gc_object_marker_class *last=0, *p;
    for (p=gc_helpers; p!=this;)
    {
      last=p;
      p=p->next;        
    }
    if (!p) 
      li_error(0,"gc_object marker not in list");
    last->next=p->next;
  }
}

void li_mark_symbols(int set);


li_symbol *li_root=0;

extern li_symbol *li_root;



li_symbol *li_find_symbol(const char *name)     // if symbol doesn't exsist, it is created
{
  syms_lock.lock();
  if (li_root)
  {
    li_symbol *p=li_root;
    while (1)
    {
      int cmp=strcmp(name,p->name()->value());
      if (cmp<0)
      {
        if (p->left())
          p=p->left();
        else
        {
          syms_lock.unlock();
          return 0;
        }
      } else if (cmp>0)
      {
        if (p->right())
          p=p->right();
        else
        {
          syms_lock.unlock();
          return 0;
        }
      } else 
      {
        syms_lock.unlock();
        return p;
      }
    }
  }

  syms_lock.unlock();
  return 0;
}

li_symbol *li_get_symbol(const char *name)     // if symbol doesn't exsist, it is created
{
  syms_lock.lock();
  if (!li_root)
  {
    li_root=new li_symbol(new li_string(name));
    syms_lock.unlock();
    return li_root;
  }
  else
  {
    li_symbol *p=li_root;
    while (1)
    {
      int cmp=strcmp(name,p->name()->value());
      if (cmp<0)
      {
        if (p->left())
          p=p->left();
        else
        {
          p->set_left(new li_symbol(new li_string(name)));
          syms_lock.unlock();
          return p->left();
        }
      } else if (cmp>0)
      {
        if (p->right())
          p=p->right();
        else
        {
          p->set_right(new li_symbol(new li_string(name)));
          syms_lock.unlock();
          return p->right();
        }
      } else
      {
        syms_lock.unlock();
        return p;
      }
    }
  }

  syms_lock.unlock();
  return 0;
}

li_symbol *li_get_symbol(char *name, li_symbol *&cache_to)
{
  if (cache_to) return cache_to;
  cache_to=li_get_symbol(name);
  return cache_to;
}

void li_recursive_mark(li_symbol *p, int set)
{
  if (p)
  {
    li_get_type(LI_SYMBOL)->mark(p, set);
    li_recursive_mark(p->left(), set);
    li_recursive_mark(p->right(), set);
  }
}

void li_mark_symbols(int set)
{
  li_recursive_mark(li_root, set);    
}



void li_mark_symbol_tree(li_symbol *s, int set)
{
  if (s)
  {
    if (set!=s->is_marked())
      li_get_type(LI_SYMBOL)->mark(s, set);

    li_mark_symbol_tree(s->left(), set);
    li_mark_symbol_tree(s->right(), set);
  }
}

void li_mark_memory_region(li_list **start, li_list **end,
                           li_list *c1, li_list *c2, int set)
{
  if (set)
  {
    for (li_list **s=start; s!=end; s++)          
      if ( ((long)(*s)&7)==0 &&  *s>=c1 && *s<c2 && (*s)->type() && !(*s)->is_marked())
        li_get_type( (*s)->unmarked_type() )->mark(*s,1);
  }
  else
    for (li_list **s=start; s!=end; s++)
      if (((long)(*s)&7)==0 && *s>=c1 && *s<c2 && (*s)->is_marked())
        li_get_type( (*s)->unmarked_type() )->mark(*s,0);
  
}

li_object *li_setf(li_object *o, li_environment *env)
{
  li_symbol *s=li_symbol::get(li_car(o,env),env);  o=li_cdr(o,env);
  li_object *value=li_eval(li_car(o,env), env);
  li_set_value(s, value, env); 
  return value;
}

li_object *li_quote_fun(li_object *o, li_environment *env)
{
  return li_car(o,env);
}

li_object *li_new(li_object *o, li_environment *env)
{
  int type=li_type::get(li_eval(li_car(o,env)),env)->value();
  return li_get_type(type)->create(li_cdr(o,env), env);
}

int li_max_cells=20*1024;

li_object *li_ptr(li_object *o, li_environment *env)
{
  return (li_object *)(li_get_int(li_eval(li_car(o,env), env),env));
}


class li_memory_manager_class : public i4_init_class
{
public:
  li_list *cells, *cstart;
  li_list *first_free;

  void get_stack_range(li_object *&start, li_object *&end)
  {
    void *current_stack_object;
    li_object *current_stack=(li_object *)(&current_stack_object);

    li_list **stack_start=((li_list **)i4_stack_base);

    if ((long)stack_start<(long)current_stack) 
    { 
      start=(li_object *)stack_start; 
      end=current_stack; 
    }
    else
    { 
      end=(li_object *)stack_start; 
      start=current_stack; 
    }
  }

  i4_bool valid_object(li_object *o)
  {
    if ((li_list *)o>=cstart && ((li_list *)o)<cstart+li_max_cells && li_valid_type(o->type()))
      return i4_T;
    else
    {
      if (i4_stack_base!=0)
      {
        li_object *s,*e;
        get_stack_range(s,e);
        
        if (o>=s && o<e)
          return i4_T;
      }

      return i4_F;
    }
  }

  int init_type() { return I4_INIT_TYPE_LISP_MEMORY; }

  void mark_stacks(int mark)
  {
    int id=i4_get_first_thread_id();
    do
    {
      void *base, *top;
      i4_get_thread_stack(id, base,top);
      if (base<top)
        li_mark_memory_region((li_list **)base,(li_list **)top,                               
                              cells, cells+li_max_cells, mark);
      else
        li_mark_memory_region((li_list **)top,(li_list **)base,
                              cells, cells+li_max_cells, mark);
    } while (i4_get_next_thread_id(id, id));
  }


  // gc : Garbage Collection
  // scans & marks all cells referenced by 
  // symbols, main stack, thread stacks, global_pointers, & helper objects
  int gc()
  {
    int t_free=0;

    if (i4_get_thread_id()!=i4_get_main_thread_id())
    {
      // if this is called from a thread stop and let main program do gc()
      threads_need_gc=1;
      while (threads_need_gc)
        i4_thread_yield();

      cell_lock.lock();
      for (int i=0; i<li_max_cells; i++)
      {
        if (cells[i]._type==LI_INVALID_TYPE)
          t_free++;
      }
      cell_lock.unlock();
    }
    else
    {
      li_object_pointer *pl;
      int i;

      if (!i4_stack_base)
        i4_error("gc:: need to call li_gc_init() from main prog");
      
      pf_li_gc.start();

      cell_lock.lock();

      i4_suspend_other_threads();
      mark_stacks(1);

      li_mark_symbols(1);

      if (li_root)     // if the system has shut down, don't mark type's objects
      {
        for (i=1; i<li_max_types(); i++)
        {
          li_type_function_table *t=li_get_type(i);
          if (t)
            t->mark(1);
        }
      }

      li_gc_object_marker_class *helpers;
      for (helpers=gc_helpers; helpers; helpers=helpers->next)
        helpers->mark_objects(1);

      for (pl=li_object_pointer_list; pl; pl=pl->next)
        if (pl->o && !pl->o->is_marked())
          li_get_type(pl->o->type())->mark(pl->o, 1);

      first_free=0;
      for (i=0; i<li_max_cells; i++)
      {
        if (!cells[i].is_marked())
        {
          if (cells[i].type()!=LI_INVALID_TYPE)
          {
            li_get_type(cells[i].type())->free(cells+i);
            cells[i].mark_free();
            cells[i]._type=LI_INVALID_TYPE;
          }


          // add to free_list
          cells[i].set_next_free(first_free);
          first_free=cells+i;
          t_free++;
        }
      }


      // unmark the stacks
      mark_stacks(0);

      // unmark symbols
      li_mark_symbols(0);

      if (li_root)
      {
        for (i=1; i<li_max_types(); i++)
        {
          li_type_function_table *t=li_get_type(i);
          if (t)
            t->mark(0);
        }
      }


      for (helpers=gc_helpers; helpers; helpers=helpers->next)
        helpers->mark_objects(0);

      for (pl=li_object_pointer_list; pl; pl=pl->next)
        if (pl->o && pl->o->is_marked())
          li_get_type(pl->o->unmarked_type())->mark(pl->o, 0);

      cell_lock.unlock();
      threads_need_gc=0;
      i4_resume_other_threads();
      pf_li_gc.stop();
    }

    return t_free;
  }

  li_list *alloc_list()
  {
    if (!first_free)
    {
      if (!gc())
        i4_error("li_alloc : out of li_list");      
    }
    
    cell_lock.lock();
    li_list *ret=first_free;
    first_free=first_free->get_next_free();
    cell_lock.unlock();


    return ret;
  }

  void free_list(li_list *l)
  {
    cell_lock.lock();
    int i=l-cells;

    // add to free_list
    cells[i]._type=LI_INVALID_TYPE; 
    cells[i].set_next_free(first_free);
    first_free=cells+i;

    cell_lock.unlock();
  }


  void init()
  {
    if (sizeof(li_list)!=8 || sizeof(li_int)!=8)
      li_error(0, "this code assumes lisp objects are size 8");


    cells=(li_list *)I4_MALLOC(li_max_cells * sizeof(li_list),"");
    cstart=cells;

    if (((long)cells)&7)  // pointer needs to alligned to 8 byte boundary
    {
      cells=((li_list *)(((long)cells&(~7))+8));
      li_max_cells--;
    }

    for (int i=0; i<li_max_cells-1; i++)
    {
      cells[i].mark_free();
      cells[i].set_next_free(cells+i+1);
    }

    cells[li_max_cells-1].set_next_free(0);
    cells[li_max_cells-1].mark_free();

    first_free=cells;

    li_nil=li_get_symbol("nil");        li_set_value(li_nil, li_nil);

    li_true_sym=li_get_symbol("T");     li_set_value(li_true_sym, li_true_sym);
    li_quote=li_get_symbol("'");
    //li_backquote==li_get_symbol("`"); // JJ WHATS THIS ??
    li_backquote=li_get_symbol("`");   //JJ
    li_comma=li_get_symbol(",");
    li_function_symbol=li_get_symbol("#");

    li_add_function("not", li_not);
    li_add_function("progn", li_progn);
    li_add_function("equal", li_equal);
    li_add_function("if", li_if);
    li_add_function("load", li_load);
    li_add_function("setf", li_setf);
    li_add_function("print", li_print);
    li_add_function(li_quote, li_quote_fun);
    li_add_function("new", li_new);
    li_add_function("read-eval", li_read_eval);
    li_add_function("ptr", li_ptr);
  }


  void uninit()
  {
    li_root=0;

    // clear all pointer references
    for (li_object_pointer *pl=li_object_pointer_list; pl; pl=pl->next)
      pl->o=0;

    int t_free=gc();


    if (t_free!=li_max_cells)
    {
      i4_warning("li_cleanup : possibly %d items still referenced", 
                 li_max_cells-t_free);

      for (int i=0; i<li_max_cells; i++)
        cells[i].mark_free();
    }

    // delete all types
    for (int t=0; t<li_max_types(); t++)
      if (t==0 || li_valid_type(t))
        li_remove_type(t);

    li_cleanup_types();

    i4_free(cstart);
  }

} li_mem_man;


void *li_cell8_alloc()
{
  if (threads_need_gc && i4_get_thread_id()==i4_get_main_thread_id())
   li_gc();
    
  return li_mem_man.alloc_list();
}


void li_cell8_free(void *ptr)
{
  li_mem_man.free_list((li_list *)ptr);
}

int li_gc()
{
  jmp_buf env;       // save all registers on the stack
  setjmp(env);


  return li_mem_man.gc();
}


i4_bool li_valid_object(li_object *o)
{
  return li_mem_man.valid_object(o);
}

// lisp/li_class.cpp
/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "main/main.hh"
#include "lisp/lisp.hh"
#include "file/file.hh"
#include "lisp/li_types.hh"
#include "lisp/li_class.hh"
#include "loaders/dir_load.hh"
#include "loaders/dir_save.hh"
#include "lisp/li_init.hh"
#include "lisp/li_load.hh"

static li_type_edit_class *li_class_editor=0;

void li_set_class_editor(li_type_edit_class *editor)
{
  li_class_editor=editor;
}


////////////////////////////// li_class_type members ///////////////////////////////////////////////

li_class *li_this;

class li_class_type : public li_type_function_table
{
public:

  struct var
  {
    li_object  *default_value;
    li_object  *property_list;
    li_symbol  *sym;
    int        original_order;

    void init()
    {
      sym=0;
      default_value=0;
      property_list=0;
      original_order=0;
    }
  };

  static int var_compare(const var *a, const var *b);

  i4_fixed_array<var> vars;

  int old_tvars;
  sw16 *value_remap;     // used during loading of a li_class

  li_class_type *derived_from;
  li_symbol *sym;
  var *get_var(li_symbol *sym);

  int type;

  static li_class_type *get(li_type_function_table *o, li_environment *env)
  { 
    li_class_type *c=(li_class_type *)o;
#ifdef LI_TYPE_CHECK
    if (c!=li_get_type(c->type))
      li_error(env, "function table does not point to a class");
#endif      
    return c;
  }

  li_object *create(li_object *params, li_environment *env);

  void mark(int set);
  void mark(li_object   *o, int set);
  void free(li_object   *o);
  void print(li_object  *o, i4_file_class *stream);
  char *name();

  li_class_type(li_symbol *sym, li_class_type *derived_from)  
    : sym(sym), derived_from(derived_from)
  {
    value_remap=0;
  }


  int get_var_offset(li_symbol *sym, int die_on_error)
  {
    w32 r=vars.size();

    if (!r) return 0;
    int l=0,m;
    li_symbol *s1;//,*s2; JJ not in use

    while (l<(int)r) // JJ cast
    {
      m = (l+r)/2;
      s1=vars[m].sym;

      if (s1==sym) 
        return m;

      if (sym<s1)
        r = m;
      else
        l = m+1;
    }

    if (l==(int)r || vars[l].sym!=sym) //JJ cast
      if (die_on_error)
        li_error(0, "var not in class %O", sym);
      else return -1;

    return l;
  }

  ~li_class_type()
  {
    vars.uninit();
  }

  // these load and save type information
  virtual void save(i4_saver_class *fp, li_environment *env);
  virtual void load(i4_loader_class *fp, li_type_number *type_remap,
                    li_environment *env);
                    
  virtual void load_done();

  // load & save type instance information
  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env);
  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
                                 li_environment *env);

};


struct sym_var
{
  li_class_type::var *var;
  li_object     *value;
};



char *li_class_type::name() 
{ 
  if (sym)
    return sym->name()->value();
  else
    return "anonymous-class"; 
}


void li_class_type::mark(int set)
{
  for (int i=0; i<vars.size(); i++)
  {
    if (vars[i].default_value)
      if (vars[i].default_value->is_marked()!=set)
        li_get_type(vars[i].default_value->unmarked_type())->mark(vars[i].default_value, set);

    if (vars[i].property_list)
      if (vars[i].property_list->is_marked()!=set)
        li_get_type(vars[i].property_list->unmarked_type())->mark(vars[i].property_list, set);
  }     
}

void li_class::mark(int set)
{
  if (!set)
    li_object::mark(set);

  li_class_type *t=get_type();
  for (int i=0; i<t->vars.size(); i++)
  {   
    int type=t->vars[i].default_value->unmarked_type();

    li_object *o=object_value(i);
    // int's and floats are stored directly and don't need marking
    if (type!=LI_INT && type!=LI_FLOAT && o->is_marked()!=set)
      li_get_type(o->unmarked_type())->mark(o, set);
  }      

  if (set)
    li_object::mark(set);
}

li_class_type::var *li_class_type::get_var(li_symbol *sym)
{
  for (int i=0; i<vars.size(); i++)
    if (vars[i].sym==sym) 
      return &vars[i];

  if (derived_from)
    return derived_from->get_var(sym);

  return 0;
}

void li_class_type::mark(li_object   *o, int set)   
{  
  ((li_class *)o)->mark(set);
}

void li_class_type::free(li_object   *o) 
{ 
  li_class::get(o,0)->free(); 
}

void li_class_type::print(li_object  *o, i4_file_class *stream) 
{ 
  li_class::get(o,0)->print(stream); 
}

li_object *li_class_type::create(li_object *params, li_environment *env)
{
  return new li_class(type, params, env);
}


// these load and save type information
void li_class_type::save(i4_saver_class *fp, li_environment *env)
{
  fp->write_32(vars.size());
  for (int i=0; i<vars.size(); i++)
    li_save_object(fp,vars[i].sym, env);
}


void li_class_type::load_done()
{
  if (value_remap)
  {
    i4_free(value_remap);
    value_remap=0;
  }
}

void li_class_type::load(i4_loader_class *fp, li_type_number *type_remap,
                         li_environment *env)
{
  old_tvars=fp->read_32();
  if (old_tvars)
  {
    value_remap=(sw16 *)I4_MALLOC(sizeof(sw16) * old_tvars, ""); 
    for (int j=0; j<old_tvars; j++)
      value_remap[j]=-1;

    for (int i=0; i<old_tvars; i++)
    {
      li_symbol *old_sym=li_symbol::get(li_load_object(fp, type_remap,env), env);
      for (int j=0; j<vars.size(); j++)
        if (old_sym==vars[j].sym)
          value_remap[i]=j;
    } 
  }
}



void li_class::save(i4_saver_class *fp, li_environment *env)
{
  li_class_type *ct=get_type();

  int t_vars=ct->vars.size();
  for (int i=0; i<t_vars; i++)
  {
    li_object *def=ct->vars[i].default_value;
    li_object *v=value(i);

    if (li_get_type(def->type())->equal(def, v))
      li_save_object(fp, 0, env);
    else
      li_save_object(fp, value(i), env);
  }
}

  // load & save type instance information
void li_class_type::save_object(i4_saver_class *fp, li_object *o, li_environment *env)
{
  li_class::get(o,env)->save(fp, env);
}

void li_class::load(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
{
  li_class_type *ct=get_type();
  int old_tvars=ct->old_tvars;
  sw16 *value_remap=ct->value_remap;

  for (int i=0; i<old_tvars; i++)
  {
    li_object *o=li_load_object(fp, type_remap, env);
    int remap=value_remap[i];
    if (remap!=-1)
    {
      li_object *def=ct->vars[remap].default_value;
         
      // if type has changed use default value      
      if ( (def && o) && o->type()==def->type())
        set_value(remap, o);
    }
  }
}

li_object *li_class_type::load_object(i4_loader_class *fp, li_type_number *type_remap, 
                                      li_environment *env)
{
  li_class *c=new li_class(type);
  c->load(fp, type_remap, env);
  return c;
}


//////////////////////////////////// li_class members /////////////////////////////////

li_class::li_class(li_type_number class_type,
                   li_object *params,
                   li_environment *env)
  : li_object(class_type)
{
  li_class_type *ct=get_type();
  int t_vars=ct->vars.size();

  values=(void **)I4_MALLOC(sizeof(void *) * t_vars, "");


  int i;
  for (i=0; i<t_vars; i++)
    set_value(i, ct->vars[i].default_value);



  i=0;
  while (params)
  {
    li_object *val=li_eval(li_car(params,env));
    

    for (int j=0; j<t_vars; j++)
      if (ct->vars[j].original_order==i)
      {
        set_value(j, val);
        j=t_vars;
      }

    params=li_cdr(params,env);
    i++;
  }
  

}


void li_class::print(i4_file_class *fp)
{        
  fp->write("#inst-",6);

  li_class_type *c=get_type();

  char *name=c->name();
  fp->write(name,strlen(name));

  fp->write_8('<');

  for (int i=0; i<c->vars.size(); i++)
  {
    li_symbol *sym=c->vars[i].sym;

    fp->write(" (",2);
    li_get_type(LI_SYMBOL)->print(sym, fp);
    fp->write_8(' ');

    li_object *v=value(i);
    li_get_type(v->type())->print(v, fp);

    fp->write_8(')');
  }

  fp->write_8('>');

}

void li_class::free()
{
  i4_free(values);
}




int li_class::member_offset(char *sym) const
{
  return get_type()->get_var_offset(li_get_symbol(sym), 0);
}

int li_class::member_offset(li_symbol *sym) const
{
  return get_type()->get_var_offset(sym, 0);
}


int li_class::get_offset(li_class_member &c, li_type_number _type) const
{
  li_class_type *ct=get_type();

  if (!c.sym)
    c.sym=li_get_symbol(c.name);
  
  c.class_type=type();
  c.offset=ct->get_var_offset(c.sym, 1);

  if (c.offset==-1)
    li_error(0, "class %s does not have a member %s", ct->name(), c.name);

#ifdef LI_TYPE_CHECK
  if (ct->vars[c.offset].default_value->type()!=_type)
    li_error(0, "class member %O is wrong type (%s should be %s)", 
             c.sym,
             li_get_type(_type)->name(),
             li_get_type(ct->vars[c.offset].default_value->type())->name());  
#endif


  return c.offset;
}



int li_class::get_offset(li_class_member &c) const
{
  li_class_type *ct=get_type();

  if (!c.sym)
    c.sym=li_get_symbol(c.name);
  
  c.class_type=type();
  c.offset=ct->get_var_offset(c.sym, 0);

  return c.offset;
}



#ifdef LI_TYPE_CHECK
li_class *li_class::get(li_object *o, li_environment *env)
{ 
  check_type(o, ((li_class_type *)li_get_type(o->type()))->type, env);   
  return ((li_class *)o); 
}
#endif


li_object *li_class::value(int member)
{
  switch (get_type()->vars[member].default_value->type())
  {
    case LI_INT : return new li_int(int_value(member)); break;
    case LI_FLOAT : return new li_float(float_value(member)); break;
    default : return object_value(member); break;
  }
}

li_object *li_class::value(char *member_name)
{
  return value(member_offset(member_name));
}


void li_class::set_value(int member, li_object *value)
{    
  li_class_type *ct=get_type();
  li_object *def_value=ct->vars[member].default_value;

  int t=def_value->type();
  switch (t) 
  {
    case LI_INT : int_value(member) = li_int::get(value,0)->value(); break;
    case LI_FLOAT : float_value(member) = li_float::get(value,0)->value(); break;
    default : object_value(member)=value;
  }
}



///////////////////////////////////// li_def_class ///////////////////////////////////////////

li_object *li_def_class(li_object *fields, li_environment *env)
{
  li_symbol *sym=li_symbol::get(li_car(fields,env),env);  fields=li_cdr(fields,env);
  li_object *derived=li_eval(li_car(fields,env), env); fields=li_cdr(fields,env);
  li_class_type  *d=0;
  int derived_type=0;
  
  if (derived!=li_nil) 
  {
    derived_type=li_type::get(derived,env)->value();
    if (derived_type)
    {   
      d=(li_class_type *)li_get_type(derived_type);
      if (d->type!=derived_type)
        li_error(env, "cannot derive a class from %O, only other classes", derived);
    }
    else li_error(env, "no such type %O", derived);
  }

  li_class_type *me=new li_class_type(sym, d);

  li_object *c;
  int t_vars=0;

  // how many variables in the parent class
  if (derived_type)
    t_vars+=li_class_total_members(derived_type);  
  
  for (c=fields; c; c=li_cdr(c,env))      // count how many variables were added
    t_vars++;

  me->vars.resize(t_vars);

  t_vars=0;

  if (derived_type)
  {
    int t_from_derived_class=li_class_total_members(derived_type);
    for (int i=0; i<t_from_derived_class; i++)
    {
      me->vars[t_vars].init();
      me->vars[t_vars].original_order=t_vars;
      li_symbol *s=li_class_get_symbol(derived_type, i);
      me->vars[t_vars].sym=s;
      me->vars[t_vars].default_value=li_class_get_default(derived_type, s);
      me->vars[t_vars].property_list=li_class_get_property_list(derived_type, s);
      t_vars++;
    }
  }
    

  for (c=fields; c; c=li_cdr(c,env))
  {
    li_object *var=li_car(c,env);
    me->vars[t_vars].init();
    me->vars[t_vars].original_order=t_vars;
    
    
    me->vars[t_vars].sym=li_symbol::get(li_car(var,env),env);  var=li_cdr(var,env);
    
    if (var)
    {
      me->vars[t_vars].default_value=li_eval(li_car(var,env), env);  var=li_cdr(var,env);      

      li_symbol *s=me->vars[t_vars].sym;
      li_object *d=me->vars[t_vars].default_value;


      if (var)
        me->vars[t_vars].property_list=li_eval(li_car(var,env), env);
    }

    t_vars++;
  }
    
  me->vars.sort(li_class_type::var_compare);
  me->editor=li_class_editor;
  me->type=li_add_type(me);

  return new li_type(me->type);
}

li_object *li_class::set(char *member_name, li_object *value) // slow, but easy way to access data
{
  int off=member_offset(member_name);
  if (off==-1) 
    li_error(0, "class %o does not have member %s", member_name);
  set_value(off, value);
  return value;
}


int li_class_type::var_compare(const var *a, const var *b)
{
  if (a->sym<b->sym)
    return -1;
  else if (a->sym>b->sym)
    return 1;
  else return 0;
}


int li_class_total_members(li_type_number type)
{
  return li_class_type::get(li_get_type(type),0)->vars.size();
}

li_symbol *li_class_get_symbol(li_type_number type, int member_number)
{
  li_class_type *ct=li_class_type::get(li_get_type(type),0);
  return ct->vars[member_number].sym;
}


li_object *li_class_get_default(li_type_number type, li_symbol *sym)
{
  li_class_type *ct=li_class_type::get(li_get_type(type),0);
  return ct->vars[ct->get_var_offset(sym, 1)].default_value;
}

li_object *li_class_get_property_list(li_type_number type, li_symbol *sym)
{
  li_class_type *ct=li_class_type::get(li_get_type(type),0);
  return ct->vars[ct->get_var_offset(sym, 1)].property_list;
}

li_object *li_setm(li_object *o, li_environment *env)
{
  li_class *c=li_class::get(li_first(o,0),0);
  li_symbol *member=li_symbol::get(li_second(o,0),0);
  li_object *value=li_eval(li_third(o,0), env);
  c->set_value(c->member_offset(member), value);
  return value;
}

li_object *li_getm(li_object *o, li_environment *env)
{
  li_class *c=li_class::get(o,0);
  return c->value(c->member_offset(li_symbol::get(li_first(o,0),0)));  
}



li_automatic_add_function(li_def_class, "def_class");
li_automatic_add_function(li_setm, "setm");
li_automatic_add_function(li_getm, "getm");

// lisp/li_dialog.cpp

/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "gui/text_input.hh"
#include "gui/text.hh"
#include "lisp/li_types.hh"
#include "lisp/li_class.hh"
#include "lisp/li_dialog.hh"
#include "file/ram_file.hh"
#include "app/app.hh"
#include "memory/array.hh"
#include "gui/image_win.hh"
#include "gui/button.hh"
#include "gui/list_box.hh"
#include "menu/textitem.hh"
#include "window/wmanager.hh"


static li_symbol_ref li_list_box("list_box");

class li_generic_edit_class : public li_type_edit_class
{
public:
  enum input_type { TEXT_INPUT,
                    LIST_BOX };

  input_type get_type(li_object *property_list, li_environment *env)
  {
    if (property_list && property_list->type()==LI_LIST &&
        li_list_box.get()==li_car(property_list,env))
      return LIST_BOX;
    else 
      return TEXT_INPUT;
  }
  

  virtual int create_edit_controls(const i4_const_str &name,
                                   li_object *o, 
                                   li_object *property_list,
                                   i4_window_class **windows, 
                                   int max_windows,
                                   li_environment *env)
  {
    if (max_windows<2) return 0;
    
    char buf[200];
    i4_ram_file_class rf(buf, 30);
    li_get_type(o->type())->print(o, &rf);
    buf[rf.tell()]=0;

    i4_graphical_style_class *style=i4_current_app->get_style();

    windows[0]=new i4_text_window_class(name, style);

    if (get_type(property_list,env)==LIST_BOX)
    {
      property_list=li_cdr(property_list, env);
    
      i4_list_box_class *lb=new i4_list_box_class(200, style, 
                                                  i4_current_app->get_window_manager());

      int on=0;
      for (;property_list; property_list=li_cdr(property_list,env), on++)
      {
        char buf[100];
        i4_ram_file_class rf(buf, 100);
        li_object *v=li_car(property_list,env);


        li_get_type(v->type())->print(v, &rf);
        buf[rf.tell()]=0;

        lb->add_item(new i4_text_item_class(buf, style)); 

        if (v->type()==o->type() && li_get_type(v->type())->equal(o,v))
          lb->set_current_item(on);
       

      }
      windows[1]=lb;   
    }    
    else
    {
      if (o->type()==LI_STRING)
      {
        buf[strlen(buf)-1]=0;   // chop of end quote
        windows[1]=new i4_text_input_class(style,buf+1, 200,200);
      }
      else
        windows[1]=new i4_text_input_class(style,buf, 200,200);
    }
                                       
    return 2;
  }

  virtual i4_bool can_apply_edit_controls(li_object *o, 
                                          li_object *property_list,
                                          i4_window_class **windows)
  {
    return i4_T;    
  }

  virtual li_object *apply_edit_controls(li_object *o, 
                                         li_object *property_list,
                                         i4_window_class **windows,
                                         li_environment *env)
  {
    if (get_type(property_list, env)==LIST_BOX)
    {
      i4_list_box_class *ib=((i4_list_box_class *)windows[1]);
      return li_nth(property_list, ib->get_current()+1, env);
    } 
    else if (get_type(property_list, env)==TEXT_INPUT)
    {
      i4_text_input_class *w=((i4_text_input_class *)windows[1]);
      
      i4_const_str::iterator i=w->get_edit_string()->begin();
      if (o->type()==LI_INT)
        return new li_int(i.read_number());
      else if (o->type()==LI_FLOAT)
        return new li_float((float)i.read_float()); // JJ cast
      else if (o->type()==LI_SYMBOL)
      {
        char buf[300];
        i4_os_string(*w->get_edit_string(), buf, 100);
        return li_get_symbol(buf);
      }
      else if (o->type()==LI_STRING)
        return new li_string(*w->get_edit_string());
      else
        return o;
    }
    else 
      return o;
  }
      

} li_generic_edit_instance;


class li_class_dialog_item : public li_dialog_item
{
public:
  char *name() { return "li_class_item"; }

  i4_array<li_dialog_item *> items;

  li_class_dialog_item(li_class *c, li_object *_prop_list, li_environment *env)
    : items(5,5)
  {
    prop_list=_prop_list; 
    o=c;

    int t=li_class_total_members(c->type()), i, max_colums=0;
    int colums[50];
    memset(colums, 0, sizeof(colums));

    for (i=0; i<t; i++)
    {
      li_symbol *sym=li_class_get_symbol(c->type(), i);
      li_object *val=c->value(i);
      li_object *prop_list=li_class_get_property_list(c->type(), sym);
      
      li_dialog_item *item=new li_dialog_item(sym->name()->value(), val, prop_list, env);
       items.add(item);

       int t_win=items[i]->t_windows;
       if (t_win>max_colums)
         max_colums=t_win;
       for (int j=0; j<t_win; j++)
         if (items[i]->windows[j] && items[i]->windows[j]->width()>colums[j])
           colums[j]=items[i]->windows[j]->width();
     }

     int dy=0, maxw=0;
     for (i=0; i<t; i++)
     {
       int dx=0, maxh=0;
       add_child(dx,dy, items[i]);

       for (int j=0; j<items[i]->t_windows; j++)
       {
         if (items[i]->windows[j])
         {
           int xoff=dx-(items[i]->windows[j]->x()-items[i]->x());
           items[i]->windows[j]->move(xoff,0);

           if (items[i]->windows[j]->height()>maxh)
             maxh=items[i]->windows[j]->height();
         }

         dx+=colums[j]+3;
         if (dx>maxw) maxw=dx;
       }
       items[i]->resize_to_fit_children();

       dy+=maxh+1;        
     }      

     private_resize(maxw,dy);
   }

   i4_bool can_apply(li_environment *env)
   {
     for (int i=0; i<items.size(); i++)
       if (!items[i]->can_apply(env))
         return i4_F;
     return i4_T;
   }

   li_object *apply(li_environment *env)
   {
     li_class *c=(li_class *)li_new(o.get()->type());

     for (int i=0; i<items.size(); i++)
       c->set_value(i, items[i]->apply(env));

     return c;
   }
 };

 class li_class_edit_class : public li_type_edit_class
 {
 public:
   int create_edit_controls(const i4_const_str &name,
                            li_object *object, 
                            li_object *property_list,
                            i4_window_class **windows, 
                            int max_windows,
                            li_environment *env)
   {
     if (max_windows)
     {
       windows[0]=new li_class_dialog_item(li_class::get(object,env), property_list, env);
       return 1;
     } else return 0;    
   }

   i4_bool can_apply_edit_controls(li_object *objectw, 
                                   li_object *property_list,
                                   i4_window_class **windows,
                                   li_environment *env)
   {
     return ((li_class_dialog_item *)windows[0])->can_apply(env);
   }

   li_object *apply_edit_controls(li_object *o, 
                                  li_object *property_list,
                                  i4_window_class **windows,
                                  li_environment *env)
   {
     return ((li_class_dialog_item *)windows[0])->apply(env);   
   }

 } li_class_edit_instance;


 class li_generic_edit_initer : public i4_init_class
 {
 public:
   int init_type() { return I4_INIT_TYPE_LISP_FUNCTIONS; }

   void init()
   {
     li_get_type(LI_INT)->editor=&li_generic_edit_instance;
     li_get_type(LI_FLOAT)->editor=&li_generic_edit_instance;
     li_get_type(LI_SYMBOL)->editor=&li_generic_edit_instance;
     li_get_type(LI_STRING)->editor=&li_generic_edit_instance;
     li_set_class_editor(&li_class_edit_instance);
   }

 } li_generic_edit_initer_instance;


 li_dialog_item::li_dialog_item() 
   : i4_color_window_class(0,0, i4_current_app->get_style()->color_hint->neutral(),
                           i4_current_app->get_style())
 { 
   windows=0; 
   t_windows=0; 
   o=0;
   prop_list=0;
 }


 li_dialog_item::li_dialog_item(const i4_const_str &name, 
                                li_object *_o, 
                                li_object *prop_list,
                                li_environment *env)

   : i4_color_window_class(0,0, i4_current_app->get_style()->color_hint->neutral(),
                           i4_current_app->get_style()),
     prop_list(prop_list)
 {
   o=_o;
   windows=0;
   t_windows=0;

   i4_window_class *w[10];

   if (li_get_type(o->type())->editor)
   {
     if (prop_list!=li_get_symbol("no_edit"))
     {
       t_windows=li_get_type(o->type())->editor->create_edit_controls(name,
                                                                      o.get(),
                                                                      prop_list,
                                                                      w, 10, env);
       if (t_windows)
       {       
         windows=(i4_window_class **)I4_MALLOC(sizeof(i4_window_class *) * t_windows,"");
         int x=0, i, maxh=0;
         for (i=0; i<t_windows; i++)
           if (w[i] && w[i]->height()>maxh)
             maxh=w[i]->height();


         for (i=0; i<t_windows; i++)
         {
           windows[i]=w[i];

           add_child(x, maxh/2 - windows[i]->height()/2 , windows[i]);
           x+=w[i]->width();
         }
         resize_to_fit_children();
       }
     }
   }
 }



 i4_bool li_dialog_item::can_apply(li_environment *env)
 {
   if (!li_get_type(o->type())->editor)  return i4_T;

   return li_get_type(o->type())->editor->can_apply_edit_controls(o.get(), prop_list, windows,env);
 }


 li_object *li_dialog_item::apply(li_environment *env)
 {
   if (li_get_type(o->type())->editor)
     return li_get_type(o->type())->editor->apply_edit_controls(o.get(), prop_list, windows, env);
   return o.get();
 }  

 li_dialog_item::~li_dialog_item()
 {
   if (windows)
     i4_free(windows);
 }


 i4_graphical_style_class *li_dialog_window_class::style()
 {
   return i4_current_app->get_style(); 
 }



 li_dialog_window_class::~li_dialog_window_class()
 {
   if (called_on_close)
   {
     if (new_value.get())
       called_on_close(li_make_list(new_value.get(), o.get(), 0),0);
     called_on_close=0;
   }
 }

 li_dialog_window_class::li_dialog_window_class(const i4_const_str &name,
                                                li_object *_o, 
                                                li_object *_prop_list,
                                                li_function_type called_on_close,
                                                li_environment *env)
   : i4_color_window_class(0,0, style()->color_hint->neutral(), style()),
     called_on_close(called_on_close), enviroment(env)
 {
   o=_o;
   prop_list=_prop_list;


   mp_handle=0;
   int t=li_get_type(o->type())->editor->create_edit_controls(name, o.get(), 
                                                             prop_list.get(), w, 10,
                                                              env);
  int x=0, maxh=0;
  for (int i=0; i<t; i++)
  {
    add_child(x, 0, w[i]);
    if (w[i]->height()>maxh)
      maxh=w[i]->height();
  }

  i4_window_class *ok, *cancel;

  if (style()->icon_hint->ok_icon && style()->icon_hint->cancel_icon)
  {
    ok=new i4_image_window_class(style()->icon_hint->ok_icon);
    cancel=new i4_image_window_class(style()->icon_hint->cancel_icon);
  }
  else
  {
    ok=new i4_text_window_class(i4gets("ok"), style());
    cancel=new i4_text_window_class(i4gets("cancel"), style());
  }
    
  resize_to_fit_children();

  i4_button_class *okb=new i4_button_class(0, ok, style(), 
                                           new i4_event_reaction_class(this, 1));
  i4_button_class *cancelb=new i4_button_class(0, cancel, style(), 
                                               new i4_event_reaction_class(this, 1));
  x=width()/2-okb->width()/2-cancelb->width()/2;
  if (x<0) x=0;

  add_child(x, maxh+1, okb);
  add_child(x+okb->width(), maxh+1, cancelb);

  resize_to_fit_children();

}

void li_dialog_window_class::receive_event(i4_event *ev)
{
  if (ev->type()==i4_event::USER_MESSAGE)
  {
    if (((i4_user_message_event_class *)ev)->sub_type==1)
    {
      if (!li_get_type(o->type())->editor->can_apply_edit_controls(o.get(), prop_list.get(), w, env()))
        return;
      else
        new_value=li_get_type(o->type())->editor->apply_edit_controls(o.get(),
                                                                      prop_list.get(), w, env());

    }

    if (mp_handle)
      style()->close_mp_window(mp_handle);        

    if (called_on_close)
    {
      if (new_value.get())
        called_on_close(li_make_list( new_value.get(), o.get(),  0),0);
      called_on_close=0;
    }

  }
  else
    i4_color_window_class::receive_event(ev);
}
  


li_dialog_window_class *li_create_dialog(const i4_const_str &name,
                                         li_object *o, 
                                         li_object *prop_list,
                                         char *close_fun,
                                         li_environment *env)
{
  li_function_type fun=0;
  if (close_fun)
    fun=li_function::get(li_get_fun(li_get_symbol(close_fun), env),env)->value();

  li_dialog_window_class *d=new li_dialog_window_class(name, o,prop_list, fun, env);

  i4_parent_window_class *mp;
  mp=i4_current_app->get_style()->create_mp_window(-1,-1, d->width(), d->height(),
                                                   name, 0);
  d->mp_handle=mp;
  mp->add_child(0,0,d);
  return d;
}




li_dialog_window_class *li_create_dialog(const i4_const_str &name,
                                         li_object *o, 
                                         li_object *prop_list,
                                         li_function_type fun,
                                         li_environment *env)
{
  li_dialog_window_class *d=new li_dialog_window_class(name, o,prop_list, fun, env);

  i4_parent_window_class *mp;
  mp=i4_current_app->get_style()->create_mp_window(-1,-1, d->width(), d->height(),
                                                   name, 0);
  d->mp_handle=mp;
  mp->add_child(0,0,d);
  return d;
}



// lisp/li_load.cpp

/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "lisp/lisp.hh"
#include "loaders/dir_load.hh"
#include "loaders/dir_save.hh"
#include "lisp/li_load.hh"

li_type_number *li_load_type_info(i4_loader_class *fp, li_environment *env)
{
  int t_types=fp->read_16(), i;
  if (!t_types)
    return 0;

  
  li_type_number *remap=(li_type_number *)I4_MALLOC(sizeof(li_type_number) * t_types, "");
  memset(remap, 0, sizeof(li_type_number) * t_types);

  for (i=1; i<t_types; i++)
  {
    char buf[300];
    int l=fp->read_16();
    if (l>sizeof(buf)) 
      li_error(env, "load type name too long");

    fp->read(buf, l);
   
    for (int j=1; j<li_max_types(); j++)
      if (li_valid_type(j))
        if (strcmp(buf, li_get_type(j)->name())==0)
          remap[i]=j;    
  }

  for (i=1; i<t_types; i++)
  {
    w32 skip=fp->read_32();

    if (remap[i])
    {
      //      i4_warning("%d : remap for %s", i, li_get_type(remap[i])->name());
      li_get_type(remap[i])->load(fp, remap, env);
    }
    else
      fp->seek(fp->tell() + skip);
  }


  return remap;
}


void li_free_type_info(li_type_number *remap)
{
  if (remap)
    i4_free(remap);

  for (int i=1; i<li_max_types(); i++)
    if (li_valid_type(i))
      li_get_type(i)->load_done();
}

void li_save_type_info(i4_saver_class *fp, li_environment *env)
{
  int t_types=1, i;
  for (i=1; i<li_max_types(); i++)
    if (li_valid_type(i))
      t_types++;

  // save the name and number of each type
  fp->write_16(t_types);
  for (i=1; i<li_max_types(); i++)
  {
    if (li_valid_type(i))
    {
      char *n=li_get_type(i)->name();
      int nl=strlen(n)+1;
      fp->write_16(nl);
      fp->write(n,nl);
    }
    else 
      fp->write_16(0);
  }

  for (i=1; i<li_max_types(); i++)
  {
    if (li_valid_type(i))
    {
      int handle=fp->mark_size();
      li_get_type(i)->save(fp, env);
      fp->end_mark_size(handle);
    }

  }
}



li_object *li_load_typed_object(char *type_name, i4_loader_class *fp, 
                                li_type_number *type_remap,
                                li_environment *env)
{
  int type=li_find_type(type_name);
  if (!type)
    li_error(env,"no type %s", type_name);
  else
  {
    li_object *o=li_load_object(fp, type_remap, env);
    if (!o || o->type()!=(w32)type) // JJ cast
      return li_new(type);
    else
      return o;
  }

  return 0;
}

li_object *li_load_typed_object(int type, i4_loader_class *fp, li_type_number *type_remap,
                                li_environment *env)
{  
  li_object *o=li_load_object(fp, type_remap, env);
  if (!o || o->type()!=(w32)type)  // JJ cast
  {
    if (type)   
      return li_new(type);
    else return 0;
  }
  else
    return o;
}

// lisp/li_types.cpp
/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "memory/array.hh"
#include "lisp/li_types.hh"
#include "file/file.hh"
#include "lisp/lisp.hh"
#include "loaders/dir_save.hh"
#include "loaders/dir_load.hh"
#include <stdio.h>


li_string::li_string(char *name)
  : li_object(LI_STRING)
{ 
  int l=strlen(name)+1; 
  _name=(char *)I4_MALLOC(l,"");
  memcpy(_name, name, l);
}

li_string::li_string(int len)
  : li_object(LI_STRING)
{
  _name=(char *)I4_MALLOC(len,"");
}

li_string::li_string(const i4_const_str &str)
  : li_object(LI_STRING)
{
  int len=str.length()+1;
  _name=(char *)I4_MALLOC(len,"");
  i4_os_string(str, _name, len);
}



void li_save_type(i4_file_class *fp, li_type_number type)
{
  fp->write_16((w16)type); // JJ cast
}

li_type_number  li_load_type(i4_file_class *fp, li_type_number *type_remap)
{
  I4_ASSERT(type_remap, "call li_load_type_info before li_load_type");

  return type_remap[fp->read_16()];
}


void li_save_object(i4_saver_class *fp, li_object *o, li_environment *env)
{
  if (!o)
    fp->write_16(0);
  else
  {
    li_save_type(fp, o->type());

    int h;
    if (o->type()>LI_TYPE)
      h=fp->mark_size();

    li_get_type(o->type())->save_object(fp, o, env);

    if (o->type()>LI_TYPE)
      fp->end_mark_size(h);
  }
}


li_object *li_load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
{
  li_type_number old_type=fp->read_16();  
  li_type_number type=type_remap[old_type];
  
  if (old_type==0)
    return 0;

  w32 skip=0;
  if (old_type>LI_TYPE)
    skip=fp->read_32();
  else if (type==0)
    i4_error("huh?");   // shouldn't happen (please, please)

  if (type)
    return li_get_type(type)->load_object(fp, type_remap, env);
  else if (type>0 && type<=LI_TYPE)
  {
    li_error(env, "type not found, but should be");
    return 0;
  }
  else
  {
    fp->seek(fp->tell() + skip);
    return 0;
  }
}

class li_invalid_type_function : public li_type_function_table
{
  virtual void mark(li_object   *o, int set) { i4_error("marking invalid object"); }
  virtual void free(li_object   *o) { i4_error("freeing invalid object"); }
  virtual int equal(li_object  *o1, li_object *o2)  
  {  
    i4_error("comparing  invalid object"); 
    return 0;
  }

  virtual void print(li_object  *o, i4_file_class *stream)   
  { i4_error("printing invalid object"); }
  virtual char *name() { i4_error("getting name for invalid object"); return 0;}

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env) 
  { li_error(env, "saving invalid object"); }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
  { 
    li_error(env, "loading invalid object"); 
    return 0;
  }

};


void li_symbol::free()
{
  i4_free(data);
}



class li_symbol_type_function : public li_type_function_table
{
  virtual void mark(li_object *o, int set)
  { 
    li_symbol *s=(li_symbol *)o;
    s->mark(set);

    if (s->value())
    {
      if (set!=s->value()->is_marked())
        li_get_type(s->value()->unmarked_type())->mark(s->value(), set);    
    }

    li_object *fun=s->fun();
    if (fun)
    {
      if (set!=fun->is_marked())
        li_get_type(fun->unmarked_type())->mark(fun, set);    
    }

    li_object *name=s->name();
    if (set!=name->is_marked())
      li_get_type(name->unmarked_type())->mark(name, set);    
  }

  virtual void free(li_object   *o)
  {
    li_symbol::get(o,0)->free();
  }
 
  virtual void print(li_object  *o, i4_file_class *stream)   
  {  
    li_symbol *s=li_symbol::get(o,0);
    char *name=s->name()->value();    
    stream->write(name, strlen(name));
  }
  virtual char *name() { return "symbol"; }

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    li_symbol *s=li_symbol::get(o,env);
    char *name=s->name()->value();
    int name_len=strlen(name)+1;

    fp->write_16(name_len);
    fp->write(name, name_len);
  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
                                 li_environment *env)
  { 
    char buf[200];
    int len=fp->read_16();
    if (len>200)
      li_error(env, "symbol name too long");
    fp->read(buf, len);
    return li_get_symbol(buf);
  }
};



char *li_get_type_name(li_type_number type)
{
  return li_get_type(type)->name();
}

li_string::li_string(i4_file_class *fp) : li_object(LI_STRING)
{
  int l=fp->read_32();
  _name=(char *)I4_MALLOC(l,"");
  fp->read(_name, l);
}

class li_string_type_function : public li_type_function_table
{ 
  virtual void free(li_object   *o) 
  { 
    i4_free(li_string::get(o,0)->value());
  }

  virtual void print(li_object  *o, i4_file_class *stream)   
  { 
    stream->printf("\"%s\"", li_string::get(o,0)->value());
  }

  virtual int equal(li_object  *o1, li_object *o2)  
  {   
    return (strcmp(li_string::get(o1,0)->value(), li_string::get(o2,0)->value())==0);
  }

  virtual char *name() { return "string"; }

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    char *s=li_string::get(o,env)->value();
    int l=strlen(s)+1;
    fp->write_32(l);
    fp->write(s,l);
  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
  {
    return new li_string(fp);
  }

};



class li_int_type_function : public li_type_function_table
{
  virtual int equal(li_object  *o1, li_object *o2)
  { 
    return li_int::get(o1,0)->value()==li_int::get(o2, 0)->value(); 
  }

  virtual void print(li_object  *o, i4_file_class *stream)   
  { 
    stream->printf("%d", li_int::get(o,0)->value());
  }

  virtual char *name() { return "int"; }

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    fp->write_32(li_int::get(o,0)->value());
  }

  virtual li_object *load_object(i4_loader_class *fp,  li_type_number *type_remap,
                                 li_environment *env)
  {
    return new li_int(fp->read_32());
  }
    

};


class li_type_type_function : public li_type_function_table
{
  virtual int equal(li_object  *o1, li_object *o2)  
  { 
    return li_int::get(o1,0)->value()==li_int::get(o2,0)->value(); 
  }

  virtual void print(li_object  *o, i4_file_class *stream)   
  { 
    stream->printf("type-%s", li_get_type(li_type::get(o,0)->value())->name());
  }

  virtual char *name() { return "type"; }

  virtual void save_object(i4_saver_class *fp, li_object *o,
                           li_environment *env)
  {
    li_save_type(fp, li_type::get(o,env)->value());
  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
                                 li_environment *env)
  {
    int new_type=li_load_type(fp, type_remap);
    if (new_type)
      return new li_type(new_type);
    else
      return 0;
  }

};



class li_float_type_function : public li_type_function_table
{
  virtual int equal(li_object  *o1, li_object *o2)  
  { return li_float::get(o1,0)->value()==li_float::get(o2,0)->value(); }

  virtual void print(li_object  *o, i4_file_class *stream)   
  { 
    char buf[200], dec=0;
    sprintf(buf, "%f", li_float::get(o,0)->value());
    
    for (char *c=buf; *c; c++)
      if (*c=='.') dec=1;
    
    if (dec)
    {
      while (buf[strlen(buf)-1]=='0')
        buf[strlen(buf)-1]=0;
    
      if (buf[strlen(buf)-1]=='.')
        buf[strlen(buf)-1]=0;
    }


    stream->write(buf,strlen(buf));
  }

  virtual char *name() { return "float"; }

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    fp->write_float(li_float::get(o,env)->value());
  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
                                 li_environment *env)
  {
    return new li_float(fp->read_float());
  }

};


class li_character_type_function : public li_type_function_table
{
  virtual int equal(li_object  *o1, li_object *o2)  
  { 
    return li_character::get(o1,0)->value()==li_character::get(o2,0)->value(); 
  }

  virtual void print(li_object  *o, i4_file_class *stream)   
  { 
    stream->printf("#%c",li_character::get(o,0)->value());
  }

  virtual char *name() { return "character"; }

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    fp->write_16(li_character::get(o,env)->value());
  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
                                 li_environment *env)
  {
    return new li_character((w8)fp->read_16()); // JJ cast
  }

};



class li_list_type_function : public li_type_function_table
{
  virtual void mark(li_object   *o, int set) 
  { 
    if (o->is_marked() && set)
      return ;

    li_list *l=(li_list *)o;
    if (l->data())
    {
      for (li_list *p=l; p;)
      {
        p->mark(set);
        if (p->data())
        {
          if (set!=p->data()->is_marked())
            li_get_type(p->data()->unmarked_type())->mark(p->data(), set);

          if (p->next() && (set!=p->next()->is_marked()))
          {
            if (p->next()->unmarked_type()==LI_LIST)
              p=(li_list *)p->next();
            else
            {
              li_get_type(p->next()->unmarked_type())->mark(p->next(), set);
              p=0;
            }
          } else p=0;
        }
        else p=0;

      }
    }
  }
  
  virtual void free(li_object   *o) 
  { 
    li_list *l=(li_list *)o;
    l->cleanup();

  }

  virtual int equal(li_object  *o1, li_object *o2)  
  { 
    if (o1==o2) return 1; 
    li_list *p1=li_list::get(o1,0), *p2=li_list::get(o2,0);

    for (;p1;)
    {
      if (!o2) return 0;

      if (p1->data()->type() != p2->data()->type()) return 0;

      if (li_get_type(p1->data()->type())->equal(p1->data(), p2->data())==0)  return 0;
       
      if (p1->next()->type()==LI_LIST)
      {
        if (p2->next()->type()!=LI_LIST)   return 0;
        p1=(li_list *)p1->next();
        p2=(li_list *)p2->next();
      }
      else if (p1->next()->type()!=p2->next()->type()) return 0;
      else return li_get_type(p1->next()->type())->equal(p1->next(), p2->next());
    }

    if (!p2) return 1;
    else return 0;
  }


  virtual void print(li_object  *o, i4_file_class *stream)   
  { 
    stream->write_8('(');
    li_list *p=li_list::get(o,0);
    o->mark(1);          // mark to prevent recursive prints

    for (; p; )
    {  
      li_get_type(p->data()->type())->print(p->data(), stream);

      if (p->next())
      {
        if (p->next()->type()!=LI_LIST)
        {
          stream->write(" . ",3);
          li_get_type(p->next()->type())->print(p->next(), stream);
          p=0;
        }
        else
        {
          p=(li_list *)p->next();
          stream->write_8(' ');
        }
      }
      else p=0;
    }

    o->mark(0);

    stream->write_8(')');
  }

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    int t=0;
    int last_is_cons=0;
    li_list *l;
    for (l=li_list::get(o,env); l;)
    {
      t++;
      if (t>2000000)
        li_error(env, "list is really big : trying to save a circular structure doesn't work");

      li_object *next=l->next();
      if (next)
      {
        if (next->type()!=LI_LIST)
        {
          l=0;
          last_is_cons=0;
        }
        else l=(li_list *)next;
      }
      else l=0;
    }


    fp->write_32(t);

    if (last_is_cons)
      fp->write_8(1);
    else
      fp->write_8(0);

    for (l=li_list::get(o, env); l;)
    {
      li_object *data=l->data();

      li_save_object(fp, data, env);

      li_object *next=l->next();
      if (next)
      {
        if (next->type()==LI_LIST)
          l=(li_list *)next;
        else
        {
          li_save_object(fp, next, env);
          l=0;
        }
      } else l=0;
    }
  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
                                 li_environment *env)
  {
    int t=fp->read_32();
    int last_is_cons=fp->read_8();
    li_list *last=0, *first=0;

    for (int i=0; i<t; i++)
    {
      li_object *data=li_load_object(fp, type_remap, env);
      li_list *l=new li_list(data, 0);
      if (!first)
        first=l;
      else
        last->set_next(l);
      last=l;
    }

    if (last_is_cons)
      last->set_next(li_load_object(fp,type_remap,env));

    return first;
  }


  virtual char *name() { return "list"; }
};





class li_function_type_function : public li_type_function_table
{
  virtual void print(li_object  *o, i4_file_class *stream)
  { 
    stream->printf("#(compiled function @ 0x%x)", (long)(li_function::get(o,0)->value()));
  }

  virtual char *name() { return "function"; }

  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    fp->write_16((w16)li_type::get(o,env)->value()); // JJ cast
  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env)
  {
    int t=type_remap[fp->read_16()];
    if (t)
      return new li_type(t);
    else
      return 0;
  }

};


li_symbol *&li_environment::current_function()
{
  return data->current_function;
}

li_object *&li_environment::current_arguments()
{
  return data->current_args;
}

void li_environment::print_call_stack(i4_file_class *fp)
{
  li_symbol *s=current_function();
  li_object *o=current_arguments();

  if (s && o)
    li_printf(fp, "%O %O", s,o);
  else if (s)
    li_printf(fp, "%O %O", s);

  if (data->next)
    data->next->print_call_stack(fp);
}


li_object *li_environment::value(li_symbol *s)
{
  for (value_data *p=data->value_list; p; p=p->next)
    if (p->symbol==s)
      return p->value;

  if (data->next)
    return data->next->value(s);

  return s->value();
}


li_object *li_environment::fun(li_symbol *s)
{
  for (fun_data *p=data->fun_list; p; p=p->next)
    if (p->symbol==s)
      return p->fun;

  if (data->next)
    return data->next->value(s);

  return s->fun();
}

void li_environment::set_value(li_symbol *s, li_object *value)
{
  if (data->local_namespace)
  {
    for (value_data *p=data->value_list; p; p=p->next)
      if (p->symbol==s)
        p->value=value;
  
    value_data *v=new value_data;
    v->symbol=s;
    v->value=value;
    v->next=data->value_list;
    data->value_list=v;
  }
  else if (data->next)
    data->next->set_value(s,value);
  else
    s->set_value(value);
}


void li_environment::set_fun(li_symbol *s, li_object *fun)
{
  if (data->local_namespace)
  {
    for (fun_data *p=data->fun_list; p; p=p->next)
      if (p->symbol==s)
        p->fun=fun;
  
    fun_data *f=new fun_data;
    f->symbol=s;
    f->fun=fun;
    f->next=data->fun_list;
    data->fun_list=f;
  }
  else if (data->next)
    data->next->set_fun(s, fun);
  else 
    s->set_fun(fun);
}


void li_environment::mark(int set)
{
  li_object::mark(set);

  for (value_data *v=data->value_list; v; v=v->next)
    if (set!=v->value->is_marked())
      li_get_type(v->value->unmarked_type())->mark(v->value,set);

  for (fun_data *f=data->fun_list; f; f=f->next)
    if (set!=f->fun->is_marked())
      li_get_type(f->fun->unmarked_type())->mark(f->fun,set);

  if (data->next && data->next->is_marked()!=set)
    li_get_type(LI_ENVIROMENT)->mark(data->next, set);
}

void li_environment::free()
{
  for (value_data *v=data->value_list; v; )
  {   
    value_data *last=v;
    v=v->next;
    delete last;
  }

  for (fun_data *f=data->fun_list; f; )
  {   
    fun_data *last=f;
    f=f->next;
    delete last;
  }

  delete data;
}

void li_environment::print(i4_file_class *s)
{
  s->printf("#env-(syms=");

  for (value_data *v=data->value_list; v; v=v->next)
  {
    s->write_8('(');
    li_get_type(v->symbol->type())->print(v->symbol, s);
    s->write_8(' ');
    li_get_type(v->value->type())->print(v->value,  s);    
    s->write_8(')');
  }

  s->printf("funs=");
  for (fun_data *f=data->fun_list; f; f=f->next)
  {
    s->write_8('(');
    li_get_type(f->symbol->type())->print(f->symbol, s);
    s->write_8(' ');
    li_get_type(f->fun->type())->print(f->fun,  s);    
    s->write_8(')');
  }
  s->write_8(')');

}



class li_environment_type_function : public li_type_function_table
{
public:
  virtual void mark(li_object   *o, int set)   { ((li_environment *)o)->mark(set); }
  virtual void free(li_object   *o) {  li_environment::get(o,0)->free();  }
  virtual void print(li_object  *o, i4_file_class *s) { li_environment::get(o,0)->print(s); }
  virtual char *name() { return "environment"; }

  
  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env) 
  { li_error(env, "cannot be saved"); }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap, li_environment *env) 
  { 
    li_error(env, "cannot be loaded"); 
    return 0;
  }

};



class li_type_manager_class : public i4_init_class
{

public: 
  i4_array<li_type_function_table *> table;

  int add(li_type_function_table *type_functions,
          li_environment *env=0,
          int anon=0)

  {
    li_type_number old_type=0, new_type=table.size();    

    if (!anon)
    {
      li_symbol *sym=li_get_symbol(type_functions->name());
      if (sym->value() && sym->value()->type()==LI_TYPE)  
      {
        old_type=li_type::get(sym->value(), env)->value();
        i4_warning("attempt to reassign type %s ignored", type_functions->name());
        delete type_functions;
        return old_type;
      }
      
      li_set_value(sym, new li_type(new_type), env);
    }

    table.add(type_functions);

    
    return new_type;
  }

  li_type_manager_class() : table(0,32) {}

  void remove(int type_num)
  {
    delete table[type_num];
    table[type_num]=0;
  }

  li_type_function_table *get(int num)
  {
    return table[num];
  }

  int init_type() { return I4_INIT_TYPE_LISP_BASE_TYPES; }
  void init()
  {
    li_invalid_type_function *invalid=new li_invalid_type_function;  
    for (int i=0; i<LI_LAST_TYPE; i++)
      add(invalid,0,1);
    
    table[LI_SYMBOL]=new li_symbol_type_function;
    table[LI_STRING]=new li_string_type_function;
    table[LI_INT]=new li_int_type_function;
    table[LI_FLOAT]=new li_float_type_function;
    table[LI_LIST]=new li_list_type_function;
    
    table[LI_CHARACTER]=new li_character_type_function;
    table[LI_FUNCTION]=new li_function_type_function;
    table[LI_ENVIROMENT]=new li_environment_type_function;
    table[LI_TYPE]=new li_type_type_function;
  }

  int find(char *name)
  {
    for (int i=1; i<table.size(); i++)
      if (strcmp(table[i]->name(), name)==0)
        return i;

    return 0;
  }

};

static li_type_manager_class li_type_man;

int li_add_type(li_type_function_table *type_functions,   // return type number for type
                li_environment *env,
                int anon)

{
  return li_type_man.add(type_functions, env, anon);
}

void li_remove_type(int type_num)
{
  li_type_man.remove(type_num);
}

void li_cleanup_types()
{
  li_type_man.table.uninit();
}

li_type_function_table *li_get_type(li_type_number type_num)
{
  return li_type_man.get(type_num);
}



li_type_number li_find_type(char *name, li_environment *env)
{
  li_symbol *s=li_find_symbol(name);
  if (s)
    return li_type::get(li_get_value(s, env),env)->value();
  else
    return 0;
}

li_type_number li_find_type(char *name, li_environment *env, li_type_number &cache_to)
{
  if (cache_to)
    return cache_to;
  else
  {
    cache_to=li_type::get(li_get_value(li_get_symbol(name), env), env)->value();
    return cache_to;
  }
}



i4_bool li_valid_type(li_type_number type_number)
{
  return type_number>=0 && type_number< (w32)li_type_man.table.size() &&  // JJ cast
    li_type_man.table[type_number]!=0;
}

int li_max_types()
{
  return li_type_man.table.size();
}

// lisp/li_vect.cpp
/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "lisp/li_vect.hh"
#include "lisp/lisp.hh"
#include "file/file.hh"
#include "loaders/dir_save.hh"
#include "loaders/dir_load.hh"
#include "lisp/li_init.hh"

li_type_number li_vect_type;
class li_vect_type_function_table : public li_type_function_table
{ 
public:
  // free data associated with an instance of this type
  virtual void free(li_object   *o)
  {
    delete li_vect::get(o,0)->v;
  }

  virtual int equal(li_object  *o1, li_object *o2) 
  { 
    i4_3d_vector v1=li_vect::get(o1,0)->value(), v2=li_vect::get(o2,0)->value();
    return v1.x==v2.x && v1.y==v2.y && v1.z==v1.z;
  }

  virtual void print(li_object  *o, i4_file_class *stream)
  {
    i4_3d_vector v=li_vect::get(o,0)->value();
    stream->printf("(vector %f %f %f)",v.x, v.y, v.z);
  }

  virtual char *name() { return "vector"; }

  virtual li_object *create(li_object *params, li_environment *env)
  {
    i4_3d_vector v;
    if (params)
    {
      v.x=li_get_float(li_eval(li_car(params,env), env),env); params=li_cdr(params,env);
      v.y=li_get_float(li_eval(li_car(params,env), env),env); params=li_cdr(params,env);
      v.z=li_get_float(li_eval(li_car(params,env), env),env); params=li_cdr(params,env);
    }
      
    return new li_vect(v);
  }


  virtual void save_object(i4_saver_class *fp, li_object *o, li_environment *env)
  {
    i4_3d_vector v=li_vect::get(o,env)->value();
    fp->write_float(v.x);
    fp->write_float(v.y);
    fp->write_float(v.z);

  }

  virtual li_object *load_object(i4_loader_class *fp, li_type_number *type_remap,
                                 li_environment *env)
  {
    i4_3d_vector v;
    v.x=fp->read_float();
    v.y=fp->read_float();
    v.z=fp->read_float();
    return new li_vect(v);
  }
};

li_automatic_add_type(li_vect_type_function_table, li_vect_type);

// lisp/msvc_lip.cpp
/********************************************************************** <BR>
  This file is part of Crack dot Com's free source code release of
  Golgotha. <a href="http://www.crack.com/golgotha_release"> <BR> for
  information about compiling & licensing issues visit this URL</a> 
  <PRE> If that doesn't help, contact Jonathan Clark at 
  golgotha_source@usa.net (Subject should have "GOLG" in it) 
***********************************************************************/

#include "lisp/lisp.hh"

#ifdef _WINDOWS
static li_object *msvc_inspect=0;
static char FP_SAVE[108];

void msvc_lip()
{
  __asm {
    pushfd
    pushad
    fsave FP_SAVE
    frstor FP_SAVE    
  }

  lip(msvc_inspect);

  __asm {
    frstor FP_SAVE    
    popad
    popfd
  }
}
#endif

