source: abuse/trunk/src/lisp/lisp.cpp @ 555 Tweet

/*
 *  Abuse - dark 2D side-scrolling platform game
 *  Copyright (c) 1995 Crack dot Com
 *  Copyright (c) 2005-2011 Sam Hocevar <sam@hocevar.net>
 *
 *  This software was released into the Public Domain. As with most public
 *  domain software, no warranty is made or implied by Crack dot Com, by
 *  Jonathan Clark, or by Sam Hocevar.
 */

#if defined HAVE_CONFIG_H
#   include "config.h"
#endif

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

#include "common.h"

#define TYPE_CHECKING 1

#include "lisp.h"
#include "lisp_gc.h"
#include "symbols.h"

#ifdef NO_LIBS
#   include "fakelib.h"
#else
#   include "status.h"
#   include "specs.h"
#   include "dprint.h"
#   include "cache.h"
#   include "dev.h"
#endif

/* To bypass the whole garbage collection issue of lisp I am going to have
 * separate spaces where lisp objects can reside.  Compiled code and gloabal
 * variables will reside in permanant space.  Eveything else will reside in
 * tmp space which gets thrown away after completion of eval.  system
 * functions reside in permant space. */

bFILE *current_print_file=NULL;

LSymbol *LSymbol::root = NULL;
size_t LSymbol::count = 0;


uint8_t *space[4], *free_space[4];
size_t space_size[4];
int print_level = 0, trace_level = 0, trace_print_level = 1000;
int total_user_functions;

int current_space;  // normally set to TMP_SPACE, unless compiling or other needs

int break_level=0;

void l1print(void *block)
{
    if(!block || item_type(block) != L_CONS_CELL)
    {
        ((LObject *)block)->Print();
        return;
    }

    dprintf("(");
    for( ; block && item_type(block) == L_CONS_CELL; block = CDR(block))
    {
        void *a = CAR(block);
        if(item_type(a) == L_CONS_CELL)
            dprintf("[...]");
        else
            ((LObject *)a)->Print();
    }
    if (block)
    {
        dprintf(" . ");
        ((LObject *)block)->Print();
    }
    dprintf(")");
}

void where_print(int max_lev = -1)
{
    dprintf("Main program\n");
    if (max_lev==-1) max_lev=PtrRef::stack.son;
    else if (max_lev>=PtrRef::stack.son) max_lev=PtrRef::stack.son-1;

    for (int i=0; i<max_lev; i++)
    {
        dprintf("%d> ", i);
        ((LObject *)*PtrRef::stack.sdata[i])->Print();
    }
}

void print_trace_stack(int max_levels)
{
    where_print(max_levels);
}

void lbreak(char const *format, ...)
{
  break_level++;
  bFILE *old_file=current_print_file;
  current_print_file=NULL;
  char st[300];
  va_list ap;
  va_start(ap, format);
  vsprintf(st, format, ap);
  va_end(ap);
  dprintf("%s\n", st);
  int cont=0;
  do
  {
    dprintf("type q to quit\n");
    dprintf("%d. Break> ", break_level);
    dgets(st, 300);
    if (!strcmp(st, "c") || !strcmp(st, "cont") || !strcmp(st, "continue"))
      cont=1;
    else if (!strcmp(st, "w") || !strcmp(st, "where"))
      where_print();
    else if (!strcmp(st, "q") || !strcmp(st, "quit"))
      exit(1);
    else if (!strcmp(st, "e") || !strcmp(st, "env") || !strcmp(st, "environment"))
    {
      dprintf("Enviorment : \nnot supported right now\n");

    }
    else if (!strcmp(st, "h") || !strcmp(st, "help") || !strcmp(st, "?"))
    {
      dprintf("CLIVE Debugger\n");
      dprintf(" w, where : show calling parents\n"
          " e, env   : show environment\n"
          " c, cont  : continue if possible\n"
          " q, quit  : quits the program\n"
          " h, help  : this\n");
    }
    else
    {
      char const *s=st;
      do
      {
        LObject *prog = LObject::Compile(s);
        PtrRef r1(prog);
        while (*s==' ' || *s=='\t' || *s=='\r' || *s=='\n')
            s++;
        prog->Eval()->Print();
      } while (*s);
    }

  } while (!cont);
  current_print_file=old_file;
  break_level--;
}

