Changeset 498
- Timestamp:
- Apr 17, 2011, 11:57:03 PM (11 years ago)
- Location:
- abuse/trunk/src/lisp
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
abuse/trunk/src/lisp/lisp.cpp
r497 r498 130 130 dprintf("CLIVE Debugger\n"); 131 131 dprintf(" w, where : show calling parents\n" 132 " e, env : show enviro ment\n"132 " e, env : show environment\n" 133 133 " c, cont : continue if possible\n" 134 134 " q, quit : quits the program\n" … … 1417 1417 break; 1418 1418 case L_COLLECTED_OBJECT: 1419 lprint_string("GC_ref rence->");1419 lprint_string("GC_reference->"); 1420 1420 ((LRedirect *)this)->ref->Print(); 1421 1421 break; … … 1429 1429 } 1430 1430 1431 void *eval_sys_function(LSysFunction *fun, void *arg_list); 1432 1431 /* PtrRef check: OK */ 1433 1432 LObject *LSymbol::EvalFunction(void *arg_list) 1434 1433 { … … 1501 1500 { 1502 1501 case L_SYS_FUNCTION: 1503 ret = ( LObject *)eval_sys_function(((LSysFunction *)fun),arg_list);1502 ret = ((LSysFunction *)fun)->EvalFunction((LList *)arg_list); 1504 1503 break; 1505 1504 case L_L_FUNCTION: … … 1790 1789 } 1791 1790 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 */ 1792 LObject *LSysFunction::EvalFunction(LList *arg_list) 1793 { 1794 LObject *ret = NULL; 1795 1796 PtrRef ref1(arg_list); 1797 1798 switch (fun_number) 1799 { 1799 1800 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; 1810 1808 case SYS_FUNC_CAR: 1811 { ret=lcar(CAR(arg_list)->Eval()); } break; 1809 ret = lcar(CAR(arg_list)->Eval()); 1810 break; 1812 1811 case SYS_FUNC_CDR: 1813 { ret=lcdr(CAR(arg_list)->Eval()); } break; 1812 ret = lcdr(CAR(arg_list)->Eval()); 1813 break; 1814 1814 case SYS_FUNC_LENGTH: 1815 1815 { 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 } 1828 1832 case SYS_FUNC_LIST: 1829 1833 { 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 } 1845 1851 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 } 1854 1862 case SYS_FUNC_QUOTE: 1855 ret=CAR(arg_list);1856 break;1863 ret = CAR(arg_list); 1864 break; 1857 1865 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; 1863 1870 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; 1869 1875 case SYS_FUNC_PLUS: 1870 1876 { 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 } 1880 1886 case SYS_FUNC_TIMES: 1881 1887 { 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 } 1908 1917 case SYS_FUNC_SLASH: 1909 1918 { 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 } 1931 1941 case SYS_FUNC_MINUS: 1932 1942 { 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 } 1943 1953 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; 1954 1965 case SYS_FUNC_SETQ: 1955 1966 case SYS_FUNC_SETF: 1956 1967 { 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)) 1969 1977 { 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) 1976 1997 { 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) 2007 2008 { 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"); 2010 2021 exit(0); 2011 2022 } 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); 2014 2028 #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 2019 2046 } 2020 2047 #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"); 2026 2054 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 } 2040 2059 case SYS_FUNC_SYMBOL_LIST: 2041 ret=NULL;2042 break;2060 ret = NULL; 2061 break; 2043 2062 case SYS_FUNC_ASSOC: 2044 2063 { 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 } 2051 2071 case SYS_FUNC_NOT: 2052 2072 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; 2055 2078 case SYS_FUNC_ACONS: 2056 2079 { 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 } 2065 2090 case SYS_FUNC_PAIRLIS: 2066 2091 { 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 } 2076 2102 case SYS_FUNC_LET: 2077 2103 { 2078 // make an a-list of new variable names and new values2079 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; 2087 2113 #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 value2103 //from the last block2104 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 values2112 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 stack2119 }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 } 2121 2147 case SYS_FUNC_DEFUN: 2122 2148 { 2123 LSymbol *symbol = (LSymbol *)CAR(arg_list);2149 LSymbol *symbol = (LSymbol *)CAR(arg_list); 2124 2150 #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)); 2140 2166 2141 2167 #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); 2145 2171 #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 } 2151 2178 case SYS_FUNC_ATOM: 2152 { ret=lisp_atom(CAR(arg_list)->Eval()); } 2179 ret = (LObject *)lisp_atom(CAR(arg_list)->Eval()); 2180 break; 2153 2181 case SYS_FUNC_AND: 2154 2182 { 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 } 2167 2198 case SYS_FUNC_OR: 2168 2199 { 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 } 2181 2215 case SYS_FUNC_PROGN: 2182 { ret=eval_block(arg_list); } break; 2216 ret = (LObject *)eval_block(arg_list); 2217 break; 2183 2218 case SYS_FUNC_CONCATENATE: 2184 ret=concatenate(arg_list);2185 break;2219 ret = (LObject *)concatenate(arg_list); 2220 break; 2186 2221 case SYS_FUNC_CHAR_CODE: 2187 2222 { 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 } 2205 2242 case SYS_FUNC_CODE_CHAR: 2206 2243 { 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 } 2217 2255 case SYS_FUNC_COND: 2218 2256 { 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 2225 2261 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 } 2233 2269 case SYS_FUNC_SELECT: 2234 2270 { 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 } 2252 2292 case SYS_FUNC_FUNCTION: 2253 ret = ((LSymbol *)CAR(arg_list)->Eval())->GetFunction();2254 break;2293 ret = ((LSymbol *)CAR(arg_list)->Eval())->GetFunction(); 2294 break; 2255 2295 case SYS_FUNC_MAPCAR: 2256 ret=mapcar(arg_list); 2296 ret = (LObject *)mapcar(arg_list); 2297 break; 2257 2298 case SYS_FUNC_FUNCALL: 2258 2299 { 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 } 2262 2304 case SYS_FUNC_GT: 2263 2305 { 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 } 2269 2311 case SYS_FUNC_LT: 2270 2312 { 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 } 2276 2318 case SYS_FUNC_GE: 2277 2319 { 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 } 2283 2325 case SYS_FUNC_LE: 2284 2326 { 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 } 2291 2332 case SYS_FUNC_TMP_SPACE: 2292 tmp_space();2293 ret=true_symbol;2294 break;2333 tmp_space(); 2334 ret = true_symbol; 2335 break; 2295 2336 case SYS_FUNC_PERM_SPACE: 2296 perm_space();2297 ret=true_symbol;2298 break;2337 perm_space(); 2338 ret = true_symbol; 2339 break; 2299 2340 case SYS_FUNC_SYMBOL_NAME: 2300 LSymbol *symb;2301 symb = (LSymbol *)CAR(arg_list)->Eval();2341 { 2342 LSymbol *symb = (LSymbol *)CAR(arg_list)->Eval(); 2302 2343 #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 } 2312 2354 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; 2318 2360 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; 2325 2369 case SYS_FUNC_DIGSTR: 2326 2370 { 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 } 2344 2387 case SYS_FUNC_LOCAL_LOAD: 2345 2388 case SYS_FUNC_LOAD: 2346 2389 case SYS_FUNC_COMPILE_FILE: 2347 2390 { 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) 2353 2399 { 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); 2367 2405 } 2368 2406 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) 2369 2425 { 2370 fp = open_file(st, "rb"); 2426 printf("Malloc error in load_script\n"); 2427 exit(0); 2371 2428 } 2372 2429 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 2374 2444 { 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); 2380 2454 } 2381 else 2455 #ifndef NO_LIBS 2456 if (stat_man) 2382 2457 { 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) 2386 2540 { 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); 2389 2544 } 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: 2498 2563 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; 2510 2565 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; 2515 2571 case SYS_FUNC_MOD: 2516 2572 { 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 2536 2600 case SYS_FUNC_FOR: 2537 2601 { 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 } 2568 2643 case SYS_FUNC_OPEN_FILE: 2569 2644 { 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 } 2591 2665 case SYS_FUNC_BIT_AND: 2592 2666 { 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 } 2601 2677 case SYS_FUNC_BIT_OR: 2602 2678 { 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 } 2611 2689 case SYS_FUNC_BIT_XOR: 2612 2690 { 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 } 2621 2701 case SYS_FUNC_MAKE_ARRAY: 2622 2702 { 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"); 2627 2809 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)) 2740 2834 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 } 2757 2852 case SYS_FUNC_GC: 2758 { 2759 collect_space(current_space); 2760 } break; 2853 collect_space(current_space); 2854 break; 2761 2855 case SYS_FUNC_SCHAR: 2762 2856 { 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 } 2773 2869 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; 2776 2873 case SYS_FUNC_NUM2STR: 2777 2874 { 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 } 2782 2880 case SYS_FUNC_NCONC: 2783 2881 { 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 } 2806 2915 case SYS_FUNC_FIRST: 2807 { ret=CAR(CAR(arg_list)->Eval()); } break; 2916 ret = CAR(CAR(arg_list)->Eval()); 2917 break; 2808 2918 case SYS_FUNC_SECOND: 2809 { ret=CAR(CDR(CAR(arg_list)->Eval())); } break; 2919 ret = CAR(CDR(CAR(arg_list)->Eval())); 2920 break; 2810 2921 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; 2812 2924 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; 2814 2927 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; 2816 2930 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; 2818 2933 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; 2820 2936 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; 2822 2939 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; 2824 2942 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; 2826 2945 case SYS_FUNC_SUBSTR: 2827 2946 { 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; 2862 2986 } 2863 2987 … … 2983 3107 } 2984 3108 3109 /* PtrRef check: OK */ 2985 3110 LObject *LObject::Eval() 2986 3111 { 2987 LObject *ret = NULL;2988 3112 PtrRef ref1(this); 2989 3113 … … 3002 3126 trace_level++; 3003 3127 } 3128 3129 LObject *ret = NULL; 3004 3130 3005 3131 if (this) -
abuse/trunk/src/lisp/lisp.h
r497 r498 143 143 struct LSysFunction : LObject 144 144 { 145 /* Methods */ 146 LObject *EvalFunction(LList *arg_list); 147 148 /* Members */ 145 149 short min_args, max_args; 146 150 short fun_number;
Note: See TracChangeset
for help on using the changeset viewer.
