Changeset 498


Ignore:
Timestamp:
Apr 17, 2011, 11:57:03 PM (6 years ago)
Author:
sam
Message:

lisp: implement LSysFunction::EvalFunction? and ensure all local pointers
are protected against collection.

Location:
abuse/trunk/src/lisp
Files:
2 edited

Legend:

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

    r497 r498  
    130130      dprintf("CLIVE Debugger\n");
    131131      dprintf(" w, where : show calling parents\n"
    132           " e, env   : show enviroment\n"
     132          " e, env   : show environment\n"
    133133          " c, cont  : continue if possible\n"
    134134          " q, quit  : quits the program\n"
     
    14171417        break;
    14181418    case L_COLLECTED_OBJECT:
    1419         lprint_string("GC_refrence->");
     1419        lprint_string("GC_reference->");
    14201420        ((LRedirect *)this)->ref->Print();
    14211421        break;
     
    14291429}
    14301430
    1431 void *eval_sys_function(LSysFunction *fun, void *arg_list);
    1432 
     1431/* PtrRef check: OK */
    14331432LObject *LSymbol::EvalFunction(void *arg_list)
    14341433{
     
    15011500    {
    15021501    case L_SYS_FUNCTION:
    1503         ret = (LObject *)eval_sys_function(((LSysFunction *)fun), arg_list);
     1502        ret = ((LSysFunction *)fun)->EvalFunction((LList *)arg_list);
    15041503        break;
    15051504    case L_L_FUNCTION:
     
    17901789}
    17911790
    1792 
    1793 void *eval_sys_function(LSysFunction *fun, void *arg_list)
    1794 {
    1795   PtrRef ref1(arg_list);
    1796   void *ret=NULL;
    1797   switch (fun->fun_number)
    1798   {
     1791/* PtrRef check: OK */
     1792LObject *LSysFunction::EvalFunction(LList *arg_list)
     1793{
     1794    LObject *ret = NULL;
     1795
     1796    PtrRef ref1(arg_list);
     1797
     1798    switch (fun_number)
     1799    {
    17991800    case SYS_FUNC_PRINT:
    1800     {
    1801       ret=NULL;
    1802       while (arg_list)
    1803       {
    1804         ret = CAR(arg_list)->Eval();
    1805         arg_list=CDR(arg_list);
    1806         ((LObject *)ret)->Print();
    1807       }
    1808       return ret;
    1809     } break;
     1801        while (arg_list)
     1802        {
     1803            ret = CAR(arg_list)->Eval();
     1804            arg_list = (LList *)CDR(arg_list);
     1805            ret->Print();
     1806        }
     1807        break;
    18101808    case SYS_FUNC_CAR:
    1811     { ret=lcar(CAR(arg_list)->Eval()); } break;
     1809        ret = lcar(CAR(arg_list)->Eval());
     1810        break;
    18121811    case SYS_FUNC_CDR:
    1813     { ret=lcdr(CAR(arg_list)->Eval()); } break;
     1812        ret = lcdr(CAR(arg_list)->Eval());
     1813        break;
    18141814    case SYS_FUNC_LENGTH:
    18151815    {
    1816       void *v = CAR(arg_list)->Eval();
    1817       switch (item_type(v))
    1818       {
    1819         case L_STRING : ret = LNumber::Create(strlen(lstring_value(v))); break;
    1820         case L_CONS_CELL : ret = LNumber::Create(((LList *)v)->GetLength()); break;
    1821         default :
    1822         {
    1823           ((LObject *)v)->Print();
    1824           lbreak("length : type not supported\n");
    1825         }
    1826       }
    1827     } break;
     1816        LObject *v = CAR(arg_list)->Eval();
     1817        switch (item_type(v))
     1818        {
     1819        case L_STRING:
     1820            ret = LNumber::Create(strlen(lstring_value(v)));
     1821            break;
     1822        case L_CONS_CELL:
     1823            ret = LNumber::Create(((LList *)v)->GetLength());
     1824            break;
     1825        default:
     1826            v->Print();
     1827            lbreak("length : type not supported\n");
     1828            break;
     1829        }
     1830        break;
     1831    }
    18281832    case SYS_FUNC_LIST:
    18291833    {
    1830       void *cur=NULL, *last=NULL, *first=NULL;
    1831       PtrRef r1(cur), r2(first), r3(last);
    1832       while (arg_list)
    1833       {
    1834     cur = LList::Create();
    1835     void *val = CAR(arg_list)->Eval();
    1836     ((LList *) cur)->car = (LObject *)val;
    1837     if (last)
    1838       ((LList *)last)->cdr = (LObject *)cur;
    1839     else first=cur;
    1840     last=cur;
    1841     arg_list=(LList *)CDR(arg_list);
    1842       }
    1843       ret=first;
    1844     } break;
     1834        LList *cur = NULL, *last = NULL, *first = NULL;
     1835        PtrRef r1(cur), r2(first), r3(last);
     1836        while (arg_list)
     1837        {
     1838            cur = LList::Create();
     1839            LObject *val = CAR(arg_list)->Eval();
     1840            cur->car = val;
     1841            if (last)
     1842                last->cdr = cur;
     1843            else
     1844                first = cur;
     1845            last = cur;
     1846            arg_list = (LList *)CDR(arg_list);
     1847        }
     1848        ret = first;
     1849        break;
     1850    }
    18451851    case SYS_FUNC_CONS:
    1846     { void *c = LList::Create();
    1847       PtrRef r1(c);
    1848       void *val = CAR(arg_list)->Eval();
    1849       ((LList *)c)->car = (LObject *)val;
    1850       val = CAR(CDR(arg_list))->Eval();
    1851       ((LList *)c)->cdr = (LObject *)val;
    1852       ret=c;
    1853     } break;
     1852    {
     1853        LList *c = LList::Create();
     1854        PtrRef r1(c);
     1855        LObject *val = CAR(arg_list)->Eval();
     1856        c->car = val;
     1857        val = CAR(CDR(arg_list))->Eval();
     1858        c->cdr = val;
     1859        ret = c;
     1860        break;
     1861    }
    18541862    case SYS_FUNC_QUOTE:
    1855     ret=CAR(arg_list);
    1856     break;
     1863        ret = CAR(arg_list);
     1864        break;
    18571865    case SYS_FUNC_EQ:
    1858     {
    1859       l_user_stack.push(CAR(arg_list)->Eval());
    1860       l_user_stack.push(CAR(CDR(arg_list))->Eval());
    1861       ret=lisp_eq(l_user_stack.pop(1), l_user_stack.pop(1));
    1862     } break;
     1866        l_user_stack.push(CAR(arg_list)->Eval());
     1867        l_user_stack.push(CAR(CDR(arg_list))->Eval());
     1868        ret = (LObject *)lisp_eq(l_user_stack.pop(1), l_user_stack.pop(1));
     1869        break;
    18631870    case SYS_FUNC_EQUAL:
    1864     {
    1865       l_user_stack.push(CAR(arg_list)->Eval());
    1866       l_user_stack.push(CAR(CDR(arg_list))->Eval());
    1867       ret=lisp_equal(l_user_stack.pop(1), l_user_stack.pop(1));
    1868     } break;
     1871        l_user_stack.push(CAR(arg_list)->Eval());
     1872        l_user_stack.push(CAR(CDR(arg_list))->Eval());
     1873        ret = (LObject *)lisp_equal(l_user_stack.pop(1), l_user_stack.pop(1));
     1874        break;
    18691875    case SYS_FUNC_PLUS:
    18701876    {
    1871       long sum=0;
    1872       while (arg_list)
    1873       {
    1874     sum+=lnumber_value(CAR(arg_list)->Eval());
    1875     arg_list=CDR(arg_list);
    1876       }
    1877       ret = LNumber::Create(sum);
    1878     }
    1879     break;
     1877        int32_t sum = 0;
     1878        while (arg_list)
     1879        {
     1880            sum += lnumber_value(CAR(arg_list)->Eval());
     1881            arg_list = (LList *)CDR(arg_list);
     1882        }
     1883        ret = LNumber::Create(sum);
     1884        break;
     1885    }
    18801886    case SYS_FUNC_TIMES:
    18811887    {
    1882       long sum;
    1883       void *first = CAR(arg_list)->Eval();
    1884       PtrRef r1(first);
    1885       if (arg_list && item_type(first)==L_FIXED_POINT)
    1886       {
    1887     sum=1<<16;
    1888     do
    1889     {
    1890       sum=(sum>>8)*(lfixed_point_value(first)>>8);
    1891       arg_list=CDR(arg_list);
    1892       if (arg_list) first = CAR(arg_list)->Eval();
    1893     } while (arg_list);
    1894 
    1895     ret = LFixedPoint::Create(sum);
    1896       } else
    1897       { sum=1;
    1898     do
    1899     {
    1900       sum*=lnumber_value(CAR(arg_list)->Eval());
    1901       arg_list=CDR(arg_list);
    1902       if (arg_list) first =CAR(arg_list)->Eval();
    1903     } while (arg_list);
    1904     ret = LNumber::Create(sum);
    1905       }
    1906     }
    1907     break;
     1888        int32_t prod;
     1889        LObject *first = CAR(arg_list)->Eval();
     1890        PtrRef r1(first);
     1891        if (arg_list && item_type(first) == L_FIXED_POINT)
     1892        {
     1893            prod = 1 << 16;
     1894            do
     1895            {
     1896                prod = (prod >> 8) * (lfixed_point_value(first) >> 8);
     1897                arg_list = (LList *)CDR(arg_list);
     1898                if (arg_list)
     1899                    first = CAR(arg_list)->Eval();
     1900            } while (arg_list);
     1901            ret = LFixedPoint::Create(prod);
     1902        }
     1903        else
     1904        {
     1905            prod = 1;
     1906            do
     1907            {
     1908                prod *= lnumber_value(CAR(arg_list)->Eval());
     1909                arg_list = (LList *)CDR(arg_list);
     1910                if (arg_list)
     1911                    first = CAR(arg_list)->Eval();
     1912            } while (arg_list);
     1913            ret = LNumber::Create(prod);
     1914        }
     1915        break;
     1916    }
    19081917    case SYS_FUNC_SLASH:
    19091918    {
    1910       long sum=0, first=1;
    1911       while (arg_list)
    1912       {
    1913     void *i = CAR(arg_list)->Eval();
    1914     PtrRef r1(i);
    1915     if (item_type(i)!=L_NUMBER)
    1916     {
    1917       ((LObject *)i)->Print();
    1918       lbreak("/ only defined for numbers, cannot divide ");
    1919       exit(0);
    1920     } else if (first)
    1921     {
    1922       sum=((LNumber *)i)->num;
    1923       first=0;
    1924     }
    1925     else sum/=((LNumber *)i)->num;
    1926     arg_list=CDR(arg_list);
    1927       }
    1928       ret = LNumber::Create(sum);
    1929     }
    1930     break;
     1919        int32_t quot = 0, first = 1;
     1920        while (arg_list)
     1921        {
     1922            LObject *i = CAR(arg_list)->Eval();
     1923            if (item_type(i) != L_NUMBER)
     1924            {
     1925                i->Print();
     1926                lbreak("/ only defined for numbers, cannot divide ");
     1927                exit(0);
     1928            }
     1929            else if (first)
     1930            {
     1931                quot = ((LNumber *)i)->num;
     1932                first = 0;
     1933            }
     1934            else
     1935                quot /= ((LNumber *)i)->num;
     1936            arg_list = (LList *)CDR(arg_list);
     1937        }
     1938        ret = LNumber::Create(quot);
     1939        break;
     1940    }
    19311941    case SYS_FUNC_MINUS:
    19321942    {
    1933       long x=lnumber_value(CAR(arg_list)->Eval());
    1934       arg_list=CDR(arg_list);
    1935       while (arg_list)
    1936       {
    1937     x-=lnumber_value(CAR(arg_list)->Eval());
    1938     arg_list=CDR(arg_list);
    1939       }
    1940       ret = LNumber::Create(x);
    1941     }
    1942     break;
     1943        int32_t sub = lnumber_value(CAR(arg_list)->Eval());
     1944        arg_list = (LList *)CDR(arg_list);
     1945        while (arg_list)
     1946        {
     1947            sub -= lnumber_value(CAR(arg_list)->Eval());
     1948            arg_list = (LList *)CDR(arg_list);
     1949        }
     1950        ret = LNumber::Create(sub);
     1951        break;
     1952    }
    19431953    case SYS_FUNC_IF:
    1944     {
    1945       if (CAR(arg_list)->Eval())
    1946       ret=CAR(CDR(arg_list))->Eval();
    1947       else
    1948       { arg_list=CDR(CDR(arg_list));                 // check for a else part
    1949     if (arg_list)
    1950       ret = CAR(arg_list)->Eval();
    1951     else ret=NULL;
    1952       }
    1953     } break;
     1954        if (CAR(arg_list)->Eval())
     1955            ret = CAR(CDR(arg_list))->Eval();
     1956        else
     1957        {
     1958            arg_list = (LList *)CDR(CDR(arg_list)); // check for a else part
     1959            if (arg_list)
     1960                ret = CAR(arg_list)->Eval();
     1961            else
     1962                ret = NULL;
     1963        }
     1964        break;
    19541965    case SYS_FUNC_SETQ:
    19551966    case SYS_FUNC_SETF:
    19561967    {
    1957       void *set_to = CAR(CDR(arg_list))->Eval(), *i=NULL;
    1958       PtrRef r1(set_to), r2(i);
    1959       i=CAR(arg_list);
    1960 
    1961       ltype x=item_type(set_to);
    1962       switch (item_type(i))
    1963       {
    1964         case L_SYMBOL :
    1965         {
    1966           switch (item_type (((LSymbol *)i)->value))
    1967           {
    1968             case L_NUMBER :
     1968        LObject *set_to = CAR(CDR(arg_list))->Eval(), *i = NULL;
     1969        PtrRef r1(set_to), r2(i);
     1970        i = CAR(arg_list);
     1971
     1972        ltype x = item_type(set_to);
     1973        switch (item_type(i))
     1974        {
     1975        case L_SYMBOL:
     1976            switch (item_type(((LSymbol *)i)->value))
    19691977            {
    1970               if (x==L_NUMBER && ((LSymbol *)i)->value!=l_undefined)
    1971                 ((LSymbol *)i)->SetNumber(lnumber_value(set_to));
    1972               else
    1973                 ((LSymbol *)i)->SetValue((LNumber *)set_to);
    1974             } break;
    1975             case L_OBJECT_VAR :
     1978            case L_NUMBER:
     1979                if (x == L_NUMBER && ((LSymbol *)i)->value != l_undefined)
     1980                    ((LSymbol *)i)->SetNumber(lnumber_value(set_to));
     1981                else
     1982                    ((LSymbol *)i)->SetValue((LNumber *)set_to);
     1983                break;
     1984            case L_OBJECT_VAR:
     1985                l_obj_set(((LObjectVar *)(((LSymbol *)i)->value))->index, set_to);
     1986                break;
     1987            default:
     1988                ((LSymbol *)i)->SetValue((LObject *)set_to);
     1989            }
     1990            ret = ((LSymbol *)i)->value;
     1991            break;
     1992        case L_CONS_CELL:   // this better be an 'aref'
     1993        {
     1994#ifdef TYPE_CHECKING
     1995            LObject *car = ((LList *)i)->car;
     1996            if (car == car_symbol)
    19761997            {
    1977               l_obj_set(((LObjectVar *)(((LSymbol *)i)->value))->index, set_to);
    1978             } break;
    1979             default :
    1980               ((LSymbol *)i)->SetValue((LObject *)set_to);
    1981           }
    1982           ret=((LSymbol *)i)->value;
    1983         } break;
    1984         case L_CONS_CELL :   // this better be an 'aref'
    1985         {
    1986 #ifdef TYPE_CHECKING
    1987           void *car=((LList *)i)->car;
    1988           if (car==car_symbol)
    1989           {
    1990             car = CAR(CDR(i))->Eval();
    1991             if (!car || item_type(car)!=L_CONS_CELL)
    1992             { ((LObject *)car)->Print(); lbreak("setq car : evaled object is not a cons cell\n"); exit(0); }
    1993             ((LList *)car)->car = (LObject *)set_to;
    1994           } else if (car==cdr_symbol)
    1995           {
    1996             car = CAR(CDR(i))->Eval();
    1997             if (!car || item_type(car)!=L_CONS_CELL)
    1998             { ((LObject *)car)->Print(); lbreak("setq cdr : evaled object is not a cons cell\n"); exit(0); }
    1999             ((LList *)car)->cdr = (LObject *)set_to;
    2000           } else if (car==aref_symbol)
    2001           {
    2002 #endif
    2003             LArray *a = (LArray *)CAR(CDR(i))->Eval();
    2004             PtrRef r1(a);
    2005 #ifdef TYPE_CHECKING
    2006             if (item_type(a) != L_1D_ARRAY)
     1998                car = CAR(CDR(i))->Eval();
     1999                if (!car || item_type(car) != L_CONS_CELL)
     2000                {
     2001                    car->Print();
     2002                    lbreak("setq car : evaled object is not a cons cell\n");
     2003                    exit(0);
     2004                }
     2005                ((LList *)car)->car = set_to;
     2006            }
     2007            else if (car == cdr_symbol)
    20072008            {
    2008                 a->Print();
    2009                 lbreak("is not an array (aref)\n");
     2009                car = CAR(CDR(i))->Eval();
     2010                if (!car || item_type(car) != L_CONS_CELL)
     2011                {
     2012                    car->Print();
     2013                    lbreak("setq cdr : evaled object is not a cons cell\n");
     2014                    exit(0);
     2015                }
     2016                ((LList *)car)->cdr = set_to;
     2017            }
     2018            else if (car != aref_symbol)
     2019            {
     2020                lbreak("expected (aref, car, cdr, or symbol) in setq\n");
    20102021                exit(0);
    20112022            }
    2012 #endif
    2013             int num = lnumber_value(CAR(CDR(CDR(i)))->Eval());
     2023            else
     2024            {
     2025#endif
     2026                LArray *a = (LArray *)CAR(CDR(i))->Eval();
     2027                PtrRef r1(a);
    20142028#ifdef TYPE_CHECKING
    2015             if (num >= (int)a->len || num < 0)
    2016             {
    2017               lbreak("aref : value of bounds (%d)\n", num);
    2018               exit(0);
     2029                if (item_type(a) != L_1D_ARRAY)
     2030                {
     2031                    a->Print();
     2032                    lbreak("is not an array (aref)\n");
     2033                    exit(0);
     2034                }
     2035#endif
     2036                int num = lnumber_value(CAR(CDR(CDR(i)))->Eval());
     2037#ifdef TYPE_CHECKING
     2038                if (num >= (int)a->len || num < 0)
     2039                {
     2040                    lbreak("aref : value of bounds (%d)\n", num);
     2041                    exit(0);
     2042                }
     2043#endif
     2044                a->GetData()[num] = set_to;
     2045#ifdef TYPE_CHECKING
    20192046            }
    20202047#endif
    2021             a->GetData()[num] = (LObject *)set_to;
    2022 #ifdef TYPE_CHECKING
    2023           } else
    2024           {
    2025             lbreak("expected (aref, car, cdr, or symbol) in setq\n");
     2048            ret = set_to;
     2049            break;
     2050        }
     2051        default:
     2052            i->Print();
     2053            lbreak("setq/setf only defined for symbols and arrays now..\n");
    20262054            exit(0);
    2027           }
    2028 #endif
    2029           ret=set_to;
    2030         } break;
    2031 
    2032         default :
    2033         {
    2034           ((LObject *)i)->Print();
    2035           lbreak("setq/setf only defined for symbols and arrays now..\n");
    2036           exit(0);
    2037         }
    2038       }
    2039     } break;
     2055            break;
     2056        }
     2057        break;
     2058    }
    20402059    case SYS_FUNC_SYMBOL_LIST:
    2041       ret=NULL;
    2042     break;
     2060        ret = NULL;
     2061        break;
    20432062    case SYS_FUNC_ASSOC:
    20442063    {
    2045       void *item = CAR(arg_list)->Eval();
    2046       PtrRef r1(item);
    2047       void *list=(LList *)CAR(CDR(arg_list))->Eval();
    2048       PtrRef r2(list);
    2049       ret=assoc(item, (LList *)list);
    2050     } break;
     2064        LObject *item = CAR(arg_list)->Eval();
     2065        PtrRef r1(item);
     2066        LList *list = (LList *)CAR(CDR(arg_list))->Eval();
     2067        PtrRef r2(list);
     2068        ret = (LObject *)assoc(item, list);
     2069        break;
     2070    }
    20512071    case SYS_FUNC_NOT:
    20522072    case SYS_FUNC_NULL:
    2053     if (CAR(arg_list)->Eval()==NULL) ret=true_symbol; else ret=NULL;
    2054     break;
     2073        if (CAR(arg_list)->Eval() == NULL)
     2074            ret = true_symbol;
     2075        else
     2076            ret = NULL;
     2077        break;
    20552078    case SYS_FUNC_ACONS:
    20562079    {
    2057       void *i1 = CAR(arg_list)->Eval(), *i2 = CAR(CDR(arg_list))->Eval();
    2058       PtrRef r1(i1);
    2059       LList *cs = LList::Create();
    2060       cs->car = (LObject *)i1;
    2061       cs->cdr = (LObject *)i2;
    2062       ret=cs;
    2063     } break;
    2064 
     2080        LObject *i1 = CAR(arg_list)->Eval();
     2081        PtrRef r1(i1);
     2082        LObject *i2 = CAR(CDR(arg_list))->Eval();
     2083        PtrRef r2(i2);
     2084        LList *cs = LList::Create();
     2085        cs->car = i1;
     2086        cs->cdr = i2;
     2087        ret = cs;
     2088        break;
     2089    }
    20652090    case SYS_FUNC_PAIRLIS:
    20662091    {
    2067       l_user_stack.push(CAR(arg_list)->Eval());
    2068       arg_list=CDR(arg_list);
    2069       l_user_stack.push(CAR(arg_list)->Eval());
    2070       arg_list=CDR(arg_list);
    2071       void *n3 = CAR(arg_list)->Eval();
    2072       void *n2=l_user_stack.pop(1);
    2073       void *n1=l_user_stack.pop(1);
    2074       ret=pairlis(n1, n2, n3);
    2075     } break;
     2092        l_user_stack.push(CAR(arg_list)->Eval());
     2093        arg_list = (LList *)CDR(arg_list);
     2094        l_user_stack.push(CAR(arg_list)->Eval());
     2095        arg_list = (LList *)CDR(arg_list);
     2096        LObject *n3 = CAR(arg_list)->Eval();
     2097        LObject *n2 = (LObject *)l_user_stack.pop(1);
     2098        LObject *n1 = (LObject *)l_user_stack.pop(1);
     2099        ret = (LObject *)pairlis(n1, n2, n3);
     2100        break;
     2101    }
    20762102    case SYS_FUNC_LET:
    20772103    {
    2078       // make an a-list of new variable names and new values
    2079       void *var_list=CAR(arg_list),
    2080            *block_list=CDR(arg_list);
    2081       PtrRef r1(block_list), r2(var_list);
    2082       long stack_start=l_user_stack.son;
    2083 
    2084       while (var_list)
    2085       {
    2086     void *var_name=CAR(CAR(var_list)), *tmp;
     2104        // make an a-list of new variable names and new values
     2105        LObject *var_list = CAR(arg_list);
     2106        LObject *block_list = CDR(arg_list);
     2107        PtrRef r1(block_list), r2(var_list);
     2108        long stack_start = l_user_stack.son;
     2109
     2110        while (var_list)
     2111        {
     2112            LObject *var_name = CAR(CAR(var_list)), *tmp;
    20872113#ifdef TYPE_CHECKING
    2088     if (item_type(var_name)!=L_SYMBOL)
    2089     {
    2090       ((LObject *)var_name)->Print();
    2091       lbreak("should be a symbol (let)\n");
    2092       exit(0);
    2093     }
    2094 #endif
    2095 
    2096     l_user_stack.push(((LSymbol *)var_name)->value);
    2097     tmp = CAR(CDR(CAR(var_list)))->Eval();
    2098     ((LSymbol *)var_name)->SetValue((LObject *)tmp);
    2099     var_list=CDR(var_list);
    2100       }
    2101 
    2102       // now evaluate each of the blocks with the new enviroment and return value
    2103       // from the last block
    2104       while (block_list)
    2105       {
    2106     ret = CAR(block_list)->Eval();
    2107     block_list=CDR(block_list);
    2108       }
    2109 
    2110       long cur_stack=stack_start;
    2111       var_list=CAR(arg_list);      // now restore the old symbol values
    2112       while (var_list)
    2113       {
    2114     void *var_name=CAR(CAR(var_list));
    2115     ((LSymbol *)var_name)->SetValue((LObject *)l_user_stack.sdata[cur_stack++]);
    2116     var_list=CDR(var_list);
    2117       }
    2118       l_user_stack.son=stack_start;    // restore the stack
    2119     }
    2120     break;
     2114            if (item_type(var_name) != L_SYMBOL)
     2115            {
     2116                var_name->Print();
     2117                lbreak("should be a symbol (let)\n");
     2118                exit(0);
     2119            }
     2120#endif
     2121
     2122            l_user_stack.push(((LSymbol *)var_name)->value);
     2123            tmp = CAR(CDR(CAR(var_list)))->Eval();
     2124            ((LSymbol *)var_name)->SetValue(tmp);
     2125            var_list = CDR(var_list);
     2126        }
     2127
     2128        // now evaluate each of the blocks with the new environment and
     2129        // return value from the last block
     2130        while (block_list)
     2131        {
     2132            ret = CAR(block_list)->Eval();
     2133            block_list = CDR(block_list);
     2134        }
     2135
     2136        long cur_stack = stack_start;
     2137        var_list = CAR(arg_list); // now restore the old symbol values
     2138        while (var_list)
     2139        {
     2140            LObject *var_name = CAR(CAR(var_list));
     2141            ((LSymbol *)var_name)->SetValue((LObject *)l_user_stack.sdata[cur_stack++]);
     2142            var_list = CDR(var_list);
     2143        }
     2144        l_user_stack.son = stack_start; // restore the stack
     2145        break;
     2146    }
    21212147    case SYS_FUNC_DEFUN:
    21222148    {
    2123       LSymbol *symbol = (LSymbol *)CAR(arg_list);
     2149        LSymbol *symbol = (LSymbol *)CAR(arg_list);
    21242150#ifdef TYPE_CHECKING
    2125       if (item_type(symbol)!=L_SYMBOL)
    2126       {
    2127         symbol->Print();
    2128     lbreak(" is not a symbol! (DEFUN)\n");
    2129     exit(0);
    2130       }
    2131 
    2132       if (item_type(arg_list)!=L_CONS_CELL)
    2133       {
    2134     ((LObject *)arg_list)->Print();
    2135     lbreak("is not a lambda list (DEFUN)\n");
    2136     exit(0);
    2137       }
    2138 #endif
    2139       void *block_list=CDR(CDR(arg_list));
     2151        if (item_type(symbol) != L_SYMBOL)
     2152        {
     2153            symbol->Print();
     2154            lbreak(" is not a symbol! (DEFUN)\n");
     2155            exit(0);
     2156        }
     2157
     2158        if (item_type(arg_list) != L_CONS_CELL)
     2159        {
     2160            arg_list->Print();
     2161            lbreak("is not a lambda list (DEFUN)\n");
     2162            exit(0);
     2163        }
     2164#endif
     2165        LObject *block_list = CDR(CDR(arg_list));
    21402166
    21412167#ifndef NO_LIBS
    2142       intptr_t a=cache.reg_lisp_block(lcar(lcdr(arg_list)));
    2143       intptr_t b=cache.reg_lisp_block(block_list);
    2144       LUserFunction *ufun=new_lisp_user_function(a, b);
     2168        intptr_t a = cache.reg_lisp_block(lcar(lcdr(arg_list)));
     2169        intptr_t b = cache.reg_lisp_block(block_list);
     2170        LUserFunction *ufun = new_lisp_user_function(a, b);
    21452171#else
    2146       LUserFunction *ufun=new_lisp_user_function(lcar(lcdr(arg_list)), block_list);
    2147 #endif
    2148       symbol->SetFunction(ufun);
    2149       ret=symbol;
    2150     } break;
     2172        LUserFunction *ufun = new_lisp_user_function(lcar(lcdr(arg_list)), block_list);
     2173#endif
     2174        symbol->SetFunction(ufun);
     2175        ret = symbol;
     2176        break;
     2177    }
    21512178    case SYS_FUNC_ATOM:
    2152     { ret=lisp_atom(CAR(arg_list)->Eval()); }
     2179        ret = (LObject *)lisp_atom(CAR(arg_list)->Eval());
     2180        break;
    21532181    case SYS_FUNC_AND:
    21542182    {
    2155       void *l=arg_list;
    2156       PtrRef r1(l);
    2157       ret=true_symbol;
    2158       while (l)
    2159       {
    2160     if (!CAR(l)->Eval())
    2161     {
    2162       ret=NULL;
    2163       l=NULL;             // short-circuit
    2164     } else l=CDR(l);
    2165       }
    2166     } break;
     2183        LObject *l = arg_list;
     2184        PtrRef r1(l);
     2185        ret = true_symbol;
     2186        while (l)
     2187        {
     2188            if (!CAR(l)->Eval())
     2189            {
     2190                ret = NULL;
     2191                l = NULL; // short-circuit
     2192            }
     2193            else
     2194                l = CDR(l);
     2195        }
     2196        break;
     2197    }
    21672198    case SYS_FUNC_OR:
    21682199    {
    2169       void *l=arg_list;
    2170       PtrRef r1(l);
    2171       ret=NULL;
    2172       while (l)
    2173       {
    2174     if (CAR(l)->Eval())
    2175     {
    2176       ret=true_symbol;
    2177       l=NULL;            // short circuit
    2178     } else l=CDR(l);
    2179       }
    2180     } break;
     2200        LObject *l = arg_list;
     2201        PtrRef r1(l);
     2202        ret = NULL;
     2203        while (l)
     2204        {
     2205            if (CAR(l)->Eval())
     2206            {
     2207                ret = true_symbol;
     2208                l = NULL; // short-circuit
     2209            }
     2210            else
     2211                l = CDR(l);
     2212        }
     2213        break;
     2214    }
    21812215    case SYS_FUNC_PROGN:
    2182     { ret=eval_block(arg_list); } break;
     2216        ret = (LObject *)eval_block(arg_list);
     2217        break;
    21832218    case SYS_FUNC_CONCATENATE:
    2184       ret=concatenate(arg_list);
    2185     break;
     2219        ret = (LObject *)concatenate(arg_list);
     2220        break;
    21862221    case SYS_FUNC_CHAR_CODE:
    21872222    {
    2188       void *i = CAR(arg_list)->Eval();
    2189       PtrRef r1(i);
    2190       ret=NULL;
    2191       switch (item_type(i))
    2192       {
    2193         case L_CHARACTER :
    2194         { ret = LNumber::Create(((LChar *)i)->ch); } break;
    2195         case L_STRING :
    2196         {  ret = LNumber::Create(*lstring_value(i)); } break;
    2197         default :
    2198         {
    2199           ((LObject *)i)->Print();
    2200           lbreak(" is not character type\n");
    2201           exit(0);
    2202         }
    2203       }
    2204     } break;
     2223        LObject *i = CAR(arg_list)->Eval();
     2224        PtrRef r1(i);
     2225        ret = NULL;
     2226        switch (item_type(i))
     2227        {
     2228        case L_CHARACTER:
     2229            ret = LNumber::Create(((LChar *)i)->ch);
     2230            break;
     2231        case L_STRING:
     2232            ret = LNumber::Create(*lstring_value(i));
     2233            break;
     2234        default:
     2235            i->Print();
     2236            lbreak(" is not character type\n");
     2237            exit(0);
     2238            break;
     2239        }
     2240        break;
     2241    }
    22052242    case SYS_FUNC_CODE_CHAR:
    22062243    {
    2207       void *i = CAR(arg_list)->Eval();
    2208       PtrRef r1(i);
    2209       if (item_type(i)!=L_NUMBER)
    2210       {
    2211     ((LObject *)i)->Print();
    2212     lbreak(" is not number type\n");
    2213     exit(0);
    2214       }
    2215       ret = LChar::Create(((LNumber *)i)->num);
    2216     } break;
     2244        LObject *i = CAR(arg_list)->Eval();
     2245        PtrRef r1(i);
     2246        if (item_type(i) != L_NUMBER)
     2247        {
     2248            i->Print();
     2249            lbreak(" is not number type\n");
     2250            exit(0);
     2251        }
     2252        ret = LChar::Create(((LNumber *)i)->num);
     2253        break;
     2254    }
    22172255    case SYS_FUNC_COND:
    22182256    {
    2219       void *block_list=CAR(arg_list);
    2220       PtrRef r1(block_list);
    2221       if (!block_list) ret=NULL;
    2222       else
    2223       {
    2224     ret=NULL;
     2257        LList *block_list = (LList *)CAR(arg_list);
     2258        PtrRef r1(block_list);
     2259        ret = NULL;
     2260        PtrRef r2(ret); // Required to protect from the last Eval call
    22252261        while (block_list)
    2226     {
    2227       if (lcar(CAR(block_list))->Eval())
    2228         ret = CAR(CDR(CAR(block_list)))->Eval();
    2229       block_list=CDR(block_list);
    2230     }
    2231       }
    2232     } break;
     2262        {
     2263            if (lcar(CAR(block_list))->Eval())
     2264                ret = CAR(CDR(CAR(block_list)))->Eval();
     2265            block_list = (LList *)CDR(block_list);
     2266        }
     2267        break;
     2268    }
    22332269    case SYS_FUNC_SELECT:
    22342270    {
    2235       void *selector = CAR(arg_list)->Eval();
    2236       void *sel=CDR(arg_list);
    2237       PtrRef r1(selector), r2(sel);
    2238       while (sel)
    2239       {
    2240     if (lisp_equal(selector, CAR(CAR(sel))->Eval()))
    2241     {
    2242       sel=CDR(CAR(sel));
    2243       while (sel)
    2244       {
    2245         ret = CAR(sel)->Eval();
    2246         sel=CDR(sel);
    2247       }
    2248       sel=NULL;
    2249     } else sel=CDR(sel);
    2250       }
    2251     } break;
     2271        LObject *selector = CAR(arg_list)->Eval();
     2272        LObject *sel = CDR(arg_list);
     2273        PtrRef r1(selector), r2(sel);
     2274        ret = NULL;
     2275        PtrRef r3(ret); // Required to protect from the last Eval call
     2276        while (sel)
     2277        {
     2278            if (lisp_equal(selector, CAR(CAR(sel))->Eval()))
     2279            {
     2280                sel = CDR(CAR(sel));
     2281                while (sel)
     2282                {
     2283                    ret = CAR(sel)->Eval();
     2284                    sel = CDR(sel);
     2285                }
     2286            }
     2287            else
     2288                sel = CDR(sel);
     2289        }
     2290        break;
     2291    }
    22522292    case SYS_FUNC_FUNCTION:
    2253       ret = ((LSymbol *)CAR(arg_list)->Eval())->GetFunction();
    2254     break;
     2293        ret = ((LSymbol *)CAR(arg_list)->Eval())->GetFunction();
     2294        break;
    22552295    case SYS_FUNC_MAPCAR:
    2256       ret=mapcar(arg_list);
     2296        ret = (LObject *)mapcar(arg_list);
     2297        break;
    22572298    case SYS_FUNC_FUNCALL:
    22582299    {
    2259       void *n1 = CAR(arg_list)->Eval();
    2260       ret = ((LSymbol *)n1)->EvalFunction(CDR(arg_list));
    2261     } break;
     2300        LSymbol *n1 = (LSymbol *)CAR(arg_list)->Eval();
     2301        ret = n1->EvalFunction(CDR(arg_list));
     2302        break;
     2303    }
    22622304    case SYS_FUNC_GT:
    22632305    {
    2264       long n1=lnumber_value(CAR(arg_list)->Eval());
    2265       long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
    2266       if (n1>n2) ret=true_symbol; else ret=NULL;
    2267     }
    2268     break;
     2306        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
     2307        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
     2308        ret = n1 > n2 ? true_symbol : NULL;
     2309        break;
     2310    }
    22692311    case SYS_FUNC_LT:
    22702312    {
    2271       long n1=lnumber_value(CAR(arg_list)->Eval());
    2272       long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
    2273       if (n1<n2) ret=true_symbol; else ret=NULL;
    2274     }
    2275     break;
     2313        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
     2314        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
     2315        ret = n1 < n2 ? true_symbol : NULL;
     2316        break;
     2317    }
    22762318    case SYS_FUNC_GE:
    22772319    {
    2278       long n1=lnumber_value(CAR(arg_list)->Eval());
    2279       long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
    2280       if (n1>=n2) ret=true_symbol; else ret=NULL;
    2281     }
    2282     break;
     2320        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
     2321        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
     2322        ret = n1 >= n2 ? true_symbol : NULL;
     2323        break;
     2324    }
    22832325    case SYS_FUNC_LE:
    22842326    {
    2285       long n1=lnumber_value(CAR(arg_list)->Eval());
    2286       long n2=lnumber_value(CAR(CDR(arg_list))->Eval());
    2287       if (n1<=n2) ret=true_symbol; else ret=NULL;
    2288     }
    2289     break;
    2290 
     2327        int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
     2328        int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
     2329        ret = n1 <= n2 ? true_symbol : NULL;
     2330        break;
     2331    }
    22912332    case SYS_FUNC_TMP_SPACE:
    2292       tmp_space();
    2293       ret=true_symbol;
    2294     break;
     2333        tmp_space();
     2334        ret = true_symbol;
     2335        break;
    22952336    case SYS_FUNC_PERM_SPACE:
    2296       perm_space();
    2297       ret=true_symbol;
    2298     break;
     2337        perm_space();
     2338        ret = true_symbol;
     2339        break;
    22992340    case SYS_FUNC_SYMBOL_NAME:
    2300       LSymbol *symb;
    2301       symb = (LSymbol *)CAR(arg_list)->Eval();
     2341    {
     2342        LSymbol *symb = (LSymbol *)CAR(arg_list)->Eval();
    23022343#ifdef TYPE_CHECKING
    2303       if (item_type(symb)!=L_SYMBOL)
    2304       {
    2305         symb->Print();
    2306         lbreak(" is not a symbol (symbol-name)\n");
    2307         exit(0);
    2308       }
    2309 #endif
    2310       ret = symb->name;
    2311     break;
     2344        if (item_type(symb) != L_SYMBOL)
     2345        {
     2346            symb->Print();
     2347            lbreak(" is not a symbol (symbol-name)\n");
     2348            exit(0);
     2349        }
     2350#endif
     2351        ret = symb->name;
     2352        break;
     2353    }
    23122354    case SYS_FUNC_TRACE:
    2313       trace_level++;
    2314       if (arg_list)
    2315         trace_print_level=lnumber_value(CAR(arg_list)->Eval());
    2316       ret=true_symbol;
    2317     break;
     2355        trace_level++;
     2356        if (arg_list)
     2357            trace_print_level = lnumber_value(CAR(arg_list)->Eval());
     2358        ret = true_symbol;
     2359        break;
    23182360    case SYS_FUNC_UNTRACE:
    2319       if (trace_level>0)
    2320       {
    2321                 trace_level--;
    2322                 ret=true_symbol;
    2323       } else ret=NULL;
    2324     break;
     2361        if (trace_level > 0)
     2362        {
     2363            trace_level--;
     2364            ret = true_symbol;
     2365        }
     2366        else
     2367            ret = NULL;
     2368        break;
    23252369    case SYS_FUNC_DIGSTR:
    23262370    {
    2327       char tmp[50], *tp;
    2328       long num=lnumber_value(CAR(arg_list)->Eval());
    2329       long dig=lnumber_value(CAR(CDR(arg_list))->Eval());
    2330       tp=tmp+49;
    2331       *(tp--)=0;
    2332       for (; num; )
    2333       {
    2334                 int d;
    2335                 d=num%10;
    2336                 *(tp--)=d+'0';
    2337                 num/=10;
    2338                 dig--;
    2339       }
    2340       while (dig--)
    2341         *(tp--)='0';
    2342       ret=LString::Create(tp+1);
    2343     } break;
     2371        char tmp[50], *tp;
     2372        int32_t num = lnumber_value(CAR(arg_list)->Eval());
     2373        int32_t dig = lnumber_value(CAR(CDR(arg_list))->Eval());
     2374        tp = tmp + 49;
     2375        *(tp--) = 0;
     2376        while (num)
     2377        {
     2378            *(tp--) = '0' + (num % 10);
     2379            num /= 10;
     2380            dig--;
     2381        }
     2382        while (dig--)
     2383            *(tp--) = '0';
     2384        ret = LString::Create(tp + 1);
     2385        break;
     2386    }
    23442387    case SYS_FUNC_LOCAL_LOAD:
    23452388    case SYS_FUNC_LOAD:
    23462389    case SYS_FUNC_COMPILE_FILE:
    23472390    {
    2348             void *fn = CAR(arg_list)->Eval();
    2349             char *st = lstring_value( fn );
    2350             PtrRef r1( fn );
    2351             bFILE *fp;
    2352             if( fun->fun_number == SYS_FUNC_LOCAL_LOAD )
     2391        LObject *fn = CAR(arg_list)->Eval();
     2392        PtrRef r1(fn);
     2393        char *st = lstring_value(fn);
     2394        bFILE *fp;
     2395        if (fun_number == SYS_FUNC_LOCAL_LOAD)
     2396        {
     2397            // A special test for gamma.lsp
     2398            if (strcmp(st, "gamma.lsp") == 0)
    23532399            {
    2354                 // A special test for gamma.lsp
    2355                 if( strcmp( st, "gamma.lsp" ) == 0 )
    2356                 {
    2357                     char *gammapath;
    2358                     gammapath = (char *)malloc( strlen( get_save_filename_prefix() ) + 9 + 1 );
    2359                     sprintf( gammapath, "%sgamma.lsp", get_save_filename_prefix() );
    2360                     fp = new jFILE( gammapath, "rb" );
    2361                     free( gammapath );
    2362                 }
    2363                 else
    2364                 {
    2365                     fp = new jFILE( st, "rb" );
    2366                 }
     2400                char *gammapath;
     2401                gammapath = (char *)malloc(strlen(get_save_filename_prefix()) + 9 + 1);
     2402                sprintf(gammapath, "%sgamma.lsp", get_save_filename_prefix());
     2403                fp = new jFILE(gammapath, "rb");
     2404                free(gammapath);
    23672405            }
    23682406            else
     2407                fp = new jFILE(st, "rb");
     2408        }
     2409        else
     2410            fp = open_file(st, "rb");
     2411
     2412        if (fp->open_failure())
     2413        {
     2414            delete fp;
     2415            if (DEFINEDP(((LSymbol *)load_warning)->GetValue())
     2416                 && ((LSymbol *)load_warning)->GetValue())
     2417                dprintf("Warning : file %s does not exist\n", st);
     2418            ret = NULL;
     2419        }
     2420        else
     2421        {
     2422            size_t l = fp->file_size();
     2423            char *s = (char *)malloc(l + 1);
     2424            if (!s)
    23692425            {
    2370                 fp = open_file(st, "rb");
     2426                printf("Malloc error in load_script\n");
     2427                exit(0);
    23712428            }
    23722429
    2373             if( fp->open_failure() )
     2430            fp->read(s, l);
     2431            s[l] = 0;
     2432            delete fp;
     2433            char const *cs = s;
     2434#ifndef NO_LIBS
     2435            char msg[100];
     2436            sprintf(msg, "(load \"%s\")", st);
     2437            if (stat_man)
     2438                stat_man->push(msg, NULL);
     2439            crc_manager.get_filenumber(st); // make sure this file gets crc'ed
     2440#endif
     2441            LObject *compiled_form = NULL;
     2442            PtrRef r11(compiled_form);
     2443            while (!end_of_program(cs))  // see if there is anything left to compile and run
    23742444            {
    2375                 delete fp;
    2376                 if( DEFINEDP(((LSymbol *)load_warning)->GetValue())
    2377                      && ((LSymbol *)load_warning)->GetValue())
    2378                     dprintf("Warning : file %s does not exist\n", st);
    2379                 ret = NULL;
     2445#ifndef NO_LIBS
     2446                if (stat_man)
     2447                    stat_man->update((cs - s) * 100 / l);
     2448#endif
     2449                void *m = mark_heap(TMP_SPACE);
     2450                compiled_form = LObject::Compile(cs);
     2451                compiled_form->Eval();
     2452                compiled_form = NULL;
     2453                restore_heap(m, TMP_SPACE);
    23802454            }
    2381             else
     2455#ifndef NO_LIBS
     2456            if (stat_man)
    23822457            {
    2383                 long l=fp->file_size();
    2384                 char *s=(char *)malloc(l + 1);
    2385                 if (!s)
     2458                stat_man->update(100);
     2459                stat_man->pop();
     2460            }
     2461#endif
     2462            free(s);
     2463            ret = fn;
     2464        }
     2465        break;
     2466    }
     2467    case SYS_FUNC_ABS:
     2468        ret = LNumber::Create(abs(lnumber_value(CAR(arg_list)->Eval())));
     2469        break;
     2470    case SYS_FUNC_MIN:
     2471    {
     2472        int32_t x = lnumber_value(CAR(arg_list)->Eval());
     2473        int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
     2474        ret = LNumber::Create(x < y ? x : y);
     2475        break;
     2476    }
     2477    case SYS_FUNC_MAX:
     2478    {
     2479        int32_t x = lnumber_value(CAR(arg_list)->Eval());
     2480        int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
     2481        ret = LNumber::Create(x > y ? x : y);
     2482        break;
     2483    }
     2484    case SYS_FUNC_BACKQUOTE:
     2485        ret = (LObject *)backquote_eval(CAR(arg_list));
     2486        break;
     2487    case SYS_FUNC_COMMA:
     2488        arg_list->Print();
     2489        lbreak("comma is illegal outside of backquote\n");
     2490        exit(0);
     2491        break;
     2492    case SYS_FUNC_NTH:
     2493    {
     2494        int32_t x = lnumber_value(CAR(arg_list)->Eval());
     2495        ret = (LObject *)nth(x, CAR(CDR(arg_list))->Eval());
     2496        break;
     2497    }
     2498    case SYS_FUNC_RESIZE_TMP:
     2499        resize_tmp(lnumber_value(CAR(arg_list)->Eval()));
     2500        break;
     2501    case SYS_FUNC_RESIZE_PERM:
     2502        resize_perm(lnumber_value(CAR(arg_list)->Eval()));
     2503        break;
     2504    case SYS_FUNC_COS:
     2505        ret = LFixedPoint::Create(lisp_cos(lnumber_value(CAR(arg_list)->Eval())));
     2506        break;
     2507    case SYS_FUNC_SIN:
     2508        ret = LFixedPoint::Create(lisp_sin(lnumber_value(CAR(arg_list)->Eval())));
     2509        break;
     2510    case SYS_FUNC_ATAN2:
     2511    {
     2512        int32_t y = (lnumber_value(CAR(arg_list)->Eval()));
     2513        int32_t x = (lnumber_value(CAR(CDR(arg_list))->Eval()));
     2514        ret = LNumber::Create(lisp_atan2(y, x));
     2515        break;
     2516    }
     2517    case SYS_FUNC_ENUM:
     2518    {
     2519        int sp = current_space;
     2520        current_space = PERM_SPACE;
     2521        int32_t x = 0;
     2522        while (arg_list)
     2523        {
     2524            LObject *sym = CAR(arg_list)->Eval();
     2525            PtrRef r1(sym);
     2526            switch (item_type(sym))
     2527            {
     2528            case L_SYMBOL:
     2529            {
     2530                LObject *tmp = LNumber::Create(x);
     2531                ((LSymbol *)sym)->value = tmp;
     2532                break;
     2533            }
     2534            case L_CONS_CELL:
     2535            {
     2536                LObject *s = CAR(sym)->Eval();
     2537                PtrRef r1(s);
     2538#ifdef TYPE_CHECKING
     2539                if (item_type(s) != L_SYMBOL)
    23862540                {
    2387                   printf("Malloc error in load_script\n");
    2388                   exit(0);
     2541                    arg_list->Print();
     2542                    lbreak("expecting (symbol value) for enum\n");
     2543                    exit(0);
    23892544                }
    2390 
    2391                 fp->read(s, l);
    2392                 s[l]=0;
    2393                 delete fp;
    2394                 char const *cs=s;
    2395             #ifndef NO_LIBS
    2396                 char msg[100];
    2397                 sprintf(msg, "(load \"%s\")", st);
    2398                 if (stat_man) stat_man->push(msg, NULL);
    2399                 crc_manager.get_filenumber(st);               // make sure this file gets crc'ed
    2400             #endif
    2401                 LObject *compiled_form = NULL;
    2402                 PtrRef r11(compiled_form);
    2403                 while (!end_of_program(cs))  // see if there is anything left to compile and run
    2404                 {
    2405             #ifndef NO_LIBS
    2406                   if (stat_man) stat_man->update((cs-s)*100/l);
    2407             #endif
    2408                   void *m=mark_heap(TMP_SPACE);
    2409                   compiled_form=LObject::Compile(cs);
    2410                   compiled_form->Eval();
    2411                   compiled_form=NULL;
    2412                   restore_heap(m, TMP_SPACE);
    2413                 }
    2414             #ifndef NO_LIBS
    2415                                 if (stat_man) stat_man->update(100);
    2416                 if (stat_man) stat_man->pop();
    2417             #endif
    2418                 free(s);
    2419                 ret=fn;
    2420       }
    2421     } break;
    2422     case SYS_FUNC_ABS:
    2423       ret = LNumber::Create(abs(lnumber_value(CAR(arg_list)->Eval()))); break;
    2424     case SYS_FUNC_MIN:
    2425     {
    2426       int x=lnumber_value(CAR(arg_list)->Eval()),
    2427           y=lnumber_value(CAR(CDR(arg_list))->Eval());
    2428       ret = LNumber::Create(x < y ? x : y);
    2429     } break;
    2430     case SYS_FUNC_MAX:
    2431     {
    2432       int x=lnumber_value(CAR(arg_list)->Eval()),
    2433           y=lnumber_value(CAR(CDR(arg_list))->Eval());
    2434       ret = LNumber::Create(x > y ? x : y);
    2435     } break;
    2436     case SYS_FUNC_BACKQUOTE:
    2437     {
    2438       ret=backquote_eval(CAR(arg_list));
    2439     } break;
    2440     case SYS_FUNC_COMMA:
    2441     {
    2442       ((LObject *)arg_list)->Print();
    2443       lbreak("comma is illegal outside of backquote\n");
    2444       exit(0);
    2445       ret=NULL;
    2446     } break;
    2447     case SYS_FUNC_NTH:
    2448     {
    2449       long x=lnumber_value(CAR(arg_list)->Eval());
    2450       ret=nth(x, CAR(CDR(arg_list))->Eval());
    2451     } break;
    2452     case SYS_FUNC_RESIZE_TMP:
    2453         resize_tmp(lnumber_value(CAR(arg_list)->Eval())); break;
    2454     case SYS_FUNC_RESIZE_PERM:
    2455         resize_perm(lnumber_value(CAR(arg_list)->Eval())); break;
    2456     case SYS_FUNC_COS:
    2457         ret = LFixedPoint::Create(lisp_cos(lnumber_value(CAR(arg_list)->Eval()))); break;
    2458     case SYS_FUNC_SIN:
    2459         ret = LFixedPoint::Create(lisp_sin(lnumber_value(CAR(arg_list)->Eval()))); break;
    2460     case SYS_FUNC_ATAN2:
    2461     {
    2462       long y=(lnumber_value(CAR(arg_list)->Eval()));   arg_list=CDR(arg_list);
    2463       long x=(lnumber_value(CAR(arg_list)->Eval()));
    2464       ret = LNumber::Create(lisp_atan2(y, x));
    2465     } break;
    2466     case SYS_FUNC_ENUM:
    2467     {
    2468       int sp=current_space;
    2469       current_space=PERM_SPACE;
    2470       long x=0;
    2471       while (arg_list)
    2472       {
    2473     void *sym = CAR(arg_list)->Eval();
    2474     PtrRef r1(sym);
    2475     switch (item_type(sym))
    2476     {
    2477       case L_SYMBOL :
    2478       { ((LSymbol *)sym)->value = LNumber::Create(x); } break;
    2479       case L_CONS_CELL :
    2480       {
    2481         void *s = CAR(sym)->Eval();
    2482         PtrRef r1(s);
    2483 #ifdef TYPE_CHECKING
    2484         if (item_type(s)!=L_SYMBOL)
    2485         {
    2486           ((LObject *)arg_list)->Print();
    2487           lbreak("expecting (sybmol value) for enum\n");
    2488           exit(0);
    2489         }
    2490 #endif
    2491         x=lnumber_value(CAR(CDR(sym))->Eval());
    2492         ((LSymbol *)sym)->value = LNumber::Create(x);
    2493       } break;
    2494       default :
    2495       {
    2496         ((LObject *)arg_list)->Print();
    2497         lbreak("expecting symbol or (symbol value) in enum\n");
     2545#endif
     2546                x = lnumber_value(CAR(CDR(sym))->Eval());
     2547                LObject *tmp = LNumber::Create(x);
     2548                ((LSymbol *)sym)->value = tmp;
     2549                break;
     2550            }
     2551            default:
     2552                arg_list->Print();
     2553                lbreak("expecting symbol or (symbol value) in enum\n");
     2554                exit(0);
     2555            }
     2556            arg_list = (LList *)CDR(arg_list);
     2557            x++;
     2558        }
     2559        current_space = sp;
     2560        break;
     2561    }
     2562    case SYS_FUNC_QUIT:
    24982563        exit(0);
    2499       }
    2500     }
    2501     arg_list=CDR(arg_list);
    2502     x++;
    2503       }
    2504       current_space=sp;
    2505     } break;
    2506     case SYS_FUNC_QUIT:
    2507     {
    2508       exit(0);
    2509     } break;
     2564        break;
    25102565    case SYS_FUNC_EVAL:
    2511     {
    2512       ret = CAR(arg_list)->Eval()->Eval();
    2513     } break;
    2514     case SYS_FUNC_BREAK: lbreak("User break"); break;
     2566        ret = CAR(arg_list)->Eval()->Eval();
     2567        break;
     2568    case SYS_FUNC_BREAK:
     2569        lbreak("User break");
     2570        break;
    25152571    case SYS_FUNC_MOD:
    25162572    {
    2517       long x=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
    2518       long y=lnumber_value(CAR(arg_list)->Eval());
    2519       if (y==0) { lbreak("mod : division by zero\n"); y=1; }
    2520       ret = LNumber::Create(x%y);
    2521     } break;
    2522 /*    case SYS_FUNC_WRITE_PROFILE:
    2523     {
    2524       char *fn=lstring_value(CAR(arg_list)->Eval());
    2525       FILE *fp=fopen(fn, "wb");
    2526       if (!fp)
    2527         lbreak("could not open %s for writing", fn);
    2528       else
    2529       {
    2530     for (void *s=symbol_list; s; s=CDR(s))
    2531       fprintf(fp, "%8d  %s\n", ((LSymbol *)(CAR(s)))->call_counter,
    2532           lstring_value(((LSymbol *)(CAR(s)))->name));
    2533     fclose(fp);
    2534       }
    2535     } break; */
     2573        int32_t x = lnumber_value(CAR(arg_list)->Eval());
     2574        int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
     2575        if (y == 0)
     2576        {
     2577            lbreak("mod: division by zero\n");
     2578            y = 1;
     2579        }
     2580        ret = LNumber::Create(x % y);
     2581        break;
     2582    }
     2583#if 0
     2584    case SYS_FUNC_WRITE_PROFILE:
     2585    {
     2586        char *fn = lstring_value(CAR(arg_list)->Eval());
     2587        FILE *fp = fopen(fn, "wb");
     2588        if (!fp)
     2589            lbreak("could not open %s for writing", fn);
     2590        else
     2591        {
     2592            for (void *s = symbol_list; s; s = CDR(s))
     2593                fprintf(fp, "%8d  %s\n", ((LSymbol *)(CAR(s)))->call_counter,
     2594                        lstring_value(((LSymbol *)(CAR(s)))->name));
     2595            fclose(fp);
     2596        }
     2597        break;
     2598    }
     2599#endif
    25362600    case SYS_FUNC_FOR:
    25372601    {
    2538       LSymbol *bind_var = (LSymbol *)CAR(arg_list);
    2539       arg_list = CDR(arg_list);
    2540       PtrRef r1(bind_var);
    2541       if (item_type(bind_var)!=L_SYMBOL)
    2542       { lbreak("expecting for iterator to be a symbol\n"); exit(1); }
    2543 
    2544       if (CAR(arg_list)!=in_symbol)
    2545       { lbreak("expecting in after 'for iterator'\n"); exit(1); }
    2546       arg_list=CDR(arg_list);
    2547 
    2548       void *ilist = CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
    2549       PtrRef r2(ilist);
    2550 
    2551       if (CAR(arg_list)!=do_symbol)
    2552       { lbreak("expecting do after 'for iterator in list'\n"); exit(1); }
    2553       arg_list=CDR(arg_list);
    2554 
    2555       void *block=NULL, *ret=NULL;
    2556       PtrRef r3(block);
    2557       l_user_stack.push(bind_var->GetValue());  // save old symbol value
    2558       while (ilist)
    2559       {
    2560                 bind_var->SetValue((LObject *)CAR(ilist));
    2561                 for (block=arg_list; block; block=CDR(block))
    2562                   ret = CAR(block)->Eval();
    2563                 ilist=CDR(ilist);
    2564       }
    2565       bind_var->SetValue((LObject *)l_user_stack.pop(1)); // restore symbol value
    2566       ret=ret;
    2567     } break;
     2602        LSymbol *bind_var = (LSymbol *)CAR(arg_list);
     2603        PtrRef r1(bind_var);
     2604        if (item_type(bind_var) != L_SYMBOL)
     2605        {
     2606            lbreak("expecting for iterator to be a symbol\n");
     2607            exit(1);
     2608        }
     2609        arg_list = (LList *)CDR(arg_list);
     2610
     2611        if (CAR(arg_list) != in_symbol)
     2612        {
     2613            lbreak("expecting in after 'for iterator'\n");
     2614            exit(1);
     2615        }
     2616        arg_list = (LList *)CDR(arg_list);
     2617
     2618        LObject *ilist = CAR(arg_list)->Eval();
     2619        PtrRef r2(ilist);
     2620        arg_list = (LList *)CDR(arg_list);
     2621
     2622        if (CAR(arg_list) != do_symbol)
     2623        {
     2624            lbreak("expecting do after 'for iterator in list'\n");
     2625            exit(1);
     2626        }
     2627        arg_list = (LList *)CDR(arg_list);
     2628
     2629        LObject *block = NULL;
     2630        PtrRef r3(block);
     2631        PtrRef r4(ret); // Required to protect from the last SetValue call
     2632        l_user_stack.push(bind_var->GetValue());  // save old symbol value
     2633        while (ilist)
     2634        {
     2635            bind_var->SetValue((LObject *)CAR(ilist));
     2636            for (block = arg_list; block; block = CDR(block))
     2637                ret = CAR(block)->Eval();
     2638            ilist = CDR(ilist);
     2639        }
     2640        bind_var->SetValue((LObject *)l_user_stack.pop(1)); // restore value
     2641        break;
     2642    }
    25682643    case SYS_FUNC_OPEN_FILE:
    25692644    {
    2570       bFILE *old_file=current_print_file;
    2571       void *str1 = CAR(arg_list)->Eval();
    2572       PtrRef r1(str1);
    2573       void *str2 = CAR(CDR(arg_list))->Eval();
    2574 
    2575 
    2576       current_print_file=open_file(lstring_value(str1),
    2577                    lstring_value(str2));
    2578 
    2579       if (!current_print_file->open_failure())
    2580       {
    2581                 while (arg_list)
    2582                 {
    2583                   ret = CAR(arg_list)->Eval();
    2584                   arg_list=CDR(arg_list);
    2585                 }
    2586       }
    2587       delete current_print_file;
    2588       current_print_file=old_file;
    2589 
    2590     } break;
     2645        LObject *str1 = CAR(arg_list)->Eval();
     2646        PtrRef r1(str1);
     2647        LObject *str2 = CAR(CDR(arg_list))->Eval();
     2648
     2649        bFILE *old_file = current_print_file;
     2650        current_print_file = open_file(lstring_value(str1),
     2651                                       lstring_value(str2));
     2652
     2653        if (!current_print_file->open_failure())
     2654        {
     2655            while (arg_list)
     2656            {
     2657                ret = CAR(arg_list)->Eval();
     2658                arg_list = (LList *)CDR(arg_list);
     2659            }
     2660        }
     2661        delete current_print_file;
     2662        current_print_file = old_file;
     2663        break;
     2664    }
    25912665    case SYS_FUNC_BIT_AND:
    25922666    {
    2593       long first=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
    2594       while (arg_list)
    2595       {
    2596         first&=lnumber_value(CAR(arg_list)->Eval());
    2597                 arg_list=CDR(arg_list);
    2598       }
    2599       ret = LNumber::Create(first);
    2600     } break;
     2667        int32_t first = lnumber_value(CAR(arg_list)->Eval());
     2668        arg_list = (LList *)CDR(arg_list);
     2669        while (arg_list)
     2670        {
     2671            first &= lnumber_value(CAR(arg_list)->Eval());
     2672            arg_list = (LList *)CDR(arg_list);
     2673        }
     2674        ret = LNumber::Create(first);
     2675        break;
     2676    }
    26012677    case SYS_FUNC_BIT_OR:
    26022678    {
    2603       long first=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
    2604       while (arg_list)
    2605       {
    2606         first|=lnumber_value(CAR(arg_list)->Eval());
    2607                 arg_list=CDR(arg_list);
    2608       }
    2609       ret = LNumber::Create(first);
    2610     } break;
     2679        int32_t first = lnumber_value(CAR(arg_list)->Eval());
     2680        arg_list = (LList *)CDR(arg_list);
     2681        while (arg_list)
     2682        {
     2683            first |= lnumber_value(CAR(arg_list)->Eval());
     2684            arg_list = (LList *)CDR(arg_list);
     2685        }
     2686        ret = LNumber::Create(first);
     2687        break;
     2688    }
    26112689    case SYS_FUNC_BIT_XOR:
    26122690    {
    2613       long first=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
    2614       while (arg_list)
    2615       {
    2616         first^=lnumber_value(CAR(arg_list)->Eval());
    2617                 arg_list=CDR(arg_list);
    2618       }
    2619       ret = LNumber::Create(first);
    2620     } break;
     2691        int32_t first = lnumber_value(CAR(arg_list)->Eval());
     2692        arg_list = (LList *)CDR(arg_list);
     2693        while (arg_list)
     2694        {
     2695            first ^= lnumber_value(CAR(arg_list)->Eval());
     2696            arg_list = (LList *)CDR(arg_list);
     2697        }
     2698        ret = LNumber::Create(first);
     2699        break;
     2700    }
    26212701    case SYS_FUNC_MAKE_ARRAY:
    26222702    {
    2623       long l=lnumber_value(CAR(arg_list)->Eval());
    2624       if (l>=2<<16 || l<=0)
    2625       {
    2626                 lbreak("bad array size %d\n", l);
     2703        int32_t l = lnumber_value(CAR(arg_list)->Eval());
     2704        if (l >= (2 << 16) || l <= 0)
     2705        {
     2706            lbreak("bad array size %d\n", l);
     2707            exit(0);
     2708        }
     2709        ret = LArray::Create(l, CDR(arg_list));
     2710        break;
     2711    }
     2712    case SYS_FUNC_AREF:
     2713    {
     2714        int32_t x = lnumber_value(CAR(CDR(arg_list))->Eval());
     2715        ret = ((LArray *)CAR(arg_list)->Eval())->Get(x);
     2716        break;
     2717    }
     2718    case SYS_FUNC_IF_1PROGN:
     2719        if (CAR(arg_list)->Eval())
     2720            ret = (LObject *)eval_block(CAR(CDR(arg_list)));
     2721        else
     2722            ret = CAR(CDR(CDR(arg_list)))->Eval();
     2723        break;
     2724    case SYS_FUNC_IF_2PROGN:
     2725        if (CAR(arg_list)->Eval())
     2726            ret = CAR(CDR(arg_list))->Eval();
     2727        else
     2728            ret = (LObject *)eval_block(CAR(CDR(CDR(arg_list))));
     2729
     2730        break;
     2731    case SYS_FUNC_IF_12PROGN:
     2732        if (CAR(arg_list)->Eval())
     2733            ret = (LObject *)eval_block(CAR(CDR(arg_list)));
     2734        else
     2735            ret = (LObject *)eval_block(CAR(CDR(CDR(arg_list))));
     2736        break;
     2737    case SYS_FUNC_EQ0:
     2738    {
     2739        LObject *v = CAR(arg_list)->Eval();
     2740        if (item_type(v) != L_NUMBER || (((LNumber *)v)->num != 0))
     2741            ret = NULL;
     2742        else
     2743            ret = true_symbol;
     2744        break;
     2745    }
     2746    case SYS_FUNC_PREPORT:
     2747    {
     2748#ifdef L_PROFILE
     2749        char *s = lstring_value(CAR(arg_list)->Eval());
     2750        preport(s);
     2751#endif
     2752        break;
     2753    }
     2754    case SYS_FUNC_SEARCH:
     2755    {
     2756        LObject *arg1 = CAR(arg_list)->Eval();
     2757        PtrRef r1(arg1); // protect this reference
     2758        arg_list = (LList *)CDR(arg_list);
     2759        char *haystack = lstring_value(CAR(arg_list)->Eval());
     2760        char *needle = lstring_value(arg1);
     2761
     2762        char *find = strstr(haystack, needle);
     2763        ret = find ? LNumber::Create(find - haystack) : NULL;
     2764        break;
     2765    }
     2766    case SYS_FUNC_ELT:
     2767    {
     2768        LObject *arg1 = CAR(arg_list)->Eval();
     2769        PtrRef r1(arg1); // protect this reference
     2770        arg_list = (LList *)CDR(arg_list);
     2771        int32_t x = lnumber_value(CAR(arg_list)->Eval());
     2772        char *st = lstring_value(arg1);
     2773        if (x < 0 || x >= (int32_t)strlen(st))
     2774        {
     2775            lbreak("elt : out of range of string\n");
     2776            ret = NULL;
     2777        }
     2778        else
     2779            ret = LChar::Create(st[x]);
     2780        break;
     2781    }
     2782    case SYS_FUNC_LISTP:
     2783    {
     2784        ltype t = item_type(CAR(arg_list)->Eval());
     2785        ret = (t == L_CONS_CELL) ? true_symbol : NULL;
     2786        break;
     2787    }
     2788    case SYS_FUNC_NUMBERP:
     2789    {
     2790        ltype t = item_type(CAR(arg_list)->Eval());
     2791        ret = (t == L_NUMBER || t == L_FIXED_POINT) ? true_symbol : NULL;
     2792        break;
     2793    }
     2794    case SYS_FUNC_DO:
     2795    {
     2796        LObject *init_var = CAR(arg_list);
     2797        PtrRef r1(init_var);
     2798        int ustack_start = l_user_stack.son;      // restore stack at end
     2799        LSymbol *sym = NULL;
     2800        PtrRef r2(sym);
     2801
     2802        // check to make sure iter vars are symbol and push old values
     2803        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
     2804        {
     2805            sym = (LSymbol *)CAR(CAR(init_var));
     2806            if (item_type(sym) != L_SYMBOL)
     2807            {
     2808                lbreak("expecting symbol name for iteration var\n");
    26272809                exit(0);
    2628       }
    2629       ret = LArray::Create(l, CDR(arg_list));
    2630     } break;
    2631     case SYS_FUNC_AREF:
    2632     {
    2633       long x=lnumber_value(CAR(CDR(arg_list))->Eval());
    2634       ret = ((LArray *)CAR(arg_list)->Eval())->Get(x);
    2635     } break;
    2636     case SYS_FUNC_IF_1PROGN:
    2637     {
    2638       if (CAR(arg_list)->Eval())
    2639         ret=eval_block(CAR(CDR(arg_list)));
    2640       else ret = CAR(CDR(CDR(arg_list)))->Eval();
    2641 
    2642     } break;
    2643     case SYS_FUNC_IF_2PROGN:
    2644     {
    2645       if (CAR(arg_list)->Eval())
    2646         ret = CAR(CDR(arg_list))->Eval();
    2647       else ret=eval_block(CAR(CDR(CDR(arg_list))));
    2648 
    2649     } break;
    2650     case SYS_FUNC_IF_12PROGN:
    2651     {
    2652       if (CAR(arg_list)->Eval())
    2653         ret=eval_block(CAR(CDR(arg_list)));
    2654       else ret=eval_block(CAR(CDR(CDR(arg_list))));
    2655 
    2656     } break;
    2657     case SYS_FUNC_EQ0:
    2658     {
    2659       void *v = CAR(arg_list)->Eval();
    2660       if (item_type(v)!=L_NUMBER || (((LNumber *)v)->num!=0))
    2661         ret=NULL;
    2662       else ret=true_symbol;
    2663     } break;
    2664     case SYS_FUNC_PREPORT:
    2665     {
    2666 #ifdef L_PROFILE
    2667       char *s=lstring_value(CAR(arg_list)->Eval());
    2668       preport(s);
    2669 #endif
    2670     } break;
    2671     case SYS_FUNC_SEARCH:
    2672     {
    2673       void *arg1 = CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
    2674       PtrRef r1(arg1);       // protect this refrence
    2675       char *haystack=lstring_value(CAR(arg_list)->Eval());
    2676       char *needle=lstring_value(arg1);
    2677 
    2678       char *find=strstr(haystack, needle);
    2679       if (find)
    2680         ret = LNumber::Create(find-haystack);
    2681       else ret=NULL;
    2682     } break;
    2683     case SYS_FUNC_ELT:
    2684     {
    2685       void *arg1 = CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
    2686       PtrRef r1(arg1);       // protect this refrence
    2687       long x=lnumber_value(CAR(arg_list)->Eval());
    2688       char *st=lstring_value(arg1);
    2689       if (x < 0 || (unsigned)x >= strlen(st))
    2690       { lbreak("elt : out of range of string\n"); ret=NULL; }
    2691       else
    2692         ret = LChar::Create(st[x]);
    2693     } break;
    2694     case SYS_FUNC_LISTP:
    2695     {
    2696       return item_type(CAR(arg_list)->Eval())==L_CONS_CELL ? true_symbol : NULL;
    2697     } break;
    2698     case SYS_FUNC_NUMBERP:
    2699     {
    2700       int t=item_type(CAR(arg_list)->Eval());
    2701       if (t==L_NUMBER || t==L_FIXED_POINT) return true_symbol; else return NULL;
    2702     } break;
    2703     case SYS_FUNC_DO:
    2704     {
    2705       void *init_var=CAR(arg_list);
    2706       PtrRef r1(init_var);
    2707       int i, ustack_start=l_user_stack.son;      // restore stack at end
    2708       LSymbol *sym = NULL;
    2709       PtrRef r2(sym);
    2710 
    2711       // check to make sure iter vars are symbol and push old values
    2712       for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var))
    2713       {
    2714                 sym = (LSymbol *)CAR(CAR(init_var));
    2715                 if (item_type(sym)!=L_SYMBOL)
    2716                 { lbreak("expecting symbol name for iteration var\n"); exit(0); }
    2717                 l_user_stack.push(sym->GetValue());
    2718       }
    2719 
    2720       void **do_evaled=l_user_stack.sdata+l_user_stack.son;
    2721       // push all of the init forms, so we can set the symbol
    2722       for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var))
    2723                 l_user_stack.push(CAR(CDR(CAR((init_var))))->Eval());
    2724 
    2725       // now set all the symbols
    2726       for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var), do_evaled++)
    2727       {
    2728                 sym = (LSymbol *)CAR(CAR(init_var));
    2729                 sym->SetValue((LObject *)*do_evaled);
    2730       }
    2731 
    2732       i=0;       // set i to 1 when terminate conditions are meet
    2733       do
    2734       {
    2735                 i = CAR(CAR(CDR(arg_list)))->Eval() != NULL;
    2736                 if (!i)
    2737                 {
    2738                   eval_block(CDR(CDR(arg_list)));
    2739                   for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var))
     2810            }
     2811            l_user_stack.push(sym->GetValue());
     2812        }
     2813
     2814        void **do_evaled = l_user_stack.sdata + l_user_stack.son;
     2815        // push all of the init forms, so we can set the symbol
     2816        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
     2817            l_user_stack.push(CAR(CDR(CAR((init_var))))->Eval());
     2818
     2819        // now set all the symbols
     2820        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
     2821        {
     2822            sym = (LSymbol *)CAR(CAR(init_var));
     2823            sym->SetValue((LObject *)*do_evaled);
     2824            do_evaled++;
     2825        }
     2826
     2827        for (int i = 0; !i; ) // set i to 1 when terminate conditions are met
     2828        {
     2829            i = CAR(CAR(CDR(arg_list)))->Eval() != NULL;
     2830            if (!i)
     2831            {
     2832                eval_block(CDR(CDR(arg_list)));
     2833                for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
    27402834                    CAR(CDR(CDR(CAR(init_var))))->Eval();
    2741                 }
    2742       } while (!i);
    2743 
    2744       ret = CAR(CDR(CAR(CDR(arg_list))))->Eval();
    2745 
    2746       // restore old values for symbols
    2747       do_evaled=l_user_stack.sdata+ustack_start;
    2748       for (init_var=CAR(arg_list); init_var; init_var=CDR(init_var), do_evaled++)
    2749       {
    2750                 sym = (LSymbol *)CAR(CAR(init_var));
    2751                 sym->SetValue((LObject *)*do_evaled);
    2752       }
    2753 
    2754       l_user_stack.son=ustack_start;
    2755 
    2756     } break;
     2835            }
     2836        }
     2837
     2838        ret = CAR(CDR(CAR(CDR(arg_list))))->Eval();
     2839
     2840        // restore old values for symbols
     2841        do_evaled = l_user_stack.sdata + ustack_start;
     2842        for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
     2843        {
     2844            sym = (LSymbol *)CAR(CAR(init_var));
     2845            sym->SetValue((LObject *)*do_evaled);
     2846            do_evaled++;
     2847        }
     2848
     2849        l_user_stack.son = ustack_start;
     2850        break;
     2851    }
    27572852    case SYS_FUNC_GC:
    2758     {
    2759       collect_space(current_space);
    2760     } break;
     2853        collect_space(current_space);
     2854        break;
    27612855    case SYS_FUNC_SCHAR:
    27622856    {
    2763       char *s=lstring_value(CAR(arg_list)->Eval());
    2764       arg_list=CDR(arg_list);
    2765       long x=lnumber_value(CAR(arg_list)->Eval());
    2766 
    2767       if ((unsigned)x >= strlen(s))
    2768       { lbreak("SCHAR: index %d should be less than the length of the string\n", x); exit(0); }
    2769       else if (x<0)
    2770       { lbreak("SCHAR: index should not be negative\n"); exit(0); }
    2771       return LChar::Create(s[x]);
    2772     } break;
     2857        char *s = lstring_value(CAR(arg_list)->Eval());
     2858        arg_list = (LList *)CDR(arg_list);
     2859        int32_t x = lnumber_value(CAR(arg_list)->Eval());
     2860
     2861        if (x < 0 || x >= (int32_t)strlen(s))
     2862        {
     2863            lbreak("SCHAR: index %d out of bounds\n", x);
     2864            exit(0);
     2865        }
     2866        ret = LChar::Create(s[x]);
     2867        break;
     2868    }
    27732869    case SYS_FUNC_SYMBOLP:
    2774     { if (item_type(CAR(arg_list)->Eval())==L_SYMBOL) return true_symbol;
    2775       else return NULL; } break;
     2870        if (item_type(CAR(arg_list)->Eval()) == L_SYMBOL)
     2871            ret = true_symbol;
     2872        break;
    27762873    case SYS_FUNC_NUM2STR:
    27772874    {
    2778       char str[20];
    2779       sprintf(str, "%ld", (long int)lnumber_value(CAR(arg_list)->Eval()));
    2780       ret=LString::Create(str);
    2781     } break;
     2875        char str[20];
     2876        sprintf(str, "%ld", (long int)lnumber_value(CAR(arg_list)->Eval()));
     2877        ret = LString::Create(str);
     2878        break;
     2879    }
    27822880    case SYS_FUNC_NCONC:
    27832881    {
    2784       void *l1=CAR(arg_list)->Eval(); arg_list=CDR(arg_list);
    2785       PtrRef r1(l1);
    2786       void *first=l1, *next;
    2787       PtrRef r2(first);
    2788 
    2789       if (!l1)
    2790       {
    2791                 l1=first=CAR(arg_list)->Eval();
    2792                 arg_list=CDR(arg_list);
    2793       }
    2794 
    2795       if (item_type(l1)!=L_CONS_CELL)
    2796       { ((LObject *)l1)->Print(); lbreak("first arg should be a list\n"); }
    2797       do
    2798       {
    2799                 next=l1;
    2800                 while (next) { l1=next; next=lcdr(next); }
    2801                 ((LList *)l1)->cdr = CAR(arg_list)->Eval();
    2802                 arg_list=CDR(arg_list);
    2803       } while (arg_list);
    2804       ret=first;
    2805     } break;
     2882        LObject *l1 = CAR(arg_list)->Eval();
     2883        PtrRef r1(l1);
     2884        arg_list = (LList *)CDR(arg_list);
     2885        LObject *first = l1, *next;
     2886        PtrRef r2(first);
     2887
     2888        if (!l1)
     2889        {
     2890            l1 = first = CAR(arg_list)->Eval();
     2891            arg_list = (LList *)CDR(arg_list);
     2892        }
     2893
     2894        if (item_type(l1) != L_CONS_CELL)
     2895        {
     2896            l1->Print();
     2897            lbreak("first arg should be a list\n");
     2898        }
     2899
     2900        do
     2901        {
     2902            next = l1;
     2903            while (next)
     2904            {
     2905                l1 = next;
     2906                next = lcdr(next);
     2907            }
     2908            LObject *tmp = CAR(arg_list)->Eval();
     2909            ((LList *)l1)->cdr = tmp;
     2910            arg_list = (LList *)CDR(arg_list);
     2911        } while (arg_list);
     2912        ret = first;
     2913        break;
     2914    }
    28062915    case SYS_FUNC_FIRST:
    2807     { ret=CAR(CAR(arg_list)->Eval()); } break;
     2916        ret = CAR(CAR(arg_list)->Eval());
     2917        break;
    28082918    case SYS_FUNC_SECOND:
    2809     { ret=CAR(CDR(CAR(arg_list)->Eval())); } break;
     2919        ret = CAR(CDR(CAR(arg_list)->Eval()));
     2920        break;
    28102921    case SYS_FUNC_THIRD:
    2811     { ret=CAR(CDR(CDR(CAR(arg_list)->Eval()))); } break;
     2922        ret = CAR(CDR(CDR(CAR(arg_list)->Eval())));
     2923        break;
    28122924    case SYS_FUNC_FOURTH:
    2813     { ret=CAR(CDR(CDR(CDR(CAR(arg_list)->Eval())))); } break;
     2925        ret = CAR(CDR(CDR(CDR(CAR(arg_list)->Eval()))));
     2926        break;
    28142927    case SYS_FUNC_FIFTH:
    2815     { ret=CAR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))); } break;
     2928        ret = CAR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))));
     2929        break;
    28162930    case SYS_FUNC_SIXTH:
    2817     { ret=CAR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))); } break;
     2931        ret = CAR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))));
     2932        break;
    28182933    case SYS_FUNC_SEVENTH:
    2819     { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))); } break;
     2934        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))));
     2935        break;
    28202936    case SYS_FUNC_EIGHTH:
    2821     { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))))); } break;
     2937        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))));
     2938        break;
    28222939    case SYS_FUNC_NINTH:
    2823     { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))))); } break;
     2940        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))))));
     2941        break;
    28242942    case SYS_FUNC_TENTH:
    2825     { ret=CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))))))); } break;
     2943        ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))))));
     2944        break;
    28262945    case SYS_FUNC_SUBSTR:
    28272946    {
    2828       long x1=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
    2829       long x2=lnumber_value(CAR(arg_list)->Eval()); arg_list=CDR(arg_list);
    2830       void *st=CAR(arg_list)->Eval();
    2831       PtrRef r1(st);
    2832 
    2833       if (x1 < 0 || x1 > x2 || (unsigned)x2 >= strlen(lstring_value(st)))
    2834         lbreak("substr : bad x1 or x2 value");
    2835 
    2836       LString *s=LString::Create(x2-x1+2);
    2837       if (x2-x1)
    2838         memcpy(lstring_value(s), lstring_value(st)+x1, x2-x1+1);
    2839 
    2840       *(lstring_value(s)+(x2-x1+1))=0;
    2841       ret=s;
    2842     } break;
    2843     case 99 :
    2844     {
    2845       void *r=NULL, *rstart=NULL;
    2846       PtrRef r1(r), r2(rstart);
    2847       while (arg_list)
    2848       {
    2849         void *q = CAR(arg_list)->Eval();
    2850         if (!rstart) rstart=q;
    2851         while (r && CDR(r)) r=CDR(r);
    2852         CDR(r) = (LObject *)q;
    2853         arg_list=CDR(arg_list);
    2854       }
    2855       return rstart;
    2856     } break;
    2857 
    2858     default :
    2859     { dprintf("Undefined system function number %d\n", ((LSysFunction *)fun)->fun_number); }
    2860   }
    2861   return ret;
     2947        int32_t x1 = lnumber_value(CAR(arg_list)->Eval());
     2948        int32_t x2 = lnumber_value(CAR(CDR(arg_list))->Eval());
     2949        LObject *st = CAR(CAR(CDR(arg_list)))->Eval();
     2950        PtrRef r1(st);
     2951
     2952        if (x1 < 0 || x1 > x2 || x2 >= (int32_t)strlen(lstring_value(st)))
     2953            lbreak("substr: bad x1 or x2 value");
     2954
     2955        LString *s = LString::Create(x2 - x1 + 2);
     2956        if (x2 - x1)
     2957            memcpy(lstring_value(s), lstring_value(st) + x1, x2 - x1 + 1);
     2958
     2959        lstring_value(s)[x2 - x1 + 1] = 0;
     2960        ret = s;
     2961        break;
     2962    }
     2963    case 99:
     2964    {
     2965        LObject *r = NULL, *rstart = NULL;
     2966        PtrRef r1(r), r2(rstart);
     2967        while (arg_list)
     2968        {
     2969            LObject *q = CAR(arg_list)->Eval();
     2970            if (!rstart)
     2971                rstart = q;
     2972            while (r && CDR(r))
     2973                r = CDR(r);
     2974            CDR(r) = q;
     2975            arg_list = (LList *)CDR(arg_list);
     2976        }
     2977        ret = rstart;
     2978        break;
     2979    }
     2980    default:
     2981        dprintf("Undefined system function number %d\n", fun_number);
     2982        break;
     2983    }
     2984
     2985    return ret;
    28622986}
    28632987
     
    29833107}
    29843108
     3109/* PtrRef check: OK */
    29853110LObject *LObject::Eval()
    29863111{
    2987     LObject *ret = NULL;
    29883112    PtrRef ref1(this);
    29893113
     
    30023126        trace_level++;
    30033127    }
     3128
     3129    LObject *ret = NULL;
    30043130
    30053131    if (this)
  • abuse/trunk/src/lisp/lisp.h

    r497 r498  
    143143struct LSysFunction : LObject
    144144{
     145    /* Methods */
     146    LObject *EvalFunction(LList *arg_list);
     147
     148    /* Members */
    145149    short min_args, max_args;
    146150    short fun_number;
Note: See TracChangeset for help on using the changeset viewer.