void need_perm_space(char const *why)
{
  if (current_space!=PERM_SPACE && current_space!=GC_SPACE)
  {
    lbreak("%s : action requires permanant space\n", why);
    exit(0);
  }
}

void *mark_heap(int heap)
{
  return free_space[heap];
}

void restore_heap(void *val, int heap)
{
  free_space[heap] = (uint8_t *)val;
}

static size_t get_free_size(int which_space)
{
    size_t used = free_space[which_space] - space[which_space];
    return space_size[which_space] > used ? space_size[which_space] - used : 0;
}

static void *lmalloc(size_t size, int which_space)
{
    // Align allocation
    size = (size + sizeof(intptr_t) - 1) & ~(sizeof(intptr_t) - 1);

    // Collect garbage if necessary
    if (size > get_free_size(which_space))
    {
        if (which_space == PERM_SPACE || which_space == TMP_SPACE)
            collect_space(which_space, 0);

        if (size > get_free_size(which_space))
            collect_space(which_space, 1);

        if (size > get_free_size(which_space))
        {
            lbreak("lisp: cannot find %d bytes in space #%d\n",
                   size, which_space);
            exit(0);
        }
    }

    void *ret = (void *)free_space[which_space];
    free_space[which_space] += size;
    return ret;
}

void *eval_block(void *list)
{
  PtrRef r1(list);
  void *ret=NULL;
  while (list)
  {
    ret = CAR(list)->Eval();
    list = CDR(list);
  }
  return ret;
}

LArray *LArray::Create(size_t len, void *rest)
{
    PtrRef r11(rest);
    size_t size = sizeof(LArray) + (len - 1) * sizeof(LObject *);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LArray *p = (LArray *)lmalloc(size, current_space);
    p->type = L_1D_ARRAY;
    p->len = len;
    LObject **data = p->GetData();
    memset(data, 0, len * sizeof(LObject *));
    PtrRef r1(p);

    if (rest)
    {
        LObject *x = CAR(rest)->Eval();
        if (x == colon_initial_contents)
        {
            x = CAR(CDR(rest))->Eval();
            data = p->GetData();
            for (size_t i = 0; i < len; i++, x = CDR(x))
            {
                if (!x)
                {
                    ((LObject *)rest)->Print();
                    lbreak("(make-array) incorrect list length\n");
                    exit(0);
                }
                data[i] = (LObject *)CAR(x);
            }
            if (x)
            {
                ((LObject *)rest)->Print();
                lbreak("(make-array) incorrect list length\n");
                exit(0);
            }
        }
        else if (x == colon_initial_element)
        {
            x = CAR(CDR(rest))->Eval();
            data = p->GetData();
            for (size_t i = 0; i < len; i++)
                data[i] = (LObject *)x;
        }
        else
        {
            ((LObject *)x)->Print();
            lbreak("Bad option argument to make-array\n");
            exit(0);
        }
    }

    return p;
}

LFixedPoint *LFixedPoint::Create(int32_t x)
{
    size_t size = sizeof(LFixedPoint);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LFixedPoint *p = (LFixedPoint *)lmalloc(size, current_space);
    p->type = L_FIXED_POINT;
    p->x = x;
    return p;
}

LObjectVar *LObjectVar::Create(int index)
{
    size_t size = sizeof(LObjectVar);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LObjectVar *p = (LObjectVar *)lmalloc(size, current_space);
    p->type = L_OBJECT_VAR;
    p->index = index;
    return p;
}

LPointer *LPointer::Create(void *addr)
{
    if (addr == NULL)
        return NULL;
    size_t size = sizeof(LPointer);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LPointer *p = (LPointer *)lmalloc(size, current_space);
    p->type = L_POINTER;
    p->addr = addr;
    return p;
}

LChar *LChar::Create(uint16_t ch)
{
    size_t size = sizeof(LChar);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LChar *c = (LChar *)lmalloc(size, current_space);
    c->type = L_CHARACTER;
    c->ch = ch;
    return c;
}

