Ignore:
Timestamp:
Mar 18, 2008, 9:36:56 PM (14 years ago)
Author:
Sam Hocevar
Message:
  • Get rid of ugly tabs and trailing spaces everywhere.
File:
1 edited

Legend:

Unmodified
Added
Removed
  • abuse/trunk/src/lisp/lisp.cpp

    r123 r124  
    4949int total_user_functions;
    5050
    51 int current_space;  // normally set to TMP_SPACE, unless compiling or other needs 
     51int current_space;  // normally set to TMP_SPACE, unless compiling or other needs
    5252
    5353// when you don't need as much as strcmp, this is faster...
     
    5656  while (*s1)
    5757  {
    58     if (*(s1++)!=*(s2++)) 
     58    if (*(s1++)!=*(s2++))
    5959      return 0;
    6060  }
     
    7575      for (;block && item_type(block)==L_CONS_CELL;block=CDR(block))
    7676      {
    77         void *a=CAR(block);
    78         if (item_type(a)==L_CONS_CELL)
    79           dprintf("[...]");
    80         else lprint(a);
     77    void *a=CAR(block);
     78    if (item_type(a)==L_CONS_CELL)
     79      dprintf("[...]");
     80    else lprint(a);
    8181      }
    8282      if (block)
    8383      {
    8484        dprintf(" . ");
    85         lprint(block);
     85    lprint(block);
    8686      }
    8787      dprintf(")");
     
    9292void where_print(int max_lev=-1)
    9393{
    94   dprintf("Main program\n");   
     94  dprintf("Main program\n");
    9595  if (max_lev==-1) max_lev=l_ptr_stack.son;
    9696  else if (max_lev>=l_ptr_stack.son) max_lev=l_ptr_stack.son-1;
     
    125125    dprintf("%d. Break> ",break_level);
    126126    dgets(st,300);
    127     if (!strcmp(st,"c") || !strcmp(st,"cont") || !strcmp(st,"continue"))   
     127    if (!strcmp(st,"c") || !strcmp(st,"cont") || !strcmp(st,"continue"))
    128128      cont=1;
    129     else if (!strcmp(st,"w") || !strcmp(st,"where"))   
     129    else if (!strcmp(st,"w") || !strcmp(st,"where"))
    130130      where_print();
    131     else if (!strcmp(st,"q") || !strcmp(st,"quit"))   
     131    else if (!strcmp(st,"q") || !strcmp(st,"quit"))
    132132      exit(1);
    133     else if (!strcmp(st,"e") || !strcmp(st,"env") || !strcmp(st,"environment"))   
     133    else if (!strcmp(st,"e") || !strcmp(st,"env") || !strcmp(st,"environment"))
    134134    {
    135135      dprintf("Enviorment : \nnot supported right now\n");
    136136
    137     } else if (!strcmp(st,"h") || !strcmp(st,"help") || !strcmp(st,"?"))   
     137    } else if (!strcmp(st,"h") || !strcmp(st,"help") || !strcmp(st,"?"))
    138138    {
    139139      dprintf("CLIVE Debugger\n");
    140140      dprintf(" w, where : show calling parents\n"
    141               " e, env   : show enviroment\n"
    142               " c, cont  : continue if possible\n"
    143               " q, quit  : quits the program\n"
    144               " h, help  : this\n");
     141          " e, env   : show enviroment\n"
     142          " c, cont  : continue if possible\n"
     143          " q, quit  : quits the program\n"
     144          " h, help  : this\n");
    145145    }
    146146    else
     
    149149      do
    150150      {
    151                                 void *prog=compile(s);
    152                                 p_ref r1(prog);
    153                                 while (*s==' ' || *s=='\t' || *s=='\r' || *s=='\n') s++;
    154                                 lprint(eval(prog));
     151                void *prog=compile(s);
     152                p_ref r1(prog);
     153                while (*s==' ' || *s=='\t' || *s=='\r' || *s=='\n') s++;
     154                lprint(eval(prog));
    155155      } while (*s);
    156156    }
     
    164164{
    165165  if (current_space!=PERM_SPACE && current_space!=GC_SPACE)
    166   { 
     166  {
    167167    lbreak("%s : action requires permanant space\n",why);
    168168    exit(0);
     
    172172void *mark_heap(int heap)
    173173{
    174   return free_space[heap]; 
     174  return free_space[heap];
    175175}
    176176
    177177void restore_heap(void *val, int heap)
    178178{
    179   free_space[heap]=(char *)val; 
     179  free_space[heap]=(char *)val;
    180180}
    181181
    182182void *lmalloc(int size, int which_space)
    183 {     
     183{
    184184  return malloc(size); /* XXX */
    185185
     
    217217  p_ref r1(list);
    218218  void *ret=NULL;
    219   while (list) 
    220   { 
     219  while (list)
     220  {
    221221    ret=eval(CAR(list));
    222222    list=CDR(list);
     
    246246      for (int i=0;i<size;i++,x=CDR(x))
    247247      {
    248         if (!x)
    249         {
    250           lprint(rest);
    251           lbreak("(make-array) incorrect list length\n");
    252           exit(0);
    253         }
    254         data[i]=CAR(x);
     248    if (!x)
     249    {
     250      lprint(rest);
     251      lbreak("(make-array) incorrect list length\n");
     252      exit(0);
     253    }
     254    data[i]=CAR(x);
    255255      }
    256256      if (x) { lprint(rest); lbreak("(make-array) incorrect list length\n"); exit(0); }
     
    270270    }
    271271  }
    272  
     272
    273273  return ((lisp_1d_array *)p);
    274274}
     
    377377  // sys functions should reside in permanant space
    378378  lisp_sys_function *ls=(lisp_sys_function *)lmalloc(sizeof(lisp_sys_function),
    379                                                      current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
     379                             current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
    380380  ls->type=L_SYS_FUNCTION;
    381381  ls->min_args=min_args;
     
    389389  // sys functions should reside in permanant space
    390390  lisp_sys_function *ls=(lisp_sys_function *)lmalloc(sizeof(lisp_sys_function),
    391                                                      current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
     391                             current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
    392392  ls->type=L_C_FUNCTION;
    393393  ls->min_args=min_args;
     
    401401  // sys functions should reside in permanant space
    402402  lisp_sys_function *ls=(lisp_sys_function *)lmalloc(sizeof(lisp_sys_function),
    403                                                      current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
     403                             current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
    404404  ls->type=L_C_BOOL;
    405405  ls->min_args=min_args;
     
    413413  // sys functions should reside in permanant space
    414414  lisp_sys_function *ls=(lisp_sys_function *)lmalloc(sizeof(lisp_sys_function),
    415                                                      current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
     415                             current_space==GC_SPACE ? GC_SPACE : PERM_SPACE);
    416416  ls->type=L_L_FUNCTION;
    417417  ls->min_args=min_args;
     
    431431lisp_symbol *new_lisp_symbol(char *name)
    432432{
    433   lisp_symbol *s=(lisp_symbol *)lmalloc(sizeof(lisp_symbol),current_space); 
     433  lisp_symbol *s=(lisp_symbol *)lmalloc(sizeof(lisp_symbol),current_space);
    434434  s->type=L_SYMBOL;
    435435  s->name=new_lisp_string(name);
     
    482482void *nth(int num, void *list)
    483483{
    484   if (num<0) 
    485   { 
     484  if (num<0)
     485  {
    486486    lbreak("NTH: %d is not a nonnegative fixnum and therefore not a valid index\n",num);
    487487    exit(1);
     
    508508  }
    509509#endif
    510   return ((lisp_pointer *)lpointer)->addr; 
     510  return ((lisp_pointer *)lpointer)->addr;
    511511}
    512512
     
    605605void *lisp_eq(void *n1, void *n2)
    606606{
    607   if (!n1 && !n2) return true_symbol;   
     607  if (!n1 && !n2) return true_symbol;   
    608608  else if ((n1 && !n2) || (n2 && !n1)) return NULL;
    609609  {
     
    650650
    651651  if (!n1 && !n2)           // if both nil, then equal
    652     return true_symbol; 
     652    return true_symbol;   
    653653  else if ((n1 && !n2) || (n2 && !n1))   // one nil, nope
    654654    return NULL;
    655   else 
     655  else
    656656  {
    657657    int t1=item_type(n1),t2=item_type(n2);
    658658    if (t1!=t2) return NULL;
    659     else 
     659    else
    660660    {
    661661      switch (t1)
    662662      {
    663         case L_STRING :
    664         { if (streq(lstring_value(n1),lstring_value(n2))) return true_symbol; else return NULL; }
    665         break;
    666         case L_CONS_CELL :
    667         {
    668           while (n1 && n2) // loop through the list and compare each element
    669           {
    670             if (!lisp_equal(CAR(n1),CAR(n2)))
    671               return NULL;
    672             n1=CDR(n1);
    673             n2=CDR(n2);
    674             if (n1 && *((ltype *)n1)!=L_CONS_CELL)
    675               return lisp_equal(n1,n2);
    676           }
    677           if (n1 || n2) return NULL;   // if one is longer than the other
    678           else return true_symbol;
    679         } break;
    680         default :
     663    case L_STRING :
     664    { if (streq(lstring_value(n1),lstring_value(n2))) return true_symbol; else return NULL; }
     665    break;
     666    case L_CONS_CELL :
     667    {
     668      while (n1 && n2) // loop through the list and compare each element
     669      {
     670        if (!lisp_equal(CAR(n1),CAR(n2)))
     671          return NULL;
     672        n1=CDR(n1);
     673        n2=CDR(n2);
     674        if (n1 && *((ltype *)n1)!=L_CONS_CELL)
     675          return lisp_equal(n1,n2);
     676      }
     677      if (n1 || n2) return NULL;   // if one is longer than the other
     678      else return true_symbol;
     679    } break;
     680    default :
    681681          return lisp_eq(n1,n2);
    682         break;
     682    break;
    683683      }
    684684    }
     
    713713  {
    714714    if (dx>0)
    715     {     
     715    {
    716716      if (dy>0)
    717717      {
    718         if (abs(dx)>abs(dy))
    719         {
    720           int32_t a=dx*29/dy;
    721           if (a>=TBS) return 0;
    722           else return 45-atan_table[a];
    723         }
    724         else
    725         {
    726           int32_t a=dy*29/dx;
    727           if (a>=TBS) return 90;
    728           else return 45+atan_table[a];
    729         }
     718    if (abs(dx)>abs(dy))
     719    {
     720      int32_t a=dx*29/dy;
     721      if (a>=TBS) return 0;
     722      else return 45-atan_table[a];
     723    }
     724    else
     725    {
     726      int32_t a=dy*29/dx;
     727      if (a>=TBS) return 90;
     728      else return 45+atan_table[a];
     729    }
    730730      } else
    731731      {
    732         if (abs(dx)>abs(dy))
    733         {
    734           int32_t a=dx*29/abs(dy);
    735           if (a>=TBS)
    736             return 0;
    737           else
    738             return 315+atan_table[a];
    739         }
    740         else
    741         {
    742           int32_t a=abs(dy)*29/dx;
    743           if (a>=TBS)
    744             return 260;
    745           else
    746             return 315-atan_table[a];
    747         }
    748       } 
     732    if (abs(dx)>abs(dy))
     733    {
     734      int32_t a=dx*29/abs(dy);
     735      if (a>=TBS)
     736        return 0;
     737      else
     738        return 315+atan_table[a];
     739    }
     740    else
     741    {
     742      int32_t a=abs(dy)*29/dx;
     743      if (a>=TBS)
     744        return 260;
     745      else
     746        return 315-atan_table[a];
     747    }
     748      }
    749749    } else
    750750    {
    751751      if (dy>0)
    752752      {
    753         if (abs(dx)>abs(dy))
    754         {
    755           int32_t a=-dx*29/dy;
    756           if (a>=TBS)
    757             return 135+45;
    758           else
    759             return 135+atan_table[a];
    760         }
    761         else
    762         {
    763           int32_t a=dy*29/-dx;
    764           if (a>=TBS)
    765             return 135-45;
    766           else
    767             return 135-atan_table[a];
    768         }
     753    if (abs(dx)>abs(dy))
     754    {
     755      int32_t a=-dx*29/dy;
     756      if (a>=TBS)
     757        return 135+45;
     758      else
     759        return 135+atan_table[a];
     760    }
     761    else
     762    {
     763      int32_t a=dy*29/-dx;
     764      if (a>=TBS)
     765        return 135-45;
     766      else
     767        return 135-atan_table[a];
     768    }
    769769      } else
    770770      {
    771         if (abs(dx)>abs(dy))
    772         {
    773           int32_t a=-dx*29/abs(dy);
    774           if (a>=TBS)
    775             return 225-45;
    776           else return 225-atan_table[a];
    777         }
    778         else
    779         {
    780           int32_t a=abs(dy)*29/abs(dx);
    781           if (a>=TBS)
    782             return 225+45;       
    783           else return 225+atan_table[a];
    784         }
    785       } 
    786     }
    787   } 
     771    if (abs(dx)>abs(dy))
     772    {
     773      int32_t a=-dx*29/abs(dy);
     774      if (a>=TBS)
     775        return 225-45;
     776      else return 225-atan_table[a];
     777    }
     778    else
     779    {
     780      int32_t a=abs(dy)*29/abs(dx);
     781      if (a>=TBS)
     782        return 225+45;   
     783      else return 225+atan_table[a];
     784    }
     785      }
     786    }
     787  }
    788788}
    789789
     
    796796  {
    797797    if (streq( ((char *)((lisp_symbol *)cs->car)->name)+sizeof(lisp_string),name))
    798       return (lisp_symbol *)(cs->car);   
     798      return (lisp_symbol *)(cs->car);
    799799  }
    800800  return NULL;
     
    806806  lisp_symbol *s=find_symbol(name);
    807807  if (s) return s;
    808   else 
     808  else
    809809  {
    810810    int sp=current_space;
     
    847847    int cmp=strcmp(name,((char *)p->name)+sizeof(lisp_string));
    848848    if (cmp==0) return p;
    849     else if (cmp<0) 
    850     { 
     849    else if (cmp<0)
     850    {
    851851      parent=&p->left;
    852852      p=p->left;
    853853    }
    854     else 
     854    else
    855855    {
    856856      parent=&p->right;
     
    902902    {
    903903      if (lisp_eq(CAR(CAR(list)),item))
    904         return lcar(list);          
     904        return lcar(list);   
    905905      list=(cons_cell *)(CDR(list));
    906906    }
     
    919919    lbreak(" is not a sequence\n");
    920920    exit(0);
    921   } 
     921  }
    922922#endif
    923923
     
    926926}
    927927
    928        
     928   
    929929
    930930void *pairlis(void *list1, void *list2, void *list3)
    931 {        
     931{   
    932932  if (item_type(list1)!=(ltype)L_CONS_CELL || item_type(list1)!=item_type(list2))
    933933    return NULL;
    934934
    935   void *ret=NULL; 
     935  void *ret=NULL;
    936936  long l1=list_length(list1),l2=list_length(list2);
    937937  if (l1!=l2)
    938   {        
     938  {    
    939939    lprint(list1);
    940940    lprint(list2);
     
    953953        ((cons_cell *)last)->cdr=cur;
    954954      last=cur;
    955              
    956       cons_cell *cell=new_cons_cell();       
     955   
     956      cons_cell *cell=new_cons_cell();   
    957957      tmp=lcar(list1);
    958958      ((cons_cell *)cell)->car=tmp;
     
    987987    return ((lisp_symbol *)symbol)->value;
    988988#ifdef TYPE_CHECKING
    989   else 
     989  else
    990990  {
    991991    lprint(symbol);
     
    10241024    exit(0);
    10251025  }
    1026   else s->value=new_lisp_object_var(number); 
     1026  else s->value=new_lisp_object_var(number);
    10271027  return NULL;
    10281028}
     
    10881088  while (*st && (*st!='"' || st[1]=='"'))
    10891089  {
    1090     if (*st=='\\' || *st=='"') st++;   
     1090    if (*st=='\\' || *st=='"') st++;
    10911091    st++; x++;
    10921092  }
     
    11051105  {
    11061106    skip_c_comment(s);
    1107     return read_ltoken(s,buffer);   
     1107    return read_ltoken(s,buffer);
    11081108  }
    11091109  else if (*s==0)
     
    11211121  } else if (*s=='#')
    11221122  {
    1123     *(buffer++)=*(s++);     
     1123    *(buffer++)=*(s++);
    11241124    if (*s!='\'')
    1125       *(buffer++)=*(s++);     
     1125      *(buffer++)=*(s++);
    11261126    *buffer=0;
    11271127  } else
    11281128  {
    11291129    while (*s && *s!=')' && *s!='(' && *s!=' ' && *s!='\n' && *s!='\r' && *s!='\t' && *s!=';' && *s!=26)
    1130       *(buffer++)=*(s++);     
     1130      *(buffer++)=*(s++);
    11311131    *buffer=0;
    11321132  }
    1133   return 1;   
     1133  return 1;
    11341134}
    11351135
     
    12031203  else if (n[0]=='(')                     // make a list of everything in ()
    12041204  {
    1205     void *first=NULL,*cur=NULL,*last=NULL;   
     1205    void *first=NULL,*cur=NULL,*last=NULL;
    12061206    p_ref r1(first),r2(cur),r3(last);
    12071207    int done=0;
     
    12111211      if (!read_ltoken(tmp,n))           // check for the end of the list
    12121212        lerror(NULL,"unexpected end of program");
    1213       if (n[0]==')') 
    1214       {
    1215                                 done=1;
    1216                                 read_ltoken(s,n);                // read off the ')'
     1213      if (n[0]==')')
     1214      {
     1215                done=1;
     1216                read_ltoken(s,n);                // read off the ')'
    12171217      }
    12181218      else
    1219       {     
    1220                                 if (n[0]=='.' && !n[1])
    1221                                 {
    1222                                   if (!first)
    1223                                     lerror(s,"token '.' not allowed here\n");        
    1224                                   else
    1225                                   {
    1226                                     void *tmp;
    1227                                     read_ltoken(s,n);              // skip the '.'
    1228                                     tmp=compile(s);
    1229                                     ((cons_cell *)last)->cdr=tmp;          // link the last cdr to
    1230                                     last=NULL;
    1231                                   }
    1232                                 } else if (!last && first)
    1233                                   lerror(s,"illegal end of dotted list\n");
    1234                                 else
    1235                                 {               
    1236                                   void *tmp;
    1237                                   cur=new_cons_cell();
    1238                                   p_ref r1(cur);
    1239                                   if (!first) first=cur;
    1240                                   tmp=compile(s);       
    1241                                   ((cons_cell *)cur)->car=tmp;
    1242                                   if (last)
    1243                                     ((cons_cell *)last)->cdr=cur;
    1244                                   last=cur;
    1245                                 }
    1246       } 
     1219      {
     1220                if (n[0]=='.' && !n[1])
     1221                {
     1222                  if (!first)
     1223                    lerror(s,"token '.' not allowed here\n");   
     1224                  else
     1225                  {
     1226                    void *tmp;
     1227                    read_ltoken(s,n);              // skip the '.'
     1228                    tmp=compile(s);
     1229                    ((cons_cell *)last)->cdr=tmp;          // link the last cdr to
     1230                    last=NULL;
     1231                  }
     1232                } else if (!last && first)
     1233                  lerror(s,"illegal end of dotted list\n");
     1234                else
     1235                {       
     1236                  void *tmp;
     1237                  cur=new_cons_cell();
     1238                  p_ref r1(cur);
     1239                  if (!first) first=cur;
     1240                  tmp=compile(s);   
     1241                  ((cons_cell *)cur)->car=tmp;
     1242                  if (last)
     1243                    ((cons_cell *)last)->cdr=cur;
     1244                  last=cur;
     1245                }
     1246      }
    12471247    } while (!done);
    12481248    ret=comp_optimize(first);
     
    12631263      if (*s=='\\')
    12641264      {
    1265                                 s++;
    1266                                 if (*s=='n') *start='\n';
    1267                                 if (*s=='r') *start='\r';
    1268                                 if (*s=='t') *start='\t';
    1269                                 if (*s=='\\') *start='\\';
     1265                s++;
     1266                if (*s=='n') *start='\n';
     1267                if (*s=='r') *start='\r';
     1268                if (*s=='t') *start='\t';
     1269                if (*s=='\\') *start='\\';
    12701270      } else *start=*s;
    12711271      if (*s=='"') s++;
     
    12811281        ret=new_lisp_character('\n');
    12821282      else if (streq(n,"space"))
    1283         ret=new_lisp_character(' ');       
    1284       else 
    1285         ret=new_lisp_character(n[0]);       
     1283        ret=new_lisp_character(' ');
     1284      else
     1285        ret=new_lisp_character(n[0]);
    12861286    }
    12871287    else if (n[1]==0)                           // short hand for function
     
    13041304  } else {
    13051305    ret = make_find_symbol(n);
    1306   } 
     1306  }
    13071307  return ret;
    13081308}
     
    13131313  if (current_print_file)
    13141314  {
    1315     for (char const *s=st;*s;s++) 
    1316     {
    1317 /*      if (*s=='\\') 
    1318       {
    1319         s++;
    1320         if (*s=='n')
    1321           current_print_file->write_uint8('\n');
    1322         else if (*s=='r')
    1323           current_print_file->write_uint8('\r');
    1324         else if (*s=='t')
    1325           current_print_file->write_uint8('\t');
    1326         else if (*s=='\\')
    1327           current_print_file->write_uint8('\\');
     1315    for (char const *s=st;*s;s++)
     1316    {
     1317/*      if (*s=='\\')
     1318      {
     1319    s++;
     1320    if (*s=='n')
     1321      current_print_file->write_uint8('\n');
     1322    else if (*s=='r')
     1323      current_print_file->write_uint8('\r');
     1324    else if (*s=='t')
     1325      current_print_file->write_uint8('\t');
     1326    else if (*s=='\\')
     1327      current_print_file->write_uint8('\\');
    13281328      }
    13291329      else*/
     
    13431343  {
    13441344    switch ((short)item_type(i))
    1345     {     
     1345    {
    13461346      case L_CONS_CELL :
    13471347      {
    1348                                 cons_cell *cs=(cons_cell *)i;
     1348                cons_cell *cs=(cons_cell *)i;
    13491349        lprint_string("(");
    1350         for (;cs;cs=(cons_cell *)lcdr(cs))     
    1351                                 {
    1352                                   if (item_type(cs)==(ltype)L_CONS_CELL)
    1353                                   {
    1354                                     lprint(cs->car);
    1355                                     if (cs->cdr)
    1356                                       lprint_string(" ");
    1357                                   }
    1358                                   else
    1359                                   {
    1360                                     lprint_string(". ");
    1361                                     lprint(cs);
    1362                                     cs=NULL;
    1363                                   }
    1364                                 }
     1350        for (;cs;cs=(cons_cell *)lcdr(cs))   
     1351                {
     1352                  if (item_type(cs)==(ltype)L_CONS_CELL)
     1353                  {
     1354                        lprint(cs->car);
     1355                    if (cs->cdr)
     1356                      lprint_string(" ");
     1357                  }
     1358                  else
     1359                  {
     1360                    lprint_string(". ");
     1361                    lprint(cs);
     1362                    cs=NULL;
     1363                  }
     1364                }
    13651365        lprint_string(")");
    13661366      }
     
    13681368      case L_NUMBER :
    13691369      {
    1370                                 char num[10];
    1371                                 sprintf(num,"%ld",((lisp_number *)i)->num);
     1370                char num[10];
     1371                sprintf(num,"%ld",((lisp_number *)i)->num);
    13721372        lprint_string(num);
    13731373      }
    13741374      break;
    1375       case L_SYMBOL :       
     1375      case L_SYMBOL :
    13761376        lprint_string((char *)(((lisp_symbol *)i)->name)+sizeof(lisp_string));
    13771377      break;
    13781378      case L_USER_FUNCTION :
    1379       case L_SYS_FUNCTION :     
     1379      case L_SYS_FUNCTION :
    13801380        lprint_string("err... function?");
    13811381      break;
     
    13881388      case L_L_FUNCTION :
    13891389        lprint_string("External lisp function\n");
    1390                         break;
     1390            break;
    13911391      case L_STRING :
    13921392      {
    1393                                 if (current_print_file)
    1394                                         lprint_string(lstring_value(i));
    1395                                 else
    1396                 dprintf("\"%s\"",lstring_value(i));
     1393                if (current_print_file)
     1394                     lprint_string(lstring_value(i));
     1395                else
     1396             dprintf("\"%s\"",lstring_value(i));
    13971397      }
    13981398      break;
     
    14001400      case L_POINTER :
    14011401      {
    1402                                 char ptr[10];
    1403                                 sprintf(ptr,"%p",lpointer_value(i));
    1404                                 lprint_string(ptr);
     1402                char ptr[10];
     1403                    sprintf(ptr,"%p",lpointer_value(i));
     1404                lprint_string(ptr);
    14051405      }
    14061406      break;
    14071407      case L_FIXED_POINT :
    1408       { 
    1409                                 char num[20];
    1410                                 sprintf(num,"%g",(lfixed_point_value(i)>>16)+
    1411                                               ((lfixed_point_value(i)&0xffff))/(double)0x10000);
    1412                                 lprint_string(num);
     1408      {
     1409                char num[20];
     1410                sprintf(num,"%g",(lfixed_point_value(i)>>16)+
     1411                          ((lfixed_point_value(i)&0xffff))/(double)0x10000);
     1412                lprint_string(num);
    14131413      } break;
    14141414      case L_CHARACTER :
    14151415      {
    1416                                 if (current_print_file)
    1417                                 {
    1418                                   uint8_t ch=((lisp_character *)i)->ch;
    1419                                   current_print_file->write(&ch,1);
    1420                                 } else
    1421                                 {
    1422                                   uint16_t ch=((lisp_character *)i)->ch;
    1423                                   dprintf("#\\");
    1424                                   switch (ch)
    1425                                   {
    1426                                     case '\n' :
    1427                                     { dprintf("newline"); break; }
    1428                                     case ' ' :
    1429                                     { dprintf("space"); break; }
    1430                                     default :
    1431                                       dprintf("%c",ch);
    1432                                   }
    1433                                 }       
     1416                if (current_print_file)
     1417                {
     1418                  uint8_t ch=((lisp_character *)i)->ch;
     1419                  current_print_file->write(&ch,1);
     1420                } else
     1421                {
     1422                  uint16_t ch=((lisp_character *)i)->ch;
     1423                  dprintf("#\\");
     1424                  switch (ch)
     1425                  {
     1426                    case '\n' :
     1427                    { dprintf("newline"); break; }
     1428                    case ' ' :
     1429                    { dprintf("space"); break; }
     1430                    default :
     1431                      dprintf("%c",ch);
     1432                  }
     1433                }
    14341434      } break;
    14351435      case L_OBJECT_VAR :
    14361436      {
    1437                                 l_obj_print(((lisp_object_var *)i)->number);
     1437                l_obj_print(((lisp_object_var *)i)->number);
    14381438      } break;
    14391439      case L_1D_ARRAY :
    14401440      {
    1441                                 lisp_1d_array *a=(lisp_1d_array *)i;
    1442                                 void **data=(void **)(a+1);
    1443                                 dprintf("#(");
    1444                                 for (int j=0;j<a->size;j++)
    1445                                 {
    1446                                   lprint(data[j]);
    1447                                   if (j!=a->size-1)
    1448                                     dprintf(" ");
    1449                                 }
    1450                                 dprintf(")");
     1441                lisp_1d_array *a=(lisp_1d_array *)i;
     1442                void **data=(void **)(a+1);
     1443                dprintf("#(");
     1444                for (int j=0;j<a->size;j++)
     1445                {
     1446                  lprint(data[j]);
     1447                  if (j!=a->size-1)
     1448                    dprintf(" ");
     1449                }
     1450                dprintf(")");
    14511451      } break;
    14521452      case L_COLLECTED_OBJECT :
    14531453      {
    1454                                 lprint_string("GC_refrence->");
    1455                                 lprint(((lisp_collected_object *)i)->new_reference);
     1454                lprint_string("GC_refrence->");
     1455                lprint(((lisp_collected_object *)i)->new_reference);
    14561456      } break;
    14571457      default :
     
    14701470
    14711471
    1472 #ifdef TYPE_CHECKING 
     1472#ifdef TYPE_CHECKING
    14731473  int args,req_min,req_max;
    14741474  if (item_type(sym)!=L_SYMBOL)
     
    14771477    lbreak("EVAL : is not a function name (not symbol either)");
    14781478    exit(0);
    1479   } 
     1479  }
    14801480#endif
    14811481
     
    14921492    case L_C_FUNCTION :
    14931493    case L_C_BOOL :
    1494     case L_L_FUNCTION :   
     1494    case L_L_FUNCTION :
    14951495    {
    14961496      req_min=((lisp_sys_function *)fun)->min_args;
     
    15051505      lprint(sym);
    15061506      lbreak(" is not a function name");
    1507       exit(0); 
     1507      exit(0);   
    15081508    } break;
    15091509  }
     
    15321532#ifdef L_PROFILE
    15331533  time_marker start;
    1534 #endif 
     1534#endif
    15351535
    15361536
     
    15411541  {
    15421542    case L_SYS_FUNCTION :
    1543     { ret=eval_sys_function( ((lisp_sys_function *)fun),arg_list); } break;   
     1543    { ret=eval_sys_function( ((lisp_sys_function *)fun),arg_list); } break;
    15441544    case L_L_FUNCTION :
    15451545    { ret=l_caller( ((lisp_sys_function *)fun)->fun_number,arg_list); } break;
     
    15541554      while (arg_list)
    15551555      {
    1556                                 if (first) {
    1557                                   tmp=new_cons_cell();
    1558                                   ((cons_cell *)cur)->cdr=tmp;
    1559                                   cur=tmp;
    1560                                 } else
    1561                                   cur=first=new_cons_cell();
    1562                        
    1563                                 void *val=eval(CAR(arg_list));
    1564                                 ((cons_cell *)cur)->car=val;
    1565                                 arg_list=lcdr(arg_list);
    1566       }       
     1556                if (first) {
     1557                  tmp=new_cons_cell();
     1558                  ((cons_cell *)cur)->cdr=tmp;
     1559                  cur=tmp;
     1560                } else
     1561                  cur=first=new_cons_cell();
     1562           
     1563                void *val=eval(CAR(arg_list));
     1564                ((cons_cell *)cur)->car=val;
     1565                arg_list=lcdr(arg_list);
     1566      }
    15671567      ret=new_lisp_number(c_caller( ((lisp_sys_function *)fun)->fun_number,first));
    15681568    } break;
     
    15731573      while (arg_list)
    15741574      {
    1575                                 if (first) {
    1576                                   tmp=new_cons_cell();
    1577                                   ((cons_cell *)cur)->cdr=tmp;
    1578                                   cur=tmp;
    1579                                 } else
    1580                                   cur=first=new_cons_cell();
    1581                        
    1582                                 void *val=eval(CAR(arg_list));
    1583                                 ((cons_cell *)cur)->car=val;
    1584                                 arg_list=lcdr(arg_list);
    1585       }       
     1575                if (first) {
     1576                  tmp=new_cons_cell();
     1577                  ((cons_cell *)cur)->cdr=tmp;
     1578                  cur=tmp;
     1579                } else
     1580                  cur=first=new_cons_cell();
     1581           
     1582                void *val=eval(CAR(arg_list));
     1583                ((cons_cell *)cur)->car=val;
     1584                arg_list=lcdr(arg_list);
     1585      }
    15861586
    15871587      if (c_caller( ((lisp_sys_function *)fun)->fun_number,first))
     
    15961596  time_marker end;
    15971597  ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
    1598 #endif 
     1598#endif
    15991599
    16001600
    16011601  return ret;
    1602 }        
     1602}   
    16031603
    16041604#ifdef L_PROFILE
     
    16571657    if (!arg_on[i]) stop=1;
    16581658  }
    1659  
     1659
    16601660  if (stop)
    16611661  {
     
    16781678      {
    16791679        na_list->cdr=new_cons_cell();
    1680                                 na_list=(cons_cell *)CDR(na_list);
    1681       }
    1682 
    1683      
     1680                na_list=(cons_cell *)CDR(na_list);
     1681      }
     1682
     1683
    16841684      if (arg_on[i])
    16851685      {
    1686                                 na_list->car=CAR(arg_on[i]);
    1687                                 arg_on[i]=(cons_cell *)CDR(arg_on[i]);
    1688       }
    1689       else stop=1;       
     1686                na_list->car=CAR(arg_on[i]);
     1687                arg_on[i]=(cons_cell *)CDR(arg_on[i]);
     1688      }
     1689      else stop=1;
    16901690    }
    16911691    if (!stop)
     
    17281728      {
    17291729        str_eval[i]=eval(CAR(el_list));
    1730         l_ptr_stack.push(&str_eval[i]);
    1731 
    1732         switch ((short)item_type(str_eval[i]))
    1733         {
    1734           case L_CONS_CELL :
    1735           {
    1736             cons_cell *char_list=(cons_cell *)str_eval[i];
    1737             while (char_list)
    1738             {
    1739               if (item_type(CAR(char_list))==(ltype)L_CHARACTER)
    1740                 len++;
    1741               else
    1742               {
    1743                 lprint(str_eval[i]);
    1744                 lbreak(" is not a character\n");               
    1745                 exit(0);
    1746               }
    1747               char_list=(cons_cell *)CDR(char_list);
    1748             }
    1749           } break;
    1750           case L_STRING : len+=strlen(lstring_value(str_eval[i])); break;
    1751           default :
    1752             lprint(prog_list);
    1753             lbreak("type not supported\n");
    1754             exit(0);
    1755           break;
    1756 
    1757         }
     1730    l_ptr_stack.push(&str_eval[i]);
     1731
     1732    switch ((short)item_type(str_eval[i]))
     1733    {
     1734      case L_CONS_CELL :
     1735      {
     1736        cons_cell *char_list=(cons_cell *)str_eval[i];
     1737        while (char_list)
     1738        {
     1739          if (item_type(CAR(char_list))==(ltype)L_CHARACTER)
     1740            len++;
     1741          else
     1742          {
     1743        lprint(str_eval[i]);
     1744        lbreak(" is not a character\n");       
     1745        exit(0);
     1746          }
     1747          char_list=(cons_cell *)CDR(char_list);
     1748        }
     1749      } break;
     1750      case L_STRING : len+=strlen(lstring_value(str_eval[i])); break;
     1751      default :
     1752        lprint(prog_list);
     1753        lbreak("type not supported\n");
     1754        exit(0);
     1755      break;
     1756
     1757    }
    17581758      }
    17591759      lisp_string *st=new_lisp_string(len+1);
     
    17631763      for (i=0;i<elements;i++)
    17641764      {
    1765         switch ((short)item_type(str_eval[i]))
    1766         {
    1767           case L_CONS_CELL :
    1768           {
    1769             cons_cell *char_list=(cons_cell *)str_eval[i];
    1770             while (char_list)
    1771             {
    1772               if (item_type(CAR(char_list))==L_CHARACTER)
    1773                 *(s++)=((lisp_character *)CAR(char_list))->ch;
    1774               char_list=(cons_cell *)CDR(char_list);
    1775             }
    1776           } break;
    1777           case L_STRING :
    1778           {
    1779             memcpy(s,lstring_value(str_eval[i]),strlen(lstring_value(str_eval[i])));
    1780             s+=strlen(lstring_value(str_eval[i]));
    1781           } break;
    1782           default : ;     // already checked for, but make compiler happy
    1783         }
     1765    switch ((short)item_type(str_eval[i]))
     1766    {
     1767      case L_CONS_CELL :
     1768      {
     1769        cons_cell *char_list=(cons_cell *)str_eval[i];
     1770        while (char_list)
     1771        {
     1772          if (item_type(CAR(char_list))==L_CHARACTER)
     1773            *(s++)=((lisp_character *)CAR(char_list))->ch;
     1774          char_list=(cons_cell *)CDR(char_list);
     1775        }
     1776      } break;
     1777      case L_STRING :
     1778      {
     1779        memcpy(s,lstring_value(str_eval[i]),strlen(lstring_value(str_eval[i])));
     1780        s+=strlen(lstring_value(str_eval[i]));
     1781      } break;
     1782      default : ;     // already checked for, but make compiler happy
     1783    }
    17841784      }
    17851785      jfree(str_eval);
    17861786      l_ptr_stack.son=old_ptr_stack_start;   // restore pointer GC stack
    1787       *s=0;     
     1787      *s=0;
    17881788      ret=st;
    17891789    }
    17901790  }
    1791   else 
     1791  else
    17921792  {
    17931793    lprint(prog_list);
     
    18151815      if (item_type(args)==L_CONS_CELL)
    18161816      {
    1817         if (CAR(args)==comma_symbol)               // dot list with a comma?
    1818         {
    1819           tmp=eval(CAR(CDR(args)));
    1820           ((cons_cell *)last)->cdr=tmp;
    1821           args=NULL;
    1822         }
    1823         else
    1824         {
    1825           cur=new_cons_cell();
    1826           if (first)
    1827             ((cons_cell *)last)->cdr=cur;
    1828           else
     1817    if (CAR(args)==comma_symbol)               // dot list with a comma?
     1818    {
     1819      tmp=eval(CAR(CDR(args)));
     1820      ((cons_cell *)last)->cdr=tmp;
     1821      args=NULL;
     1822    }
     1823    else
     1824    {
     1825      cur=new_cons_cell();
     1826      if (first)
     1827        ((cons_cell *)last)->cdr=cur;
     1828      else
    18291829            first=cur;
    1830           last=cur;
     1830      last=cur;
    18311831          tmp=backquote_eval(CAR(args));
    18321832          ((cons_cell *)cur)->car=tmp;
    1833           args=CDR(args);
    1834         }
     1833       args=CDR(args);
     1834    }
    18351835      } else
    18361836      {
    1837         tmp=backquote_eval(args);
    1838         ((cons_cell *)last)->cdr=tmp;
    1839         args=NULL;
     1837    tmp=backquote_eval(args);
     1838    ((cons_cell *)last)->cdr=tmp;
     1839    args=NULL;
    18401840      }
    18411841
     
    18541854  {
    18551855    case 0 :                                                    // print
    1856     { 
     1856    {
    18571857      ret=NULL;
    18581858      while (arg_list)
    18591859      {
    18601860        ret=eval(CAR(arg_list));  arg_list=CDR(arg_list);
    1861         lprint(ret);
    1862       }
    1863       return ret; 
     1861    lprint(ret);
     1862      }
     1863      return ret;
    18641864    } break;
    18651865    case 1 :                                                    // car
     
    18681868    { ret=lcdr(eval(CAR(arg_list))); } break;
    18691869    case 3 :                                                    // length
    1870     { 
     1870    {
    18711871      void *v=eval(CAR(arg_list));
    18721872      switch (item_type(v))
    1873       { 
    1874         case L_STRING : ret=new_lisp_number(strlen(lstring_value(v))); break;
    1875         case L_CONS_CELL : ret=new_lisp_number(list_length(v)); break;
    1876         default :
    1877         { lprint(v);
    1878           lbreak("length : type not supported\n");
    1879         }
    1880       }
    1881     } break;                                           
     1873      {
     1874    case L_STRING : ret=new_lisp_number(strlen(lstring_value(v))); break;
     1875    case L_CONS_CELL : ret=new_lisp_number(list_length(v)); break;
     1876    default :
     1877    { lprint(v);
     1878      lbreak("length : type not supported\n");
     1879    }
     1880      }
     1881    } break;                       
    18821882    case 4 :                                                    // list
    1883     { 
     1883    {
    18841884      void *cur=NULL,*last=NULL,*first=NULL;
    18851885      p_ref r1(cur),r2(first),r3(last);
    18861886      while (arg_list)
    18871887      {
    1888         cur=new_cons_cell();
    1889         void *val=eval(CAR(arg_list));
    1890         ((cons_cell *) cur)->car=val;
    1891         if (last)
    1892           ((cons_cell *)last)->cdr=cur;
    1893         else first=cur;
    1894         last=cur;
    1895         arg_list=(cons_cell *)CDR(arg_list);
    1896       }  
    1897       ret=first; 
     1888    cur=new_cons_cell();
     1889    void *val=eval(CAR(arg_list));
     1890    ((cons_cell *) cur)->car=val;
     1891    if (last)
     1892      ((cons_cell *)last)->cdr=cur;
     1893    else first=cur;
     1894    last=cur;
     1895    arg_list=(cons_cell *)CDR(arg_list);
     1896      }   
     1897      ret=first;
    18981898    } break;
    18991899    case 5 :                                             // cons
    1900     { void *c=new_cons_cell(); 
     1900    { void *c=new_cons_cell();
    19011901      p_ref r1(c);
    1902       void *val=eval(CAR(arg_list)); 
     1902      void *val=eval(CAR(arg_list));
    19031903      ((cons_cell *)c)->car=val;
    1904       val=eval(CAR(CDR(arg_list))); 
     1904      val=eval(CAR(CDR(arg_list)));
    19051905      ((cons_cell *)c)->cdr=val;
    19061906      ret=c;
     
    19261926      while (arg_list)
    19271927      {
    1928         sum+=lnumber_value(eval(CAR(arg_list)));
    1929         arg_list=CDR(arg_list);
     1928    sum+=lnumber_value(eval(CAR(arg_list)));
     1929    arg_list=CDR(arg_list);
    19301930      }
    19311931      ret=new_lisp_number(sum);
     
    19391939      if (arg_list && item_type(first)==L_FIXED_POINT)
    19401940      {
    1941         sum=1<<16;
    1942         do
    1943         {
    1944           sum=(sum>>8)*(lfixed_point_value(first)>>8);
    1945           arg_list=CDR(arg_list);
    1946           if (arg_list) first=eval(CAR(arg_list));
    1947         } while (arg_list);
    1948 
    1949         ret=new_lisp_fixed_point(sum);
     1941    sum=1<<16;
     1942    do
     1943    {
     1944      sum=(sum>>8)*(lfixed_point_value(first)>>8);
     1945      arg_list=CDR(arg_list);
     1946      if (arg_list) first=eval(CAR(arg_list));
     1947    } while (arg_list);
     1948
     1949    ret=new_lisp_fixed_point(sum);
    19501950      } else
    19511951      { sum=1;
    1952         do
    1953         {
    1954           sum*=lnumber_value(eval(CAR(arg_list)));
    1955           arg_list=CDR(arg_list);
    1956           if (arg_list) first=eval(CAR(arg_list));
    1957         } while (arg_list);
    1958         ret=new_lisp_number(sum);
     1952    do
     1953    {
     1954      sum*=lnumber_value(eval(CAR(arg_list)));
     1955      arg_list=CDR(arg_list);
     1956      if (arg_list) first=eval(CAR(arg_list));
     1957    } while (arg_list);
     1958    ret=new_lisp_number(sum);
    19591959      }
    19601960    }
     
    19651965      while (arg_list)
    19661966      {
    1967         void *i=eval(CAR(arg_list));
    1968         p_ref r1(i);
    1969         if (item_type(i)!=L_NUMBER)
    1970         {
    1971           lprint(i);
    1972           lbreak("/ only defined for numbers, cannot divide ");
    1973           exit(0);
    1974         } else if (first)
    1975         {
    1976           sum=((lisp_number *)i)->num;
    1977           first=0;
    1978         }
    1979         else sum/=((lisp_number *)i)->num;
    1980         arg_list=CDR(arg_list);
     1967    void *i=eval(CAR(arg_list));
     1968    p_ref r1(i);
     1969    if (item_type(i)!=L_NUMBER)
     1970    {
     1971      lprint(i);
     1972      lbreak("/ only defined for numbers, cannot divide ");
     1973      exit(0);
     1974    } else if (first)
     1975    {
     1976      sum=((lisp_number *)i)->num;
     1977      first=0;
     1978    }
     1979    else sum/=((lisp_number *)i)->num;
     1980    arg_list=CDR(arg_list);
    19811981      }
    19821982      ret=new_lisp_number(sum);
     
    19881988      while (arg_list)
    19891989      {
    1990         x-=lnumber_value(eval(CAR(arg_list)));
    1991         arg_list=CDR(arg_list);
     1990    x-=lnumber_value(eval(CAR(arg_list)));
     1991    arg_list=CDR(arg_list);
    19921992      }
    19931993      ret=new_lisp_number(x);
     
    19981998      if (eval(CAR(arg_list)))
    19991999      ret=eval(CAR(CDR(arg_list)));
    2000       else 
     2000      else
    20012001      { arg_list=CDR(CDR(arg_list));                 // check for a else part
    2002         if (arg_list)   
    2003           ret=eval(CAR(arg_list));
    2004         else ret=NULL;
     2002    if (arg_list)   
     2003      ret=eval(CAR(arg_list));
     2004    else ret=NULL;
    20052005      }
    20062006    } break;
    20072007    case 63 :
    20082008    case 11 :                                         // setf
    2009     {     
     2009    {
    20102010      void *set_to=eval(CAR(CDR(arg_list))),*i=NULL;
    20112011      p_ref r1(set_to),r2(i);
     
    20152015      switch (item_type(i))
    20162016      {
    2017         case L_SYMBOL :
    2018         {
    2019           switch (item_type (((lisp_symbol *)i)->value))
    2020           {
    2021             case L_NUMBER :
    2022             {
    2023               if (x==L_NUMBER && ((lisp_symbol *)i)->value!=l_undefined)
    2024               ((lisp_number *)(((lisp_symbol *)i)->value))->num=lnumber_value(set_to);
    2025               else
    2026               ((lisp_symbol *)i)->value=set_to;
    2027             } break;
    2028             case L_OBJECT_VAR :
    2029             {
    2030               l_obj_set(((lisp_object_var *)(((lisp_symbol *)i)->value))->number,set_to); 
    2031             } break;
    2032             default :
    2033             ((lisp_symbol *)i)->value=set_to;
    2034           }
    2035           ret=((lisp_symbol *)i)->value;
    2036         } break;
    2037         case L_CONS_CELL :   // this better be an 'aref'
    2038         {
     2017    case L_SYMBOL :
     2018    {
     2019      switch (item_type (((lisp_symbol *)i)->value))
     2020      {
     2021        case L_NUMBER :
     2022        {
     2023          if (x==L_NUMBER && ((lisp_symbol *)i)->value!=l_undefined)
     2024          ((lisp_number *)(((lisp_symbol *)i)->value))->num=lnumber_value(set_to);
     2025          else
     2026          ((lisp_symbol *)i)->value=set_to;
     2027        } break;
     2028        case L_OBJECT_VAR :
     2029        {
     2030          l_obj_set(((lisp_object_var *)(((lisp_symbol *)i)->value))->number,set_to);
     2031        } break;
     2032        default :
     2033        ((lisp_symbol *)i)->value=set_to;
     2034      }
     2035      ret=((lisp_symbol *)i)->value;
     2036    } break;
     2037    case L_CONS_CELL :   // this better be an 'aref'
     2038    {
    20392039#ifdef TYPE_CHECKING
    2040           void *car=((cons_cell *)i)->car;
    2041           if (car==car_symbol)
    2042           {
    2043             car=eval(CAR(CDR(i)));
    2044             if (!car || item_type(car)!=L_CONS_CELL)
    2045             { lprint(car); lbreak("setq car : evaled object is not a cons cell\n"); exit(0); }
    2046             ((cons_cell *)car)->car=set_to;
    2047           } else if (car==cdr_symbol)
    2048           {
    2049             car=eval(CAR(CDR(i)));
    2050             if (!car || item_type(car)!=L_CONS_CELL)
    2051             { lprint(car); lbreak("setq cdr : evaled object is not a cons cell\n"); exit(0); }
    2052             ((cons_cell *)car)->cdr=set_to;
    2053           } else if (car==aref_symbol)
    2054           {
    2055 #endif
    2056             void *a=(lisp_1d_array *)eval(CAR(CDR(i)));
    2057             p_ref r1(a);
     2040      void *car=((cons_cell *)i)->car;
     2041      if (car==car_symbol)
     2042      {
     2043        car=eval(CAR(CDR(i)));
     2044        if (!car || item_type(car)!=L_CONS_CELL)
     2045        { lprint(car); lbreak("setq car : evaled object is not a cons cell\n"); exit(0); }
     2046        ((cons_cell *)car)->car=set_to;
     2047      } else if (car==cdr_symbol)
     2048      {
     2049        car=eval(CAR(CDR(i)));
     2050        if (!car || item_type(car)!=L_CONS_CELL)
     2051        { lprint(car); lbreak("setq cdr : evaled object is not a cons cell\n"); exit(0); }
     2052        ((cons_cell *)car)->cdr=set_to;
     2053      } else if (car==aref_symbol)
     2054      {
     2055#endif
     2056        void *a=(lisp_1d_array *)eval(CAR(CDR(i)));
     2057        p_ref r1(a);
    20582058#ifdef TYPE_CHECKING
    2059             if (item_type(a)!=L_1D_ARRAY)
    2060             {
    2061               lprint(a);
    2062               lbreak("is not an array (aref)\n");
    2063               exit(0);
    2064             }
    2065 #endif
    2066             long num=lnumber_value(eval(CAR(CDR(CDR(i)))));
     2059        if (item_type(a)!=L_1D_ARRAY)
     2060        {
     2061          lprint(a);
     2062          lbreak("is not an array (aref)\n");
     2063          exit(0);
     2064        }
     2065#endif
     2066        long num=lnumber_value(eval(CAR(CDR(CDR(i)))));
    20672067#ifdef TYPE_CHECKING
    2068             if (num>=((lisp_1d_array *)a)->size || num<0)
    2069             {
    2070               lbreak("aref : value of bounds (%d)\n",num);
    2071               exit(0);
    2072             }
    2073 #endif
    2074             void **data=(void **)(((lisp_1d_array *)a)+1);
    2075             data[num]=set_to;
     2068        if (num>=((lisp_1d_array *)a)->size || num<0)
     2069        {
     2070          lbreak("aref : value of bounds (%d)\n",num);
     2071          exit(0);
     2072        }
     2073#endif
     2074        void **data=(void **)(((lisp_1d_array *)a)+1);
     2075        data[num]=set_to;
    20762076#ifdef TYPE_CHECKING
    2077           } else
    2078           {
    2079             lbreak("expected (aref, car, cdr, or symbol) in setq\n");
    2080             exit(0);
    2081           }
    2082 #endif
    2083           ret=set_to;
    2084         } break;
    2085 
    2086         default :
    2087         {
    2088           lprint(i);
    2089           lbreak("setq/setf only defined for symbols and arrays now..\n");
    2090           exit(0);
    2091         }
     2077      } else
     2078      {
     2079        lbreak("expected (aref, car, cdr, or symbol) in setq\n");
     2080        exit(0);
     2081      }
     2082#endif
     2083      ret=set_to;
     2084    } break;
     2085
     2086    default :
     2087    {
     2088      lprint(i);
     2089      lbreak("setq/setf only defined for symbols and arrays now..\n");
     2090      exit(0);
     2091    }
    20922092      }
    20932093    } break;
     
    21182118
    21192119    case 16 :                                       // pairlis
    2120     {    
     2120    {   
    21212121      l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list);
    21222122      l_user_stack.push(eval(CAR(arg_list))); arg_list=CDR(arg_list);
    21232123      void *n3=eval(CAR(arg_list));
    21242124      void *n2=l_user_stack.pop(1);
    2125       void *n1=l_user_stack.pop(1);     
     2125      void *n1=l_user_stack.pop(1);
    21262126      ret=pairlis(n1,n2,n3);
    21272127    } break;
     
    21362136      while (var_list)
    21372137      {
    2138         void *var_name=CAR(CAR(var_list)),*tmp;
     2138    void *var_name=CAR(CAR(var_list)),*tmp;
    21392139#ifdef TYPE_CHECKING
    2140         if (item_type(var_name)!=L_SYMBOL)
    2141         {
    2142           lprint(var_name);
    2143           lbreak("should be a symbol (let)\n");
    2144           exit(0);
    2145         }
    2146 #endif
    2147 
    2148         l_user_stack.push(((lisp_symbol *)var_name)->value);
    2149         tmp=eval(CAR(CDR(CAR(var_list))));     
    2150         ((lisp_symbol *)var_name)->value=tmp;
    2151         var_list=CDR(var_list);
     2140    if (item_type(var_name)!=L_SYMBOL)
     2141    {
     2142      lprint(var_name);
     2143      lbreak("should be a symbol (let)\n");
     2144      exit(0);
     2145    }
     2146#endif
     2147
     2148    l_user_stack.push(((lisp_symbol *)var_name)->value);
     2149    tmp=eval(CAR(CDR(CAR(var_list))));   
     2150    ((lisp_symbol *)var_name)->value=tmp;
     2151    var_list=CDR(var_list);
    21522152      }
    21532153
     
    21552155      // from the last block
    21562156      while (block_list)
    2157       {    
    2158         ret=eval(CAR(block_list));
    2159         block_list=CDR(block_list);        
     2157      {    
     2158    ret=eval(CAR(block_list));
     2159    block_list=CDR(block_list);   
    21602160      }
    21612161
     
    21642164      while (var_list)
    21652165      {
    2166         void *var_name=CAR(CAR(var_list));
    2167         ((lisp_symbol *)var_name)->value=l_user_stack.sdata[cur_stack++];
    2168         var_list=CDR(var_list);
     2166    void *var_name=CAR(CAR(var_list));
     2167    ((lisp_symbol *)var_name)->value=l_user_stack.sdata[cur_stack++];
     2168    var_list=CDR(var_list);
    21692169      }
    21702170      l_user_stack.son=stack_start;     // restore the stack
    21712171    }
    2172     break;       
     2172    break;
    21732173    case 18 :                                   // defun
    21742174    {
     
    21772177      if (item_type(symbol)!=L_SYMBOL)
    21782178      {
    2179         lprint(symbol);
    2180         lbreak(" is not a symbol! (DEFUN)\n");
    2181         exit(0);
     2179    lprint(symbol);
     2180    lbreak(" is not a symbol! (DEFUN)\n");
     2181    exit(0);
    21822182      }
    21832183
    21842184      if (item_type(arg_list)!=L_CONS_CELL)
    21852185      {
    2186         lprint(arg_list);
    2187         lbreak("is not a lambda list (DEFUN)\n");
    2188         exit(0);
     2186    lprint(arg_list);
     2187    lbreak("is not a lambda list (DEFUN)\n");
     2188    exit(0);
    21892189      }
    21902190#endif
     
    22102210      while (l)
    22112211      {
    2212         if (!eval(CAR(l)))
    2213         {
    2214           ret=NULL;
    2215           l=NULL;             // short-circuit
    2216         } else l=CDR(l);
     2212    if (!eval(CAR(l)))
     2213    {
     2214      ret=NULL;
     2215      l=NULL;             // short-circuit
     2216    } else l=CDR(l);
    22172217      }
    22182218    } break;
     
    22242224      while (l)
    22252225      {
    2226         if (eval(CAR(l)))
    2227         {
    2228           ret=true_symbol;
    2229           l=NULL;            // short circuit
    2230         } else l=CDR(l);
     2226    if (eval(CAR(l)))
     2227    {
     2228      ret=true_symbol;
     2229      l=NULL;            // short circuit
     2230    } else l=CDR(l);
    22312231      }
    22322232    } break;
     
    22382238    case 26 :                                        // char-code
    22392239    {
    2240       void *i=eval(CAR(arg_list));   
     2240      void *i=eval(CAR(arg_list));
    22412241      p_ref r1(i);
    22422242      ret=NULL;
    22432243      switch (item_type(i))
    22442244      {
    2245         case L_CHARACTER :
    2246         { ret=new_lisp_number(((lisp_character *)i)->ch); } break;
    2247         case L_STRING :
    2248         {  ret=new_lisp_number(*lstring_value(i)); } break;
    2249         default :
    2250         {
    2251           lprint(i);
    2252           lbreak(" is not character type\n");
    2253           exit(0);
    2254         }
    2255       }            
     2245    case L_CHARACTER :
     2246    { ret=new_lisp_number(((lisp_character *)i)->ch); } break;
     2247    case L_STRING :
     2248    {  ret=new_lisp_number(*lstring_value(i)); } break;
     2249    default :
     2250    {
     2251      lprint(i);
     2252      lbreak(" is not character type\n");
     2253      exit(0);
     2254    }
     2255      }       
    22562256    } break;
    22572257    case 27 :                                        // code-char
     
    22612261      if (item_type(i)!=L_NUMBER)
    22622262      {
    2263         lprint(i);
    2264         lbreak(" is not number type\n");
    2265         exit(0);
     2263    lprint(i);
     2264    lbreak(" is not number type\n");
     2265    exit(0);
    22662266      }
    22672267      ret=new_lisp_character(((lisp_number *)i)->num);
     
    22742274      else
    22752275      {
    2276         ret=NULL;
     2276    ret=NULL;
    22772277        while (block_list)
    2278         {
    2279           if (eval(lcar(CAR(block_list))))
    2280             ret=eval(CAR(CDR(CAR(block_list))));
    2281           block_list=CDR(block_list);
    2282         }
     2278    {
     2279      if (eval(lcar(CAR(block_list))))
     2280        ret=eval(CAR(CDR(CAR(block_list))));
     2281      block_list=CDR(block_list);
     2282    }
    22832283      }
    22842284    } break;
     
    22902290      while (sel)
    22912291      {
    2292         if (lisp_equal(selector,eval(CAR(CAR(sel)))))
    2293         {
    2294           sel=CDR(CAR(sel));
    2295           while (sel)
    2296           {
    2297             ret=eval(CAR(sel));
    2298             sel=CDR(sel);
    2299           }
    2300           sel=NULL;
    2301         } else sel=CDR(sel);
    2302       }
    2303     } break;
    2304     case 32 :                                      // function   
     2292    if (lisp_equal(selector,eval(CAR(CAR(sel)))))
     2293    {
     2294      sel=CDR(CAR(sel));
     2295      while (sel)
     2296      {
     2297        ret=eval(CAR(sel));
     2298        sel=CDR(sel);
     2299      }
     2300      sel=NULL;
     2301    } else sel=CDR(sel);
     2302      }
     2303    } break;
     2304    case 32 :                                      // function
    23052305      ret=lookup_symbol_function(eval(CAR(arg_list)));
    23062306    break;
    23072307    case 33 :                                      // mapcar
    2308       ret=mapcar(arg_list);   
     2308      ret=mapcar(arg_list);
    23092309    case 34 :                                      // funcall
    23102310    {
    23112311      void *n1=eval(CAR(arg_list));
    2312       ret=eval_function((lisp_symbol *)n1,CDR(arg_list));     
     2312      ret=eval_function((lisp_symbol *)n1,CDR(arg_list));
    23132313    } break;
    23142314    case 35 :                                                   // >
     
    23182318      if (n1>n2) ret=true_symbol; else ret=NULL;
    23192319    }
    2320     break;     
     2320    break;
    23212321    case 36 :                                                   // <
    23222322    {
     
    23242324      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
    23252325      if (n1<n2) ret=true_symbol; else ret=NULL;
    2326     }   
     2326    }
    23272327    break;
    23282328    case 47 :                                                   // >=
     
    23322332      if (n1>=n2) ret=true_symbol; else ret=NULL;
    23332333    }
    2334     break;     
     2334    break;
    23352335    case 48 :                                                   // <=
    23362336    {
     
    23382338      long n2=lnumber_value(eval(CAR(CDR(arg_list))));
    23392339      if (n1<=n2) ret=true_symbol; else ret=NULL;
    2340     }   
     2340    }
    23412341    break;
    23422342
     
    23552355      if (item_type(symb)!=L_SYMBOL)
    23562356      {
    2357         lprint(symb);
    2358         lbreak(" is not a symbol (symbol-name)\n");
    2359         exit(0);
    2360       }
    2361 #endif
    2362       ret=((lisp_symbol *)symb)->name;   
     2357    lprint(symb);
     2358    lbreak(" is not a symbol (symbol-name)\n");
     2359    exit(0);
     2360      }
     2361#endif
     2362      ret=((lisp_symbol *)symb)->name;
    23632363    break;
    23642364    case 40 :                                                  // trace
     
    23712371      if (trace_level>0)
    23722372      {
    2373                                 trace_level--;
    2374                                 ret=true_symbol;
     2373                trace_level--;
     2374                ret=true_symbol;
    23752375      } else ret=NULL;
    23762376    break;
     
    23842384      for (;num;)
    23852385      {
    2386                                 int d;
    2387                                 d=num%10;
    2388                                 *(tp--)=d+'0';
    2389                                 num/=10;
    2390                                 dig--;
     2386                int d;
     2387                d=num%10;
     2388                *(tp--)=d+'0';
     2389                num/=10;
     2390                dig--;
    23912391      }
    23922392      while (dig--)
     
    23982398    case 43:                                     // compile-file
    23992399    {
    2400                         void *fn = eval( CAR( arg_list ) );
    2401                         char *st = lstring_value( fn );
    2402                         p_ref r1( fn );
    2403                         bFILE *fp;
    2404                         if( fun->fun_number == 98 )          // local_load
    2405                         {
    2406                                 // A special test for gamma.lsp
    2407                                 if( strcmp( st, "gamma.lsp" ) == 0 )
    2408                                 {
    2409                                         char *gammapath;
    2410                                         gammapath = (char *)jmalloc( strlen( get_save_filename_prefix() ) + 9 + 1, "gammapath" );
    2411                                         sprintf( gammapath, "%sgamma.lsp", get_save_filename_prefix() );
    2412                                         fp = new jFILE( gammapath, "rb" );
    2413                                         jfree( gammapath );
    2414                                 }
    2415                                 else
    2416                                 {
    2417                                         fp = new jFILE( st, "rb" );
    2418                                 }
    2419                         }
    2420                         else
    2421                         {
    2422                                 fp = open_file(st,"rb");
    2423                         }
    2424 
    2425                         if( fp->open_failure() )
    2426                         {
    2427                                 delete fp;
    2428                                 if( DEFINEDP(symbol_value(load_warning)) && symbol_value(load_warning) )
    2429                                         dprintf("Warning : file %s does not exists\n",st);
    2430                                 ret = NULL;
    2431                         }
    2432                         else
    2433                         {
    2434                                 long l=fp->file_size();
    2435                                 char *s=(char *)jmalloc(l+1,"loaded script");
    2436                                 if (!s)
    2437                                 {
    2438                                   printf("Malloc error in load_script\n");
    2439                                   exit(0);
    2440                                 }
    2441                        
    2442                                 fp->read(s,l);
    2443                                 s[l]=0;
    2444                                 delete fp;
    2445                                 char const *cs=s;
    2446                         #ifndef NO_LIBS
    2447                                 char msg[100];
    2448                                 sprintf(msg,"(load \"%s\")",st);
    2449                                 if (stat_man) stat_man->push(msg,NULL);
    2450                                 crc_manager.get_filenumber(st);               // make sure this file gets crc'ed
    2451                         #endif
    2452                                 void *compiled_form=NULL;
    2453                                 p_ref r11(compiled_form);
    2454                                 while (!end_of_program(cs))  // see if there is anything left to compile and run
    2455                                 {
    2456                         #ifndef NO_LIBS
    2457                                   if (stat_man) stat_man->update((cs-s)*100/l);
    2458                         #endif
    2459                                   void *m=mark_heap(TMP_SPACE);
    2460                                   compiled_form=compile(cs);
    2461                                   eval(compiled_form);
    2462                                   compiled_form=NULL;
    2463                                   restore_heap(m,TMP_SPACE);
    2464                                 }       
    2465                         #ifndef NO_LIBS
     2400            void *fn = eval( CAR( arg_list ) );
     2401            char *st = lstring_value( fn );
     2402            p_ref r1( fn );
     2403            bFILE *fp;
     2404            if( fun->fun_number == 98 )          // local_load
     2405            {
     2406                // A special test for gamma.lsp
     2407                if( strcmp( st, "gamma.lsp" ) == 0 )
     2408                {
     2409                    char *gammapath;
     2410                    gammapath = (char *)jmalloc( strlen( get_save_filename_prefix() ) + 9 + 1, "gammapath" );
     2411                    sprintf( gammapath, "%sgamma.lsp", get_save_filename_prefix() );
     2412                    fp = new jFILE( gammapath, "rb" );
     2413                    jfree( gammapath );
     2414                }
     2415                else
     2416                {
     2417                    fp = new jFILE( st, "rb" );
     2418                }
     2419            }
     2420            else
     2421            {
     2422                fp = open_file(st,"rb");
     2423            }
     2424
     2425            if( fp->open_failure() )
     2426            {
     2427                delete fp;
     2428                if( DEFINEDP(symbol_value(load_warning)) && symbol_value(load_warning) )
     2429                    dprintf("Warning : file %s does not exists\n",st);
     2430                ret = NULL;
     2431            }
     2432            else
     2433            {
     2434                long l=fp->file_size();
     2435                char *s=(char *)jmalloc(l+1,"loaded script");
     2436                if (!s)
     2437                {
     2438                  printf("Malloc error in load_script\n");
     2439                  exit(0);
     2440                }
     2441           
     2442                fp->read(s,l);
     2443                s[l]=0;
     2444                delete fp;
     2445                char const *cs=s;
     2446            #ifndef NO_LIBS
     2447                char msg[100];
     2448                sprintf(msg,"(load \"%s\")",st);
     2449                if (stat_man) stat_man->push(msg,NULL);
     2450                crc_manager.get_filenumber(st);               // make sure this file gets crc'ed
     2451            #endif
     2452                void *compiled_form=NULL;
     2453                p_ref r11(compiled_form);
     2454                while (!end_of_program(cs))  // see if there is anything left to compile and run
     2455                {
     2456            #ifndef NO_LIBS
     2457                  if (stat_man) stat_man->update((cs-s)*100/l);
     2458            #endif
     2459                  void *m=mark_heap(TMP_SPACE);
     2460                  compiled_form=compile(cs);
     2461                  eval(compiled_form);
     2462                  compiled_form=NULL;
     2463                  restore_heap(m,TMP_SPACE);
     2464                }   
     2465            #ifndef NO_LIBS
    24662466                                if (stat_man) stat_man->update(100);
    2467                                 if (stat_man) stat_man->pop();
    2468                         #endif     
    2469                                 jfree(s);
    2470                                 ret=fn;
     2467                if (stat_man) stat_man->pop();
     2468            #endif
     2469                jfree(s);
     2470                ret=fn;
    24712471      }
    24722472    } break;
     
    24872487      ret=backquote_eval(CAR(arg_list));
    24882488    } break;
    2489     case 50 : 
     2489    case 50 :
    24902490    {
    24912491      lprint(arg_list);
     
    24942494      ret=NULL;
    24952495    } break;
    2496     case 51 : 
     2496    case 51 :
    24972497    {
    24982498      long x=lnumber_value(eval(CAR(arg_list)));
    2499       ret=nth(x,eval(CAR(CDR(arg_list)))); 
     2499      ret=nth(x,eval(CAR(CDR(arg_list))));
    25002500    } break;
    25012501    case 52 : resize_tmp(lnumber_value(eval(CAR(arg_list)))); break;
    2502     case 53 : resize_perm(lnumber_value(eval(CAR(arg_list)))); break;   
     2502    case 53 : resize_perm(lnumber_value(eval(CAR(arg_list)))); break;
    25032503    case 54 : ret=new_lisp_fixed_point(lisp_cos(lnumber_value(eval(CAR(arg_list))))); break;
    25042504    case 55 : ret=new_lisp_fixed_point(lisp_sin(lnumber_value(eval(CAR(arg_list))))); break;
     
    25072507      long y=(lnumber_value(eval(CAR(arg_list))));   arg_list=CDR(arg_list);
    25082508      long x=(lnumber_value(eval(CAR(arg_list))));
    2509       ret=new_lisp_number(lisp_atan2(y,x));     
     2509      ret=new_lisp_number(lisp_atan2(y,x));
    25102510    } break;
    25112511    case 57 :
     
    25162516      while (arg_list)
    25172517      {
    2518         void *sym=eval(CAR(arg_list));
    2519         p_ref r1(sym);
    2520         switch (item_type(sym))
    2521         {
    2522           case L_SYMBOL :
    2523           { ((lisp_symbol *)sym)->value=new_lisp_number(x); } break;
    2524           case L_CONS_CELL :
    2525           {
    2526             void *s=eval(CAR(sym));
    2527             p_ref r1(s);
     2518    void *sym=eval(CAR(arg_list));
     2519    p_ref r1(sym);
     2520    switch (item_type(sym))
     2521    {
     2522      case L_SYMBOL :
     2523      { ((lisp_symbol *)sym)->value=new_lisp_number(x); } break;
     2524      case L_CONS_CELL :
     2525      {
     2526        void *s=eval(CAR(sym));
     2527        p_ref r1(s);
    25282528#ifdef TYPE_CHECKING
    2529             if (item_type(s)!=L_SYMBOL)
    2530             { lprint(arg_list);
    2531               lbreak("expecting (sybmol value) for enum\n");
    2532               exit(0);
    2533             }
    2534 #endif
    2535             x=lnumber_value(eval(CAR(CDR(sym))));
    2536             ((lisp_symbol *)sym)->value=new_lisp_number(x);
    2537           } break;
    2538           default :
    2539           {
    2540             lprint(arg_list);
    2541             lbreak("expecting symbol or (symbol value) in enum\n");
    2542             exit(0);
    2543           }
    2544         }
    2545         arg_list=CDR(arg_list);
    2546         x++;
    2547       }     
     2529        if (item_type(s)!=L_SYMBOL)
     2530        { lprint(arg_list);
     2531          lbreak("expecting (sybmol value) for enum\n");
     2532          exit(0);
     2533        }
     2534#endif
     2535        x=lnumber_value(eval(CAR(CDR(sym))));
     2536        ((lisp_symbol *)sym)->value=new_lisp_number(x);
     2537      } break;
     2538      default :
     2539      {
     2540        lprint(arg_list);
     2541        lbreak("expecting symbol or (symbol value) in enum\n");
     2542        exit(0);
     2543      }
     2544    }
     2545    arg_list=CDR(arg_list);
     2546    x++;
     2547      }
    25482548      current_space=sp;
    25492549    } break;
     
    25612561      long x=lnumber_value(eval(CAR(arg_list))); arg_list=CDR(arg_list);
    25622562      long y=lnumber_value(eval(CAR(arg_list)));
    2563       if (y==0) { lbreak("mod : division by zero\n"); y=1; }     
     2563      if (y==0) { lbreak("mod : division by zero\n"); y=1; }
    25642564      ret=new_lisp_number(x%y);
    25652565    } break;
     
    25712571        lbreak("could not open %s for writing",fn);
    25722572      else
    2573       { 
    2574         for (void *s=symbol_list;s;s=CDR(s))             
    2575           fprintf(fp,"%8d  %s\n",((lisp_symbol *)(CAR(s)))->call_counter,
    2576                   lstring_value(((lisp_symbol *)(CAR(s)))->name));
    2577         fclose(fp);
     2573      {   
     2574    for (void *s=symbol_list;s;s=CDR(s))       
     2575      fprintf(fp,"%8d  %s\n",((lisp_symbol *)(CAR(s)))->call_counter,
     2576          lstring_value(((lisp_symbol *)(CAR(s)))->name));
     2577    fclose(fp);
    25782578      }
    25792579    } break;*/
     
    25912591      void *ilist=eval(CAR(arg_list)); arg_list=CDR(arg_list);
    25922592      p_ref r2(ilist);
    2593      
     2593
    25942594      if (CAR(arg_list)!=do_symbol)
    25952595      { lbreak("expecting do after 'for iterator in list'\n"); exit(1); }
     
    26012601      while (ilist)
    26022602      {
    2603                                 set_symbol_value(bind_var,CAR(ilist));
    2604                                 for (block=arg_list;block;block=CDR(block))
    2605                                   ret=eval(CAR(block));
    2606                                 ilist=CDR(ilist);
     2603                set_symbol_value(bind_var,CAR(ilist));
     2604                for (block=arg_list;block;block=CDR(block))
     2605                  ret=eval(CAR(block));
     2606                ilist=CDR(ilist);
    26072607      }
    26082608      set_symbol_value(bind_var,l_user_stack.pop(1));
     
    26152615      p_ref r1(str1);
    26162616      void *str2=eval(CAR(CDR(arg_list)));
    2617      
    2618      
     2617
     2618
    26192619      current_print_file=open_file(lstring_value(str1),
    2620                                    lstring_value(str2));
     2620                   lstring_value(str2));
    26212621
    26222622      if (!current_print_file->open_failure())
    26232623      {
    2624                                 while (arg_list)
    2625                                 {
    2626                                   ret=eval(CAR(arg_list));       
    2627                                   arg_list=CDR(arg_list);
    2628                                 }
    2629       }     
     2624                while (arg_list)
     2625                {
     2626                  ret=eval(CAR(arg_list));   
     2627                  arg_list=CDR(arg_list);
     2628                }
     2629      }
    26302630      delete current_print_file;
    2631       current_print_file=old_file;     
     2631      current_print_file=old_file;
    26322632
    26332633    } break;
     
    26382638      {
    26392639        first&=lnumber_value(eval(CAR(arg_list)));
    2640                                 arg_list=CDR(arg_list);
    2641       } 
     2640                arg_list=CDR(arg_list);
     2641      }
    26422642      ret=new_lisp_number(first);
    26432643    } break;
     
    26482648      {
    26492649        first|=lnumber_value(eval(CAR(arg_list)));
    2650                                 arg_list=CDR(arg_list);
    2651       } 
     2650                arg_list=CDR(arg_list);
     2651      }
    26522652      ret=new_lisp_number(first);
    26532653    } break;
     
    26582658      {
    26592659        first^=lnumber_value(eval(CAR(arg_list)));
    2660                                 arg_list=CDR(arg_list);
    2661       } 
     2660                arg_list=CDR(arg_list);
     2661      }
    26622662      ret=new_lisp_number(first);
    26632663    } break;
     
    26672667      if (l>=2<<16 || l<=0)
    26682668      {
    2669                                 lbreak("bad array size %d\n",l);
    2670                                 exit(0);
     2669                lbreak("bad array size %d\n",l);
     2670                exit(0);
    26712671      }
    26722672      ret=new_lisp_1d_array(l,CDR(arg_list));
     
    27082708    {
    27092709#ifdef L_PROFILE
    2710       char *s=lstring_value(eval(CAR(arg_list)));     
     2710      char *s=lstring_value(eval(CAR(arg_list)));
    27112711      preport(s);
    27122712#endif
     
    27162716      void *arg1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
    27172717      p_ref r1(arg1);       // protect this refrence
    2718       char *haystack=lstring_value(eval(CAR(arg_list)));     
     2718      char *haystack=lstring_value(eval(CAR(arg_list)));
    27192719      char *needle=lstring_value(arg1);
    27202720
     
    27552755      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
    27562756      {
    2757                                 sym=CAR(CAR(init_var));
    2758                                 if (item_type(sym)!=L_SYMBOL)
    2759                                 { lbreak("expecting symbol name for iteration var\n"); exit(0); }
    2760                                 l_user_stack.push(symbol_value(sym));
    2761       }
    2762      
     2757                sym=CAR(CAR(init_var));
     2758                if (item_type(sym)!=L_SYMBOL)
     2759                { lbreak("expecting symbol name for iteration var\n"); exit(0); }
     2760                l_user_stack.push(symbol_value(sym));
     2761      }
     2762
    27632763      void **do_evaled=l_user_stack.sdata+l_user_stack.son;
    27642764      // push all of the init forms, so we can set the symbol
    2765       for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))   
    2766                                 l_user_stack.push(eval(CAR(CDR(CAR((init_var))))));
     2765      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
     2766                l_user_stack.push(eval(CAR(CDR(CAR((init_var))))));
    27672767
    27682768      // now set all the symbols
    27692769      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)
    27702770      {
    2771                                 sym=CAR(CAR(init_var));
    2772                                 set_symbol_value(sym,*do_evaled);
     2771                sym=CAR(CAR(init_var));
     2772                set_symbol_value(sym,*do_evaled);
    27732773      }
    27742774
     
    27762776      do
    27772777      {
    2778                                 i=(eval(CAR(CAR(CDR(arg_list))))!=NULL);
    2779                                 if (!i)
    2780                                 {
    2781                                   eval_block(CDR(CDR(arg_list)));
    2782                                   for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
    2783                                     eval(CAR(CDR(CDR(CAR(init_var)))));
    2784                                 }
     2778                i=(eval(CAR(CAR(CDR(arg_list))))!=NULL);
     2779                if (!i)
     2780                {
     2781                  eval_block(CDR(CDR(arg_list)));
     2782                  for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var))
     2783                    eval(CAR(CDR(CDR(CAR(init_var)))));
     2784                }
    27852785      } while (!i);
    2786      
     2786
    27872787      ret=eval(CAR(CDR(CAR(CDR(arg_list)))));
    27882788
    27892789      // restore old values for symbols
    27902790      do_evaled=l_user_stack.sdata+ustack_start;
    2791       for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)     
    2792       {
    2793                                 sym=CAR(CAR(init_var));
    2794                                 set_symbol_value(sym,*do_evaled);
     2791      for (init_var=CAR(arg_list);init_var;init_var=CDR(init_var),do_evaled++)
     2792      {
     2793                sym=CAR(CAR(init_var));
     2794                set_symbol_value(sym,*do_evaled);
    27952795      }
    27962796
    27972797      l_user_stack.son=ustack_start;
    2798      
     2798
    27992799    } break;
    28002800    case 82 : // gc
    2801     { 
     2801    {
    28022802      collect_space(current_space);
    28032803    } break;
     
    28242824    case 86 : // nconc
    28252825    {
    2826       void *l1=eval(CAR(arg_list)); arg_list=CDR(arg_list);           
    2827       p_ref r1(l1);     
     2826      void *l1=eval(CAR(arg_list)); arg_list=CDR(arg_list);
     2827      p_ref r1(l1);
    28282828      void *first=l1,*next;
    28292829      p_ref r2(first);
     
    28312831      if (!l1)
    28322832      {
    2833                                 l1=first=eval(CAR(arg_list));
    2834                                 arg_list=CDR(arg_list);
    2835       }
    2836      
     2833                l1=first=eval(CAR(arg_list));
     2834                arg_list=CDR(arg_list);
     2835      }
     2836
    28372837      if (item_type(l1)!=L_CONS_CELL)
    28382838      { lprint(l1); lbreak("first arg should be a list\n"); }
    28392839      do
    28402840      {
    2841                                 next=l1;
    2842                                 while (next) { l1=next; next=lcdr(next); }
    2843                                 ((cons_cell *)l1)->cdr=eval(CAR(arg_list));     
    2844                                 arg_list=CDR(arg_list);
    2845       } while (arg_list);     
     2841                next=l1;
     2842                while (next) { l1=next; next=lcdr(next); }
     2843                ((cons_cell *)l1)->cdr=eval(CAR(arg_list));   
     2844                arg_list=CDR(arg_list);
     2845      } while (arg_list);
    28462846      ret=first;
    28472847    } break;
     
    28892889      while (arg_list)
    28902890      {
    2891                                 void *q=eval(CAR(arg_list));
    2892                                 if (!rstart) rstart=q;
    2893                                 while (r && CDR(r)) r=CDR(r);
    2894                                 CDR(r)=q;        
    2895                                 arg_list=CDR(arg_list);
     2891                void *q=eval(CAR(arg_list));
     2892                if (!rstart) rstart=q;
     2893                while (r && CDR(r)) r=CDR(r);
     2894                CDR(r)=q;   
     2895                arg_list=CDR(arg_list);
    28962896      }
    28972897      return rstart;
    28982898    } break;
    28992899
    2900     default : 
     2900    default :
    29012901    { dprintf("Undefined system function number %d\n",((lisp_sys_function *)fun)->fun_number); }
    29022902  }
     
    29332933    lbreak("EVAL : is not a function name (not symbol either)");
    29342934    exit(0);
    2935   } 
     2935  }
    29362936#endif
    29372937#ifdef L_PROFILE
    29382938  time_marker start;
    2939 #endif 
     2939#endif
    29402940
    29412941
     
    29522952#ifndef NO_LIBS
    29532953  void *fun_arg_list=cache.lblock(fun->alist);
    2954   void *block_list=cache.lblock(fun->blist); 
     2954  void *block_list=cache.lblock(fun->blist);
    29552955  p_ref r9(block_list),r10(fun_arg_list);
    29562956#else
     
    29632963
    29642964  // mark the start start, so we can restore when done
    2965   long stack_start=l_user_stack.son; 
     2965  long stack_start=l_user_stack.son;
    29662966
    29672967  // first push all of the old symbol values
     
    30073007  {
    30083008    ret=eval(CAR(block_list));
    3009     block_list=CDR(block_list);   
     3009    block_list=CDR(block_list);
    30103010  }
    30113011
     
    30193019  time_marker end;
    30203020  ((lisp_symbol *)sym)->time_taken+=end.diff_time(&start);
    3021 #endif 
     3021#endif
    30223022
    30233023
    30243024  return ret;
    3025 } 
     3025}
    30263026
    30273027
     
    30313031void *eval(void *prog)
    30323032{
    3033  
    3034 
    3035   void *ret=NULL; 
     3033
     3034
     3035  void *ret=NULL;
    30363036  p_ref ref1(prog);
    30373037
    30383038
    30393039  int tstart=trace_level;
    3040  
     3040
    30413041  if (trace_level)
    30423042  {
    30433043    if (trace_level<=trace_print_level)
    30443044    {
    3045       dprintf("%d (%d,%d,%d) TRACE : ",trace_level, 
    3046               space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
    3047               space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
    3048               l_ptr_stack.son);
     3045      dprintf("%d (%d,%d,%d) TRACE : ",trace_level,
     3046          space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
     3047          space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
     3048          l_ptr_stack.son);
    30493049      lprint(prog);
    30503050
     
    30563056  {
    30573057    switch (item_type(prog))
    3058     {   
     3058    {
    30593059      case L_BAD_CELL :
    30603060      { lbreak("error : eval on a bad cell\n"); exit(0); } break;
    30613061      case L_CHARACTER :
    30623062      case L_STRING :
    3063       case L_NUMBER : 
     3063      case L_NUMBER :
    30643064      case L_POINTER :
    30653065      case L_FIXED_POINT :
    30663066      { ret=prog; } break;
    3067       case L_SYMBOL : 
     3067      case L_SYMBOL :
    30683068      { if (prog==true_symbol)
    3069                                 ret=prog;
     3069                  ret=prog;
    30703070        else
    3071                                 {
    3072                                   ret=lookup_symbol_value(prog);
    3073                                   if (item_type(ret)==L_OBJECT_VAR)
    3074                                     ret=l_obj_get(((lisp_object_var *)ret)->number);
    3075                                 }
     3071                {
     3072                  ret=lookup_symbol_value(prog);
     3073                  if (item_type(ret)==L_OBJECT_VAR)
     3074                    ret=l_obj_get(((lisp_object_var *)ret)->number);
     3075                }
    30763076      } break;
    30773077      case L_CONS_CELL :
     
    30883088    trace_level--;
    30893089    if (trace_level<=trace_print_level)
    3090       dprintf("%d (%d,%d,%d) TRACE ==> ",trace_level, 
    3091               space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
    3092               space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
    3093               l_ptr_stack.son);
     3090      dprintf("%d (%d,%d,%d) TRACE ==> ",trace_level,
     3091          space_size[PERM_SPACE]-((char *)free_space[PERM_SPACE]-(char *)space[PERM_SPACE]),
     3092          space_size[TMP_SPACE]-((char *)free_space[TMP_SPACE]-(char *)space[TMP_SPACE]),
     3093          l_ptr_stack.son);
    30943094    lprint(ret);
    30953095    dprintf("\n");
    30963096  }
    3097  
     3097
    30983098/*  l_user_stack.push(ret);
    30993099  collect_space(PERM_SPACE);
     
    31153115    // 25               26          27       28  29   30     31
    31163116    "concatenate","char-code","code-char","*","/","cond","select",
    3117     // 32            33         34     35    36    37       
     3117    // 32            33         34     35    36    37
    31183118    "function", "mapcar", "funcall", ">", "<", "tmp-space",
    31193119    //   38              39        40       41         42
     
    31443144
    31453145// 0      1       2        3       4         5       6      7        8
    3146  1, -1,   1, 1,   1, 1,   0, -1,   0, -1,   2, 2,   1, 1,   2, 2,  0, -1, 
     3146 1, -1,   1, 1,   1, 1,   0, -1,   0, -1,   2, 2,   1, 1,   2, 2,  0, -1,
    31473147// 9      10      11      12       13       14      15      16      17
    3148  1, -1,   2, 3,   2, 2,   0, 0,    2, 2,    1, 1,   2, 2,   2, 2,   1, -1, 
     3148 1, -1,   2, 3,   2, 2,   0, 0,    2, 2,    1, 1,   2, 2,   2, 2,   1, -1,
    31493149// 18     19      20      21       22       23      24      25      26
    31503150 2, -1,  1, 1,   1, 1,  -1, -1,  -1, -1,  -1, -1,  2, 2,   1,-1,   1, 1,
     
    31653165// 90      91    92      93        94       95      96       97     98
    31663166 1,1,     1,1,   1,1,    1,1,     1,1,      1,1,     1,1,   3,3,    1,1
    3167  
    3168 }; 
     3167
     3168};
    31693169
    31703170int total_symbols()
     
    31833183    lbreak("Only smaller resizes allowed for now.\n");
    31843184    exit(0);
    3185   } else 
     3185  } else
    31863186    dprintf("doesn't work yet!\n");
    31873187}
     
    32113211  lsym_root=NULL;
    32123212  total_user_functions=0;
    3213   free_space[0]=space[0]=(char *)jmalloc(perm_size,"lisp perm space"); 
     3213  free_space[0]=space[0]=(char *)jmalloc(perm_size,"lisp perm space");
    32143214  space_size[0]=perm_size;
    3215  
     3215
    32163216
    32173217  free_space[1]=space[1]=(char *)jmalloc(tmp_size,"lisp tmp space");
     
    32193219
    32203220
    3221   current_space=PERM_SPACE; 
    3222  
    3223  
     3221  current_space=PERM_SPACE;
     3222
     3223
    32243224  l_comp_init();
    32253225  for (i=0;i<TOTAL_SYS_FUNCS;i++)
     
    32283228  current_space=TMP_SPACE;
    32293229  dprintf("Lisp : %d symbols defined, %d system functions, %d pre-compiled functions\n",
    3230           total_symbols(),TOTAL_SYS_FUNCS,total_user_functions);
     3230      total_symbols(),TOTAL_SYS_FUNCS,total_user_functions);
    32313231}
    32323232
     
    32643264      item_type(((lisp_symbol *)symbol)->value)==L_NUMBER)
    32653265    ((lisp_number *)((lisp_symbol *)symbol)->value)->num=num;
    3266   else 
     3266  else
    32673267    ((lisp_symbol *)(symbol))->value=new_lisp_number(num);
    32683268
Note: See TracChangeset for help on using the changeset viewer.