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

Last change on this file since 555 was 555, checked in by Sam Hocevar, 11 years ago

ps3: make everything compile on the PS3. Of course, nothing links yet
because so much support is missing.

File size: 81.4 KB
Line 
1/*
2 *  Abuse - dark 2D side-scrolling platform game
3 *  Copyright (c) 1995 Crack dot Com
4 *  Copyright (c) 2005-2011 Sam Hocevar <sam@hocevar.net>
5 *
6 *  This software was released into the Public Domain. As with most public
7 *  domain software, no warranty is made or implied by Crack dot Com, by
8 *  Jonathan Clark, or by Sam Hocevar.
9 */
10
11#if defined HAVE_CONFIG_H
12#   include "config.h"
13#endif
14
15#include <stdio.h>
16#include <ctype.h>
17#include <stdlib.h>
18#include <string.h>
19#include <stdarg.h>
20
21#include "common.h"
22
23#define TYPE_CHECKING 1
24
25#include "lisp.h"
26#include "lisp_gc.h"
27#include "symbols.h"
28
29#ifdef NO_LIBS
30#   include "fakelib.h"
31#else
32#   include "status.h"
33#   include "specs.h"
34#   include "dprint.h"
35#   include "cache.h"
36#   include "dev.h"
37#endif
38
39/* To bypass the whole garbage collection issue of lisp I am going to have
40 * separate spaces where lisp objects can reside.  Compiled code and gloabal
41 * variables will reside in permanant space.  Eveything else will reside in
42 * tmp space which gets thrown away after completion of eval.  system
43 * functions reside in permant space. */
44
45bFILE *current_print_file=NULL;
46
47LSymbol *LSymbol::root = NULL;
48size_t LSymbol::count = 0;
49
50
51uint8_t *space[4], *free_space[4];
52size_t space_size[4];
53int print_level = 0, trace_level = 0, trace_print_level = 1000;
54int total_user_functions;
55
56int current_space;  // normally set to TMP_SPACE, unless compiling or other needs
57
58int break_level=0;
59
60void l1print(void *block)
61{
62    if(!block || item_type(block) != L_CONS_CELL)
63    {
64        ((LObject *)block)->Print();
65        return;
66    }
67
68    dprintf("(");
69    for( ; block && item_type(block) == L_CONS_CELL; block = CDR(block))
70    {
71        void *a = CAR(block);
72        if(item_type(a) == L_CONS_CELL)
73            dprintf("[...]");
74        else
75            ((LObject *)a)->Print();
76    }
77    if (block)
78    {
79        dprintf(" . ");
80        ((LObject *)block)->Print();
81    }
82    dprintf(")");
83}
84
85void where_print(int max_lev = -1)
86{
87    dprintf("Main program\n");
88    if (max_lev==-1) max_lev=PtrRef::stack.son;
89    else if (max_lev>=PtrRef::stack.son) max_lev=PtrRef::stack.son-1;
90
91    for (int i=0; i<max_lev; i++)
92    {
93        dprintf("%d> ", i);
94        ((LObject *)*PtrRef::stack.sdata[i])->Print();
95    }
96}
97
98void print_trace_stack(int max_levels)
99{
100    where_print(max_levels);
101}
102
103void lbreak(char const *format, ...)
104{
105  break_level++;
106  bFILE *old_file=current_print_file;
107  current_print_file=NULL;
108  char st[300];
109  va_list ap;
110  va_start(ap, format);
111  vsprintf(st, format, ap);
112  va_end(ap);
113  dprintf("%s\n", st);
114  int cont=0;
115  do
116  {
117    dprintf("type q to quit\n");
118    dprintf("%d. Break> ", break_level);
119    dgets(st, 300);
120    if (!strcmp(st, "c") || !strcmp(st, "cont") || !strcmp(st, "continue"))
121      cont=1;
122    else if (!strcmp(st, "w") || !strcmp(st, "where"))
123      where_print();
124    else if (!strcmp(st, "q") || !strcmp(st, "quit"))
125      exit(1);
126    else if (!strcmp(st, "e") || !strcmp(st, "env") || !strcmp(st, "environment"))
127    {
128      dprintf("Enviorment : \nnot supported right now\n");
129
130    }
131    else if (!strcmp(st, "h") || !strcmp(st, "help") || !strcmp(st, "?"))
132    {
133      dprintf("CLIVE Debugger\n");
134      dprintf(" w, where : show calling parents\n"
135          " e, env   : show environment\n"
136          " c, cont  : continue if possible\n"
137          " q, quit  : quits the program\n"
138          " h, help  : this\n");
139    }
140    else
141    {
142      char const *s=st;
143      do
144      {
145        LObject *prog = LObject::Compile(s);
146        PtrRef r1(prog);
147        while (*s==' ' || *s=='\t' || *s=='\r' || *s=='\n')
148            s++;
149        prog->Eval()->Print();
150      } while (*s);
151    }
152
153  } while (!cont);
154  current_print_file=old_file;
155  break_level--;
156}
157
158void need_perm_space(char const *why)
159{
160  if (current_space!=PERM_SPACE && current_space!=GC_SPACE)
161  {
162    lbreak("%s : action requires permanant space\n", why);
163    exit(0);
164  }
165}
166
167void *mark_heap(int heap)
168{
169  return free_space[heap];
170}
171
172void restore_heap(void *val, int heap)
173{
174  free_space[heap] = (uint8_t *)val;
175}
176
177static size_t get_free_size(int which_space)
178{
179    size_t used = free_space[which_space] - space[which_space];
180    return space_size[which_space] > used ? space_size[which_space] - used : 0;
181}
182
183static void *lmalloc(size_t size, int which_space)
184{
185    // Align allocation
186    size = (size + sizeof(intptr_t) - 1) & ~(sizeof(intptr_t) - 1);
187
188    // Collect garbage if necessary
189    if (size > get_free_size(which_space))
190    {
191        if (which_space == PERM_SPACE || which_space == TMP_SPACE)
192            collect_space(which_space, 0);
193
194        if (size > get_free_size(which_space))
195            collect_space(which_space, 1);
196
197        if (size > get_free_size(which_space))
198        {
199            lbreak("lisp: cannot find %d bytes in space #%d\n",
200                   size, which_space);
201            exit(0);
202        }
203    }
204
205    void *ret = (void *)free_space[which_space];
206    free_space[which_space] += size;
207    return ret;
208}
209
210void *eval_block(void *list)
211{
212  PtrRef r1(list);
213  void *ret=NULL;
214  while (list)
215  {
216    ret = CAR(list)->Eval();
217    list = CDR(list);
218  }
219  return ret;
220}
221
222LArray *LArray::Create(size_t len, void *rest)
223{
224    PtrRef r11(rest);
225    size_t size = sizeof(LArray) + (len - 1) * sizeof(LObject *);
226    if (size < sizeof(LRedirect))
227        size = sizeof(LRedirect);
228
229    LArray *p = (LArray *)lmalloc(size, current_space);
230    p->type = L_1D_ARRAY;
231    p->len = len;
232    LObject **data = p->GetData();
233    memset(data, 0, len * sizeof(LObject *));
234    PtrRef r1(p);
235
236    if (rest)
237    {
238        LObject *x = CAR(rest)->Eval();
239        if (x == colon_initial_contents)
240        {
241            x = CAR(CDR(rest))->Eval();
242            data = p->GetData();
243            for (size_t i = 0; i < len; i++, x = CDR(x))
244            {
245                if (!x)
246                {
247                    ((LObject *)rest)->Print();
248                    lbreak("(make-array) incorrect list length\n");
249                    exit(0);
250                }
251                data[i] = (LObject *)CAR(x);
252            }
253            if (x)
254            {
255                ((LObject *)rest)->Print();
256                lbreak("(make-array) incorrect list length\n");
257                exit(0);
258            }
259        }
260        else if (x == colon_initial_element)
261        {
262            x = CAR(CDR(rest))->Eval();
263            data = p->GetData();
264            for (size_t i = 0; i < len; i++)
265                data[i] = (LObject *)x;
266        }
267        else
268        {
269            ((LObject *)x)->Print();
270            lbreak("Bad option argument to make-array\n");
271            exit(0);
272        }
273    }
274
275    return p;
276}
277
278LFixedPoint *LFixedPoint::Create(int32_t x)
279{
280    size_t size = sizeof(LFixedPoint);
281    if (size < sizeof(LRedirect))
282        size = sizeof(LRedirect);
283
284    LFixedPoint *p = (LFixedPoint *)lmalloc(size, current_space);
285    p->type = L_FIXED_POINT;
286    p->x = x;
287    return p;
288}
289
290LObjectVar *LObjectVar::Create(int index)
291{
292    size_t size = sizeof(LObjectVar);
293    if (size < sizeof(LRedirect))
294        size = sizeof(LRedirect);
295
296    LObjectVar *p = (LObjectVar *)lmalloc(size, current_space);
297    p->type = L_OBJECT_VAR;
298    p->index = index;
299    return p;
300}
301
302LPointer *LPointer::Create(void *addr)
303{
304    if (addr == NULL)
305        return NULL;
306    size_t size = sizeof(LPointer);
307    if (size < sizeof(LRedirect))
308        size = sizeof(LRedirect);
309
310    LPointer *p = (LPointer *)lmalloc(size, current_space);
311    p->type = L_POINTER;
312    p->addr = addr;
313    return p;
314}
315
316LChar *LChar::Create(uint16_t ch)
317{
318    size_t size = sizeof(LChar);
319    if (size < sizeof(LRedirect))
320        size = sizeof(LRedirect);
321
322    LChar *c = (LChar *)lmalloc(size, current_space);
323    c->type = L_CHARACTER;
324    c->ch = ch;
325    return c;
326}
327
328struct LString *LString::Create(char const *string)
329{
330    LString *s = Create(strlen(string) + 1);
331    strcpy(s->str, string);
332    return s;
333}
334
335struct LString *LString::Create(char const *string, int length)
336{
337    LString *s = Create(length + 1);
338    memcpy(s->str, string, length);
339    s->str[length] = 0;
340    return s;
341}
342
343struct LString *LString::Create(int length)
344{
345    size_t size = sizeof(LString) + length - 1;
346    if (size < sizeof(LRedirect))
347        size = sizeof(LRedirect);
348
349    LString *s = (LString *)lmalloc(size, current_space);
350    s->type = L_STRING;
351    s->str[0] = '\0';
352    return s;
353}
354
355LUserFunction *new_lisp_user_function(LList *arg_list, LList *block_list)
356{
357    PtrRef r1(arg_list), r2(block_list);
358
359    size_t size = sizeof(LUserFunction);
360    if (size < sizeof(LRedirect))
361        size = sizeof(LRedirect);
362
363    LUserFunction *lu = (LUserFunction *)lmalloc(size, current_space);
364    lu->type = L_USER_FUNCTION;
365    lu->arg_list = arg_list;
366    lu->block_list = block_list;
367    return lu;
368}
369
370LSysFunction *new_lisp_sys_function(int min_args, int max_args, int fun_number)
371{
372    size_t size = sizeof(LSysFunction);
373    if (size < sizeof(LRedirect))
374        size = sizeof(LRedirect);
375
376    // System functions should reside in permanant space
377    int space = (current_space == GC_SPACE) ? GC_SPACE : PERM_SPACE;
378    LSysFunction *ls = (LSysFunction *)lmalloc(size, space);
379    ls->type = L_SYS_FUNCTION;
380    ls->min_args = min_args;
381    ls->max_args = max_args;
382    ls->fun_number = fun_number;
383    return ls;
384}
385
386LSysFunction *new_lisp_c_function(int min_args, int max_args, int fun_number)
387{
388    LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
389    ls->type = L_C_FUNCTION;
390    return ls;
391}
392
393LSysFunction *new_lisp_c_bool(int min_args, int max_args, int fun_number)
394{
395    LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
396    ls->type = L_C_BOOL;
397    return ls;
398}
399
400LSysFunction *new_user_lisp_function(int min_args, int max_args, int fun_number)
401{
402    LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
403    ls->type = L_L_FUNCTION;
404    return ls;
405}
406
407LSymbol *new_lisp_symbol(char *name)
408{
409    size_t size = sizeof(LSymbol);
410    if (size < sizeof(LRedirect))
411        size = sizeof(LRedirect);
412
413    LSymbol *s = (LSymbol *)lmalloc(size, current_space);
414    s->type = L_SYMBOL;
415    s->name = LString::Create(name);
416    s->value = l_undefined;
417    s->function = l_undefined;
418#ifdef L_PROFILE
419    s->time_taken = 0;
420#endif
421    return s;
422}
423
424LNumber *LNumber::Create(long num)
425{
426    size_t size = sizeof(LNumber);
427    if (size < sizeof(LRedirect))
428        size = sizeof(LRedirect);
429
430    LNumber *n = (LNumber *)lmalloc(size, current_space);
431    n->type = L_NUMBER;
432    n->num = num;
433    return n;
434}
435
436LList *LList::Create()
437{
438    size_t size = sizeof(LList);
439    if (size < sizeof(LRedirect))
440        size = sizeof(LRedirect);
441
442    LList *c = (LList *)lmalloc(size, current_space);
443    c->type = L_CONS_CELL;
444    c->car = NULL;
445    c->cdr = NULL;
446    return c;
447}
448
449char *lerror(char const *loc, char const *cause)
450{
451  int lines;
452  if (loc)
453  {
454    for (lines=0; *loc && lines<10; loc++)
455    {
456      if (*loc=='\n') lines++;
457      dprintf("%c", *loc);
458    }
459    dprintf("\nPROGRAM LOCATION : \n");
460  }
461  if (cause)
462    dprintf("ERROR MESSAGE : %s\n", cause);
463  lbreak("");
464  exit(0);
465  return NULL;
466}
467
468void *nth(int num, void *list)
469{
470  if (num<0)
471  {
472    lbreak("NTH: %d is not a nonnegative fixnum and therefore not a valid index\n", num);
473    exit(1);
474  }
475
476  while (list && num)
477  {
478    list=CDR(list);
479    num--;
480  }
481  if (!list) return NULL;
482  else return CAR(list);
483}
484
485void *lpointer_value(void *lpointer)
486{
487  if (!lpointer) return NULL;
488#ifdef TYPE_CHECKING
489  else if (item_type(lpointer)!=L_POINTER)
490  {
491    ((LObject *)lpointer)->Print();
492    lbreak(" is not a pointer\n");
493    exit(0);
494  }
495#endif
496  return ((LPointer *)lpointer)->addr;
497}
498
499int32_t lnumber_value(void *lnumber)
500{
501  switch (item_type(lnumber))
502  {
503    case L_NUMBER :
504      return ((LNumber *)lnumber)->num;
505    case L_FIXED_POINT :
506      return (((LFixedPoint *)lnumber)->x)>>16;
507    case L_STRING :
508      return (uint8_t)*lstring_value(lnumber);
509    case L_CHARACTER :
510      return lcharacter_value(lnumber);
511    default :
512    {
513      ((LObject *)lnumber)->Print();
514      lbreak(" is not a number\n");
515      exit(0);
516    }
517  }
518  return 0;
519}
520
521char *LString::GetString()
522{
523#ifdef TYPE_CHECKING
524    if (item_type(this) != L_STRING)
525    {
526        Print();
527        lbreak(" is not a string\n");
528        exit(0);
529    }
530#endif
531    return str;
532}
533
534void *lisp_atom(void *i)
535{
536  if (item_type(i)==(ltype)L_CONS_CELL)
537    return NULL;
538  else return true_symbol;
539}
540
541LObject *lcdr(void *c)
542{
543  if (!c) return NULL;
544  else if (item_type(c)==(ltype)L_CONS_CELL)
545    return ((LList *)c)->cdr;
546  else
547    return NULL;
548}
549
550LObject *lcar(void *c)
551{
552  if (!c) return NULL;
553  else if (item_type(c)==(ltype)L_CONS_CELL)
554    return ((LList *)c)->car;
555  else return NULL;
556}
557
558uint16_t lcharacter_value(void *c)
559{
560#ifdef TYPE_CHECKING
561  if (item_type(c)!=L_CHARACTER)
562  {
563    ((LObject *)c)->Print();
564    lbreak("is not a character\n");
565    exit(0);
566  }
567#endif
568  return ((LChar *)c)->ch;
569}
570
571long lfixed_point_value(void *c)
572{
573  switch (item_type(c))
574  {
575    case L_NUMBER :
576      return ((LNumber *)c)->num<<16; break;
577    case L_FIXED_POINT :
578      return (((LFixedPoint *)c)->x); break;
579    default :
580    {
581      ((LObject *)c)->Print();
582      lbreak(" is not a number\n");
583      exit(0);
584    }
585  }
586  return 0;
587}
588
589void *lisp_eq(void *n1, void *n2)
590{
591  if (!n1 && !n2) return true_symbol;
592  else if ((n1 && !n2) || (n2 && !n1)) return NULL;
593  {
594    int t1=*((ltype *)n1), t2=*((ltype *)n2);
595    if (t1!=t2) return NULL;
596    else if (t1==L_NUMBER)
597    { if (((LNumber *)n1)->num==((LNumber *)n2)->num)
598        return true_symbol;
599      else return NULL;
600    } else if (t1==L_CHARACTER)
601    {
602      if (((LChar *)n1)->ch==((LChar *)n2)->ch)
603        return true_symbol;
604      else return NULL;
605    }
606    else if (n1==n2)
607      return true_symbol;
608    else if (t1==L_POINTER)
609      if (n1==n2) return true_symbol;
610  }
611  return NULL;
612}
613
614LObject *LArray::Get(int x)
615{
616#ifdef TYPE_CHECKING
617    if (type != L_1D_ARRAY)
618    {
619        Print();
620        lbreak("is not an array\n");
621        exit(0);
622    }
623#endif
624    if (x >= (int)len || x < 0)
625    {
626        lbreak("array reference out of bounds (%d)\n", x);
627        exit(0);
628    }
629    return data[x];
630}
631
632void *lisp_equal(void *n1, void *n2)
633{
634    if(!n1 && !n2) // if both nil, then equal
635        return true_symbol;
636
637    if(!n1 || !n2) // one nil, nope
638        return NULL;
639
640    int t1 = item_type(n1), t2 = item_type(n2);
641    if(t1 != t2)
642        return NULL;
643
644    switch (t1)
645    {
646    case L_STRING :
647        if (!strcmp(lstring_value(n1), lstring_value(n2)))
648            return true_symbol;
649        return NULL;
650    case L_CONS_CELL :
651        while (n1 && n2) // loop through the list and compare each element
652        {
653          if (!lisp_equal(CAR(n1), CAR(n2)))
654            return NULL;
655          n1=CDR(n1);
656          n2=CDR(n2);
657          if (n1 && *((ltype *)n1)!=L_CONS_CELL)
658            return lisp_equal(n1, n2);
659        }
660        if (n1 || n2)
661