struct LString *LString::Create(char const *string)
{
    LString *s = Create(strlen(string) + 1);
    strcpy(s->str, string);
    return s;
}

struct LString *LString::Create(char const *string, int length)
{
    LString *s = Create(length + 1);
    memcpy(s->str, string, length);
    s->str[length] = 0;
    return s;
}

struct LString *LString::Create(int length)
{
    size_t size = sizeof(LString) + length - 1;
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LString *s = (LString *)lmalloc(size, current_space);
    s->type = L_STRING;
    s->str[0] = '\0';
    return s;
}

LUserFunction *new_lisp_user_function(LList *arg_list, LList *block_list)
{
    PtrRef r1(arg_list), r2(block_list);

    size_t size = sizeof(LUserFunction);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LUserFunction *lu = (LUserFunction *)lmalloc(size, current_space);
    lu->type = L_USER_FUNCTION;
    lu->arg_list = arg_list;
    lu->block_list = block_list;
    return lu;
}

LSysFunction *new_lisp_sys_function(int min_args, int max_args, int fun_number)
{
    size_t size = sizeof(LSysFunction);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    // System functions should reside in permanant space
    int space = (current_space == GC_SPACE) ? GC_SPACE : PERM_SPACE;
    LSysFunction *ls = (LSysFunction *)lmalloc(size, space);
    ls->type = L_SYS_FUNCTION;
    ls->min_args = min_args;
    ls->max_args = max_args;
    ls->fun_number = fun_number;
    return ls;
}

LSysFunction *new_lisp_c_function(int min_args, int max_args, int fun_number)
{
    LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
    ls->type = L_C_FUNCTION;
    return ls;
}

LSysFunction *new_lisp_c_bool(int min_args, int max_args, int fun_number)
{
    LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
    ls->type = L_C_BOOL;
    return ls;
}

LSysFunction *new_user_lisp_function(int min_args, int max_args, int fun_number)
{
    LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
    ls->type = L_L_FUNCTION;
    return ls;
}

LSymbol *new_lisp_symbol(char *name)
{
    size_t size = sizeof(LSymbol);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LSymbol *s = (LSymbol *)lmalloc(size, current_space);
    s->type = L_SYMBOL;
    s->name = LString::Create(name);
    s->value = l_undefined;
    s->function = l_undefined;
#ifdef L_PROFILE
    s->time_taken = 0;
#endif
    return s;
}

LNumber *LNumber::Create(long num)
{
    size_t size = sizeof(LNumber);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LNumber *n = (LNumber *)lmalloc(size, current_space);
    n->type = L_NUMBER;
    n->num = num;
    return n;
}

LList *LList::Create()
{
    size_t size = sizeof(LList);
    if (size < sizeof(LRedirect))
        size = sizeof(LRedirect);

    LList *c = (LList *)lmalloc(size, current_space);
    c->type = L_CONS_CELL;
    c->car = NULL;
    c->cdr = NULL;
    return c;
}

char *lerror(char const *loc, char const *cause)
{
  int lines;
  if (loc)
  {
    for (lines=0; *loc && lines<10; loc++)
    {
      if (*loc=='\n') lines++;
      dprintf("%c", *loc);
    }
    dprintf("\nPROGRAM LOCATION : \n");
  }
  if (cause)
    dprintf("ERROR MESSAGE : %s\n", cause);
  lbreak("");
  exit(0);
  return NULL;
}

void *nth(int num, void *list)
{
  if (num<0)
  {
    lbreak("NTH: %d is not a nonnegative fixnum and therefore not a valid index\n", num);
    exit(1);
  }

  while (list && num)
  {
    list=CDR(list);
    num--;
  }
  if (!list) return NULL;
  else return CAR(list);
}

void *lpointer_value(void *lpointer)
{
  if (!lpointer) return NULL;
#ifdef TYPE_CHECKING
  else if (item_type(lpointer)!=L_POINTER)
  {
    ((LObject *)lpointer)->Print();
    lbreak(" is not a pointer\n");
    exit(0);
  }
#endif
  return ((LPointer *)lpointer)->addr;
}

int32_t lnumber_value(void *lnumber)
{
  switch (item_type(lnumber))
  {
    case L_NUMBER :
      return ((LNumber *)lnumber)->num;
    case L_FIXED_POINT :
      return (((LFixedPoint *)lnumber)->x)>>16;
    case L_STRING :
      return (uint8_t)*lstring_value(lnumber);
    case L_CHARACTER :
      return lcharacter_value(lnumber);
    default :
    {
      ((LObject *)lnumber)->Print();
      lbreak(" is not a number\n");
      exit(0);
    }
  }
  return 0;
}

char *LString::GetString()
{
#ifdef TYPE_CHECKING
    if (item_type(this) != L_STRING)
    {
        Print();
        lbreak(" is not a string\n");
        exit(0);
    }
#endif
    return str;
}

void *lisp_atom(void *i)
{
  if (item_type(i)==(ltype)L_CONS_CELL)
    return NULL;
  else return true_symbol;
}

LObject *lcdr(void *c)
{
  if (!c) return NULL;
  else if (item_type(c)==(ltype)L_CONS_CELL)
    return ((LList *)c)->cdr;
  else
    return NULL;
}

LObject *lcar(void *c)
{
  if (!c) return NULL;
  else if (item_type(c)==(ltype)L_CONS_CELL)
    return ((LList *)c)->car;
  else return NULL;
}

uint16_t lcharacter_value(void *c)
{
#ifdef TYPE_CHECKING
  if (item_type(c)!=L_CHARACTER)
  {
    ((LObject *)c)->Print();
    lbreak("is not a character\n");
    exit(0);
  }
#endif
  return ((LChar *)c)->ch;
}

long lfixed_point_value(void *c)
{
  switch (item_type(c))
  {
    case L_NUMBER :
      return ((LNumber *)c)->num<<16; break;
    case L_FIXED_POINT :
      return (((LFixedPoint *)c)->x); break;
    default :
    {
      ((LObject *)c)->Print();
      lbreak(" is not a number\n");
      exit(0);
    }
  }
  return 0;
}

void *lisp_eq(void *n1, void *n2)
{
  if (!n1 && !n2) return true_symbol;
  else if ((n1 && !n2) || (n2 && !n1)) return NULL;
  {
    int t1=*((ltype *)n1), t2=*((ltype *)n2);
    if (t1!=t2) return NULL;
    else if (t1==L_NUMBER)
    { if (((LNumber *)n1)->num==((LNumber *)n2)->num)
        return true_symbol;
      else return NULL;
    } else if (t1==L_CHARACTER)
    {
      if (((LChar *)n1)->ch==((LChar *)n2)->ch)
        return true_symbol;
      else return NULL;
    }
    else if (n1==n2)
      return true_symbol;
    else if (t1==L_POINTER)
      if (n1==n2) return true_symbol;
  }
  return NULL;
}

LObject *LArray::Get(int x)
{
#ifdef TYPE_CHECKING
    if (type != L_1D_ARRAY)
    {
        Print();
        lbreak("is not an array\n");
        exit(0);
    }
#endif
    if (x >= (int)len || x < 0)
    {
        lbreak("array reference out of bounds (%d)\n", x);
        exit(0);
    }
    return data[x];
}

void *lisp_equal(void *n1, void *n2)
{
    if(!n1 && !n2) // if both nil, then equal
        return true_symbol;

    if(!n1 || !n2) // one nil, nope
        return NULL;

    int t1 = item_type(n1), t2 = item_type(n2);
    if(t1 != t2)
        return NULL;

    switch (t1)
    {
    case L_STRING :
        if (!strcmp(lstring_value(n1), lstring_value(n2)))
            return true_symbol;
        return NULL;
    case L_CONS_CELL :
        while (n1 && n2) // loop through the list and compare each element
        {
          if (!lisp_equal(CAR(n1), CAR(n2)))
            return NULL;
          n1=CDR(n1);
          n2=CDR(n2);
          if (n1 && *((ltype *)n1)!=L_CONS_CELL)
            return lisp_equal(n1, n2);
        }
        if (n1 || n2)