diff --git a/ANNOUNCEMENT b/ANNOUNCEMENT index b325f88d9..cdb34aa08 100644 --- a/ANNOUNCEMENT +++ b/ANNOUNCEMENT @@ -1,4 +1,4 @@ -Announcement of ECL v0.7 +Announcement of ECL v0.7b ========================= ECL stands for Embeddable Common-Lisp. The ECL project is an effort to @@ -10,66 +10,106 @@ ECL is currently hosted at SourceForge. The home page of the project is http://ecls.sourceforge.net, and in it you will find source code releases, a CVS tree and an up to date documentation. -ECL 0.7 -======= +Notes for this release +====================== + +The names of many functions have changed. The global variables which +held pointers to symbols and keywords have disappeared. But the most +important change is the change on the calling conventions. Now there +are two types of C functions which the Lisp environment recognizes + +1) Functions with a fixed number of arguments + cl_object my_function(cl_object arg1, cl_object arg2) +They are passed to the lisp environment using cl_def_c_function() +and cl_make_cfun(). They take a fixed number of arguments and the +interpreter checks this for them + +2) Functions with optional and keyword arguments + cl_object my_function(int narg, ...) +They get a variable number of arguments, given by "narg". They should +check this and signal an error if needed. They are manipulated using +cl_def_c_function_va() and cl_make_cfun_va(). + +See below for a list of changes (And read src/h/external.h, +src/c/cfun.d, src/c/eval.d if you want :-) + +ECL 0.7b +======== * Errors fixed: - - When installing, ECL would not build all required directories. - - - Symbol BUILD-PROGRAM should be exported from package C. - - - In compiled code UNWIND-PROTECT would procted also the exit form, - resulting in an infinite loop when the exit form fails. + - SI::BC-DISASSEMBLE would not use Lisp streams for output. * System design: - - Global variables READsuppress, READdefault_float_format, - READtable, and READbase have been removed. The corresponding - special variables are used instead. + - Setting a (DECLARE (SI::C-LOCAL)) inside a function, we advise the + compiler to make it local to an object file and do not export it + for general use outside this file, neither as C code nor in Lisp. - - No need for function read_object_recursive(), since read_object() - is equivalent to it. + - New function cl_defvar() implements DEFVAR. - - Changed the algorithm of the list reader. A dot which is not - escaped is read as a symbol SI::. which is recognized by - LEFT-PARENTHESIS-READER. This avoids using global variables - "in_list_flag" and "dot_flag". - - - The calling conventions have been changed. SI::C-ARGUMENTS-LIMIT - and LAMBDA-PARAMETERS-LIMIT are both 64. Up to C-ARGUMENTS-LIMIT - may be passed to a function using C calling conventions. If the - function is to retrieve more arguments, (for instance through a - &rest variable), this can be done, but then the arguments have to - be pushed on the lisp stack. This method allows us to raise the - CALL-ARGUMENTS-LIMIT up to MOST-POSITIVE-FIXNUM. From a users - point of view, there is no visible change, excep the fact that a - function may receive more &optional, &key and &rest arguments. - - - The function apply() has been replaced with cl_apply_from_stack(). - The former took a pointer to the list of arguments. The latter - assumes that the last "narg" elements on the lisp stack are the - arguments of the function. + - Global variable si::*cblock* keeps a pointer to the descriptor of the + library being loaded (on systems which support DLLs). * Visible changes: - - New functions SI:SAFE-EVAL and cl_safe_eval() allow the user to - evaluate code with errors without jumping into the - debugger. Useful when embedding ECL in other programs. + - The C counterparts of the Lisp functions have now the prefix + cl_*. For instance, LIST-LENGTH is named cl_list_length(). There + are two types of functions. Those who take a fixed number of + arguments, are just called using C calling conventions: + cl_object form = c_string_to_object("(1 2 3 4)"); + cl_object l = cl_list_length(form); + But there are functions which take a variable number of arguments: + in this case, the first argument must be the total number of + arguments. For instance + cl_object form = cl_read(0); + or + cl_object form = cl_read(1, Cnil); - - New function SI:OPEN-UNIX-SOCKET-STREAM creates a two-way stream - attached to a unix socked (Unix sockets are pipes which programs - from the same computer may use to communicate with each other, and - they are either anonymous (not supported by ECL) or associated to - a file of the filesystem). + - Renamed functions MF() and MM() to cl_def_c_function(), + cl_def_c_function_va() and cl_def_c_macro_va(). Removed + make_function() and make_si_function(), which had a more limited + purpose. The *_va() functions take as argument a C function with + prototype + cl_object (*function)(int narg, ...) + which means that the function should accept any number of + arguments and signal an error when the number is incorrect. The + functions without *_va() suffix, take as argument a C function + with prototype + cl_object (*function)() + and an integer "narg" denoting the number of arguments that this + function actually receives. - - New function SI:LOOKUP-HOST-ENTRY encompasses the C calls - gethostbyname() and gethostbyaddress() and it is used to guess the - address, aliases and hostname of a machine in the Internet (Currently - we only support AF_INET protocol). + - Within the debugger, users are now able to evaluate expressions using the + lexical environment of the functions being debugged. Sample session: + > (defun foo (x) (cos x)) + FOO + > (foo 'a) + A is not of type NUMBER. + Broken at COS. + >> :b + Backtrace: COS > foo > eval + >> :p + Broken at FOO. + >> :v + Block names: FOO. + Local variables: + X: A + >> (return-from foo (cos 2.0)) + -0.4161468 + + - DISASSEMBLE can now either disassemble the bytecodes of an interpreted + function, or translate a lisp expression into C and show the result. + + - New program "ecl-config" outputs either the flags compile ("ecl-config -c") + or to link ("ecl-config -l") a program using the ECL library. + + - In compiled code, constants which are EQUALP are merged; that is, they + become EQ at run time. + + - cl_special_form_p() renamed to cl_special_operator_p(). * ANSI compatibility: - - READ and READ-PRESERVING-WHITESPACE behave the same when - RECURSIVE-P is NIL. Furthermore, EOF is detected when EOF-ERROR-P - is true, regardless of the value of RECURSIVE-P. + - DEFINE-SYMBOL-MACRO finally implemented. + diff --git a/src/CHANGELOG b/src/CHANGELOG index b16cd34b7..9d8f0291e 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1016,6 +1016,86 @@ ECL 0.7 RECURSIVE-P is NIL. Furthermore, EOF is detected when EOF-ERROR-P is true, regardless of the value of RECURSIVE-P. +ECL 0.7b +======== + +* Errors fixed: + + - SI::BC-DISASSEMBLE would not use Lisp streams for output. + +* System design: + + - Setting a (DECLARE (SI::C-LOCAL)) inside a function, we advise the + compiler to make it local to an object file and do not export it + for general use outside this file, neither as C code nor in Lisp. + + - New function cl_defvar() implements DEFVAR. + + - Global variable si::*cblock* keeps a pointer to the descriptor of the + library being loaded (on systems which support DLLs). + +* Visible changes: + + - The C counterparts of the Lisp functions have now the prefix + cl_*. For instance, LIST-LENGTH is named cl_list_length(). There + are two types of functions. Those who take a fixed number of + arguments, are just called using C calling conventions: + cl_object form = c_string_to_object("(1 2 3 4)"); + cl_object l = cl_list_length(form); + But there are functions which take a variable number of arguments: + in this case, the first argument must be the total number of + arguments. For instance + cl_object form = cl_read(0); + or + cl_object form = cl_read(1, Cnil); + + - Renamed functions MF() and MM() to cl_def_c_function(), + cl_def_c_function_va() and cl_def_c_macro_va(). Removed + make_function() and make_si_function(), which had a more limited + purpose. The *_va() functions take as argument a C function with + prototype + cl_object (*function)(int narg, ...) + which means that the function should accept any number of + arguments and signal an error when the number is incorrect. The + functions without *_va() suffix, take as argument a C function + with prototype + cl_object (*function)() + and an integer "narg" denoting the number of arguments that this + function actually receives. + + - Within the debugger, users are now able to evaluate expressions using the + lexical environment of the functions being debugged. Sample session: + > (defun foo (x) (cos x)) + FOO + > (foo 'a) + A is not of type NUMBER. + Broken at COS. + >> :b + Backtrace: COS > foo > eval + >> :p + Broken at FOO. + >> :v + Block names: FOO. + Local variables: + X: A + >> (return-from foo (cos 2.0)) + -0.4161468 + + - DISASSEMBLE can now either disassemble the bytecodes of an interpreted + function, or translate a lisp expression into C and show the result. + + - New program "ecl-config" outputs either the flags compile ("ecl-config -c") + or to link ("ecl-config -l") a program using the ECL library. + + - In compiled code, constants which are EQUALP are merged; that is, they + become EQ at run time. + + - cl_special_form_p() renamed to cl_special_operator_p(). + +* ANSI compatibility: + + - DEFINE-SYMBOL-MACRO finally implemented. + TODO: ===== diff --git a/src/Makefile.in b/src/Makefile.in index f3ab32dbd..fd2e4ac44 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -76,6 +76,7 @@ BUILD-STAMP: config.status install: BUILD-STAMP $(INSTALL) -d $(PREFIX)$(bindir) $(PREFIX)$(mandir) $(PREFIX)$(libdir)/h $(INSTALL_PROGRAM) -s $(TARGETS) $(PREFIX)$(bindir) + $(INSTALL_PROGRAM) ecl-config $(PREFIX)$(bindir) $(INSTALL_DATA) $(srcdir)/etc/ecl.1 $(PREFIX)$(mandir) $(INSTALL_DATA) BUILD-STAMP $(LSP_LIBRARIES) $(LIBRARIES) $(PREFIX)$(libdir) $(INSTALL_DATA) h/config.h $(PREFIX)$(libdir)/h @@ -90,7 +91,7 @@ installgc: uninstall: rm -rf $(mandir)/ecl.1 - rm -rf $(bindir)/ecl$(EXE) + for i in $(TARGETS) ecl-config; do rm -rf $(bindir)/$$i; done rm -rf $(libdir) cd doc; $(MAKE) uninstall diff --git a/src/aclocal.m4 b/src/aclocal.m4 index ac22e6ed3..1d8f9f727 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -109,7 +109,7 @@ configure___software_version=SOFTWARE_VERSION CPP=`eval "echo $CPP"` eval `${CPP} -D${host} ${tempcname} \ | grep 'configure___' \ - | sed -e 's/^configure___\([^=]*=\)[ ]*\(.*[^ ]\) */\1"\2"/'` + | sed -e 's/^configure___\([^=]*\)=[ ]*\(.*[^ ]\) */\1="$\1 \2"/'` rm ${tempcname} ] AC_MSG_CHECKING(for ld flags when building shared libraries) diff --git a/src/ansi-tests/hashlong.lisp b/src/ansi-tests/hashlong.lisp index b8999275f..fda4a9c22 100644 --- a/src/ansi-tests/hashlong.lisp +++ b/src/ansi-tests/hashlong.lisp @@ -18,6 +18,10 @@ (setf (symbol-function 'setf-gethash) (symbol-function 'sb-impl::%puthash)) t +#+ecl +(setf (symbol-function 'setf-gethash) + (symbol-function 'si::hash-set)) + (check-for-bug :hashlong-legacy-21 (defun symbole () (let ((b 0.) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 08ac7faee..3a7a5bd7e 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -28,7 +28,7 @@ libdir = @libdir@ HDIR = $(top_srcdir)/h HFILES = ../h/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h\ $(HDIR)/machines.h $(HDIR)/object.h $(HDIR)/cs.h $(HDIR)/stacks.h\ - $(HDIR)/external.h $(HDIR)/lisp_external.h $(HDIR)/eval.h\ + $(HDIR)/external.h $(HDIR)/eval.h\ $(HDIR)/number.h $(HDIR)/page.h $(HDIR)/unify.h\ $(HDIR)/lwp.h $(HDIR)/critical.h OBJS = main.o symbol.o package.o list.o\ @@ -71,8 +71,8 @@ $(DPP): $(srcdir)/dpp.c symbols_list2.h $(TRUE_CC) @CFLAGS@ -I../h -I./ -I$(HDIR) $(DEFS) $(srcdir)/dpp.c -o $@ symbols_list2.h: $(srcdir)/symbols_list.h Makefile cat $(srcdir)/symbols_list.h | \ - sed -e 's%{"\(.*\)",.*,.*,[ ]*NULL}%{"\1",NULL}%g' \ - -e 's%{"\(.*\)",.*,.*,[ ]*\(.*\)}%{"\1","\2"}%g' \ + sed -e 's%{"\(.*\)",.*,[ ]*NULL,.*}%{"\1",NULL}%g' \ + -e 's%{"\(.*\)",.*,[ ]*\(.*\),.*}%{"\1","\2"}%g' \ -e 's%{NULL.*%{NULL,NULL}};%' > $@ # @@ -88,8 +88,5 @@ apply.o: apply.c $(HFILES) $(HDIR)/cs.h # # These files are interrelated # -all_symbols.o: all_symbols.c symbols_def.h +all_symbols.o: all_symbols.c $(CC) $(CFLAGS) -I./ all_symbols.c -o $@ -symbols_def.h: $(srcdir)/symbols_list.h Makefile - cat $(srcdir)/symbols_list.h | grep '[ ]&' | \ - sed 's/^.* &\([a-zA-Z_0-9]*\),.*/cl_object \1;/g' > symbols_def.h diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 627660218..efdcb8dcc 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -10,7 +10,6 @@ #define KEYWORD 10 #define FORM_ORDINARY 16 -#include "symbols_def.h" #include "symbols_list.h" cl_index cl_num_symbols_in_core = 0; @@ -21,6 +20,7 @@ cl_index cl_num_symbols_in_core = 0; cl_object output; cl_object package; cl_object found = Cnil; + cl_object maxarg = MAKE_FIXNUM(-1); bool is_symbol; @ assert_type_symbol(symbol); @@ -38,7 +38,7 @@ cl_index cl_num_symbols_in_core = 0; output = @format(3, Cnil, make_constant_string("((cl_object)(cl_symbols+~A))"), MAKE_FIXNUM(p)); - @(return found output) + @(return found output maxarg) } } else { cl_object fun; @@ -50,6 +50,7 @@ cl_index cl_num_symbols_in_core = 0; if (fun == SYM_FUN(s)) { symbol = s; found = Ct; + maxarg = MAKE_FIXNUM(fun->cfun.narg); break; } } @@ -71,7 +72,7 @@ cl_index cl_num_symbols_in_core = 0; l-= 2; source++; } else if (!is_symbol) { - c = 'L'; + c = '_'; } else if (package == keyword_package) { c = 'K'; } else { @@ -112,7 +113,7 @@ cl_index cl_num_symbols_in_core = 0; } else if (c == ':') { c = 'X'; } else { - @(return Cnil Cnil) + @(return Cnil Cnil maxarg) } *(dest++) = c; output->string.fillp++; @@ -122,12 +123,12 @@ cl_index cl_num_symbols_in_core = 0; *(dest++) = '\0'; if (!Null(package)) output = @si::string-concatenate(2,package,output); - @(return found output) + @(return found output maxarg) @) static void -make_this_symbol(int i, cl_object s, int code, const char *name, cl_object *loc, - cl_objectfn fun) +make_this_symbol(int i, cl_object s, int code, const char *name, + cl_objectfn fun, int narg) { enum stype stp; cl_object package; @@ -157,24 +158,25 @@ make_this_symbol(int i, cl_object s, int code, const char *name, cl_object *loc, sethash(s->symbol.name, package->pack.external, s); SYM_VAL(s) = s; } else { - cl_import(s, package); - cl_export(s, package); + cl_import2(s, package); + cl_export2(s, package); } - if (loc != NULL) - *loc = s; if (code == FORM_ORDINARY) s->symbol.isform = TRUE; - else if (fun != NULL) - SYM_FUN(s) = make_cfun(fun, s, NULL); + else if (fun != NULL) { + cl_object f = cl_make_cfun_va(fun, s, NULL); + SYM_FUN(s) = f; + f->cfun.narg = narg; + } cl_num_symbols_in_core = i + 1; } void init_all_symbols(void) { - int i, code; + int i, code, narg; const char *name; - cl_object s, *loc; + cl_object s; cl_objectfn fun; /* We skip NIL and T */ @@ -182,8 +184,8 @@ init_all_symbols(void) s = (cl_object)(cl_symbols + i); code = cl_symbols[i].init.type; name = cl_symbols[i].init.name; - loc = cl_symbols[i].init.loc; fun = (cl_objectfn)cl_symbols[i].init.fun; - make_this_symbol(i, s, code, name, loc, fun); + narg = cl_symbols[i].init.narg; + make_this_symbol(i, s, code, name, fun, narg); } } diff --git a/src/c/alloc.d b/src/c/alloc.d index b6d4c6ae7..57184c376 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -719,7 +719,7 @@ static int t_from_type(cl_object type) { int t; - type = coerce_to_string(type); + type = cl_string(type); for (t = (int)t_start ; t < (int)t_end ; t++) { struct typemanager *tm = &tm_table[t]; if (tm->tm_name && diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 6931a769b..25f52caa7 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -14,6 +14,8 @@ #include "ecl.h" #include "page.h" +#include "gc.h" +#include "private/gc_priv.h" #ifdef GBC_BOEHM @@ -45,8 +47,14 @@ cl_alloc_object(cl_type t) } tm = tm_of(t); - start_critical_section(); + start_critical_section(); +#if 0 obj = (cl_object)GC_malloc(tm->tm_size); +#else + obj = (cl_object)GC_malloc_explicitly_typed + (tm->tm_size & ~GC_DS_BITMAP, + tm->tm_size); +#endif obj->d.t = t; /* GC_malloc already resets objects */ end_critical_section(); @@ -157,13 +165,18 @@ init_tm(cl_type t, char *name, cl_index elsize) static int alloc_initialized = FALSE; +static void (*old_GC_push_other_roots)(); + void init_alloc(void) { + static void stacks_scanner(); + if (alloc_initialized) return; alloc_initialized = TRUE; GC_no_dls = 1; + GC_init_explicit_typing(); init_tm(t_shortfloat, "SHORT-FLOAT", /* 8 */ sizeof(struct shortfloat_struct)); @@ -198,6 +211,34 @@ init_alloc(void) init_tm(t_cont, "CONT", sizeof(struct cont)); init_tm(t_thread, "THREAD", sizeof(struct thread)); #endif /* THREADS */ + + old_GC_push_other_roots = GC_push_other_roots; + GC_push_other_roots = stacks_scanner; +} + +/********************************************************** + * GARBAGE COLLECTOR * + **********************************************************/ + +static void +stacks_scanner(void) +{ + if (cl_stack) { + GC_push_conditional(cl_stack, cl_stack_top,1); + GC_set_mark_bit(cl_stack); + } + if (frs_top && (frs_top >= frs_org)) { + GC_push_conditional(frs_org, frs_top+1,1); + GC_set_mark_bit(frs_org); + } + if (bds_top && (bds_top >= bds_org)) { + GC_push_conditional(bds_org, bds_top+1,1); + GC_set_mark_bit(bds_top); + } + if (NValues) + GC_push_all(Values, Values+NValues+1); + if (old_GC_push_other_roots) + (*old_GC_push_other_roots)(); } /********************************************************** diff --git a/src/c/apply.d b/src/c/apply.d index 334559b6e..c22e4aeb2 100644 --- a/src/c/apply.d +++ b/src/c/apply.d @@ -656,3 +656,320 @@ APPLY_closure(int n, cl_objectfn fn, cl_object cl, cl_object *x) /* Arguments above 64 have been pushed on the stack */ } } + +cl_object +APPLY_fixed(int n, cl_object (*fn)(), cl_object *x) +{ + switch (n) { + case 0: return (*fn)(); + case 1: return (*fn)(x[0]); + case 2: return (*fn)(x[0],x[1]); + case 3: return (*fn)(x[0],x[1],x[2]); + case 4: return (*fn)(x[0],x[1],x[2],x[3]); + case 5: return (*fn)(x[0],x[1],x[2],x[3],x[4]); + case 6: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5]); + case 7: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6]); + case 8: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]); + case 9: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8]); + case 10: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9]); + case 11: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10]); + case 12: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11]); + case 13: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12]); + case 14: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13]); + case 15: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14]); + case 16: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15]); + case 17: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16]); + case 18: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17]); + case 19: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18]); + case 20: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19]); + case 21: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20]); + case 22: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21]); + case 23: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22]); + case 24: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23]); + case 25: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24]); + case 26: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25]); + case 27: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26]); + case 28: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27]); + case 29: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28]); + case 30: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29]); + case 31: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30]); + case 32: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31]); + case 33: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32]); + case 34: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33]); + case 35: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34]); + case 36: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35]); + case 37: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36]); + case 38: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37]); + case 39: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38]); + case 40: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39]); + case 41: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40]); + case 42: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41]); + case 43: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42]); + case 44: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43]); + case 45: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44]); + case 46: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45]); + case 47: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46]); + case 48: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47]); + case 49: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48]); + case 50: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49]); + case 51: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50]); + case 52: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51]); + case 53: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52]); + case 54: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53]); + case 55: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54]); + case 56: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55]); + case 57: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56]); + case 58: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57]); + case 59: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58]); + case 60: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59]); + case 61: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60]); + case 62: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61]); + case 63: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + x[8],x[9],x[10],x[11],x[12],x[13],x[14], + x[15],x[16],x[17],x[18],x[19],x[20],x[21], + x[22],x[23],x[24],x[25],x[26],x[27],x[28], + x[29],x[30],x[31],x[32],x[33],x[34],x[35], + x[36],x[37],x[38],x[39],x[40],x[41],x[42], + x[43],x[44],x[45],x[46],x[47],x[48],x[49], + x[50],x[51],x[52],x[53],x[54],x[55],x[56], + x[57],x[58],x[59],x[60],x[61],x[62]); + default: + FEerror("Too many arguments", 0); + } +} diff --git a/src/c/array.d b/src/c/array.d index 0ba4421a1..829a05089 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -41,19 +41,19 @@ object_to_index(cl_object n) } } -@(defun row-major-aref (x indx) - cl_index j; -@ - j = fixnnint(indx); - @(return aref(x, j)) -@) +cl_object +cl_row_major_aref(cl_object x, cl_object indx) +{ + cl_index j = fixnnint(indx); + @(return aref(x, j)) +} -@(defun si::row-major-aset (x indx val) - cl_index j; -@ - j = fixnnint(indx); - @(return aset(x, j, val)) -@) +cl_object +si_row_major_aset(cl_object x, cl_object indx, cl_object val) +{ + cl_index j = fixnnint(indx); + @(return aset(x, j, val)) +} @(defun aref (x &rest indx) cl_index r, s, i, j; @@ -307,11 +307,14 @@ aset1(cl_object v, cl_index index, cl_object val) (si:make-vector element-type dimension adjustable fill-pointer displaced-to displaced-index-offset) */ -@(defun si::make_vector (etype dim adj fillp displ disploff) +cl_object +si_make_vector(cl_object etype, cl_object dim, cl_object adj, + cl_object fillp, cl_object displ, cl_object disploff) +{ cl_index d, f; cl_object x; cl_elttype aet; -@ + aet = get_elttype(etype); if ((d = fixnnint(dim)) > ADIMLIM) FEerror("The vector dimension, ~D, is too large.", 1, dim); @@ -346,7 +349,7 @@ aset1(cl_object v, cl_index index, cl_object val) else displace(x, displ, disploff); @(return x) -@) +} void array_allocself(cl_object x) @@ -477,9 +480,11 @@ array_address(cl_object x, cl_index inc) } } -@(defun array_element_type (a) +cl_object +cl_array_element_type(cl_object a) +{ cl_object output; -@ + switch (array_elttype(a)) { case aet_object: output = Ct; break; case aet_ch: output = @'base-char'; break; @@ -491,7 +496,7 @@ array_address(cl_object x, cl_index inc) case aet_i8: output = @'integer8'; break; } @(return output) -@) +} /* Displace(from, to, offset) displaces the from-array @@ -598,16 +603,19 @@ array_elttype(cl_object x) } } -@(defun array_rank (a) -@ +cl_object +cl_array_rank(cl_object a) +{ assert_type_array(a); @(return ((type_of(a) == t_array) ? MAKE_FIXNUM(a->array.rank) : MAKE_FIXNUM(1))) -@) +} -@(defun array_dimension (a index) +cl_object +cl_array_dimension(cl_object a, cl_object index) +{ cl_index i, dim; -@ + i = fixnnint(index); switch (type_of(a)) { case t_array: @@ -631,32 +639,37 @@ ILLEGAL: FEerror("~S is an illegal axis-number to the array ~S.", FEwrong_type_argument(@'array', a); } @(return MAKE_FIXNUM(dim)) -@) +} -@(defun array_total_size (a) -@ +cl_object +cl_array_total_size(cl_object a) +{ assert_type_array(a); @(return MAKE_FIXNUM(a->array.dim)) -@) +} -@(defun adjustable_array_p (a) -@ +cl_object +cl_adjustable_array_p(cl_object a) +{ assert_type_array(a); @(return (a->array.adjustable ? Ct : Cnil)) -@) +} /* Internal function for checking if an array is displaced. */ -@(defun si::displaced_array_p (a) -@ +cl_object +si_displaced_array_p(cl_object a) +{ assert_type_array(a); @(return ((CAR(a->array.displaced) != Cnil) ? Ct : Cnil)) -@) +} -@(defun svref (x index) +cl_object +cl_svref(cl_object x, cl_object index) +{ cl_index i; -@ + if (type_of(x) != t_vector || x->vector.adjustable || x->vector.hasfillp || @@ -666,11 +679,13 @@ ILLEGAL: FEerror("~S is an illegal axis-number to the array ~S.", if ((i = fixnnint(index)) >= x->vector.dim) illegal_index(x, index); @(return x->vector.self.t[i]) -@) +} -@(defun si::svset (x index v) +cl_object +si_svset(cl_object x, cl_object index, cl_object v) +{ cl_index i; -@ + if (type_of(x) != t_vector || x->vector.adjustable || x->vector.hasfillp || @@ -680,11 +695,13 @@ ILLEGAL: FEerror("~S is an illegal axis-number to the array ~S.", if ((i = fixnnint(index)) >= x->vector.dim) illegal_index(x, index); @(return (x->vector.self.t[i] = v)) -@) +} -@(defun array_has_fill_pointer_p (a) +cl_object +cl_array_has_fill_pointer_p(cl_object a) +{ cl_object r; -@ + switch (type_of(a)) { case t_array: r = Cnil; break; @@ -697,22 +714,25 @@ ILLEGAL: FEerror("~S is an illegal axis-number to the array ~S.", FEwrong_type_argument(@'array', a); } @(return r) -@) +} -@(defun fill_pointer (a) -@ +cl_object +cl_fill_pointer(cl_object a) +{ assert_type_vector(a); if (a->vector.hasfillp) @(return MAKE_FIXNUM(a->vector.fillp)) FEerror("The vector ~S has no fill pointer.", 1, a); -@) +} /* Internal function for setting fill pointer. */ -@(defun si::fill_pointer_set (a fp) +cl_object +si_fill_pointer_set(cl_object a, cl_object fp) +{ cl_index i; -@ + assert_type_vector(a); i = fixnnint(fp); if (a->vector.hasfillp) @@ -723,7 +743,7 @@ ILLEGAL: FEerror("~S is an illegal axis-number to the array ~S.", else FEerror("The vector ~S has no fill pointer.", 1, a); @(return fp) -@) +} /* Internal function for replacing the contents of arrays: @@ -732,10 +752,12 @@ ILLEGAL: FEerror("~S is an illegal axis-number to the array ~S.", Used in ADJUST-ARRAY. */ -@(defun si::replace_array (olda newa) +cl_object +si_replace_array(cl_object olda, cl_object newa) +{ cl_object displaced, dlist; ptrdiff_t diff; -@ + if (type_of(olda) != type_of(newa) || (type_of(olda) == t_array && olda->array.rank != newa->array.rank)) goto CANNOT; @@ -765,7 +787,7 @@ ILLEGAL: FEerror("~S is an illegal axis-number to the array ~S.", CANNOT: FEerror("Cannot replace the array ~S by the array ~S.", 2, olda, newa); -@) +} void init_array(void) diff --git a/src/c/assignment.d b/src/c/assignment.d index fa2eb4e00..72a947da6 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -18,20 +18,15 @@ #include cl_object -set(cl_object var, cl_object val) +cl_set(cl_object var, cl_object val) { if (!SYMBOLP(var)) FEtype_error_symbol(var); if (var->symbol.stype == stp_constant) FEinvalid_variable("Cannot assign to the constant ~S.", var); - return (SYM_VAL(var) = val); + return1(SYM_VAL(var) = val); } -@(defun set (var val) -@ - @(return set(var, val)) -@) - cl_object setf_namep(cl_object fun_spec) { cl_object cdr; @@ -53,12 +48,14 @@ setf_namep(cl_object fun_spec) } else return(OBJNULL); } -@(defun si::setf_namep (arg) +cl_object +si_setf_namep(cl_object arg) +{ cl_object x; -@ + x = setf_namep(arg); @(return ((x != OBJNULL) ? x : Cnil)) -@) +} @(defun si::fset (fun def &optional macro pprint) cl_type t; @@ -101,18 +98,20 @@ setf_namep(cl_object fun_spec) @(return fun) @) -@(defun makunbound (sym) -@ +cl_object +cl_makunbound(cl_object sym) +{ if (!SYMBOLP(sym)) FEtype_error_symbol(sym); if ((enum stype)sym->symbol.stype == stp_constant) FEinvalid_variable("Cannot unbind the constant ~S.", sym); SYM_VAL(sym) = OBJNULL; @(return sym) -@) +} -@(defun fmakunbound (sym) -@ +cl_object +cl_fmakunbound(cl_object sym) +{ if (!SYMBOLP(sym)) { cl_object sym1 = setf_namep(sym); if (sym1 == OBJNULL) @@ -121,7 +120,7 @@ setf_namep(cl_object fun_spec) remprop(sym, @'si::setf-lambda'); remprop(sym, @'si::setf-method'); remprop(sym, @'si::setf-update'); - @fmakunbound(1, sym1); + cl_fmakunbound(sym1); @(return sym) } if (sym->symbol.isform) { @@ -140,20 +139,21 @@ setf_namep(cl_object fun_spec) SYM_FUN(sym) = OBJNULL; sym->symbol.mflag = FALSE; @(return sym) -@) +} void clear_compiler_properties(cl_object sym) { - @si::unlink-symbol(1, sym); + si_unlink_symbol(sym); if (symbol_value(@'si::*inhibit-macro-special*') != Cnil) (void)funcall(2, @'si::clear-compiler-properties', sym); } -@(defun si::clear_compiler_properties (sym) -@ +cl_object +si_clear_compiler_properties(cl_object sym) +{ @(return sym) -@) +} #ifdef PDE void diff --git a/src/c/backq.d b/src/c/backq.d index 980563857..25ade547d 100644 --- a/src/c/backq.d +++ b/src/c/backq.d @@ -283,7 +283,7 @@ static @(return backq(in)) @) -#define make_cf(f) make_cfun((f), Cnil, NULL); +#define make_cf(f) cl_make_cfun_va((f), Cnil, NULL); void init_backq(void) diff --git a/src/c/cfun.d b/src/c/cfun.d index e14401a3e..063921d94 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -18,7 +18,7 @@ #include /* for memmove() */ cl_object -make_cfun(cl_objectfn self, cl_object name, cl_object cblock) +cl_make_cfun(cl_object (*self)(), cl_object name, cl_object cblock, int narg) { cl_object cf; @@ -26,11 +26,27 @@ make_cfun(cl_objectfn self, cl_object name, cl_object cblock) cf->cfun.entry = self; cf->cfun.name = name; cf->cfun.block = cblock; + cf->cfun.narg = narg; + if (narg < 0 || narg >= C_ARGUMENTS_LIMIT) + FEprogram_error("cl_make_cfun: function requires too many arguments.",0); return(cf); } cl_object -make_cclosure(cl_objectfn self, cl_object env, cl_object block) +cl_make_cfun_va(cl_objectfn self, cl_object name, cl_object cblock) +{ + cl_object cf; + + cf = cl_alloc_object(t_cfun); + cf->cfun.entry = self; + cf->cfun.name = name; + cf->cfun.block = cblock; + cf->cfun.narg = -1; + return(cf); +} + +cl_object +cl_make_cclosure_va(cl_objectfn self, cl_object env, cl_object block) { cl_object cc; @@ -42,25 +58,19 @@ make_cclosure(cl_objectfn self, cl_object env, cl_object block) } void -MF(cl_object sym, cl_objectfn self, cl_object block) +cl_def_c_function(cl_object sym, cl_object (*self)(), int narg) { - cl_object cf; - if (!SYMBOLP(sym)) FEtype_error_symbol(sym); if (sym->symbol.isform && sym->symbol.mflag) sym->symbol.isform = FALSE; clear_compiler_properties(sym); - cf = cl_alloc_object(t_cfun); - cf->cfun.entry = self; - cf->cfun.name = sym; - cf->cfun.block = block; - SYM_FUN(sym) = cf; + SYM_FUN(sym) = cl_make_cfun(self, sym, symbol_value(@'si::*cblock*'), narg); sym->symbol.mflag = FALSE; } void -MM(cl_object sym, cl_objectfn self, cl_object block) +cl_def_c_macro_va(cl_object sym, cl_objectfn self) { cl_object cf; @@ -72,39 +82,27 @@ MM(cl_object sym, cl_objectfn self, cl_object block) #ifdef PDE record_source_pathname(sym, @'defmacro'); #endif - cf = cl_alloc_object(t_cfun); - cf->cfun.entry = self; - cf->cfun.name = sym; - cf->cfun.block = block; - SYM_FUN(sym) = cf; + SYM_FUN(sym) = cl_make_cfun_va(self, sym, symbol_value(@'si::*cblock*')); sym->symbol.mflag = TRUE; } -cl_object -make_function(const char *s, cl_objectfn f) +void +cl_def_c_function_va(cl_object sym, cl_objectfn self) { - cl_object x; - - x = make_ordinary(s); - SYM_FUN(x) = make_cfun(f, x, NULL); - x->symbol.mflag = FALSE; - return(x); + if (!SYMBOLP(sym)) + FEtype_error_symbol(sym); + if (sym->symbol.isform && sym->symbol.mflag) + sym->symbol.isform = FALSE; + clear_compiler_properties(sym); + SYM_FUN(sym) = cl_make_cfun_va(self, sym, symbol_value(@'si::*cblock*')); + sym->symbol.mflag = FALSE; } cl_object -make_si_function(const char *s, cl_objectfn f) +si_compiled_function_name(cl_object fun) { - cl_object x; - - x = make_si_ordinary(s); - SYM_FUN(x) = make_cfun(f, x, NULL); - x->symbol.mflag = FALSE; - return(x); -} - -@(defun si::compiled_function_name (fun) cl_object output; -@ + switch(type_of(fun)) { case t_bytecodes: output = fun->bytecodes.data[0]; break; @@ -116,11 +114,13 @@ make_si_function(const char *s, cl_objectfn f) FEerror("~S is not a compiled-function.", 1, fun); } @(return output) -@) +} -@(defun si::compiled_function_source (fun) +cl_object +si_compiled_function_source(cl_object fun) +{ cl_object output; -@ + switch(type_of(fun)) { case t_bytecodes: if (!Null(fun->bytecodes.lex)) @@ -137,11 +137,13 @@ make_si_function(const char *s, cl_objectfn f) FEerror("~S is not a compiled-function.", 1, fun); } @(return output) -@) +} -@(defun si::compiled_function_block (fun) +cl_object +si_compiled_function_block(cl_object fun) +{ cl_object output; -@ + switch(type_of(fun)) { case t_cfun: output = fun->cfun.block; break; @@ -151,4 +153,4 @@ make_si_function(const char *s, cl_objectfn f) FEerror("~S is not a compiled-function.", 1, fun); } @(return output) -@) +} diff --git a/src/c/character.d b/src/c/character.d index 7db031b46..d3d68f7b7 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -39,60 +39,62 @@ char_code(cl_object c) FEtype_error_character(c); } -@(defun standard_char_p (c) - cl_fixnum i; -@ +cl_object +cl_standard_char_p(cl_object c) +{ /* INV: char_code() checks the type */ - i = char_code(c); + cl_fixnum i = char_code(c); if ((' ' <= i && i < '\177') || i == '\n') - @(return Ct) - @(return Cnil) -@) + return1(Ct); + return1(Cnil); +} -@(defun graphic_char_p (c) - cl_fixnum i; -@ +cl_object +cl_graphic_char_p(cl_object c) +{ /* INV: char_code() checks the type */ - i = char_code(c); + cl_fixnum i = char_code(c); if (' ' <= i && i < '\177') /* ' ' < '\177' ??? Beppe*/ - @(return Ct) - @(return Cnil) -@) + return1(Ct); + return1(Cnil); +} -@(defun alpha_char_p (c) - cl_fixnum i; -@ +cl_object +cl_alpha_char_p(cl_object c) +{ /* INV: char_code() checks the type */ - i = char_code(c); + cl_fixnum i = char_code(c); if (isalpha(i)) - @(return Ct) + return1(Ct); else - @(return Cnil) -@) + return1(Cnil); +} -@(defun upper_case_p (c) -@ +cl_object +cl_upper_case_p(cl_object c) +{ /* INV: char_code() checks the type */ if (isupper(char_code(c))) - @(return Ct) - @(return Cnil) -@) + return1(Ct); + return1(Cnil); +} -@(defun lower_case_p (c) -@ +cl_object +cl_lower_case_p(cl_object c) +{ /* INV: char_code() checks the type */ if (islower(char_code(c))) - @(return Ct) - @(return Cnil) -@) + return1(Ct); + return1(Cnil); +} -@(defun both_case_p (c) - cl_fixnum code; -@ +cl_object +cl_both_case_p(cl_object c) +{ /* INV: char_code() checks the type */ - code = char_code(c); - @(return ((isupper(code) || islower(code)) ? Ct : Cnil)) -@) + cl_fixnum code = char_code(c); + return1((isupper(code) || islower(code)) ? Ct : Cnil); +} #define basep(d) (d <= 36) @@ -125,16 +127,13 @@ digitp(int i, int r) return(-1); } -@(defun alphanumericp (c) - cl_fixnum i; -@ +cl_object +cl_alphanumericp(cl_object c) +{ /* INV: char_code() checks type of `c' */ - i = char_code(c); - if (isalnum(i)) - @(return Ct) - else - @(return Cnil) -@) + cl_fixnum i = char_code(c); + return1(isalnum(i)? Ct : Cnil); +} @(defun char= (c &rest cs) @ @@ -317,10 +316,11 @@ char_compare(cl_object x, cl_object y) @) -@(defun character (x) -@ - @(return coerce_to_character(x)) -@) +cl_object +cl_character(cl_object x) +{ + return1(coerce_to_character(x)); +} cl_object coerce_to_character(cl_object x) @@ -338,42 +338,45 @@ coerce_to_character(cl_object x) } } -@(defun char_code (c) -@ +cl_object +cl_char_code(cl_object c) +{ /* INV: char_code() checks the type of `c' */ - @(return MAKE_FIXNUM(char_code(c))) -@) + return1(MAKE_FIXNUM(char_code(c))); +} -@(defun code_char (c) +cl_object +cl_code_char(cl_object c) +{ cl_fixnum fc; -@ + /* INV: fixnnint() checks the type of `c' */ if (type_of(c) == t_bignum) - @(return Cnil) + return1(Cnil); if ((fc = fixnnint(c)) >= CHAR_CODE_LIMIT) - @(return Cnil) - @(return CODE_CHAR(fc)) -@) + return1(Cnil); + return1(CODE_CHAR(fc)); +} -@(defun char_upcase (c) - cl_fixnum code; -@ +cl_object +cl_char_upcase(cl_object c) +{ /* INV: char_code() checks the type of `c' */ - code = char_code(c); - @(return (islower(char_code(c)) ? - CODE_CHAR(toupper(char_code(c))) : - c)) -@) + cl_fixnum code = char_code(c); + return1(islower(char_code(c)) ? + CODE_CHAR(toupper(char_code(c))) : + c); +} -@(defun char_downcase (c) - cl_fixnum code; -@ +cl_object +cl_char_downcase(cl_object c) +{ /* INV: char_code() checks the type of `c' */ - code = char_code(c); - @(return (isupper(char_code(c)) ? - CODE_CHAR(tolower(char_code(c))) : - c)) -@) + cl_fixnum code = char_code(c); + return1(isupper(char_code(c)) ? + CODE_CHAR(tolower(char_code(c))) : + c); +} @(defun digit_char (w &optional (r MAKE_FIXNUM(10))) int dw; @@ -398,48 +401,53 @@ digit_weight(int w, int r) return(w - 10 + 'A'); } -@(defun char_int (c) -@ +cl_object +cl_char_int(cl_object c) +{ /* INV: char_code() checks the type of `c' */ - @(return MAKE_FIXNUM(char_code(c))) -@) + return1(MAKE_FIXNUM(char_code(c))); +} -@(defun int_char (x) -@ +cl_object +cl_int_char(cl_object x) +{ /* INV: fixnnint(x) checks the type of `c' */ if (type_of(x) == t_bignum) - @(return Cnil) - @(return CODE_CHAR(fixnnint(x))) -@) + return1(Cnil); + return1(CODE_CHAR(fixnnint(x))); +} -@(defun char_name (c) -@ +cl_object +cl_char_name(cl_object c) +{ /* INV: char_code() checks the type of `c' */ switch (char_code(c)) { case '0': - @(return STnull) + return1(STnull); case '\r': - @(return STreturn) + return1(STreturn); case ' ': - @(return STspace) + return1(STspace); case '\177': - @(return STrubout) + return1(STrubout); case '\f': - @(return STpage) + return1(STpage); case '\t': - @(return STtab) + return1(STtab); case '\b': - @(return STbackspace) + return1(STbackspace); case '\n': - @(return STnewline) + return1(STnewline); } - @(return Cnil) -@) + return1(Cnil); +} -@(defun name_char (s) +cl_object +cl_name_char(cl_object s) +{ char c; -@ - s = coerce_to_string(s); + + s = cl_string(s); if (string_equal(s, STreturn)) c = '\r'; else if (string_equal(s, STspace)) @@ -456,9 +464,9 @@ digit_weight(int w, int r) c = '\n'; else if (string_equal(s, STnull)) c = '\000'; else - @(return Cnil) - @(return CODE_CHAR(c)) -@) + return1(Cnil); + return1(CODE_CHAR(c)); +} void init_character(void) diff --git a/src/c/cinit.d b/src/c/cinit.d index 60f19f464..e86023248 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -15,11 +15,11 @@ #include "ecl.h" -static -@(defun si::simple_toplevel () +static cl_object si_simple_toplevel () +{ cl_object sentence; cl_object lex_old = lex_env; -@ + /* Simple minded top level loop */ printf(";*** Lisp core booted ****\nECLS (Embeddable Common Lisp) %d pages\n", MAXPAGE); fflush(stdout); @@ -39,11 +39,13 @@ static #endif } lex_env = lex_old; -@) +} int main(int argc, char **args) { + cl_object top_level; + /* This should be always the first call */ cl_boot(argc, args); @@ -58,9 +60,9 @@ main(int argc, char **args) #ifdef CLX SYM_VAL(@'*features*') = CONS(make_keyword("WANTS-CLX"), SYM_VAL(@'*features*')); #endif - make_si_function("TOP-LEVEL", (cl_objectfn)@si::simple-toplevel); - - funcall(1, _intern("TOP-LEVEL", system_package)); + top_level = _intern("TOP-LEVEL", system_package); + cl_def_c_function(top_level, si_simple_toplevel, 0); + funcall(1, top_level); return(0); } diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index 93fd6ae4d..4b6076602 100644 --- a/src/c/cmpaux.d +++ b/src/c/cmpaux.d @@ -21,11 +21,12 @@ #define CHAR_BIT (sizeof(char)*8) #endif -@(defun si::specialp (sym) -@ +cl_object +si_specialp(cl_object sym) +{ @(return ((SYMBOLP(sym) && sym->symbol.stype == stp_special) ? Ct : Cnil)) -@) +} int ifloor(int x, int y) @@ -280,7 +281,7 @@ void init_cmpaux(void) { SYM_VAL(@'LAMBDA-LIST-KEYWORDS') = - list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', @'&aux', + cl_list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', @'&aux', @'&whole', @'&environment', @'&body'); SYM_VAL(@'LAMBDA-PARAMETERS-LIMIT') = MAKE_FIXNUM(LAMBDA_PARAMETERS_LIMIT); diff --git a/src/c/compiler.d b/src/c/compiler.d index d0fd10234..ef75dc60b 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -331,31 +331,23 @@ FEill_formed_input() FEprogram_error("Unproper list handled to the compiler.", 0); } -static void -c_new_env() -{ - c_env.variables = Cnil; - c_env.macros = Cnil; - c_env.lexical_level = 0; -} - static void c_register_block(cl_object name) { - c_env.variables = CONS(list(2, @':block', name), c_env.variables); + c_env.variables = CONS(cl_list(2, @':block', name), c_env.variables); } static void c_register_tags(cl_object all_tags) { - c_env.variables = CONS(list(2, @':tag', all_tags), c_env.variables); + c_env.variables = CONS(cl_list(2, @':tag', all_tags), c_env.variables); } static void c_register_function(cl_object name) { - c_env.variables = CONS(list(2, @':function', name), c_env.variables); - c_env.macros = CONS(list(2, name, @'function'), c_env.macros); + c_env.variables = CONS(cl_list(2, @':function', name), c_env.variables); + c_env.macros = CONS(cl_list(2, name, @'function'), c_env.macros); } static cl_object @@ -367,23 +359,48 @@ c_macro_expand1(cl_object stmt) static void c_register_symbol_macro(cl_object name, cl_object exp_fun) { - c_env.variables = CONS(list(3, name, @'si::symbol-macro', exp_fun), + c_env.variables = CONS(cl_list(3, name, @'si::symbol-macro', exp_fun), c_env.variables); } static void c_register_macro(cl_object name, cl_object exp_fun) { - c_env.macros = CONS(list(3, name, @'macro', exp_fun), c_env.macros); + c_env.macros = CONS(cl_list(3, name, @'macro', exp_fun), c_env.macros); } static void c_register_var(register cl_object var, bool special) { - c_env.variables = CONS(list(2, var, special? @'special' : Cnil), + c_env.variables = CONS(cl_list(2, var, special? @'special' : Cnil), c_env.variables); } +static void +c_new_env(cl_object env) +{ + c_env.variables = Cnil; + c_env.macros = Cnil; + if (Null(env)) { + c_env.lexical_level = 0; + return; + } + c_env.lexical_level = 1; + for (env = @revappend(2, env, Cnil); !Null(env); env = CDDR(env)) + { + cl_object tag = CADR(env); + cl_object what = CAR(env); + if (tag == @':tag') + c_register_tags(Cnil); + else if (tag == @':block') + c_register_block(CAR(what)); + else if (tag == @':function') + c_register_function(CAR(what)); + else + c_register_var(tag, FALSE); + } +} + static cl_object c_tag_ref(cl_object the_tag, cl_object the_type) { @@ -879,7 +896,7 @@ c_do_doa(int op, cl_object args) { /* Compile stepping clauses */ if (length(stepping) == 1) op = OP_BIND; - for (vars = Cnil, stepping=nreverse(stepping); !endp(stepping); ) { + for (vars = Cnil, stepping=cl_nreverse(stepping); !endp(stepping); ) { cl_object pair = pop(&stepping); cl_object var = CAR(pair); cl_object value = CDR(pair); @@ -1223,7 +1240,7 @@ c_let_leta(int op, cl_object args) { cl_object bindings, specials, body, l, vars; cl_object old_variables = c_env.variables; - bindings = car(args); + bindings = cl_car(args); body = c_process_declarations(CDR(args)); specials = VALUES(3); @@ -1336,7 +1353,7 @@ c_multiple_value_bind(cl_object args) c_env.variables = old_env; } else { cl_object old_variables = c_env.variables; - for (vars=reverse(vars); n; n--){ + for (vars=cl_reverse(vars); n; n--){ cl_object var = pop(&vars); if (!SYMBOLP(var)) FEillegal_variable_name(var); @@ -1362,7 +1379,7 @@ c_multiple_value_call(cl_object args) { name = pop(&args); if (endp(args)) { /* If no arguments, just use ordinary call */ - c_call(list(1, name), FALSE); + c_call(cl_list(1, name), FALSE); return; } asm_op(OP_MCALL); @@ -1397,7 +1414,7 @@ c_multiple_value_setq(cl_object args) { /* Look for symbol macros, building the list of variables and the list of late assignments. */ - for (orig_vars = reverse(pop(&args)); !endp(orig_vars); ) { + for (orig_vars = cl_reverse(pop(&args)); !endp(orig_vars); ) { cl_object aux, v = pop(&orig_vars); if (!SYMBOLP(v)) FEillegal_variable_name(v); @@ -1406,7 +1423,7 @@ c_multiple_value_setq(cl_object args) { aux = v; v = @gensym(0); temp_vars = CONS(v, temp_vars); - late_assignment = CONS(list(3, @'setf', aux, v), + late_assignment = CONS(cl_list(3, @'setf', aux, v), late_assignment); } vars = CONS(v, vars); @@ -1432,7 +1449,7 @@ c_multiple_value_setq(cl_object args) { /* Compile variables */ asm_op2(OP_MSETQ, nvars); - vars = reverse(vars); + vars = cl_reverse(vars); while (nvars--) { cl_object var = pop(&vars); cl_fixnum ndx; @@ -1450,7 +1467,9 @@ c_multiple_value_setq(cl_object args) { /* Assign to symbol-macros */ if (!Null(late_assignment)) { + asm_op(OP_MPROG1); compile_body(late_assignment); + asm_op(OP_EXIT); c_undo_bindings(old_variables); } } @@ -1628,7 +1647,7 @@ c_setq(cl_object args) { compile_form(value, FALSE); compile_setq(OP_SETQ, var); } else { - compile_form(list(3, @'setf', var, value), FALSE); + compile_form(cl_list(3, @'setf', var, value), FALSE); } } } @@ -1651,12 +1670,12 @@ c_symbol_macrolet(cl_object args) cl_object definition = pop(&def_list); cl_object name = pop(&definition); cl_object expansion = pop(&definition); - cl_object arglist = list(2, @gensym(0), @gensym(0)); + cl_object arglist = cl_list(2, @gensym(0), @gensym(0)); cl_object function; if (name->symbol.stype == stp_special || c_var_ref(name) == -2) FEprogram_error("SYMBOL-MACROLET: Symbol ~A cannot be \ declared special and appear in a symbol-macrolet.", 1, name); - definition = list(2, arglist, list(2, @'quote', expansion)); + definition = cl_list(2, arglist, cl_list(2, @'quote', expansion)); function = make_lambda(name, definition); c_register_symbol_macro(name, function); } @@ -1973,14 +1992,16 @@ compile_body(cl_object body) { @(return declarations body documentation specials) @) -@(defun si::process_lambda_list (lambda) +cl_object +si_process_lambda_list(cl_object lambda) +{ cl_object documentation, declarations, specials; cl_object lambda_list, body, form; cl_object x, v, key, init, spp; cl_object reqs = Cnil, opts = Cnil, keys = Cnil, rest = Cnil, auxs = Cnil; int nreq = 0, nopt = 0, nkey = 0, naux = 0; cl_object allow_other_keys = Cnil; -@ + bds_check; if (ATOM(lambda)) FEprogram_error("LAMBDA: No lambda list.", 0); @@ -2154,12 +2175,12 @@ OUTPUT: if ((nreq+nopt+(!Null(rest))+nkey) >= LAMBDA_PARAMETERS_LIMIT) FEprogram_error("LAMBDA: Argument list ist too long, ~S.", 1, CAR(lambda)); - @(return CONS(MAKE_FIXNUM(nreq), nreverse(reqs)) - CONS(MAKE_FIXNUM(nopt), nreverse(opts)) - nreverse(rest) + @(return CONS(MAKE_FIXNUM(nreq), cl_nreverse(reqs)) + CONS(MAKE_FIXNUM(nopt), cl_nreverse(opts)) + cl_nreverse(rest) allow_other_keys - CONS(MAKE_FIXNUM(nkey), nreverse(keys)) - nreverse(auxs) + CONS(MAKE_FIXNUM(nkey), cl_nreverse(keys)) + cl_nreverse(auxs) documentation specials declarations @@ -2167,7 +2188,7 @@ OUTPUT: ILLEGAL_LAMBDA: FEprogram_error("LAMBDA: Illegal lambda list ~S.", 1, CAR(lambda)); -@) +} static void c_default(cl_index deflt_pc) { @@ -2211,7 +2232,7 @@ make_lambda(cl_object name, cl_object lambda) { c_env.lexical_level++; - reqs = @si::process-lambda-list(1,lambda); + reqs = si_process_lambda_list(lambda); opts = VALUES(1); rest = VALUES(2); allow_other_keys = VALUES(3); @@ -2261,7 +2282,7 @@ make_lambda(cl_object name, cl_object lambda) { c_register_var2(asm_ref(opts_pc+2), &specials); opts_pc+=3; } - c_register_var2(car(rest), &specials); + c_register_var2(cl_car(rest), &specials); while (nkeys--) { c_default(keys_pc+2); c_register_var2(asm_ref(keys_pc+1), &specials); @@ -2296,21 +2317,24 @@ make_lambda(cl_object name, cl_object lambda) { return asm_end(handle, Cnil); } -@(defun si::function-block-name (name) -@ +cl_object +si_function_block_name(cl_object name) +{ if (SYMBOLP(name)) @(return name) if (CONSP(name) && CAR(name) == @'setf' && CONSP(CDR(name)) && SYMBOLP(CADR(name)) && Null(CDDR(name))) @(return CADR(name)) FEerror("Not a valid function name ~S",1,name); -@) +} -@(defun si::make_lambda (name rest) +cl_object +si_make_lambda(cl_object name, cl_object rest) +{ cl_object lambda; cl_compiler_env old_c_env = c_env; -@ - c_new_env(); + + c_new_env(Cnil); if (frs_push(FRS_PROTECT, Cnil)) { c_env = old_c_env; frs_pop(); @@ -2320,30 +2344,24 @@ make_lambda(cl_object name, cl_object lambda) { frs_pop(); c_env = old_c_env; @(return lambda) -@) +} cl_object eval(cl_object form, cl_object *new_bytecodes, cl_object env) { cl_compiler_env old_c_env = c_env; - cl_object bytecodes, lex_old = lex_env; + cl_object bytecodes; cl_index handle; bool unwinding; - c_new_env(); - if (Null(env)) { - lex_new(); - c_env.lexical_level = 0; - } else { - c_env.lexical_level = 1; - lex_env = env; - lex_copy(); - } + ihs_push(@'eval'); + lex_env = env; + c_new_env(env); handle = asm_begin(); if (frs_push(FRS_PROTECT, Cnil)) { asm_clear(handle); - lex_env = lex_old; c_env = old_c_env; + ihs_pop(); frs_pop(); unwind(nlj_fr, nlj_tag); } @@ -2359,9 +2377,9 @@ eval(cl_object form, cl_object *new_bytecodes, cl_object env) *new_bytecodes = bytecodes; } interpret(bytecodes->bytecodes.data); - frs_pop(); - lex_env = lex_old; c_env = old_c_env; + ihs_pop(); + frs_pop(); return VALUES(0); } diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 23f7d68f7..5c495a44f 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -22,16 +22,41 @@ static cl_object *disassemble(cl_object *vector); static cl_object *base = NULL; +static void +print_noarg(const char *s) { + princ_str(s, Cnil); +} + +static void +print_oparg(const char *s, cl_fixnum n) { + princ_str(s, Cnil); + princ(MAKE_FIXNUM(n), Cnil); +} + +static void +print_arg(const char *s, cl_object x) { + princ_str(s, Cnil); + princ(x, Cnil); +} + +static void +print_oparg_arg(const char *s, cl_fixnum n, cl_object x) { + princ_str(s, Cnil); + princ(MAKE_FIXNUM(n), Cnil); + princ_str(",", Cnil); + princ(x, Cnil); +} + static cl_object * disassemble_vars(const char *message, cl_object *vector, cl_index step) { cl_index n = fix(next_code(vector)); if (n) { - @terpri(0); - printf(message); + terpri(Cnil); + print_noarg(message); for (; n; n--, vector+=step) { - @prin1(1,vector[0]); - if (n > 1) printf(", "); + prin1(vector[0], Cnil); + if (n > 1) print_noarg(", "); } } return vector; @@ -42,10 +67,8 @@ disassemble_lambda(cl_object *vector) { cl_object specials; cl_index n; - @terpri(0); /* Name of LAMBDA */ - printf("Name:\t\t"); - @prin1(1, next_code(vector)); + print_arg("\nName:\t\t", next_code(vector)); /* Variables that have been declared special */ specials = next_code(vector); @@ -58,27 +81,20 @@ disassemble_lambda(cl_object *vector) { /* Print rest argument */ if (vector[0] != Cnil) { - @terpri(0); - printf("Rest:\t\t%s"); - @prin1(1, vector[0]); + print_arg("\nRest:\t\t", vector[0]); } vector++; /* Print keyword arguments */ if (vector[0] != Cnil) { - @terpri(0); - printf("Other keys:\t"); - @prin1(1, vector[0]); + print_arg("\nOther keys:\t", vector[0]); } vector++; vector = disassemble_vars("Keywords:\t", vector, 4); /* Print aux arguments */ - @terpri(0); - printf("\nDocumentation:\t"); - @prin1(1, next_code(vector)); - printf("\nDeclarations:\t"); - @prin1(1, next_code(vector)); + print_arg("\nDocumentation:\t", next_code(vector)); + print_arg("\nDeclarations:\t", next_code(vector)); base = vector; while (vector[0] != MAKE_FIXNUM(OP_HALT)) @@ -123,13 +139,11 @@ disassemble_block(cl_object *vector) { cl_fixnum exit = packed_label(vector-1); cl_object block_name = next_code(vector); - lex_env = listX(3, @':block', CONS(block_name, Cnil), lex_env); + lex_env = cl_listX(3, @':block', CONS(block_name, Cnil), lex_env); - printf("BLOCK\t"); - @prin1(1, block_name); - printf(",%d", exit); + print_oparg_arg("BLOCK\t", exit, block_name); vector = disassemble(vector); - printf("\t\t; block"); + print_noarg("\t\t; block"); lex_env = lex_old; return vector; @@ -145,9 +159,9 @@ disassemble_block(cl_object *vector) { */ static cl_object * disassemble_catch(cl_object *vector) { - printf("CATCH\t%d", packed_label(vector - 1)); + print_oparg("CATCH\t", packed_label(vector - 1)); vector = disassemble(vector); - printf("\t\t; catch"); + print_noarg("\t\t; catch"); return vector; } @@ -165,9 +179,9 @@ disassemble_do(cl_object *vector) { lex_copy(); exit = packed_label(vector-1); - printf("DO\t%d", exit); + print_oparg("DO\t", exit); vector = disassemble(vector); - printf("\t\t; do"); + print_noarg("\t\t; do"); lex_env = lex_old; return vector; @@ -192,13 +206,13 @@ disassemble_dolist(cl_object *vector) { lex_copy(); exit = packed_label(vector-1); - printf("DOLIST\t%d", exit); + print_oparg("DOLIST\t", exit); vector = disassemble(vector); - printf("\t\t; dolist binding"); + print_noarg("\t\t; dolist binding"); vector = disassemble(vector); - printf("\t\t; dolist body"); + print_noarg("\t\t; dolist body"); vector = disassemble(vector); - printf("\t\t; dolist"); + print_noarg("\t\t; dolist"); lex_env = lex_old; return vector; @@ -223,13 +237,13 @@ disassemble_dotimes(cl_object *vector) { lex_copy(); exit = packed_label(vector-1); - printf("DOTIMES\t%d", exit); + print_oparg("DOTIMES\t", exit); vector = disassemble(vector); - printf("\t\t; dotimes times"); + print_noarg("\t\t; dotimes times"); vector = disassemble(vector); - printf("\t\t; dotimes body"); + print_noarg("\t\t; dotimes body"); vector = disassemble(vector); - printf("\t\t; dotimes"); + print_noarg("\t\t; dotimes"); lex_env = lex_old; return vector; @@ -250,16 +264,15 @@ disassemble_flet(cl_object *vector) { cl_object lex_old = lex_env; cl_index nfun = get_oparg(vector[-1]); - printf("FLET"); + print_noarg("FLET"); lex_copy(); while (nfun--) { cl_object fun = next_code(vector); - @terpri(0); - printf("\tFLET\t"); + print_noarg("\n\tFLET\t"); @prin1(1, fun->bytecodes.data[0]); } vector = disassemble(vector); - printf("\t\t; flet"); + print_noarg("\t\t; flet"); lex_env = lex_old; return vector; @@ -280,16 +293,14 @@ disassemble_labels(cl_object *vector) { cl_object lex_old = lex_env; cl_index nfun = get_oparg(vector[-1]); - printf("LABELS"); + print_noarg("LABELS"); lex_copy(); while (nfun--) { cl_object fun = next_code(vector); - @terpri(0); - printf("\tLABELS\t"); - @prin1(1, fun->bytecodes.data[0]); + print_arg("\n\tLABELS\t", fun->bytecodes.data[0]); } vector = disassemble(vector); - printf("\t\t; labels"); + print_noarg("\t\t; labels"); lex_env = lex_old; return vector; @@ -304,9 +315,9 @@ disassemble_labels(cl_object *vector) { */ static cl_object * disassemble_mcall(cl_object *vector) { - printf("MCALL"); + print_noarg("MCALL"); vector = disassemble(vector); - printf("\t\t; mcall"); + print_noarg("\t\t; mcall"); return vector; } @@ -319,9 +330,9 @@ disassemble_mcall(cl_object *vector) { */ static cl_object * disassemble_mprog1(cl_object *vector) { - printf("MPROG1"); + print_noarg("MPROG1"); vector = disassemble(vector); - printf("\t\t; mprog1"); + print_noarg("\t\t; mprog1"); return vector; } @@ -340,20 +351,20 @@ disassemble_msetq(cl_object *vector) { int i = get_oparg(vector[-1]); bool newline = FALSE; + while (i--) { cl_object var = next_code(vector); if (newline) { - @terpri(0); - printf("\t"); + print_noarg("\n\t"); } else newline = TRUE; if (FIXNUMP(var)) { - printf("MSETQ\t%d", fix(var)); + @format(4, Ct, make_constant_string("MSETQ\t~D,VALUES(~D)"), + var, MAKE_FIXNUM(i)); } else { - printf("MSETQS\t"); - @prin1(1, var); + @format(4, Ct, make_constant_string("MSETQS\t~A,VALUES(~D)"), + var, MAKE_FIXNUM(i)); } - printf(", VALUES(%d)", i); } return vector; } @@ -367,9 +378,9 @@ disassemble_msetq(cl_object *vector) */ static cl_object * disassemble_progv(cl_object *vector) { - printf("PROGV"); + print_noarg("PROGV"); vector = disassemble(vector); - printf("\t\t; progv"); + print_noarg("\t\t; progv"); return vector; } @@ -393,14 +404,13 @@ disassemble_tagbody(cl_object *vector) { cl_object lex_old = lex_env; lex_copy(); - printf("TAGBODY"); + print_noarg("TAGBODY"); for (i=0; ibytecodes.data); - @(return v) -@) + @(return v) + } + @(return Cnil) +} -@(defun si::bc_split (b) +cl_object +si_bc_split(cl_object b) +{ cl_object vector; -@ + if (type_of(b) != t_bytecodes) @(return Cnil Cnil) vector = cl_alloc_simple_vector(b->bytecodes.size, aet_object); vector->vector.self.t = b->bytecodes.data; @(return b->bytecodes.lex vector) -@) +} diff --git a/src/c/dpp.c b/src/c/dpp.c index b08cd9435..ca9f80614 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -762,8 +762,6 @@ LOOP: put_declaration(); put_lineno(); } else if (strcmp(p, "return") == 0) { - if (!in_defun) - error("@(return) found outside @(defun)"); tab_save = tab; get_return(); put_return(); diff --git a/src/c/error.d b/src/c/error.d index 537bbc6c6..3a806f908 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -111,8 +111,8 @@ FEprogram_error(const char *s, int narg, ...) funcall(4, @'si::universal-error-handler', Cnil, /* not correctable */ @'si::simple-program-error', /* condition name */ - list(4, @':format-control', make_constant_string(s), - @':format-arguments', cl_grab_rest_args(args))); + cl_list(4, @':format-control', make_constant_string(s), + @':format-arguments', cl_grab_rest_args(args))); } void @@ -123,8 +123,8 @@ FEcontrol_error(const char *s, int narg, ...) funcall(4, @'si::universal-error-handler', Cnil, /* not correctable */ @'si::simple-control-error', /* condition name */ - list(4, @':format-control', make_constant_string(s), - @':format-arguments', cl_grab_rest_args(args))); + cl_list(4, @':format-control', make_constant_string(s), + @':format-arguments', cl_grab_rest_args(args))); } void @@ -261,7 +261,7 @@ not_a_variable(cl_object obj) void init_error(void) { - MF(@'si::universal-error-handler', universal_error_handler, Cnil); + cl_def_c_function_va(@'si::universal-error-handler', universal_error_handler); null_string = make_constant_string(""); register_root(&null_string); } diff --git a/src/c/eval.d b/src/c/eval.d index 9573bc5d1..76655c52b 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -73,6 +73,11 @@ cl_apply_from_stack(cl_index narg, cl_object fun) AGAIN: switch (type_of(fun)) { case t_cfun: + if (fun->cfun.narg >= 0) { + if (narg != fun->cfun.narg) + check_arg_failed(narg, fun->cfun.narg); + return APPLY_fixed(narg, fun->cfun.entry, cl_stack_top - narg); + } return APPLY(narg, fun->cfun.entry, cl_stack_top - narg); case t_cclosure: return APPLY_closure(narg, fun->cclosure.entry, @@ -114,14 +119,20 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args) AGAIN: switch (type_of(fun)) { case t_cfun: - if (pLK) { - putprop(sym, CONS(CONS(make_unsigned_integer((cl_index)pLK), - make_unsigned_integer((cl_index)*pLK)), - getf(sym->symbol.plist, @'si::link-from', Cnil)), - @'si::link-from'); - *pLK = fun->cfun.entry; + if (fun->cfun.narg >= 0) { + if (narg != fun->cfun.narg) + check_arg_failed(narg, fun->cfun.narg); + out = APPLY_fixed(narg, fun->cfun.entry, cl_stack_top - narg); + } else { + if (pLK) { + putprop(sym, CONS(CONS(make_unsigned_integer((cl_index)pLK), + make_unsigned_integer((cl_index)*pLK)), + getf(sym->symbol.plist, @'si::link-from', Cnil)), + @'si::link-from'); + *pLK = fun->cfun.entry; + } + out = APPLY(narg, fun->cfun.entry, cl_stack + sp); } - out = APPLY(narg, fun->cfun.entry, cl_stack + sp); break; #ifdef CLOS case t_gfun: { @@ -145,9 +156,11 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args) return out; } -@(defun si::unlink_symbol (s) +cl_object +si_unlink_symbol(cl_object s) +{ cl_object pl; -@ + if (!SYMBOLP(s)) FEtype_error_symbol(s); pl = getf(s->symbol.plist, @'si::link-from', Cnil); @@ -157,7 +170,7 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args) remf(&s->symbol.plist, @'si::link-from'); } @(return) -@) +} @(defun funcall (function &rest funargs) cl_index sp; @@ -171,7 +184,13 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args) AGAIN: switch (type_of(fun)) { case t_cfun: - out = APPLY(narg, fun->cfun.entry, cl_stack + sp); + if (fun->cfun.narg >= 0) { + if (narg != fun->cfun.narg) + check_arg_failed(narg, fun->cfun.narg); + out = APPLY_fixed(narg, fun->cfun.entry, cl_stack_top - narg); + } else { + out = APPLY(narg, fun->cfun.entry, cl_stack + sp); + } break; case t_cclosure: out = APPLY_closure(narg, fun->cclosure.entry, @@ -198,19 +217,17 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args) return out; @) -@(defun eval (form) - cl_object output; -@ - output = eval(form, NULL, Cnil); - returnn(output); -@) +cl_object +cl_eval(cl_object form) +{ + return eval(form, NULL, Cnil); +} -@(defun si::eval-with-env (form env) - cl_object output; -@ - output = eval(form, NULL, env); - returnn(output); -@) +cl_object +si_eval_with_env(cl_object form, cl_object env) +{ + return eval(form, NULL, env); +} cl_object cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object err_value) @@ -234,9 +251,11 @@ cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object returnn(cl_safe_eval(form, NULL, env, err_value)); @) -@(defun constantp (arg) +cl_object +cl_constantp(cl_object arg) +{ cl_object flag; -@ + switch (type_of(arg)) { case t_cons: flag = (CAR(arg) == @'quote') ? Ct : Cnil; @@ -248,7 +267,7 @@ cl_safe_eval(cl_object form, cl_object *new_bytecodes, cl_object env, cl_object flag = Ct; } @(return flag) -@) +} void init_eval(void) diff --git a/src/c/file.d b/src/c/file.d index 45ad56b97..c337e77ef 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -143,27 +143,27 @@ BEGIN: } cl_object -stream_element_type(cl_object strm) +cl_stream_element_type(cl_object strm) { cl_object x; BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) - return(@'base-char'); + @(return @'base-char'); #endif if (type_of(strm) != t_stream) FEtype_error_stream(strm); switch ((enum smmode)strm->stream.mode) { case smm_closed: closed_stream(strm); - return(FALSE); case smm_input: case smm_output: case smm_io: case smm_probe: - return(strm->stream.object0); + x = strm->stream.object0; + break; case smm_synonym: strm = symbol_value(strm->stream.object0); @@ -173,25 +173,29 @@ BEGIN: x = strm->stream.object0; if (endp(x)) return(Ct); - return(stream_element_type(CAR(x))); + strm = CAR(x); + goto BEGIN; case smm_concatenated: x = strm->stream.object0; if (endp(x)) return(Ct); - return(stream_element_type(CAR(x))); + strm = CAR(x); + goto BEGIN; case smm_two_way: case smm_echo: - return(stream_element_type(strm->stream.object0)); + strm = strm->stream.object0; + goto BEGIN; case smm_string_input: case smm_string_output: - return(@'base-char'); + x = @'base-char'; default: error("illegal stream mode"); } + @(return x) } /*---------------------------------------------------------------------- @@ -1291,9 +1295,11 @@ BEGIN: } } -@(defun make_synonym_stream (sym) +cl_object +cl_make_synonym_stream(cl_object sym) +{ cl_object x; -@ + assert_type_symbol(sym); x = cl_alloc_object(t_stream); x->stream.mode = (short)smm_synonym; @@ -1302,7 +1308,7 @@ BEGIN: x->stream.object1 = OBJNULL; x->stream.int0 = x->stream.int1 = 0; @(return x) -@) +} @(defun make_broadcast_stream (&rest ap) @@ -1319,7 +1325,7 @@ BEGIN: x = cl_alloc_object(t_stream); x->stream.mode = (short)smm_broadcast; x->stream.file = NULL; - x->stream.object0 = nreverse(streams); + x->stream.object0 = cl_nreverse(streams); x->stream.object1 = OBJNULL; x->stream.int0 = x->stream.int1 = 0; @(return x) @@ -1339,29 +1345,31 @@ BEGIN: x = cl_alloc_object(t_stream); x->stream.mode = (short)smm_concatenated; x->stream.file = NULL; - x->stream.object0 = nreverse(streams); + x->stream.object0 = cl_nreverse(streams); x->stream.object1 = OBJNULL; x->stream.int0 = x->stream.int1 = 0; @(return x) @) -@(defun make_two_way_stream (strm1 strm2) -@ +cl_object +cl_make_two_way_stream(cl_object strm1, cl_object strm2) +{ if (type_of(strm1) != t_stream || !input_stream_p(strm1)) cannot_read(strm1); if (type_of(strm2) != t_stream || !output_stream_p(strm2)) cannot_write(strm2); @(return make_two_way_stream(strm1, strm2)) -@) +} -@(defun make_echo_stream (strm1 strm2) -@ +cl_object +cl_make_echo_stream(cl_object strm1, cl_object strm2) +{ if (type_of(strm1) != t_stream || !input_stream_p(strm1)) cannot_read(strm1); if (type_of(strm2) != t_stream || !output_stream_p(strm2)) cannot_write(strm2); @(return make_echo_stream(strm1, strm2)) -@) +} @(defun make_string_input_stream (strng &o istart iend) cl_index s, e; @@ -1389,18 +1397,20 @@ for the string ~S.", 3, istart, iend, strng); @) -@(defun make_string_output_stream () -@ +cl_object +cl_make_string_output_stream() +{ @(return make_string_output_stream(64)) -@) +} -@(defun get_output_stream_string (strm) -@ +cl_object +cl_get_output_stream_string(cl_object strm) +{ if (type_of(strm) != t_stream || (enum smmode)strm->stream.mode != smm_string_output) FEerror("~S is not a string-output stream.", 1, strm); @(return get_output_stream_string(strm)) -@) +} /*---------------------------------------------------------------------- * (SI:OUTPUT-STREAM-STRING string-output-stream) @@ -1409,33 +1419,32 @@ for the string ~S.", * string-output-stream. *---------------------------------------------------------------------- */ -@(defun si::output_stream_string (strm) -@ +cl_object +si_output_stream_string(cl_object strm) +{ if (type_of(strm) != t_stream || (enum smmode)strm->stream.mode != smm_string_output) FEerror("~S is not a string-output stream.", 1, strm); @(return strm->stream.object0) -@) +} -@(defun streamp (strm) -@ +cl_object +cl_streamp(cl_object strm) +{ @(return ((type_of(strm) == t_stream) ? Ct : Cnil)) -@) +} -@(defun input_stream_p (strm) -@ +cl_object +cl_input_stream_p(cl_object strm) +{ @(return (input_stream_p(strm) ? Ct : Cnil)) -@) +} -@(defun output_stream_p (strm) -@ +cl_object +cl_output_stream_p(cl_object strm) +{ @(return (output_stream_p(strm) ? Ct : Cnil)) -@) - -@(defun stream_element_type (strm) -@ - @(return stream_element_type(strm)) -@) +} @(defun close (strm &key abort) @ @@ -1513,41 +1522,44 @@ for the file-stream ~S.", } @) -@(defun file_length (strm) - int i; -@ - i = file_length(strm); +cl_object +cl_file_length(cl_object strm) +{ + cl_fixnum i = file_length(strm); @(return ((i < 0) ? Cnil : MAKE_FIXNUM(i))) -@) +} -@(defun open_stream_p (strm) -@ +cl_object +cl_open_stream_p(cl_object strm) +{ /* ANSI and Cltl2 specify that open-stream-p should work on closed streams, and that a stream is only closed when #'close has been applied on it */ @(return (strm->stream.mode != smm_closed ? Ct : Cnil)) -@) +} -@(defun si::get_string_input_stream_index (strm) -@ +cl_object +si_get_string_input_stream_index(cl_object strm) +{ if ((enum smmode)strm->stream.mode != smm_string_input) FEerror("~S is not a string-input stream.", 1, strm); @(return MAKE_FIXNUM(strm->stream.int0)) -@) +} -@(defun si::make_string_output_stream_from_string (s) - cl_object strm; -@ +cl_object +si_make_string_output_stream_from_string(cl_object s) +{ @(return make_string_output_stream_from_string(s)) -@) +} -@(defun si::copy_stream (in out) -@ +cl_object +si_copy_stream(cl_object in, cl_object out) +{ while (!stream_at_end(in)) writec_stream(readc_stream(in), out); flush_stream(out); @(return Ct) -@) +} void init_file(void) diff --git a/src/c/gfun.d b/src/c/gfun.d index a994d8f55..2114f6f95 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -14,10 +14,12 @@ #include "ecl.h" -@(defun si::allocate_gfun (name arg_no ht) +cl_object +si_allocate_gfun(cl_object name, cl_object arg_no, cl_object ht) +{ cl_object x; int n, i; -@ + if (type_of(ht) != t_hashtable) FEwrong_type_argument(@'hash-table', ht); @@ -32,84 +34,94 @@ x->gfun.specializers[i] = OBJNULL; x->gfun.instance = Cnil; @(return x) -@) +} -@(defun si::gfun_name (x) -@ +cl_object +si_gfun_name(cl_object x) +{ if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); @(return x->gfun.name) -@) +} -@(defun si::gfun_name_set (x name) -@ +cl_object +si_gfun_name_set(cl_object x, cl_object name) +{ if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); x->gfun.name = name; @(return x) -@) +} -@(defun si::gfun_method_ht (x) -@ +cl_object +si_gfun_method_ht(cl_object x) +{ if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); @(return x->gfun.method_hash) -@) +} -@(defun si::gfun_method_ht_set (x y) -@ +cl_object +si_gfun_method_ht_set(cl_object x, cl_object y) +{ if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); if (type_of(y) != t_hashtable) FEwrong_type_argument(@'hash-table', y); x->gfun.method_hash = y; @(return x) -@) +} -@(defun si::gfun_spec_how_ref (x y) +cl_object +si_gfun_spec_how_ref(cl_object x, cl_object y) +{ int i; -@ + if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); if (!FIXNUMP(y) || (i = fix(y)) < 0 || i >= x->gfun.arg_no) FEerror("~S is an illegal spec_how index.", 1, y); @(return x->gfun.specializers[i]) -@) +} -@(defun si::gfun_spec_how_set (x y spec) +cl_object +si_gfun_spec_how_set(cl_object x, cl_object y, cl_object spec) +{ int i; -@ + if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); if (!FIXNUMP(y) || (i = fix(y)) >= x->gfun.arg_no) FEerror("~S is an illegal spec_how index.", 1, y); x->gfun.specializers[i] = spec; @(return spec) -@) +} -@(defun si::gfun_instance (x) -@ +cl_object +si_gfun_instance(cl_object x) +{ if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); @(return x->gfun.instance) -@) +} -@(defun si::gfun_instance_set (x y) -@ +cl_object +si_gfun_instance_set(cl_object x, cl_object y) +{ if (type_of(x) != t_gfun) FEwrong_type_argument(@'dispatch-function', x); if (type_of(y) != t_instance) FEwrong_type_argument(@'instance', y); x->gfun.instance = y; @(return x) -@) +} -@(defun si::gfunp (x) -@ +cl_object +si_gfunp(cl_object x) +{ @(return ((type_of(x) == t_gfun)? Ct : Cnil)) -@) - +} /* * variation of gethash from hash.d, which takes an array of objects as key @@ -147,9 +159,11 @@ get_meth_hash(cl_object *keys, int argno, cl_object hashtable) internal_error("get_meth_hash"); } -@(defun si::method_ht_get (keylist table) +cl_object +si_method_ht_get(cl_object keylist, cl_object table) +{ struct hashtable_entry *e; -@ + { int i, argn = length(keylist); cl_object keys[argn]; /* __GNUC__ */ @@ -158,7 +172,7 @@ get_meth_hash(cl_object *keys, int argno, cl_object hashtable) e = get_meth_hash(keys, argn, table); } @(return ((e->key == OBJNULL)? Cnil : e->value)) -@) +} static void set_meth_hash(cl_object *keys, int argno, cl_object hashtable, cl_object value) @@ -194,7 +208,7 @@ compute_method(int narg, cl_object fun, cl_object *args) if (*spec_how != Cnil) argtype[spec_no++] = (ATOM(*spec_how) || !member_eq(args[i], *spec_how)) ? - TYPE_OF(args[i]) : + cl_type_of(args[i]) : args[i]; } @@ -223,12 +237,14 @@ compute_method(int narg, cl_object fun, cl_object *args) return func; } -@(defun si::set_compiled_function_name (fn new_name) +cl_object +si_set_compiled_function_name(cl_object fn, cl_object new_name) +{ cl_type t = type_of(fn); -@ + if (t == t_cfun) @(return (fn->cfun.name = new_name)) if (t == t_bytecodes) @(return (fn->bytecodes.data[0] = new_name)) FEerror("~S is not a compiled-function.", 1, fn); -@) +} diff --git a/src/c/hash.d b/src/c/hash.d index 5d0a6330e..53e1002e6 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -401,7 +401,7 @@ extend_hashtable(cl_object hashtable) (rehash_size make_shortfloat(1.5)) (rehash_threshold make_shortfloat(0.7))) @ - @(return cl_make_hash_table(test, size, rehash_size, rehash_threshold)) + @(return cl__make_hash_table(test, size, rehash_size, rehash_threshold)) @) cl_object @@ -417,8 +417,8 @@ cl_clear_hash_table(cl_object hashtable) } cl_object -cl_make_hash_table(cl_object test, cl_object size, cl_object rehash_size, - cl_object rehash_threshold) +cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, + cl_object rehash_threshold) { enum httest htt; cl_index i, hsize; @@ -466,10 +466,11 @@ cl_make_hash_table(cl_object test, cl_object size, cl_object rehash_size, return h; } -@(defun hash_table_p (ht) -@ +cl_object +cl_hash_table_p(cl_object ht) +{ @(return ((type_of(ht) == t_hashtable) ? Ct : Cnil)) -@) +} @(defun gethash (key ht &optional (no_value Cnil)) struct hashtable_entry *e; @@ -482,12 +483,13 @@ cl_make_hash_table(cl_object test, cl_object size, cl_object rehash_size, @(return no_value Cnil) @) -@(defun si::hash_set (key ht val) -@ +cl_object +si_hash_set(cl_object key, cl_object ht, cl_object val) +{ /* INV: sethash() checks the type of hashtable */ sethash(key, ht, val); @(return val) -@) +} bool remhash(cl_object key, cl_object hashtable) @@ -505,16 +507,18 @@ remhash(cl_object key, cl_object hashtable) return FALSE; } -@(defun remhash (key ht) - struct hashtable_entry *e; -@ +cl_object +cl_remhash(cl_object key, cl_object ht) +{ /* INV: search_hash() checks the type of hashtable */ @(return (remhash(key, ht)? Ct : Cnil)); -@) +} -@(defun clrhash (ht) +cl_object +cl_clrhash(cl_object ht) +{ cl_index i; -@ + assert_type_hash_table(ht); for(i = 0; i < ht->hash.size; i++) { ht->hash.data[i].key = OBJNULL; @@ -522,34 +526,40 @@ remhash(cl_object key, cl_object hashtable) } ht->hash.entries = 0; @(return ht) -@) +} -@(defun hash_table_count (ht) -@ +cl_object +cl_hash_table_count(cl_object ht) +{ assert_type_hash_table(ht); @(return (MAKE_FIXNUM(ht->hash.entries))) -@) +} -@(defun hash_table_rehash_size (ht) -@ +cl_object +cl_hash_table_rehash_size(cl_object ht) +{ assert_type_hash_table(ht); @(return ht->hash.rehash_size) -@) +} -@(defun hash_table_rehash_threshold (ht) -@ +cl_object +cl_hash_table_rehash_threshold(cl_object ht) +{ assert_type_hash_table(ht); @(return ht->hash.threshold) -@) +} -@(defun sxhash (key) -@ +cl_object +cl_sxhash(cl_object key) +{ @(return (MAKE_FIXNUM(_hash_equal(~(cl_hashkey)0, 0, key) & 0x7fffffff))) -@) +} -@(defun maphash (fun ht) +cl_object +cl_maphash(cl_object fun, cl_object ht) +{ cl_index i; -@ + assert_type_hash_table(ht); for (i = 0; i < ht->hash.size; i++) { if(ht->hash.data[i].key != OBJNULL) @@ -558,4 +568,4 @@ remhash(cl_object key, cl_object hashtable) ht->hash.data[i].value); } @(return Cnil) -@) +} diff --git a/src/c/instance.d b/src/c/instance.d index f507cdd07..4c751b5d6 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -26,21 +26,24 @@ cl_allocate_instance(cl_object clas, int size) return(x); } -@(defun si::allocate_instance (clas size) -@ +cl_object +si_allocate_instance(cl_object clas, cl_object size) +{ if (type_of(clas) != t_instance) FEwrong_type_argument(@'instance', clas); @(return cl_allocate_instance(clas, fixnnint(size))) -@) +} /* corr is a list of (newi . oldi) describing which of the new slots retains a value from an old slot */ -@(defun si::change_instance (x clas size corr) +cl_object +si_change_instance(cl_object x, cl_object clas, cl_object size, cl_object corr) +{ int nslot, i; cl_object * oldslots; -@ + if (type_of(x) != t_instance) FEwrong_type_argument(@'instance', x); @@ -61,24 +64,26 @@ cl_allocate_instance(cl_object clas, int size) x->instance.slots[i] = OBJNULL; } @(return) /* FIXME! Is this what we need? */ -@) +} -@(defun si::instance_class (x) -@ +cl_object +si_instance_class(cl_object x) +{ if (type_of(x) != t_instance) FEwrong_type_argument(@'instance', x); @(return CLASS_OF(x)) -@) +} -@(defun si::instance_class_set (x y) -@ +cl_object +si_instance_class_set(cl_object x, cl_object y) +{ if (type_of(x) != t_instance) FEwrong_type_argument(@'instance', x); if (type_of(y) != t_instance) FEwrong_type_argument(@'instance', y); CLASS_OF(x) = y; @(return x) -@) +} cl_object instance_ref(cl_object x, int i) @@ -90,20 +95,24 @@ instance_ref(cl_object x, int i) return(x->instance.slots[i]); } -@(defun si::instance_ref (x index) +cl_object +si_instance_ref(cl_object x, cl_object index) +{ cl_fixnum i; -@ + if (type_of(x) != t_instance) FEwrong_type_argument(@'instance', x); if (!FIXNUMP(index) || (i = fix(index)) < 0 || i >= x->instance.length) FEerror("~S is an illegal slot index.", 1, index); @(return x->instance.slots[i]) -@) +} -@(defun si::instance_ref_safe (x index) +cl_object +si_instance_ref_safe(cl_object x, cl_object index) +{ cl_fixnum i; -@ + if (type_of(x) != t_instance) FEwrong_type_argument(@'instance', x); if (!FIXNUMP(index) || @@ -113,7 +122,7 @@ instance_ref(cl_object x, int i) if (x == OBJNULL) FEerror("Slot index ~S unbound", 1, index); @(return x->instance.slots[i]) -@) +} cl_object instance_set(cl_object x, int i, cl_object v) @@ -126,9 +135,11 @@ instance_set(cl_object x, int i, cl_object v) return(v); } -@(defun si::instance_set (x index value) +cl_object +si_instance_set(cl_object x, cl_object index, cl_object value) +{ cl_fixnum i; -@ + if (type_of(x) != t_instance) FEwrong_type_argument(@'instance', x); if (!FIXNUMP(index) || @@ -136,28 +147,33 @@ instance_set(cl_object x, int i, cl_object v) FEerror("~S is an illegal slot index.", 1, index); x->instance.slots[i] = value; @(return value) -@) +} -@(defun si::instancep (x) -@ +cl_object +si_instancep(cl_object x) +{ @(return ((type_of(x) == t_instance) ? Ct : Cnil)) -@) +} -@(defun si::unbound () -@ +cl_object +si_unbound() +{ /* Returns an object that cannot be read or written and which is used to represent an unitialized slot */ @(return OBJNULL) -@) +} -@(defun si::sl_boundp (x) -@ +cl_object +si_sl_boundp(cl_object x) +{ @(return ((x == OBJNULL) ? Cnil : Ct)) -@) +} -@(defun si::sl_makunbound (x index) +cl_object +si_sl_makunbound(cl_object x, cl_object index) +{ cl_fixnum i; -@ + if (type_of(x) != t_instance) FEwrong_type_argument(@'instance', x); if (!FIXNUMP(index) || @@ -165,4 +181,4 @@ instance_set(cl_object x, int i, cl_object v) FEerror("~S is an illegal slot index.", 1, index); x->instance.slots[i] = OBJNULL; @(return x) -@) +} diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 0c9ea888f..edc9fa49b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -43,6 +43,8 @@ cl_stack_set_size(cl_index new_size) new_stack = (cl_object *)cl_alloc(new_size * sizeof(cl_object)); memcpy(new_stack, cl_stack, cl_stack_size * sizeof(cl_object)); + + GC_free(cl_stack); cl_stack_size = new_size; cl_stack = new_stack; cl_stack_top = cl_stack + top; @@ -425,7 +427,13 @@ interpret_funcall(int narg, cl_object fun) { case t_cfun: ihs_push(fun->cfun.name); lex_env = Cnil; - x = APPLY(narg, fun->cfun.entry, args); + if (fun->cfun.narg >= 0) { + if (narg != fun->cfun.narg) + check_arg_failed(narg, fun->cfun.narg); + x = APPLY_fixed(narg, fun->cfun.entry, args); + } else { + x = APPLY(narg, fun->cfun.entry, args); + } ihs_pop(); break; case t_cclosure: @@ -802,7 +810,7 @@ interpret_mcall(cl_object *vector) { return vector; } -/* OP_PROG1 +/* OP_MPROG1 ... OP_EXIT @@ -874,7 +882,7 @@ interpret_progv(cl_object *vector) { if (values == Cnil) bds_bind(CAR(vars), OBJNULL); else { - bds_bind(CAR(vars), car(values)); + bds_bind(CAR(vars), cl_car(values)); values = CDR(values); } vars = CDR(vars); diff --git a/src/c/list.d b/src/c/list.d index 1f4398700..1edd6ec53 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -141,41 +141,23 @@ cl_return f ## _if_not(int narg, cl_object arg1, cl_object pred, cl_object arg3, return f(narg+2, arg1, pred, arg3, @':test-not', @'funcall', key, val); \ } -@(defun car (x) -@ - if (Null(x)) - @(return Cnil) - if (ATOM(x)) - FEtype_error_list(x); - @(return CAR(x)) -@) - cl_object -car(cl_object x) +cl_car(cl_object x) { if (Null(x)) - return(x); + return1(x); if (CONSP(x)) - return(CAR(x)); + return1(CAR(x)); FEtype_error_list(x); } -@(defun cdr (x) -@ - if (Null(x)) - @(return Cnil) - if (ATOM(x)) - FEtype_error_list(x); - @(return CDR(x)) -@) - cl_object -cdr(cl_object x) +cl_cdr(cl_object x) { if (Null(x)) - return(x); + return1(x); if (CONSP(x)) - return(CDR(x)); + return1(CDR(x)); FEtype_error_list(x); } @@ -190,18 +172,6 @@ cdr(cl_object x) @(return list) @) -cl_object -list(int narg, ...) -{ - cl_object p = Cnil, *z = &p; - va_list args; - - va_start(args, narg); - while (narg-- > 0) - z = &CDR(*z = CONS(va_arg(args, cl_object), Cnil)); - return(p); -} - @(defun list* (&rest args) cl_object p = Cnil, *z=&p; @ @@ -213,19 +183,6 @@ list(int narg, ...) @(return p) @) -cl_object -listX(int narg, ...) -{ - cl_object p = Cnil, *z = &p; - va_list args; - - va_start(args, narg); - while (--narg > 0) - z = &CDR( *z = CONS(va_arg(args,cl_object), Cnil)); - *z = va_arg(args, cl_object); - return(p); -} - static void copy_list_to(cl_object x, cl_object **z) { @@ -263,7 +220,6 @@ append(cl_object x, cl_object y) return(w); } -#if 1 /* Open coded CARs and CDRs */ #define car(foo) \ (void)foo; \ @@ -282,22 +238,10 @@ append(cl_object x, cl_object y) goto E; \ } #define defcxr(name, arg, code) \ -cl_object name(cl_object foo) { \ +cl_object cl_##name(cl_object foo) { \ cl_object arg = foo; \ - code; return x; \ -E: FEtype_error_list(arg);} \ -cl_return clL##name(int narg, cl_object arg) { \ - check_arg(1); \ - return1(name(arg)); \ -} -#else -#define defcxr(name, arg, code) \ -cl_object name(cl_object arg) { return code; } \ -cl_return clL##name(int narg, cl_object arg) { \ - check_arg(1); \ - return1(name(arg)); \ -} -#endif + code; return1(x); \ +E: FEtype_error_list(arg);} defcxr(caar, x, car(car(x))) defcxr(cadr, x, car(cdr(x))) @@ -330,8 +274,7 @@ defcxr(cddddr, x, cdr(cdr(cdr(cdr(x))))) #undef car #undef cdr -#define LENTH(n) (int narg, cl_object x) {\ - check_arg(1);\ +#define LENTH(n) (cl_object x) {\ return1(nth(n, x));\ } cl_return @fifth LENTH(4) @@ -754,8 +697,8 @@ sublis(cl_object alist, cl_object tree) cs_check(alist); loop_for_in(x) { - item_compared = car(CAR(x)); - if (TEST(tree)) return(cdr(CAR(x))); + item_compared = cl_car(CAR(x)); + if (TEST(tree)) return(cl_cdr(CAR(x))); } end_loop_for_in; if (CONSP(tree)) return(CONS(sublis(alist, CAR(tree)), sublis(alist, CDR(tree)))); @@ -785,7 +728,7 @@ nsublis(cl_object alist, cl_object *treep) cs_check(alist); loop_for_in(x) { - item_compared = car(CAR(x)); + item_compared = cl_car(CAR(x)); if (TEST(*treep)) { *treep = CDAR(x); return; diff --git a/src/c/load.d b/src/c/load.d index 72d872496..db30ff66e 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -21,13 +21,15 @@ #endif #ifdef ENABLE_DLOPEN -@(defun si::load_binary (filename verbose print) +cl_object +si_load_binary(cl_object filename, cl_object verbose, cl_object print) +{ cl_object block; cl_object basename; cl_object prefix; -@ + /* We need the full pathname */ - filename = coerce_to_filename(truename(filename)); + filename = coerce_to_filename(cl_truename(filename)); /* Try to load shared object file */ block = cl_alloc_object(t_codeblock); @@ -52,8 +54,8 @@ make_simple_string("init_"), prefix, make_simple_string("_")); - basename = coerce_to_pathname(filename); - basename = @pathname-name(1,basename); + basename = cl_pathname(filename); + basename = cl_pathname_name(basename); basename = @si::string-concatenate(2, prefix, @string-upcase(1,basename)); block->cblock.entry = dlsym(block->cblock.handle, basename->string.self); @@ -66,12 +68,14 @@ GO_ON: read_VV(block, block->cblock.entry); @(return Cnil) -@) +} #endif /* ENABLE_DLOPEN */ -@(defun si::load_source (source verbose print) +cl_object +si_load_source(cl_object source, cl_object verbose, cl_object print) +{ cl_object x, strm; -@ + /* Source may be either a stream or a filename */ if (type_of(source) != t_pathname && type_of(source) != t_string) { /* INV: if "source" is not a valid stream, file.d will complain */ @@ -109,7 +113,7 @@ GO_ON: close_stream(strm, TRUE); frs_pop(); @(return Cnil) -@) +} @(defun load (source &key (verbose symbol_value(@'*load-verbose*')) @@ -140,7 +144,7 @@ GO_ON: if (!file_exists(filename)) { filename = Cnil; } else { - function = cdr(assoc(pathname->pathname.type, hooks)); + function = cl_cdr(assoc(pathname->pathname.type, hooks)); } } else loop_for_in(hooks) { /* Otherwise try with known extensions until a matching @@ -175,7 +179,7 @@ NOT_A_FILENAME: unwind(nlj_fr, nlj_tag); } if (Null(function)) - ok = @si::load-source(3, filename, verbose, print); + ok = si_load_source(filename, verbose, print); else ok = funcall(4, function, filename, verbose, print); if (!Null(ok)) @@ -195,25 +199,19 @@ NOT_A_FILENAME: void init_load(void) { - cl_object load_source, load_binary; - SYM_VAL(@'*load-verbose*') = Ct; SYM_VAL(@'*load-print*') = Cnil; #ifdef PDE SYM_VAL(@'si::*source-pathname*') = Cnil; #endif - load_source = make_si_ordinary("LOAD-SOURCE"); + SYM_VAL(@'si::*load-hooks*') = cl_list(4, #ifdef ENABLE_DLOPEN - load_binary = make_si_ordinary("LOAD-BINARY"); + CONS(make_simple_string("so"), @'si::load-binary'), #endif - SYM_VAL(@'si::*load-hooks*') = list(4, -#ifdef ENABLE_DLOPEN - CONS(make_simple_string("so"), load_binary), -#endif - CONS(make_simple_string("lsp"), load_source), - CONS(make_simple_string("lisp"), load_source), - CONS(Cnil, load_source)); + CONS(make_simple_string("lsp"), @'si::load-source'), + CONS(make_simple_string("lisp"), @'si::load-source'), + CONS(Cnil, @'si::load-source')); #ifdef ENABLE_DLOPEN if (dlopen(NULL, RTLD_NOW|RTLD_GLOBAL) == NULL) diff --git a/src/c/macros.d b/src/c/macros.d index b6219e63e..c213378fb 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -31,9 +31,12 @@ static cl_object search_symbol_macro(cl_object name, cl_object env) { cl_object record = assq(name, CAR(env)); - if (CONSP(record) && CADR(record) == @'si::symbol-macro') + if (Null(record)) + return get(name, @'si::symbol-macro', Cnil); + else if (CADR(record) == @'si::symbol-macro') return CADDR(record); - return Cnil; + else + return Cnil; } cl_object diff --git a/src/c/main.d b/src/c/main.d index 75edf74b7..14b731e1d 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -114,30 +114,37 @@ cl_boot(int argc, char **argv) exit(i); @) -@(defun si::argc () -@ +cl_object +si_argc() +{ @(return MAKE_FIXNUM(ARGC)) -@) +} -@(defun si::argv (index) +cl_object +si_argv(cl_object index) +{ cl_fixnum i; -@ + if (!FIXNUMP(index) || (i = fix(index)) < 0 || i >= ARGC) FEerror("Illegal argument index: ~S.", 1, index); @(return make_string_copy(ARGV[i])) -@) +} -@(defun si::getenv (var) +cl_object +si_getenv(cl_object var) +{ const char *value; -@ + assert_type_string(var); value = getenv(var->string.self); @(return ((value == NULL)? Cnil : make_string_copy(value))) -@) +} -@(defun si::setenv (var value) +cl_object +si_setenv(cl_object var, cl_object value) +{ cl_fixnum ret_val; -@ + assert_type_string(var); if (value == Cnil) { /* Remove the variable when setting to nil, so that @@ -153,12 +160,13 @@ cl_boot(int argc, char **argv) CEerror("SI:SETENV failed: insufficient space in environment.", 1, "Continue anyway"); @(return (value)) -@) +} -@(defun si::pointer (x) -@ +cl_object +si_pointer(cl_object x) +{ @(return make_unsigned_integer((cl_index)x)) -@) +} void init_main(void) diff --git a/src/c/multival.d b/src/c/multival.d index 24d445431..44b3bae08 100644 --- a/src/c/multival.d +++ b/src/c/multival.d @@ -28,8 +28,9 @@ returnn(VALUES(0)); @) -@(defun values_list (list) -@ +cl_object +cl_values_list(cl_object list) +{ VALUES(0) = Cnil; for (NValues=0; !endp(list); list=CDR(list)) { if (NValues == VSSIZE) @@ -37,10 +38,10 @@ VALUES(NValues++) = CAR(list); } returnn(VALUES(0)); -@) +} void init_multival(void) { - make_constant("MULTIPLE-VALUES-LIMIT",MAKE_FIXNUM(32)); + SYM_VAL(@'MULTIPLE-VALUES-LIMIT') = MAKE_FIXNUM(32); } diff --git a/src/c/num_arith.d b/src/c/num_arith.d index 3f51db9b5..f02beaff9 100644 --- a/src/c/num_arith.d +++ b/src/c/num_arith.d @@ -497,8 +497,9 @@ number_minus(cl_object x, cl_object y) } } -@(defun conjugate (c) -@ +cl_object +cl_conjugate(cl_object c) +{ switch (type_of(c)) { case t_complex: c = make_complex(c->complex.real, @@ -513,7 +514,7 @@ number_minus(cl_object x, cl_object y) FEtype_error_number(c); } @(return c) -@) +} cl_object number_negate(cl_object x) @@ -777,10 +778,12 @@ get_gcd(cl_object x, cl_object y) } /* (1+ x) */ -@(defun 1+ (x) -@ /* INV: type check is in one_plus() */ +cl_object +@1+(cl_object x) +{ + /* INV: type check is in one_plus() */ @(return one_plus(x)) -@) +} cl_object @@ -823,11 +826,11 @@ one_plus(cl_object x) } /* (1- x) */ -@(defun 1- (x) -@ /* INV: type check is in one_minus() */ +cl_object +@1-(cl_object x) +{ /* INV: type check is in one_minus() */ @(return one_minus(x)) -@) - +} cl_object one_minus(cl_object x) diff --git a/src/c/num_co.d b/src/c/num_co.d index 8de36f7bd..1bf086eb6 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -117,9 +117,11 @@ number_remainder(cl_object x, cl_object y, cl_object q) @(return x) @) -@(defun numerator (x) +cl_object +cl_numerator(cl_object x) +{ cl_object out; -@ + switch (type_of(x)) { case t_ratio: out = x->ratio.num; @@ -132,11 +134,13 @@ number_remainder(cl_object x, cl_object y, cl_object q) FEwrong_type_argument(@'rational', x); } @(return out) -@) +} -@(defun denominator (x) +cl_object +cl_denominator(cl_object x) +{ cl_object out; -@ + switch (type_of(x)) { case t_ratio: out = x->ratio.den; @@ -149,7 +153,7 @@ number_remainder(cl_object x, cl_object y, cl_object q) FEwrong_type_argument(@'rational', x); } @(return out) -@) +} cl_object floor1(cl_object x) @@ -675,26 +679,28 @@ round2(cl_object x, cl_object y) @) -@(defun mod (x y) -@ +cl_object +cl_mod(cl_object x, cl_object y) +{ /* INV: #'floor always outputs two values */ @floor(2, x, y); @(return VALUES(1)) -@) +} - -@(defun rem (x y) -@ +cl_object +cl_rem(cl_object x, cl_object y) +{ @truncate(2, x, y); @(return VALUES(1)) -@) +} - -@(defun decode_float (x) +cl_object +cl_decode_float(cl_object x) +{ double d; int e, s; cl_type tx = type_of(x); -@ + switch (tx) { case t_shortfloat: { float d = sf(x); @@ -724,12 +730,13 @@ round2(cl_object x, cl_object y) FEtype_error_float(x); } @(return x MAKE_FIXNUM(e) make_shortfloat(s)) -@) +} - -@(defun scale_float (x y) +cl_object +cl_scale_float(cl_object x, cl_object y) +{ int k; -@ + if (FIXNUMP(y)) k = fix(y); else @@ -745,17 +752,17 @@ round2(cl_object x, cl_object y) FEtype_error_float(x); } @(return x) -@) +} - -@(defun float_radix (x) +cl_object +cl_float_radix(cl_object x) +{ cl_type t = type_of(x); -@ + if (t != t_shortfloat && t != t_longfloat) FEtype_error_float(x); @(return MAKE_FIXNUM(2)) -@) - +} @(defun float_sign (x &optional (y x)) int negativep; @@ -782,8 +789,9 @@ round2(cl_object x, cl_object y) } @) -@(defun float_digits (x) -@ +cl_object +cl_float_digits(cl_object x) +{ switch (type_of(x)) { case t_shortfloat: x = MAKE_FIXNUM(6); @@ -795,26 +803,28 @@ round2(cl_object x, cl_object y) FEtype_error_float(x); } @(return x) -@) +} - -@(defun float_precision (x) -@ +cl_object +cl_float_precision(cl_object x) +{ switch (type_of(x)) { case t_shortfloat: - @(return ((sf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(24))) + x = (sf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(24); case t_longfloat: - @(return ((lf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(53))) + x = (lf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(53); default: FEtype_error_float(x); } -@) + @(return x) +} - -@(defun integer_decode_float (x) +cl_object +cl_integer_decode_float(cl_object x) +{ unsigned int h, l; int e, s; -@ + switch (type_of(x)) { case t_longfloat: { double d = lf(x); @@ -858,7 +868,7 @@ round2(cl_object x, cl_object y) FEtype_error_float(x); } @(return x MAKE_FIXNUM(e) MAKE_FIXNUM(s)) -@) +} @(defun complex (r &optional (i MAKE_FIXNUM(0))) @@ -866,9 +876,9 @@ round2(cl_object x, cl_object y) @(return make_complex(r, i)) @) - -@(defun realpart (x) -@ +cl_object +cl_realpart(cl_object x) +{ switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -883,11 +893,11 @@ round2(cl_object x, cl_object y) FEtype_error_number(x); } @(return x) -@) +} - -@(defun imagpart (x) -@ +cl_object +cl_imagpart(cl_object x) +{ switch (type_of(x)) { case t_fixnum: case t_bignum: @@ -907,7 +917,7 @@ round2(cl_object x, cl_object y) FEtype_error_number(x); } @(return x) -@) +} void init_num_co(void) diff --git a/src/c/num_log.d b/src/c/num_log.d index 5aa2c0146..e9bb056f8 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -252,10 +252,11 @@ b_c2_op(cl_fixnum i, cl_fixnum j) return(~j); } -@(defun lognot (x) -@ +cl_object +cl_lognot(cl_object x) +{ return @logxor(2,x,MAKE_FIXNUM(-1)); -@) +} static cl_fixnum count_bits(cl_object x) @@ -354,39 +355,47 @@ int_bit_length(int i) @(return log_op(narg, eqv_op, nums)) @) -@(defun lognand (x y) -@ +cl_object +cl_lognand(cl_object x, cl_object y) +{ @(return log_op2(x, y, nand_op)) -@) +} -@(defun lognor (x y) -@ +cl_object +cl_lognor(cl_object x, cl_object y) +{ @(return log_op2(x, y, nor_op)) -@) +} -@(defun logandc1 (x y) -@ +cl_object +cl_logandc1(cl_object x, cl_object y) +{ @(return log_op2(x, y, andc1_op)) -@) +} -@(defun logandc2 (x y) -@ +cl_object +cl_logandc2(cl_object x, cl_object y) +{ @(return log_op2(x, y, andc2_op)) -@) +} -@(defun logorc1 (x y) -@ +cl_object +cl_logorc1(cl_object x, cl_object y) +{ @(return log_op2(x, y, orc1_op)) -@) +} -@(defun logorc2 (x y) -@ +cl_object +cl_logorc2(cl_object x, cl_object y) +{ @(return log_op2(x, y, orc2_op)) -@) +} -@(defun boole (o x y) +cl_object +cl_boole(cl_object o, cl_object x, cl_object y) +{ bit_operator op; -@ + /* INV: log_op() checks types */ switch(fixint(o)) { case BOOLCLR: op = b_clr_op; break; @@ -410,12 +419,14 @@ int_bit_length(int i) 1, o); } @(return log_op2(x, y, op)) -@) +} -@(defun logbitp (p x) +cl_object +cl_logbitp(cl_object p, cl_object x) +{ bool i; int n; -@ + assert_type_integer(x); if (FIXNUMP(p)) { cl_fixnum n = fixnnint(p); @@ -433,12 +444,14 @@ int_bit_length(int i) i = (big_sign(x) < 0); } @(return (i ? Ct : Cnil)) -@) +} -@(defun ash (x y) +cl_object +cl_ash(cl_object x, cl_object y) +{ cl_object r; int sign_x; -@ + assert_type_integer(x); assert_type_integer(y); if (FIXNUMP(y)) @@ -469,16 +482,19 @@ int_bit_length(int i) FEerror("Insufficient memory.", 0); } @(return r) -@) +} -@(defun logcount (x) -@ +cl_object +cl_logcount(cl_object x) +{ @(return MAKE_FIXNUM(count_bits(x))) -@) +} -@(defun integer_length (x) +cl_object +cl_integer_length(cl_object x) +{ int count, i; -@ + switch (type_of(x)) { case t_fixnum: i = fix(x); @@ -494,7 +510,7 @@ int_bit_length(int i) FEtype_error_integer(x); } @(return MAKE_FIXNUM(count)) -@) +} void init_num_log(void) @@ -517,7 +533,9 @@ init_num_log(void) SYM_VAL(@'BOOLE-ORC2') = MAKE_FIXNUM(BOOLORC2); } -@(defun si::bit_array_op (o x y r) +cl_object +si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r) +{ cl_fixnum i, j, n, d; cl_object r0; bit_operator op; @@ -525,7 +543,7 @@ init_num_log(void) int xi, yi, ri; byte *xp, *yp, *rp; int xo, yo, ro; -@ + if (type_of(x) == t_bitvector) { d = x->vector.dim; xp = x->vector.self.bit; @@ -559,7 +577,7 @@ init_num_log(void) } L1: if (Null(r)) { - r = @si::make-vector(6, @'bit', MAKE_FIXNUM(d), Cnil, Cnil, Cnil, Cnil); + r = si_make_vector(@'bit', MAKE_FIXNUM(d), Cnil, Cnil, Cnil, Cnil); } } else { if (type_of(x) != t_array) @@ -695,5 +713,4 @@ init_num_log(void) @(return r0) ERROR: FEerror("Illegal arguments for bit-array operation.", 0); -@) - +} diff --git a/src/c/num_pred.d b/src/c/num_pred.d index ff14554d0..17e4767d7 100644 --- a/src/c/num_pred.d +++ b/src/c/num_pred.d @@ -116,27 +116,32 @@ number_evenp(cl_object x) FEtype_error_integer(x); } -@(defun zerop (x) -@ /* INV: number_zerop() checks type */ +cl_object +cl_zerop(cl_object x) +{ /* INV: number_zerop() checks type */ @(return (number_zerop(x) ? Ct : Cnil)) -@) +} -@(defun plusp (x) -@ /* INV: number_plusp() checks type */ +cl_object +cl_plusp(cl_object x) +{ /* INV: number_plusp() checks type */ @(return (number_plusp(x) ? Ct : Cnil)) -@) +} -@(defun minusp (x) -@ /* INV: number_minusp() checks type */ +cl_object +cl_minusp(cl_object x) +{ /* INV: number_minusp() checks type */ @(return (number_minusp(x) ? Ct : Cnil)) -@) +} -@(defun oddp (x) -@ /* INV: number_oddp() checks type */ +cl_object +cl_oddp(cl_object x) +{ /* INV: number_oddp() checks type */ @(return (number_oddp(x) ? Ct : Cnil)) -@) +} -@(defun evenp (x) -@ /* INV: number_evenp() checks_type */ +cl_object +cl_evenp(cl_object x) +{ /* INV: number_evenp() checks_type */ @(return (number_evenp(x) ? Ct : Cnil)) -@) +} diff --git a/src/c/num_rand.d b/src/c/num_rand.d index fb1328149..68af4cba1 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -94,10 +94,11 @@ advance_random_state(cl_object rs) @(return make_random_state(rs)) @) -@(defun random_state_p (x) -@ +cl_object +cl_random_state_p(cl_object x) +{ @(return ((type_of(x) == t_random) ? Ct : Cnil)) -@) +} void init_num_rand(void) diff --git a/src/c/num_sfun.d b/src/c/num_sfun.d index 520d5eaec..7a010d991 100644 --- a/src/c/num_sfun.d +++ b/src/c/num_sfun.d @@ -56,31 +56,31 @@ fixnum_expt(cl_fixnum x, cl_fixnum y) } cl_object -number_exp(cl_object x) +cl_exp(cl_object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return(make_shortfloat(expf(number_to_double(x)))); + return1(make_shortfloat(expf(number_to_double(x)))); case t_shortfloat: - return(make_shortfloat(expf(sf(x)))); + return1(make_shortfloat(expf(sf(x)))); case t_longfloat: - return(make_longfloat(exp(lf(x)))); + return1(make_longfloat(exp(lf(x)))); case t_complex: { cl_object y, y1; y = x->complex.imag; x = x->complex.real; - x = number_exp(x); - y1 = number_cos(y); - y = number_sin(y); + x = cl_exp(x); + y1 = cl_cos(y); + y = cl_sin(y); y = make_complex(y1, y); x = number_times(x, y); - return(x); + return1(x); } default: @@ -89,7 +89,7 @@ number_exp(cl_object x) } cl_object -number_expt(cl_object x, cl_object y) +cl_expt(cl_object x, cl_object y) { cl_type tx, ty; cl_object z; @@ -97,18 +97,18 @@ number_expt(cl_object x, cl_object y) if (y == MAKE_FIXNUM(0)) switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return(MAKE_FIXNUM(1)); + return1(MAKE_FIXNUM(1)); case t_shortfloat: - return(make_shortfloat(1.0)); + return1(make_shortfloat(1.0)); case t_longfloat: - return(make_longfloat(1.0)); + return1(make_longfloat(1.0)); case t_complex: - z = number_expt(x->complex.real, y); + z = cl_expt(x->complex.real, y); z = make_complex(z, MAKE_FIXNUM(0)); - return(z); + return1(z); default: FEtype_error_number(x); @@ -117,14 +117,14 @@ number_expt(cl_object x, cl_object y) if (number_zerop(x)) { if (!number_plusp(ty==t_complex?y->complex.real:y)) FEerror("Cannot raise zero to the power ~S.", 1, y); - return(number_times(x, y)); + return1(number_times(x, y)); } if (ty == t_fixnum || ty == t_bignum) { if (number_minusp(y)) { z = number_negate(y); - z = number_expt(x, z); + z = cl_expt(x, z); z = number_divide(MAKE_FIXNUM(1), z); - return(z); + return1(z); } z = MAKE_FIXNUM(1); do { @@ -134,16 +134,16 @@ number_expt(cl_object x, cl_object y) x = number_times(x, x); y = integer_divide(y, MAKE_FIXNUM(2)); } while (number_plusp(y)); - return z; + return1(z); } - z = number_nlog(x); + z = cl_log1(x); z = number_times(z, y); - z = number_exp(z); - return(z); + z = cl_exp(z); + return1(z); } cl_object -number_nlog(cl_object x) +cl_log1(cl_object x) { cl_object r, i, a, p; @@ -163,13 +163,13 @@ number_nlog(cl_object x) case t_fixnum: case t_bignum: case t_ratio: - return(make_shortfloat(logf(number_to_double(x)))); + return1(make_shortfloat(logf(number_to_double(x)))); case t_shortfloat: - return(make_shortfloat(logf(sf(x)))); + return1(make_shortfloat(logf(sf(x)))); case t_longfloat: - return(make_longfloat(log(lf(x)))); + return1(make_longfloat(log(lf(x)))); default: FEtype_error_number(x); @@ -178,41 +178,41 @@ COMPLEX: a = number_times(r, r); p = number_times(i, i); a = number_plus(a, p); - a = number_nlog(a); + a = cl_log1(a); a = number_divide(a, MAKE_FIXNUM(2)); - p = number_atan2(i, r); + p = cl_atan2(i, r); x = make_complex(a, p); - return(x); + return1(x); } cl_object -number_log(cl_object x, cl_object y) +cl_log2(cl_object x, cl_object y) { if (number_zerop(y)) FEerror("Zero is the logarithmic singularity.", 0); - return(number_divide(number_nlog(y), number_nlog(x))); + return1(number_divide(cl_log1(y), cl_log1(x))); } cl_object -number_sqrt(cl_object x) +cl_sqrt(cl_object x) { cl_object z; if (type_of(x) == t_complex) goto COMPLEX; if (number_minusp(x)) - return make_complex(MAKE_FIXNUM(0), number_sqrt(number_negate(x))); + return1(make_complex(MAKE_FIXNUM(0), cl_sqrt(number_negate(x)))); switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return(make_shortfloat(sqrtf(number_to_double(x)))); + return1(make_shortfloat(sqrtf(number_to_double(x)))); case t_shortfloat: - return(make_shortfloat(sqrtf(sf(x)))); + return1(make_shortfloat(sqrtf(sf(x)))); case t_longfloat: - return(make_longfloat(sqrt(lf(x)))); + return1(make_longfloat(sqrt(lf(x)))); default: FEtype_error_number(x); @@ -220,12 +220,12 @@ number_sqrt(cl_object x) COMPLEX: z = make_ratio(MAKE_FIXNUM(1), MAKE_FIXNUM(2)); - z = number_expt(x, z); - return(z); + z = cl_expt(x, z); + return1(z); } cl_object -number_atan2(cl_object y, cl_object x) +cl_atan2(cl_object y, cl_object x) { cl_object z; double dy, dx, dz; @@ -257,47 +257,47 @@ number_atan2(cl_object y, cl_object x) z = make_longfloat(dz); else z = make_shortfloat(dz); - return(z); + return1(z); } cl_object -number_atan(cl_object y) +cl_atan1(cl_object y) { cl_object z, z1; if (type_of(y) == t_complex) { #if 0 /* FIXME! ANSI states it should be this first part */ z = number_times(imag_unit, y); - z = number_nlog(one_plus(z)) + - number_nlog(number_minus(MAKE_FIXNUM(1), z)); + z = cl_log1(one_plus(z)) + + cl_log1(number_minus(MAKE_FIXNUM(1), z)); z = number_divide(z, number_times(MAKE_FIXNUM(2), imag_unit)); #else z = number_times(imag_unit, y); z = one_plus(z); z1 = number_times(y, y); z1 = one_plus(z1); - z1 = number_sqrt(z1); + z1 = cl_sqrt(z1); z = number_divide(z, z1); - z = number_nlog(z); + z = cl_log1(z); z = number_times(minus_imag_unit, z); #endif /* ANSI */ - return(z); + return1(z); } - return(number_atan2(y, MAKE_FIXNUM(1))); + return1(cl_atan2(y, MAKE_FIXNUM(1))); } cl_object -number_sin(cl_object x) +cl_sin(cl_object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return(make_shortfloat(sinf(number_to_double(x)))); + return1(make_shortfloat(sinf(number_to_double(x)))); case t_shortfloat: - return(make_shortfloat(sinf(sf(x)))); + return1(make_shortfloat(sinf(sf(x)))); case t_longfloat: - return(make_longfloat(sin(lf(x)))); + return1(make_longfloat(sin(lf(x)))); case t_complex: { /* z = x + I y @@ -309,8 +309,8 @@ number_sin(cl_object x) double a = sin(dx) * cosh(dy); double b = cos(dx) * sinh(dy); if (type_of(x->complex.real) != t_longfloat) - return make_complex(make_shortfloat(a), make_shortfloat(b)); - return make_complex(make_longfloat(a), make_longfloat(b)); + return1(make_complex(make_shortfloat(a), make_shortfloat(b))); + return1(make_complex(make_longfloat(a), make_longfloat(b))); } default: FEtype_error_number(x); @@ -318,17 +318,17 @@ number_sin(cl_object x) } cl_object -number_cos(cl_object x) +cl_cos(cl_object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return(make_shortfloat(cosf(number_to_double(x)))); + return1(make_shortfloat(cosf(number_to_double(x)))); case t_shortfloat: - return(make_shortfloat(cosf(sf(x)))); + return1(make_shortfloat(cosf(sf(x)))); case t_longfloat: - return(make_longfloat(cos(lf(x)))); + return1(make_longfloat(cos(lf(x)))); case t_complex: { /* z = x + I y @@ -339,8 +339,8 @@ number_cos(cl_object x) double a = cos(dx) * cosh(dy); double b = -sin(dx) * sinh(dy); if (type_of(x->complex.real) != t_longfloat) - return make_complex(make_shortfloat(a), make_shortfloat(b)); - return make_complex(make_longfloat(a), make_longfloat(b)); + return1(make_complex(make_shortfloat(a), make_shortfloat(b))); + return1(make_complex(make_longfloat(a), make_longfloat(b))); } default: FEtype_error_number(x); @@ -348,21 +348,21 @@ number_cos(cl_object x) } cl_object -number_tan(cl_object x) +cl_tan(cl_object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return(make_shortfloat(tanf(number_to_double(x)))); + return1(make_shortfloat(tanf(number_to_double(x)))); case t_shortfloat: - return(make_shortfloat(tanf(sf(x)))); + return1(make_shortfloat(tanf(sf(x)))); case t_longfloat: - return(make_longfloat(tan(lf(x)))); + return1(make_longfloat(tan(lf(x)))); case t_complex: { - cl_object a = number_sin(x); - cl_object b = number_cos(x); - return number_divide(a, b); + cl_object a = cl_sin(x); + cl_object b = cl_cos(x); + return1(number_divide(a, b)); } default: FEtype_error_number(x); @@ -370,18 +370,18 @@ number_tan(cl_object x) } cl_object -number_sinh(cl_object x) +cl_sinh(cl_object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return make_shortfloat(sinhf(number_to_double(x))); + return1(make_shortfloat(sinhf(number_to_double(x)))); case t_shortfloat: - return make_shortfloat(sinhf(sf(x))); + return1(make_shortfloat(sinhf(sf(x)))); case t_longfloat: - return make_longfloat(sinh(lf(x))); + return1(make_longfloat(sinh(lf(x)))); case t_complex: { /* z = x + I y @@ -394,8 +394,8 @@ number_sinh(cl_object x) double a = sinh(dx) * cos(dy); double b = cosh(dx) * sin(dy); if (type_of(x->complex.real) != t_longfloat) - return make_complex(make_shortfloat(a), make_shortfloat(b)); - return make_complex(make_longfloat(a), make_longfloat(b)); + return1(make_complex(make_shortfloat(a), make_shortfloat(b))); + return1(make_complex(make_longfloat(a), make_longfloat(b))); } default: FEtype_error_number(x); @@ -403,17 +403,17 @@ number_sinh(cl_object x) } cl_object -number_cosh(cl_object x) +cl_cosh(cl_object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return make_shortfloat(coshf(number_to_double(x))); + return1(make_shortfloat(coshf(number_to_double(x)))); case t_shortfloat: - return make_shortfloat(coshf(sf(x))); + return1(make_shortfloat(coshf(sf(x)))); case t_longfloat: - return make_longfloat(cosh(lf(x))); + return1(make_longfloat(cosh(lf(x)))); case t_complex: { /* z = x + I y @@ -426,8 +426,8 @@ number_cosh(cl_object x) double a = cosh(dx) * cos(dy); double b = sinh(dx) * sin(dy); if (type_of(x->complex.real) != t_longfloat) - return make_complex(make_shortfloat(a), make_shortfloat(b)); - return make_complex(make_longfloat(a), make_longfloat(b)); + return1(make_complex(make_shortfloat(a), make_shortfloat(b))); + return1(make_complex(make_longfloat(a), make_longfloat(b))); } default: FEtype_error_number(x); @@ -435,84 +435,39 @@ number_cosh(cl_object x) } cl_object -number_tanh(cl_object x) +cl_tanh(cl_object x) { switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: - return(make_shortfloat(tanhf(number_to_double(x)))); + return1(make_shortfloat(tanhf(number_to_double(x)))); case t_shortfloat: - return(make_shortfloat(tanhf(sf(x)))); + return1(make_shortfloat(tanhf(sf(x)))); case t_longfloat: - return(make_longfloat(tanh(lf(x)))); + return1(make_longfloat(tanh(lf(x)))); case t_complex: { - cl_object a = number_sinh(x); - cl_object b = number_cosh(x); - return number_divide(a, b); + cl_object a = cl_sinh(x); + cl_object b = cl_cosh(x); + return1(number_divide(a, b)); } default: FEtype_error_number(x); } } -@(defun exp (x) -@ /* INV: type check in number_exp() */ - @(return number_exp(x)) -@) - -@(defun expt (x y) -@ /* INV: type check in number_expt() */ - @(return number_expt(x, y)) -@) - @(defun log (x &optional (y OBJNULL)) -@ /* INV: type check in number_nlog() and number_log() */ +@ /* INV: type check in cl_log1() and cl_log2() */ if (y == OBJNULL) - @(return number_nlog(x)) - @(return number_log(y, x)) -@) - -@(defun sqrt (x) -@ /* INV: type check in number_sqrt() */ - @(return number_sqrt(x)) -@) - -@(defun sin (x) -@ /* INV: type check in number_sin() */ - @(return number_sin(x)) -@) - -@(defun cos (x) -@ /* INV: type check in number_cos() */ - @(return number_cos(x)) -@) - -@(defun tan (x) -@ /* INV: type check in number_tan() */ - @(return number_tan(x)) + @(return cl_log1(x)) + @(return cl_log2(y, x)) @) @(defun atan (x &optional (y OBJNULL)) -@ /* INV: type check in number_atan() & number_atan2() */ +@ /* INV: type check in cl_atan() & cl_atan2() */ if (y == OBJNULL) - @(return number_atan(x)) - @(return number_atan2(x, y)) -@) - -@(defun sinh (x) -@ /* INV: type check in number_sin() */ - @(return number_sinh(x)) -@) - -@(defun cosh (x) -@ /* INV: type check in number_cos() */ - @(return number_cosh(x)) -@) - -@(defun tanh (x) -@ /* INV: type check in number_tan() */ - @(return number_tanh(x)) + @(return cl_atan1(x)) + @(return cl_atan2(x, y)) @) void diff --git a/src/c/number.d b/src/c/number.d index d73ef997f..d28df541f 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -49,7 +49,7 @@ fixnnint(cl_object x) } FEcondition(9, @'simple-type-error', @':format-control', make_simple_string("Not a non-negative fixnum ~S"), - @':format-arguments', list(1,x), + @':format-arguments', cl_list(1,x), @':expected-type', @'fixnum', @':datum', x); } diff --git a/src/c/package.d b/src/c/package.d index 869d8fb11..325653df2 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -96,7 +96,7 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) cl_object x, y; cl_index i; - name = coerce_to_string(name); + name = cl_string(name); assert_type_proper_list(nicknames); assert_type_proper_list(use_list); @@ -110,7 +110,7 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) x->pack.usedby = Cnil; x->pack.locked = FALSE; for (; !endp(nicknames); nicknames = CDR(nicknames)) { - cl_object nick = coerce_to_string(CAR(nicknames)); + cl_object nick = cl_string(CAR(nicknames)); if (find_package(nick) != Cnil) package_already(nick); x->pack.nicknames = CONS(nick, x->pack.nicknames); @@ -144,8 +144,8 @@ rename_package(cl_object x, cl_object name, cl_object nicknames) Marco Antoniotti 19951028 */ - x = coerce_to_package(x); - name = coerce_to_string(name); + x = si_coerce_to_package(x); + name = cl_string(name); y = find_package(name); if ((y != Cnil) && (y != x)) package_already(name); @@ -160,7 +160,7 @@ rename_package(cl_object x, cl_object name, cl_object nicknames) continue; if (y != Cnil) package_already(nick); - x->pack.nicknames = CONS(coerce_to_string(nick), x->pack.nicknames); + x->pack.nicknames = CONS(cl_string(nick), x->pack.nicknames); } return(x); } @@ -190,12 +190,9 @@ find_package(cl_object name) } cl_object -coerce_to_package(cl_object p) +si_coerce_to_package(cl_object p) { - cl_object pp; - if (type_of(p) == t_package) - return(p); - pp = find_package(p); + cl_object pp = find_package(p); if (!Null(pp)) return (pp); FEwrong_type_argument(@'package', p); @@ -232,7 +229,7 @@ intern(cl_object name, cl_object p, int *intern_flag) cl_object s, ul; assert_type_string(name); - p = coerce_to_package(p); + p = si_coerce_to_package(p); s = gethash_safe(name, p->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = EXTERNAL; @@ -275,7 +272,7 @@ find_symbol(cl_object name, cl_object p, int *intern_flag) cl_object s, ul; name = coerce_to_string_designator(name); - p = coerce_to_package(p); + p = si_coerce_to_package(p); s = gethash_safe(name, p->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = EXTERNAL; @@ -315,7 +312,7 @@ unintern(cl_object s, cl_object p) cl_object x, y, l, hash; assert_type_symbol(s); - p = coerce_to_package(p); + p = si_coerce_to_package(p); hash = p->pack.internal; x = gethash_safe(s->symbol.name, hash, OBJNULL); if (x == s) { @@ -358,19 +355,19 @@ UNINTERN: } void -cl_export(cl_object s, cl_object p) +cl_export2(cl_object s, cl_object p) { cl_object x, l, hash = OBJNULL; int intern_flag; BEGIN: assert_type_symbol(s); - p = coerce_to_package(p); + p = si_coerce_to_package(p); x = find_symbol(s, p, &intern_flag); if (!intern_flag) FEerror("The symbol ~S is not accessible from ~S.", 2, s, p); if (x != s) { - cl_import(s, p); /* signals an error */ + cl_import2(s, p); /* signals an error */ goto BEGIN; } if (intern_flag == EXTERNAL) @@ -397,7 +394,7 @@ delete_package(cl_object p) cl_object hash, list; cl_index i; - p = coerce_to_package(p); + p = si_coerce_to_package(p); if (p == lisp_package || p == keyword_package) FEerror("Cannot remove package ~S", 1, p->pack.name); for (list = p->pack.uses; !endp(list); list = CDR(list)) @@ -417,7 +414,7 @@ delete_package(cl_object p) } void -cl_unexport(cl_object s, cl_object p) +cl_unexport2(cl_object s, cl_object p) { int intern_flag; cl_object x; @@ -425,7 +422,7 @@ cl_unexport(cl_object s, cl_object p) if (p == keyword_package) FEerror("Cannot unexport a symbol from the keyword.", 0); assert_type_symbol(s); - p = coerce_to_package(p); + p = si_coerce_to_package(p); x = find_symbol(s, p, &intern_flag); if (intern_flag != EXTERNAL || x != s) /* According to ANSI & Cltl, internal symbols are @@ -436,13 +433,13 @@ cl_unexport(cl_object s, cl_object p) } void -cl_import(cl_object s, cl_object p) +cl_import2(cl_object s, cl_object p) { int intern_flag; cl_object x; assert_type_symbol(s); - p = coerce_to_package(p); + p = si_coerce_to_package(p); x = find_symbol(s, p, &intern_flag); if (intern_flag) { if (x != s) @@ -465,7 +462,7 @@ shadowing_import(cl_object s, cl_object p) cl_object x; assert_type_symbol(s); - p = coerce_to_package(p); + p = si_coerce_to_package(p); x = find_symbol(s, p, &intern_flag); if (intern_flag && intern_flag != INHERITED) { if (x == s) { @@ -496,7 +493,7 @@ shadow(cl_object s, cl_object p) cl_object x; assert_type_symbol(s); - p = coerce_to_package(p); + p = si_coerce_to_package(p); x = find_symbol(s, p, &intern_flag); if (intern_flag != INTERNAL && intern_flag != EXTERNAL) { x = make_symbol(s); @@ -513,10 +510,10 @@ use_package(cl_object x, cl_object p) cl_index i, hash_length; int intern_flag; - x = coerce_to_package(x); + x = si_coerce_to_package(x); if (x == keyword_package) FEerror("Cannot use keyword package.", 0); - p = coerce_to_package(p); + p = si_coerce_to_package(p); if (p == keyword_package) FEerror("Cannot use in keyword package.", 0); if (p == x) @@ -543,8 +540,8 @@ a name conflict.", 4, x, p, here, there); void unuse_package(cl_object x, cl_object p) { - x = coerce_to_package(x); - p = coerce_to_package(p); + x = si_coerce_to_package(x); + p = si_coerce_to_package(p); delete_eq(x, &p->pack.uses); delete_eq(p, &x->pack.usedby); } @@ -555,36 +552,39 @@ unuse_package(cl_object x, cl_object p) @(return make_package(pack_name, nicknames, use)) @) -@(defun si::select_package (pack_name) +cl_object +si_select_package(cl_object pack_name) +{ cl_object p; -@ + /* INV: find_package()/in_package() perform type checks */ p = find_package(pack_name); if (Null(p)) FEerror("Package ~s not found", 1, pack_name); @(return (SYM_VAL(@'*package*') = p)) -@) +} -@(defun find_package (p) -@ +cl_object +cl_find_package(cl_object p) +{ @(return find_package(p)) -@) +} -@(defun package_name (p) -@ - /* INV: coerce_to_package() performs type checks */ +cl_object +cl_package_name(cl_object p) +{ /* FIXME: name should be a fresh one */ - p = coerce_to_package(p); + p = si_coerce_to_package(p); @(return p->pack.name) -@) +} -@(defun package_nicknames (p) -@ - /* INV: coerce_to_package() type checks */ +cl_object +cl_package_nicknames(cl_object p) +{ /* FIXME: list should be a fresh one */ - p = coerce_to_package(p); + p = si_coerce_to_package(p); @(return p->pack.nicknames) -@) +} @(defun rename_package (pack new_name &o new_nicknames) @ @@ -592,42 +592,43 @@ unuse_package(cl_object x, cl_object p) @(return rename_package(pack, new_name, new_nicknames)) @) -@(defun package_use_list (p) -@ - /* INV: coerce_to_package() type checks */ +cl_object +cl_package_use_list(cl_object p) +{ /* FIXME: list should be a fresh one */ - p = coerce_to_package(p); + p = si_coerce_to_package(p); @(return p->pack.uses) -@) +} -@(defun package_used_by_list (p) -@ - /* INV: coerce_to_package() type checks */ +cl_object +cl_package_used_by_list(cl_object p) +{ /* FIXME: list should be a fresh one */ - p = coerce_to_package(p); + p = si_coerce_to_package(p); @(return p->pack.usedby) -@) +} -@(defun package_shadowing_symbols (p) -@ - /* INV: coerce_to_package() type checks */ +cl_object +cl_package_shadowing_symbols(cl_object p) +{ /* FIXME: list should be a fresh one */ - p = coerce_to_package(p); + p = si_coerce_to_package(p); @(return p->pack.shadowings) -@) +} -@(defun si::package_lock (p t) -@ - /* INV: coerce_to_package() type checks */ - p = coerce_to_package(p); +cl_object +si_package_lock(cl_object p, cl_object t) +{ + p = si_coerce_to_package(p); p->pack.locked = (t != Cnil); @(return p) -@) +} -@(defun list_all_packages () -@ +cl_object +cl_list_all_packages() +{ @(return copy_list(package_list)) -@) +} @(defun intern (strng &optional (p current_package()) &aux sym) int intern_flag; @@ -669,13 +670,13 @@ BEGIN: case t_symbol: if (Null(symbols)) break; - cl_export(symbols, pack); + cl_export2(symbols, pack); break; case t_cons: - pack = coerce_to_package(pack); /* Saves time */ + pack = si_coerce_to_package(pack); for (l = symbols; !endp(l); l = CDR(l)) - cl_export(CAR(l), pack); + cl_export2(CAR(l), pack); break; default: @@ -693,13 +694,13 @@ BEGIN: case t_symbol: if (Null(symbols)) break; - cl_unexport(symbols, pack); + cl_unexport2(symbols, pack); break; case t_cons: - pack = coerce_to_package(pack); /* Saves time */ + pack = si_coerce_to_package(pack); for (l = symbols; !endp(l); l = CDR(l)) - cl_unexport(CAR(l), pack); + cl_unexport2(CAR(l), pack); break; default: @@ -717,13 +718,13 @@ BEGIN: case t_symbol: if (Null(symbols)) break; - cl_import(symbols, pack); + cl_import2(symbols, pack); break; case t_cons: - pack = coerce_to_package(pack); /* Saves time */ + pack = si_coerce_to_package(pack); for (l = symbols; !endp(l); l = CDR(l)) - cl_import(CAR(l), pack); + cl_import2(CAR(l), pack); break; default: @@ -745,7 +746,7 @@ BEGIN: break; case t_cons: - pack = coerce_to_package(pack); /* Saves time */ + pack = si_coerce_to_package(pack); for (l = symbols; !endp(l); l = CDR(l)) shadowing_import(CAR(l), pack); break; @@ -769,7 +770,7 @@ BEGIN: break; case t_cons: - pack = coerce_to_package(pack); /* Saves time */ + pack = si_coerce_to_package(pack); for (l = symbols; !endp(l); l = CDR(l)) shadow(CAR(l), pack); break; @@ -795,7 +796,7 @@ BEGIN: break; case t_cons: - pa = coerce_to_package(pa); /* Saves time */ + pa = si_coerce_to_package(pa); for (l = pack; !endp(l); l = CDR(l)) use_package(CAR(l), pa); break; @@ -822,7 +823,7 @@ BEGIN: break; case t_cons: - pa = coerce_to_package(pa); + pa = si_coerce_to_package(pa); for (l = pack; !endp(l); l = CDR(l)) unuse_package(CAR(l), pa); break; @@ -834,43 +835,49 @@ BEGIN: @(return Ct) @) -@(defun si::package_internal (p index) +cl_object +si_package_internal(cl_object p, cl_object index) +{ cl_fixnum j; cl_object hash; -@ - p = coerce_to_package(p); + + p = si_coerce_to_package(p); hash = p->pack.internal; if (!FIXNUMP(index) || (j = fix(index)) < 0 || j >= hash->hash.size) FEerror("~S is an illegal index to a package hashtable.", 1, index); @(return ((hash->hash.data[j].key != OBJNULL)? hash->hash.data[j].value : MAKE_FIXNUM(1))) -@) +} -@(defun si::package_external (p index) +cl_object +si_package_external(cl_object p, cl_object index) +{ cl_fixnum j; cl_object hash; -@ - p = coerce_to_package(p); + + p = si_coerce_to_package(p); hash = p->pack.external; if (!FIXNUMP(index) || (j = fix(index)) < 0 || j >= hash->hash.size) FEerror("~S is an illegal index to a package hashtable.", 1, index); @(return ((hash->hash.data[j].key != OBJNULL)? hash->hash.data[j].value : MAKE_FIXNUM(1))) -@) +} -@(defun si::package_size (p) -@ +cl_object +si_package_size(cl_object p) +{ assert_type_package(p); @(return MAKE_FIXNUM(p->pack.external->hash.size) MAKE_FIXNUM(p->pack.internal->hash.size)) -@) +} -@(defun delete_package (p) -@ +cl_object +cl_delete_package(cl_object p) +{ delete_package(p); -@) +} void init_package(void) @@ -911,10 +918,10 @@ init_package(void) #endif Cnil->symbol.hpack = lisp_package; - cl_import(Cnil, lisp_package); - cl_export(Cnil, lisp_package); + cl_import2(Cnil, lisp_package); + cl_export2(Cnil, lisp_package); Ct->symbol.hpack = lisp_package; - cl_import(Ct, lisp_package); - cl_export(Ct, lisp_package); + cl_import2(Ct, lisp_package); + cl_export2(Ct, lisp_package); } diff --git a/src/c/pathname.d b/src/c/pathname.d index ed1b0b6aa..abfcdf4d4 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -45,13 +45,13 @@ make_pathname(cl_object host, cl_object device, cl_object directory, switch (type_of(directory)) { case t_string: - directory = list(2, @':absolute', directory); + directory = cl_list(2, @':absolute', directory); break; case t_symbol: if (directory == Cnil) break; if (directory == @':wild') - directory = list(2, @':absolute', @':wild-inferiors'); + directory = cl_list(2, @':absolute', @':wild-inferiors'); error_directory(directory); break; case t_cons: @@ -344,7 +344,7 @@ parse_namestring(const char *s, cl_index start, cl_index end, cl_index *ep, if (!endp(path)) { if (CAR(path) == @':absolute') { /* According to ANSI CL, "/.." is erroneous */ - if (cadr(path) == @':up') + if (cl_cadr(path) == @':up') return Cnil; } else { /* If path is relative and we got here, then it @@ -371,7 +371,7 @@ parse_namestring(const char *s, cl_index start, cl_index end, cl_index *ep, } cl_object -coerce_to_pathname(cl_object x) +cl_pathname(cl_object x) { cl_object y; cl_index e; @@ -383,10 +383,10 @@ L: y = parse_namestring(x->string.self, 0, x->string.fillp, &e,Cnil); if (y == Cnil || e != x->string.fillp) FEerror("~S is not a valid pathname string", 1, x); - return(y); + return1(y); case t_pathname: - return(x); + return1(x); case t_stream: switch ((enum smmode)x->stream.mode) { @@ -425,14 +425,12 @@ coerce_to_file_pathname(cl_object pathname) return pathname; } -static cl_object translate_logical_pathname(cl_object x); - cl_object coerce_to_physical_pathname(cl_object x) { - x = coerce_to_pathname(x); + x = cl_pathname(x); if (x->pathname.logical) - return translate_logical_pathname(x); + return cl_translate_logical_pathname(x); return x; } @@ -459,7 +457,7 @@ merge_pathnames(cl_object path, cl_object defaults, cl_object default_version) { cl_object host, device, directory, name, type, version; - defaults = coerce_to_pathname(defaults); + defaults = cl_pathname(defaults); if (type_of(path) == t_string) { cl_index foo; cl_object aux = parse_namestring(path->string.self, 0, @@ -468,7 +466,7 @@ merge_pathnames(cl_object path, cl_object defaults, cl_object default_version) if (aux != Cnil) path = aux; } if (type_of(path) != t_pathname) - path = coerce_to_pathname(path); + path = cl_pathname(path); if (Null(path->pathname.host)) host = defaults->pathname.host; else @@ -630,7 +628,7 @@ L: if (x->string.self[0] != '~') return(x); /* added by E. Wang */ - return(namestring(coerce_to_pathname(x))); + return(namestring(cl_pathname(x))); case t_pathname: return(namestring(x)); @@ -662,11 +660,6 @@ L: } } -@(defun pathname (name) -@ /* INV: coerce_to_pathname() checks types */ - @(return coerce_to_pathname(name)) -@) - @(defun parse_namestring (thing &o host (defaults symbol_value(@'*default-pathname-defaults*')) @@ -674,7 +667,6 @@ L: &a x y) cl_index s, e, ee; @ - /* INV: coerce_to_pathname() checks types */ /* defaults is ignored */ x = thing; L: @@ -735,9 +727,8 @@ L: &o (defaults symbol_value(@'*default-pathname-defaults*')) (default_version @':newest')) @ - /* INV: coerce_to_pathname() checks types */ - path = coerce_to_pathname(path); - defaults = coerce_to_pathname(defaults); + path = cl_pathname(path); + defaults = cl_pathname(defaults); @(return merge_pathnames(path, defaults, default_version)) @) @@ -748,112 +739,113 @@ L: if (Null(defaults)) { defaults = symbol_value(@'*default-pathname-defaults*'); - defaults = coerce_to_pathname(defaults); + defaults = cl_pathname(defaults); defaults = make_pathname(defaults->pathname.host, Cnil, Cnil, Cnil, Cnil, Cnil); } else - defaults = coerce_to_pathname(defaults); + defaults = cl_pathname(defaults); x = make_pathname(host, device, directory, name, type, version); x = merge_pathnames(x, defaults, Cnil); @(return x) @) -@(defun pathnamep (pname) -@ +cl_object +cl_pathnamep(cl_object pname) +{ @(return ((type_of(pname) == t_pathname)? Ct : Cnil)) -@) +} -@(defun si::logical_pathname_p (pname) -@ +cl_object +si_logical_pathname_p(cl_object pname) +{ @(return ((type_of(pname) == t_pathname && pname->pathname.logical)? Ct : Cnil)) -@) +} -@(defun pathname_host (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_pathname_host(cl_object pname) +{ + pname = cl_pathname(pname); @(return pname->pathname.host) -@) +} -@(defun pathname_device (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_pathname_device(cl_object pname) +{ + pname = cl_pathname(pname); @(return pname->pathname.device) -@) +} -@(defun pathname_directory (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_pathname_directory(cl_object pname) +{ + pname = cl_pathname(pname); @(return pname->pathname.directory) -@) +} -@(defun pathname_name (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_pathname_name(cl_object pname) +{ + pname = cl_pathname(pname); @(return pname->pathname.name) -@) +} -@(defun pathname_type (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_pathname_type(cl_object pname) +{ + pname = cl_pathname(pname); @(return pname->pathname.type) -@) +} -@(defun pathname_version (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_pathname_version(cl_object pname) +{ + pname = cl_pathname(pname); @(return pname->pathname.version) -@) +} -@(defun namestring (pname) -@ - /* INV: coerce_to_pathname() checks types */ +cl_object +cl_namestring(cl_object pname) +{ @(return coerce_to_namestring(pname)) -@) +} -@(defun file_namestring (pname) -@ - /* INV: coerce_to_filename() checks types */ +cl_object +cl_file_namestring(cl_object pname) +{ pname = coerce_to_filename(pname); @(return namestring(make_pathname(Cnil, Cnil, Cnil, pname->pathname.name, pname->pathname.type, pname->pathname.version))) -@) +} -@(defun directory_namestring (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_directory_namestring(cl_object pname) +{ + pname = cl_pathname(pname); @(return namestring(make_pathname(Cnil, Cnil, pname->pathname.directory, Cnil, Cnil, Cnil))) -@) +} -@(defun host_namestring (pname) -@ - /* INV: coerce_to_pathname() checks types */ - pname = coerce_to_pathname(pname); +cl_object +cl_host_namestring(cl_object pname) +{ + pname = cl_pathname(pname); pname = pname->pathname.host; if (Null(pname) || pname == @':wild') pname = null_string; @(return pname) -@) +} @(defun enough_namestring (path &o (defaults symbol_value(@'*default-pathname-defaults*'))) cl_object newpath; @ - /* INV: coerce_to_pathname() checks types */ - defaults = coerce_to_pathname(defaults); - path = coerce_to_pathname(path); + defaults = cl_pathname(defaults); + path = cl_pathname(path); newpath = make_pathname(equalp(path->pathname.host, defaults->pathname.host) ? Cnil : path->pathname.host, @@ -941,8 +933,8 @@ path_list_match(cl_object a, cl_object mask) { bool pathname_match_p(cl_object path, cl_object mask) { - path = coerce_to_pathname(path); - mask = coerce_to_pathname(mask); + path = cl_pathname(path); + mask = cl_pathname(mask); if (path->pathname.logical != mask->pathname.logical) return FALSE; #if 0 @@ -962,10 +954,10 @@ pathname_match_p(cl_object path, cl_object mask) return TRUE; } -@(defun pathname_match_p (path mask) -@ +cl_object cl_pathname_match_p(cl_object path, cl_object mask) +{ @(return (pathname_match_p(path, mask)? Ct : Cnil)) -@) +} /* --------------- PATHNAME TRANSLATIONS ------------------ */ @@ -1014,8 +1006,8 @@ coerce_to_from_pathname(cl_object x, cl_object host) } for (l = set, set = Cnil; !endp(l); l = CDR(l)) { cl_object item = CAR(l); - cl_object from = coerce_to_from_pathname(car(item), host); - cl_object to = coerce_to_pathname(cadr(item)); + cl_object from = coerce_to_from_pathname(cl_car(item), host); + cl_object to = cl_pathname(cl_cadr(item)); if (type_of(from) != t_pathname || !from->pathname.logical) FEerror("~S is not a valid from-pathname translation", 1, from); if (type_of(to) != t_pathname) @@ -1154,13 +1146,13 @@ copy_list_wildcards(cl_object *wilds, cl_object to) } cl_object -translate_pathname(cl_object source, cl_object from, cl_object to) +cl_translate_pathname(cl_object source, cl_object from, cl_object to) { cl_object wilds, out, d, *pc; - source = coerce_to_pathname(source); - from = coerce_to_pathname(from); - to = coerce_to_pathname(to); + source = cl_pathname(source); + from = cl_pathname(from); + to = cl_pathname(to); if (source->pathname.logical != from->pathname.logical) goto error; @@ -1221,16 +1213,11 @@ translate_pathname(cl_object source, cl_object from, cl_object to) FEerror("Number of wildcards in ~S do not match ~S", 2, from, to); } -@(defun translate_pathname (source from to) -@ - @(return translate_pathname(source, from, to)) -@) - -static cl_object -translate_logical_pathname(cl_object source) +cl_object +cl_translate_logical_pathname(cl_object source) { cl_object l, pair; - source = coerce_to_pathname(source); + source = cl_pathname(source); if (!source->pathname.logical) goto error; begin: @@ -1238,7 +1225,7 @@ translate_logical_pathname(cl_object source) for(; !endp(l); l = CDR(l)) { pair = CAR(l); if (pathname_match_p(source, CAR(pair))) { - source = translate_pathname(source, CAR(pair), CADR(pair)); + source = cl_translate_pathname(source, CAR(pair), CADR(pair)); if (source->pathname.logical) goto begin; return source; @@ -1248,11 +1235,6 @@ translate_logical_pathname(cl_object source) FEerror("~S admits no logical pathname translations", 1, source); } -@(defun translate_logical_pathname (source) -@ - @(return translate_logical_pathname(source)) -@) - void init_pathname(void) { @@ -1260,6 +1242,6 @@ init_pathname(void) SYM_VAL(@'*default-pathname-defaults*') = make_pathname(Cnil, Cnil, Cnil, Cnil, Cnil, Cnil); @si::pathname-translations(2,make_simple_string("SYS"), - list(1,list(2,make_simple_string("*.*"), - make_simple_string("./*.*")))); + cl_list(1,cl_list(2,make_simple_string("*.*"), + make_simple_string("./*.*")))); } diff --git a/src/c/predicate.d b/src/c/predicate.d index c7f7524a1..11291a51e 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -16,42 +16,48 @@ #include "ecl.h" -@(defun identity (x) -@ +cl_object +cl_identity(cl_object x) +{ @(return x) -@) +} -@(defun null (x) -@ +cl_object +cl_null(cl_object x) +{ @(return (Null(x) ? Ct : Cnil)) -@) +} -@(defun symbolp (x) -@ +cl_object +cl_symbolp(cl_object x) +{ @(return (SYMBOLP(x) ? Ct : Cnil)) -@) +} -@(defun atom (x) -@ +cl_object +cl_atom(cl_object x) +{ @(return (ATOM(x) ? Ct : Cnil)) -@) +} -@(defun consp (x) -@ +cl_object +cl_consp(cl_object x) +{ @(return (CONSP(x) ? Ct : Cnil)) -@) +} -@(defun listp (x) -@ +cl_object +cl_listp(cl_object x) +{ @(return ((Null(x) || CONSP(x)) ? Ct : Cnil)) -@) +} -@(defun numberp (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_numberp(cl_object x) +{ + cl_type t = type_of(x); @(return (NUMBER_TYPE(t) ? Ct : Cnil)) -@) +} /* Used in compiled code */ bool numberp(cl_object x) @@ -60,123 +66,132 @@ bool numberp(cl_object x) return(NUMBER_TYPE(t)); } -@(defun integerp (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_integerp(cl_object x) +{ + cl_type t = type_of(x); @(return ((t == t_fixnum || t == t_bignum) ? Ct : Cnil)) -@) +} -@(defun rationalp (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_rationalp(cl_object x) +{ + cl_type t = type_of(x); @(return ((t == t_fixnum || t == t_bignum || t == t_ratio) ? Ct : Cnil)) -@) +} -@(defun floatp (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_floatp(cl_object x) +{ + cl_type t = type_of(x); @(return ((t == t_longfloat || t == t_shortfloat) ? Ct : Cnil)) -@) +} -@(defun realp (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_realp(cl_object x) +{ + cl_type t = type_of(x); @(return (REAL_TYPE(t) ? Ct : Cnil)) -@) +} -@(defun complexp (x) -@ +cl_object +cl_complexp(cl_object x) +{ @(return ((type_of(x) == t_complex) ? Ct : Cnil)) -@) +} -@(defun characterp (x) -@ +cl_object +cl_characterp(cl_object x) +{ @(return (CHARACTERP(x) ? Ct : Cnil)) -@) +} -@(defun stringp (x) -@ +cl_object +cl_stringp(cl_object x) +{ @(return ((type_of(x) == t_string) ? Ct : Cnil)) -@) +} -@(defun bit_vector_p (x) -@ +cl_object +cl_bit_vector_p(cl_object x) +{ @(return ((type_of(x) == t_bitvector) ? Ct : Cnil)) -@) +} -@(defun vectorp (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_vectorp(cl_object x) +{ + cl_type t = type_of(x); @(return ((t == t_vector || t == t_string || t == t_bitvector) ? Ct : Cnil)) -@) +} -@(defun simple_string_p (x) -@ +cl_object +cl_simple_string_p(cl_object x) +{ @(return ((type_of(x) == t_string && !x->string.adjustable && !x->string.hasfillp && Null(CAR(x->string.displaced))) ? Ct : Cnil)) -@) +} -@(defun simple_bit_vector_p (x) -@ +cl_object +cl_simple_bit_vector_p(cl_object x) +{ @(return ((type_of(x) == t_bitvector && !x->vector.adjustable && !x->vector.hasfillp && Null(CAR(x->vector.displaced))) ? Ct : Cnil)) -@) +} -@(defun simple_vector_p (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_simple_vector_p(cl_object x) +{ + cl_type t = type_of(x); @(return ((t == t_vector && !x->vector.adjustable && !x->vector.hasfillp && Null(CAR(x->vector.displaced)) && (cl_elttype)x->vector.elttype == aet_object) ? Ct : Cnil)) -@) +} -@(defun arrayp (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_arrayp(cl_object x) +{ + cl_type t = type_of(x); @(return (ARRAY_TYPE(t) ? Ct : Cnil)) -@) +} -@(defun packagep (x) -@ +cl_object +cl_packagep(cl_object x) +{ @(return ((type_of(x) == t_package) ? Ct : Cnil)) -@) +} -@(defun functionp (x) +cl_object +cl_functionp(cl_object x) +{ cl_type t; cl_object output; -@ + t = type_of(x); if (t == t_bytecodes || t == t_cfun || t == t_cclosure) output = Ct; else output = Cnil; @(return output) -@) +} -@(defun compiled_function_p (x) - cl_type t; -@ - t = type_of(x); +cl_object +cl_compiled_function_p(cl_object x) +{ + cl_type t = type_of(x); @(return ((t == t_bytecodes || t == t_cfun || t == t_cclosure) ? Ct : Cnil)) -@) +} -@(defun commonp (x) - cl_object output; -@ - output = (FALSE /* type_of(x) == t_spice */ +cl_object +cl_commonp(cl_object x) +{ + cl_object output = (FALSE /* type_of(x) == t_spice */ #ifdef THREADS || type_of(x) == t_thread || type_of(x) == t_cont @@ -187,12 +202,13 @@ bool numberp(cl_object x) #endif ) ? Cnil : Ct; @(return output) -@) +} -@(defun eq (x y) -@ +cl_object +cl_eq(cl_object x, cl_object y) +{ @(return ((x == y) ? Ct : Cnil)) -@) +} bool eql(cl_object x, cl_object y) @@ -236,10 +252,11 @@ eql(cl_object x, cl_object y) } } -@(defun eql (x y) -@ +cl_object +cl_eql(cl_object x, cl_object y) +{ @(return (eql(x, y) ? Ct : Cnil)) -@) +} bool equal(register cl_object x, cl_object y) @@ -330,10 +347,11 @@ BEGIN: } } -@(defun equal (x y) -@ +cl_object +cl_equal(cl_object x, cl_object y) +{ @(return (equal(x, y) ? Ct : Cnil)) -@) +} bool equalp(cl_object x, cl_object y) @@ -445,12 +463,14 @@ ARRAY: } } -@(defun equalp (x y) -@ +cl_object +cl_equalp(cl_object x, cl_object y) +{ @(return (equalp(x, y) ? Ct : Cnil)) -@) +} -@(defun si::fixnump (x) -@ +cl_object +si_fixnump(cl_object x) +{ @(return (FIXNUMP(x) ? Ct : Cnil)) -@) +} diff --git a/src/c/print.d b/src/c/print.d index 3b4dae763..5d49ff7cd 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -1555,19 +1555,22 @@ potential_number_p(cl_object strng, int base) @(return Cnil) @) -@(defun write-byte (integer binary_output_stream) -@ +cl_object +cl_write_byte(cl_object integer, cl_object binary_output_stream) +{ if (!FIXNUMP(integer)) FEerror("~S is not a byte.", 1, integer); assert_type_stream(binary_output_stream); writec_stream(fix(integer), binary_output_stream); @(return integer) -@) +} -@(defun si::write-bytes (stream string start end) +cl_object +si_write_bytes(cl_object stream, cl_object string, cl_object start, cl_object end) +{ cl_index is, ie; FILE *fp; int written, sofarwritten, towrite; -@ + assert_type_stream(stream); if (stream->stream.mode == smm_closed) closed_stream(stream); @@ -1588,7 +1591,7 @@ potential_number_p(cl_object strng, int base) else @(return MAKE_FIXNUM(-1)) } @(return MAKE_FIXNUM(sofarwritten - is)) -@) +} void init_print(void) @@ -1621,8 +1624,8 @@ init_print(void) PRINTlength = -1; PRINTarray = FALSE; - CIRCLEstack = cl_make_hash_table(@'eq', MAKE_FIXNUM(1024), make_shortfloat(1.5), - make_shortfloat(0.7)); + CIRCLEstack = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), make_shortfloat(1.5), + make_shortfloat(0.7)); register_root(&CIRCLEstack); no_stream = @make_broadcast_stream(0); diff --git a/src/c/read.d b/src/c/read.d index 05512ca87..ee8804d60 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -723,7 +723,7 @@ static n = 8*n + c->string.self[i] - '0'; c = CODE_CHAR(n & 0377); } else { - c = @name_char(1,c); + c = cl_name_char(c); if (Null(c)) FEerror("~S is an illegal character name.", 1, c); } @(return c) @@ -776,8 +776,8 @@ static cl_stack_push(CAR(x)); goto L; } - @(return list(4, @'si::,', @'apply', - CONS(@'quote', CONS(@'vector', Cnil)), x)) + @(return cl_list(4, @'si::,', @'apply', + CONS(@'quote', CONS(@'vector', Cnil)), x)) } for (dimcount = 0 ;; dimcount++) { delimiting_char = CODE_CHAR(')'); @@ -935,7 +935,7 @@ static switch (code) { case 0: { cl_object name = read_object(in); - @si::select-package(1,name); + si_select_package(name); break; } case 1: { @@ -945,7 +945,7 @@ static break; } default: { - cl_object read_VV_block = SYM_VAL(@'si::*read-vv-block*'); + cl_object read_VV_block = SYM_VAL(@'si::*cblock*'); code = -code - 1; if (code < 0 || code >= read_VV_block->cblock.data_size) FEerror("Bogus binary file. #!~S unknown.",1, @@ -1181,7 +1181,7 @@ static static @(defun "sharp_P_reader" (in c d) @ - @(return coerce_to_pathname(read_object(in))) + @(return cl_pathname(read_object(in))) @) /* @@ -1193,7 +1193,7 @@ static if (d != Cnil && !read_suppress) extra_argument('"', d); unread_char(c, in); - @(return coerce_to_pathname(read_object(in))) + @(return cl_pathname(read_object(in))) @) /* @@ -1591,9 +1591,11 @@ CANNOT_PARSE: @(return MAKE_FIXNUM(c)) @) -@(defun si::read_bytes (stream string start end) +cl_object +si_read_bytes(cl_object stream, cl_object string, cl_object start, cl_object end) +{ int is, ie, c; FILE *fp; -@ + assert_type_stream(stream); if (stream->stream.mode == smm_closed) closed_stream(stream); @@ -1607,7 +1609,7 @@ CANNOT_PARSE: ie - is, fp); @(return MAKE_FIXNUM(c)) -@) +} @@ -1629,10 +1631,11 @@ CANNOT_PARSE: @(return copy_readtable(from, to)) @) -@(defun readtablep (readtable) -@ +cl_object +cl_readtablep(cl_object readtable) +{ @(return ((type_of(readtable) == t_readtable)? Ct : Cnil)) -@) +} static struct readtable_entry* read_table_entry(cl_object rdtbl, cl_object c) @@ -1751,31 +1754,27 @@ read_table_entry(cl_object rdtbl, cl_object c) cl_object c_string_to_object(const char *s) { - return string_to_object(make_constant_string(s)); + return si_string_to_object(make_constant_string(s)); } cl_object -string_to_object(cl_object x) +si_string_to_object(cl_object x) { cl_object in; + assert_type_string(x); in = make_string_input_stream(x, 0, x->string.fillp); preserving_whitespace_flag = FALSE; detect_eos_flag = FALSE; x = read_object(in); - return(x); + @(return x) } -@(defun si::string_to_object (str) -@ - assert_type_string(str); - @(return string_to_object(str)) -@) - -@(defun si::standard_readtable () -@ +cl_object +si_standard_readtable() +{ @(return standard_readtable) -@) +} static void extra_argument(int c, cl_object d) @@ -1785,7 +1784,7 @@ extra_argument(int c, cl_object d) } -#define make_cf(f) make_cfun((cl_objectfn)(f), Cnil, NULL) +#define make_cf(f) cl_make_cfun_va((cl_objectfn)(f), Cnil, NULL) void init_read(void) @@ -1865,8 +1864,8 @@ init_read(void) dtab['A'] = dtab['a'] = make_cf(sharp_A_reader); dtab['S'] = dtab['s'] = make_cf(sharp_S_reader); */ - dtab['A'] = dtab['a'] = make_si_ordinary("SHARP-A-READER"); - dtab['S'] = dtab['s'] = make_si_ordinary("SHARP-S-READER"); + dtab['A'] = dtab['a'] = @'si::sharp-a-reader'; + dtab['S'] = dtab['s'] = @'si::sharp-s-reader'; dtab['P'] = dtab['p'] = make_cf(sharp_P_reader); dtab['='] = make_cf(sharp_eq_reader); @@ -1904,6 +1903,8 @@ init_read(void) register_root(&delimiting_char); detect_eos_flag = FALSE; + + SYM_VAL(@'si::*cblock*') = Cnil; } /* @@ -1944,6 +1945,7 @@ read_VV(cl_object block, void *entry) if (frs_push(FRS_PROTECT, Cnil)) e = TRUE; else { + bds_bind(@'si::*cblock*', block); if (len == 0) goto NO_DATA; in=make_string_input_stream(make_constant_string(block->cblock.data_text), 0, block->cblock.data_text_size); @@ -1952,18 +1954,18 @@ read_VV(cl_object block, void *entry) bds_bind(@'*read-suppress*', Cnil); bds_bind(@'*package*', lisp_package); bds_bind(@'*readtable*', standard_readtable); - bds_bind(@'si::*read-vv-block*', block); for (i = 0 ; i < len; i++) { x = @read(4, in, Cnil, OBJNULL, Cnil); if (x == OBJNULL) break; VV[i] = x; } - bds_unwind_n(6); + bds_unwind_n(5); if (i < len) FEerror("Not enough data while loading binary file",0); NO_DATA: (*entry_point)(MAKE_FIXNUM(0)); + bds_unwind1; e = FALSE; } diff --git a/src/c/reference.d b/src/c/reference.d index 8ed2f7f7e..d11093eb4 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -20,9 +20,11 @@ #define SBOUNDP(sym) (SYM_VAL(sym) == OBJNULL) #define FBOUNDP(sym) (SYM_FUN(sym) == OBJNULL) -@(defun fboundp (sym) +cl_object +cl_fboundp(cl_object sym) +{ cl_object output; -@ + if (!SYMBOLP(sym)) { cl_object sym1 = setf_namep(sym); if (sym1 != OBJNULL) @@ -37,7 +39,7 @@ else output = Ct; @(return output) -@) +} cl_object symbol_function(cl_object sym) @@ -64,9 +66,11 @@ symbol_function(cl_object sym) (if defined CLOS it returns also generic-function for generic functions) */ -@(defun symbol_function (sym) +cl_object +cl_symbol_function(cl_object sym) +{ cl_object output; -@ + if (!SYMBOLP(sym)) { cl_object sym1 = setf_namep(sym); if (sym1 == OBJNULL) @@ -82,18 +86,20 @@ symbol_function(cl_object sym) else output = SYM_FUN(sym); @(return output) -@) +} -@(defun si::coerce_to_function (fun) +cl_object +si_coerce_to_function(cl_object fun) +{ cl_type t = type_of(fun); -@ + if (t == t_symbol) { if (FBOUNDP(fun) || fun->symbol.mflag) FEundefined_function(fun); else @(return SYM_FUN(fun)) } else if (t == t_cons && CAR(fun) == @'lambda') { - return @si::make-lambda(2, Cnil, CDR(fun)); + return si_make_lambda(Cnil, CDR(fun)); } else { cl_object setf_sym = setf_namep(fun); if ((setf_sym != OBJNULL) && !FBOUNDP(setf_sym)) @@ -101,23 +107,25 @@ symbol_function(cl_object sym) else FEinvalid_function(fun); } -@) +} -@(defun symbol_value (sym) -@ +cl_object +cl_symbol_value(cl_object sym) +{ if (!SYMBOLP(sym)) FEtype_error_symbol(sym); if (SBOUNDP(sym)) FEunbound_variable(sym); @(return SYM_VAL(sym)) -@) +} -@(defun boundp (sym) -@ +cl_object +cl_boundp(cl_object sym) +{ if (!SYMBOLP(sym)) FEtype_error_symbol(sym); @(return (SBOUNDP(sym)? Cnil : Ct)) -@) +} @(defun macro_function (sym &optional env) cl_object fd; @@ -135,9 +143,10 @@ symbol_function(cl_object sym) @(return fd) @) -@(defun special_form_p (form) -@ +cl_object +cl_special_operator_p(cl_object form) +{ if (!SYMBOLP(form)) FEtype_error_symbol(form); @(return (form->symbol.isform? Ct : Cnil)) -@) +} diff --git a/src/c/sequence.d b/src/c/sequence.d index 7b72d8c51..b34c490d5 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -60,10 +60,11 @@ cl_alloc_simple_bitvector(int l) return(x); } -@(defun elt (x i) -@ +cl_object +cl_elt(cl_object x, cl_object i) +{ @(return elt(x, fixint(i))) -@) +} cl_object elt(cl_object seq, cl_fixnum index) @@ -103,10 +104,11 @@ E: FEtype_error_index(MAKE_FIXNUM(index)); } -@(defun si::elt_set (seq index val) -@ +cl_object +si_elt_set(cl_object seq, cl_object index, cl_object val) +{ @(return elt_set(seq, fixint(index), val)) -@) +} cl_object elt_set(cl_object seq, cl_fixnum index, cl_object val) @@ -264,16 +266,17 @@ ILLEGAL_START_END: for the sequence ~S.", 3, start, end, sequence); @) -@(defun copy_seq (x) -@ - /* INV: #'subseq outputs only one value */ +cl_object +cl_copy_seq(cl_object x) +{ return @subseq(2, x, MAKE_FIXNUM(0)); -@) +} -@(defun length (x) -@ +cl_object +cl_length(cl_object x) +{ @(return MAKE_FIXNUM(length(x))) -@) +} cl_fixnum length(cl_object x) @@ -304,29 +307,26 @@ length(cl_object x) } } -@(defun reverse (x) -@ - @(return reverse(x)) -@) - cl_object -reverse(cl_object seq) +cl_reverse(cl_object seq) { - cl_object x, y, v; + cl_object x, y; int i, j, k; cl_object endp_temp; switch (type_of(seq)) { case t_symbol: if (Null(seq)) - return(Cnil); - FEwrong_type_argument(@'sequence', seq); + y = Cnil; + else + FEwrong_type_argument(@'sequence', seq); + break; case t_cons: - v = Cnil; + y = Cnil; for (x = seq; !endp(x); x = CDR(x)) - v = CONS(CAR(x), v); - return(v); + y = CONS(CAR(x), y); + break; case t_vector: x = seq; @@ -355,7 +355,7 @@ reverse(cl_object seq) default: internal_error("reverse"); } - return(y); + break; case t_string: x = seq; @@ -364,7 +364,7 @@ reverse(cl_object seq) for (j = x->string.fillp - 1, i = 0; j >=0; --j, i++) y->string.self[j] = x->string.self[i]; y->string.self[x->string.fillp] = '\0'; - return(y); + break; case t_bitvector: x = seq; @@ -377,20 +377,16 @@ reverse(cl_object seq) y->vector.self.bit[j/CHAR_BIT] |= 0200>>j%CHAR_BIT; else y->vector.self.bit[j/CHAR_BIT] &= ~(0200>>j%CHAR_BIT); - return(v); + break; default: FEwrong_type_argument(@'sequence', seq); } + @(return y) } -@(defun nreverse (x) -@ - @(return nreverse(x)) -@) - cl_object -nreverse(cl_object seq) +cl_nreverse(cl_object seq) { cl_object x, y, z; int i, j, k; @@ -398,9 +394,9 @@ nreverse(cl_object seq) switch (type_of(seq)) { case t_symbol: - if (Null(seq)) - return(Cnil); - FEwrong_type_argument(@'sequence', seq); + if (!Null(seq)) + FEwrong_type_argument(@'sequence', seq); + break; case t_cons: for (x = Cnil, y = seq; !endp(CDR(y));) { @@ -410,7 +406,8 @@ nreverse(cl_object seq) x = z; } CDR(y) = x; - return(y); + seq = y; + break; case t_vector: x = seq; @@ -423,40 +420,39 @@ nreverse(cl_object seq) x->vector.self.t[i] = x->vector.self.t[j]; x->vector.self.t[j] = y; } - return(seq); - + break; case aet_sf: for (i = 0, j = k - 1; i < j; i++, --j) { float y = x->array.self.sf[i]; x->array.self.sf[i] = x->array.self.sf[j]; x->array.self.sf[j] = y; } - return(seq); - + break; case aet_lf: for (i = 0, j = k - 1; i < j; i++, --j) { double y = x->array.self.lf[i]; x->array.self.lf[i] = x->array.self.lf[j]; x->array.self.lf[j] = y; } - return(seq); + break; case aet_b8: for (i = 0, j = k - 1; i < j; i++, --j) { u_int8_t y = x->array.self.b8[i]; x->array.self.b8[i] = x->array.self.b8[j]; x->array.self.b8[j] = y; } - return(seq); + break; case aet_i8: for (i = 0, j = k - 1; i < j; i++, --j) { int8_t y = x->array.self.i8[i]; x->array.self.i8[i] = x->array.self.i8[j]; x->array.self.i8[j] = y; } - return(seq); + break; default: internal_error("subseq"); } + break; case t_string: x = seq; @@ -465,7 +461,7 @@ nreverse(cl_object seq) x->string.self[i] = x->string.self[j]; x->string.self[j] = k; } - return(seq); + break; case t_bitvector: x = seq; @@ -487,9 +483,9 @@ nreverse(cl_object seq) x->vector.self.bit[j/CHAR_BIT] &= ~(0200>>j%CHAR_BIT); } - return(seq); - + break; default: FEwrong_type_argument(@'sequence', seq); } + @(return seq) } diff --git a/src/c/stacks.d b/src/c/stacks.d index a08f038a7..bf67034bf 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -76,20 +76,23 @@ get_bds_ptr(cl_object x) FEerror("~S is an illegal bds index.", 1, x); } -@(defun si::bds_top () -@ +cl_object +si_bds_top() +{ @(return MAKE_FIXNUM(bds_top - bds_org)) -@) +} -@(defun si::bds_var (arg) -@ +cl_object +si_bds_var(cl_object arg) +{ @(return get_bds_ptr(arg)->bds_sym) -@) +} -@(defun si::bds_val (arg) -@ +cl_object +si_bds_val(cl_object arg) +{ @(return get_bds_ptr(arg)->bds_val) -@) +} /******************** INVOCATION STACK **********************/ @@ -120,6 +123,7 @@ ihs_function_name(cl_object x) void ihs_push(cl_object function) { + /* INV: ihs_push saves the lexical environment */ cl_stack_push(function); cl_stack_push(lex_env); cl_stack_push(MAKE_FIXNUM(ihs_top)); @@ -129,6 +133,7 @@ ihs_push(cl_object function) void ihs_pop(void) { + /* INV: ihs_pop restores the lexical environment */ cl_stack_set_index(ihs_top); ihs_top = fix(cl_stack_top[-1]); lex_env = cl_stack_top[-2]; @@ -183,10 +188,12 @@ ihs_top_function_name(void) return(Cnil); } -@(defun si::ihs_top (name) +cl_object +si_ihs_top(cl_object name) +{ cl_index h = ihs_top; cl_object *sp; -@ + name = ihs_function_name(name); while (h > 0) { cl_object *sp = get_ihs_ptr(h); @@ -198,29 +205,32 @@ ihs_top_function_name(void) if (h == 0) h = ihs_top; @(return MAKE_FIXNUM(h)) -@) +} -@(defun si::ihs-prev (x) -@ +cl_object +si_ihs_prev(cl_object x) +{ @(return MAKE_FIXNUM(ihs_prev(fixnnint(x)))) -@) +} -@(defun si::ihs-next (x) -@ +cl_object +si_ihs_next(cl_object x) +{ @(return MAKE_FIXNUM(ihs_next(fixnnint(x)))) -@) +} -@(defun si::ihs_fun (arg) -@ +cl_object +si_ihs_fun(cl_object arg) +{ @(return get_ihs_ptr(fixnnint(arg))[-3]) -@) +} -@(defun si::ihs_env (arg) - cl_object lex; -@ - lex = get_ihs_ptr(ihs_next(fixnnint(arg)))[-2]; +cl_object +si_ihs_env(cl_object arg) +{ + cl_object lex = get_ihs_ptr(ihs_next(fixnnint(arg)))[-2]; @(return lex) -@) +} /********************** FRAME STACK *************************/ @@ -307,51 +317,61 @@ get_frame_ptr(cl_object x) FEerror("~S is an illegal frs index.", 1, x); } -@(defun si::frs_top () -@ +cl_object +si_frs_top() +{ @(return MAKE_FIXNUM(frs_top - frs_org)) -@) +} -@(defun si::frs_bds (arg) -@ +cl_object +si_frs_bds(cl_object arg) +{ @(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_bds_top - bds_org)) -@) +} -@(defun si::frs_class (arg) +cl_object +si_frs_class(cl_object arg) +{ enum fr_class c; cl_object output; -@ + c = get_frame_ptr(arg)->frs_class; if (c == FRS_CATCH) output = @':catch'; else if (c == FRS_PROTECT) output = @':protect'; else if (c == FRS_CATCHALL) output = @':catchall'; else FEerror("Unknown frs class was detected.", 0); @(return output) -@) +} -@(defun si::frs_tag (arg) -@ +cl_object +si_frs_tag(cl_object arg) +{ @(return get_frame_ptr(arg)->frs_val) -@) +} -@(defun si::frs_ihs (arg) -@ +cl_object +si_frs_ihs(cl_object arg) +{ @(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_ihs)) -@) +} -@(defun si::sch_frs_base (fr ihs) +cl_object +si_sch_frs_base(cl_object fr, cl_object ihs) +{ frame_ptr x; cl_index y; -@ + y = fixnnint(ihs); for (x = get_frame_ptr(fr); x <= frs_top && x->frs_ihs < y; x++); @(return ((x > frs_top) ? Cnil : MAKE_FIXNUM(x - frs_org))) -@) +} /********************* INITIALIZATION ***********************/ -@(defun si::reset_stack_limits () -@ +cl_object +si_reset_stack_limits() +{ + volatile foo = 0; if (bds_top < bds_org + (bds_size - 2*BDSGETA)) bds_limit = bds_org + (bds_size - 2*BDSGETA); else @@ -361,17 +381,17 @@ get_frame_ptr(cl_object x) else error("can't reset frs_limit."); #ifdef DOWN_STACK - if (&narg > cs_org - cssize + 16) + if (&foo > cs_org - cssize + 16) cs_limit = cs_org - cssize; #else - if (&narg < cs_org + cssize - 16) + if (&foo < cs_org + cssize - 16) cs_limit = cs_org + cssize; #endif else error("can't reset cs_limit."); @(return Cnil) -@) +} void init_stacks(int *new_cs_org) diff --git a/src/c/string.d b/src/c/string.d index 8436b38f8..006da05fd 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -118,23 +118,23 @@ copy_simple_string(cl_object x) } cl_object -coerce_to_string(cl_object x) +cl_string(cl_object x) { cl_object y; switch (type_of(x)) { case t_symbol: - return x->symbol.name; + return1(x->symbol.name); case t_character: y = cl_alloc_simple_string(1); y->string.self = (char *)cl_alloc_atomic(2); y->string.self[1] = '\0'; y->string.self[0] = CHAR_CODE(x); - return(y); + return1(y); case t_string: - return(x); + return1(x); default: FEtype_error_string(x); @@ -170,20 +170,24 @@ coerce_to_string_designator(cl_object x) } } -@(defun char (s i) +cl_object +cl_char(cl_object s, cl_object i) +{ cl_index j; -@ + assert_type_string(s); j = object_to_index(i); /* CHAR bypasses fill pointers when accessing strings */ if (j >= s->string.dim-1) illegal_index(s, i); @(return CODE_CHAR(s->string.self[j])) -@) +} -@(defun si::char_set (str index c) +cl_object +si_char_set(cl_object str, cl_object index, cl_object c) +{ cl_index j; -@ + assert_type_string(str); j = object_to_index(index); /* CHAR bypasses fill pointers when accessing strings */ @@ -192,7 +196,7 @@ coerce_to_string_designator(cl_object x) /* INV: char_code() checks type of `c' */ str->string.self[j] = char_code(c); @(return c) -@) +} void get_string_start_end(cl_object string, cl_object start, cl_object end, @@ -505,14 +509,11 @@ member_char(int c, cl_object char_bag) } static cl_return -string_trim0(int narg, bool left_trim, bool right_trim, cl_object char_bag, - cl_object strng) +string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strng) { cl_object res; cl_index i, j, k; - if (narg != 2) - check_arg_failed(narg, 2); strng = coerce_to_string_designator(strng); i = 0; j = strng->string.fillp - 1; @@ -533,14 +534,14 @@ string_trim0(int narg, bool left_trim, bool right_trim, cl_object char_bag, } cl_return -@string-trim(int narg, cl_object char_bag, cl_object strng) - { return string_trim0(narg, TRUE, TRUE, char_bag, strng); } +cl_string_trim(cl_object char_bag, cl_object strng) + { return string_trim0(TRUE, TRUE, char_bag, strng); } cl_return -@string-left-trim(int narg, cl_object char_bag, cl_object strng) - { return string_trim0(narg, TRUE, FALSE, char_bag, strng); } +cl_string_left_trim(cl_object char_bag, cl_object strng) + { return string_trim0(TRUE, FALSE, char_bag, strng); } cl_return -@string-right-trim(int narg, cl_object char_bag, cl_object strng) - { return string_trim0(narg, FALSE, TRUE, char_bag, strng);} +cl_string_right_trim(cl_object char_bag, cl_object strng) + { return string_trim0(FALSE, TRUE, char_bag, strng);} static cl_return @@ -662,12 +663,6 @@ nstring_case(int narg, int (*casefun)(int, bool *), cl_va_list ARGS) @(return nstring_case(narg, char_capitalize, args)) @) - -@(defun string (x) -@ - @(return coerce_to_string(x)) -@) - @(defun si::string_concatenate (&rest args) cl_index l; int i; diff --git a/src/c/structure.d b/src/c/structure.d index 9475b99cb..e91b4db9e 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -47,11 +47,12 @@ structure_subtypep(cl_object x, cl_object y) } #endif /* CLOS */ -@(defun si::structure_subtype_p (x y) -@ +cl_object +si_structure_subtype_p(cl_object x, cl_object y) +{ @(return ((type_of(x) == T_STRUCTURE && structure_subtypep(STYPE(x), y)) ? Ct : Cnil)) -@) +} #ifndef CLOS /* This is only used for printing. Should not cons!! */ @@ -65,7 +66,7 @@ structure_to_list(cl_object x) @'si::structure-slot-descriptions', Cnil); p = &CDR(r = CONS(SNAME(x), Cnil)); for (i=0, n=SLENGTH(x); !endp(s) && i 0; --i) { l = CDR(l); @@ -174,9 +192,11 @@ structure_set(cl_object x, cl_object name, int n, cl_object v) } CAR(l) = v; @(return v) -@) +} -@(defun si::list_nth (idx x) +cl_object +si_list_nth(cl_object idx, cl_object x) +{ /* Used in structure access functions generated by DEFSTRUCT. si:list-nth is similar to nth except that @@ -184,11 +204,11 @@ structure_set(cl_object x, cl_object name, int n, cl_object v) */ cl_fixnum i; cl_object l; -@ + assert_type_cons(x); for (i = fixnnint(idx), l = x; i > 0; --i) { l = CDR(l); if (endp(l)) FEtype_error_index(idx); } @(return CAR(l)) -@) +} diff --git a/src/c/symbol.d b/src/c/symbol.d index 36a6cc48f..bb815d3df 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -28,11 +28,12 @@ static cl_object gensym_prefix; static cl_object gentemp_prefix; static cl_index gentemp_counter; -@(defun make_symbol (str) -@ +cl_object +cl_make_symbol(cl_object str) +{ assert_type_string(str); @(return make_symbol(str)) -@) +} cl_object make_symbol(cl_object st) @@ -53,79 +54,28 @@ make_symbol(cl_object st) } /* - Make_ordinary(s) makes an ordinary symbol from C string s - and interns it in lisp package as an external symbol. + cl_defvar(s, v) makes a special variable from a symbol and, if it was + unbound, assignes it the value V. */ -cl_object -make_ordinary(const char *s) +void +cl_defvar(cl_object s, cl_object v) { - cl_object x = _intern(s, lisp_package); - cl_export(x, lisp_package); - return(x); + assert_type_symbol(s); + s->symbol.stype = (short)stp_special; + if (SYM_VAL(s) == OBJNULL) + SYM_VAL(s) = v; } /* - Make_special(s, v) makes a special variable from C string s - with initial value v in lisp package. + cl_defparameter(s, v) makes a special variable from a symbol and, + assignes it the value V. */ -cl_object -make_special(const char *s, cl_object v) +void +cl_defparameter(cl_object s, cl_object v) { - cl_object x = make_ordinary(s); - x->symbol.stype = (short)stp_special; - SYM_VAL(x) = v; - return(x); -} - -/* - Make_constant(s, v) makes a constant from C string s - with constant value v in lisp package. -*/ -cl_object -make_constant(const char *s, cl_object v) -{ - cl_object x = make_ordinary(s); - x->symbol.stype = (short)stp_constant; - SYM_VAL(x) = v; - return(x); -} - -/* - Make_si_ordinary(s) makes an ordinary symbol from C string s - and interns it in system package as an external symbol. -*/ -cl_object -make_si_ordinary(const char *s) -{ - cl_object x = _intern(s, system_package); - cl_export(x, system_package); - return(x); -} - -/* - Make_si_special(s, v) makes a special variable from C string s - with initial value v in system package. -*/ -cl_object -make_si_special(const char *s, cl_object v) -{ - cl_object x = make_si_ordinary(s); - x->symbol.stype = (short)stp_special; - SYM_VAL(x) = v; - return(x); -} - -/* - Make_si_constant(s, v) makes a constant from C string s - with constant value v in system package. -*/ -cl_object -make_si_constant(const char *s, cl_object v) -{ - cl_object x = make_si_ordinary(s); - x->symbol.stype = (short)stp_constant; - SYM_VAL(x) = v; - return(x); + assert_type_symbol(s); + s->symbol.stype = (short)stp_special; + SYM_VAL(s) = v; } /* @@ -275,26 +225,30 @@ keywordp(cl_object s) @(return getf(sym->symbol.plist, indicator, deflt)) @) -@(defun remprop (sym prop) -@ +cl_object +cl_remprop(cl_object sym, cl_object prop) +{ assert_type_symbol(sym); @(return (remf(&sym->symbol.plist, prop)? Ct: Cnil)) -@) +} -@(defun symbol_plist (sym) -@ +cl_object +cl_symbol_plist(cl_object sym) +{ assert_type_symbol(sym); @(return sym->symbol.plist) -@) +} @(defun getf (place indicator &optional deflt) @ @(return getf(place, indicator, deflt)) @) -@(defun get_properties (place indicator_list) +cl_object +cl_get_properties(cl_object place, cl_object indicator_list) +{ cl_object slow, cdr_l, l; -@ + /* This loop guarantees finishing for circular lists */ for (slow = l = place; CONSP(l); ) { cdr_l = CDR(l); @@ -310,7 +264,7 @@ keywordp(cl_object s) if (l != Cnil) FEtype_error_plist(place); @(return Cnil Cnil Cnil) -@) +} cl_object symbol_name(cl_object x) @@ -319,10 +273,11 @@ symbol_name(cl_object x) return x->symbol.name; } -@(defun symbol_name (sym) -@ +cl_object +cl_symbol_name(cl_object sym) +{ @(return symbol_name(sym)) -@) +} @(defun copy_symbol (sym &optional cp &aux x) @ @@ -403,26 +358,29 @@ ONCE_MORE: @(return smbl) @) -@(defun symbol_package (sym) -@ +cl_object +cl_symbol_package(cl_object sym) +{ assert_type_symbol(sym); @(return sym->symbol.hpack) -@) +} -@(defun keywordp (sym) -@ +cl_object +cl_keywordp(cl_object sym) +{ @(return ((SYMBOLP(sym) && keywordp(sym))? Ct: Cnil)) -@) +} /* (SI:PUT-F plist value indicator) returns the new property list with value for property indicator. It will be used in SETF for GETF. */ -@(defun si::put_f (plist value indicator) -@ +cl_object +si_put_f(cl_object plist, cl_object value, cl_object indicator) +{ @(return putf(plist, value, indicator)) -@) +} /* (SI:REM-F plist indicator) returns two values: @@ -435,26 +393,28 @@ ONCE_MORE: It will be used for macro REMF. */ -@(defun si::rem_f (plist indicator) - bool found; -@ - found = remf(&plist, indicator); +cl_object +si_rem_f(cl_object plist, cl_object indicator) +{ + bool found = remf(&plist, indicator); @(return plist (found? Ct : Cnil)) -@) +} -@(defun si::set_symbol_plist (sym plist) -@ +cl_object +si_set_symbol_plist(cl_object sym, cl_object plist) +{ assert_type_symbol(sym); sym->symbol.plist = plist; @(return plist) -@) +} -@(defun si::putprop (sym value indicator) -@ +cl_object +si_putprop(cl_object sym, cl_object value, cl_object indicator) +{ assert_type_symbol(sym); sym->symbol.plist = putf(sym->symbol.plist, value, indicator); @(return value) -@) +} /* Added for defstruct. Beppe */ @(defun si::put_properties (sym &rest ind_values) @@ -468,18 +428,20 @@ ONCE_MORE: @(return sym) @) -@(defun si::*make_special (sym) -@ +cl_object +@si::*make_special(cl_object sym) +{ assert_type_symbol(sym); if ((enum stype)sym->symbol.stype == stp_constant) FEerror("~S is a constant.", 1, sym); sym->symbol.stype = (short)stp_special; remf(&sym->symbol.plist, @'si::symbol-macro'); @(return sym) -@) +} -@(defun si::*make_constant (sym val) -@ +cl_object +@si::*make_constant(cl_object sym, cl_object val) +{ assert_type_symbol(sym); if ((enum stype)sym->symbol.stype == stp_special) FEerror( @@ -488,7 +450,7 @@ ONCE_MORE: sym->symbol.stype = (short)stp_constant; SYM_VAL(sym) = val; @(return sym) -@) +} void init_symbol(void) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 71955fe0c..0e54eb93f 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -7,1250 +7,1255 @@ cl_symbol_initializer #endif cl_symbols[] = { -{"NIL", CL_ORDINARY, NULL, NULL}, -{"T", CL_ORDINARY, NULL, NULL}, +{"NIL", CL_ORDINARY, NULL, -1}, +{"T", CL_ORDINARY, NULL, -1}, /* LISP PACKAGE */ -{"&ALLOW-OTHER-KEYS", CL_ORDINARY, &clSAallow_other_keys, NULL}, -{"&AUX", CL_ORDINARY, &clSAaux, NULL}, -{"&BODY", CL_ORDINARY, NULL, NULL}, -{"&ENVIRONMENT", CL_ORDINARY, NULL, NULL}, -{"&KEY", CL_ORDINARY, &clSAkey, NULL}, -{"&OPTIONAL", CL_ORDINARY, &clSAoptional, NULL}, -{"&REST", CL_ORDINARY, &clSArest, NULL}, -{"&WHOLE", CL_ORDINARY, NULL, NULL}, -{"+", CL_SPECIAL, NULL, clLP}, -{"++", CL_SPECIAL, NULL, NULL}, -{"+++", CL_SPECIAL, NULL, NULL}, -{"-", CL_SPECIAL, NULL, clLM}, -{"*", CL_SPECIAL, &clV, clLX}, -{"**", CL_SPECIAL, NULL, NULL}, -{"***", CL_SPECIAL, NULL, NULL}, -{"/", CL_SPECIAL, &clV, clLN}, -{"//", CL_SPECIAL, NULL, NULL}, -{"///", CL_SPECIAL, NULL, NULL}, -{"/=", CL_ORDINARY, NULL, clLNE}, -{"*COMPILE-PRINT*", CL_SPECIAL, NULL, NULL}, -{"*COMPILE-VERBOSE*", CL_SPECIAL, NULL, NULL}, -{"*DEBUG-IO*", CL_SPECIAL, &clVdebug_io, NULL}, -{"*DEFAULT-PATHNAME-DEFAULTS*", CL_SPECIAL, &clVdefault_pathname_defaults, NULL}, -{"*ERROR-OUTPUT*", CL_SPECIAL, &clVerror_output, NULL}, -{"*FEATURES*", CL_SPECIAL, &clVfeatures, NULL}, -{"*GENSYM-COUNTER*", CL_SPECIAL, &clVgensym_counter, NULL}, -{"*LOAD-PRINT*", CL_SPECIAL, &clVload_print, NULL}, -{"*LOAD-VERBOSE*", CL_SPECIAL, &clVload_verbose, NULL}, -{"*MACROEXPAND-HOOK*", CL_SPECIAL, &clVmacroexpand_hook, NULL}, -{"*MODULES*", CL_SPECIAL, NULL, NULL}, -{"*PACKAGE*", CL_SPECIAL, &clVpackage, NULL}, -{"*PRINT-ARRAY*", CL_SPECIAL, &clVprint_array, NULL}, -{"*PRINT-BASE*", CL_SPECIAL, &clVprint_base, NULL}, -{"*PRINT-CASE*", CL_SPECIAL, &clVprint_case, NULL}, -{"*PRINT-CIRCLE*", CL_SPECIAL, &clVprint_circle, NULL}, -{"*PRINT-ESCAPE*", CL_SPECIAL, &clVprint_escape, NULL}, -{"*PRINT-GENSYM*", CL_SPECIAL, &clVprint_gensym, NULL}, -{"*PRINT-LENGTH*", CL_SPECIAL, &clVprint_length, NULL}, -{"*PRINT-LEVEL*", CL_SPECIAL, &clVprint_level, NULL}, -{"*PRINT-PRETTY*", CL_SPECIAL, &clVprint_pretty, NULL}, -{"*PRINT-RADIX*", CL_SPECIAL, &clVprint_radix, NULL}, -{"*QUERY-IO*", CL_SPECIAL, &clVquery_io, NULL}, -{"*RANDOM-STATE*", CL_SPECIAL, &clVrandom_state, NULL}, -{"*READ-BASE*", CL_SPECIAL, &clVread_base, NULL}, -{"*READ-DEFAULT-FLOAT-FORMAT*", CL_SPECIAL, &clVread_default_float_format, NULL}, -{"*READ-SUPPRESS*", CL_SPECIAL, &clVread_suppress, NULL}, -{"*READTABLE*", CL_SPECIAL, &clVreadtable, NULL}, -{"*STANDARD-INPUT*", CL_SPECIAL, &clVstandard_input, NULL}, -{"*STANDARD-OUTPUT*", CL_SPECIAL, &clVstandard_output, NULL}, -{"*TERMINAL-IO*", CL_SPECIAL, &clVterminal_io, NULL}, -{"*TRACE-OUTPUT*", CL_SPECIAL, &clVtrace_output, NULL}, -{"1+", CL_ORDINARY, NULL, clL1P}, -{"1-", CL_ORDINARY, NULL, clL1M}, -{"<", CL_ORDINARY, NULL, clLL}, -{"<=", CL_ORDINARY, NULL, clLLE}, -{"=", CL_ORDINARY, NULL, clLE}, -{">", CL_ORDINARY, NULL, clLG}, -{">=", CL_ORDINARY, NULL, clLGE}, -{"ABS", CL_ORDINARY, NULL, NULL}, -{"ACONS", CL_ORDINARY, NULL, clLacons}, -{"ACOS", CL_ORDINARY, NULL, NULL}, -{"ACOSH", CL_ORDINARY, NULL, NULL}, -{"ADJOIN", CL_ORDINARY, NULL, clLadjoin}, -{"ADJUST-ARRAY", CL_ORDINARY, NULL, NULL}, -{"ADJUSTABLE-ARRAY-P", CL_ORDINARY, NULL, clLadjustable_array_p}, -{"ALPHA-CHAR-P", CL_ORDINARY, NULL, clLalpha_char_p}, -{"ALPHANUMERICP", CL_ORDINARY, NULL, clLalphanumericp}, -{"AND", CL_ORDINARY, &clSand, NULL}, -{"APPEND", CL_ORDINARY, &clSappend, clLappend}, -{"APPLY", CL_ORDINARY, &clSapply, clLapply}, -{"APROPOS", CL_ORDINARY, NULL, NULL}, -{"APROPOS-LIST", CL_ORDINARY, NULL, NULL}, -{"AREF", CL_ORDINARY, NULL, clLaref}, -{"ARITHMETIC-ERROR", CL_ORDINARY, &clSarithmetic_error, NULL}, -{"ARRAY", CL_ORDINARY, &clSarray, NULL}, -{"ARRAY-DIMENSION", CL_ORDINARY, NULL, clLarray_dimension}, -{"ARRAY-DIMENSION-LIMIT", CL_ORDINARY, NULL, NULL}, -{"ARRAY-DIMENSIONS", CL_ORDINARY, NULL, NULL}, -{"ARRAY-ELEMENT-TYPE", CL_ORDINARY, NULL, clLarray_element_type}, -{"ARRAY-HAS-FILL-POINTER-P", CL_ORDINARY, NULL, clLarray_has_fill_pointer_p}, -{"ARRAY-IN-BOUNDS-P", CL_ORDINARY, NULL, NULL}, -{"ARRAY-RANK", CL_ORDINARY, NULL, clLarray_rank}, -{"ARRAY-RANK-LIMIT", CL_CONSTANT, NULL, NULL}, -{"ARRAY-ROW-MAJOR-INDEX", CL_ORDINARY, NULL, NULL}, -{"ARRAY-TOTAL-SIZE", CL_ORDINARY, NULL, clLarray_total_size}, -{"ARRAY-TOTAL-SIZE-LIMIT", CL_CONSTANT, NULL, NULL}, -{"ARRAYP", CL_ORDINARY, NULL, clLarrayp}, -{"ASH", CL_ORDINARY, NULL, clLash}, -{"ASIN", CL_ORDINARY, NULL, NULL}, -{"ASINH", CL_ORDINARY, NULL, NULL}, -{"ASSERT", CL_ORDINARY, NULL, NULL}, -{"ASSOC", CL_ORDINARY, NULL, clLassoc}, -{"ASSOC-IF", CL_ORDINARY, NULL, clLassoc_if}, -{"ASSOC-IF-NOT", CL_ORDINARY, NULL, clLassoc_if_not}, -{"ATAN", CL_ORDINARY, NULL, clLatan}, -{"ATANH", CL_ORDINARY, NULL, NULL}, -{"ATOM", CL_ORDINARY, NULL, clLatom}, -{"BASE-CHAR", CL_ORDINARY, &clSbase_char, NULL}, -{"BASE-STRING", CL_ORDINARY, NULL, NULL}, -{"BIGNUM", CL_ORDINARY, &clSbignum, NULL}, -{"BIT", CL_ORDINARY, &clSbit, NULL}, -{"BIT-AND", CL_ORDINARY, NULL, NULL}, -{"BIT-ANDC1", CL_ORDINARY, NULL, NULL}, -{"BIT-ANDC2", CL_ORDINARY, NULL, NULL}, -{"BIT-EQV", CL_ORDINARY, NULL, NULL}, -{"BIT-IOR", CL_ORDINARY, NULL, NULL}, -{"BIT-NAND", CL_ORDINARY, NULL, NULL}, -{"BIT-NOR", CL_ORDINARY, NULL, NULL}, -{"BIT-NOT", CL_ORDINARY, NULL, NULL}, -{"BIT-ORC1", CL_ORDINARY, NULL, NULL}, -{"BIT-ORC2", CL_ORDINARY, NULL, NULL}, -{"BIT-VECTOR", CL_ORDINARY, &clSbit_vector, NULL}, -{"BIT-VECTOR-P", CL_ORDINARY, NULL, clLbit_vector_p}, -{"BIT-XOR", CL_ORDINARY, NULL, NULL}, -{"BLOCK", FORM_ORDINARY, &clSblock, NULL}, -{"BOOLE", CL_ORDINARY, NULL, clLboole}, -{"BOOLE-1", CL_CONSTANT, NULL, NULL}, -{"BOOLE-2", CL_CONSTANT, NULL, NULL}, -{"BOOLE-AND", CL_CONSTANT, NULL, NULL}, -{"BOOLE-ANDC1", CL_CONSTANT, NULL, NULL}, -{"BOOLE-ANDC2", CL_CONSTANT, NULL, NULL}, -{"BOOLE-C1", CL_CONSTANT, NULL, NULL}, -{"BOOLE-C2", CL_CONSTANT, NULL, NULL}, -{"BOOLE-CLR", CL_CONSTANT, NULL, NULL}, -{"BOOLE-EQV", CL_CONSTANT, NULL, NULL}, -{"BOOLE-IOR", CL_CONSTANT, NULL, NULL}, -{"BOOLE-NAND", CL_CONSTANT, NULL, NULL}, -{"BOOLE-NOR", CL_CONSTANT, NULL, NULL}, -{"BOOLE-ORC1", CL_CONSTANT, NULL, NULL}, -{"BOOLE-ORC2", CL_CONSTANT, NULL, NULL}, -{"BOOLE-SET", CL_CONSTANT, NULL, NULL}, -{"BOOLE-XOR", CL_CONSTANT, NULL, NULL}, -{"BOOLEAN", CL_ORDINARY, NULL, NULL}, -{"BOTH-CASE-P", CL_ORDINARY, NULL, clLboth_case_p}, -{"BOUNDP", CL_ORDINARY, NULL, clLboundp}, -{"BREAK", CL_ORDINARY, NULL, NULL}, -{"BROADCAST-STREAM", CL_ORDINARY, &clSbroadcast_stream, NULL}, -{"BUTLAST", CL_ORDINARY, NULL, clLbutlast}, -{"BYTE", CL_ORDINARY, NULL, NULL}, -{"BYTE-POSITION", CL_ORDINARY, NULL, NULL}, -{"BYTE-SIZE", CL_ORDINARY, NULL, NULL}, -{"BYTE8", CL_ORDINARY, &clSbyte8, NULL}, -{"CAAAAR", CL_ORDINARY, NULL, clLcaaaar}, -{"CAAADR", CL_ORDINARY, NULL, clLcaaadr}, -{"CAAAR", CL_ORDINARY, NULL, clLcaaar}, -{"CAADAR", CL_ORDINARY, NULL, clLcaadar}, -{"CAADDR", CL_ORDINARY, NULL, clLcaaddr}, -{"CAADR", CL_ORDINARY, NULL, clLcaadr}, -{"CAAR", CL_ORDINARY, NULL, clLcaar}, -{"CADAAR", CL_ORDINARY, NULL, clLcadaar}, -{"CADADR", CL_ORDINARY, NULL, clLcadadr}, -{"CADAR", CL_ORDINARY, NULL, clLcadar}, -{"CADDAR", CL_ORDINARY, NULL, clLcaddar}, -{"CADDDR", CL_ORDINARY, NULL, clLcadddr}, -{"CADDR", CL_ORDINARY, NULL, clLcaddr}, -{"CADR", CL_ORDINARY, NULL, clLcadr}, -{"CALL-ARGUMENTS-LIMIT", CL_CONSTANT, NULL, NULL}, -{"CAR", CL_ORDINARY, NULL, clLcar}, -{"CASE", FORM_ORDINARY, NULL, NULL}, -{"CATCH", FORM_ORDINARY, NULL, NULL}, -{"CCASE", CL_ORDINARY, NULL, NULL}, -{"CDAAAR", CL_ORDINARY, NULL, clLcdaaar}, -{"CDAADR", CL_ORDINARY, NULL, clLcdaadr}, -{"CDAAR", CL_ORDINARY, NULL, clLcdaar}, -{"CDADAR", CL_ORDINARY, NULL, clLcdadar}, -{"CDADDR", CL_ORDINARY, NULL, clLcdaddr}, -{"CDADR", CL_ORDINARY, NULL, clLcdadr}, -{"CDAR", CL_ORDINARY, NULL, clLcdar}, -{"CDDAAR", CL_ORDINARY, NULL, clLcddaar}, -{"CDDADR", CL_ORDINARY, NULL, clLcddadr}, -{"CDDAR", CL_ORDINARY, NULL, clLcddar}, -{"CDDDAR", CL_ORDINARY, NULL, clLcdddar}, -{"CDDDDR", CL_ORDINARY, NULL, clLcddddr}, -{"CDDDR", CL_ORDINARY, NULL, clLcdddr}, -{"CDDR", CL_ORDINARY, NULL, clLcddr}, -{"CDR", CL_ORDINARY, NULL, clLcdr}, -{"CEILING", CL_ORDINARY, NULL, clLceiling}, -{"CELL-ERROR", CL_ORDINARY, &clScell_error, NULL}, -{"CERROR", CL_ORDINARY, NULL, clLcerror}, -{"CHAR", CL_ORDINARY, NULL, clLchar}, -{"CHAR-CODE", CL_ORDINARY, NULL, clLchar_code}, -{"CHAR-CODE-LIMIT", CL_CONSTANT, NULL, NULL}, -{"CHAR-DOWNCASE", CL_ORDINARY, NULL, clLchar_downcase}, -{"CHAR-EQUAL", CL_ORDINARY, NULL, clLchar_equal}, -{"CHAR-GREATERP", CL_ORDINARY, NULL, clLchar_greaterp}, -{"CHAR-INT", CL_ORDINARY, NULL, clLchar_int}, -{"CHAR-LESSP", CL_ORDINARY, NULL, clLchar_lessp}, -{"CHAR-NAME", CL_ORDINARY, NULL, clLchar_name}, -{"CHAR-NOT-EQUAL", CL_ORDINARY, NULL, clLchar_not_equal}, -{"CHAR-NOT-GREATERP", CL_ORDINARY, NULL, clLchar_not_greaterp}, -{"CHAR-NOT-LESSP", CL_ORDINARY, NULL, clLchar_not_lessp}, -{"CHAR-UPCASE", CL_ORDINARY, NULL, clLchar_upcase}, -{"CHAR/=", CL_ORDINARY, NULL, clLcharNE}, -{"CHAR<", CL_ORDINARY, NULL, clLcharL}, -{"CHAR<=", CL_ORDINARY, NULL, clLcharLE}, -{"CHAR=", CL_ORDINARY, NULL, clLcharE}, -{"CHAR>", CL_ORDINARY, NULL, clLcharG}, -{"CHAR>=", CL_ORDINARY, NULL, clLcharGE}, -{"CHARACTER", CL_ORDINARY, &clScharacter, clLcharacter}, -{"CHARACTERP", CL_ORDINARY, NULL, clLcharacterp}, -{"CHECK-TYPE", CL_ORDINARY, NULL, NULL}, -{"CIS", CL_ORDINARY, NULL, NULL}, -{"CLEAR-INPUT", CL_ORDINARY, NULL, clLclear_input}, -{"CLEAR-OUTPUT", CL_ORDINARY, NULL, clLclear_output}, -{"CLOSE", CL_ORDINARY, NULL, clLclose}, -{"CLRHASH", CL_ORDINARY, NULL, clLclrhash}, -{"CODE-CHAR", CL_ORDINARY, NULL, clLcode_char}, -{"COERCE", CL_ORDINARY, NULL, NULL}, -{"COMMON", CL_ORDINARY, &clScommon, NULL}, -{"COMMONP", CL_ORDINARY, NULL, clLcommonp}, -{"COMPILATION-SPEED", CL_ORDINARY, NULL, NULL}, -{"COMPILE", CL_ORDINARY, &clScompile, NULL}, -{"COMPILE-FILE", CL_ORDINARY, NULL, NULL}, -{"COMPILE-FILE-PATHNAME", CL_ORDINARY, NULL, NULL}, -{"COMPILED-FUNCTION", CL_ORDINARY, &clScompiled_function, NULL}, -{"COMPILED-FUNCTION-P", CL_ORDINARY, NULL, clLcompiled_function_p}, -{"COMPILER-LET", FORM_ORDINARY, NULL, NULL}, -{"COMPILER-MACRO-FUNCTION", CL_ORDINARY, NULL, NULL}, -{"COMPLEMENT", CL_ORDINARY, NULL, NULL}, -{"COMPLEX", CL_ORDINARY, &clScomplex, clLcomplex}, -{"COMPLEXP", CL_ORDINARY, NULL, clLcomplexp}, -{"CONCATENATE", CL_ORDINARY, NULL, NULL}, -{"CONCATENATED-STREAM", CL_ORDINARY, &clSconcatenated_stream, NULL}, -{"COND", FORM_ORDINARY, NULL, NULL}, -{"CONDITION", CL_ORDINARY, &clScondition, NULL}, -{"CONJUGATE", CL_ORDINARY, NULL, clLconjugate}, -{"CONS", CL_ORDINARY, &clScons, clLcons}, -{"CONSP", CL_ORDINARY, NULL, clLconsp}, -{"CONSTANTLY", CL_ORDINARY, NULL, NULL}, -{"CONSTANTP", CL_ORDINARY, NULL, clLconstantp}, -{"COPY-ALIST", CL_ORDINARY, NULL, clLcopy_alist}, -{"COPY-LIST", CL_ORDINARY, NULL, clLcopy_list}, -{"COPY-READTABLE", CL_ORDINARY, NULL, clLcopy_readtable}, -{"COPY-SEQ", CL_ORDINARY, NULL, clLcopy_seq}, -{"COPY-SYMBOL", CL_ORDINARY, NULL, clLcopy_symbol}, -{"COPY-TREE", CL_ORDINARY, NULL, clLcopy_tree}, -{"COS", CL_ORDINARY, NULL, clLcos}, -{"COSH", CL_ORDINARY, NULL, clLcosh}, -{"COUNT", CL_ORDINARY, NULL, NULL}, -{"COUNT-IF", CL_ORDINARY, NULL, NULL}, -{"COUNT-IF-NOT", CL_ORDINARY, NULL, NULL}, -{"CTYPECASE", CL_ORDINARY, NULL, NULL}, -{"DEBUG", CL_ORDINARY, NULL, NULL}, -{"DECF", CL_ORDINARY, NULL, NULL}, -{"DECLAIM", CL_ORDINARY, NULL, NULL}, -{"DECLARATION", CL_ORDINARY, NULL, NULL}, -{"DECLARE", FORM_ORDINARY, &clSdeclare, NULL}, -{"DECODE-FLOAT", CL_ORDINARY, NULL, clLdecode_float}, -{"DECODE-UNIVERSAL-TIME", CL_ORDINARY, NULL, NULL}, -{"DEFCONSTANT", CL_ORDINARY, NULL, NULL}, -{"DEFINE-COMPILER-MACRO", CL_ORDINARY, NULL, NULL}, -{"DEFINE-MODIFY-MACRO", CL_ORDINARY, NULL, NULL}, -{"DEFINE-SETF-EXPANDER", CL_ORDINARY, NULL, NULL}, -{"DEFINE-SYMBOL-MACRO", CL_ORDINARY, NULL, NULL}, -{"DEFMACRO", CL_ORDINARY, NULL, NULL}, -{"DEFPACKAGE", CL_ORDINARY, NULL, NULL}, -{"DEFPARAMETER", CL_ORDINARY, NULL, NULL}, -{"DEFSETF", CL_ORDINARY, NULL, NULL}, -{"DEFSTRUCT", CL_ORDINARY, NULL, NULL}, -{"DEFTYPE", CL_ORDINARY, NULL, NULL}, -{"DEFUN", CL_ORDINARY, NULL, NULL}, -{"DEFVAR", CL_ORDINARY, NULL, NULL}, -{"DELETE", CL_ORDINARY, NULL, NULL}, -{"DELETE-DUPLICATES", CL_ORDINARY, NULL, NULL}, -{"DELETE-FILE", CL_ORDINARY, NULL, clLdelete_file}, -{"DELETE-IF", CL_ORDINARY, NULL, NULL}, -{"DELETE-IF-NOT", CL_ORDINARY, NULL, NULL}, -{"DELETE-PACKAGE", CL_ORDINARY, NULL, clLdelete_package}, -{"DENOMINATOR", CL_ORDINARY, NULL, clLdenominator}, -{"DEPOSIT-FIELD", CL_ORDINARY, NULL, NULL}, -{"DESCRIBE", CL_ORDINARY, NULL, NULL}, -{"DESTRUCTURING-BIND", CL_ORDINARY, NULL, NULL}, -{"DIGIT-CHAR", CL_ORDINARY, NULL, clLdigit_char}, -{"DIGIT-CHAR-P", CL_ORDINARY, NULL, clLdigit_char_p}, -{"DIRECTORY", CL_ORDINARY, NULL, clLdirectory}, -{"DIRECTORY-NAMESTRING", CL_ORDINARY, NULL, clLdirectory_namestring}, -{"DISASSEMBLE", CL_ORDINARY, NULL, NULL}, -{"DISPATCH-FUNCTION", CL_ORDINARY, &clSdispatch_function, NULL}, -{"DIVISION-BY-ZERO", CL_ORDINARY, &clSdivision_by_zero, NULL}, -{"DO", FORM_ORDINARY, NULL, NULL}, -{"DO*", FORM_ORDINARY, NULL, NULL}, -{"DO-ALL-SYMBOLS", CL_ORDINARY, NULL, NULL}, -{"DO-EXTERNAL-SYMBOLS", CL_ORDINARY, NULL, NULL}, -{"DO-SYMBOLS", CL_ORDINARY, NULL, NULL}, -{"DOCUMENTATION", CL_ORDINARY, NULL, NULL}, -{"DOLIST", FORM_ORDINARY, NULL, NULL}, -{"DOTIMES", FORM_ORDINARY, NULL, NULL}, -{"DOUBLE-FLOAT", CL_ORDINARY, &clSdouble_float, NULL}, -{"DOUBLE-FLOAT-EPSILON", CL_CONSTANT, NULL, NULL}, -{"DOUBLE-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, NULL}, -{"DPB", CL_ORDINARY, NULL, NULL}, -{"DRIBBLE", CL_ORDINARY, NULL, NULL}, -{"ECASE", CL_ORDINARY, NULL, NULL}, -{"ECHO-STREAM", CL_ORDINARY, &clSecho_stream, NULL}, -{"ED", CL_ORDINARY, NULL, NULL}, -{"EIGHTH", CL_ORDINARY, NULL, clLeighth}, -{"ELT", CL_ORDINARY, NULL, clLelt}, -{"ENCODE-UNIVERSAL-TIME", CL_ORDINARY, NULL, NULL}, -{"END-OF-FILE", CL_ORDINARY, &clSend_of_file, NULL}, -{"ENDP", CL_ORDINARY, NULL, clLendp}, -{"ENOUGH-NAMESTRING", CL_ORDINARY, NULL, clLenough_namestring}, -{"EQ", CL_ORDINARY, &clSeq, clLeq}, -{"EQL", CL_ORDINARY, &clSeql, clLeql}, -{"EQUAL", CL_ORDINARY, &clSequal, clLequal}, -{"EQUALP", CL_ORDINARY, NULL, clLequalp}, -{"ERROR", CL_ORDINARY, &clSerror, clLerror}, -{"ETYPECASE", CL_ORDINARY, NULL, NULL}, -{"EVAL", CL_ORDINARY, &clSeval, clLeval}, -{"EVAL-WHEN", FORM_ORDINARY, NULL, NULL}, -{"EVENP", CL_ORDINARY, NULL, clLevenp}, -{"EVERY", CL_ORDINARY, NULL, NULL}, -{"EXP", CL_ORDINARY, NULL, clLexp}, -{"EXPORT", CL_ORDINARY, NULL, clLexport}, -{"EXPT", CL_ORDINARY, NULL, clLexpt}, -{"EXTENDED-CHAR", CL_ORDINARY, &clSextended_char, NULL}, -{"FBOUNDP", CL_ORDINARY, NULL, clLfboundp}, -{"FCEILING", CL_ORDINARY, NULL, NULL}, -{"FFLOOR", CL_ORDINARY, NULL, NULL}, -{"FIFTH", CL_ORDINARY, NULL, clLfifth}, -{"FILE-AUTHOR", CL_ORDINARY, NULL, clLfile_author}, -{"FILE-ERROR", CL_ORDINARY, &clSfile_error, NULL}, -{"FILE-LENGTH", CL_ORDINARY, NULL, clLfile_length}, -{"FILE-NAMESTRING", CL_ORDINARY, NULL, clLfile_namestring}, -{"FILE-POSITION", CL_ORDINARY, NULL, clLfile_position}, -{"FILE-STREAM", CL_ORDINARY, &clSfile_stream, NULL}, -{"FILE-WRITE-DATE", CL_ORDINARY, NULL, clLfile_write_date}, -{"FILL", CL_ORDINARY, NULL, NULL}, -{"FILL-POINTER", CL_ORDINARY, NULL, clLfill_pointer}, -{"FIND", CL_ORDINARY, NULL, NULL}, -{"FIND-ALL-SYMBOLS", CL_ORDINARY, NULL, NULL}, -{"FIND-IF", CL_ORDINARY, NULL, NULL}, -{"FIND-IF-NOT", CL_ORDINARY, NULL, NULL}, -{"FIND-PACKAGE", CL_ORDINARY, NULL, clLfind_package}, -{"FIND-SYMBOL", CL_ORDINARY, NULL, clLfind_symbol}, -{"FINISH-OUTPUT", CL_ORDINARY, NULL, clLforce_output}, -{"FIRST", CL_ORDINARY, NULL, clLcar}, -{"FIXNUM", CL_ORDINARY, &clSfixnum, NULL}, -{"FLET", FORM_ORDINARY, NULL, NULL}, -{"FLOAT", CL_ORDINARY, &clSfloat, clLfloat}, -{"FLOAT-DIGITS", CL_ORDINARY, NULL, clLfloat_digits}, -{"FLOAT-PRECISION", CL_ORDINARY, NULL, clLfloat_precision}, -{"FLOAT-RADIX", CL_ORDINARY, NULL, clLfloat_radix}, -{"FLOAT-SIGN", CL_ORDINARY, NULL, clLfloat_sign}, -{"FLOATING-POINT-INEXACT", CL_ORDINARY, &clSfloating_point_inexact, NULL}, -{"FLOATING-POINT-INVALID-OPERATION", CL_ORDINARY, &clSfloating_point_invalid_operation, NULL}, -{"FLOATING-POINT-OVERFLOW", CL_ORDINARY, &clSfloating_point_overflow, NULL}, -{"FLOATING-POINT-UNDERFLOW", CL_ORDINARY, &clSfloating_point_underflow, NULL}, -{"FLOATP", CL_ORDINARY, NULL, clLfloatp}, -{"FLOOR", CL_ORDINARY, NULL, clLfloor}, -{"FMAKUNBOUND", CL_ORDINARY, NULL, clLfmakunbound}, -{"FORCE-OUTPUT", CL_ORDINARY, NULL, clLforce_output}, -{"FORMAT", CL_ORDINARY, NULL, clLformat}, -{"FOURTH", CL_ORDINARY, NULL, clLcadddr}, -{"FRESH-LINE", CL_ORDINARY, NULL, clLfresh_line}, -{"FROUND", CL_ORDINARY, NULL, NULL}, -{"FTRUNCATE", CL_ORDINARY, NULL, NULL}, -{"FTYPE", CL_ORDINARY, NULL, NULL}, -{"FUNCALL", CL_ORDINARY, &clSfuncall, clLfuncall}, -{"FUNCTION", FORM_ORDINARY, &clSfunction, NULL}, -{"FUNCTIONP", CL_ORDINARY, NULL, clLfunctionp}, -{"GCD", CL_ORDINARY, NULL, clLgcd}, -{"GENSYM", CL_ORDINARY, NULL, clLgensym}, -{"GENTEMP", CL_ORDINARY, NULL, clLgentemp}, -{"GET", CL_ORDINARY, NULL, clLget}, -{"GET-DECODED-TIME", CL_ORDINARY, NULL, NULL}, -{"GET-DISPATCH-MACRO-CHARACTER", CL_ORDINARY, NULL, clLget_dispatch_macro_character}, -{"GET-INTERNAL-REAL-TIME", CL_ORDINARY, NULL, clLget_internal_real_time}, -{"GET-INTERNAL-RUN-TIME", CL_ORDINARY, NULL, clLget_internal_run_time}, -{"GET-MACRO-CHARACTER", CL_ORDINARY, NULL, clLget_macro_character}, -{"GET-OUTPUT-STREAM-STRING", CL_ORDINARY, NULL, clLget_output_stream_string}, -{"GET-PROPERTIES", CL_ORDINARY, NULL, clLget_properties}, -{"GET-SETF-EXPANSION", CL_ORDINARY, NULL, NULL}, -{"GET-UNIVERSAL-TIME", CL_ORDINARY, NULL, clLget_universal_time}, -{"GETF", CL_ORDINARY, NULL, clLgetf}, -{"GETHASH", CL_ORDINARY, NULL, clLgethash}, -{"GO", FORM_ORDINARY, NULL, NULL}, -{"GRAPHIC-CHAR-P", CL_ORDINARY, NULL, clLgraphic_char_p}, -{"HASH-TABLE", CL_ORDINARY, &clShash_table, NULL}, -{"HASH-TABLE-COUNT", CL_ORDINARY, NULL, clLhash_table_count}, -{"HASH-TABLE-P", CL_ORDINARY, NULL, clLhash_table_p}, -{"HASH-TABLE-REHASH-SIZE", CL_ORDINARY, NULL, clLhash_table_rehash_size}, -{"HASH-TABLE-REHASH-THRESHOLD", CL_ORDINARY, NULL, clLhash_table_rehash_threshold}, -{"HOST-NAMESTRING", CL_ORDINARY, NULL, clLhost_namestring}, -{"IDENTITY", CL_ORDINARY, NULL, clLidentity}, -{"IGNORE", CL_ORDINARY, NULL, NULL}, -{"IMAGPART", CL_ORDINARY, NULL, clLimagpart}, -{"IMPORT", CL_ORDINARY, NULL, clLimport}, -{"IN-PACKAGE", CL_ORDINARY, NULL, NULL}, -{"INCF", CL_ORDINARY, NULL, NULL}, -{"INLINE", CL_ORDINARY, NULL, NULL}, -{"INPUT-STREAM-P", CL_ORDINARY, NULL, clLinput_stream_p}, -{"INSPECT", CL_ORDINARY, NULL, NULL}, -{"INSTANCE", CL_ORDINARY, &clSinstance, NULL}, -{"INT-CHAR", CL_ORDINARY, NULL, clLint_char}, -{"INTEGER", CL_ORDINARY, &clSinteger, NULL}, -{"INTEGER-DECODE-FLOAT", CL_ORDINARY, NULL, clLinteger_decode_float}, -{"INTEGER-LENGTH", CL_ORDINARY, NULL, clLinteger_length}, -{"INTEGER8", CL_ORDINARY, &clSinteger8, NULL}, -{"INTEGERP", CL_ORDINARY, NULL, clLintegerp}, -{"INTERN", CL_ORDINARY, NULL, clLintern}, -{"INTERNAL-TIME-UNITS-PER-SECOND", CL_CONSTANT, NULL, NULL}, -{"INTERSECTION", CL_ORDINARY, NULL, NULL}, -{"ISQRT", CL_ORDINARY, NULL, NULL}, -{"KEYWORD", CL_ORDINARY, &clSkeyword, NULL}, -{"KEYWORDP", CL_ORDINARY, NULL, clLkeywordp}, -{"LABELS", FORM_ORDINARY, NULL, NULL}, -{"LAMBDA", FORM_ORDINARY, &clSlambda, NULL}, -{"LAMBDA-BLOCK", CL_ORDINARY, &clSlambda_block, NULL}, -{"LAMBDA-LIST-KEYWORDS", CL_CONSTANT, NULL, NULL}, -{"LAMBDA-PARAMETERS-LIMIT", CL_CONSTANT, NULL, NULL}, -{"LAST", CL_ORDINARY, NULL, clLlast}, -{"LCM", CL_ORDINARY, NULL, clLlcm}, -{"LDB", CL_ORDINARY, NULL, NULL}, -{"LDB-TEST", CL_ORDINARY, NULL, NULL}, -{"LDIFF", CL_ORDINARY, NULL, clLldiff}, -{"LEAST-NEGATIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LEAST-NEGATIVE-LONG-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LEAST-NEGATIVE-SHORT-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LEAST-NEGATIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LEAST-POSITIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LEAST-POSITIVE-LONG-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LEAST-POSITIVE-SHORT-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LEAST-POSITIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"LENGTH", CL_ORDINARY, NULL, clLlength}, -{"LET", FORM_ORDINARY, NULL, NULL}, -{"LET*", FORM_ORDINARY, NULL, NULL}, -{"LISP-IMPLEMENTATION-TYPE", CL_ORDINARY, NULL, NULL}, -{"LISP-IMPLEMENTATION-VERSION", CL_ORDINARY, NULL, NULL}, -{"LIST", CL_ORDINARY, &clSlist, clLlist}, -{"LIST*", CL_ORDINARY, &clSlistX, clLlistX}, -{"LIST-ALL-PACKAGES", CL_ORDINARY, NULL, clLlist_all_packages}, -{"LIST-LENGTH", CL_ORDINARY, NULL, clLlist_length}, -{"LISTEN", CL_ORDINARY, NULL, clLlisten}, -{"LISTP", CL_ORDINARY, NULL, clLlistp}, -{"LOAD", CL_ORDINARY, &clSload, clLload}, -{"LOAD-TIME-VALUE", CL_ORDINARY, NULL, NULL}, -{"LOCALLY", FORM_ORDINARY, NULL, NULL}, -{"LOG", CL_ORDINARY, NULL, clLlog}, -{"LOGAND", CL_ORDINARY, NULL, clLlogand}, -{"LOGANDC1", CL_ORDINARY, NULL, clLlogandc1}, -{"LOGANDC2", CL_ORDINARY, NULL, clLlogandc2}, -{"LOGBITP", CL_ORDINARY, NULL, clLlogbitp}, -{"LOGCOUNT", CL_ORDINARY, NULL, clLlogcount}, -{"LOGEQV", CL_ORDINARY, NULL, clLlogeqv}, -{"LOGICAL-PATHNAME", CL_ORDINARY, &clSlogical_pathname, NULL}, -{"LOGICAL-PATHNAME-TRANSLATIONS", CL_ORDINARY, NULL, NULL}, -{"LOGIOR", CL_ORDINARY, NULL, clLlogior}, -{"LOGNAND", CL_ORDINARY, NULL, clLlognand}, -{"LOGNOR", CL_ORDINARY, NULL, clLlognor}, -{"LOGNOT", CL_ORDINARY, NULL, clLlognot}, -{"LOGORC1", CL_ORDINARY, NULL, clLlogorc1}, -{"LOGORC2", CL_ORDINARY, NULL, clLlogorc2}, -{"LOGTEST", CL_ORDINARY, NULL, NULL}, -{"LOGXOR", CL_ORDINARY, NULL, clLlogxor}, -{"LONG-FLOAT", CL_ORDINARY, &clSlong_float, NULL}, -{"LONG-FLOAT-EPSILON", CL_CONSTANT, NULL, NULL}, -{"LONG-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, NULL}, -{"LONG-SITE-NAME", CL_ORDINARY, NULL, NULL}, -{"LOOP", CL_ORDINARY, NULL, NULL}, -{"LOOP-FINISH", CL_ORDINARY, NULL, NULL}, -{"LOWER-CASE-P", CL_ORDINARY, NULL, clLlower_case_p}, -{"MACHINE-INSTANCE", CL_ORDINARY, NULL, NULL}, -{"MACHINE-TYPE", CL_ORDINARY, NULL, NULL}, -{"MACHINE-VERSION", CL_ORDINARY, NULL, NULL}, -{"MACRO", CL_ORDINARY, &clSmacro, NULL}, -{"MACRO-FUNCTION", CL_ORDINARY, NULL, clLmacro_function}, -{"MACROEXPAND", CL_ORDINARY, NULL, clLmacroexpand}, -{"MACROEXPAND-1", CL_ORDINARY, NULL, clLmacroexpand_1}, -{"MACROLET", FORM_ORDINARY, NULL, NULL}, -{"MAKE-ARRAY", CL_ORDINARY, NULL, NULL}, -{"MAKE-BROADCAST-STREAM", CL_ORDINARY, NULL, clLmake_broadcast_stream}, -{"MAKE-CONCATENATED-STREAM", CL_ORDINARY, NULL, clLmake_concatenated_stream}, -{"MAKE-DISPATCH-MACRO-CHARACTER", CL_ORDINARY, NULL, clLmake_dispatch_macro_character}, -{"MAKE-ECHO-STREAM", CL_ORDINARY, NULL, clLmake_echo_stream}, -{"MAKE-HASH-TABLE", CL_ORDINARY, NULL, clLmake_hash_table}, -{"MAKE-LIST", CL_ORDINARY, NULL, clLmake_list}, -{"MAKE-PACKAGE", CL_ORDINARY, NULL, clLmake_package}, -{"MAKE-PATHNAME", CL_ORDINARY, NULL, clLmake_pathname}, -{"MAKE-RANDOM-STATE", CL_ORDINARY, NULL, clLmake_random_state}, -{"MAKE-SEQUENCE", CL_ORDINARY, NULL, NULL}, -{"MAKE-STRING", CL_ORDINARY, NULL, clLmake_string}, -{"MAKE-STRING-INPUT-STREAM", CL_ORDINARY, NULL, clLmake_string_input_stream}, -{"MAKE-STRING-OUTPUT-STREAM", CL_ORDINARY, NULL, clLmake_string_output_stream}, -{"MAKE-SYMBOL", CL_ORDINARY, NULL, clLmake_symbol}, -{"MAKE-SYNONYM-STREAM", CL_ORDINARY, NULL, clLmake_synonym_stream}, -{"MAKE-TWO-WAY-STREAM", CL_ORDINARY, NULL, clLmake_two_way_stream}, -{"MAKUNBOUND", CL_ORDINARY, NULL, clLmakunbound}, -{"MAP", CL_ORDINARY, NULL, NULL}, -{"MAP-INTO", CL_ORDINARY, NULL, NULL}, -{"MAPC", CL_ORDINARY, NULL, clLmapc}, -{"MAPCAN", CL_ORDINARY, NULL, clLmapcan}, -{"MAPCAR", CL_ORDINARY, NULL, clLmapcar}, -{"MAPCON", CL_ORDINARY, NULL, clLmapcon}, -{"MAPHASH", CL_ORDINARY, NULL, clLmaphash}, -{"MAPL", CL_ORDINARY, NULL, clLmapl}, -{"MAPLIST", CL_ORDINARY, NULL, clLmaplist}, -{"MASK-FIELD", CL_ORDINARY, NULL, NULL}, -{"MAX", CL_ORDINARY, NULL, clLmax}, -{"MEMBER", CL_ORDINARY, &clSmember, clLmember}, -{"MEMBER-IF", CL_ORDINARY, NULL, clLmember_if}, -{"MEMBER-IF-NOT", CL_ORDINARY, NULL, clLmember_if_not}, -{"MERGE", CL_ORDINARY, NULL, NULL}, -{"MERGE-PATHNAMES", CL_ORDINARY, NULL, clLmerge_pathnames}, -{"MIN", CL_ORDINARY, NULL, clLmin}, -{"MINUSP", CL_ORDINARY, NULL, clLminusp}, -{"MISMATCH", CL_ORDINARY, NULL, NULL}, -{"MOD", CL_ORDINARY, &clSmod, clLmod}, -{"MOST-NEGATIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MOST-NEGATIVE-FIXNUM", CL_CONSTANT, NULL, NULL}, -{"MOST-NEGATIVE-LONG-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MOST-NEGATIVE-SHORT-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MOST-NEGATIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MOST-POSITIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MOST-POSITIVE-FIXNUM", CL_CONSTANT, NULL, NULL}, -{"MOST-POSITIVE-LONG-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MOST-POSITIVE-SHORT-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MOST-POSITIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, NULL}, -{"MULTIPLE-VALUE-BIND", FORM_ORDINARY, NULL, NULL}, -{"MULTIPLE-VALUE-CALL", FORM_ORDINARY, NULL, NULL}, -{"MULTIPLE-VALUE-LIST", FORM_ORDINARY, NULL, NULL}, -{"MULTIPLE-VALUE-PROG1", FORM_ORDINARY, NULL, NULL}, -{"MULTIPLE-VALUE-SETQ", FORM_ORDINARY, NULL, NULL}, -{"NAME-CHAR", CL_ORDINARY, NULL, clLname_char}, -{"NAMED-LAMBDA", FORM_ORDINARY, NULL, NULL}, -{"NAMESTRING", CL_ORDINARY, NULL, clLnamestring}, -{"NBUTLAST", CL_ORDINARY, NULL, clLnbutlast}, -{"NCONC", CL_ORDINARY, &clSnconc, clLnconc}, -{"NINTERSECTION", CL_ORDINARY, NULL, NULL}, -{"NINTH", CL_ORDINARY, NULL, clLninth}, -{"NOT", CL_ORDINARY, &clSnot, clLnull}, -{"NOTANY", CL_ORDINARY, NULL, NULL}, -{"NOTEVERY", CL_ORDINARY, NULL, NULL}, -{"NOTINLINE", CL_ORDINARY, NULL, NULL}, -{"NRECONC", CL_ORDINARY, NULL, clLnreconc}, -{"NREVERSE", CL_ORDINARY, NULL, clLnreverse}, -{"NSET-DIFFERENCE", CL_ORDINARY, NULL, NULL}, -{"NSET-EXCLUSIVE-OR", CL_ORDINARY, NULL, NULL}, -{"NSTRING-CAPITALIZE", CL_ORDINARY, NULL, clLnstring_capitalize}, -{"NSTRING-DOWNCASE", CL_ORDINARY, NULL, clLnstring_downcase}, -{"NSTRING-UPCASE", CL_ORDINARY, NULL, clLnstring_upcase}, -{"NSUBLIS", CL_ORDINARY, NULL, clLnsublis}, -{"NSUBST", CL_ORDINARY, NULL, clLnsubst}, -{"NSUBST-IF", CL_ORDINARY, NULL, clLnsubst_if}, -{"NSUBST-IF-NOT", CL_ORDINARY, NULL, clLnsubst_if_not}, -{"NSUBSTITUTE", CL_ORDINARY, NULL, NULL}, -{"NSUBSTITUTE-IF", CL_ORDINARY, NULL, NULL}, -{"NSUBSTITUTE-IF-NOT", CL_ORDINARY, NULL, NULL}, -{"NTH", CL_ORDINARY, NULL, clLnth}, -{"NTH-VALUE", FORM_ORDINARY, NULL, NULL}, -{"NTHCDR", CL_ORDINARY, NULL, clLnthcdr}, -{"NULL", CL_ORDINARY, &clSnull, clLnull}, -{"NUMBER", CL_ORDINARY, &clSnumber, NULL}, -{"NUMBERP", CL_ORDINARY, NULL, clLnumberp}, -{"NUMERATOR", CL_ORDINARY, NULL, clLnumerator}, -{"NUNION", CL_ORDINARY, NULL, NULL}, -{"ODDP", CL_ORDINARY, NULL, clLoddp}, -{"OPEN", CL_ORDINARY, NULL, clLopen}, -{"OPEN-STREAM-P", CL_ORDINARY, NULL, clLopen_stream_p}, -{"OPTIMIZE", CL_ORDINARY, NULL, NULL}, -{"OR", CL_ORDINARY, &clSor, NULL}, -{"OTHERWISE", CL_ORDINARY, &clSotherwise, NULL}, -{"OUTPUT-STREAM-P", CL_ORDINARY, NULL, clLoutput_stream_p}, -{"PACKAGE", CL_ORDINARY, &clSpackage, NULL}, -{"PACKAGE-ERROR", CL_ORDINARY, &clSpackage_error, NULL}, -{"PACKAGE-NAME", CL_ORDINARY, NULL, clLpackage_name}, -{"PACKAGE-NICKNAMES", CL_ORDINARY, NULL, clLpackage_nicknames}, -{"PACKAGE-SHADOWING-SYMBOLS", CL_ORDINARY, NULL, clLpackage_shadowing_symbols}, -{"PACKAGE-USE-LIST", CL_ORDINARY, NULL, clLpackage_use_list}, -{"PACKAGE-USED-BY-LIST", CL_ORDINARY, NULL, clLpackage_used_by_list}, -{"PACKAGEP", CL_ORDINARY, NULL, clLpackagep}, -{"PAIRLIS", CL_ORDINARY, NULL, clLpairlis}, -{"PARSE-ERROR", CL_ORDINARY, &clSparse_error, NULL}, -{"PARSE-INTEGER", CL_ORDINARY, NULL, clLparse_integer}, -{"PARSE-NAMESTRING", CL_ORDINARY, NULL, clLparse_namestring}, -{"PATHNAME", CL_ORDINARY, &clSpathname, clLpathname}, -{"PATHNAME-DEVICE", CL_ORDINARY, NULL, clLpathname_device}, -{"PATHNAME-DIRECTORY", CL_ORDINARY, NULL, clLpathname_directory}, -{"PATHNAME-HOST", CL_ORDINARY, NULL, clLpathname_host}, -{"PATHNAME-MATCH-P", CL_ORDINARY, NULL, clLpathname_match_p}, -{"PATHNAME-NAME", CL_ORDINARY, NULL, clLpathname_name}, -{"PATHNAME-TYPE", CL_ORDINARY, NULL, clLpathname_type}, -{"PATHNAME-VERSION", CL_ORDINARY, NULL, clLpathname_version}, -{"PATHNAMEP", CL_ORDINARY, NULL, clLpathnamep}, -{"PEEK-CHAR", CL_ORDINARY, NULL, clLpeek_char}, -{"PHASE", CL_ORDINARY, NULL, NULL}, -{"PI", CL_ORDINARY, NULL, NULL}, -{"PLUSP", CL_ORDINARY, &clSplusp, clLplusp}, -{"POP", CL_ORDINARY, NULL, NULL}, -{"POSITION", CL_ORDINARY, NULL, NULL}, -{"POSITION-IF", CL_ORDINARY, NULL, NULL}, -{"POSITION-IF-NOT", CL_ORDINARY, NULL, NULL}, -{"PPRINT", CL_ORDINARY, NULL, clLpprint}, -{"PRIN1", CL_ORDINARY, NULL, clLprin1}, -{"PRIN1-TO-STRING", CL_ORDINARY, NULL, NULL}, -{"PRINC", CL_ORDINARY, NULL, clLprinc}, -{"PRINC-TO-STRING", CL_ORDINARY, NULL, NULL}, -{"PRINT", CL_ORDINARY, NULL, clLprint}, -{"PRINT-NOT-READABLE", CL_ORDINARY, &clSprint_not_readable, NULL}, -{"PROBE-FILE", CL_ORDINARY, NULL, clLprobe_file}, -{"PROCLAIM", CL_ORDINARY, NULL, NULL}, -{"PROG", FORM_ORDINARY, NULL, NULL}, -{"PROG*", FORM_ORDINARY, NULL, NULL}, -{"PROG1", FORM_ORDINARY, NULL, NULL}, -{"PROG2", FORM_ORDINARY, NULL, NULL}, -{"PROGN", FORM_ORDINARY, &clSprogn, NULL}, -{"PROGRAM-ERROR", CL_ORDINARY, &clSprogram_error, NULL}, -{"PROGV", FORM_ORDINARY, NULL, NULL}, -{"PROVIDE", CL_ORDINARY, NULL, NULL}, -{"PSETF", CL_ORDINARY, &clSpsetf, NULL}, -{"PSETQ", FORM_ORDINARY, NULL, NULL}, -{"PUSH", CL_ORDINARY, NULL, NULL}, -{"PUSHNEW", CL_ORDINARY, NULL, NULL}, -{"QUIT", CL_ORDINARY, NULL, clLquit}, -{"QUOTE", FORM_ORDINARY, &clSquote, NULL}, -{"RANDOM", CL_ORDINARY, NULL, clLrandom}, -{"RANDOM-STATE", CL_ORDINARY, &clSrandom_state, NULL}, -{"RANDOM-STATE-P", CL_ORDINARY, NULL, clLrandom_state_p}, -{"RASSOC", CL_ORDINARY, NULL, clLrassoc}, -{"RASSOC-IF", CL_ORDINARY, NULL, clLrassoc_if}, -{"RASSOC-IF-NOT", CL_ORDINARY, NULL, clLrassoc_if_not}, -{"RATIO", CL_ORDINARY, &clSratio, NULL}, -{"RATIONAL", CL_ORDINARY, &clSrational, NULL}, -{"RATIONALIZE", CL_ORDINARY, NULL, NULL}, -{"RATIONALP", CL_ORDINARY, NULL, clLrationalp}, -{"READ", CL_ORDINARY, NULL, clLread}, -{"READ-BYTE", CL_ORDINARY, NULL, clLread_byte}, -{"READ-CHAR", CL_ORDINARY, NULL, clLread_char}, -{"READ-CHAR-NO-HANG", CL_ORDINARY, NULL, clLread_char_no_hang}, -{"READ-DELIMITED-LIST", CL_ORDINARY, NULL, clLread_delimited_list}, -{"READ-FROM-STRING", CL_ORDINARY, NULL, NULL}, -{"READ-LINE", CL_ORDINARY, NULL, clLread_line}, -{"READ-PRESERVING-WHITESPACE", CL_ORDINARY, NULL, clLread_preserving_whitespace}, -{"READER-ERROR", CL_ORDINARY, &clSreader_error, NULL}, -{"READTABLE", CL_ORDINARY, &clSreadtable, NULL}, -{"READTABLEP", CL_ORDINARY, NULL, clLreadtablep}, -{"REAL", CL_ORDINARY, &clSreal, NULL}, -{"REALP", CL_ORDINARY, NULL, clLrealp}, -{"REALPART", CL_ORDINARY, NULL, clLrealpart}, -{"REDUCE", CL_ORDINARY, NULL, NULL}, -{"REM", CL_ORDINARY, NULL, clLrem}, -{"REMF", CL_ORDINARY, NULL, NULL}, -{"REMHASH", CL_ORDINARY, NULL, clLremhash}, -{"REMOVE", CL_ORDINARY, NULL, NULL}, -{"REMOVE-DUPLICATES", CL_ORDINARY, NULL, NULL}, -{"REMOVE-IF", CL_ORDINARY, NULL, NULL}, -{"REMOVE-IF-NOT", CL_ORDINARY, NULL, NULL}, -{"REMPROP", CL_ORDINARY, NULL, clLremprop}, -{"RENAME-FILE", CL_ORDINARY, NULL, clLrename_file}, -{"RENAME-PACKAGE", CL_ORDINARY, NULL, clLrename_package}, -{"REPLACE", CL_ORDINARY, NULL, NULL}, -{"REQUIRE", CL_ORDINARY, NULL, NULL}, -{"REST", CL_ORDINARY, NULL, clLcdr}, -{"RETURN", FORM_ORDINARY, NULL, NULL}, -{"RETURN-FROM", FORM_ORDINARY, NULL, NULL}, -{"REVAPPEND", CL_ORDINARY, NULL, clLrevappend}, -{"REVERSE", CL_ORDINARY, NULL, clLreverse}, -{"ROOM", CL_ORDINARY, NULL, NULL}, -{"ROTATEF", CL_ORDINARY, NULL, NULL}, -{"ROUND", CL_ORDINARY, NULL, clLround}, -{"ROW-MAJOR-AREF", CL_ORDINARY, NULL, clLrow_major_aref}, -{"RPLACA", CL_ORDINARY, NULL, clLrplaca}, -{"RPLACD", CL_ORDINARY, NULL, clLrplacd}, -{"SAFETY", CL_ORDINARY, NULL, NULL}, -{"SATISFIES", CL_ORDINARY, &clSsatisfies, NULL}, -{"SBIT", CL_ORDINARY, NULL, NULL}, -{"SCALE-FLOAT", CL_ORDINARY, NULL, clLscale_float}, -{"SCHAR", CL_ORDINARY, NULL, clLchar}, -{"SEARCH", CL_ORDINARY, NULL, NULL}, -{"SECOND", CL_ORDINARY, NULL, clLcadr}, -{"SEQUENCE", CL_ORDINARY, &clSsequence, NULL}, -{"SERIOUS-CONDITION", CL_ORDINARY, &clSserious_condition, NULL}, -{"SET", CL_ORDINARY, NULL, clLset}, -{"SET-DIFFERENCE", CL_ORDINARY, NULL, NULL}, -{"SET-DISPATCH-MACRO-CHARACTER", CL_ORDINARY, NULL, clLset_dispatch_macro_character}, -{"SET-EXCLUSIVE-OR", CL_ORDINARY, NULL, NULL}, -{"SET-MACRO-CHARACTER", CL_ORDINARY, NULL, clLset_macro_character}, -{"SET-SYNTAX-FROM-CHAR", CL_ORDINARY, NULL, clLset_syntax_from_char}, -{"SETF", CL_ORDINARY, &clSsetf, NULL}, -{"SETQ", FORM_ORDINARY, NULL, NULL}, -{"SEVENTH", CL_ORDINARY, NULL, clLseventh}, -{"SHADOW", CL_ORDINARY, NULL, clLshadow}, -{"SHADOWING-IMPORT", CL_ORDINARY, NULL, clLshadowing_import}, -{"SHIFTF", CL_ORDINARY, NULL, NULL}, -{"SHORT-FLOAT", CL_ORDINARY, &clSshort_float, NULL}, -{"SHORT-FLOAT-EPSILON", CL_CONSTANT, NULL, NULL}, -{"SHORT-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, NULL}, -{"SHORT-SITE-NAME", CL_ORDINARY, NULL, NULL}, -{"SIGNED-BYTE", CL_ORDINARY, &clSsigned_byte, NULL}, -{"SIGNED-CHAR", CL_ORDINARY, &clSsigned_char, NULL}, -{"SIGNED-SHORT", CL_ORDINARY, &clSsigned_short, NULL}, -{"SIGNUM", CL_ORDINARY, NULL, NULL}, -{"SIMPLE-ARRAY", CL_ORDINARY, &clSsimple_array, NULL}, -{"SIMPLE-BASE-STRING", CL_ORDINARY, NULL, NULL}, -{"SIMPLE-BIT-VECTOR", CL_ORDINARY, &clSsimple_bit_vector, NULL}, -{"SIMPLE-BIT-VECTOR-P", CL_ORDINARY, NULL, clLsimple_bit_vector_p}, -{"SIMPLE-CONDITION", CL_ORDINARY, &clSsimple_condition, NULL}, -{"SIMPLE-ERROR", CL_ORDINARY, &clSsimple_error, NULL}, -{"SIMPLE-STRING", CL_ORDINARY, &clSsimple_string, NULL}, -{"SIMPLE-STRING-P", CL_ORDINARY, NULL, clLsimple_string_p}, -{"SIMPLE-TYPE-ERROR", CL_ORDINARY, &clSsimple_type_error, NULL}, -{"SIMPLE-VECTOR", CL_ORDINARY, &clSsimple_vector, NULL}, -{"SIMPLE-VECTOR-P", CL_ORDINARY, NULL, clLsimple_vector_p}, -{"SIMPLE-WARNING", CL_ORDINARY, &clSsimple_warning, NULL}, -{"SIN", CL_ORDINARY, NULL, clLsin}, -{"SINGLE-FLOAT", CL_ORDINARY, &clSsingle_float, NULL}, -{"SINGLE-FLOAT-EPSILON", CL_CONSTANT, NULL, NULL}, -{"SINGLE-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, NULL}, -{"SINH", CL_ORDINARY, NULL, clLsinh}, -{"SIXTH", CL_ORDINARY, NULL, clLsixth}, -{"SLEEP", CL_ORDINARY, NULL, clLsleep}, -{"SOFTWARE-TYPE", CL_ORDINARY, NULL, NULL}, -{"SOFTWARE-VERSION", CL_ORDINARY, NULL, NULL}, -{"SOME", CL_ORDINARY, NULL, NULL}, -{"SORT", CL_ORDINARY, NULL, NULL}, -{"SPACE", CL_ORDINARY, NULL, NULL}, -{"SPECIAL", CL_ORDINARY, &clSspecial, NULL}, -{"SPECIAL-FORM-P", CL_ORDINARY, NULL, clLspecial_form_p}, -{"SPECIAL-OPERATOR-P", CL_ORDINARY, NULL, NULL}, -{"SPEED", CL_ORDINARY, NULL, NULL}, -{"SQRT", CL_ORDINARY, NULL, clLsqrt}, -{"STABLE-SORT", CL_ORDINARY, NULL, NULL}, -{"STANDARD-CHAR", CL_ORDINARY, &clSstandard_char, NULL}, -{"STANDARD-CHAR-P", CL_ORDINARY, NULL, clLstandard_char_p}, -{"STEP", CL_ORDINARY, NULL, NULL}, -{"STORAGE-CONDITION", CL_ORDINARY, &clSstorage_condition, NULL}, -{"STREAM", CL_ORDINARY, &clSstream, NULL}, -{"STREAM-ELEMENT-TYPE", CL_ORDINARY, NULL, clLstream_element_type}, -{"STREAM-ERROR", CL_ORDINARY, &clSstream_error, NULL}, -{"STREAMP", CL_ORDINARY, NULL, clLstreamp}, -{"STRING", CL_ORDINARY, &clSstring, clLstring}, -{"STRING-CAPITALIZE", CL_ORDINARY, NULL, clLstring_capitalize}, -{"STRING-DOWNCASE", CL_ORDINARY, NULL, clLstring_downcase}, -{"STRING-EQUAL", CL_ORDINARY, NULL, clLstring_equal}, -{"STRING-GREATERP", CL_ORDINARY, NULL, clLstring_greaterp}, -{"STRING-LEFT-TRIM", CL_ORDINARY, NULL, clLstring_left_trim}, -{"STRING-LESSP", CL_ORDINARY, NULL, clLstring_lessp}, -{"STRING-NOT-EQUAL", CL_ORDINARY, NULL, clLstring_not_equal}, -{"STRING-NOT-GREATERP", CL_ORDINARY, NULL, clLstring_not_greaterp}, -{"STRING-NOT-LESSP", CL_ORDINARY, NULL, clLstring_not_lessp}, -{"STRING-RIGHT-TRIM", CL_ORDINARY, NULL, clLstring_right_trim}, -{"STRING-STREAM", CL_ORDINARY, &clSstring_stream, NULL}, -{"STRING-TRIM", CL_ORDINARY, NULL, clLstring_trim}, -{"STRING-UPCASE", CL_ORDINARY, NULL, clLstring_upcase}, -{"STRING/=", CL_ORDINARY, NULL, clLstringNE}, -{"STRING<", CL_ORDINARY, NULL, clLstringL}, -{"STRING<=", CL_ORDINARY, NULL, clLstringLE}, -{"STRING=", CL_ORDINARY, NULL, clLstringE}, -{"STRING>", CL_ORDINARY, NULL, clLstringG}, -{"STRING>=", CL_ORDINARY, NULL, clLstringGE}, -{"STRINGP", CL_ORDINARY, NULL, clLstringp}, -{"STRUCTURE", CL_ORDINARY, &clSstructure, NULL}, -{"STYLE-WARNING", CL_ORDINARY, &clSstyle_warning, NULL}, -{"SUBLIS", CL_ORDINARY, NULL, clLsublis}, -{"SUBSEQ", CL_ORDINARY, NULL, clLsubseq}, -{"SUBSETP", CL_ORDINARY, NULL, NULL}, -{"SUBST", CL_ORDINARY, NULL, clLsubst}, -{"SUBST-IF", CL_ORDINARY, NULL, clLsubst_if}, -{"SUBST-IF-NOT", CL_ORDINARY, NULL, clLsubst_if_not}, -{"SUBSTITUTE", CL_ORDINARY, NULL, NULL}, -{"SUBSTITUTE-IF", CL_ORDINARY, NULL, NULL}, -{"SUBSTITUTE-IF-NOT", CL_ORDINARY, NULL, NULL}, -{"SUBTYPEP", CL_ORDINARY, &clSsubtypep, NULL}, -{"SVREF", CL_ORDINARY, NULL, clLsvref}, -{"SXHASH", CL_ORDINARY, NULL, clLsxhash}, -{"SYMBOL", CL_ORDINARY, &clSsymbol, NULL}, -{"SYMBOL-FUNCTION", CL_ORDINARY, NULL, clLsymbol_function}, -{"SYMBOL-MACROLET", FORM_ORDINARY, NULL, NULL}, -{"SYMBOL-NAME", CL_ORDINARY, NULL, clLsymbol_name}, -{"SYMBOL-PACKAGE", CL_ORDINARY, NULL, clLsymbol_package}, -{"SYMBOL-PLIST", CL_ORDINARY, NULL, clLsymbol_plist}, -{"SYMBOL-VALUE", CL_ORDINARY, NULL, clLsymbol_value}, -{"SYMBOLP", CL_ORDINARY, NULL, clLsymbolp}, -{"SYNONYM-STREAM", CL_ORDINARY, &clSsynonym_stream, NULL}, -{"TAG", CL_ORDINARY, &clStag, NULL}, -{"TAGBODY", FORM_ORDINARY, NULL, NULL}, -{"TAILP", CL_ORDINARY, NULL, clLtailp}, -{"TAN", CL_ORDINARY, NULL, clLtan}, -{"TANH", CL_ORDINARY, NULL, clLtanh}, -{"TENTH", CL_ORDINARY, NULL, clLtenth}, -{"TERPRI", CL_ORDINARY, NULL, clLterpri}, -{"THE", FORM_ORDINARY, NULL, NULL}, -{"THIRD", CL_ORDINARY, NULL, clLcaddr}, -{"THROW", FORM_ORDINARY, NULL, NULL}, -{"TIME", CL_ORDINARY, NULL, NULL}, -{"TRACE", CL_ORDINARY, NULL, NULL}, -{"TRANSLATE-LOGICAL-PATHNAME", CL_ORDINARY, NULL, clLtranslate_logical_pathname}, -{"TRANSLATE-PATHNAME", CL_ORDINARY, NULL, clLtranslate_pathname}, -{"TREE-EQUAL", CL_ORDINARY, NULL, clLtree_equal}, -{"TRUENAME", CL_ORDINARY, NULL, clLtruename}, -{"TRUNCATE", CL_ORDINARY, NULL, clLtruncate}, -{"TWO-WAY-STREAM", CL_ORDINARY, &clStwo_way_stream, NULL}, -{"TYPE", CL_ORDINARY, NULL, NULL}, -{"TYPE-ERROR", CL_ORDINARY, &clStype_error, NULL}, -{"TYPE-OF", CL_ORDINARY, NULL, clLtype_of}, -{"TYPECASE", CL_ORDINARY, NULL, NULL}, -{"TYPEP", CL_ORDINARY, &clStypep, NULL}, -{"UNBOUND-SLOT", CL_ORDINARY, &clSunbound_slot, NULL}, -{"UNBOUND-VARIABLE", CL_ORDINARY, &clSunbound_variable, NULL}, -{"UNDEFINED-FUNCTION", CL_ORDINARY, &clSundefined_function, NULL}, -{"UNEXPORT", CL_ORDINARY, NULL, clLunexport}, -{"UNINTERN", CL_ORDINARY, NULL, clLunintern}, -{"UNION", CL_ORDINARY, NULL, NULL}, -{"UNLESS", FORM_ORDINARY, NULL, NULL}, -{"UNREAD-CHAR", CL_ORDINARY, NULL, clLunread_char}, -{"UNSIGNED-BYTE", CL_ORDINARY, &clSunsigned_byte, NULL}, -{"UNSIGNED-CHAR", CL_ORDINARY, &clSunsigned_char, NULL}, -{"UNSIGNED-SHORT", CL_ORDINARY, &clSunsigned_short, NULL}, -{"UNTRACE", CL_ORDINARY, NULL, NULL}, -{"UNUSE-PACKAGE", CL_ORDINARY, NULL, clLunuse_package}, -{"UNWIND-PROTECT", FORM_ORDINARY, NULL, NULL}, -{"UPPER-CASE-P", CL_ORDINARY, NULL, clLupper_case_p}, -{"USE-PACKAGE", CL_ORDINARY, NULL, clLuse_package}, -{"USER-HOMEDIR-PATHNAME", CL_ORDINARY, NULL, clLuser_homedir_pathname}, -{"VALUES", CL_ORDINARY, &clSvalues, clLvalues}, -{"VALUES-LIST", CL_ORDINARY, NULL, clLvalues_list}, -{"VARIABLE", CL_ORDINARY, NULL, NULL}, -{"VECTOR", CL_ORDINARY, &clSvector, NULL}, -{"VECTOR-POP", CL_ORDINARY, NULL, NULL}, -{"VECTOR-PUSH", CL_ORDINARY, NULL, NULL}, -{"VECTOR-PUSH-EXTEND", CL_ORDINARY, NULL, NULL}, -{"VECTORP", CL_ORDINARY, NULL, clLvectorp}, -{"WARN", CL_ORDINARY, &clSwarn, NULL}, -{"WARNING", CL_ORDINARY, &clSwarning, NULL}, -{"WHEN", FORM_ORDINARY, NULL, NULL}, -{"WITH-INPUT-FROM-STRING", CL_ORDINARY, NULL, NULL}, -{"WITH-OPEN-FILE", CL_ORDINARY, NULL, NULL}, -{"WITH-OPEN-STREAM", CL_ORDINARY, NULL, NULL}, -{"WITH-OUTPUT-TO-STRING", CL_ORDINARY, NULL, NULL}, -{"WITH-STANDARD-IO-SYNTAX", CL_ORDINARY, NULL, NULL}, -{"WRITE", CL_ORDINARY, NULL, clLwrite}, -{"WRITE-BYTE", CL_ORDINARY, NULL, clLwrite_byte}, -{"WRITE-CHAR", CL_ORDINARY, NULL, clLwrite_char}, -{"WRITE-LINE", CL_ORDINARY, NULL, clLwrite_line}, -{"WRITE-STRING", CL_ORDINARY, NULL, clLwrite_string}, -{"WRITE-TO-STRING", CL_ORDINARY, NULL, NULL}, -{"Y-OR-N-P", CL_ORDINARY, NULL, NULL}, -{"YES-OR-NO-P", CL_ORDINARY, NULL, NULL}, -{"ZEROP", CL_ORDINARY, NULL, clLzerop}, +{"&ALLOW-OTHER-KEYS", CL_ORDINARY, NULL, -1}, +{"&AUX", CL_ORDINARY, NULL, -1}, +{"&BODY", CL_ORDINARY, NULL, -1}, +{"&ENVIRONMENT", CL_ORDINARY, NULL, -1}, +{"&KEY", CL_ORDINARY, NULL, -1}, +{"&OPTIONAL", CL_ORDINARY, NULL, -1}, +{"&REST", CL_ORDINARY, NULL, -1}, +{"&WHOLE", CL_ORDINARY, NULL, -1}, +{"+", CL_SPECIAL, cl_P, -1}, +{"++", CL_SPECIAL, NULL, -1}, +{"+++", CL_SPECIAL, NULL, -1}, +{"-", CL_SPECIAL, cl_M, -1}, +{"*", CL_SPECIAL, cl_X, -1}, +{"**", CL_SPECIAL, NULL, -1}, +{"***", CL_SPECIAL, NULL, -1}, +{"/", CL_SPECIAL, cl_N, -1}, +{"//", CL_SPECIAL, NULL, -1}, +{"///", CL_SPECIAL, NULL, -1}, +{"/=", CL_ORDINARY, cl_NE, -1}, +{"*COMPILE-PRINT*", CL_SPECIAL, NULL, -1}, +{"*COMPILE-VERBOSE*", CL_SPECIAL, NULL, -1}, +{"*DEBUG-IO*", CL_SPECIAL, NULL, -1}, +{"*DEFAULT-PATHNAME-DEFAULTS*", CL_SPECIAL, NULL, -1}, +{"*ERROR-OUTPUT*", CL_SPECIAL, NULL, -1}, +{"*FEATURES*", CL_SPECIAL, NULL, -1}, +{"*GENSYM-COUNTER*", CL_SPECIAL, NULL, -1}, +{"*LOAD-PRINT*", CL_SPECIAL, NULL, -1}, +{"*LOAD-VERBOSE*", CL_SPECIAL, NULL, -1}, +{"*MACROEXPAND-HOOK*", CL_SPECIAL, NULL, -1}, +{"*MODULES*", CL_SPECIAL, NULL, -1}, +{"*PACKAGE*", CL_SPECIAL, NULL, -1}, +{"*PRINT-ARRAY*", CL_SPECIAL, NULL, -1}, +{"*PRINT-BASE*", CL_SPECIAL, NULL, -1}, +{"*PRINT-CASE*", CL_SPECIAL, NULL, -1}, +{"*PRINT-CIRCLE*", CL_SPECIAL, NULL, -1}, +{"*PRINT-ESCAPE*", CL_SPECIAL, NULL, -1}, +{"*PRINT-GENSYM*", CL_SPECIAL, NULL, -1}, +{"*PRINT-LENGTH*", CL_SPECIAL, NULL, -1}, +{"*PRINT-LEVEL*", CL_SPECIAL, NULL, -1}, +{"*PRINT-PRETTY*", CL_SPECIAL, NULL, -1}, +{"*PRINT-RADIX*", CL_SPECIAL, NULL, -1}, +{"*QUERY-IO*", CL_SPECIAL, NULL, -1}, +{"*RANDOM-STATE*", CL_SPECIAL, NULL, -1}, +{"*READ-BASE*", CL_SPECIAL, NULL, -1}, +{"*READ-DEFAULT-FLOAT-FORMAT*", CL_SPECIAL, NULL, -1}, +{"*READ-SUPPRESS*", CL_SPECIAL, NULL, -1}, +{"*READTABLE*", CL_SPECIAL, NULL, -1}, +{"*STANDARD-INPUT*", CL_SPECIAL, NULL, -1}, +{"*STANDARD-OUTPUT*", CL_SPECIAL, NULL, -1}, +{"*TERMINAL-IO*", CL_SPECIAL, NULL, -1}, +{"*TRACE-OUTPUT*", CL_SPECIAL, NULL, -1}, +{"1+", CL_ORDINARY, cl_1P, 1}, +{"1-", CL_ORDINARY, cl_1M, 1}, +{"<", CL_ORDINARY, cl_L, -1}, +{"<=", CL_ORDINARY, cl_LE, -1}, +{"=", CL_ORDINARY, cl_E, -1}, +{">", CL_ORDINARY, cl_G, -1}, +{">=", CL_ORDINARY, cl_GE, -1}, +{"ABS", CL_ORDINARY, NULL, -1}, +{"ACONS", CL_ORDINARY, cl_acons, -1}, +{"ACOS", CL_ORDINARY, NULL, -1}, +{"ACOSH", CL_ORDINARY, NULL, -1}, +{"ADJOIN", CL_ORDINARY, cl_adjoin, -1}, +{"ADJUST-ARRAY", CL_ORDINARY, NULL, -1}, +{"ADJUSTABLE-ARRAY-P", CL_ORDINARY, cl_adjustable_array_p, 1}, +{"ALPHA-CHAR-P", CL_ORDINARY, cl_alpha_char_p, 1}, +{"ALPHANUMERICP", CL_ORDINARY, cl_alphanumericp, 1}, +{"AND", CL_ORDINARY, NULL, -1}, +{"APPEND", CL_ORDINARY, cl_append, -1}, +{"APPLY", CL_ORDINARY, cl_apply, -1}, +{"APROPOS", CL_ORDINARY, NULL, -1}, +{"APROPOS-LIST", CL_ORDINARY, NULL, -1}, +{"AREF", CL_ORDINARY, cl_aref, -1}, +{"ARITHMETIC-ERROR", CL_ORDINARY, NULL, -1}, +{"ARRAY", CL_ORDINARY, NULL, -1}, +{"ARRAY-DIMENSION", CL_ORDINARY, cl_array_dimension, 2}, +{"ARRAY-DIMENSION-LIMIT", CL_ORDINARY, NULL, -1}, +{"ARRAY-DIMENSIONS", CL_ORDINARY, NULL, -1}, +{"ARRAY-ELEMENT-TYPE", CL_ORDINARY, cl_array_element_type, 1}, +{"ARRAY-HAS-FILL-POINTER-P", CL_ORDINARY, cl_array_has_fill_pointer_p, 1}, +{"ARRAY-IN-BOUNDS-P", CL_ORDINARY, NULL, -1}, +{"ARRAY-RANK", CL_ORDINARY, cl_array_rank, 1}, +{"ARRAY-RANK-LIMIT", CL_CONSTANT, NULL, -1}, +{"ARRAY-ROW-MAJOR-INDEX", CL_ORDINARY, NULL, -1}, +{"ARRAY-TOTAL-SIZE", CL_ORDINARY, cl_array_total_size, 1}, +{"ARRAY-TOTAL-SIZE-LIMIT", CL_CONSTANT, NULL, -1}, +{"ARRAYP", CL_ORDINARY, cl_arrayp, 1}, +{"ASH", CL_ORDINARY, cl_ash, 2}, +{"ASIN", CL_ORDINARY, NULL, -1}, +{"ASINH", CL_ORDINARY, NULL, -1}, +{"ASSERT", CL_ORDINARY, NULL, -1}, +{"ASSOC", CL_ORDINARY, cl_assoc, -1}, +{"ASSOC-IF", CL_ORDINARY, cl_assoc_if, -1}, +{"ASSOC-IF-NOT", CL_ORDINARY, cl_assoc_if_not, -1}, +{"ATAN", CL_ORDINARY, cl_atan, -1}, +{"ATANH", CL_ORDINARY, NULL, -1}, +{"ATOM", CL_ORDINARY, cl_atom, 1}, +{"BASE-CHAR", CL_ORDINARY, NULL, -1}, +{"BASE-STRING", CL_ORDINARY, NULL, -1}, +{"BIGNUM", CL_ORDINARY, NULL, -1}, +{"BIT", CL_ORDINARY, NULL, -1}, +{"BIT-AND", CL_ORDINARY, NULL, -1}, +{"BIT-ANDC1", CL_ORDINARY, NULL, -1}, +{"BIT-ANDC2", CL_ORDINARY, NULL, -1}, +{"BIT-EQV", CL_ORDINARY, NULL, -1}, +{"BIT-IOR", CL_ORDINARY, NULL, -1}, +{"BIT-NAND", CL_ORDINARY, NULL, -1}, +{"BIT-NOR", CL_ORDINARY, NULL, -1}, +{"BIT-NOT", CL_ORDINARY, NULL, -1}, +{"BIT-ORC1", CL_ORDINARY, NULL, -1}, +{"BIT-ORC2", CL_ORDINARY, NULL, -1}, +{"BIT-VECTOR", CL_ORDINARY, NULL, -1}, +{"BIT-VECTOR-P", CL_ORDINARY, cl_bit_vector_p, 1}, +{"BIT-XOR", CL_ORDINARY, NULL, -1}, +{"BLOCK", FORM_ORDINARY, NULL, -1}, +{"BOOLE", CL_ORDINARY, cl_boole, 3}, +{"BOOLE-1", CL_CONSTANT, NULL, -1}, +{"BOOLE-2", CL_CONSTANT, NULL, -1}, +{"BOOLE-AND", CL_CONSTANT, NULL, -1}, +{"BOOLE-ANDC1", CL_CONSTANT, NULL, -1}, +{"BOOLE-ANDC2", CL_CONSTANT, NULL, -1}, +{"BOOLE-C1", CL_CONSTANT, NULL, -1}, +{"BOOLE-C2", CL_CONSTANT, NULL, -1}, +{"BOOLE-CLR", CL_CONSTANT, NULL, -1}, +{"BOOLE-EQV", CL_CONSTANT, NULL, -1}, +{"BOOLE-IOR", CL_CONSTANT, NULL, -1}, +{"BOOLE-NAND", CL_CONSTANT, NULL, -1}, +{"BOOLE-NOR", CL_CONSTANT, NULL, -1}, +{"BOOLE-ORC1", CL_CONSTANT, NULL, -1}, +{"BOOLE-ORC2", CL_CONSTANT, NULL, -1}, +{"BOOLE-SET", CL_CONSTANT, NULL, -1}, +{"BOOLE-XOR", CL_CONSTANT, NULL, -1}, +{"BOOLEAN", CL_ORDINARY, NULL, -1}, +{"BOTH-CASE-P", CL_ORDINARY, cl_both_case_p, 1}, +{"BOUNDP", CL_ORDINARY, cl_boundp, 1}, +{"BREAK", CL_ORDINARY, NULL, -1}, +{"BROADCAST-STREAM", CL_ORDINARY, NULL, -1}, +{"BUTLAST", CL_ORDINARY, cl_butlast, -1}, +{"BYTE", CL_ORDINARY, NULL, -1}, +{"BYTE-POSITION", CL_ORDINARY, NULL, -1}, +{"BYTE-SIZE", CL_ORDINARY, NULL, -1}, +{"BYTE8", CL_ORDINARY, NULL, -1}, +{"CAAAAR", CL_ORDINARY, cl_caaaar, 1}, +{"CAAADR", CL_ORDINARY, cl_caaadr, 1}, +{"CAAAR", CL_ORDINARY, cl_caaar, 1}, +{"CAADAR", CL_ORDINARY, cl_caadar, 1}, +{"CAADDR", CL_ORDINARY, cl_caaddr, 1}, +{"CAADR", CL_ORDINARY, cl_caadr, 1}, +{"CAAR", CL_ORDINARY, cl_caar, 1}, +{"CADAAR", CL_ORDINARY, cl_cadaar, 1}, +{"CADADR", CL_ORDINARY, cl_cadadr, 1}, +{"CADAR", CL_ORDINARY, cl_cadar, 1}, +{"CADDAR", CL_ORDINARY, cl_caddar, 1}, +{"CADDDR", CL_ORDINARY, cl_cadddr, 1}, +{"CADDR", CL_ORDINARY, cl_caddr, 1}, +{"CADR", CL_ORDINARY, cl_cadr, 1}, +{"CALL-ARGUMENTS-LIMIT", CL_CONSTANT, NULL, -1}, +{"CAR", CL_ORDINARY, cl_car, 1}, +{"CASE", FORM_ORDINARY, NULL, -1}, +{"CATCH", FORM_ORDINARY, NULL, -1}, +{"CCASE", CL_ORDINARY, NULL, -1}, +{"CDAAAR", CL_ORDINARY, cl_cdaaar, 1}, +{"CDAADR", CL_ORDINARY, cl_cdaadr, 1}, +{"CDAAR", CL_ORDINARY, cl_cdaar, 1}, +{"CDADAR", CL_ORDINARY, cl_cdadar, 1}, +{"CDADDR", CL_ORDINARY, cl_cdaddr, 1}, +{"CDADR", CL_ORDINARY, cl_cdadr, 1}, +{"CDAR", CL_ORDINARY, cl_cdar, 1}, +{"CDDAAR", CL_ORDINARY, cl_cddaar, 1}, +{"CDDADR", CL_ORDINARY, cl_cddadr, 1}, +{"CDDAR", CL_ORDINARY, cl_cddar, 1}, +{"CDDDAR", CL_ORDINARY, cl_cdddar, 1}, +{"CDDDDR", CL_ORDINARY, cl_cddddr, 1}, +{"CDDDR", CL_ORDINARY, cl_cdddr, 1}, +{"CDDR", CL_ORDINARY, cl_cddr, 1}, +{"CDR", CL_ORDINARY, cl_cdr, 1}, +{"CEILING", CL_ORDINARY, cl_ceiling, -1}, +{"CELL-ERROR", CL_ORDINARY, NULL, -1}, +{"CERROR", CL_ORDINARY, cl_cerror, -1}, +{"CHAR", CL_ORDINARY, cl_char, 2}, +{"CHAR-CODE", CL_ORDINARY, cl_char_code, 1}, +{"CHAR-CODE-LIMIT", CL_CONSTANT, NULL, -1}, +{"CHAR-DOWNCASE", CL_ORDINARY, cl_char_downcase, 1}, +{"CHAR-EQUAL", CL_ORDINARY, cl_char_equal, -1}, +{"CHAR-GREATERP", CL_ORDINARY, cl_char_greaterp, -1}, +{"CHAR-INT", CL_ORDINARY, cl_char_int, 1}, +{"CHAR-LESSP", CL_ORDINARY, cl_char_lessp, -1}, +{"CHAR-NAME", CL_ORDINARY, cl_char_name, 1}, +{"CHAR-NOT-EQUAL", CL_ORDINARY, cl_char_not_equal, -1}, +{"CHAR-NOT-GREATERP", CL_ORDINARY, cl_char_not_greaterp, -1}, +{"CHAR-NOT-LESSP", CL_ORDINARY, cl_char_not_lessp, -1}, +{"CHAR-UPCASE", CL_ORDINARY, cl_char_upcase, 1}, +{"CHAR/=", CL_ORDINARY, cl_charNE, -1}, +{"CHAR<", CL_ORDINARY, cl_charL, -1}, +{"CHAR<=", CL_ORDINARY, cl_charLE, -1}, +{"CHAR=", CL_ORDINARY, cl_charE, -1}, +{"CHAR>", CL_ORDINARY, cl_charG, -1}, +{"CHAR>=", CL_ORDINARY, cl_charGE, -1}, +{"CHARACTER", CL_ORDINARY, cl_character, 1}, +{"CHARACTERP", CL_ORDINARY, cl_characterp, 1}, +{"CHECK-TYPE", CL_ORDINARY, NULL, -1}, +{"CIS", CL_ORDINARY, NULL, -1}, +{"CLEAR-INPUT", CL_ORDINARY, cl_clear_input, -1}, +{"CLEAR-OUTPUT", CL_ORDINARY, cl_clear_output, -1}, +{"CLOSE", CL_ORDINARY, cl_close, -1}, +{"CLRHASH", CL_ORDINARY, cl_clrhash, 1}, +{"CODE-CHAR", CL_ORDINARY, cl_code_char, 1}, +{"COERCE", CL_ORDINARY, NULL, -1}, +{"COMMON", CL_ORDINARY, NULL, -1}, +{"COMMONP", CL_ORDINARY, cl_commonp, 1}, +{"COMPILATION-SPEED", CL_ORDINARY, NULL, -1}, +{"COMPILE", CL_ORDINARY, NULL, -1}, +{"COMPILE-FILE", CL_ORDINARY, NULL, -1}, +{"COMPILE-FILE-PATHNAME", CL_ORDINARY, NULL, -1}, +{"COMPILED-FUNCTION", CL_ORDINARY, NULL, -1}, +{"COMPILED-FUNCTION-P", CL_ORDINARY, cl_compiled_function_p, 1}, +{"COMPILER-LET", FORM_ORDINARY, NULL, -1}, +{"COMPILER-MACRO-FUNCTION", CL_ORDINARY, NULL, -1}, +{"COMPLEMENT", CL_ORDINARY, NULL, -1}, +{"COMPLEX", CL_ORDINARY, cl_complex, -1}, +{"COMPLEXP", CL_ORDINARY, cl_complexp, 1}, +{"CONCATENATE", CL_ORDINARY, NULL, -1}, +{"CONCATENATED-STREAM", CL_ORDINARY, NULL, -1}, +{"COND", FORM_ORDINARY, NULL, -1}, +{"CONDITION", CL_ORDINARY, NULL, -1}, +{"CONJUGATE", CL_ORDINARY, cl_conjugate, 1}, +{"CONS", CL_ORDINARY, cl_cons, -1}, +{"CONSP", CL_ORDINARY, cl_consp, 1}, +{"CONSTANTLY", CL_ORDINARY, NULL, -1}, +{"CONSTANTP", CL_ORDINARY, cl_constantp, 1}, +{"COPY-ALIST", CL_ORDINARY, cl_copy_alist, -1}, +{"COPY-LIST", CL_ORDINARY, cl_copy_list, -1}, +{"COPY-READTABLE", CL_ORDINARY, cl_copy_readtable, -1}, +{"COPY-SEQ", CL_ORDINARY, cl_copy_seq, 1}, +{"COPY-SYMBOL", CL_ORDINARY, cl_copy_symbol, -1}, +{"COPY-TREE", CL_ORDINARY, cl_copy_tree, -1}, +{"COS", CL_ORDINARY, cl_cos, 1}, +{"COSH", CL_ORDINARY, cl_cosh, 1}, +{"COUNT", CL_ORDINARY, NULL, -1}, +{"COUNT-IF", CL_ORDINARY, NULL, -1}, +{"COUNT-IF-NOT", CL_ORDINARY, NULL, -1}, +{"CTYPECASE", CL_ORDINARY, NULL, -1}, +{"DEBUG", CL_ORDINARY, NULL, -1}, +{"DECF", CL_ORDINARY, NULL, -1}, +{"DECLAIM", CL_ORDINARY, NULL, -1}, +{"DECLARATION", CL_ORDINARY, NULL, -1}, +{"DECLARE", FORM_ORDINARY, NULL, -1}, +{"DECODE-FLOAT", CL_ORDINARY, cl_decode_float, 1}, +{"DECODE-UNIVERSAL-TIME", CL_ORDINARY, NULL, -1}, +{"DEFCONSTANT", CL_ORDINARY, NULL, -1}, +{"DEFINE-COMPILER-MACRO", CL_ORDINARY, NULL, -1}, +{"DEFINE-MODIFY-MACRO", CL_ORDINARY, NULL, -1}, +{"DEFINE-SETF-EXPANDER", CL_ORDINARY, NULL, -1}, +{"DEFINE-SYMBOL-MACRO", CL_ORDINARY, NULL, -1}, +{"DEFMACRO", CL_ORDINARY, NULL, -1}, +{"DEFPACKAGE", CL_ORDINARY, NULL, -1}, +{"DEFPARAMETER", CL_ORDINARY, NULL, -1}, +{"DEFSETF", CL_ORDINARY, NULL, -1}, +{"DEFSTRUCT", CL_ORDINARY, NULL, -1}, +{"DEFTYPE", CL_ORDINARY, NULL, -1}, +{"DEFUN", CL_ORDINARY, NULL, -1}, +{"DEFVAR", CL_ORDINARY, NULL, -1}, +{"DELETE", CL_ORDINARY, NULL, -1}, +{"DELETE-DUPLICATES", CL_ORDINARY, NULL, -1}, +{"DELETE-FILE", CL_ORDINARY, cl_delete_file, 1}, +{"DELETE-IF", CL_ORDINARY, NULL, -1}, +{"DELETE-IF-NOT", CL_ORDINARY, NULL, -1}, +{"DELETE-PACKAGE", CL_ORDINARY, cl_delete_package, 1}, +{"DENOMINATOR", CL_ORDINARY, cl_denominator, 1}, +{"DEPOSIT-FIELD", CL_ORDINARY, NULL, -1}, +{"DESCRIBE", CL_ORDINARY, NULL, -1}, +{"DESTRUCTURING-BIND", CL_ORDINARY, NULL, -1}, +{"DIGIT-CHAR", CL_ORDINARY, cl_digit_char, -1}, +{"DIGIT-CHAR-P", CL_ORDINARY, cl_digit_char_p, -1}, +{"DIRECTORY", CL_ORDINARY, cl_directory, -1}, +{"DIRECTORY-NAMESTRING", CL_ORDINARY, cl_directory_namestring, 1}, +{"DISASSEMBLE", CL_ORDINARY, NULL, -1}, +{"DISPATCH-FUNCTION", CL_ORDINARY, NULL, -1}, +{"DIVISION-BY-ZERO", CL_ORDINARY, NULL, -1}, +{"DO", FORM_ORDINARY, NULL, -1}, +{"DO*", FORM_ORDINARY, NULL, -1}, +{"DO-ALL-SYMBOLS", CL_ORDINARY, NULL, -1}, +{"DO-EXTERNAL-SYMBOLS", CL_ORDINARY, NULL, -1}, +{"DO-SYMBOLS", CL_ORDINARY, NULL, -1}, +{"DOCUMENTATION", CL_ORDINARY, NULL, -1}, +{"DOLIST", FORM_ORDINARY, NULL, -1}, +{"DOTIMES", FORM_ORDINARY, NULL, -1}, +{"DOUBLE-FLOAT", CL_ORDINARY, NULL, -1}, +{"DOUBLE-FLOAT-EPSILON", CL_CONSTANT, NULL, -1}, +{"DOUBLE-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, -1}, +{"DPB", CL_ORDINARY, NULL, -1}, +{"DRIBBLE", CL_ORDINARY, NULL, -1}, +{"ECASE", CL_ORDINARY, NULL, -1}, +{"ECHO-STREAM", CL_ORDINARY, NULL, -1}, +{"ED", CL_ORDINARY, NULL, -1}, +{"EIGHTH", CL_ORDINARY, cl_eighth, 1}, +{"ELT", CL_ORDINARY, cl_elt, 2}, +{"ENCODE-UNIVERSAL-TIME", CL_ORDINARY, NULL, -1}, +{"END-OF-FILE", CL_ORDINARY, NULL, -1}, +{"ENDP", CL_ORDINARY, cl_endp, -1}, +{"ENOUGH-NAMESTRING", CL_ORDINARY, cl_enough_namestring, -1}, +{"EQ", CL_ORDINARY, cl_eq, 2}, +{"EQL", CL_ORDINARY, cl_eql, 2}, +{"EQUAL", CL_ORDINARY, cl_equal, 2}, +{"EQUALP", CL_ORDINARY, cl_equalp, 2}, +{"ERROR", CL_ORDINARY, cl_error, -1}, +{"ETYPECASE", CL_ORDINARY, NULL, -1}, +{"EVAL", CL_ORDINARY, cl_eval, 1}, +{"EVAL-WHEN", FORM_ORDINARY, NULL, -1}, +{"EVENP", CL_ORDINARY, cl_evenp, 1}, +{"EVERY", CL_ORDINARY, NULL, -1}, +{"EXP", CL_ORDINARY, cl_exp, 1}, +{"EXPORT", CL_ORDINARY, cl_export, -1}, +{"EXPT", CL_ORDINARY, cl_expt, 2}, +{"EXTENDED-CHAR", CL_ORDINARY, NULL, -1}, +{"FBOUNDP", CL_ORDINARY, cl_fboundp, 1}, +{"FCEILING", CL_ORDINARY, NULL, -1}, +{"FFLOOR", CL_ORDINARY, NULL, -1}, +{"FIFTH", CL_ORDINARY, cl_fifth, 1}, +{"FILE-AUTHOR", CL_ORDINARY, cl_file_author, 1}, +{"FILE-ERROR", CL_ORDINARY, NULL, -1}, +{"FILE-LENGTH", CL_ORDINARY, cl_file_length, 1}, +{"FILE-NAMESTRING", CL_ORDINARY, cl_file_namestring, 1}, +{"FILE-POSITION", CL_ORDINARY, cl_file_position, -1}, +{"FILE-STREAM", CL_ORDINARY, NULL, -1}, +{"FILE-WRITE-DATE", CL_ORDINARY, cl_file_write_date, 1}, +{"FILL", CL_ORDINARY, NULL, -1}, +{"FILL-POINTER", CL_ORDINARY, cl_fill_pointer, 1}, +{"FIND", CL_ORDINARY, NULL, -1}, +{"FIND-ALL-SYMBOLS", CL_ORDINARY, NULL, -1}, +{"FIND-IF", CL_ORDINARY, NULL, -1}, +{"FIND-IF-NOT", CL_ORDINARY, NULL, -1}, +{"FIND-PACKAGE", CL_ORDINARY, cl_find_package, 1}, +{"FIND-SYMBOL", CL_ORDINARY, cl_find_symbol, -1}, +{"FINISH-OUTPUT", CL_ORDINARY, cl_force_output, -1}, +{"FIRST", CL_ORDINARY, cl_car, 1}, +{"FIXNUM", CL_ORDINARY, NULL, -1}, +{"FLET", FORM_ORDINARY, NULL, -1}, +{"FLOAT", CL_ORDINARY, cl_float, -1}, +{"FLOAT-DIGITS", CL_ORDINARY, cl_float_digits, 1}, +{"FLOAT-PRECISION", CL_ORDINARY, cl_float_precision, 1}, +{"FLOAT-RADIX", CL_ORDINARY, cl_float_radix, 1}, +{"FLOAT-SIGN", CL_ORDINARY, cl_float_sign, -1}, +{"FLOATING-POINT-INEXACT", CL_ORDINARY, NULL, -1}, +{"FLOATING-POINT-INVALID-OPERATION", CL_ORDINARY, NULL, -1}, +{"FLOATING-POINT-OVERFLOW", CL_ORDINARY, NULL, -1}, +{"FLOATING-POINT-UNDERFLOW", CL_ORDINARY, NULL, -1}, +{"FLOATP", CL_ORDINARY, cl_floatp, 1}, +{"FLOOR", CL_ORDINARY, cl_floor, -1}, +{"FMAKUNBOUND", CL_ORDINARY, cl_fmakunbound, 1}, +{"FORCE-OUTPUT", CL_ORDINARY, cl_force_output, -1}, +{"FORMAT", CL_ORDINARY, cl_format, -1}, +{"FOURTH", CL_ORDINARY, cl_cadddr, 1}, +{"FRESH-LINE", CL_ORDINARY, cl_fresh_line, -1}, +{"FROUND", CL_ORDINARY, NULL, -1}, +{"FTRUNCATE", CL_ORDINARY, NULL, -1}, +{"FTYPE", CL_ORDINARY, NULL, -1}, +{"FUNCALL", CL_ORDINARY, cl_funcall, -1}, +{"FUNCTION", FORM_ORDINARY, NULL, -1}, +{"FUNCTIONP", CL_ORDINARY, cl_functionp, 1}, +{"GCD", CL_ORDINARY, cl_gcd, -1}, +{"GENSYM", CL_ORDINARY, cl_gensym, -1}, +{"GENTEMP", CL_ORDINARY, cl_gentemp, -1}, +{"GET", CL_ORDINARY, cl_get, -1}, +{"GET-DECODED-TIME", CL_ORDINARY, NULL, -1}, +{"GET-DISPATCH-MACRO-CHARACTER", CL_ORDINARY, cl_get_dispatch_macro_character, -1}, +{"GET-INTERNAL-REAL-TIME", CL_ORDINARY, cl_get_internal_real_time, 0}, +{"GET-INTERNAL-RUN-TIME", CL_ORDINARY, cl_get_internal_run_time, 0}, +{"GET-MACRO-CHARACTER", CL_ORDINARY, cl_get_macro_character, -1}, +{"GET-OUTPUT-STREAM-STRING", CL_ORDINARY, cl_get_output_stream_string, 1}, +{"GET-PROPERTIES", CL_ORDINARY, cl_get_properties, 2}, +{"GET-SETF-EXPANSION", CL_ORDINARY, NULL, -1}, +{"GET-UNIVERSAL-TIME", CL_ORDINARY, cl_get_universal_time, 0}, +{"GETF", CL_ORDINARY, cl_getf, -1}, +{"GETHASH", CL_ORDINARY, cl_gethash, -1}, +{"GO", FORM_ORDINARY, NULL, -1}, +{"GRAPHIC-CHAR-P", CL_ORDINARY, cl_graphic_char_p, 1}, +{"HASH-TABLE", CL_ORDINARY, NULL, -1}, +{"HASH-TABLE-COUNT", CL_ORDINARY, cl_hash_table_count, 1}, +{"HASH-TABLE-P", CL_ORDINARY, cl_hash_table_p, 1}, +{"HASH-TABLE-REHASH-SIZE", CL_ORDINARY, cl_hash_table_rehash_size, 1}, +{"HASH-TABLE-REHASH-THRESHOLD", CL_ORDINARY, cl_hash_table_rehash_threshold, 1}, +{"HOST-NAMESTRING", CL_ORDINARY, cl_host_namestring, 1}, +{"IDENTITY", CL_ORDINARY, cl_identity, 1}, +{"IGNORE", CL_ORDINARY, NULL, -1}, +{"IMAGPART", CL_ORDINARY, cl_imagpart, 1}, +{"IMPORT", CL_ORDINARY, cl_import, -1}, +{"IN-PACKAGE", CL_ORDINARY, NULL, -1}, +{"INCF", CL_ORDINARY, NULL, -1}, +{"INLINE", CL_ORDINARY, NULL, -1}, +{"INPUT-STREAM-P", CL_ORDINARY, cl_input_stream_p, 1}, +{"INSPECT", CL_ORDINARY, NULL, -1}, +{"INSTANCE", CL_ORDINARY, NULL, -1}, +{"INT-CHAR", CL_ORDINARY, cl_int_char, 1}, +{"INTEGER", CL_ORDINARY, NULL, -1}, +{"INTEGER-DECODE-FLOAT", CL_ORDINARY, cl_integer_decode_float, 1}, +{"INTEGER-LENGTH", CL_ORDINARY, cl_integer_length, 1}, +{"INTEGER8", CL_ORDINARY, NULL, -1}, +{"INTEGERP", CL_ORDINARY, cl_integerp, 1}, +{"INTERN", CL_ORDINARY, cl_intern, -1}, +{"INTERNAL-TIME-UNITS-PER-SECOND", CL_CONSTANT, NULL, -1}, +{"INTERSECTION", CL_ORDINARY, NULL, -1}, +{"ISQRT", CL_ORDINARY, NULL, -1}, +{"KEYWORD", CL_ORDINARY, NULL, -1}, +{"KEYWORDP", CL_ORDINARY, cl_keywordp, 1}, +{"LABELS", FORM_ORDINARY, NULL, -1}, +{"LAMBDA", FORM_ORDINARY, NULL, -1}, +{"LAMBDA-BLOCK", CL_ORDINARY, NULL, -1}, +{"LAMBDA-LIST-KEYWORDS", CL_CONSTANT, NULL, -1}, +{"LAMBDA-PARAMETERS-LIMIT", CL_CONSTANT, NULL, -1}, +{"LAST", CL_ORDINARY, cl_last, -1}, +{"LCM", CL_ORDINARY, cl_lcm, -1}, +{"LDB", CL_ORDINARY, NULL, -1}, +{"LDB-TEST", CL_ORDINARY, NULL, -1}, +{"LDIFF", CL_ORDINARY, cl_ldiff, -1}, +{"LEAST-NEGATIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"LEAST-NEGATIVE-LONG-FLOAT", CL_CONSTANT, NULL, -1}, +{"LEAST-NEGATIVE-SHORT-FLOAT", CL_CONSTANT, NULL, -1}, +{"LEAST-NEGATIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"LEAST-POSITIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"LEAST-POSITIVE-LONG-FLOAT", CL_CONSTANT, NULL, -1}, +{"LEAST-POSITIVE-SHORT-FLOAT", CL_CONSTANT, NULL, -1}, +{"LEAST-POSITIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"LENGTH", CL_ORDINARY, cl_length, 1}, +{"LET", FORM_ORDINARY, NULL, -1}, +{"LET*", FORM_ORDINARY, NULL, -1}, +{"LISP-IMPLEMENTATION-TYPE", CL_ORDINARY, NULL, -1}, +{"LISP-IMPLEMENTATION-VERSION", CL_ORDINARY, NULL, -1}, +{"LIST", CL_ORDINARY, cl_list, -1}, +{"LIST*", CL_ORDINARY, cl_listX, -1}, +{"LIST-ALL-PACKAGES", CL_ORDINARY, cl_list_all_packages, 0}, +{"LIST-LENGTH", CL_ORDINARY, cl_list_length, -1}, +{"LISTEN", CL_ORDINARY, cl_listen, -1}, +{"LISTP", CL_ORDINARY, cl_listp, 1}, +{"LOAD", CL_ORDINARY, cl_load, -1}, +{"LOAD-TIME-VALUE", CL_ORDINARY, NULL, -1}, +{"LOCALLY", FORM_ORDINARY, NULL, -1}, +{"LOG", CL_ORDINARY, cl_log, -1}, +{"LOGAND", CL_ORDINARY, cl_logand, -1}, +{"LOGANDC1", CL_ORDINARY, cl_logandc1, 2}, +{"LOGANDC2", CL_ORDINARY, cl_logandc2, 2}, +{"LOGBITP", CL_ORDINARY, cl_logbitp, 2}, +{"LOGCOUNT", CL_ORDINARY, cl_logcount, 1}, +{"LOGEQV", CL_ORDINARY, cl_logeqv, -1}, +{"LOGICAL-PATHNAME", CL_ORDINARY, NULL, -1}, +{"LOGICAL-PATHNAME-TRANSLATIONS", CL_ORDINARY, NULL, -1}, +{"LOGIOR", CL_ORDINARY, cl_logior, -1}, +{"LOGNAND", CL_ORDINARY, cl_lognand, 2}, +{"LOGNOR", CL_ORDINARY, cl_lognor, 2}, +{"LOGNOT", CL_ORDINARY, cl_lognot, 1}, +{"LOGORC1", CL_ORDINARY, cl_logorc1, 2}, +{"LOGORC2", CL_ORDINARY, cl_logorc2, 2}, +{"LOGTEST", CL_ORDINARY, NULL, -1}, +{"LOGXOR", CL_ORDINARY, cl_logxor, -1}, +{"LONG-FLOAT", CL_ORDINARY, NULL, -1}, +{"LONG-FLOAT-EPSILON", CL_CONSTANT, NULL, -1}, +{"LONG-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, -1}, +{"LONG-SITE-NAME", CL_ORDINARY, NULL, -1}, +{"LOOP", CL_ORDINARY, NULL, -1}, +{"LOOP-FINISH", CL_ORDINARY, NULL, -1}, +{"LOWER-CASE-P", CL_ORDINARY, cl_lower_case_p, 1}, +{"MACHINE-INSTANCE", CL_ORDINARY, NULL, -1}, +{"MACHINE-TYPE", CL_ORDINARY, NULL, -1}, +{"MACHINE-VERSION", CL_ORDINARY, NULL, -1}, +{"MACRO", CL_ORDINARY, NULL, -1}, +{"MACRO-FUNCTION", CL_ORDINARY, cl_macro_function, -1}, +{"MACROEXPAND", CL_ORDINARY, cl_macroexpand, -1}, +{"MACROEXPAND-1", CL_ORDINARY, cl_macroexpand_1, -1}, +{"MACROLET", FORM_ORDINARY, NULL, -1}, +{"MAKE-ARRAY", CL_ORDINARY, NULL, -1}, +{"MAKE-BROADCAST-STREAM", CL_ORDINARY, cl_make_broadcast_stream, -1}, +{"MAKE-CONCATENATED-STREAM", CL_ORDINARY, cl_make_concatenated_stream, -1}, +{"MAKE-DISPATCH-MACRO-CHARACTER", CL_ORDINARY, cl_make_dispatch_macro_character, -1}, +{"MAKE-ECHO-STREAM", CL_ORDINARY, cl_make_echo_stream, 2}, +{"MAKE-HASH-TABLE", CL_ORDINARY, cl_make_hash_table, -1}, +{"MAKE-LIST", CL_ORDINARY, cl_make_list, -1}, +{"MAKE-PACKAGE", CL_ORDINARY, cl_make_package, -1}, +{"MAKE-PATHNAME", CL_ORDINARY, cl_make_pathname, -1}, +{"MAKE-RANDOM-STATE", CL_ORDINARY, cl_make_random_state, -1}, +{"MAKE-SEQUENCE", CL_ORDINARY, NULL, -1}, +{"MAKE-STRING", CL_ORDINARY, cl_make_string, -1}, +{"MAKE-STRING-INPUT-STREAM", CL_ORDINARY, cl_make_string_input_stream, -1}, +{"MAKE-STRING-OUTPUT-STREAM", CL_ORDINARY, cl_make_string_output_stream, 0}, +{"MAKE-SYMBOL", CL_ORDINARY, cl_make_symbol, 1}, +{"MAKE-SYNONYM-STREAM", CL_ORDINARY, cl_make_synonym_stream, 1}, +{"MAKE-TWO-WAY-STREAM", CL_ORDINARY, cl_make_two_way_stream, 2}, +{"MAKUNBOUND", CL_ORDINARY, cl_makunbound, 1}, +{"MAP", CL_ORDINARY, NULL, -1}, +{"MAP-INTO", CL_ORDINARY, NULL, -1}, +{"MAPC", CL_ORDINARY, cl_mapc, -1}, +{"MAPCAN", CL_ORDINARY, cl_mapcan, -1}, +{"MAPCAR", CL_ORDINARY, cl_mapcar, -1}, +{"MAPCON", CL_ORDINARY, cl_mapcon, -1}, +{"MAPHASH", CL_ORDINARY, cl_maphash, 2}, +{"MAPL", CL_ORDINARY, cl_mapl, -1}, +{"MAPLIST", CL_ORDINARY, cl_maplist, -1}, +{"MASK-FIELD", CL_ORDINARY, NULL, -1}, +{"MAX", CL_ORDINARY, cl_max, -1}, +{"MEMBER", CL_ORDINARY, cl_member, -1}, +{"MEMBER-IF", CL_ORDINARY, cl_member_if, -1}, +{"MEMBER-IF-NOT", CL_ORDINARY, cl_member_if_not, -1}, +{"MERGE", CL_ORDINARY, NULL, -1}, +{"MERGE-PATHNAMES", CL_ORDINARY, cl_merge_pathnames, -1}, +{"MIN", CL_ORDINARY, cl_min, -1}, +{"MINUSP", CL_ORDINARY, cl_minusp, 1}, +{"MISMATCH", CL_ORDINARY, NULL, -1}, +{"MOD", CL_ORDINARY, cl_mod, 2}, +{"MOST-NEGATIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"MOST-NEGATIVE-FIXNUM", CL_CONSTANT, NULL, -1}, +{"MOST-NEGATIVE-LONG-FLOAT", CL_CONSTANT, NULL, -1}, +{"MOST-NEGATIVE-SHORT-FLOAT", CL_CONSTANT, NULL, -1}, +{"MOST-NEGATIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"MOST-POSITIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"MOST-POSITIVE-FIXNUM", CL_CONSTANT, NULL, -1}, +{"MOST-POSITIVE-LONG-FLOAT", CL_CONSTANT, NULL, -1}, +{"MOST-POSITIVE-SHORT-FLOAT", CL_CONSTANT, NULL, -1}, +{"MOST-POSITIVE-SINGLE-FLOAT", CL_CONSTANT, NULL, -1}, +{"MULTIPLE-VALUE-BIND", FORM_ORDINARY, NULL, -1}, +{"MULTIPLE-VALUE-CALL", FORM_ORDINARY, NULL, -1}, +{"MULTIPLE-VALUE-LIST", FORM_ORDINARY, NULL, -1}, +{"MULTIPLE-VALUE-PROG1", FORM_ORDINARY, NULL, -1}, +{"MULTIPLE-VALUE-SETQ", FORM_ORDINARY, NULL, -1}, +{"MULTIPLE-VALUES-LIMIT", CL_CONSTANT, NULL, -1}, +{"NAME-CHAR", CL_ORDINARY, cl_name_char, 1}, +{"NAMED-LAMBDA", FORM_ORDINARY, NULL, -1}, +{"NAMESTRING", CL_ORDINARY, cl_namestring, 1}, +{"NBUTLAST", CL_ORDINARY, cl_nbutlast, -1}, +{"NCONC", CL_ORDINARY, cl_nconc, -1}, +{"NINTERSECTION", CL_ORDINARY, NULL, -1}, +{"NINTH", CL_ORDINARY, cl_ninth, 1}, +{"NOT", CL_ORDINARY, cl_null, 1}, +{"NOTANY", CL_ORDINARY, NULL, -1}, +{"NOTEVERY", CL_ORDINARY, NULL, -1}, +{"NOTINLINE", CL_ORDINARY, NULL, -1}, +{"NRECONC", CL_ORDINARY, cl_nreconc, -1}, +{"NREVERSE", CL_ORDINARY, cl_nreverse, 1}, +{"NSET-DIFFERENCE", CL_ORDINARY, NULL, -1}, +{"NSET-EXCLUSIVE-OR", CL_ORDINARY, NULL, -1}, +{"NSTRING-CAPITALIZE", CL_ORDINARY, cl_nstring_capitalize, -1}, +{"NSTRING-DOWNCASE", CL_ORDINARY, cl_nstring_downcase, -1}, +{"NSTRING-UPCASE", CL_ORDINARY, cl_nstring_upcase, -1}, +{"NSUBLIS", CL_ORDINARY, cl_nsublis, -1}, +{"NSUBST", CL_ORDINARY, cl_nsubst, -1}, +{"NSUBST-IF", CL_ORDINARY, cl_nsubst_if, -1}, +{"NSUBST-IF-NOT", CL_ORDINARY, cl_nsubst_if_not, -1}, +{"NSUBSTITUTE", CL_ORDINARY, NULL, -1}, +{"NSUBSTITUTE-IF", CL_ORDINARY, NULL, -1}, +{"NSUBSTITUTE-IF-NOT", CL_ORDINARY, NULL, -1}, +{"NTH", CL_ORDINARY, cl_nth, -1}, +{"NTH-VALUE", FORM_ORDINARY, NULL, -1}, +{"NTHCDR", CL_ORDINARY, cl_nthcdr, -1}, +{"NULL", CL_ORDINARY, cl_null, 1}, +{"NUMBER", CL_ORDINARY, NULL, -1}, +{"NUMBERP", CL_ORDINARY, cl_numberp, 1}, +{"NUMERATOR", CL_ORDINARY, cl_numerator, 1}, +{"NUNION", CL_ORDINARY, NULL, -1}, +{"ODDP", CL_ORDINARY, cl_oddp, 1}, +{"OPEN", CL_ORDINARY, cl_open, -1}, +{"OPEN-STREAM-P", CL_ORDINARY, cl_open_stream_p, 1}, +{"OPTIMIZE", CL_ORDINARY, NULL, -1}, +{"OR", CL_ORDINARY, NULL, -1}, +{"OTHERWISE", CL_ORDINARY, NULL, -1}, +{"OUTPUT-STREAM-P", CL_ORDINARY, cl_output_stream_p, 1}, +{"PACKAGE", CL_ORDINARY, NULL, -1}, +{"PACKAGE-ERROR", CL_ORDINARY, NULL, -1}, +{"PACKAGE-NAME", CL_ORDINARY, cl_package_name, 1}, +{"PACKAGE-NICKNAMES", CL_ORDINARY, cl_package_nicknames, 1}, +{"PACKAGE-SHADOWING-SYMBOLS", CL_ORDINARY, cl_package_shadowing_symbols, 1}, +{"PACKAGE-USE-LIST", CL_ORDINARY, cl_package_use_list, 1}, +{"PACKAGE-USED-BY-LIST", CL_ORDINARY, cl_package_used_by_list, 1}, +{"PACKAGEP", CL_ORDINARY, cl_packagep, 1}, +{"PAIRLIS", CL_ORDINARY, cl_pairlis, -1}, +{"PARSE-ERROR", CL_ORDINARY, NULL, -1}, +{"PARSE-INTEGER", CL_ORDINARY, cl_parse_integer, -1}, +{"PARSE-NAMESTRING", CL_ORDINARY, cl_parse_namestring, -1}, +{"PATHNAME", CL_ORDINARY, cl_pathname, 1}, +{"PATHNAME-DEVICE", CL_ORDINARY, cl_pathname_device, 1}, +{"PATHNAME-DIRECTORY", CL_ORDINARY, cl_pathname_directory, 1}, +{"PATHNAME-HOST", CL_ORDINARY, cl_pathname_host, 1}, +{"PATHNAME-MATCH-P", CL_ORDINARY, cl_pathname_match_p, 2}, +{"PATHNAME-NAME", CL_ORDINARY, cl_pathname_name, 1}, +{"PATHNAME-TYPE", CL_ORDINARY, cl_pathname_type, 1}, +{"PATHNAME-VERSION", CL_ORDINARY, cl_pathname_version, 1}, +{"PATHNAMEP", CL_ORDINARY, cl_pathnamep, 1}, +{"PEEK-CHAR", CL_ORDINARY, cl_peek_char, -1}, +{"PHASE", CL_ORDINARY, NULL, -1}, +{"PI", CL_ORDINARY, NULL, -1}, +{"PLUSP", CL_ORDINARY, cl_plusp, 1}, +{"POP", CL_ORDINARY, NULL, -1}, +{"POSITION", CL_ORDINARY, NULL, -1}, +{"POSITION-IF", CL_ORDINARY, NULL, -1}, +{"POSITION-IF-NOT", CL_ORDINARY, NULL, -1}, +{"PPRINT", CL_ORDINARY, cl_pprint, -1}, +{"PRIN1", CL_ORDINARY, cl_prin1, -1}, +{"PRIN1-TO-STRING", CL_ORDINARY, NULL, -1}, +{"PRINC", CL_ORDINARY, cl_princ, -1}, +{"PRINC-TO-STRING", CL_ORDINARY, NULL, -1}, +{"PRINT", CL_ORDINARY, cl_print, -1}, +{"PRINT-NOT-READABLE", CL_ORDINARY, NULL, -1}, +{"PROBE-FILE", CL_ORDINARY, cl_probe_file, 1}, +{"PROCLAIM", CL_ORDINARY, NULL, -1}, +{"PROG", FORM_ORDINARY, NULL, -1}, +{"PROG*", FORM_ORDINARY, NULL, -1}, +{"PROG1", FORM_ORDINARY, NULL, -1}, +{"PROG2", FORM_ORDINARY, NULL, -1}, +{"PROGN", FORM_ORDINARY, NULL, -1}, +{"PROGRAM-ERROR", CL_ORDINARY, NULL, -1}, +{"PROGV", FORM_ORDINARY, NULL, -1}, +{"PROVIDE", CL_ORDINARY, NULL, -1}, +{"PSETF", CL_ORDINARY, NULL, -1}, +{"PSETQ", FORM_ORDINARY, NULL, -1}, +{"PUSH", CL_ORDINARY, NULL, -1}, +{"PUSHNEW", CL_ORDINARY, NULL, -1}, +{"QUIT", CL_ORDINARY, cl_quit, -1}, +{"QUOTE", FORM_ORDINARY, NULL, -1}, +{"RANDOM", CL_ORDINARY, cl_random, -1}, +{"RANDOM-STATE", CL_ORDINARY, NULL, -1}, +{"RANDOM-STATE-P", CL_ORDINARY, cl_random_state_p, 1}, +{"RASSOC", CL_ORDINARY, cl_rassoc, -1}, +{"RASSOC-IF", CL_ORDINARY, cl_rassoc_if, -1}, +{"RASSOC-IF-NOT", CL_ORDINARY, cl_rassoc_if_not, -1}, +{"RATIO", CL_ORDINARY, NULL, -1}, +{"RATIONAL", CL_ORDINARY, NULL, -1}, +{"RATIONALIZE", CL_ORDINARY, NULL, -1}, +{"RATIONALP", CL_ORDINARY, cl_rationalp, 1}, +{"READ", CL_ORDINARY, cl_read, -1}, +{"READ-BYTE", CL_ORDINARY, cl_read_byte, -1}, +{"READ-CHAR", CL_ORDINARY, cl_read_char, -1}, +{"READ-CHAR-NO-HANG", CL_ORDINARY, cl_read_char_no_hang, -1}, +{"READ-DELIMITED-LIST", CL_ORDINARY, cl_read_delimited_list, -1}, +{"READ-FROM-STRING", CL_ORDINARY, NULL, -1}, +{"READ-LINE", CL_ORDINARY, cl_read_line, -1}, +{"READ-PRESERVING-WHITESPACE", CL_ORDINARY, cl_read_preserving_whitespace, -1}, +{"READER-ERROR", CL_ORDINARY, NULL, -1}, +{"READTABLE", CL_ORDINARY, NULL, -1}, +{"READTABLEP", CL_ORDINARY, cl_readtablep, 1}, +{"REAL", CL_ORDINARY, NULL, -1}, +{"REALP", CL_ORDINARY, cl_realp, 1}, +{"REALPART", CL_ORDINARY, cl_realpart, 1}, +{"REDUCE", CL_ORDINARY, NULL, -1}, +{"REM", CL_ORDINARY, cl_rem, 2}, +{"REMF", CL_ORDINARY, NULL, -1}, +{"REMHASH", CL_ORDINARY, cl_remhash, 2}, +{"REMOVE", CL_ORDINARY, NULL, -1}, +{"REMOVE-DUPLICATES", CL_ORDINARY, NULL, -1}, +{"REMOVE-IF", CL_ORDINARY, NULL, -1}, +{"REMOVE-IF-NOT", CL_ORDINARY, NULL, -1}, +{"REMPROP", CL_ORDINARY, cl_remprop, 2}, +{"RENAME-FILE", CL_ORDINARY, cl_rename_file, 2}, +{"RENAME-PACKAGE", CL_ORDINARY, cl_rename_package, -1}, +{"REPLACE", CL_ORDINARY, NULL, -1}, +{"REQUIRE", CL_ORDINARY, NULL, -1}, +{"REST", CL_ORDINARY, cl_cdr, 1}, +{"RETURN", FORM_ORDINARY, NULL, -1}, +{"RETURN-FROM", FORM_ORDINARY, NULL, -1}, +{"REVAPPEND", CL_ORDINARY, cl_revappend, -1}, +{"REVERSE", CL_ORDINARY, cl_reverse, 1}, +{"ROOM", CL_ORDINARY, NULL, -1}, +{"ROTATEF", CL_ORDINARY, NULL, -1}, +{"ROUND", CL_ORDINARY, cl_round, -1}, +{"ROW-MAJOR-AREF", CL_ORDINARY, cl_row_major_aref, 2}, +{"RPLACA", CL_ORDINARY, cl_rplaca, -1}, +{"RPLACD", CL_ORDINARY, cl_rplacd, -1}, +{"SAFETY", CL_ORDINARY, NULL, -1}, +{"SATISFIES", CL_ORDINARY, NULL, -1}, +{"SBIT", CL_ORDINARY, NULL, -1}, +{"SCALE-FLOAT", CL_ORDINARY, cl_scale_float, 2}, +{"SCHAR", CL_ORDINARY, cl_char, 2}, +{"SEARCH", CL_ORDINARY, NULL, -1}, +{"SECOND", CL_ORDINARY, cl_cadr, 1}, +{"SEQUENCE", CL_ORDINARY, NULL, -1}, +{"SERIOUS-CONDITION", CL_ORDINARY, NULL, -1}, +{"SET", CL_ORDINARY, cl_set, 2}, +{"SET-DIFFERENCE", CL_ORDINARY, NULL, -1}, +{"SET-DISPATCH-MACRO-CHARACTER", CL_ORDINARY, cl_set_dispatch_macro_character, -1}, +{"SET-EXCLUSIVE-OR", CL_ORDINARY, NULL, -1}, +{"SET-MACRO-CHARACTER", CL_ORDINARY, cl_set_macro_character, -1}, +{"SET-SYNTAX-FROM-CHAR", CL_ORDINARY, cl_set_syntax_from_char, -1}, +{"SETF", CL_ORDINARY, NULL, -1}, +{"SETQ", FORM_ORDINARY, NULL, -1}, +{"SEVENTH", CL_ORDINARY, cl_seventh, 1}, +{"SHADOW", CL_ORDINARY, cl_shadow, -1}, +{"SHADOWING-IMPORT", CL_ORDINARY, cl_shadowing_import, -1}, +{"SHIFTF", CL_ORDINARY, NULL, -1}, +{"SHORT-FLOAT", CL_ORDINARY, NULL, -1}, +{"SHORT-FLOAT-EPSILON", CL_CONSTANT, NULL, -1}, +{"SHORT-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, -1}, +{"SHORT-SITE-NAME", CL_ORDINARY, NULL, -1}, +{"SIGNED-BYTE", CL_ORDINARY, NULL, -1}, +{"SIGNED-CHAR", CL_ORDINARY, NULL, -1}, +{"SIGNED-SHORT", CL_ORDINARY, NULL, -1}, +{"SIGNUM", CL_ORDINARY, NULL, -1}, +{"SIMPLE-ARRAY", CL_ORDINARY, NULL, -1}, +{"SIMPLE-BASE-STRING", CL_ORDINARY, NULL, -1}, +{"SIMPLE-BIT-VECTOR", CL_ORDINARY, NULL, -1}, +{"SIMPLE-BIT-VECTOR-P", CL_ORDINARY, cl_simple_bit_vector_p, 1}, +{"SIMPLE-CONDITION", CL_ORDINARY, NULL, -1}, +{"SIMPLE-ERROR", CL_ORDINARY, NULL, -1}, +{"SIMPLE-STRING", CL_ORDINARY, NULL, -1}, +{"SIMPLE-STRING-P", CL_ORDINARY, cl_simple_string_p, 1}, +{"SIMPLE-TYPE-ERROR", CL_ORDINARY, NULL, -1}, +{"SIMPLE-VECTOR", CL_ORDINARY, NULL, -1}, +{"SIMPLE-VECTOR-P", CL_ORDINARY, cl_simple_vector_p, 1}, +{"SIMPLE-WARNING", CL_ORDINARY, NULL, -1}, +{"SIN", CL_ORDINARY, cl_sin, 1}, +{"SINGLE-FLOAT", CL_ORDINARY, NULL, -1}, +{"SINGLE-FLOAT-EPSILON", CL_CONSTANT, NULL, -1}, +{"SINGLE-FLOAT-NEGATIVE-EPSILON", CL_CONSTANT, NULL, -1}, +{"SINH", CL_ORDINARY, cl_sinh, 1}, +{"SIXTH", CL_ORDINARY, cl_sixth, 1}, +{"SLEEP", CL_ORDINARY, cl_sleep, 1}, +{"SOFTWARE-TYPE", CL_ORDINARY, NULL, -1}, +{"SOFTWARE-VERSION", CL_ORDINARY, NULL, -1}, +{"SOME", CL_ORDINARY, NULL, -1}, +{"SORT", CL_ORDINARY, NULL, -1}, +{"SPACE", CL_ORDINARY, NULL, -1}, +{"SPECIAL", CL_ORDINARY, NULL, -1}, +{"SPECIAL-FORM-P", CL_ORDINARY, cl_special_operator_p, 1}, +{"SPECIAL-OPERATOR-P", CL_ORDINARY, cl_special_operator_p, 1}, +{"SPEED", CL_ORDINARY, NULL, -1}, +{"SQRT", CL_ORDINARY, cl_sqrt, 1}, +{"STABLE-SORT", CL_ORDINARY, NULL, -1}, +{"STANDARD-CHAR", CL_ORDINARY, NULL, -1}, +{"STANDARD-CHAR-P", CL_ORDINARY, cl_standard_char_p, 1}, +{"STEP", CL_ORDINARY, NULL, -1}, +{"STORAGE-CONDITION", CL_ORDINARY, NULL, -1}, +{"STREAM", CL_ORDINARY, NULL, -1}, +{"STREAM-ELEMENT-TYPE", CL_ORDINARY, cl_stream_element_type, 1}, +{"STREAM-ERROR", CL_ORDINARY, NULL, -1}, +{"STREAMP", CL_ORDINARY, cl_streamp, 1}, +{"STRING", CL_ORDINARY, cl_string, 1}, +{"STRING-CAPITALIZE", CL_ORDINARY, cl_string_capitalize, -1}, +{"STRING-DOWNCASE", CL_ORDINARY, cl_string_downcase, -1}, +{"STRING-EQUAL", CL_ORDINARY, cl_string_equal, -1}, +{"STRING-GREATERP", CL_ORDINARY, cl_string_greaterp, -1}, +{"STRING-LEFT-TRIM", CL_ORDINARY, cl_string_left_trim, 2}, +{"STRING-LESSP", CL_ORDINARY, cl_string_lessp, -1}, +{"STRING-NOT-EQUAL", CL_ORDINARY, cl_string_not_equal, -1}, +{"STRING-NOT-GREATERP", CL_ORDINARY, cl_string_not_greaterp, -1}, +{"STRING-NOT-LESSP", CL_ORDINARY, cl_string_not_lessp, -1}, +{"STRING-RIGHT-TRIM", CL_ORDINARY, cl_string_right_trim, 2}, +{"STRING-STREAM", CL_ORDINARY, NULL, -1}, +{"STRING-TRIM", CL_ORDINARY, cl_string_trim, 2}, +{"STRING-UPCASE", CL_ORDINARY, cl_string_upcase, -1}, +{"STRING/=", CL_ORDINARY, cl_stringNE, -1}, +{"STRING<", CL_ORDINARY, cl_stringL, -1}, +{"STRING<=", CL_ORDINARY, cl_stringLE, -1}, +{"STRING=", CL_ORDINARY, cl_stringE, -1}, +{"STRING>", CL_ORDINARY, cl_stringG, -1}, +{"STRING>=", CL_ORDINARY, cl_stringGE, -1}, +{"STRINGP", CL_ORDINARY, cl_stringp, 1}, +{"STRUCTURE", CL_ORDINARY, NULL, -1}, +{"STYLE-WARNING", CL_ORDINARY, NULL, -1}, +{"SUBLIS", CL_ORDINARY, cl_sublis, -1}, +{"SUBSEQ", CL_ORDINARY, cl_subseq, -1}, +{"SUBSETP", CL_ORDINARY, NULL, -1}, +{"SUBST", CL_ORDINARY, cl_subst, -1}, +{"SUBST-IF", CL_ORDINARY, cl_subst_if, -1}, +{"SUBST-IF-NOT", CL_ORDINARY, cl_subst_if_not, -1}, +{"SUBSTITUTE", CL_ORDINARY, NULL, -1}, +{"SUBSTITUTE-IF", CL_ORDINARY, NULL, -1}, +{"SUBSTITUTE-IF-NOT", CL_ORDINARY, NULL, -1}, +{"SUBTYPEP", CL_ORDINARY, NULL, -1}, +{"SVREF", CL_ORDINARY, cl_svref, 2}, +{"SXHASH", CL_ORDINARY, cl_sxhash, 1}, +{"SYMBOL", CL_ORDINARY, NULL, -1}, +{"SYMBOL-FUNCTION", CL_ORDINARY, cl_symbol_function, 1}, +{"SYMBOL-MACROLET", FORM_ORDINARY, NULL, -1}, +{"SYMBOL-NAME", CL_ORDINARY, cl_symbol_name, 1}, +{"SYMBOL-PACKAGE", CL_ORDINARY, cl_symbol_package, 1}, +{"SYMBOL-PLIST", CL_ORDINARY, cl_symbol_plist, 1}, +{"SYMBOL-VALUE", CL_ORDINARY, cl_symbol_value, 1}, +{"SYMBOLP", CL_ORDINARY, cl_symbolp, 1}, +{"SYNONYM-STREAM", CL_ORDINARY, NULL, -1}, +{"TAG", CL_ORDINARY, NULL, -1}, +{"TAGBODY", FORM_ORDINARY, NULL, -1}, +{"TAILP", CL_ORDINARY, cl_tailp, -1}, +{"TAN", CL_ORDINARY, cl_tan, 1}, +{"TANH", CL_ORDINARY, cl_tanh, 1}, +{"TENTH", CL_ORDINARY, cl_tenth, 1}, +{"TERPRI", CL_ORDINARY, cl_terpri, -1}, +{"THE", FORM_ORDINARY, NULL, -1}, +{"THIRD", CL_ORDINARY, cl_caddr, 1}, +{"THROW", FORM_ORDINARY, NULL, -1}, +{"TIME", CL_ORDINARY, NULL, -1}, +{"TRACE", CL_ORDINARY, NULL, -1}, +{"TRANSLATE-LOGICAL-PATHNAME", CL_ORDINARY, cl_translate_logical_pathname, 1}, +{"TRANSLATE-PATHNAME", CL_ORDINARY, cl_translate_pathname, 3}, +{"TREE-EQUAL", CL_ORDINARY, cl_tree_equal, -1}, +{"TRUENAME", CL_ORDINARY, cl_truename, 1}, +{"TRUNCATE", CL_ORDINARY, cl_truncate, -1}, +{"TWO-WAY-STREAM", CL_ORDINARY, NULL, -1}, +{"TYPE", CL_ORDINARY, NULL, -1}, +{"TYPE-ERROR", CL_ORDINARY, NULL, -1}, +{"TYPE-OF", CL_ORDINARY, cl_type_of, 1}, +{"TYPECASE", CL_ORDINARY, NULL, -1}, +{"TYPEP", CL_ORDINARY, NULL, -1}, +{"UNBOUND-SLOT", CL_ORDINARY, NULL, -1}, +{"UNBOUND-VARIABLE", CL_ORDINARY, NULL, -1}, +{"UNDEFINED-FUNCTION", CL_ORDINARY, NULL, -1}, +{"UNEXPORT", CL_ORDINARY, cl_unexport, -1}, +{"UNINTERN", CL_ORDINARY, cl_unintern, -1}, +{"UNION", CL_ORDINARY, NULL, -1}, +{"UNLESS", FORM_ORDINARY, NULL, -1}, +{"UNREAD-CHAR", CL_ORDINARY, cl_unread_char, -1}, +{"UNSIGNED-BYTE", CL_ORDINARY, NULL, -1}, +{"UNSIGNED-CHAR", CL_ORDINARY, NULL, -1}, +{"UNSIGNED-SHORT", CL_ORDINARY, NULL, -1}, +{"UNTRACE", CL_ORDINARY, NULL, -1}, +{"UNUSE-PACKAGE", CL_ORDINARY, cl_unuse_package, -1}, +{"UNWIND-PROTECT", FORM_ORDINARY, NULL, -1}, +{"UPPER-CASE-P", CL_ORDINARY, cl_upper_case_p, 1}, +{"USE-PACKAGE", CL_ORDINARY, cl_use_package, -1}, +{"USER-HOMEDIR-PATHNAME", CL_ORDINARY, cl_user_homedir_pathname, -1}, +{"VALUES", CL_ORDINARY, cl_values, -1}, +{"VALUES-LIST", CL_ORDINARY, cl_values_list, 1}, +{"VARIABLE", CL_ORDINARY, NULL, -1}, +{"VECTOR", CL_ORDINARY, NULL, -1}, +{"VECTOR-POP", CL_ORDINARY, NULL, -1}, +{"VECTOR-PUSH", CL_ORDINARY, NULL, -1}, +{"VECTOR-PUSH-EXTEND", CL_ORDINARY, NULL, -1}, +{"VECTORP", CL_ORDINARY, cl_vectorp, 1}, +{"WARN", CL_ORDINARY, NULL, -1}, +{"WARNING", CL_ORDINARY, NULL, -1}, +{"WHEN", FORM_ORDINARY, NULL, -1}, +{"WITH-INPUT-FROM-STRING", CL_ORDINARY, NULL, -1}, +{"WITH-OPEN-FILE", CL_ORDINARY, NULL, -1}, +{"WITH-OPEN-STREAM", CL_ORDINARY, NULL, -1}, +{"WITH-OUTPUT-TO-STRING", CL_ORDINARY, NULL, -1}, +{"WITH-STANDARD-IO-SYNTAX", CL_ORDINARY, NULL, -1}, +{"WRITE", CL_ORDINARY, cl_write, -1}, +{"WRITE-BYTE", CL_ORDINARY, cl_write_byte, 2}, +{"WRITE-CHAR", CL_ORDINARY, cl_write_char, -1}, +{"WRITE-LINE", CL_ORDINARY, cl_write_line, -1}, +{"WRITE-STRING", CL_ORDINARY, cl_write_string, -1}, +{"WRITE-TO-STRING", CL_ORDINARY, NULL, -1}, +{"Y-OR-N-P", CL_ORDINARY, NULL, -1}, +{"YES-OR-NO-P", CL_ORDINARY, NULL, -1}, +{"ZEROP", CL_ORDINARY, cl_zerop, 1}, #ifdef CLOS -{"ADD-METHOD", CL_ORDINARY, NULL, NULL}, -{"BUILT-IN-CLASS", CL_ORDINARY, &clSbuilt_in_class, NULL}, -{"CALL-NEXT-METHOD", CL_ORDINARY, NULL, NULL}, -{"CHANGE-CLASS", CL_ORDINARY, NULL, NULL}, -{"CLASS", CL_ORDINARY, &clSclass, NULL}, -{"CLASS-CHANGED", CL_ORDINARY, NULL, NULL}, -{"CLASS-NAME", CL_ORDINARY, NULL, NULL}, -{"CLASS-OF", CL_ORDINARY, NULL, NULL}, -{"DEFCLASS", CL_ORDINARY, NULL, NULL}, -{"DEFGENERIC", CL_ORDINARY, NULL, NULL}, -{"DEFINE-METHOD-COMBINATION", CL_ORDINARY, NULL, NULL}, -{"DEFMETHOD", CL_ORDINARY, NULL, NULL}, -{"DESCRIBE-OBJECT", CL_ORDINARY, NULL, NULL}, -{"ENSURE-GENERIC-FUNCTION", CL_ORDINARY, NULL, NULL}, -{"FIND-CLASS", CL_ORDINARY, NULL, clLfind_class}, -{"FIND-METHOD", CL_ORDINARY, NULL, NULL}, -{"GENERIC-FLET", CL_ORDINARY, NULL, NULL}, -{"GENERIC-FUNCTION", CL_ORDINARY, NULL, NULL}, -{"GENERIC-LABELS", CL_ORDINARY, NULL, NULL}, -{"GET-METHOD", CL_ORDINARY, NULL, NULL}, -{"IF", FORM_ORDINARY, NULL, NULL}, -{"INITIALIZE-INSTANCE", CL_ORDINARY, NULL, NULL}, -{"INVALID-METHOD-ERROR", CL_ORDINARY, NULL, NULL}, -{"MAKE-INSTANCE", CL_ORDINARY, NULL, NULL}, -{"MAKE-INSTANCES-OBSOLETE", CL_ORDINARY, NULL, NULL}, -{"MAKE-METHOD-CALL", CL_ORDINARY, NULL, NULL}, -{"METHOD", CL_ORDINARY, NULL, NULL}, -{"METHOD-COMBINATION-ERROR", CL_ORDINARY, NULL, NULL}, -{"METHOD-QUALIFIERS", CL_ORDINARY, NULL, NULL}, -{"NEXT-METHOD-P", CL_ORDINARY, NULL, NULL}, -{"NO-APPLICABLE-METHOD", CL_ORDINARY, NULL, NULL}, -{"PRINT-OBJECT", CL_ORDINARY, &clSprint_object, NULL}, -{"PRINT-UNREADABLE-OBJECT", CL_ORDINARY, NULL, NULL}, -{"REINITIALIZE-INSTANCE", CL_ORDINARY, NULL, NULL}, -{"REMOVE-METHOD", CL_ORDINARY, NULL, NULL}, -{"SHARED-INITIALIZE", CL_ORDINARY, NULL, NULL}, -{"SLOT-BOUNDP", CL_ORDINARY, NULL, NULL}, -{"SLOT-EXISTS-P", CL_ORDINARY, NULL, NULL}, -{"SLOT-MAKUNBOUND", CL_ORDINARY, NULL, NULL}, -{"SLOT-MISSING", CL_ORDINARY, NULL, NULL}, -{"SLOT-UNBOUND", CL_ORDINARY, NULL, NULL}, -{"SLOT-VALUE", CL_ORDINARY, NULL, NULL}, -{"STANDARD-CLASS", CL_ORDINARY, NULL, NULL}, -{"STANDARD-GENERIC-FUNCTION", CL_ORDINARY, NULL, NULL}, -{"STANDARD-METHOD", CL_ORDINARY, NULL, NULL}, -{"STANDARD-OBJECT", CL_ORDINARY, NULL, NULL}, -{"STRUCTURE-CLASS", CL_ORDINARY, NULL, NULL}, -{"STRUCTURE-OBJECT", CL_ORDINARY, &clSstructure_object, NULL}, -{"SUBCLASSP", CL_ORDINARY, NULL, NULL}, -{"UPDATE-INSTANCE-FOR-REDEFINED-CLASS", CL_ORDINARY, NULL, NULL}, -{"UPDATE-INSTANCE-STRUCTURE", CL_ORDINARY, NULL, NULL}, -{"WITH-ACCESSORS", CL_ORDINARY, NULL, NULL}, -{"WITH-ADDED-METHODS", CL_ORDINARY, NULL, NULL}, -{"WITH-SLOTS", CL_ORDINARY, NULL, NULL}, +{"ADD-METHOD", CL_ORDINARY, NULL, -1}, +{"BUILT-IN-CLASS", CL_ORDINARY, NULL, -1}, +{"CALL-NEXT-METHOD", CL_ORDINARY, NULL, -1}, +{"CHANGE-CLASS", CL_ORDINARY, NULL, -1}, +{"CLASS", CL_ORDINARY, NULL, -1}, +{"CLASS-CHANGED", CL_ORDINARY, NULL, -1}, +{"CLASS-NAME", CL_ORDINARY, NULL, -1}, +{"CLASS-OF", CL_ORDINARY, NULL, -1}, +{"DEFCLASS", CL_ORDINARY, NULL, -1}, +{"DEFGENERIC", CL_ORDINARY, NULL, -1}, +{"DEFINE-METHOD-COMBINATION", CL_ORDINARY, NULL, -1}, +{"DEFMETHOD", CL_ORDINARY, NULL, -1}, +{"DESCRIBE-OBJECT", CL_ORDINARY, NULL, -1}, +{"ENSURE-GENERIC-FUNCTION", CL_ORDINARY, NULL, -1}, +{"FIND-CLASS", CL_ORDINARY, cl_find_class, -1}, +{"FIND-METHOD", CL_ORDINARY, NULL, -1}, +{"GENERIC-FLET", CL_ORDINARY, NULL, -1}, +{"GENERIC-FUNCTION", CL_ORDINARY, NULL, -1}, +{"GENERIC-LABELS", CL_ORDINARY, NULL, -1}, +{"GET-METHOD", CL_ORDINARY, NULL, -1}, +{"IF", FORM_ORDINARY, NULL, -1}, +{"INITIALIZE-INSTANCE", CL_ORDINARY, NULL, -1}, +{"INVALID-METHOD-ERROR", CL_ORDINARY, NULL, -1}, +{"MAKE-INSTANCE", CL_ORDINARY, NULL, -1}, +{"MAKE-INSTANCES-OBSOLETE", CL_ORDINARY, NULL, -1}, +{"MAKE-METHOD-CALL", CL_ORDINARY, NULL, -1}, +{"METHOD", CL_ORDINARY, NULL, -1}, +{"METHOD-COMBINATION-ERROR", CL_ORDINARY, NULL, -1}, +{"METHOD-QUALIFIERS", CL_ORDINARY, NULL, -1}, +{"NEXT-METHOD-P", CL_ORDINARY, NULL, -1}, +{"NO-APPLICABLE-METHOD", CL_ORDINARY, NULL, -1}, +{"PRINT-OBJECT", CL_ORDINARY, NULL, -1}, +{"PRINT-UNREADABLE-OBJECT", CL_ORDINARY, NULL, -1}, +{"REINITIALIZE-INSTANCE", CL_ORDINARY, NULL, -1}, +{"REMOVE-METHOD", CL_ORDINARY, NULL, -1}, +{"SHARED-INITIALIZE", CL_ORDINARY, NULL, -1}, +{"SLOT-BOUNDP", CL_ORDINARY, NULL, -1}, +{"SLOT-EXISTS-P", CL_ORDINARY, NULL, -1}, +{"SLOT-MAKUNBOUND", CL_ORDINARY, NULL, -1}, +{"SLOT-MISSING", CL_ORDINARY, NULL, -1}, +{"SLOT-UNBOUND", CL_ORDINARY, NULL, -1}, +{"SLOT-VALUE", CL_ORDINARY, NULL, -1}, +{"STANDARD-CLASS", CL_ORDINARY, NULL, -1}, +{"STANDARD-GENERIC-FUNCTION", CL_ORDINARY, NULL, -1}, +{"STANDARD-METHOD", CL_ORDINARY, NULL, -1}, +{"STANDARD-OBJECT", CL_ORDINARY, NULL, -1}, +{"STRUCTURE-CLASS", CL_ORDINARY, NULL, -1}, +{"STRUCTURE-OBJECT", CL_ORDINARY, NULL, -1}, +{"SUBCLASSP", CL_ORDINARY, NULL, -1}, +{"UPDATE-INSTANCE-FOR-REDEFINED-CLASS", CL_ORDINARY, NULL, -1}, +{"UPDATE-INSTANCE-STRUCTURE", CL_ORDINARY, NULL, -1}, +{"WITH-ACCESSORS", CL_ORDINARY, NULL, -1}, +{"WITH-ADDED-METHODS", CL_ORDINARY, NULL, -1}, +{"WITH-SLOTS", CL_ORDINARY, NULL, -1}, #endif /* SYSTEM PACKAGE */ -{"SI::#!", SI_ORDINARY, &siSsharp_exclamation, NULL}, -{"SI::*CLASS-NAME-HASH-TABLE*", SI_SPECIAL, &siVclass_name_hash_table, NULL}, -{"SI::*GC-MESSAGE*", SI_SPECIAL, &siVgc_message, NULL}, -{"SI::*GC-VERBOSE*", SI_SPECIAL, &siVgc_verbose, NULL}, -{"SI::*IGNORE-ERRORS*", SI_SPECIAL, NULL, NULL}, -{"SI::*IGNORE-EOF-ON-TERMINAL-IO*", SI_SPECIAL, &siVignore_eof_on_terminal_io, NULL}, -{"SI::*INDENT-FORMATTED-OUTPUT*", SI_SPECIAL, &siVindent_formatted_output, NULL}, -{"SI::*INHIBIT-MACRO-SPECIAL*", SI_SPECIAL, &siVinhibit_macro_special, NULL}, -{"SI::*INIT-FUNCTION-PREFIX*", SI_SPECIAL, &siVinit_function_prefix, NULL}, -{"SI::*KEEP-DEFINITIONS*", SI_SPECIAL, &siVkeep_definitions, NULL}, -{"SI::*LOAD-HOOKS*", SI_SPECIAL, &siVload_hooks, NULL}, -{"SI::*MAKE-CONSTANT", SI_ORDINARY, NULL, siLXmake_constant}, -{"SI::*MAKE-SPECIAL", SI_ORDINARY, NULL, siLXmake_special}, -{"SI::*PRINT-PACKAGE*", SI_SPECIAL, &siVprint_package, NULL}, -{"SI::*PRINT-STRUCTURE*", SI_SPECIAL, &siVprint_structure, NULL}, -{"SI::*READ-VV-BLOCK*", SI_SPECIAL, NULL, NULL}, -{"SI::.", SI_ORDINARY, NULL, NULL}, -{"SI::,", SI_ORDINARY, NULL, NULL}, -{"SI::,.", SI_ORDINARY, NULL, NULL}, -{"SI::,@", SI_ORDINARY, NULL, NULL}, -{"SI::ARGC", SI_ORDINARY, NULL, siLargc}, -{"SI::ARGV", SI_ORDINARY, NULL, siLargv}, -{"SI::ASET", SI_ORDINARY, NULL, siLaset}, -{"SI::BC-DISASSEMBLE", SI_ORDINARY, NULL, siLbc_disassemble}, -{"SI::BC-SPLIT", SI_ORDINARY, NULL, siLbc_split}, -{"SI::BDS-TOP", SI_ORDINARY, NULL, siLbds_top}, -{"SI::BDS-VAL", SI_ORDINARY, NULL, siLbds_val}, -{"SI::BDS-VAR", SI_ORDINARY, NULL, siLbds_var}, -{"SI::BIT-ARRAY-OP", SI_ORDINARY, NULL, siLbit_array_op}, -{"SI::C-ARGUMENTS-LIMIT", SI_ORDINARY, NULL, NULL}, -{"SI::CHAR-SET", SI_ORDINARY, NULL, siLchar_set}, -{"SI::CHDIR", SI_ORDINARY, NULL, siLchdir}, -{"SI::CLEAR-COMPILER-PROPERTIES", SI_ORDINARY, &siSclear_compiler_properties, siLclear_compiler_properties}, -{"SI::COERCE-TO-FUNCTION", SI_ORDINARY, NULL, siLcoerce_to_function}, -{"SI::COMPILED-FUNCTION-BLOCK", SI_ORDINARY, NULL, siLcompiled_function_block}, -{"SI::COMPILED-FUNCTION-NAME", SI_ORDINARY, NULL, siLcompiled_function_name}, -{"SI::COMPILED-FUNCTION-SOURCE", SI_ORDINARY, NULL, siLcompiled_function_source}, -{"SI::COMPUTE-APPLICABLE-METHODS", SI_ORDINARY, &siScompute_applicable_methods, NULL}, -{"SI::COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY, &siScompute_effective_method, NULL}, -{"SI::COPY-STREAM", SI_ORDINARY, NULL, siLcopy_stream}, -{"SI::COPY-STRUCTURE", SI_ORDINARY, NULL, siLcopy_structure}, -{"SI::DAYLIGHT-SAVING-TIME-P", SI_ORDINARY, NULL, siLdaylight_saving_time_p}, -{"SI::DISPLACED-ARRAY-P", SI_ORDINARY, NULL, siLdisplaced_array_p}, -{"SI::ELT-SET", SI_ORDINARY, NULL, siLelt_set}, -{"SI::EVAL-WITH-ENV", SI_ORDINARY, NULL, siLeval_with_env}, -{"SI::EXPAND-DEFMACRO", SI_ORDINARY, &siSexpand_defmacro, NULL}, -{"SI::FILL-POINTER-SET", SI_ORDINARY, NULL, siLfill_pointer_set}, -{"SI::FIXNUMP", SI_ORDINARY, NULL, siLfixnump}, -{"SI::FRS-BDS", SI_ORDINARY, NULL, siLfrs_bds}, -{"SI::FRS-CLASS", SI_ORDINARY, NULL, siLfrs_class}, -{"SI::FRS-IHS", SI_ORDINARY, NULL, siLfrs_ihs}, -{"SI::FRS-TAG", SI_ORDINARY, NULL, siLfrs_tag}, -{"SI::FRS-TOP", SI_ORDINARY, NULL, siLfrs_top}, -{"SI::FSET", SI_ORDINARY, NULL, siLfset}, -{"SI::FUNCTION-BLOCK-NAME", SI_ORDINARY, NULL, siLfunction_block_name}, -{"SI::GENERIC-FUNCTION-METHOD-COMBINATION", SI_ORDINARY, &siSgeneric_function_method_combination, NULL}, -{"SI::GENERIC-FUNCTION-METHOD-COMBINATION-ARGS", SI_ORDINARY, &siSgeneric_function_method_combination_args, NULL}, -{"SI::GET-LOCAL-TIME-ZONE", SI_ORDINARY, NULL, siLget_local_time_zone}, -{"SI::GET-STRING-INPUT-STREAM-INDEX", SI_ORDINARY, NULL, siLget_string_input_stream_index}, -{"SI::GETENV", SI_ORDINARY, NULL, siLgetenv}, -{"SI::HASH-SET", SI_ORDINARY, NULL, siLhash_set}, -{"SI::IHS-ENV", SI_ORDINARY, NULL, siLihs_env}, -{"SI::IHS-FUN", SI_ORDINARY, NULL, siLihs_fun}, -{"SI::IHS-NEXT", SI_ORDINARY, NULL, siLihs_next}, -{"SI::IHS-PREV", SI_ORDINARY, NULL, siLihs_prev}, -{"SI::IHS-TOP", SI_ORDINARY, NULL, siLihs_top}, -{"SI::INTERPRETER-STACK", SI_ORDINARY, NULL, siLinterpreter_stack}, -{"SI::LINK-FROM", SI_ORDINARY, NULL, NULL}, -{"SI::LINK-TO", SI_ORDINARY, NULL, NULL}, -{"SI::LIST-NTH", SI_ORDINARY, NULL, siLlist_nth}, -{"SI::LOAD-SOURCE", SI_ORDINARY, NULL, siLload_source}, -{"SI::LOGICAL-PATHNAME-P", SI_ORDINARY, NULL, siLlogical_pathname_p}, -{"SI::MAKE-LAMBDA", SI_ORDINARY, NULL, siLmake_lambda}, -{"SI::MAKE-PURE-ARRAY", SI_ORDINARY, NULL, siLmake_pure_array}, -{"SI::MAKE-STRING-OUTPUT-STREAM-FROM-STRING", SI_ORDINARY, NULL, siLmake_string_output_stream_from_string}, -{"SI::MAKE-STRUCTURE", SI_ORDINARY, NULL, siLmake_structure}, -{"SI::MAKE-VECTOR", SI_ORDINARY, NULL, siLmake_vector}, -{"SI::MANGLE-NAME", SI_ORDINARY, NULL, siLmangle_name}, -{"SI::MEMBER1", SI_ORDINARY, NULL, siLmember1}, -{"SI::MEMQ", SI_ORDINARY, NULL, siLmemq}, -{"SI::MKDIR", SI_ORDINARY, NULL, siLmkdir}, -{"SI::OPEN-PIPE", SI_ORDINARY, NULL, siLopen_pipe}, -{"SI::OUTPUT-STREAM-STRING", SI_ORDINARY, NULL, siLoutput_stream_string}, -{"SI::PACKAGE-EXTERNAL", SI_ORDINARY, NULL, siLpackage_external}, -{"SI::PACKAGE-INTERNAL", SI_ORDINARY, NULL, siLpackage_internal}, -{"SI::PACKAGE-LOCK", SI_ORDINARY, NULL, siLpackage_lock}, -{"SI::PACKAGE-SIZE", SI_ORDINARY, NULL, siLpackage_size}, -{"SI::PATHNAME-TRANSLATIONS", SI_ORDINARY, NULL, siLpathname_translations}, -{"SI::POINTER", SI_ORDINARY, NULL, siLpointer}, -{"SI::PRETTY-PRINT-FORMAT", SI_ORDINARY, &siSpretty_print_format, NULL}, -{"SI::PROCESS-DECLARATIONS", SI_ORDINARY, NULL, siLprocess_declarations}, -{"SI::PROCESS-LAMBDA-LIST", SI_ORDINARY, NULL, siLprocess_lambda_list}, -{"SI::PUT-F", SI_ORDINARY, NULL, siLput_f}, -{"SI::PUT-PROPERTIES", SI_ORDINARY, NULL, siLput_properties}, -{"SI::PUTPROP", SI_ORDINARY, NULL, siLputprop}, -{"SI::READ-BYTES", SI_ORDINARY, NULL, siLread_bytes}, -{"SI::REM-F", SI_ORDINARY, NULL, siLrem_f}, -{"SI::REPLACE-ARRAY", SI_ORDINARY, NULL, siLreplace_array}, -{"SI::RESET-STACK-LIMITS", SI_ORDINARY, NULL, siLreset_stack_limits}, -{"SI::ROW-MAJOR-ASET", SI_ORDINARY, NULL, siLrow_major_aset}, -{"SI::RPLACA-NTHCDR", SI_ORDINARY, NULL, siLrplaca_nthcdr}, -{"SI::SAFE-EVAL", SI_ORDINARY, NULL, siLsafe_eval}, -{"SI::SCH-FRS-BASE", SI_ORDINARY, NULL, siLsch_frs_base}, -{"SI::SCHAR-SET", SI_ORDINARY, NULL, siLchar_set}, -{"SI::SELECT-PACKAGE", SI_ORDINARY, NULL, siLselect_package}, -{"SI::SET-SYMBOL-PLIST", SI_ORDINARY, NULL, siLset_symbol_plist}, -{"SI::SETENV", SI_ORDINARY, NULL, siLsetenv}, -{"SI::SETF-LAMBDA", SI_ORDINARY, &siSsetf_lambda, NULL}, -{"SI::SETF-METHOD", SI_ORDINARY, &siSsetf_method, NULL}, -{"SI::SETF-NAMEP", SI_ORDINARY, NULL, siLsetf_namep}, -{"SI::SETF-SYMBOL", SI_ORDINARY, &siSsetf_symbol, NULL}, -{"SI::SETF-UPDATE", SI_ORDINARY, &siSsetf_update, NULL}, -{"SI::SIMPLE-CONTROL-ERROR", SI_ORDINARY, &siSsimple_control_error, NULL}, -{"SI::SIMPLE-PROGRAM-ERROR", SI_ORDINARY, &siSsimple_program_error, NULL}, -{"SI::SPECIALP", SI_ORDINARY, NULL, siLspecialp}, -{"SI::STANDARD-READTABLE", SI_ORDINARY, NULL, siLstandard_readtable}, -{"SI::STRING-CONCATENATE", SI_ORDINARY, NULL, siLstring_concatenate}, -{"SI::STRING-MATCH", SI_ORDINARY, NULL, siLstring_match}, -{"SI::STRING-TO-OBJECT", SI_ORDINARY, NULL, siLstring_to_object}, -{"SI::STRUCTURE-NAME", SI_ORDINARY, NULL, siLstructure_name}, -{"SI::STRUCTURE-PRINT-FUNCTION", SI_ORDINARY, &siSstructure_print_function, NULL}, -{"SI::STRUCTURE-REF", SI_ORDINARY, NULL, siLstructure_ref}, -{"SI::STRUCTURE-SET", SI_ORDINARY, NULL, siLstructure_set}, -{"SI::STRUCTURE-SLOT-DESCRIPTIONS", SI_ORDINARY, &siSstructure_slot_descriptions, NULL}, -{"SI::STRUCTURE-SUBTYPE-P", SI_ORDINARY, NULL, siLstructure_subtype_p}, -{"SI::STRUCTUREP", SI_ORDINARY, NULL, siLstructurep}, -{"SI::SVSET", SI_ORDINARY, NULL, siLsvset}, -{"SI::SYMBOL-MACRO", SI_ORDINARY, &siSsymbol_macro, NULL}, -{"SI::SYSTEM", SI_ORDINARY, NULL, siLsystem}, -{"SI::TERMINAL-INTERRUPT", SI_ORDINARY, &siSterminal_interrupt, NULL}, -{"SI::UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, &siSuniversal_error_handler, NULL}, -{"SI::UNLINK-SYMBOL", SI_ORDINARY, NULL, siLunlink_symbol}, -{"SI::WRITE-BYTES", SI_ORDINARY, NULL, siLwrite_bytes}, +{"SI::#!", SI_ORDINARY, NULL, -1}, +{"SI::*CBLOCK*", SI_SPECIAL, NULL, -1}, +{"SI::*CLASS-NAME-HASH-TABLE*", SI_SPECIAL, NULL, -1}, +{"SI::*GC-MESSAGE*", SI_SPECIAL, NULL, -1}, +{"SI::*GC-VERBOSE*", SI_SPECIAL, NULL, -1}, +{"SI::*IGNORE-ERRORS*", SI_SPECIAL, NULL, -1}, +{"SI::*IGNORE-EOF-ON-TERMINAL-IO*", SI_SPECIAL, NULL, -1}, +{"SI::*INDENT-FORMATTED-OUTPUT*", SI_SPECIAL, NULL, -1}, +{"SI::*INHIBIT-MACRO-SPECIAL*", SI_SPECIAL, NULL, -1}, +{"SI::*INIT-FUNCTION-PREFIX*", SI_SPECIAL, NULL, -1}, +{"SI::*INTERRUPT-ENABLE*", SI_SPECIAL, NULL, 1}, +{"SI::*KEEP-DEFINITIONS*", SI_SPECIAL, NULL, -1}, +{"SI::*LOAD-HOOKS*", SI_SPECIAL, NULL, -1}, +{"SI::*MAKE-CONSTANT", SI_ORDINARY, si_Xmake_constant, 2}, +{"SI::*MAKE-SPECIAL", SI_ORDINARY, si_Xmake_special, 1}, +{"SI::*PRINT-PACKAGE*", SI_SPECIAL, NULL, -1}, +{"SI::*PRINT-STRUCTURE*", SI_SPECIAL, NULL, -1}, +{"SI::.", SI_ORDINARY, NULL, -1}, +{"SI::,", SI_ORDINARY, NULL, -1}, +{"SI::,.", SI_ORDINARY, NULL, -1}, +{"SI::,@", SI_ORDINARY, NULL, -1}, +{"SI::ARGC", SI_ORDINARY, si_argc, 0}, +{"SI::ARGV", SI_ORDINARY, si_argv, 1}, +{"SI::ASET", SI_ORDINARY, si_aset, -1}, +{"SI::BC-DISASSEMBLE", SI_ORDINARY, si_bc_disassemble, 1}, +{"SI::BC-SPLIT", SI_ORDINARY, si_bc_split, 1}, +{"SI::BDS-TOP", SI_ORDINARY, si_bds_top, 0}, +{"SI::BDS-VAL", SI_ORDINARY, si_bds_val, 1}, +{"SI::BDS-VAR", SI_ORDINARY, si_bds_var, 1}, +{"SI::BIT-ARRAY-OP", SI_ORDINARY, si_bit_array_op, 4}, +{"SI::C-ARGUMENTS-LIMIT", SI_ORDINARY, NULL, -1}, +{"SI::CHAR-SET", SI_ORDINARY, si_char_set, 3}, +{"SI::CHDIR", SI_ORDINARY, si_chdir, 1}, +{"SI::CLEAR-COMPILER-PROPERTIES", SI_ORDINARY, si_clear_compiler_properties, 1}, +{"SI::COERCE-TO-FUNCTION", SI_ORDINARY, si_coerce_to_function, 1}, +{"SI::COERCE-TO-PACKAGE", SI_ORDINARY, si_coerce_to_package, 1}, +{"SI::COMPILED-FUNCTION-BLOCK", SI_ORDINARY, si_compiled_function_block, 1}, +{"SI::COMPILED-FUNCTION-NAME", SI_ORDINARY, si_compiled_function_name, 1}, +{"SI::COMPILED-FUNCTION-SOURCE", SI_ORDINARY, si_compiled_function_source, 1}, +{"SI::COMPUTE-APPLICABLE-METHODS", SI_ORDINARY, NULL, -1}, +{"SI::COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY, NULL, -1}, +{"SI::COPY-STREAM", SI_ORDINARY, si_copy_stream, 1}, +{"SI::COPY-STRUCTURE", SI_ORDINARY, si_copy_structure, 1}, +{"SI::DAYLIGHT-SAVING-TIME-P", SI_ORDINARY, si_daylight_saving_time_p, -1}, +{"SI::DISPLACED-ARRAY-P", SI_ORDINARY, si_displaced_array_p, 1}, +{"SI::ELT-SET", SI_ORDINARY, si_elt_set, 3}, +{"SI::EVAL-WITH-ENV", SI_ORDINARY, si_eval_with_env, 2}, +{"SI::EXPAND-DEFMACRO", SI_ORDINARY, NULL, -1}, +{"SI::FILL-POINTER-SET", SI_ORDINARY, si_fill_pointer_set, 2}, +{"SI::FIXNUMP", SI_ORDINARY, si_fixnump, 1}, +{"SI::FRS-BDS", SI_ORDINARY, si_frs_bds, 1}, +{"SI::FRS-CLASS", SI_ORDINARY, si_frs_class, 1}, +{"SI::FRS-IHS", SI_ORDINARY, si_frs_ihs, 1}, +{"SI::FRS-TAG", SI_ORDINARY, si_frs_tag, 1}, +{"SI::FRS-TOP", SI_ORDINARY, si_frs_top, 0}, +{"SI::FSET", SI_ORDINARY, si_fset, -1}, +{"SI::FUNCTION-BLOCK-NAME", SI_ORDINARY, si_function_block_name, 1}, +{"SI::GENERIC-FUNCTION-METHOD-COMBINATION", SI_ORDINARY, NULL, -1}, +{"SI::GENERIC-FUNCTION-METHOD-COMBINATION-ARGS", SI_ORDINARY, NULL, -1}, +{"SI::GET-LOCAL-TIME-ZONE", SI_ORDINARY, si_get_local_time_zone, 0}, +{"SI::GET-STRING-INPUT-STREAM-INDEX", SI_ORDINARY, si_get_string_input_stream_index, 1}, +{"SI::GETENV", SI_ORDINARY, si_getenv, 1}, +{"SI::HASH-SET", SI_ORDINARY, si_hash_set, 3}, +{"SI::IHS-ENV", SI_ORDINARY, si_ihs_env, 1}, +{"SI::IHS-FUN", SI_ORDINARY, si_ihs_fun, 1}, +{"SI::IHS-NEXT", SI_ORDINARY, si_ihs_next, 1}, +{"SI::IHS-PREV", SI_ORDINARY, si_ihs_prev, 1}, +{"SI::IHS-TOP", SI_ORDINARY, si_ihs_top, 1}, +{"SI::INTERPRETER-STACK", SI_ORDINARY, si_interpreter_stack, -1}, +{"SI::LINK-FROM", SI_ORDINARY, NULL, -1}, +{"SI::LINK-TO", SI_ORDINARY, NULL, -1}, +{"SI::LIST-NTH", SI_ORDINARY, si_list_nth, 2}, +{"SI::LOAD-SOURCE", SI_ORDINARY, si_load_source, 3}, +{"SI::LOGICAL-PATHNAME-P", SI_ORDINARY, si_logical_pathname_p, 1}, +{"SI::MAKE-LAMBDA", SI_ORDINARY, si_make_lambda, 2}, +{"SI::MAKE-PURE-ARRAY", SI_ORDINARY, si_make_pure_array, -1}, +{"SI::MAKE-STRING-OUTPUT-STREAM-FROM-STRING", SI_ORDINARY, si_make_string_output_stream_from_string, 1}, +{"SI::MAKE-STRUCTURE", SI_ORDINARY, si_make_structure, -1}, +{"SI::MAKE-VECTOR", SI_ORDINARY, si_make_vector, 6}, +{"SI::MANGLE-NAME", SI_ORDINARY, si_mangle_name, -1}, +{"SI::MEMBER1", SI_ORDINARY, si_member1, -1}, +{"SI::MEMQ", SI_ORDINARY, si_memq, -1}, +{"SI::MKDIR", SI_ORDINARY, si_mkdir, 1}, +{"SI::OPEN-PIPE", SI_ORDINARY, si_open_pipe, 1}, +{"SI::OUTPUT-STREAM-STRING", SI_ORDINARY, si_output_stream_string, 1}, +{"SI::PACKAGE-EXTERNAL", SI_ORDINARY, si_package_external, 2}, +{"SI::PACKAGE-INTERNAL", SI_ORDINARY, si_package_internal, 2}, +{"SI::PACKAGE-LOCK", SI_ORDINARY, si_package_lock, 2}, +{"SI::PACKAGE-SIZE", SI_ORDINARY, si_package_size, 1}, +{"SI::PATHNAME-TRANSLATIONS", SI_ORDINARY, si_pathname_translations, -1}, +{"SI::POINTER", SI_ORDINARY, si_pointer, 1}, +{"SI::PRETTY-PRINT-FORMAT", SI_ORDINARY, NULL, -1}, +{"SI::PROCESS-DECLARATIONS", SI_ORDINARY, si_process_declarations, -1}, +{"SI::PROCESS-LAMBDA-LIST", SI_ORDINARY, si_process_lambda_list, 1}, +{"SI::PUT-F", SI_ORDINARY, si_put_f, 3}, +{"SI::PUT-PROPERTIES", SI_ORDINARY, si_put_properties, -1}, +{"SI::PUTPROP", SI_ORDINARY, si_putprop, 3}, +{"SI::READ-BYTES", SI_ORDINARY, si_read_bytes, 4}, +{"SI::REM-F", SI_ORDINARY, si_rem_f, 2}, +{"SI::REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2}, +{"SI::RESET-STACK-LIMITS", SI_ORDINARY, si_reset_stack_limits, 0}, +{"SI::ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3}, +{"SI::RPLACA-NTHCDR", SI_ORDINARY, si_rplaca_nthcdr, 3}, +{"SI::SAFE-EVAL", SI_ORDINARY, si_safe_eval, -1}, +{"SI::SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2}, +{"SI::SCHAR-SET", SI_ORDINARY, si_char_set, 3}, +{"SI::SHARP-A-READER", SI_ORDINARY, NULL, -1}, +{"SI::SHARP-S-READER", SI_ORDINARY, NULL, -1}, +{"SI::SELECT-PACKAGE", SI_ORDINARY, si_select_package, 1}, +{"SI::SET-SYMBOL-PLIST", SI_ORDINARY, si_set_symbol_plist, 2}, +{"SI::SETENV", SI_ORDINARY, si_setenv, 2}, +{"SI::SETF-LAMBDA", SI_ORDINARY, NULL, -1}, +{"SI::SETF-METHOD", SI_ORDINARY, NULL, -1}, +{"SI::SETF-NAMEP", SI_ORDINARY, si_setf_namep, 1}, +{"SI::SETF-SYMBOL", SI_ORDINARY, NULL, -1}, +{"SI::SETF-UPDATE", SI_ORDINARY, NULL, -1}, +{"SI::SIMPLE-CONTROL-ERROR", SI_ORDINARY, NULL, -1}, +{"SI::SIMPLE-PROGRAM-ERROR", SI_ORDINARY, NULL, -1}, +{"SI::SPECIALP", SI_ORDINARY, si_specialp, 1}, +{"SI::STANDARD-READTABLE", SI_ORDINARY, si_standard_readtable, 0}, +{"SI::STRING-CONCATENATE", SI_ORDINARY, si_string_concatenate, -1}, +{"SI::STRING-MATCH", SI_ORDINARY, si_string_match, 2}, +{"SI::STRING-TO-OBJECT", SI_ORDINARY, si_string_to_object, 1}, +{"SI::STRUCTURE-NAME", SI_ORDINARY, si_structure_name, 1}, +{"SI::STRUCTURE-PRINT-FUNCTION", SI_ORDINARY, NULL, -1}, +{"SI::STRUCTURE-REF", SI_ORDINARY, si_structure_ref, 3}, +{"SI::STRUCTURE-SET", SI_ORDINARY, si_structure_set, 4}, +{"SI::STRUCTURE-SLOT-DESCRIPTIONS", SI_ORDINARY, NULL, -1}, +{"SI::STRUCTURE-SUBTYPE-P", SI_ORDINARY, si_structure_subtype_p, 2}, +{"SI::STRUCTUREP", SI_ORDINARY, si_structurep, 1}, +{"SI::SVSET", SI_ORDINARY, si_svset, 3}, +{"SI::SYMBOL-MACRO", SI_ORDINARY, NULL, -1}, +{"SI::SYSTEM", SI_ORDINARY, si_system, 1}, +{"SI::TERMINAL-INTERRUPT", SI_ORDINARY, NULL, -1}, +{"SI::UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1}, +{"SI::UNLINK-SYMBOL", SI_ORDINARY, si_unlink_symbol, 1}, +{"SI::WRITE-BYTES", SI_ORDINARY, si_write_bytes, 4}, #ifndef CLOS -{"SI::STRUCTURE-INCLUDE", SI_ORDINARY, &siSstructure_include, NULL}, +{"SI::STRUCTURE-INCLUDE", SI_ORDINARY, NULL, -1}, #else -{"SI::ALLOCATE-GFUN", SI_ORDINARY, NULL, siLallocate_gfun}, -{"SI::ALLOCATE-INSTANCE", SI_ORDINARY, NULL, siLallocate_instance}, -{"SI::CHANGE-INSTANCE", SI_ORDINARY, NULL, siLchange_instance}, -{"SI::GFUN-NAME", SI_ORDINARY, NULL, siLgfun_name}, -{"SI::GFUN-NAME-SET", SI_ORDINARY, NULL, siLgfun_name_set}, -{"SI::GFUN-METHOD-HT", SI_ORDINARY, NULL, siLgfun_method_ht}, -{"SI::GFUN-METHOD-HT-SET", SI_ORDINARY, NULL, siLgfun_method_ht_set}, -{"SI::GFUN-SPEC-HOW-REF", SI_ORDINARY, NULL, siLgfun_spec_how_ref}, -{"SI::GFUN-SPEC-HOW-SET", SI_ORDINARY, NULL, siLgfun_spec_how_set}, -{"SI::GFUN-INSTANCE", SI_ORDINARY, NULL, siLgfun_instance}, -{"SI::GFUN-INSTANCE-SET", SI_ORDINARY, NULL, siLgfun_instance_set}, -{"SI::GFUNP", SI_ORDINARY, NULL, siLgfunp}, -{"SI::INSTANCE-REF-SAFE", SI_ORDINARY, NULL, siLinstance_ref_safe}, -{"SI::INSTANCE-REF", SI_ORDINARY, NULL, siLinstance_ref}, -{"SI::INSTANCE-SET", SI_ORDINARY, NULL, siLinstance_set}, -{"SI::INSTANCE-CLASS", SI_ORDINARY, NULL, siLinstance_class}, -{"SI::INSTANCE-CLASS-SET", SI_ORDINARY, NULL, siLinstance_class_set}, -{"SI::INSTANCEP", SI_ORDINARY, NULL, siLinstancep}, -{"SI::METHOD-HT-GET", SI_ORDINARY, NULL, siLmethod_ht_get}, -{"SI::SET-COMPILED-FUNCTION-NAME", SI_ORDINARY, NULL, siLset_compiled_function_name}, -{"SI::SL-BOUNDP", SI_ORDINARY, NULL, siLsl_boundp}, -{"SI::SL-MAKUNBOUND", SI_ORDINARY, NULL, siLsl_makunbound}, -{"SI::UNBOUND", SI_ORDINARY, NULL, siLunbound}, +{"SI::ALLOCATE-GFUN", SI_ORDINARY, si_allocate_gfun, 3}, +{"SI::ALLOCATE-INSTANCE", SI_ORDINARY, si_allocate_instance, 2}, +{"SI::CHANGE-INSTANCE", SI_ORDINARY, si_change_instance, 4}, +{"SI::GFUN-NAME", SI_ORDINARY, si_gfun_name, 1}, +{"SI::GFUN-NAME-SET", SI_ORDINARY, si_gfun_name_set, 2}, +{"SI::GFUN-METHOD-HT", SI_ORDINARY, si_gfun_method_ht, 1}, +{"SI::GFUN-METHOD-HT-SET", SI_ORDINARY, si_gfun_method_ht_set, 2}, +{"SI::GFUN-SPEC-HOW-REF", SI_ORDINARY, si_gfun_spec_how_ref, 2}, +{"SI::GFUN-SPEC-HOW-SET", SI_ORDINARY, si_gfun_spec_how_set, 3}, +{"SI::GFUN-INSTANCE", SI_ORDINARY, si_gfun_instance, 1}, +{"SI::GFUN-INSTANCE-SET", SI_ORDINARY, si_gfun_instance_set, 2}, +{"SI::GFUNP", SI_ORDINARY, si_gfunp, 1}, +{"SI::INSTANCE-REF-SAFE", SI_ORDINARY, si_instance_ref_safe, 2}, +{"SI::INSTANCE-REF", SI_ORDINARY, si_instance_ref, 2}, +{"SI::INSTANCE-SET", SI_ORDINARY, si_instance_set, 3}, +{"SI::INSTANCE-CLASS", SI_ORDINARY, si_instance_class, 1}, +{"SI::INSTANCE-CLASS-SET", SI_ORDINARY, si_instance_class_set, 2}, +{"SI::INSTANCEP", SI_ORDINARY, si_instancep, 1}, +{"SI::METHOD-HT-GET", SI_ORDINARY, si_method_ht_get, 2}, +{"SI::SET-COMPILED-FUNCTION-NAME", SI_ORDINARY, si_set_compiled_function_name, 2}, +{"SI::SL-BOUNDP", SI_ORDINARY, si_sl_boundp, 1}, +{"SI::SL-MAKUNBOUND", SI_ORDINARY, si_sl_makunbound, 2}, +{"SI::UNBOUND", SI_ORDINARY, si_unbound, 0}, #endif #ifdef PROFILE -{"SI::*PROFILE-ARRAY*", SI_SPECIAL, &sSAprofile_arrayA, NULL}, +{"SI::*PROFILE-ARRAY*", SI_SPECIAL, NULL, -1}, #endif #ifdef ENABLE_DLOPEN -{"SI::LOAD-BINARY", SI_ORDINARY, NULL, siLload_binary}, +{"SI::LOAD-BINARY", SI_ORDINARY, si_load_binary, 3}, #endif #ifdef ECL_CLOS_STREAMS -{"STREAM-CLEAR-INPUT", CL_ORDINARY, &clSstream_clear_input, NULL}, -{"STREAM-CLEAR-OUTPUT", CL_ORDINARY, &clSstream_clear_output, NULL}, -{"STREAM-CLOSE", CL_ORDINARY, &clSstream_close, NULL}, -{"STREAM-FORCE-OUTPUT", CL_ORDINARY, &clSstream_force_output, NULL}, -{"STREAM-INPUT-P", CL_ORDINARY, &clSstream_input_p, NULL}, -{"STREAM-LISTEN", CL_ORDINARY, &clSstream_listen, NULL}, -{"STREAM-OUTPUT-P", CL_ORDINARY, &clSstream_output_p, NULL}, -{"STREAM-READ-CHAR", CL_ORDINARY, &clSstream_read_char, NULL}, -{"STREAM-UNREAD-CHAR", CL_ORDINARY, &clSstream_unread_char, NULL}, -{"STREAM-WRITE-CHAR", CL_ORDINARY, &clSstream_write_char, NULL}, +{"STREAM-CLEAR-INPUT", CL_ORDINARY, NULL, -1}, +{"STREAM-CLEAR-OUTPUT", CL_ORDINARY, NULL, -1}, +{"STREAM-CLOSE", CL_ORDINARY, NULL, -1}, +{"STREAM-FORCE-OUTPUT", CL_ORDINARY, NULL, -1}, +{"STREAM-INPUT-P", CL_ORDINARY, NULL, -1}, +{"STREAM-LISTEN", CL_ORDINARY, NULL, -1}, +{"STREAM-OUTPUT-P", CL_ORDINARY, NULL, -1}, +{"STREAM-READ-CHAR", CL_ORDINARY, NULL, -1}, +{"STREAM-UNREAD-CHAR", CL_ORDINARY, NULL, -1}, +{"STREAM-WRITE-CHAR", CL_ORDINARY, NULL, -1}, #endif #ifdef PDE -{"SI::*RECORD-SOURCE-PATHNAME-P*", SI_SPECIAL, &siVrecord_source_pathname_p, NULL}, -{"SI::*SOURCE-PATHNAME*", SI_SPECIAL, &siVsource_pathname, NULL}, -{"SI::RECORD-SOURCE-PATHNAME", SI_ORDINARY, &siSrecord_source_pathname, NULL}, +{"SI::*RECORD-SOURCE-PATHNAME-P*", SI_SPECIAL, NULL, -1}, +{"SI::*SOURCE-PATHNAME*", SI_SPECIAL, NULL, -1}, +{"SI::RECORD-SOURCE-PATHNAME", SI_ORDINARY, NULL, -1}, #endif #ifdef THREADS -{"CONT", CL_ORDINARY, &clScont, NULL}, -{"DEAD", CL_ORDINARY, &clSdead, NULL}, -{"RUNNING", CL_ORDINARY, &clSrunning, NULL}, -{"STOPPED", CL_ORDINARY, &clSstopped, NULL}, -{"SUSPENDED", CL_ORDINARY, &clSsuspended, NULL}, -{"THREAD", CL_ORDINARY, &clSthread, NULL}, -{"WAITING", CL_ORDINARY, &clSwaiting, NULL}, -{"SI::THREAD-BREAK-IN", SI_ORDINARY, NULL, siLthread_break_in}, -{"SI::THREAD-BREAK-QUIT", SI_ORDINARY, NULL, siLthread_break_quit}, -{"SI::THREAD-BREAK-RESUME", SI_ORDINARY, NULL, siLthread_break_resume}, -{"SI::THREAD-TOP-LEVEL", SI_ORDINARY, &siSthread_top_level, NULL}, -{"MAKE-THREAD", CL_ORDINARY, NULL, clLmake_thread}, -{"DEACTIVATE", CL_ORDINARY, NULL, clLdeactivate}, -{"REACTIVATE", CL_ORDINARY, NULL, clLreactivate}, -{"KILL-THREAD", CL_ORDINARY, NULL, clLkill_thread}, -{"CURRENT-THREAD", CL_ORDINARY, NULL, clLcurrent_thread}, -{"THREAD-STATUS", CL_ORDINARY, NULL, clLthread_status}, -{"THREAD-LIST", CL_ORDINARY, NULL, clLthread_list}, -{"MAKE-CONTINUATION", CL_ORDINARY, NULL, clLmake_continuation}, -{"THREAD-OF", CL_ORDINARY, NULL, clLthread_of}, -{"CONTINUATION-OF", CL_ORDINARY, NULL, clLcontinuation_of}, -{"RESUME", CL_ORDINARY, NULL, clLresume}, -{"%DISABLE-SCHEDULER", CL_ORDINARY, NULL, clLdisable_scheduler}, -{"%ENABLE-SCHEDULER", CL_ORDINARY, NULL, clLenable_scheduler}, -{"%SUSPEND", CL_ORDINARY, NULL, clLsuspend}, -{"%DELAY", CL_ORDINARY, NULL, clLdelay}, -{"%THREAD-WAIT", CL_ORDINARY, NULL, clLthread_wait}, -{"%THREAD-WAIT-WITH-TIMEOUT", CL_ORDINARY, NULL, clLthread_wait_with_timeout}, +{"CONT", CL_ORDINARY, NULL, -1}, +{"DEAD", CL_ORDINARY, NULL, -1}, +{"RUNNING", CL_ORDINARY, NULL, -1}, +{"STOPPED", CL_ORDINARY, NULL, -1}, +{"SUSPENDED", CL_ORDINARY, NULL, -1}, +{"THREAD", CL_ORDINARY, NULL, -1}, +{"WAITING", CL_ORDINARY, NULL, -1}, +{"SI::THREAD-BREAK-IN", SI_ORDINARY, si_thread_break_in, -1}, +{"SI::THREAD-BREAK-QUIT", SI_ORDINARY, si_thread_break_quit, -1}, +{"SI::THREAD-BREAK-RESUME", SI_ORDINARY, si_thread_break_resume, -1}, +{"SI::THREAD-TOP-LEVEL", SI_ORDINARY, NULL, -1}, +{"MAKE-THREAD", CL_ORDINARY, cl_make_thread, -1}, +{"DEACTIVATE", CL_ORDINARY, cl_deactivate, -1}, +{"REACTIVATE", CL_ORDINARY, cl_reactivate, -1}, +{"KILL-THREAD", CL_ORDINARY, cl_kill_thread, -1}, +{"CURRENT-THREAD", CL_ORDINARY, cl_current_thread, -1}, +{"THREAD-STATUS", CL_ORDINARY, cl_thread_status, -1}, +{"THREAD-LIST", CL_ORDINARY, cl_thread_list, -1}, +{"MAKE-CONTINUATION", CL_ORDINARY, cl_make_continuation, -1}, +{"THREAD-OF", CL_ORDINARY, cl_thread_of, -1}, +{"CONTINUATION-OF", CL_ORDINARY, cl_continuation_of, -1}, +{"RESUME", CL_ORDINARY, cl_resume, -1}, +{"%DISABLE-SCHEDULER", CL_ORDINARY, cl_disable_scheduler, -1}, +{"%ENABLE-SCHEDULER", CL_ORDINARY, cl_enable_scheduler, -1}, +{"%SUSPEND", CL_ORDINARY, cl_suspend, -1}, +{"%DELAY", CL_ORDINARY, cl_delay, -1}, +{"%THREAD-WAIT", CL_ORDINARY, cl_thread_wait, -1}, +{"%THREAD-WAIT-WITH-TIMEOUT", CL_ORDINARY, cl_thread_wait_with_timeout, -1}, #endif #ifdef GBC_BOEHM -{"GC", CL_ORDINARY, NULL, clLgc}, +{"GC", CL_ORDINARY, cl_gc, -1}, #endif #if !defined(GBC_BOEHM) -{"GC", CL_ORDINARY, NULL, clLgc}, -{"SI::ALLOCATE", SI_ORDINARY, NULL, siLallocate}, -{"SI::ALLOCATED-PAGES", SI_ORDINARY, NULL, siLallocated_pages}, -{"SI::MAXIMUM-ALLOCATABLE-PAGES", SI_ORDINARY, NULL, siLmaximum_allocatable_pages}, -{"SI::ALLOCATE-CONTIGUOUS-PAGES", SI_ORDINARY, NULL, siLallocate_contiguous_pages}, -{"SI::ALLOCATED-CONTIGUOUS-PAGES", SI_ORDINARY, NULL, siLallocated_contiguous_pages}, -{"SI::MAXIMUM-CONTIGUOUS-PAGES", SI_ORDINARY, NULL, siLmaximum_contiguous_pages}, -{"SI::GC-TIME", SI_ORDINARY, NULL, siLgc_time}, -{"SI::GET-HOLE-SIZE", SI_ORDINARY, NULL, siLget_hole_size}, -{"SI::SET-HOLE-SIZE", SI_ORDINARY, NULL, siLset_hole_size}, -{"SI::IGNORE-MAXIMUM-PAGES", SI_ORDINARY, NULL, siLignore_maximum_pages}, -{"SI::ROOM-REPORT", SI_ORDINARY, NULL, siLroom_report}, -{"SI::RESET-GC-COUNT", SI_ORDINARY, NULL, siLreset_gc_count}, +{"GC", CL_ORDINARY, cl_gc, -1}, +{"SI::ALLOCATE", SI_ORDINARY, si_allocate, -1}, +{"SI::ALLOCATED-PAGES", SI_ORDINARY, si_allocated_pages, -1}, +{"SI::MAXIMUM-ALLOCATABLE-PAGES", SI_ORDINARY, si_maximum_allocatable_pages, -1}, +{"SI::ALLOCATE-CONTIGUOUS-PAGES", SI_ORDINARY, si_allocate_contiguous_pages, -1}, +{"SI::ALLOCATED-CONTIGUOUS-PAGES", SI_ORDINARY, si_allocated_contiguous_pages, -1}, +{"SI::MAXIMUM-CONTIGUOUS-PAGES", SI_ORDINARY, si_maximum_contiguous_pages, -1}, +{"SI::GC-TIME", SI_ORDINARY, si_gc_time, -1}, +{"SI::GET-HOLE-SIZE", SI_ORDINARY, si_get_hole_size, -1}, +{"SI::SET-HOLE-SIZE", SI_ORDINARY, si_set_hole_size, -1}, +{"SI::IGNORE-MAXIMUM-PAGES", SI_ORDINARY, si_ignore_maximum_pages, -1}, +{"SI::ROOM-REPORT", SI_ORDINARY, si_room_report, -1}, +{"SI::RESET-GC-COUNT", SI_ORDINARY, si_reset_gc_count, -1}, #endif /* !GBC_BOEHM */ #ifdef PROFILE -{"SI::PROFILE", SI_ORDINARY, NULL, siLprofile}, -{"SI::CLEAR-PROFILE", SI_ORDINARY, NULL, siLclear_profile}, -{"SI::DISPLAY-PROFILE", SI_ORDINARY, NULL, siLdisplay_profile}, +{"SI::PROFILE", SI_ORDINARY, si_profile, -1}, +{"SI::CLEAR-PROFILE", SI_ORDINARY, si_clear_profile, -1}, +{"SI::DISPLAY-PROFILE", SI_ORDINARY, si_display_profile, -1}, #endif /* PROFILE */ #ifdef TCP -{"SI::OPEN-CLIENT-STREAM", SI_ORDINARY, NULL, siLopen_client_stream}, -{"SI::OPEN-SERVER-STREAM", SI_ORDINARY, NULL, siLopen_server_stream}, -{"SI::OPEN-UNIX-SOCKET-STREAM", SI_ORDINARY, NULL, siLopen_unix_socket_stream}, -{"SI::LOOKUP-HOST-ENTRY", SI_ORDINARY, NULL, siLlookup_host_entry}, +{"SI::OPEN-CLIENT-STREAM", SI_ORDINARY, si_open_client_stream, 2}, +{"SI::OPEN-SERVER-STREAM", SI_ORDINARY, si_open_server_stream, 1}, +{"SI::OPEN-UNIX-SOCKET-STREAM", SI_ORDINARY, si_open_unix_socket_stream, 1}, +{"SI::LOOKUP-HOST-ENTRY", SI_ORDINARY, si_lookup_host_entry, 1}, #endif #ifdef unix -{"SI::CATCH-BAD-SIGNALS", SI_ORDINARY, NULL, siLcatch_bad_signals}, -{"SI::UNCATCH-BAD-SIGNALS", SI_ORDINARY, NULL, siLuncatch_bad_signals}, +{"SI::CATCH-BAD-SIGNALS", SI_ORDINARY, si_catch_bad_signals, 0}, +{"SI::UNCATCH-BAD-SIGNALS", SI_ORDINARY, si_uncatch_bad_signals, 0}, #endif /* unix */ /* KEYWORD PACKAGE */ -{":ABORT", KEYWORD, &Kabort, NULL}, -{":ABSOLUTE", KEYWORD, &Kabsolute, NULL}, -{":ALLOW-OTHER-KEYS", KEYWORD, &Kallow_other_keys, NULL}, -{":APPEND", KEYWORD, &Kappend, NULL}, -{":ARRAY", KEYWORD, &Karray, NULL}, -{":BASE", KEYWORD, &Kbase, NULL}, -{":BLOCK", KEYWORD, &Kblock, NULL}, -{":CAPITALIZE", KEYWORD, &Kcapitalize, NULL}, -{":CASE", KEYWORD, &Kcase, NULL}, -{":CATCH", KEYWORD, &Kcatch, NULL}, -{":CATCHALL", KEYWORD, &Kcatchall, NULL}, -{":CIRCLE", KEYWORD, &Kcircle, NULL}, -{":COMPILE-TOPLEVEL", KEYWORD, &Kcompile_toplevel, NULL}, -{":CREATE", KEYWORD, &Kcreate, NULL}, -{":DATUM", KEYWORD, &Kdatum, NULL}, -{":DEFAULT", KEYWORD, &Kdefault, NULL}, -{":DEFAULTS", KEYWORD, &Kdefaults, NULL}, -{":DEVICE", KEYWORD, &Kdevice, NULL}, -{":DIRECTION", KEYWORD, &Kdirection, NULL}, -{":DIRECTORY", KEYWORD, &Kdirectory, NULL}, -{":DOWNCASE", KEYWORD, &Kdowncase, NULL}, -{":ELEMENT-TYPE", KEYWORD, &Kelement_type, NULL}, -{":END", KEYWORD, &Kend, NULL}, -{":END1", KEYWORD, &Kend1, NULL}, -{":END2", KEYWORD, &Kend2, NULL}, -{":ERROR", KEYWORD, &Kerror, NULL}, -{":ESCAPE", KEYWORD, &Kescape, NULL}, -{":EXECUTE", KEYWORD, &Kexecute, NULL}, -{":EXPECTED-TYPE", KEYWORD, &Kexpected_type, NULL}, -{":EXTERNAL", KEYWORD, &Kexternal, NULL}, -{":FORMAT-ARGUMENTS", KEYWORD, &Kformat_arguments, NULL}, -{":FORMAT-CONTROL", KEYWORD, &Kformat_control, NULL}, -{":FUNCTION", KEYWORD, &Kfunction, NULL}, -{":GENSYM", KEYWORD, &Kgensym, NULL}, -{":HOST", KEYWORD, &Khost, NULL}, -{":IF-DOES-NOT-EXIST", KEYWORD, &Kif_does_not_exist, NULL}, -{":IF-EXISTS", KEYWORD, &Kif_exists, NULL}, -{":INHERITED", KEYWORD, &Kinherited, NULL}, -{":INITIAL-ELEMENT", KEYWORD, &Kinitial_element, NULL}, -{":INPUT", KEYWORD, &Kinput, NULL}, -{":INTERNAL", KEYWORD, &Kinternal, NULL}, -{":IO", KEYWORD, &Kio, NULL}, -{":JUNK-ALLOWED", KEYWORD, &Kjunk_allowed, NULL}, -{":KEY", KEYWORD, &Kkey, NULL}, -{":LENGTH", KEYWORD, &Klength, NULL}, -{":LEVEL", KEYWORD, &Klevel, NULL}, -{":LIST-ALL", KEYWORD, &Klist_all, NULL}, -{":LOAD-TOPLEVEL", KEYWORD, &Kload_toplevel, NULL}, -{":NAME", KEYWORD, &Kname, NULL}, -{":NEW-VERSION", KEYWORD, &Knew_version, NULL}, -{":NEWEST", KEYWORD, &Knewest, NULL}, -{":NICKNAMES", KEYWORD, &Knicknames, NULL}, -{":OUTPUT", KEYWORD, &Koutput, NULL}, -{":OVERWRITE", KEYWORD, &Koverwrite, NULL}, -{":PATHNAME", KEYWORD, &Kpathname, NULL}, -{":PRETTY", KEYWORD, &Kpretty, NULL}, -{":PRINT", KEYWORD, &Kprint, NULL}, -{":PROBE", KEYWORD, &Kprobe, NULL}, -{":PROTECT", KEYWORD, &Kprotect, NULL}, -{":RADIX", KEYWORD, &Kradix, NULL}, -{":REHASH-SIZE", KEYWORD, &Krehash_size, NULL}, -{":REHASH-THRESHOLD", KEYWORD, &Krehash_threshold, NULL}, -{":RELATIVE", KEYWORD, &Krelative, NULL}, -{":RENAME", KEYWORD, &Krename, NULL}, -{":RENAME-AND-DELETE", KEYWORD, &Krename_and_delete, NULL}, -{":SET-DEFAULT-PATHNAME", KEYWORD, &Kset_default_pathname, NULL}, -{":SIZE", KEYWORD, &Ksize, NULL}, -{":START", KEYWORD, &Kstart, NULL}, -{":START1", KEYWORD, &Kstart1, NULL}, -{":START2", KEYWORD, &Kstart2, NULL}, -{":STREAM", KEYWORD, &Kstream, NULL}, -{":SUPERSEDE", KEYWORD, &Ksupersede, NULL}, -{":TAG", KEYWORD, &Ktag, NULL}, -{":TEST", KEYWORD, &Ktest, NULL}, -{":TEST-NOT", KEYWORD, &Ktest_not, NULL}, -{":TYPE", KEYWORD, &Ktype, NULL}, -{":UNSPECIFIC", KEYWORD, &Kunspecific, NULL}, -{":UP", KEYWORD, &Kup, NULL}, -{":UPCASE", KEYWORD, &Kupcase, NULL}, -{":USE", KEYWORD, &Kuse, NULL}, -{":VERBOSE", KEYWORD, &Kverbose, NULL}, -{":VERSION", KEYWORD, &Kversion, NULL}, -{":WILD", KEYWORD, &Kwild, NULL}, -{":WILD-INFERIORS", KEYWORD, &Kwild_inferiors, NULL}, +{":ABORT", KEYWORD, NULL, -1}, +{":ABSOLUTE", KEYWORD, NULL, -1}, +{":ALLOW-OTHER-KEYS", KEYWORD, NULL, -1}, +{":APPEND", KEYWORD, NULL, -1}, +{":ARRAY", KEYWORD, NULL, -1}, +{":BASE", KEYWORD, NULL, -1}, +{":BLOCK", KEYWORD, NULL, -1}, +{":CAPITALIZE", KEYWORD, NULL, -1}, +{":CASE", KEYWORD, NULL, -1}, +{":CATCH", KEYWORD, NULL, -1}, +{":CATCHALL", KEYWORD, NULL, -1}, +{":CIRCLE", KEYWORD, NULL, -1}, +{":COMPILE-TOPLEVEL", KEYWORD, NULL, -1}, +{":CREATE", KEYWORD, NULL, -1}, +{":DATUM", KEYWORD, NULL, -1}, +{":DEFAULT", KEYWORD, NULL, -1}, +{":DEFAULTS", KEYWORD, NULL, -1}, +{":DEVICE", KEYWORD, NULL, -1}, +{":DIRECTION", KEYWORD, NULL, -1}, +{":DIRECTORY", KEYWORD, NULL, -1}, +{":DOWNCASE", KEYWORD, NULL, -1}, +{":ELEMENT-TYPE", KEYWORD, NULL, -1}, +{":END", KEYWORD, NULL, -1}, +{":END1", KEYWORD, NULL, -1}, +{":END2", KEYWORD, NULL, -1}, +{":ERROR", KEYWORD, NULL, -1}, +{":ESCAPE", KEYWORD, NULL, -1}, +{":EXECUTE", KEYWORD, NULL, -1}, +{":EXPECTED-TYPE", KEYWORD, NULL, -1}, +{":EXTERNAL", KEYWORD, NULL, -1}, +{":FORMAT-ARGUMENTS", KEYWORD, NULL, -1}, +{":FORMAT-CONTROL", KEYWORD, NULL, -1}, +{":FUNCTION", KEYWORD, NULL, -1}, +{":GENSYM", KEYWORD, NULL, -1}, +{":HOST", KEYWORD, NULL, -1}, +{":IF-DOES-NOT-EXIST", KEYWORD, NULL, -1}, +{":IF-EXISTS", KEYWORD, NULL, -1}, +{":INHERITED", KEYWORD, NULL, -1}, +{":INITIAL-ELEMENT", KEYWORD, NULL, -1}, +{":INPUT", KEYWORD, NULL, -1}, +{":INTERNAL", KEYWORD, NULL, -1}, +{":IO", KEYWORD, NULL, -1}, +{":JUNK-ALLOWED", KEYWORD, NULL, -1}, +{":KEY", KEYWORD, NULL, -1}, +{":LENGTH", KEYWORD, NULL, -1}, +{":LEVEL", KEYWORD, NULL, -1}, +{":LIST-ALL", KEYWORD, NULL, -1}, +{":LOAD-TOPLEVEL", KEYWORD, NULL, -1}, +{":NAME", KEYWORD, NULL, -1}, +{":NEW-VERSION", KEYWORD, NULL, -1}, +{":NEWEST", KEYWORD, NULL, -1}, +{":NICKNAMES", KEYWORD, NULL, -1}, +{":OUTPUT", KEYWORD, NULL, -1}, +{":OVERWRITE", KEYWORD, NULL, -1}, +{":PATHNAME", KEYWORD, NULL, -1}, +{":PRETTY", KEYWORD, NULL, -1}, +{":PRINT", KEYWORD, NULL, -1}, +{":PROBE", KEYWORD, NULL, -1}, +{":PROTECT", KEYWORD, NULL, -1}, +{":RADIX", KEYWORD, NULL, -1}, +{":REHASH-SIZE", KEYWORD, NULL, -1}, +{":REHASH-THRESHOLD", KEYWORD, NULL, -1}, +{":RELATIVE", KEYWORD, NULL, -1}, +{":RENAME", KEYWORD, NULL, -1}, +{":RENAME-AND-DELETE", KEYWORD, NULL, -1}, +{":SET-DEFAULT-PATHNAME", KEYWORD, NULL, -1}, +{":SIZE", KEYWORD, NULL, -1}, +{":START", KEYWORD, NULL, -1}, +{":START1", KEYWORD, NULL, -1}, +{":START2", KEYWORD, NULL, -1}, +{":STREAM", KEYWORD, NULL, -1}, +{":SUPERSEDE", KEYWORD, NULL, -1}, +{":TAG", KEYWORD, NULL, -1}, +{":TEST", KEYWORD, NULL, -1}, +{":TEST-NOT", KEYWORD, NULL, -1}, +{":TYPE", KEYWORD, NULL, -1}, +{":UNSPECIFIC", KEYWORD, NULL, -1}, +{":UP", KEYWORD, NULL, -1}, +{":UPCASE", KEYWORD, NULL, -1}, +{":USE", KEYWORD, NULL, -1}, +{":VERBOSE", KEYWORD, NULL, -1}, +{":VERSION", KEYWORD, NULL, -1}, +{":WILD", KEYWORD, NULL, -1}, +{":WILD-INFERIORS", KEYWORD, NULL, -1}, /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, NULL}}; diff --git a/src/c/tclBasic.d b/src/c/tclBasic.d index 8cfda9c96..26c0672db 100644 --- a/src/c/tclBasic.d +++ b/src/c/tclBasic.d @@ -504,7 +504,7 @@ Tcl_GetCommandInfo(Tcl_Interp *interp, /* Interpreter in which to look { cl_object v = _intern(cmdName, tk_package); - if (!structure_subtypep(TYPE_OF(SYM_VAL(v)), TkWidgetType)) return 0; + if (!structure_subtypep(cl_type_of(SYM_VAL(v)), TkWidgetType)) return 0; infoPtr->proc = (Tcl_CmdProc *)fix(SLOT(SYM_VAL(v), 0)); infoPtr->clientData = (ClientData)fix(SLOT(SYM_VAL(v), 1)); diff --git a/src/c/tcp.d b/src/c/tcp.d index 1e4df0bc7..a68d5b612 100644 --- a/src/c/tcp.d +++ b/src/c/tcp.d @@ -233,10 +233,12 @@ make_stream(cl_object host, int fd, enum smmode smm) (read-line s) "Wed Jun 22 19:44:36 METDST 1994" */ -@(defun si::open_client_stream (host port) +cl_object +si_open_client_stream(cl_object host, cl_object port) +{ int fd, p; /* file descriptor */ cl_object streamIn, streamOut; -@ + assert_type_string(host); /* Ensure "host" is a string */ p = fixnnint(port); /* INV: fixnnint() checks type */ @@ -254,13 +256,15 @@ make_stream(cl_object host, int fd, enum smmode smm) streamOut = make_stream(host, fd, smm_output); @(return make_two_way_stream(streamIn, streamOut)) -@) +} -@(defun si::open_server_stream (port) +cl_object +si_open_server_stream(cl_object port) +{ int fd; /* file descriptor */ cl_object streamIn, streamOut; cl_object output; -@ + if (!FIXNUMP(port)) FEwrong_type_argument(TSpositive_number, port); @@ -276,17 +280,19 @@ make_stream(cl_object host, int fd, enum smmode smm) output = make_two_way_stream(streamIn, streamOut); } @(return output) -@) +} /************************************************************ * Unix sockets * ************************************************************/ -@(defun si::open-unix-socket-stream (path) +cl_object +si_open_unix_socket_stream(cl_object path) +{ int fd; /* file descriptor */ cl_object streamIn, streamOut; struct sockaddr_un addr; -@ + if (type_of(path) != t_string) FEwrong_type_argument(@'string', path); if (path->string.fillp > UNIX_MAX_PATH-1) @@ -312,18 +318,20 @@ make_stream(cl_object host, int fd, enum smmode smm) streamOut = make_stream(path, fd, smm_output); @(return make_two_way_stream(streamIn, streamOut)) -@) +} /************************************************************ * Hostname resolution * ************************************************************/ -@(defun si::lookup-host-entry (host_or_address) +cl_object +si_lookup_host_entry(cl_object host_or_address) +{ struct hostent *he; unsigned long l; unsigned char address[4]; cl_object name, aliases, addresses; int i; -@ + switch (type_of(host_or_address)) { case t_string: host_or_address->string.self[host_or_address->string.fillp] = 0; @@ -357,4 +365,4 @@ make_stream(cl_object host, int fd, enum smmode smm) addresses = CONS(make_integer(l), addresses); } @(return name aliases addresses) -@) +} diff --git a/src/c/time.d b/src/c/time.d index cf203d2da..42265de8a 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -50,22 +50,24 @@ UTC_time_to_universal_time(int i) return number_plus(bignum1(i), Jan1st1970UT); } -@(defun get_universal_time () -@ +cl_object +cl_get_universal_time() +{ @(return UTC_time_to_universal_time(time(0))) -@) +} -@(defun sleep (z) +cl_object +cl_sleep(cl_object z) +{ double r; #ifdef HAVE_NANOSLEEP struct timespec tm; #endif -@ /* INV: number_minusp() makes sure `z' is real */ if (number_minusp(z)) FEcondition(9, @'simple-type-error', @':format-control', make_simple_string("Not a non-negative number ~S"), - @':format-arguments', list(1, z), + @':format-arguments', cl_list(1, z), @':expected-type', @'real', @':datum', z); #ifdef HAVE_NANOSLEEP r = object_to_double(z); @@ -81,30 +83,35 @@ UTC_time_to_universal_time(int i) sleep(1000); #endif @(return Cnil) -@) +} -@(defun get_internal_run_time () +cl_object +cl_get_internal_run_time() +{ struct tms buf; -@ + times(&buf); @(return MAKE_FIXNUM(buf.tms_utime)) -@) +} -@(defun get_internal_real_time () -@ +cl_object +cl_get_internal_real_time() +{ @(return MAKE_FIXNUM((time(0) - beginning)*HZ)) -@) +} /* * Return the hours west of Greenwich for the current timezone. * * Based on Lott's get_timezone() function from CMU Common Lisp. */ -@(defun si::get_local_time_zone () +cl_object +si_get_local_time_zone() +{ struct tm ltm, gtm; int mw; time_t when = 0L; -@ + ltm = *localtime(&when); gtm = *gmtime(&when); @@ -116,7 +123,7 @@ UTC_time_to_universal_time(int i) mw += 24*60; @(return make_ratio(MAKE_FIXNUM(mw), MAKE_FIXNUM(60))) -@) +} /* * Return T if daylight saving is in effect at Universal Time UT, which diff --git a/src/c/typespec.d b/src/c/typespec.d index f0d14fa66..702716792 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -62,7 +62,7 @@ void FEtype_error_proper_list(cl_object x) { FEcondition(9, @'simple-type-error', @':format-control', make_simple_string("Not a proper list ~D"), - @':format-arguments', list(1, x), + @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); } @@ -72,7 +72,7 @@ FEtype_error_alist(cl_object x) { FEcondition(9, @'simple-type-error', @':format-control', make_simple_string("Not a valid association list ~D"), - @':format-arguments', list(1, x), + @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); } @@ -82,7 +82,7 @@ FEtype_error_plist(cl_object x) { FEcondition(9, @'simple-type-error', @':format-control', make_simple_string("Not a valid property list ~D"), - @':format-arguments', list(1, x), + @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); } @@ -94,7 +94,7 @@ FEcircular_list(cl_object x) bds_bind(@'*print-circle*', Ct); FEcondition(9, @'simple-type-error', @':format-control', make_simple_string("Circular list ~D"), - @':format-arguments', list(1, x), + @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); } @@ -104,7 +104,7 @@ FEtype_error_index(cl_object x) { FEcondition(9, @'simple-type-error', @':format-control', make_simple_string("Index out of bounds ~D"), - @':format-arguments', list(1, x), + @':format-arguments', cl_list(1, x), @':expected-type', @'fixnum', @':datum', x); } @@ -233,155 +233,158 @@ assert_type_vector(cl_object p) } cl_object -TYPE_OF(cl_object x) +cl_type_of(cl_object x) { + cl_object t; switch (type_of(x)) { #ifdef CLOS case t_instance: { cl_object cl = CLASS_OF(x); if (CLASS_NAME(cl) != Cnil) - return(CLASS_NAME(cl)); + t = CLASS_NAME(cl); else - return(cl); + t = cl; } + break; #endif - case t_fixnum: - return(@'fixnum'); + t = @'fixnum'; break; case t_bignum: - return(@'bignum'); + t = @'bignum'; break; case t_ratio: - return(@'ratio'); + t = @'ratio'; break; case t_shortfloat: - return(@'short-float'); + t = @'short-float'; break; case t_longfloat: - return(@'long-float'); + t = @'long-float'; break; case t_complex: - return(@'complex'); + t = @'complex'; break; case t_character: { int i = CHAR_CODE(x); if ((' ' <= i && i < '\177') || i == '\n') - return(@'standard-char'); + t = @'standard-char'; else - return(@'base-char'); + t = @'base-char'; + break; } case t_symbol: if (x == Cnil) - return(@'null'); - if (x->symbol.hpack == keyword_package) - return(@'keyword'); + t = @'null'; + else if (x->symbol.hpack == keyword_package) + t = @'keyword'; else - return(@'symbol'); + t = @'symbol'; + break; case t_package: - return(@'package'); + t = @'package'; break; case t_cons: - return(@'cons'); + t = @'cons'; break; case t_hashtable: - return(@'hash-table'); + t = @'hash-table'; break; case t_array: if (x->array.adjustable || Null(CAR(x->array.displaced))) - return(@'array'); + t = @'array'; else - return(@'simple-array'); + t = @'simple-array'; + break; case t_vector: if (x->vector.adjustable || x->vector.hasfillp || Null(CAR(x->vector.displaced)) || (cl_elttype)x->vector.elttype != aet_object) - return(@'vector'); + t = @'vector'; else - return(@'simple-vector'); + t = @'simple-vector'; + break; case t_string: if (x->string.adjustable || x->string.hasfillp || Null(CAR(x->string.displaced))) - return(@'string'); + t = @'string'; else - return(@'simple-string'); + t = @'simple-string'; + break; case t_bitvector: if (x->vector.adjustable || x->vector.hasfillp || Null(CAR(x->vector.displaced))) - return(@'bit-vector'); + t = @'bit-vector'; else - return(@'simple-bit-vector'); + t = @'simple-bit-vector'; + break; #ifndef CLOS case t_structure: - return(x->str.name); + t = x->str.name; break; #endif case t_stream: switch (x->stream.mode) { - case smm_synonym: return @'synonym-stream'; - case smm_broadcast: return @'broadcast-stream'; - case smm_concatenated: return @'concatenated-stream'; - case smm_two_way: return @'two-way-stream'; + case smm_synonym: t = @'synonym-stream'; break; + case smm_broadcast: t = @'broadcast-stream'; break; + case smm_concatenated: t = @'concatenated-stream'; break; + case smm_two_way: t = @'two-way-stream'; break; case smm_string_input: - case smm_string_output: return @'string-stream'; - case smm_echo: return @'echo-stream'; - default: return @'file-stream'; + case smm_string_output: t = @'string-stream'; break; + case smm_echo: t = @'echo-stream'; break; + default: t = @'file-stream'; break; } + break; case t_readtable: - return(@'readtable'); + t = @'readtable'; break; case t_pathname: - if (x->pathname.logical) - return @'logical-pathname'; - return(@'pathname'); + t = x->pathname.logical? @'logical-pathname' : @'pathname'; + break; case t_random: - return(@'random-state'); + t = @'random-state'; break; case t_bytecodes: case t_cfun: case t_cclosure: - return(@'function'); + t = @'function'; break; #ifdef THREADS case t_cont: - return(@'cont'); + t = @'cont'; break; case t_thread: - return(@'thread'); + t = @'thread'; break; #endif #ifdef CLOS case t_gfun: - return(@'dispatch-function'); + t = @'dispatch-function'; break; #endif default: error("not a lisp data object"); } + return1(t); } -@(defun type_of (x) -@ - @(return TYPE_OF(x)) -@) - void init_typespec(void) { - TSnon_negative_integer = list(3, @'integer', MAKE_FIXNUM(0), @'*'); + TSnon_negative_integer = cl_list(3, @'integer', MAKE_FIXNUM(0), @'*'); register_root(&TSnon_negative_integer); - TSpositive_number = list(2, @'satisfies', @'plusp'); + TSpositive_number = cl_list(2, @'satisfies', @'plusp'); register_root(&TSpositive_number); } diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index 0da778ccd..05f7e1063 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -181,7 +181,7 @@ truedirectory(cl_object pathname) } cl_object -truename(cl_object pathname) +cl_truename(cl_object pathname) { cl_object directory; cl_object truefilename; @@ -216,12 +216,10 @@ truename(cl_object pathname) switch (get_file_system_type(truefilename->string.self)) { case FILE_DOES_NOT_EXIST: FEerror("truename: file does not exist or cannot be accessed",1,pathname); - return OBJNULL; case FILE_DIRECTORY: FEerror("truename: ~A is a directory", 1, truefilename); - return OBJNULL; default: - return coerce_to_pathname(truefilename); + return1(cl_pathname(truefilename)); } } @@ -258,49 +256,50 @@ file_len(FILE *fp) return(filestatus.st_size); } -@(defun truename (file) -@ - /* INV: truename() checks type of file */ - @(return truename(file)) -@) - -@(defun rename_file (oldn newn) +cl_object +cl_rename_file(cl_object oldn, cl_object newn) +{ cl_object filename, newfilename, old_truename, new_truename; -@ + /* INV: coerce_to_file_pathname() checks types */ oldn = coerce_to_file_pathname(oldn); newn = coerce_to_file_pathname(newn); newn = merge_pathnames(newn, oldn, Cnil); - old_truename = truename(oldn); + old_truename = cl_truename(oldn); filename = coerce_to_filename(oldn); newfilename = coerce_to_filename(newn); if (rename(filename->string.self, newfilename->string.self) < 0) FEfilesystem_error("Cannot rename the file ~S to ~S.", 2, oldn, newn); - new_truename = truename(newn); + new_truename = cl_truename(newn); @(return newn old_truename new_truename) -@) +} -@(defun delete_file (file) +cl_object +cl_delete_file(cl_object file) +{ cl_object filename; -@ + /* INV: coerce_to_filename() checks types */ filename = coerce_to_filename(file); if (unlink(filename->string.self) < 0) FEfilesystem_error("Cannot delete the file ~S.", 1, file); @(return Ct) -@) +} -@(defun probe_file (file) -@ +cl_object +cl_probe_file(cl_object file) +{ /* INV: file_exists() and truename() check types */ - @(return (file_exists(file)? truename(file) : Cnil)) -@) + @(return (file_exists(file)? cl_truename(file) : Cnil)) +} -@(defun file_write_date (file) +cl_object +cl_file_write_date(cl_object file) +{ cl_object filename, time; struct stat filestatus; -@ + /* INV: coerce_to_filename() checks types */ filename = coerce_to_filename(file); if (stat(filename->string.self, &filestatus) < 0) @@ -308,16 +307,18 @@ file_len(FILE *fp) else time = UTC_time_to_universal_time(filestatus.st_mtime); @(return time) -@) +} -@(defun file_author (file) +cl_object +cl_file_author(cl_object file) +{ cl_object filename; struct stat filestatus; struct passwd *pwent; #ifndef __STDC__ extern struct passwd *getpwuid(uid_t); #endif -@ + /* INV: coerce_to_filename() checks types */ filename = coerce_to_filename(file); if (stat(filename->string.self, &filestatus) < 0) @@ -325,7 +326,7 @@ file_len(FILE *fp) file); pwent = getpwuid(filestatus.st_uid); @(return make_string_copy(pwent->pw_name)) -@) +} const char * expand_pathname(const char *name) @@ -368,7 +369,7 @@ homedir_pathname(cl_object user) if (Null(user)) pwent = getpwuid(getuid()); else { - user = coerce_to_string(user); + user = cl_string(user); p = user->string.self; i = user->string.fillp; if (i > 0 && *p == '~') { @@ -460,12 +461,13 @@ string_match(const char *s, const char *p) { return (*p == 0); } -@(defun si::string_match (s1 s2) -@ +cl_object +si_string_match(cl_object s1, cl_object s2) +{ assert_type_string(s1); assert_type_string(s2); @(return (string_match(s1->string.self, s2->string.self) ? Ct : Cnil)) -@) +} static cl_object actual_directory(cl_object namestring, cl_object mask, bool all) @@ -595,9 +597,11 @@ actual_directory(cl_object namestring, cl_object mask, bool all) @(return actual_directory(directory, mask, all)) @) -@(defun si::chdir (directory) +cl_object +si_chdir(cl_object directory) +{ cl_object filename, previous; -@ + /* INV: coerce_to_filename() checks types */ filename = coerce_to_filename(directory); previous = current_dir(); @@ -606,12 +610,14 @@ actual_directory(cl_object namestring, cl_object mask, bool all) 1, filename); } @(return previous) -@) +} -@(defun si::mkdir (directory mode) +cl_object +si_mkdir(cl_object directory, cl_object mode) +{ cl_object filename; int modeint; -@ + /* INV: coerce_to_filename() checks types */ filename = coerce_to_filename(directory); modeint = fixnnint(mode); @@ -620,7 +626,7 @@ actual_directory(cl_object namestring, cl_object mask, bool all) filename); } @(return filename) -@) +} #ifdef sun4sol2 /* These functions can't be used with static linking on Solaris */ diff --git a/src/c/unixint.d b/src/c/unixint.d index 0d2e170d5..8da59a300 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -28,8 +28,6 @@ int interrupt_flag; /* console interupt flag */ typedef void (*signalfn)(int); -static cl_object SVinterrupt_enable; - #ifndef THREADS static void @@ -52,8 +50,8 @@ sigint(void) signal(SIGINT, (signalfn)sigint); return; } - if (symbol_value(SVinterrupt_enable) == Cnil) { - SYM_VAL(SVinterrupt_enable) = Ct; + if (symbol_value(@'si::*interrupt-enable*') == Cnil) { + SYM_VAL(@'si::*interrupt-enable*') = Ct; signal(SIGINT, (signalfn)sigint); return; } @@ -85,8 +83,8 @@ sigint() return; } - if (symbol_value(SVinterrupt_enable) == Cnil) { - SVinterrupt_enable->symbol.dbind = Ct; + if (symbol_value(@'si::*interrupt-enable*') == Cnil) { + SYM_VAL(@'si::*interrupt-enable*') = Ct; return; } @@ -125,10 +123,13 @@ You should check the signal and exit from Lisp.", 1, } } -@(defun si::catch_bad_signals () -@ +cl_object +si_catch_bad_signals() +{ signal(SIGILL, (signalfn)signal_catcher); +#ifndef GBC_BOEHM signal(SIGBUS, (signalfn)signal_catcher); +#endif signal(SIGSEGV, (signalfn)signal_catcher); #ifdef SIGIOT signal(SIGIOT, (signalfn)signal_catcher); @@ -140,12 +141,15 @@ You should check the signal and exit from Lisp.", 1, signal(SIGSYS, (signalfn)signal_catcher); #endif @(return Ct) -@) +} -@(defun si::uncatch_bad_signals () -@ +cl_object +si_uncatch_bad_signals() +{ signal(SIGILL, SIG_DFL); +#ifndef GBC_BOEHM signal(SIGBUS, SIG_DFL); +#endif signal(SIGSEGV, SIG_DFL); #ifdef SIGIOT signal(SIGIOT, SIG_DFL); @@ -157,7 +161,7 @@ You should check the signal and exit from Lisp.", 1, signal(SIGSYS, SIG_DFL); #endif @(return Ct) -@) +} #endif /* unix */ void @@ -174,5 +178,5 @@ enable_interrupt(void) void init_interrupt(void) { - SVinterrupt_enable = make_si_special("*INTERRUPT-ENABLE*", Ct); + SYM_VAL(@'SI::*INTERRUPT-ENABLE*') = Ct; } diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 00a3821cd..6ab04d8ca 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -85,10 +85,12 @@ system(const char *command) #endif #endif -@(defun si::system (cmd) +cl_object +si_system(cl_object cmd) +{ volatile char *s; volatile int code; -@ + assert_type_string(cmd); s = cmd->string.self; code = system((const char *)s); @@ -97,12 +99,14 @@ system(const char *command) FEerror("Too long command line: ~S.", 1, cmd);*/ /* FIXME! This is a non portable way of getting the exit code */ @(return MAKE_FIXNUM(code >> 8)) -@) +} -@(defun si::open_pipe (cmd) +cl_object +si_open_pipe(cl_object cmd) +{ FILE *ptr; cl_object stream; -@ + assert_type_string(cmd); if ((ptr = popen(cmd->string.self, OPEN_R)) == NULL) @@ -117,4 +121,4 @@ system(const char *command) setbuf(ptr, stream->stream.buffer = cl_alloc_atomic(BUFSIZ)); #endif @(return stream) -@) +} diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 5eec1ad9c..04b726a32 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -105,6 +105,7 @@ strings." interactive-function) (defun restart-report (restart stream) + (declare (si::c-local)) (let ((fn (restart-report-function restart))) (if fn (funcall fn stream) @@ -213,6 +214,7 @@ strings." ;;; ---------------------------------------------------------------------- ;;; Condition Data Type +#+nil (defun condition-print (condition stream depth) (declare (ignore depth)) (if *print-escape* @@ -447,6 +449,7 @@ strings." ;;; by all the other routines. (defun coerce-to-condition (datum arguments default-type function-name) + (declare (si::c-local)) (cond ((typep datum 'CONDITION) (when arguments (cerror "Ignore the additional arguments." @@ -591,6 +594,7 @@ returns with NIL." (:REPORT (lambda (c s) (declare (ignore c)) (write-string "Abort failed." s)))) +#+nil (defun simple-condition-class-p (type) (typep type 'SIMPLE-CONDITION-CLASS)) diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index 126b17afb..55bf83094 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -54,6 +54,7 @@ :slots all-slots)))))) (defun collect-all-slots (slots name superclasses-names) + (declare (si::c-local)) (let* ((superclasses (mapcar #'find-class superclasses-names)) (cpl (compute-class-precedence-list name superclasses))) (collect-slotds cpl slots))) @@ -83,6 +84,7 @@ ;;; parsing (defun parse-defclass (args) + (declare (si::c-local)) (let (name superclasses slots options metaclass-name default-initargs documentation) (unless args @@ -156,6 +158,7 @@ shared-slots))))))) (defun generate-slot-accessors (name slotds shared-slotds) + (declare (si::c-local)) (when (plusp (length slotds)) (append (if (< (+ (length slotds) @@ -244,6 +247,7 @@ (defun generate-optional-slot-accessors (name slotds shared-slotds &optional optimized) + (declare (si::c-type)) (nconc ;; instance slots accessor methods (do ((scan slotds (cdr scan)) @@ -479,6 +483,7 @@ cpl)))) (defun walk-supers (supers cpl precedence-alist) + (declare (si::c-local)) (do* ((pre (reverse supers)) (sup) (precedence)) @@ -494,6 +499,7 @@ (setq cpl (adjoin sup cpl)))) (defun class-ordering-error (root element path precedence-alist) + (declare (si::c-local)) (setq path (cons element (reverse (member element (reverse path) :test #'eq)))) (flet ((pretty (class) (or (class-name class) class))) (let ((explanations ())) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index ef1d76f3e..5b859bbf3 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -13,6 +13,7 @@ ;;; Fixup (defun fix-early-methods () + (declare (si::c-local)) (dolist (method-info *early-methods*) (let* ((method-name (car method-info)) (gfun (symbol-function method-name)) @@ -43,6 +44,7 @@ function plist options gf-object 'STANDARD-METHOD)))))) + #-ecl-min (fmakunbound 'FIX-EARLY-METHODS) (makunbound '*EARLY-METHODS*)) @@ -146,12 +148,14 @@ ;;; method comparison (defun compare-methods (method-1 method-2 args-specializers) + (declare (si::c-local)) (let ((specializers-list-1 (specializers method-1)) (specializers-list-2 (specializers method-2))) (compare-specializers-lists specializers-list-1 specializers-list-2 args-specializers))) (defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers) + (declare (si::c-local)) (when (or spec-list-1 spec-list-2) (ecase (compare-specializers (first spec-list-1) (first spec-list-2) @@ -171,6 +175,7 @@ ) (defun compare-specializers (spec-1 spec-2 arg-spec) + (declare (si::c-local)) (let* ((arg-class (closest-class arg-spec)) (cpl (cons arg-class (if (typep arg-class 'STANDARD-CLASS) @@ -193,7 +198,8 @@ (t (compare-complex-specializers spec-1 spec-2 arg-spec))))) (defun compare-complex-specializers (spec-1 spec-2 arg-spec) - (declare (ignore spec-1 spec-2 arg-spec)) + (declare (ignore spec-1 spec-2 arg-spec) + (si::c-local)) (error "Complex type specifiers are not yet supported.")) (defun si:compute-effective-method (gf applicable-methods diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 663719b0d..4c5b2d3d3 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -10,10 +10,11 @@ (in-package "CLOS") (defun legal-generic-function-p (name) + (declare (si::c-local)) (cond ((not (fboundp name))) ; a generic function already exists ((si:gfunp (symbol-function name))) - ((special-form-p name) + ((special-operator-p name) (error "~A is a special form" name)) ((macro-function name) (error "~A is a macro" name)) @@ -96,6 +97,7 @@ ;;; parsing (defun parse-defgeneric (args) + (declare (si::c-local)) ;; (values function-specifier lambda-list options) (let (function-specifier) (unless args @@ -111,12 +113,14 @@ (values function-specifier (first args) (rest args)))) (defun parse-generic-function (args) + (declare (si::c-local)) ;; (values lambda-list options) (unless args (error "Illegal generic-function form: missing lambda-list")) (values (first args) (rest args))) (defun parse-generic-options (options lambda-list) + (declare (si::c-local)) (let (argument-precedence-order declaration documentation @@ -237,6 +241,7 @@ than once") ;;; ---------------------------------------------------------------------- ;;; congruence +#+nil (defun congruent-lambda-list-p (l1 l2) (let (post-keyword) (do ((scan1 l1 (cdr scan1)) @@ -273,6 +278,7 @@ than once") ;;; parsing (defun parse-lambda-list (lambda-list &optional post-keyword) + (declare (si::c-local)) (let ((arg (car lambda-list))) (cond ((null lambda-list)) ((eq arg '&AUX) @@ -288,6 +294,7 @@ than once") (parse-lambda-list (cdr lambda-list))))))) (defun parse-parameter-names (parameter-list lambda-list) + (declare (si::c-local)) (let (required-list count) (setf required-list (do ((l lambda-list (cdr l))) @@ -303,6 +310,7 @@ than once") option" l))))) (defun parse-legal-declaration (decl) + (declare (si::c-local)) (unless (eq (car decl) 'OPTIMIZE) (error "The only declaration allowed is optimize")) (do* ((d (cdr decl) (cdr d)) @@ -312,11 +320,13 @@ than once") (error "The only qualities allowed are speed and space")))) (defun parse-legal-documentation (doc) + (declare (si::c-local)) (unless (stringp doc) (error "The documentation must be a string")) doc) (defun parse-legal-method-combination (name args) + (declare (si::c-local)) (unless (method-combination-p name) (error "~A is not the name of a method-combination type" name)) (unless (legal-method-combination-args name args) @@ -325,6 +335,7 @@ than once") (values name args)) (defun legal-generic-function-classp (class-name) + (declare (si::c-local)) ; until we don't know when a class can be the class of a generic function (unless (subtypep (find-class class-name) (find-class 'GENERIC-FUNCTION)) @@ -333,9 +344,11 @@ than once") class-name) (defun parse-legal-method-class (class-name) + (declare (si::c-local)) ; until we don't know when a class can be the class of a method (error "At the moment the class of a method can be only standard-method")) (defun parse-legal-method-list (methods-list) + (declare (si::c-local)) methods-list) diff --git a/src/clos/inspect.lsp b/src/clos/inspect.lsp index 520c74041..0c524e76d 100644 --- a/src/clos/inspect.lsp +++ b/src/clos/inspect.lsp @@ -282,6 +282,7 @@ (terpri))))) (defun select-clos-? () + (declare (si::c-local)) (terpri) (format t "Inspect commands for clos instances:~%~ diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index fc915558e..f2508a80d 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -39,6 +39,7 @@ (defun search-make-instance (obj) + (declare (si::c-local)) (let* ((gfun (symbol-function (if (si::tracing-body 'make-instance) (get 'make-instance 'si::traced) 'make-instance))) @@ -57,6 +58,7 @@ t)) (defun metaclassp (obj) + (declare (si::c-local)) (and (si:instancep obj) (search-make-instance (si:instance-class obj)) (search-make-instance obj) @@ -74,7 +76,7 @@ (defun install-method (name qualifiers specializers lambda-list doc plist fun &rest options) (declare (ignore doc) - (notinline ensure-generic-function method-class)) + (notinline cos ensure-generic-function method-class)) ; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) (let* ((gf (ensure-generic-function name :lambda-list lambda-list)) (method (make-method qualifiers specializers lambda-list diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 41d8b8897..485804033 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -42,11 +42,9 @@ (parse-defmethod args) (multiple-value-bind (fn-form specializers doc plist) (expand-defmethod name qualifiers lambda-list body env) - (multiple-value-bind - (parameters specialized-lambda-list specializers) + (multiple-value-bind (parameters specialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list nil) (declare (ignore parameters)) - (walker::env-lexical-variables env) `(PROGN #+PDE (EVAL-WHEN @@ -71,7 +69,8 @@ (defun expand-defmethod (generic-function-name qualifiers specialized-lambda-list body env) ;; (values fn-form specializers doc) - (declare (ignore qualifiers)) + (declare (ignore qualifiers) + (si::c-local)) (multiple-value-bind (declarations real-body documentation) (sys::find-declarations body) (multiple-value-bind (parameters lambda-list specializers) @@ -290,6 +289,7 @@ aux-bindings call-next-method-p next-method-p-p) + (declare (si::c-local)) (cond ((and (null save-original-args) (null applyp)) ;; @@ -424,6 +424,7 @@ (or (symbolp name) (si:setf-namep name))) (defun parse-defmethod (args) + (declare (si::c-local)) ;; (values name qualifiers arglist body) (let (name qualifiers) (unless args @@ -444,6 +445,7 @@ (values name qualifiers (first args) (rest args)))) (defun parse-specialized-lambda-list (arglist warningp) + (declare (si::c-local)) ;; This function has been modified to get an easy control on the ;; correctness of the specialized-lambda-list. Furthermore it has became ;; an iterative function. @@ -519,6 +521,7 @@ (nreverse specializers)))) (defun declaration-specializers (arglist declarations) + (declare (si::c-local)) (do ((argscan arglist (cdr argscan)) (declist (when declarations (cdr declarations)))) ((or @@ -587,6 +590,7 @@ ) (defun update-method-key-hash-table (class lambda-list) + (declare (si::c-local)) (let (post-key-list keywords-list) ;; search &key in lambda-list (setq post-key-list @@ -697,6 +701,7 @@ ;;; optimizers (defun can-optimize-access (var env) + (declare (si::c-local)) ;; (values required-parameter class) (let ((required-parameter? (or (third (variable-declaration 'VARIABLE-REBINDING var env)) @@ -708,6 +713,7 @@ (defun optimize-standard-instance-access (class parameter form slots) + (declare (si::c-local)) ;; Returns an optimized form corresponding to FORM. ;; SLOTS is a list of: ;; (parameter [(class . class-index-table) {(slot-name . slot-index)}+]) @@ -752,9 +758,11 @@ ; (slotd-type (find slot (slot-value class 'SLOTS) :key #'slotd-name))) (defun signal-slot-unbound (instance slot-name) + (declare (si::c-local)) (slot-unbound (si:instance-class instance) instance slot-name)) (defun add-index-binding (method-body isl) + (declare (si::c-local)) (let (class-index-bindings slot-index-bindings slot-index-declarations) diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index c8149e24e..56e63715a 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -18,6 +18,7 @@ documentation) (defun PARSE-SLOT (slot) + (declare (si::c-local)) (let ((name nil) (initargs nil) (initform 'INITFORM-UNSUPPLIED) ; default @@ -75,6 +76,7 @@ (push (parse-slot (first scan)) collect))) (defun LEGAL-SLOT-OPTION-P (option) + (declare (si::c-local)) (member option '(:accessor :reader :writer :allocation :initarg :initform :type :documentation))) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index e53aa80f4..0c7f53c12 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -318,6 +318,7 @@ ;;; check-initargs (defun check-initargs (class initargs) + (declare (si::c-local)) ;; scan initarg list (do* ((name-loc initargs (cddr name-loc)) (name (first name-loc) (first name-loc))) diff --git a/src/clos/walk.lsp b/src/clos/walk.lsp index bcbca401c..e9f5a40d8 100644 --- a/src/clos/walk.lsp +++ b/src/clos/walk.lsp @@ -149,6 +149,7 @@ (push `(,(car m) macro ,(second m)) funs)) (cons vars funs))) +#+nil (defun environment-function (env fn) (when env (let ((entry (assoc fn (cdr env)))) @@ -157,6 +158,7 @@ (third entry))))) (defun environment-macro (env macro) + (declare (si::c-local)) (when env (let ((entry (assoc macro (cdr env)))) (and entry @@ -187,6 +189,7 @@ ,@body)))) (defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) + (declare (si::c-local)) (let ((gensym (make-symbol name))) (eval `(defmacro ,gensym ,llist ,@body)) (macro-function gensym))) @@ -210,12 +213,14 @@ (defvar *key-to-walker-environment* (gensym)) (defun env-lock (env) + (declare (si::c-local)) (environment-macro env *key-to-walker-environment*)) (defun walker-environment-bind-1 (env &key (walk-function nil wfnp) (walk-form nil wfop) (declarations nil decp) (lexical-variables nil lexp)) + (declare (si::c-local)) (let ((lock (env-lock env))) (list (list *key-to-walker-environment* @@ -225,25 +230,31 @@ (if lexp lexical-variables (fourth lock))))))) (defun env-walk-function (env) + (declare (si::c-local)) (first (env-lock env))) (defun env-walk-form (env) + (declare (si::c-local)) (second (env-lock env))) (defun env-declarations (env) + (declare (si::c-local)) (third (env-lock env))) (defun env-lexical-variables (env) + (declare (si::c-local)) (fourth (env-lock env))) (defun note-declaration (declaration env) + (declare (si::c-local)) (push declaration (third (env-lock env)))) (defun note-lexical-binding (thing env) (push #+NEW (list thing :LEXICAL-VAR) #-NEW thing (fourth (env-lock env)))) (defun VARIABLE-LEXICAL-P (var env) + (declare (si::c-local)) #+NEW (let ((entry (member var (env-lexical-variables env) :key #'car))) (when (eq (cadar entry) :LEXICAL-VAR) @@ -253,6 +264,7 @@ #+NEW (defun variable-symbol-macro-p (var env) + (declare (si::c-local)) (let ((entry (member var (env-lexical-variables env) :key #'car))) (when (eq (cadar entry) :macro) entry))) @@ -260,6 +272,7 @@ (defvar *VARIABLE-DECLARATIONS* '(SPECIAL TYPE)) ; Beppe (defun VARIABLE-DECLARATION (declaration var env) + (declare (si::c-local)) (if (not (member declaration *variable-declarations*)) (error "~S is not a recognized variable declaration." declaration) (let ((id (or (variable-lexical-p var env) var))) @@ -271,6 +284,7 @@ (return decl)))))) (defun VARIABLE-SPECIAL-P (var env) + (declare (si::c-local)) (or (not (null (variable-declaration 'SPECIAL var env))) (variable-globally-special-p var))) @@ -583,7 +597,7 @@ (walk-form-internal newnewform context env)) ((and (symbolp fn) (not (fboundp fn)) - (special-form-p fn)) + (special-operator-p fn)) (error "~S is a special form, not defined in the CommonLisp.~%~ manual This code walker doesn't know how to walk it.~%~ @@ -597,6 +611,7 @@ newnewform '(CALL REPEAT (EVAL)) context env)))))))))) (defun walk-template (form template context env) + (declare (si::c-local)) (if (atom template) (ecase template ((EVAL FUNCTION TEST EFFECT RETURN) @@ -645,6 +660,7 @@ (cdr form) (cdr template) context env)))))))) (defun walk-template-handle-repeat (form template stop-form context env) + (declare (si::c-local)) (if (eq form stop-form) (walk-template form (cdr template) context env) (walk-template-handle-repeat-1 form @@ -656,6 +672,7 @@ (defun walk-template-handle-repeat-1 (form template repeat-template stop-form context env) + (declare (si::c-local)) (cond ((null form) ()) ((eq form stop-form) (if (null repeat-template) @@ -682,20 +699,24 @@ (walk-repeat-eval (cdr form) env)))) (defun recons (x car cdr) + (declare (si::c-local)) (if (or (not (eq (car x) car)) (not (eq (cdr x) cdr))) (cons car cdr) x)) (defun relist (x &rest args) + (declare (si::c-local)) (if (null args) nil (relist-internal x args nil))) (defun relist* (x &rest args) + (declare (si::c-local)) (relist-internal x args 'T)) (defun relist-internal (x args *p) + (declare (si::c-local)) (if (null (cdr args)) (if *p (car args) (recons x (car args) nil)) (recons x @@ -710,6 +731,7 @@ (defun walk-declarations (body fn env &optional doc-string-p declarations old-body &aux (form (car body)) macrop new-form) + (declare (si::c-local)) (cond ((and (stringp form) ;might be a doc string (cdr body) ;isn't the returned value (null doc-string-p) ;no doc string yet @@ -755,13 +777,15 @@ (defun walk-unexpected-declare (form context env) - (declare (ignore context env)) + (declare (ignore context env) + (si::c-local)) (warn "Encountered declare ~S in a place where a declare was not expected." form) form) (defun walk-arglist (arglist context env &optional (destructuringp nil) &aux arg) + (declare (si::c-local)) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) (or (member arg lambda-list-keywords) @@ -966,6 +990,7 @@ sequentialp))))) (defun walk-bindings-2 (bindings walked-bindings context env) + (declare (si::c-local)) (and bindings (let ((binding (car bindings)) (walked-binding (car walked-bindings))) @@ -1054,6 +1079,7 @@ (recons form (car form) (walk-tagbody-1 (cdr form) context env))) (defun walk-tagbody-1 (form context env) + (declare (si::c-local)) (and form (recons form (walk-form-internal (car form) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index dfff07a8f..6dba8202f 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -257,7 +257,7 @@ ;;; NARG is a location containing the number of ARGS-PUSHED ;;; LOC is either NIL or the location of the function object ;;; -(defun call-global (fname locs loc return-type narg &aux fd) +(defun call-global (fname locs loc return-type narg &aux found fd maxarg) (flet ((emit-linking-call (fname locs narg &aux i) (cond ((null *linking-calls*) (cmpwarn "Emitting linking call for ~a" fname) @@ -292,9 +292,8 @@ ;; Call to a function whose C language function name is known, ;; either because it has been proclaimed so, or because it belongs ;; to the runtime. - ((or (setq fd (get fname 'Lfun)) - (and (car (setq fd (multiple-value-list (si::mangle-name fname t)))) - (setq fd (cadr fd)))) + ((or (setq maxarg -1 fd (get fname 'Lfun)) + (multiple-value-setq (found fd maxarg) (si::mangle-name fname t))) (multiple-value-bind (val found) (gethash fd *compiler-declared-globals*) ;; We only write declarations for functions which are not @@ -302,7 +301,10 @@ (when (and (not found) (not (si::mangle-name fname t))) (wt-h "extern cl_object " fd "();") (setf (gethash fd *compiler-declared-globals*) 1))) - (unwind-exit (call-loc fname fd locs narg))) + (unwind-exit + (if (minusp maxarg) + (call-loc fname fd locs narg) + (call-loc-fixed fname fd locs narg maxarg)))) ;; Linking call (*compile-to-linking-call* ; disabled within init_code @@ -347,6 +349,17 @@ (t (list 'CALL "cl_apply_from_stack" narg-loc (list fun) fname)))) +(defun call-loc-fixed (fname fun args narg-loc maxarg) + (cond ((not (eq 'ARGS-PUSHED args)) + (when (/= (length args) maxarg) + (error "Too many arguments to function ~S." fname)) + (list 'CALL-FIX fun (coerce-locs args nil) fname)) + ((stringp fun) + (wt "if(" narg-loc "!=" maxarg ") check_arg_failed(" narg-loc "," maxarg ");") + (list 'CALL-FIX "APPLY_fixed" (list fun `(STACK-POINTER ,narg-loc)) fname narg-loc)) + (t + (baboon)))) + (defun wt-stack-pointer (narg) (wt "cl_stack_top-" narg)) @@ -357,6 +370,15 @@ (wt ")") (when fname (wt-comment fname))) +(defun wt-call-fix (fun args &optional fname) + (wt fun "(") + (when args + (wt (pop args)) + (dolist (arg args) + (wt "," arg))) + (wt ")") + (when fname (wt-comment fname))) + ;;; ;;; c2call-unknown-global ;;; LOC is NIL or location containing function @@ -384,4 +406,5 @@ (setf (get 'call-global 'c2) #'c2call-global) (setf (get 'CALL 'WT-LOC) #'wt-call) +(setf (get 'CALL-FIX 'WT-LOC) #'wt-call-fix) (setf (get 'STACK-POINTER 'WT-LOC) #'wt-stack-pointer) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 9111d705a..26c652f9b 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -345,8 +345,8 @@ The default value is NIL.") (defvar *non-package-operation* nil) -(defvar *objects* nil) ; holds { ( object vv-index ) }* -(defvar *constants* nil) ; holds { ( symbol vv-index ) }* +(defvar *objects* nil) ; holds { ( object text vv-index ) }* +(defvar *keywords* nil) ; holds { ( key-list text vv-index ) }* (defvar *load-time-values* nil) ; holds { ( vv-index form ) }*, ;;; where each vv-index should be given an object before ;;; defining the current function during loading process. diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 8a12dd83e..6d046a864 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -24,7 +24,7 @@ (setq *next-cfun* 0) (setq *last-label* 0) (setq *objects* nil) - (setq *constants* nil) + (setq *keywords* nil) (setq *local-funs* nil) (setq *global-funs* nil) (setq *linking-calls* nil) @@ -64,23 +64,55 @@ (defun add-symbol (symbol) (add-object symbol)) -(defun add-keyword (symbol &aux x) - (incf *next-vv*) - (setq x (format nil "VV[~d]" *next-vv*)) - (push (list symbol x) *objects*) - (wt-data symbol) - x) +#+nil +(defun add-keywords (keywords) + ;; We have to build, in the vector VV[], a sequence with all + ;; the keywords that this function uses. It does not matter + ;; whether the same keywords appeared before, because + ;; cl_parse_key() needs the whole list. However, we can optimize + ;; the case of a single keyword, reusing the value of a previous + ;; occurrence. + (let ((x (assoc keywords *keywords* :test #'equalp))) + (cond (x + (second x)) + ((and (setq x (assoc (first keywords) *objects*)) + (= (length keywords) 1)) + (second x)) + (t + (flet ((add-keyword (keyword) + (let ((x (format nil "VV[~d]" (incf *next-vv*)))) + (push (list keyword x *next-vv*) *objects*) + (wt-data keyword) + x))) + (setq x (add-keyword (first keywords))) + (dolist (k keywords) + (add-keyword k)) + x))))) + +(defun add-keywords (keywords) + (flet ((add-keyword (keyword &aux x) + (incf *next-vv*) + (setq x (format nil "VV[~d]" *next-vv*)) + (let ((y (assoc keyword *objects*))) + (if y + (wt-filtered-data (format nil "#!~d" (- (1+ (third y))))) + (wt-data keyword))) + (push (list keyword x *next-vv*) *objects*) + x)) + (let ((x (add-keyword (first keywords)))) + (dolist (k (rest keywords)) + (add-keyword k)) + x))) (defun add-object (object &aux x found) - ;;; Used only during Pass 1. - (cond ((setq x (assoc object *objects*)) + (cond ((setq x (assoc object *objects* :test 'equalp)) (second x)) ((and (symbolp object) (multiple-value-setq (found x) (si::mangle-name object))) x) (t (incf *next-vv*) (setq x (format nil "VV[~d]" *next-vv*)) - (push (list object x) *objects*) + (push (list object x *next-vv*) *objects*) (wt-data object) x))) @@ -429,6 +461,7 @@ (pushnew x *alien-declarations*) (warn "The declaration specifier ~s is not a symbol." x)))) + (SI::C-LOCAL) (otherwise (unless (member (car decl) *alien-declarations*) (warn "The declaration specifier ~s is unknown." diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index ab1fd10b6..0debd4993 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -317,7 +317,7 @@ (if *safe-compile* (progn (wt-nl "{cl_object l= ") - (dotimes (i index) (declare (fixnum i)) (wt "cdr(")) + (dotimes (i index) (declare (fixnum i)) (wt "cl_cdr(")) (wt (car args)) (dotimes (i index)(declare (fixnum i)) (wt ")")) (wt ";") @@ -350,7 +350,7 @@ (wt-nl "{cl_object ") (wt-lcl l) (wt "= ") (if *safe-compile* (progn - (dotimes (i index) (declare (fixnum i)) (wt "cdr(")) + (dotimes (i index) (declare (fixnum i)) (wt "cl_cdr(")) (wt (car args)) (dotimes (i index) (declare (fixnum i)) (wt ")")) (wt ";") diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 1d4407103..5cc56a37b 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -251,7 +251,7 @@ (unless (null loc) (cond ((eq loc t)) ((atom loc) - (wt-nl "if(" loc ")")) + (wt-nl "if((" loc ")!=Cnil)")) ((eq (car loc) 'INLINE-COND) (wt-nl "if(") (wt-inline-loc (third loc) (fourth loc)) @@ -268,7 +268,7 @@ (unless (eq loc t) (cond ((null loc)) ((atom loc) - (wt-nl "if(" loc ")")) + (wt-nl "if((" loc ")==Cnil)")) ((eq (car loc) 'INLINE-COND) (wt-nl "if(!(") (wt-inline-loc (third loc) (fourth loc)) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 931ecbd12..06f1295be 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -527,14 +527,14 @@ (otherwise (return t))))) (defun list-inline (&rest x) - (wt "list(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\))) + (wt "cl_list(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\))) (defun list*-inline (&rest x) (case (length x) (1 (wt (car x))) (2 (wt "make_cons(" (car x) "," (second x) ")")) (otherwise - (wt "listX(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\))))) + (wt "cl_listX(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\))))) ;;; ---------------------------------------------------------------------- diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index d8ab5b64f..651df857c 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -554,9 +554,9 @@ (wt-nl "narg -= i;") (wt-nl "narg -=" nreq ";")) - (wt-h "#define L" cfun "keys (&" (add-keyword (caar keywords)) ")") - (dolist (kwd (rest keywords)) - (add-keyword (first kwd))) + (wt-h "#define L" cfun "keys (&" + (add-keywords (mapcar #'car keywords)) + ")") (wt-nl "{ cl_object keyvars[" (* 2 nkey) "];") (wt-nl "cl_parse_key(args," (length keywords) ",L" cfun "keys,keyvars") diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index bdbb6d4cf..f32f19a8a 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -64,7 +64,7 @@ (defun set-loc (loc &aux fd (is-call (and (consp loc) - (member (car loc) '(CALL CALL-LOCAL) + (member (car loc) '(CALL CALL-LOCAL CALL-FIX) :test #'eq)))) (case *destination* (VALUES diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 7a0df67dd..3e110a8fb 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -468,22 +468,15 @@ Cannot compile ~a." &aux def disassembled-form (*compiler-in-use* *compiler-in-use*) (*print-pretty* nil)) + (when (or (symbolp thing) (si::setf-namep thing)) + (setq thing (eval `(function ,thing)))) (cond ((null thing)) - ((symbolp thing) - (setq def (symbol-function thing)) - (when (macro-function thing) - (setq def (cdr def))) - (return-from disassemble (disassemble def))) ((functionp thing) - (if (setq def (si::compiled-function-source thing)) - (setq disassembled-form - `(defun ,(or (si::compiled-function-name thing) - GAZONK) - ,@def)) + (unless (si::bc-disassemble thing) (error "The function definition for ~S was lost." thing))) ((and (consp thing) (eq (car thing) 'LAMBDA)) (setq disassembled-form `(defun gazonk ,@(cdr thing)))) - (t (setq disassembled-form thing))) + (t (setq disassembled-form thing))) (when *compiler-in-use* (format t "~&;;; The compiler was called recursively.~ diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 185953b97..868403d41 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -156,7 +156,7 @@ (wt "}")) (unless (eq *exit* 'RETURN) (wt-nl)) (wt-nl "if (NValues>1) NValues=1;}") - (unwind-exit 'VALUES))) + (unwind-exit (if vrefs (caar vrefs) '(VALUE 0))))) (defun c1multiple-value-bind (args &aux (info (make-info)) (vars nil) (vnames nil) init-form diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 2a8e788fe..26a0894bf 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -170,8 +170,8 @@ (defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) (declare (type fun fun)) (if (fun-closure fun) - (wt "make_cclosure((cl_objectfn)LC" cfun ",env" *env-lvl*) - (wt "make_cfun((cl_objectfn)LC" cfun ",Cnil")) ; empty environment + (wt "cl_make_cclosure_va((cl_objectfn)LC" cfun ",env" *env-lvl*) + (wt "cl_make_cfun_va((cl_objectfn)LC" cfun ",Cnil")) ; empty environment (wt ",Cblock)")) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index c0b713d72..d76ceca8f 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -237,17 +237,21 @@ (let* (lambda-expr (fname (car args)) (cfun (exported-fname fname)) + (no-entry nil) (doc nil) output) (setq lambda-expr (c1lambda-expr (cdr args) fname)) (unless (eql setjmps *setjmps*) (setf (info-volatile (second lambda-expr)) t)) - (when (and (setq doc (fourth lambda-expr)) - (setq doc (si::expand-set-documentation fname 'function doc))) - (t1expr `(progn ,@doc))) + (multiple-value-bind (decl body doc) + (si::process-declarations (cddr args) nil) + (cond ((assoc 'si::c-local decl) + (setq no-entry t)) + ((setq doc (si::expand-set-documentation fname 'function doc)) + (t1expr `(progn ,@doc))))) (add-load-time-values) - (setq output (new-defun fname cfun lambda-expr *special-binding*)) + (setq output (new-defun fname cfun lambda-expr *special-binding* no-entry)) (when (and (get fname 'PROCLAIMED-FUNCTION) @@ -282,7 +286,7 @@ output)) ;;; Mechanism for sharing code: -(defun new-defun (fname cfun lambda-expr special-binding) +(defun new-defun (fname cfun lambda-expr special-binding &optional no-entry) (let ((previous (dolist (form *global-funs*) (when (and (eq 'DEFUN (car form)) (equal special-binding (fifth form)) @@ -291,9 +295,10 @@ (if previous (progn (cmpnote "Sharing code for function ~A" fname) - (list 'DEFUN fname previous nil special-binding *funarg-vars*)) + (list 'DEFUN fname previous nil special-binding *funarg-vars* + no-entry)) (let ((fun-desc (list fname cfun lambda-expr special-binding - *funarg-vars*))) + *funarg-vars* no-entry))) (push fun-desc *global-funs*) (cons 'DEFUN fun-desc))))) @@ -331,19 +336,18 @@ "register " "")) -(defun t2defun (fname cfun lambda-expr sp funarg-vars - &aux (vv (add-symbol fname)) - (nkey (length (fifth (third lambda-expr))))) +(defun t2defun (fname cfun lambda-expr sp funarg-vars no-entry) (declare (ignore sp funarg-vars)) - (when (get fname 'NO-GLOBAL-ENTRY) (return-from t2defun nil)) - (if (numberp cfun) - (wt-nl "MF(" vv ",(cl_objectfn)L" cfun ",Cblock);") - (wt-nl "MF(" vv ",(cl_objectfn)" cfun ",Cblock);")) - (when (get fname 'PROCLAIMED-FUNCTION) - (wt-if-proclaimed fname cfun vv lambda-expr)) -) + (if no-entry + (return-from t2defun nil)) + (let ((vv (add-symbol fname))) + (if (numberp cfun) + (wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)L" cfun ");") + (wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)" cfun ");")) + (when (get fname 'PROCLAIMED-FUNCTION) + (wt-if-proclaimed fname cfun vv lambda-expr)))) -(defun t3defun (fname cfun lambda-expr sp funarg-vars +(defun t3defun (fname cfun lambda-expr sp funarg-vars no-entry &aux inline-info lambda-list requireds (*current-form* (list 'DEFUN fname)) (*volatile* (when lambda-expr @@ -587,7 +591,7 @@ (wt-nl "(void)putprop(" vv "," ppn ",siSpretty_print_format);") (wt-nl))) (wt-h "static cl_object L" cfun "();") - (wt-nl "MM(" vv ",(cl_objectfn)L" cfun ",Cblock);")) + (wt-nl "cl_def_c_macro_va(" vv ",(cl_objectfn)L" cfun ");")) (defun t3defmacro (fname cfun macro-lambda ppn sp &aux (*lcl* 0) (*temp* 0) (*max-temp* 0) @@ -662,13 +666,13 @@ :loc (add-symbol name)) form)))) (defun t2defvar (var form &aux (vv (var-loc var))) - (wt-nl vv "->symbol.stype=(short)stp_special;") - (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) - (*destination* (list 'VAR var))) - (wt-nl "if(" vv "->symbol.dbind == OBJNULL){") + (let* ((*exit* (next-label)) + (*unwind-exit* (list *exit*)) + (*temp* *temp*) + (*destination* `(TEMP ,(next-temp)))) (c2expr form) - (wt "}") - (wt-label *exit*))) + (wt-nl "cl_defvar(" vv "," *destination* ");") + (wt-label *exit*))) (defun t1decl-body (decls body) (if (null decls) @@ -858,7 +862,7 @@ &aux (vv (add-symbol fname))) (declare (ignore arg-types type body)) (wt-h "static cl_object L" cfun "();") - (wt-nl "MF(" vv ",(cl_objectfn)L" cfun ",Cblock);") + (wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)L" cfun ");") ) (eval-when (compile eval) ; also in cmpinline.lsp @@ -947,7 +951,7 @@ (let ((previous (new-local *level* fun funob))) (if (and previous (fun-var previous)) (setf (fun-var fun) (fun-var previous)) - (let ((loc (progn (wt-data nil) `(VV ,(incf *next-vv*))))) + (let ((loc (progn (wt-data 0) `(VV ,(incf *next-vv*))))) (wt-nl loc " = ") (wt-make-closure fun) (wt ";") (setf (fun-var fun) loc)))) ) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 7eec7a584..1a9766430 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -240,7 +240,7 @@ (SPECIAL (wt-nl "(" var-loc "->symbol.dbind)= " loc ";")) (GLOBAL (if *safe-compile* - (wt-nl "set(" var-loc "," loc ");") + (wt-nl "cl_set(" var-loc "," loc ");") (wt-nl "(" var-loc "->symbol.dbind)= " loc ";"))) (t (wt-nl) (wt-lcl var-loc) (wt "= ") diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 66c36a199..8fc5910d5 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -44,10 +44,6 @@ &rest optimizers) ;; The value NIL for each parameter except for fname means "not known". ;; optimizers is a list of alternating {safety inline-info}* as above. - (multiple-value-bind (found name) - (si::mangle-name fname t) - (when found - (setf (get fname 'Lfun) name))) (when arg-types (setf (get fname 'arg-types) (mapcar #'(lambda (x) (if (eql x '*) '* (type-filter x))) @@ -353,94 +349,64 @@ ; file list.d (CAR (T) T NIL NIL - :inline-safe ((t) t nil nil "car(#0)") :inline-unsafe ((t) t nil nil "CAR(#0)")) (CDR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdr(#0)") :inline-unsafe ((t) t nil nil "CDR(#0)")) (CAAR (T) T NIL NIL - :inline-safe ((t) t nil nil "caar(#0)") :inline-unsafe ((t) t nil nil "CAAR(#0)")) (CADR (T) T NIL NIL - :inline-safe ((t) t nil nil "cadr(#0)") :inline-unsafe ((t) t nil nil "CADR(#0)")) (CDAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdar(#0)") :inline-unsafe ((t) t nil nil "CDAR(#0)")) (CDDR (T) T NIL NIL - :inline-safe ((t) t nil nil "cddr(#0)") :inline-unsafe ((t) t nil nil "CDDR(#0)")) (CAAAR (T) T NIL NIL - :inline-safe ((t) t nil nil "caaar(#0)") :inline-unsafe ((t) t nil nil "CAAAR(#0)")) (CAADR (T) T NIL NIL - :inline-safe ((t) t nil nil "caadr(#0)") :inline-unsafe ((t) t nil nil "CAADR(#0)")) (CADAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cadar(#0)") :inline-unsafe ((t) t nil nil "CADAR(#0)")) (CADDR (T) T NIL NIL - :inline-safe ((t) t nil nil "caddr(#0)") :inline-unsafe ((t) t nil nil "CADDR(#0)")) (CDAAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdaar(#0)") :inline-unsafe ((t) t nil nil "CDAAR(#0)")) (CDADR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdadr(#0)") :inline-unsafe ((t) t nil nil "CDADR(#0)")) (CDDAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cddar(#0)") :inline-unsafe ((t) t nil nil "CDDAR(#0)")) (CDDDR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdddr(#0)") :inline-unsafe ((t) t nil nil "CDDDR(#0)")) (CAAAAR (T) T NIL NIL - :inline-safe ((t) t nil nil "caaaar(#0)") :inline-unsafe ((t) t nil nil "CAAAAR(#0)")) (CAAADR (T) T NIL NIL - :inline-safe ((t) t nil nil "caaadr(#0)") :inline-unsafe ((t) t nil nil "CAAADR(#0)")) (CAADAR (T) T NIL NIL - :inline-safe ((t) t nil nil "caadar(#0)") :inline-unsafe ((t) t nil nil "CAADAR(#0)")) (CAADDR (T) T NIL NIL - :inline-safe ((t) t nil nil "caaddr(#0)") :inline-unsafe ((t) t nil nil "CAADDR(#0)")) (CADAAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cadaar(#0)") :inline-unsafe ((t) t nil nil "CADAAR(#0)")) (CADADR (T) T NIL NIL - :inline-safe ((t) t nil nil "cadadr(#0)") :inline-unsafe ((t) t nil nil "CADADR(#0)")) (CADDAR (T) T NIL NIL - :inline-safe ((t) t nil nil "caddar(#0)") :inline-unsafe ((t) t nil nil "CADDAR(#0)")) (CADDDR (T) T NIL NIL - :inline-safe ((t) t nil nil "cadddr(#0)") :inline-unsafe ((t) t nil nil "CADDDR(#0)")) (CDAAAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdaaar(#0)") :inline-unsafe ((t) t nil nil "CDAAAR(#0)")) (CDAADR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdaadr(#0)") :inline-unsafe ((t) t nil nil "CDAADR(#0)")) (CDADAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdadar(#0)") :inline-unsafe ((t) t nil nil "CDADAR(#0)")) (CDADDR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdaddr(#0)") :inline-unsafe ((t) t nil nil "CDADDR(#0)")) (CDDAAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cddaar(#0)") :inline-unsafe ((t) t nil nil "CDDAAR(#0)")) (CDDADR (T) T NIL NIL - :inline-safe ((t) t nil nil "cddadr(#0)") :inline-unsafe ((t) t nil nil "CDDADR(#0)")) (CDDDAR (T) T NIL NIL - :inline-safe ((t) t nil nil "cdddar(#0)") :inline-unsafe ((t) t nil nil "CDDDAR(#0)")) (CDDDDR (T) T NIL NIL - :inline-safe ((t) t nil nil "cddddr(#0)") :inline-unsafe ((t) t nil nil "CDDDDR(#0)")) (CONS (T T) T NIL NIL :inline-always ((t t) t nil t "CONS(#0,#1)")) @@ -455,16 +421,16 @@ :inline-unsafe ((t t) t nil nil "nth(fix(#0),#1)") :inline-unsafe ((fixnum t) t nil nil "nth(#0,#1)")) (FIRST (T) T NIL NIL - :inline-safe ((t) t nil nil "car(#0)") + :inline-safe ((t) t nil nil "cl_car(#0)") :inline-unsafe ((t) t nil nil "CAR(#0)")) (SECOND (T) T nil nil - :inline-safe ((t) t nil nil "cadr(#0)") + :inline-safe ((t) t nil nil "cl_cadr(#0)") :inline-unsafe ((t) t nil nil "CADR(#0)")) (THIRD (T) T nil nil - :inline-safe ((t) t nil nil "caddr(#0)") + :inline-safe ((t) t nil nil "cl_caddr(#0)") :inline-unsafe ((t) t nil nil "CADDR(#0)")) (FOURTH (T) T nil nil - :inline-safe ((t) t nil nil "cadddr(#0)") + :inline-safe ((t) t nil nil "cl_cadddr(#0)") :inline-unsafe ((t) t nil nil "CADDDR(#0)")) (FIFTH (T) T) (SIXTH (T) T) @@ -473,7 +439,7 @@ (NINTH (T) T) (TENTH (T) T) (REST (T) T NIL NIL - :inline-safe ((t) t nil nil "cdr(#0)") + :inline-safe ((t) t nil nil "cl_cdr(#0)") :inline-unsafe ((t) t nil nil "CDR(#0)")) (NTHCDR (fixnum t) T nil nil :inline-always ((t t) t nil nil "nthcdr(fixint(#0),#1)") @@ -705,9 +671,9 @@ (RANDOM (T *) T) (MAKE-RANDOM-STATE (*) T) (RANDOM-STATE-P (T) T NIL T) -(EXP (T) T NIL NIL :inline-always ((number) t nil t "number_exp(#0)")) +(EXP (T) T NIL NIL :inline-always ((number) t nil t "cl_exp(#0)")) (EXPT (T T) T NIL NIL - :inline-always ((t t) t nil t "number_expt(#0,#1)") + :inline-always ((t t) t nil t "cl_expt(#0,#1)") :inline-always ((fixnum fixnum) fixnum nil nil (lambda (loc1 loc2) (if (and (consp loc1) (eq (car loc1) 'fixnum) @@ -917,10 +883,8 @@ type_of(#0)==t_bitvector")) :inline-always ((t) fixnum nil nil "length(#0)") :inline-unsafe (((array t)) fixnum nil nil "(#0)->vector.fillp") :inline-unsafe ((string) fixnum nil nil "(#0)->string.fillp")) -(REVERSE (sequence) sequence nil nil - :inline-always ((t) t nil t "reverse(#0)")) -(NREVERSE (sequence) sequence nil nil - :inline-always ((t) t t t "nreverse(#0)")) +(REVERSE (sequence) sequence nil nil) +(NREVERSE (sequence) sequence nil nil) ; file character.d (CHAR (string fixnum) character nil nil @@ -976,8 +940,7 @@ type_of(#0)==t_bitvector")) (NSTRING-UPCASE (string *) string) (NSTRING-DOWNCASE (string *) string) (NSTRING-CAPITALIZE (string *) string) -(STRING (T) string nil t - :inline-always ((t) t nil nil "coerce_to_string(#0)")) +(STRING (T) string nil t) (STRING-CONCATENATE (T) string nil nil) ; file structure.d @@ -1045,8 +1008,7 @@ type_of(#0)==t_bitvector")) (si::GET-LOCAL-TIME-ZONE nil T) (SLEEP (real) T) -(TYPE-OF (T) T NIL NIL - :inline-always ((t) t nil t "TYPE_OF(#0)")) +(TYPE-OF (T) T NIL NIL) ;;; Beppe's additions (READ-BYTES (stream vector fixnum fixnum) T) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index b96d00c70..2b1a3042f 100644 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -3,6 +3,11 @@ ;;; (load "bare.lsp") +;;; +;;; Trick to make names shorter +;;; +(rename-package "CL" "CL" '("COMMON-LISP" "LISP")) + ;;; ;;; * Compile, load and link Common-Lisp base library ;;; diff --git a/src/configure b/src/configure index 4d0009152..78e55fb7b 100755 --- a/src/configure +++ b/src/configure @@ -841,6 +841,7 @@ Optional Features: --enable-clx Include CLX. --enable-local-boehm Use already installed Boehm GC library. --enable-local-gmp Use already installed GMP library. +--enable-threads Include the multiple thread facility. --disable-shared Enable building dynamically loadable extensions. --enable-cxx Build ECL using C++ compiler @@ -1224,7 +1225,7 @@ echo "***" exit 2; fi -ECL_VERSION=0.7 +ECL_VERSION=0.7b ac_aux_dir= @@ -1349,6 +1350,11 @@ if test "${with_gmp+set}" = set; then else gmp_flags="" fi; +# Check whether --enable-threads or --disable-threads was given. +if test "${enable_threads+set}" = set; then + enableval="$enable_threads" + threads="$enable_threads" +fi; # Check whether --enable-shared or --disable-shared was given. if test "${enable_shared+set}" = set; then enableval="$enable_shared" @@ -3795,7 +3801,7 @@ configure___software_version=SOFTWARE_VERSION CPP=`eval "echo $CPP"` eval `${CPP} -D${host} ${tempcname} \ | grep 'configure___' \ - | sed -e 's/^configure___\([^=]*=\)[ ]*\(.*[^ ]\) */\1"\2"/'` + | sed -e 's/^configure___\([^=]*\)=[ ]*\(.*[^ ]\) */\1="$\1 \2"/'` rm ${tempcname} echo "$as_me:$LINENO: checking for ld flags when building shared libraries" >&5 @@ -3833,7 +3839,6 @@ libdir="${exec_prefix}/lib/ecl" includedir="${exec_prefix}/lib/ecl/h" mandir="${prefix}/man/man1" infodir="${prefix}/info" -builddir=`pwd` TARGETS="ecl${EXEEXT}" LIBRARIES="libecl.a" LSP_LIBRARIES="liblsp.a libclos.a" @@ -3919,12 +3924,19 @@ if test "${locative}" ; then _ACEOF fi +echo "$as_me:$LINENO: checking Checking for threads support" >&5 +echo $ECHO_N "checking Checking for threads support... $ECHO_C" >&6 if test "${threads}" ; then EXTRA_OBJS="${EXTRA_OBJS} lwp.o" cat >>confdefs.h <<\_ACEOF #define THREADS 1 _ACEOF + echo "$as_me:$LINENO: result: userland threads" >&5 +echo "${ECHO_T}userland threads" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi if test ${usecxx} = "no" ; then ECL_CC="${CC}" @@ -5565,10 +5577,10 @@ else echo "${ECHO_T}configuring local copy" >&6 test -d gmp && rm -rf gmp if mkdir gmp; then - (cd gmp; + (destdir=`pwd`; cd gmp; $srcdir/gmp/configure --disable-shared --prefix=$bindir \ - --infodir=${builddir}/doc --includedir=${builddir}/h \ - --libdir=${builddir} $gmp_flags) + --infodir=${destdir}/doc --includedir=${destdir}/h \ + --libdir=${destdir} $gmp_flags) fi fi echo "$as_me:$LINENO: checking checking for Boehm-Weiser gc..." >&5 @@ -5581,15 +5593,18 @@ elif test "${local_boehm}" = "no" ; then echo "${ECHO_T}configuring local copy" >&6 test -d gc && rm -rf gc if mkdir gc; then - (cd gc; + (destdir=`pwd`; cd gc; $srcdir/gc/configure --disable-threads --disable-shared --prefix=$bindir \ - --includedir=${builddir}/h --libdir=${builddir}) + --includedir=${destdir}/h --libdir=${destdir}) fi else echo "$as_me:$LINENO: result: already installed" >&5 echo "${ECHO_T}already installed" >&6 fi ac_config_files="$ac_config_files compile.lsp compile_rest.lsp bare.lsp lsp/config.lsp cmp/cmpcfg.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile tk/Makefile clx/defsys.lsp tests/Makefile ansi-tests/Makefile gabriel/Makefile lsp/defsys.lsp cmp/defsys.lsp clos/defsys.lsp" + +ac_config_files="$ac_config_files ecl-config:util/ecl-config" + cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure @@ -6081,6 +6096,7 @@ do "lsp/defsys.lsp" ) CONFIG_FILES="$CONFIG_FILES lsp/defsys.lsp" ;; "cmp/defsys.lsp" ) CONFIG_FILES="$CONFIG_FILES cmp/defsys.lsp" ;; "clos/defsys.lsp" ) CONFIG_FILES="$CONFIG_FILES clos/defsys.lsp" ;; + "ecl-config" ) CONFIG_FILES="$CONFIG_FILES ecl-config:util/ecl-config" ;; "h/config.h" ) CONFIG_HEADERS="$CONFIG_HEADERS h/config.h" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} @@ -6420,6 +6436,10 @@ s,@INSTALL@,$ac_INSTALL,;t t rm -f $tmp/out fi + # Run the commands associated with the file. + case $ac_file in + ecl-config ) chmod +x ecl-config ;; + esac done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF diff --git a/src/configure.in b/src/configure.in index 853f64548..d99595bc8 100644 --- a/src/configure.in +++ b/src/configure.in @@ -31,7 +31,7 @@ exit 2; fi dnl Set the version number. This seems the best place to keep it. -ECL_VERSION=0.7 +ECL_VERSION=0.7b AC_SUBST(ECL_VERSION) dnl Guess operating system of host. We do not allow cross-compiling. @@ -70,9 +70,9 @@ AC_ARG_WITH(gmp, dnl AC_ARG_ENABLE(locative, dnl [--enable-locative Include locative support.], dnl locative="$enable_locative") -dnl AC_ARG_ENABLE(threads, -dnl [--enable-threads Include the multiple thread facility.], -dnl threads="$enable_threads") +AC_ARG_ENABLE(threads, + [--enable-threads Include the multiple thread facility.], + threads="$enable_threads") dnl AC_ARG_ENABLE(runtime, dnl [--enable-runtime Build no compiler.], dnl runtime="$enable_runtime") @@ -209,9 +209,13 @@ if test "${locative}" ; then EXTRA_OBJS="${EXTRA_OBJS} unify.o" AC_DEFINE(LOCATIVE) fi +AC_MSG_CHECKING(Checking for threads support) if test "${threads}" ; then EXTRA_OBJS="${EXTRA_OBJS} lwp.o" AC_DEFINE(THREADS) + AC_MSG_RESULT(userland threads) +else + AC_MSG_RESULT(no) fi if test ${usecxx} = "no" ; then ECL_CC="${CC}" @@ -283,10 +287,10 @@ else AC_MSG_RESULT(configuring local copy) test -d gmp && rm -rf gmp if mkdir gmp; then - (cd gmp; + (destdir=`pwd`; cd gmp; $srcdir/gmp/configure --disable-shared --prefix=$bindir \ - --infodir=${builddir}/doc --includedir=${builddir}/h \ - --libdir=${builddir} $gmp_flags) + --infodir=${destdir}/doc --includedir=${destdir}/h \ + --libdir=${destdir} $gmp_flags) fi fi dnl --------------------------------------------------------------------- @@ -299,9 +303,9 @@ elif test "${local_boehm}" = "no" ; then AC_MSG_RESULT(configuring local copy) test -d gc && rm -rf gc if mkdir gc; then - (cd gc; + (destdir=`pwd`; cd gc; $srcdir/gc/configure --disable-threads --disable-shared --prefix=$bindir \ - --includedir=${builddir}/h --libdir=${builddir}) + --includedir=${destdir}/h --libdir=${destdir}) fi else AC_MSG_RESULT(already installed) @@ -309,8 +313,10 @@ fi dnl --------------------------------------------------------------------- dnl Final pass over configuration files dnl -AC_OUTPUT(compile.lsp compile_rest.lsp bare.lsp +AC_CONFIG_FILES(compile.lsp compile_rest.lsp bare.lsp lsp/config.lsp cmp/cmpcfg.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile tk/Makefile clx/defsys.lsp tests/Makefile ansi-tests/Makefile gabriel/Makefile lsp/defsys.lsp cmp/defsys.lsp clos/defsys.lsp) +AC_CONFIG_FILES([ecl-config:util/ecl-config],[chmod +x ecl-config]) +AC_OUTPUT diff --git a/src/gc/mark.c b/src/gc/mark.c index 8ca36f13c..69d6e6e3b 100644 --- a/src/gc/mark.c +++ b/src/gc/mark.c @@ -566,6 +566,7 @@ mse * mark_stack_limit; break; case GC_DS_BITMAP: mark_stack_top--; +#if 0 descr &= ~GC_DS_TAGS; credit -= WORDS_TO_BYTES(WORDSZ/2); /* guess */ while (descr != 0) { @@ -580,6 +581,22 @@ mse * mark_stack_limit; descr <<= 1; ++ current_p; } +#else + descr = BYTES_TO_WORDS(descr); + credit -= WORDS_TO_BYTES(WORDSZ/2); /* guess */ + while (descr) { + current = *current_p; + if ((long)current & 3 == 0) { + if ((ptr_t)current >= least_ha && (ptr_t)current < greatest_ha) { + PREFETCH(current); + HC_PUSH_CONTENTS((ptr_t)current, mark_stack_top, + mark_stack_limit, current_p, exit1); + } + } + descr--; + ++ current_p; + } +#endif continue; case GC_DS_PROC: mark_stack_top--; diff --git a/src/h/ecl-cmp.h b/src/h/ecl-cmp.h index 8401b94c0..9cb98b0f2 100644 --- a/src/h/ecl-cmp.h +++ b/src/h/ecl-cmp.h @@ -29,7 +29,6 @@ #include "critical.h" #endif #include "external.h" -#include "lisp_external.h" #include "eval.h" #include "number.h" #ifdef LOCATIVE diff --git a/src/h/ecl.h b/src/h/ecl.h index 0139f0387..8bc39cb18 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -28,12 +28,11 @@ #ifdef THREADS # include "lwp.h" #endif -#include "external.h" #ifndef _ARGS #define _ARGS(x) x #endif +#include "external.h" /*#include "ecl-inl.h"*/ -#include "lisp_external.h" #include "eval.h" #include "number.h" #ifdef LOCATIVE diff --git a/src/h/external.h b/src/h/external.h index d622f3dd3..59293983d 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -2,6 +2,10 @@ extern "C" { #endif +#ifndef _ARGS +#define _ARGS(x) (int n, ...) +#endif + struct let { cl_object let_var; cl_object let_spp; @@ -24,10 +28,22 @@ extern void cl_dealloc(void *p, cl_index s); extern void *cl_alloc(cl_index n); extern void *cl_alloc_align(cl_index size, cl_index align); #ifdef GBC_BOEHM +extern cl_object cl_gc _ARGS((int narg, cl_object area)); extern void *cl_alloc_atomic(cl_index size); extern void *cl_alloc_atomic_align(cl_index size, cl_index align); extern void init_alloc_function(void); #else +extern cl_object si_room_report _ARGS((int narg)); +extern cl_object si_allocate _ARGS((int narg, cl_object type, cl_object qty, ...)); +extern cl_object si_maximum_allocatable_pages _ARGS((int narg, cl_object type)); +extern cl_object si_allocated_pages _ARGS((int narg, cl_object type)); +extern cl_object si_alloc_contpage _ARGS((int narg, cl_object qty, ...)); +extern cl_object si_allocated_contiguous_pages _ARGS((int narg)); +extern cl_object si_maximum_contiguous_pages _ARGS((int narg)); +extern cl_object si_allocate_contiguous_pages _ARGS((int narg, cl_object qty, ...)); +extern cl_object si_get_hole_size _ARGS((int narg)); +extern cl_object si_set_hole_size _ARGS((int narg, cl_object size)); +extern cl_object si_ignore_maximum_pages _ARGS((int narg, ...)); #define cl_alloc_atomic(x) cl_alloc(x) #define cl_alloc_atomic_align(x,s) cl_alloc_align(x,s) #endif /* GBC_BOEHM */ @@ -39,12 +55,15 @@ extern void init_all_functions(void); /* all_symbols */ + +extern cl_object si_mangle_name _ARGS((int narg, cl_object symbol, ...)); + typedef union { struct { const char *name; int type; - cl_object *loc; void *fun; + short narg; } init; struct symbol data; } cl_symbol_initializer; @@ -55,12 +74,32 @@ extern void init_all_symbols(void); /* apply.c */ +extern cl_object APPLY_fixed(int n, cl_object (*f)(), cl_object *x); extern cl_object APPLY(int n, cl_objectfn, cl_object *x); extern cl_object APPLY_closure(int n, cl_objectfn, cl_object cl, cl_object *x); /* array.c */ +extern cl_object cl_row_major_aref(cl_object x, cl_object i); +extern cl_object si_row_major_aset(cl_object x, cl_object i, cl_object v); +extern cl_object si_make_vector(cl_object etype, cl_object dim, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff); +extern cl_object cl_array_element_type(cl_object a); +extern cl_object cl_array_rank(cl_object a); +extern cl_object cl_array_dimension(cl_object a, cl_object index); +extern cl_object cl_array_total_size(cl_object a); +extern cl_object cl_adjustable_array_p(cl_object a); +extern cl_object si_displaced_array_p(cl_object a); +extern cl_object cl_svref(cl_object x, cl_object index); +extern cl_object si_svset(cl_object x, cl_object index, cl_object v); +extern cl_object cl_array_has_fill_pointer_p(cl_object a); +extern cl_object cl_fill_pointer(cl_object a); +extern cl_object si_fill_pointer_set(cl_object a, cl_object fp); +extern cl_object si_replace_array(cl_object old_obj, cl_object new_obj); +extern cl_object cl_aref _ARGS((int narg, cl_object x, ...)); +extern cl_object si_aset _ARGS((int narg, cl_object v, cl_object x, ...)); +extern cl_object si_make_pure_array _ARGS((int narg, cl_object etype, cl_object adj, cl_object displ, cl_object disploff, ...)); + extern cl_index object_to_index(cl_object n); extern cl_object aref(cl_object x, cl_index index); extern cl_object aref1(cl_object v, cl_index index); @@ -76,7 +115,13 @@ extern void init_array(void); /* assignment.c */ -extern cl_object set(cl_object sym, cl_object val); +extern cl_object cl_set(cl_object var, cl_object val); +extern cl_object si_setf_namep(cl_object arg); +extern cl_object cl_makunbound(cl_object sym); +extern cl_object cl_fmakunbound(cl_object sym); +extern cl_object si_clear_compiler_properties(cl_object sym); +extern cl_object si_fset _ARGS((int narg, cl_object fun, cl_object def, ...)); + extern cl_object setf_namep(cl_object fun_spec); extern void clear_compiler_properties(cl_object sym); extern void init_assignment(void); @@ -84,6 +129,8 @@ extern void init_assignment(void); /* backq.c */ +extern cl_object cl_comma_reader _ARGS((int narg, cl_object in, cl_object c)); +extern cl_object cl_backquote_reader _ARGS((int narg, cl_object in, cl_object c)); extern void init_backq(void); @@ -119,17 +166,53 @@ extern void init_catch(void); /* cfun.c */ -extern cl_object make_cfun(cl_objectfn self, cl_object name, cl_object block); -extern cl_object make_cclosure(cl_objectfn self, cl_object env, cl_object block); -extern void MF(cl_object sym, cl_objectfn self, cl_object block); -extern void MM(cl_object sym, cl_objectfn self, cl_object block); -extern cl_object make_function(const char *s, cl_objectfn f); -extern cl_object make_si_function(const char *s, cl_objectfn f); +extern cl_object si_compiled_function_name(cl_object fun); +extern cl_object si_compiled_function_block(cl_object fun); +extern cl_object si_compiled_function_source(cl_object fun); + +extern cl_object cl_make_cfun(cl_object (*self)(), cl_object name, cl_object block, int narg); +extern cl_object cl_make_cfun_va(cl_object (*self)(int narg,...), cl_object name, cl_object block); +extern cl_object cl_make_cclosure_va(cl_object (*self)(int narg,...), cl_object env, cl_object block); +extern void cl_def_c_function(cl_object sym, cl_object (*self)(), int narg); +extern void cl_def_c_macro_va(cl_object sym, cl_object (*self)(int narg,...)); +extern void cl_def_c_function_va(cl_object sym, cl_object (*self)(int narg,...)); extern void init_cfun(void); /* character.c */ +extern cl_object cl_digit_char_p _ARGS((int narg, cl_object c, ...)); +extern cl_object cl_charE _ARGS((int narg, cl_object c, ...)); +extern cl_object cl_charNE _ARGS((int narg, ...)); +extern cl_object cl_charL _ARGS((int narg, ...)); +extern cl_object cl_charG _ARGS((int narg, ...)); +extern cl_object cl_charLE _ARGS((int narg, ...)); +extern cl_object cl_charGE _ARGS((int narg, ...)); +extern cl_object cl_char_equal _ARGS((int narg, cl_object c, ...)); +extern cl_object cl_char_not_equal _ARGS((int narg, ...)); +extern cl_object cl_char_lessp _ARGS((int narg, ...)); +extern cl_object cl_char_greaterp _ARGS((int narg, ...)); +extern cl_object cl_char_not_greaterp _ARGS((int narg, ...)); +extern cl_object cl_char_not_lessp _ARGS((int narg, ...)); +extern cl_object cl_digit_char _ARGS((int narg, cl_object w, ...)); + +extern cl_object cl_alpha_char_p(cl_object c); +extern cl_object cl_alphanumericp(cl_object c); +extern cl_object cl_both_case_p(cl_object c); +extern cl_object cl_char_code(cl_object c); +extern cl_object cl_char_downcase(cl_object c); +extern cl_object cl_char_int(cl_object c); +extern cl_object cl_char_name(cl_object c); +extern cl_object cl_char_upcase(cl_object c); +extern cl_object cl_character(cl_object x); +extern cl_object cl_code_char(cl_object c); +extern cl_object cl_graphic_char_p(cl_object c); +extern cl_object cl_int_char(cl_object x); +extern cl_object cl_lower_case_p(cl_object c); +extern cl_object cl_name_char(cl_object s); +extern cl_object cl_standard_char_p(cl_object c); +extern cl_object cl_upper_case_p(cl_object c); + extern cl_fixnum char_code(cl_object c); extern int digitp(int i, int r); extern bool char_eq(cl_object x, cl_object y); @@ -141,10 +224,11 @@ extern short digit_weight(int w, int r); extern void init_character(void); extern void init_character_function(void); - /* clos.c */ #ifdef CLOS +extern cl_object cl_find_class _ARGS((int narg, cl_object name, ...)); + extern cl_object class_class; extern cl_object class_object; extern cl_object class_built_in; @@ -153,6 +237,8 @@ extern void init_clos(void); /* cmpaux.c */ +extern cl_object si_specialp(cl_object sym); + extern int ifloor(int x, int y); extern int imod(int x, int y); extern char object_to_char(cl_object x); @@ -171,12 +257,19 @@ extern void init_cmpaux(void); /* compiler.c */ +extern cl_object si_process_lambda_list(cl_object lambda); +extern cl_object si_make_lambda(cl_object name, cl_object body); +extern cl_object si_function_block_name(cl_object name); +extern cl_object si_process_declarations _ARGS((int narg, cl_object body, ...)); + extern cl_object make_lambda(cl_object name, cl_object lambda); extern cl_object eval(cl_object form, cl_object *bytecodes, cl_object env); extern void init_compiler(void); /* interpreter.c */ +extern cl_object si_interpreter_stack _ARGS((int narg)); + extern void cl_stack_push(cl_object o); extern cl_object cl_stack_pop(void); extern cl_index cl_stack_index(void); @@ -198,9 +291,16 @@ extern void init_interpreter(void); extern void init_conditional(void); +/* disassembler.c */ + +extern cl_object si_bc_disassemble(cl_object v); +extern cl_object si_bc_split(cl_object v); /* error.c */ +extern cl_object cl_error _ARGS((int narg, cl_object eformat, ...)); +extern cl_object cl_cerror _ARGS((int narg, cl_object cformat, cl_object eformat, ...)); + extern cl_object null_string; extern void internal_error(const char *s) __attribute__((noreturn)); extern void cs_overflow(void) __attribute__((noreturn)); @@ -231,12 +331,20 @@ extern void FEend_of_file(cl_object strm); /* eval.c */ -#define funcall clLfuncall +extern cl_object cl_funcall _ARGS((int narg, cl_object fun, ...)); +extern cl_object cl_apply _ARGS((int narg, cl_object fun, cl_object arg, ...)); +extern cl_object si_safe_eval _ARGS((int n, cl_object form, ...)); #define cl_va_start(a,p,n,k) (va_start(a[0].args,p),a[0].narg=n,cl__va_start(a,k)) extern void cl__va_start(cl_va_list args, int args_before); extern cl_object cl_va_arg(cl_va_list args); +extern cl_object si_unlink_symbol(cl_object s); +extern cl_object cl_eval(cl_object form); +extern cl_object si_eval_with_env(cl_object form, cl_object env); +extern cl_object cl_constantp(cl_object arg); + +#define funcall cl_funcall extern cl_object cl_apply_from_stack(cl_index narg, cl_object fun); extern cl_object link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args); extern cl_object cl_safe_eval(cl_object form, cl_object *bytecodes, cl_object env, cl_object err_value); @@ -244,6 +352,28 @@ extern void init_eval(void); /* file.c */ +extern cl_object cl_make_synonym_stream(cl_object sym); +extern cl_object cl_make_two_way_stream(cl_object strm1, cl_object strm2); +extern cl_object cl_make_echo_stream(cl_object strm1, cl_object strm2); +extern cl_object cl_make_string_output_stream(); +extern cl_object cl_get_output_stream_string(cl_object strm); +extern cl_object si_output_stream_string(cl_object strm); +extern cl_object cl_streamp(cl_object strm); +extern cl_object cl_input_stream_p(cl_object strm); +extern cl_object cl_output_stream_p(cl_object strm); +extern cl_object cl_stream_element_type(cl_object strm); +extern cl_object cl_file_length(cl_object strm); +extern cl_object si_get_string_input_stream_index(cl_object strm); +extern cl_object si_make_string_output_stream_from_string(cl_object strng); +extern cl_object si_copy_stream(cl_object in, cl_object out); +extern cl_object cl_open_stream_p(cl_object strm); +extern cl_object cl_make_broadcast_stream _ARGS((int narg, ...)); +extern cl_object cl_make_concatenated_stream _ARGS((int narg, ...)); +extern cl_object cl_make_string_input_stream _ARGS((int narg, cl_object strng, ...)); +extern cl_object cl_close _ARGS((int narg, cl_object strm, ...)); +extern cl_object cl_open _ARGS((int narg, cl_object filename, ...)); +extern cl_object cl_file_position _ARGS((int narg, cl_object file_stream, ...)); + extern bool input_stream_p(cl_object strm); extern bool output_stream_p(cl_object strm); extern cl_object stream_element_type(cl_object strm); @@ -275,12 +405,18 @@ extern void init_file_function(void); /* format.c */ +extern cl_object cl_format _ARGS((int narg, volatile cl_object strm, cl_object string, ...)); extern void init_format(void); /* gbc.c */ #if !defined(GBC_BOEHM) +extern cl_object cl_gc _ARGS((int narg, cl_object area)); +extern cl_object si_room_report _ARGS((int narg)); +extern cl_object si_reset_gc_count _ARGS((int narg)); +extern cl_object si_gc_time _ARGS((int narg)); + #define GC_enabled() GC_enable #define GC_enable() GC_enable = TRUE; #define GC_disable() GC_enable = FALSE; @@ -308,6 +444,19 @@ extern void gc(cl_type t); /* gfun.c */ #ifdef CLOS +extern cl_object si_allocate_gfun(cl_object name, cl_object arg_no, cl_object ht); +extern cl_object si_gfun_name(cl_object x); +extern cl_object si_gfun_name_set(cl_object x, cl_object name); +extern cl_object si_gfun_method_ht(cl_object x); +extern cl_object si_gfun_method_ht_set(cl_object x, cl_object y); +extern cl_object si_gfun_spec_how_ref(cl_object x, cl_object y); +extern cl_object si_gfun_spec_how_set(cl_object x, cl_object y, cl_object spec); +extern cl_object si_gfun_instance(cl_object x); +extern cl_object si_gfun_instance_set(cl_object x, cl_object y); +extern cl_object si_gfunp(cl_object x); +extern cl_object si_method_ht_get(cl_object keylist, cl_object table); +extern cl_object si_set_compiled_function_name(cl_object keylist, cl_object table); + extern cl_object compute_method(int narg, cl_object fun, cl_object *args); extern void init_gfun(void); #endif /* CLOS */ @@ -315,7 +464,19 @@ extern void init_gfun(void); /* hash.c */ -extern cl_object cl_make_hash_table(cl_object test, cl_object size, cl_object rehash_size, cl_object rehash_threshold); +extern cl_object cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, cl_object rehash_threshold); +extern cl_object cl_hash_table_p(cl_object ht); +extern cl_object si_hash_set(cl_object key, cl_object ht, cl_object val); +extern cl_object cl_remhash(cl_object key, cl_object ht); +extern cl_object cl_clrhash(cl_object ht); +extern cl_object cl_hash_table_count(cl_object ht); +extern cl_object cl_sxhash(cl_object key); +extern cl_object cl_maphash(cl_object fun, cl_object ht); +extern cl_object cl_hash_table_rehash_size(cl_object ht); +extern cl_object cl_hash_table_rehash_threshold(cl_object ht); +extern cl_object cl_make_hash_table _ARGS((int narg, ...)); +extern cl_object cl_gethash _ARGS((int narg, cl_object key, cl_object ht, ...)); + extern cl_hashkey update_crc32(cl_hashkey crc, const char *buffer, cl_index len); extern cl_hashkey hash_eq(cl_object x); extern cl_hashkey hash_eql(cl_object x); @@ -338,6 +499,18 @@ extern void init_libs(void); /* instance.c */ #ifdef CLOS +extern cl_object si_allocate_instance(cl_object clas, cl_object size); +extern cl_object si_change_instance(cl_object x, cl_object clas, cl_object size, cl_object corr); +extern cl_object si_instance_class(cl_object x); +extern cl_object si_instance_class_set(cl_object x, cl_object y); +extern cl_object si_instance_ref(cl_object x, cl_object index); +extern cl_object si_instance_ref_safe(cl_object x, cl_object index); +extern cl_object si_instance_set(cl_object x, cl_object index, cl_object value); +extern cl_object si_instancep(cl_object x); +extern cl_object si_unbound(); +extern cl_object si_sl_boundp(cl_object x); +extern cl_object si_sl_makunbound(cl_object x, cl_object index); + extern cl_object cl_allocate_instance(cl_object clas, int size); extern cl_object instance_ref(cl_object x, int i); extern cl_object instance_set(cl_object x, int i, cl_object v); @@ -359,41 +532,91 @@ extern void init_let(void); /* list.c */ +extern cl_object cl_caar(cl_object x); +extern cl_object cl_cadr(cl_object x); +extern cl_object cl_cdar(cl_object x); +extern cl_object cl_cddr(cl_object x); +extern cl_object cl_caaar(cl_object x); +extern cl_object cl_caadr(cl_object x); +extern cl_object cl_cadar(cl_object x); +extern cl_object cl_caddr(cl_object x); +extern cl_object cl_cdaar(cl_object x); +extern cl_object cl_cdadr(cl_object x); +extern cl_object cl_cddar(cl_object x); +extern cl_object cl_cdddr(cl_object x); +extern cl_object cl_caaaar(cl_object x); +extern cl_object cl_caaadr(cl_object x); +extern cl_object cl_caadar(cl_object x); +extern cl_object cl_caaddr(cl_object x); +extern cl_object cl_cadaar(cl_object x); +extern cl_object cl_cadadr(cl_object x); +extern cl_object cl_caddar(cl_object x); +extern cl_object cl_cadddr(cl_object x); +extern cl_object cl_cdaaar(cl_object x); +extern cl_object cl_cdaadr(cl_object x); +extern cl_object cl_cdadar(cl_object x); +extern cl_object cl_cdaddr(cl_object x); +extern cl_object cl_cddaar(cl_object x); +extern cl_object cl_cddadr(cl_object x); +extern cl_object cl_cdddar(cl_object x); +extern cl_object cl_cddddr(cl_object x); +extern cl_object cl_fifth(cl_object x); +extern cl_object cl_sixth(cl_object x); +extern cl_object cl_seventh(cl_object x); +extern cl_object cl_eighth(cl_object x); +extern cl_object cl_ninth(cl_object x); +extern cl_object cl_tenth(cl_object x); +extern cl_object cl_list _ARGS((int narg, ...)); +extern cl_object cl_listX _ARGS((int narg, ...)); +extern cl_object cl_append _ARGS((int narg, ...)); +extern cl_object cl_cons _ARGS((int narg, cl_object car, cl_object cdr)); +extern cl_object cl_tree_equal _ARGS((int narg, cl_object x, cl_object y, ...)); +extern cl_object cl_endp _ARGS((int narg, cl_object x)); +extern cl_object cl_list_length _ARGS((int narg, cl_object x)); +extern cl_object cl_nth _ARGS((int narg, cl_object n, cl_object x)); +extern cl_object cl_nthcdr _ARGS((int narg, cl_object n, cl_object x)); +extern cl_object cl_last _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_make_list _ARGS((int narg, cl_object size, ...)); +extern cl_object cl_copy_list _ARGS((int narg, cl_object x)); +extern cl_object cl_copy_alist _ARGS((int narg, cl_object x)); +extern cl_object cl_copy_tree _ARGS((int narg, cl_object x)); +extern cl_object cl_revappend _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object cl_nconc _ARGS((int narg, ...)); +extern cl_object cl_nreconc _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object cl_butlast _ARGS((int narg, cl_object lis, ...)); +extern cl_object cl_nbutlast _ARGS((int narg, cl_object lis, ...)); +extern cl_object cl_ldiff _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object cl_rplaca _ARGS((int narg, cl_object x, cl_object v)); +extern cl_object cl_rplacd _ARGS((int narg, cl_object x, cl_object v)); +extern cl_object cl_subst _ARGS((int narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); +extern cl_object cl_subst_if _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); +extern cl_object cl_subst_if_not _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); +extern cl_object cl_nsubst _ARGS((int narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); +extern cl_object cl_nsubst_if _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); +extern cl_object cl_nsubst_if_not _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); +extern cl_object cl_sublis _ARGS((int narg, cl_object alist, cl_object tree, ...)); +extern cl_object cl_nsublis _ARGS((int narg, cl_object alist, cl_object tree, ...)); +extern cl_object cl_member _ARGS((int narg, cl_object item, cl_object list, ...)); +extern cl_object si_memq _ARGS((int narg, cl_object x, cl_object l)); +extern cl_object cl_member_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); +extern cl_object cl_member_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); +extern cl_object si_member1 _ARGS((int narg, cl_object item, cl_object list, ...)); +extern cl_object cl_tailp _ARGS((int narg, cl_object y, cl_object x)); +extern cl_object cl_adjoin _ARGS((int narg, cl_object item, cl_object list, cl_object k1, cl_object v1, cl_object k2, cl_object v2, cl_object k3, cl_object v3)); +extern cl_object cl_acons _ARGS((int narg, cl_object x, cl_object y, cl_object z)); +extern cl_object cl_pairlis _ARGS((int narg, cl_object keys, cl_object data, ...)); +extern cl_object cl_rassoc _ARGS((int narg, cl_object item, cl_object alist, ...)); +extern cl_object cl_assoc _ARGS((int narg, cl_object item, cl_object alist, ...)); +extern cl_object cl_assoc_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); +extern cl_object cl_assoc_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); +extern cl_object cl_rassoc_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); +extern cl_object cl_rassoc_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); + extern cl_object list_length(cl_object x); extern cl_object identity(cl_object x); -extern cl_object car(cl_object x); -extern cl_object cdr(cl_object x); -extern cl_object list(int narg, ...); -extern cl_object listX(int narg, ...); +extern cl_object cl_car(cl_object x); +extern cl_object cl_cdr(cl_object x); extern cl_object append(cl_object x, cl_object y); -extern cl_object caar(cl_object x); -extern cl_object cadr(cl_object x); -extern cl_object cdar(cl_object x); -extern cl_object cddr(cl_object x); -extern cl_object caaar(cl_object x); -extern cl_object caadr(cl_object x); -extern cl_object cadar(cl_object x); -extern cl_object caddr(cl_object x); -extern cl_object cdaar(cl_object x); -extern cl_object cdadr(cl_object x); -extern cl_object cddar(cl_object x); -extern cl_object cdddr(cl_object x); -extern cl_object caaaar(cl_object x); -extern cl_object caaadr(cl_object x); -extern cl_object caadar(cl_object x); -extern cl_object caaddr(cl_object x); -extern cl_object cadaar(cl_object x); -extern cl_object cadadr(cl_object x); -extern cl_object caddar(cl_object x); -extern cl_object cadddr(cl_object x); -extern cl_object cdaaar(cl_object x); -extern cl_object cdaadr(cl_object x); -extern cl_object cdadar(cl_object x); -extern cl_object cdaddr(cl_object x); -extern cl_object cddaar(cl_object x); -extern cl_object cddadr(cl_object x); -extern cl_object cdddar(cl_object x); -extern cl_object cddddr(cl_object x); extern bool endp(cl_object x); extern cl_object nth(cl_fixnum n, cl_object x); extern cl_object nthcdr(cl_fixnum n, cl_object x); @@ -418,11 +641,36 @@ extern void init_list(void); /* load.c */ +extern cl_object si_load_source(cl_object file, cl_object verbose, cl_object print); +extern cl_object si_load_binary(cl_object file, cl_object verbose, cl_object print); +extern cl_object cl_load _ARGS((int narg, cl_object pathname, ...)); + extern void init_load(void); extern void load_until_tag(cl_object stream, cl_object end_tag); /* lwp.c */ #ifdef THREADS +extern cl_object si_thread_break_in _ARGS((int narg)); +extern cl_object si_thread_break_quit _ARGS((int narg)); +extern cl_object si_thread_break_resume _ARGS((int narg)); +extern cl_object cl_thread_list _ARGS((int narg)); +extern cl_object cl_make_thread _ARGS((int narg, cl_object fun)); +extern cl_object cl_deactivate _ARGS((int narg, cl_object thread)); +extern cl_object cl_reactivate _ARGS((int narg, cl_object thread)); +extern cl_object cl_kill_thread _ARGS((int narg, cl_object thread)); +extern cl_object cl_current_thread _ARGS((int narg)); +extern cl_object cl_thread_status _ARGS((int narg, cl_object thread)); +extern cl_object cl_make_continuation _ARGS((int narg, cl_object thread)); +extern cl_object cl_thread_of _ARGS((int narg, cl_object cont)); +extern cl_object cl_continuation_of _ARGS((int narg, cl_object thread)); +extern cl_object cl_resume _ARGS((int narg, cl_object cont, ...)); +extern cl_object cl_disable_scheduler _ARGS((int narg)); +extern cl_object cl_enable_scheduler _ARGS((int narg)); +extern cl_object cl_suspend _ARGS((int narg)); +extern cl_object cl_delay _ARGS((int narg, cl_object interval)); +extern cl_object cl_thread_wait _ARGS((int narg, cl_object fun, ...)); +extern cl_object cl_thread_wait_with_timeout _ARGS((int narg, cl_object timeout, cl_object fun, ...)); + extern int critical_level; extern int update_queue(void); extern int activate_thread(cl_object thread); @@ -438,6 +686,9 @@ extern int init_lwp(void); /* macros.c */ +extern cl_object cl_macroexpand _ARGS((int narg, cl_object form, ...)); +extern cl_object cl_macroexpand_1 _ARGS((int narg, cl_object form, ...)); + extern cl_object search_macro(cl_object name, cl_object env); extern cl_object macro_expand1(cl_object form, cl_object env); extern cl_object macro_expand(cl_object form, cl_object env); @@ -446,6 +697,13 @@ extern void init_macros(void); /* main.c */ +extern cl_object si_argc(); +extern cl_object si_argv(cl_object index); +extern cl_object si_getenv(cl_object var); +extern cl_object si_setenv(cl_object var, cl_object value); +extern cl_object si_pointer(cl_object x); +extern cl_object cl_quit _ARGS((int narg, ...)); + extern int cl_boot(int argc, char **argv); extern const char *ecl_self; extern void init_main(void); @@ -453,16 +711,34 @@ extern void init_main(void); /* mapfun.c */ +extern cl_object cl_mapcar _ARGS((int narg, cl_object fun, ...)); +extern cl_object cl_maplist _ARGS((int narg, cl_object fun, ...)); +extern cl_object cl_mapc _ARGS((int narg, cl_object fun, ...)); +extern cl_object cl_mapl _ARGS((int narg, cl_object fun, ...)); +extern cl_object cl_mapcan _ARGS((int narg, cl_object fun, ...)); +extern cl_object cl_mapcon _ARGS((int narg, cl_object fun, ...)); extern void init_mapfun(void); /* multival.c */ +extern cl_object cl_values_list(cl_object list); +extern cl_object cl_values _ARGS((int narg, ...)); extern void init_multival(void); /* num_arith.c */ +extern cl_object cl_conjugate(cl_object c); +extern cl_object cl_1P(cl_object x); +extern cl_object cl_1M(cl_object x); +extern cl_object cl_X _ARGS((int narg, ...)); +extern cl_object cl_P _ARGS((int narg, ...)); +extern cl_object cl_M _ARGS((int narg, cl_object num, ...)); +extern cl_object cl_N _ARGS((int narg, cl_object num, ...)); +extern cl_object cl_gcd _ARGS((int narg, ...)); +extern cl_object cl_lcm _ARGS((int narg, cl_object lcm, ...)); + extern cl_object fixnum_times(cl_fixnum i, cl_fixnum j); extern cl_object number_times(cl_object x, cl_object y); extern cl_object number_to_complex(cl_object x); @@ -495,6 +771,26 @@ extern void init_number(void); /* num_co.c */ +extern cl_object cl_numerator(cl_object x); +extern cl_object cl_denominator(cl_object x); +extern cl_object cl_mod(cl_object x, cl_object y); +extern cl_object cl_rem(cl_object x, cl_object y); +extern cl_object cl_decode_float(cl_object x); +extern cl_object cl_scale_float(cl_object x, cl_object y); +extern cl_object cl_float_radix(cl_object x); +extern cl_object cl_float_digits(cl_object x); +extern cl_object cl_float_precision(cl_object x); +extern cl_object cl_integer_decode_float(cl_object x); +extern cl_object cl_realpart(cl_object x); +extern cl_object cl_imagpart(cl_object x); +extern cl_object cl_float _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_floor _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_ceiling _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_truncate _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_round _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_float_sign _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_complex _ARGS((int narg, cl_object r, ...)); + extern cl_object double_to_integer(double d); extern cl_object float_to_integer(float d); extern cl_object floor1(cl_object x); @@ -510,6 +806,15 @@ extern void init_num_co(void); /* num_comp.c */ +extern cl_object cl_E _ARGS((int narg, cl_object num, ...)); +extern cl_object cl_NE _ARGS((int narg, ...)); +extern cl_object cl_L _ARGS((int narg, ...)); +extern cl_object cl_G _ARGS((int narg, ...)); +extern cl_object cl_GE _ARGS((int narg, ...)); +extern cl_object cl_LE _ARGS((int narg, ...)); +extern cl_object cl_max _ARGS((int narg, cl_object max, ...)); +extern cl_object cl_min _ARGS((int narg, cl_object min, ...)); + extern int number_equalp(cl_object x, cl_object y); extern int number_compare(cl_object x, cl_object y); extern void init_num_comp(void); @@ -517,6 +822,24 @@ extern void init_num_comp(void); /* num_log.c */ +extern cl_object cl_lognand(cl_object x, cl_object y); +extern cl_object cl_lognor(cl_object x, cl_object y); +extern cl_object cl_logandc1(cl_object x, cl_object y); +extern cl_object cl_logandc2(cl_object x, cl_object y); +extern cl_object cl_logorc1(cl_object x, cl_object y); +extern cl_object cl_logorc2(cl_object x, cl_object y); +extern cl_object cl_lognot(cl_object x); +extern cl_object cl_boole(cl_object o, cl_object x, cl_object y); +extern cl_object cl_logbitp(cl_object p, cl_object x); +extern cl_object cl_ash(cl_object x, cl_object y); +extern cl_object cl_logcount(cl_object x); +extern cl_object cl_integer_length(cl_object x); +extern cl_object si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r); +extern cl_object cl_logior _ARGS((int narg, ...)); +extern cl_object cl_logxor _ARGS((int narg, ...)); +extern cl_object cl_logand _ARGS((int narg, ...)); +extern cl_object cl_logeqv _ARGS((int narg, ...)); + extern cl_object integer_shift(cl_object x, cl_fixnum w); extern int int_bit_length(int i); extern void init_num_log(void); @@ -524,6 +847,12 @@ extern void init_num_log(void); /* num_pred.c */ +extern cl_object cl_zerop(cl_object x); +extern cl_object cl_plusp(cl_object x); +extern cl_object cl_minusp(cl_object x); +extern cl_object cl_oddp(cl_object x); +extern cl_object cl_evenp(cl_object x); + extern int number_zerop(cl_object x); extern int number_plusp(cl_object x); extern int number_minusp(cl_object x); @@ -534,6 +863,9 @@ extern void init_num_pred(void); /* num_rand.c */ +extern cl_object cl_random_state_p(cl_object x); +extern cl_object cl_random _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_make_random_state _ARGS((int narg, ...)); extern cl_object make_random_state(cl_object rs); extern void init_num_rand(void); @@ -544,24 +876,52 @@ extern cl_object imag_unit; extern cl_object minus_imag_unit; extern cl_object imag_two; extern cl_fixnum fixnum_expt(cl_fixnum x, cl_fixnum y); -extern cl_object number_exp(cl_object x); -extern cl_object number_expt(cl_object x, cl_object y); -extern cl_object number_nlog(cl_object x); -extern cl_object number_log(cl_object x, cl_object y); -extern cl_object number_sqrt(cl_object x); -extern cl_object number_atan2(cl_object y, cl_object x); -extern cl_object number_atan(cl_object y); -extern cl_object number_sin(cl_object x); -extern cl_object number_cos(cl_object x); -extern cl_object number_tan(cl_object x); -extern cl_object number_sinh(cl_object x); -extern cl_object number_cosh(cl_object x); -extern cl_object number_tanh(cl_object x); +extern cl_object cl_exp(cl_object x); +extern cl_object cl_expt(cl_object x, cl_object y); +extern cl_object cl_log1(cl_object x); +extern cl_object cl_log2(cl_object x, cl_object y); +extern cl_object cl_sqrt(cl_object x); +extern cl_object cl_atan2(cl_object y, cl_object x); +extern cl_object cl_atan1(cl_object y); +extern cl_object cl_sin(cl_object x); +extern cl_object cl_cos(cl_object x); +extern cl_object cl_tan(cl_object x); +extern cl_object cl_sinh(cl_object x); +extern cl_object cl_cosh(cl_object x); +extern cl_object cl_tanh(cl_object x); +extern cl_object cl_atan _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_log _ARGS((int narg, cl_object x, ...)); extern void init_num_sfun(void); /* package.c */ +extern cl_object si_select_package(cl_object pack_name); +extern cl_object cl_find_package(cl_object p); +extern cl_object cl_package_name(cl_object p); +extern cl_object cl_package_nicknames(cl_object p); +extern cl_object cl_package_use_list(cl_object p); +extern cl_object cl_package_used_by_list(cl_object p); +extern cl_object cl_package_shadowing_symbols(cl_object p); +extern cl_object cl_list_all_packages(); +extern cl_object si_package_internal(cl_object p, cl_object index); +extern cl_object si_package_external(cl_object p, cl_object index); +extern cl_object si_package_size(cl_object p); +extern cl_object si_package_lock(cl_object p, cl_object t); +extern cl_object cl_delete_package(cl_object p); +extern cl_object cl_make_package _ARGS((int narg, cl_object pack_name, ...)); +extern cl_object cl_intern _ARGS((int narg, cl_object strng, ...)); +extern cl_object cl_find_symbol _ARGS((int narg, cl_object strng, ...)); +extern cl_object cl_unintern _ARGS((int narg, cl_object symbl, ...)); +extern cl_object cl_export _ARGS((int narg, cl_object symbols, ...)); +extern cl_object cl_unexport _ARGS((int narg, cl_object symbols, ...)); +extern cl_object cl_import _ARGS((int narg, cl_object symbols, ...)); +extern cl_object cl_rename_package _ARGS((int narg, cl_object pack, cl_object new_name, ...)); +extern cl_object cl_shadowing_import _ARGS((int narg, cl_object symbols, ...)); +extern cl_object cl_shadow _ARGS((int narg, cl_object symbols, ...)); +extern cl_object cl_use_package _ARGS((int narg, cl_object pack, ...)); +extern cl_object cl_unuse_package _ARGS((int narg, cl_object pack, ...)); + extern bool lisp_package_locked; extern cl_object lisp_package; extern cl_object user_package; @@ -571,15 +931,15 @@ extern cl_object clos_package; extern cl_object make_package(cl_object n, cl_object ns, cl_object ul); extern cl_object rename_package(cl_object x, cl_object n, cl_object ns); extern cl_object find_package(cl_object n); -extern cl_object coerce_to_package(cl_object p); +extern cl_object si_coerce_to_package(cl_object p); extern cl_object current_package(void); extern cl_object intern(cl_object name, cl_object p, int *intern_flag); extern cl_object _intern(const char *s, cl_object p); extern cl_object find_symbol(cl_object name, cl_object p, int *intern_flag); extern bool unintern(cl_object s, cl_object p); -extern void cl_export(cl_object s, cl_object p); -extern void cl_unexport(cl_object s, cl_object p); -extern void cl_import(cl_object s, cl_object p); +extern void cl_export2(cl_object s, cl_object p); +extern void cl_unexport2(cl_object s, cl_object p); +extern void cl_import2(cl_object s, cl_object p); extern void shadowing_import(cl_object s, cl_object p); extern void shadow(cl_object s, cl_object p); extern void use_package(cl_object x0, cl_object p); @@ -591,9 +951,31 @@ extern void init_package_function(void); /* pathname.c */ +extern cl_object cl_pathname(cl_object name); +extern cl_object cl_pathnamep(cl_object pname); +extern cl_object cl_pathname_host(cl_object pname); +extern cl_object cl_pathname_device(cl_object pname); +extern cl_object cl_pathname_directory(cl_object pname); +extern cl_object cl_pathname_name(cl_object pname); +extern cl_object cl_pathname_type(cl_object pname); +extern cl_object cl_pathname_version(cl_object pname); +extern cl_object cl_namestring(cl_object pname); +extern cl_object cl_file_namestring(cl_object pname); +extern cl_object cl_directory_namestring(cl_object pname); +extern cl_object cl_host_namestring(cl_object pname); +extern cl_object si_logical_pathname_p(cl_object pname); +extern cl_object cl_pathname_match_p(cl_object path, cl_object mask); +extern cl_object cl_translate_pathname(cl_object source, cl_object from, cl_object to); +extern cl_object cl_translate_logical_pathname(cl_object source); +extern cl_object cl_parse_namestring _ARGS((int narg, cl_object thing, ...)); +extern cl_object cl_parse_logical_namestring _ARGS((int narg, cl_object thing, ...)); +extern cl_object cl_merge_pathnames _ARGS((int narg, cl_object path, ...)); +extern cl_object cl_make_pathname _ARGS((int narg, ...)); +extern cl_object cl_enough_namestring _ARGS((int narg, cl_object path, ...)); +extern cl_object si_pathname_translations _ARGS((int narg, cl_object host, ...)); + extern cl_object make_pathname(cl_object host, cl_object device, cl_object directory, cl_object name, cl_object type, cl_object version); extern cl_object parse_namestring(const char *s, cl_index start, cl_index end, cl_index *ep, cl_object default_host); -extern cl_object coerce_to_pathname(cl_object x); extern cl_object coerce_to_physical_pathname(cl_object x); extern cl_object coerce_to_file_pathname(cl_object pathname); extern cl_object coerce_to_filename(cl_object pathname); @@ -609,6 +991,36 @@ extern void init_pathname(void); /* predicate.c */ +extern cl_object cl_identity(cl_object x); +extern cl_object cl_null(cl_object x); +extern cl_object cl_symbolp(cl_object x); +extern cl_object cl_atom(cl_object x); +extern cl_object cl_consp(cl_object x); +extern cl_object cl_listp(cl_object x); +extern cl_object cl_numberp(cl_object x); +extern cl_object cl_integerp(cl_object x); +extern cl_object cl_rationalp(cl_object x); +extern cl_object cl_floatp(cl_object x); +extern cl_object cl_realp(cl_object x); +extern cl_object cl_complexp(cl_object x); +extern cl_object cl_characterp(cl_object x); +extern cl_object cl_stringp(cl_object x); +extern cl_object cl_bit_vector_p(cl_object x); +extern cl_object cl_vectorp(cl_object x); +extern cl_object cl_simple_string_p(cl_object x); +extern cl_object cl_simple_bit_vector_p(cl_object x); +extern cl_object cl_simple_vector_p(cl_object x); +extern cl_object cl_arrayp(cl_object x); +extern cl_object cl_packagep(cl_object x); +extern cl_object cl_functionp(cl_object x); +extern cl_object cl_compiled_function_p(cl_object x); +extern cl_object cl_commonp(cl_object x); +extern cl_object cl_eq(cl_object x, cl_object y); +extern cl_object cl_eql(cl_object x, cl_object y); +extern cl_object cl_equal(cl_object x, cl_object y); +extern cl_object cl_equalp(cl_object x, cl_object y); +extern cl_object si_fixnump(cl_object x); + extern bool numberp(cl_object x); extern bool eql(cl_object x, cl_object y); extern bool equal(register cl_object x, cl_object y); @@ -618,6 +1030,22 @@ extern void init_predicate(void); /* print.c */ +extern cl_object cl_write_byte(cl_object integer, cl_object binary_output_stream); +extern cl_object si_write_bytes(cl_object stream, cl_object string, cl_object start, cl_object end); +extern cl_object cl_write _ARGS((int narg, cl_object x, ...)); +extern cl_object cl_prin1 _ARGS((int narg, cl_object obj, ...)); +extern cl_object cl_print _ARGS((int narg, cl_object obj, ...)); +extern cl_object cl_pprint _ARGS((int narg, cl_object obj, ...)); +extern cl_object cl_princ _ARGS((int narg, cl_object obj, ...)); +extern cl_object cl_write_char _ARGS((int narg, cl_object c, ...)); +extern cl_object cl_write_string _ARGS((int narg, cl_object strng, ...)); +extern cl_object cl_write_line _ARGS((int narg, cl_object strng, ...)); +extern cl_object cl_terpri _ARGS((int narg, ...)); +extern cl_object cl_fresh_line _ARGS((int narg, ...)); +extern cl_object cl_force_output _ARGS((int narg, ...)); +#define cl_finish_output cl_force_output +extern cl_object cl_clear_output _ARGS((int narg, ...)); + extern cl_object princ(cl_object obj, cl_object strm); extern cl_object prin1(cl_object obj, cl_object strm); extern cl_object print(cl_object obj, cl_object strm); @@ -631,6 +1059,9 @@ extern void init_print_function(void); /* profile.c */ #ifdef PROFILE +extern cl_object si_profile _ARGS((int narg, cl_object scale, cl_object start_address)); +extern cl_object si_clear_profile _ARGS((int narg)); +extern cl_object si_display_profile _ARGS((int narg)); extern int total_ticks(unsigned short *aar, unsigned int dim); extern int init_profile(void); #endif @@ -643,6 +1074,30 @@ extern void init_prog(void); /* read.c */ +extern cl_object si_read_bytes(cl_object stream, cl_object string, cl_object start, cl_object end); +extern cl_object cl_readtablep(cl_object readtable); +extern cl_object si_string_to_object(cl_object str); +extern cl_object si_standard_readtable(); +extern cl_object cl_read _ARGS((int narg, ...)); +extern cl_object cl_read_preserving_whitespace _ARGS((int narg, ...)); +extern cl_object cl_read_delimited_list _ARGS((int narg, cl_object d, ...)); +extern cl_object cl_read_line _ARGS((int narg, ...)); +extern cl_object cl_read_char _ARGS((int narg, ...)); +extern cl_object cl_unread_char _ARGS((int narg, cl_object c, ...)); +extern cl_object cl_peek_char _ARGS((int narg, ...)); +extern cl_object cl_listen _ARGS((int narg, ...)); +extern cl_object cl_read_char_no_hang _ARGS((int narg, ...)); +extern cl_object cl_clear_input _ARGS((int narg, ...)); +extern cl_object cl_parse_integer _ARGS((int narg, cl_object strng, ...)); +extern cl_object cl_read_byte _ARGS((int narg, cl_object binary_input_stream, ...)); +extern cl_object cl_copy_readtable _ARGS((int narg, ...)); +extern cl_object cl_set_syntax_from_char _ARGS((int narg, cl_object tochr, cl_object fromchr, ...)); +extern cl_object cl_set_macro_character _ARGS((int narg, cl_object chr, cl_object fnc, ...)); +extern cl_object cl_get_macro_character _ARGS((int narg, cl_object chr, ...)); +extern cl_object cl_make_dispatch_macro_character _ARGS((int narg, cl_object chr, ...)); +extern cl_object cl_set_dispatch_macro_character _ARGS((int narg, cl_object dspchr, cl_object subchr, cl_object fnc, ...)); +extern cl_object cl_get_dispatch_macro_character _ARGS((int narg, cl_object dspchr, cl_object subchr, ...)); + extern cl_object standard_readtable; #ifndef THREADS extern bool preserving_whitespace_flag; @@ -663,7 +1118,6 @@ extern cl_object copy_readtable(cl_object from, cl_object to); extern cl_object cl_current_readtable(void); extern int cl_current_read_base(void); extern char cl_current_read_default_float_format(void); -extern cl_object string_to_object(cl_object x); extern cl_object c_string_to_object(const char *s); extern void init_read(void); extern void init_read_function(void); @@ -672,25 +1126,54 @@ extern void read_VV(cl_object block, void *entry); /* reference.c */ +extern cl_object cl_fboundp(cl_object sym); +extern cl_object cl_symbol_function(cl_object sym); +extern cl_object si_coerce_to_function(cl_object form); +extern cl_object cl_symbol_value(cl_object sym); +extern cl_object cl_boundp(cl_object sym); +extern cl_object cl_special_operator_p(cl_object form); +extern cl_object cl_macro_function _ARGS((int narg, cl_object sym, ...)); + extern cl_object symbol_function(cl_object sym); -extern cl_object make_lambda(cl_object name, cl_object lambda); extern void init_reference(void); /* sequence.c */ +extern cl_object cl_elt(cl_object x, cl_object i); +extern cl_object si_elt_set(cl_object seq, cl_object index, cl_object val); +extern cl_object cl_copy_seq(cl_object x); +extern cl_object cl_length(cl_object x); +extern cl_object cl_reverse(cl_object x); +extern cl_object cl_nreverse(cl_object x); +extern cl_object cl_subseq _ARGS((int narg, cl_object sequence, cl_object start, ...)); + extern cl_object cl_alloc_simple_vector(int l, cl_elttype aet); extern cl_object cl_alloc_simple_bitvector(int l); extern cl_object elt(cl_object seq, cl_fixnum index); extern cl_object elt_set(cl_object seq, cl_fixnum index, cl_object val); extern cl_fixnum length(cl_object x); -extern cl_object reverse(cl_object seq); -extern cl_object nreverse(cl_object seq); extern void init_sequence(void); /* stacks.c */ +extern cl_object si_ihs_top(cl_object arg); +extern cl_object si_ihs_fun(cl_object arg); +extern cl_object si_ihs_env(cl_object arg); +extern cl_object si_ihs_next(cl_object arg); +extern cl_object si_ihs_prev(cl_object arg); +extern cl_object si_frs_top(); +extern cl_object si_frs_bds(cl_object arg); +extern cl_object si_frs_class(cl_object arg); +extern cl_object si_frs_tag(cl_object arg); +extern cl_object si_frs_ihs(cl_object arg); +extern cl_object si_bds_top(); +extern cl_object si_bds_var(cl_object arg); +extern cl_object si_bds_val(cl_object arg); +extern cl_object si_sch_frs_base(cl_object fr, cl_object ihs); +extern cl_object si_reset_stack_limits(); + extern void bds_overflow(void) __attribute__((noreturn)); extern void bds_unwind(bds_ptr new_bds_top); extern int frs_overflow(void) __attribute__((noreturn)); @@ -702,13 +1185,39 @@ extern void init_stacks(int *); /* string.c */ +extern cl_object cl_char(cl_object s, cl_object i); +extern cl_object si_char_set(cl_object str, cl_object index, cl_object c); +extern cl_object cl_string_trim(cl_object char_bag, cl_object strng); +extern cl_object cl_string_left_trim(cl_object char_bag, cl_object strng); +extern cl_object cl_string_right_trim(cl_object char_bag, cl_object strng); +extern cl_object cl_string(cl_object x); +extern cl_object cl_make_string _ARGS((int narg, cl_object size, ...)); +extern cl_object cl_stringE _ARGS((int narg, cl_object string1, cl_object string2, ...)); +extern cl_object cl_string_equal _ARGS((int narg, cl_object string1, cl_object string2, ...)); +extern cl_object cl_stringL _ARGS((int narg, ...)); +extern cl_object cl_stringG _ARGS((int narg, ...)); +extern cl_object cl_stringLE _ARGS((int narg, ...)); +extern cl_object cl_stringGE _ARGS((int narg, ...)); +extern cl_object cl_stringNE _ARGS((int narg, ...)); +extern cl_object cl_string_lessp _ARGS((int narg, ...)); +extern cl_object cl_string_greaterp _ARGS((int narg, ...)); +extern cl_object cl_string_not_greaterp _ARGS((int narg, ...)); +extern cl_object cl_string_not_lessp _ARGS((int narg, ...)); +extern cl_object cl_string_not_equal _ARGS((int narg, ...)); +extern cl_object cl_string_upcase _ARGS((int narg, ...)); +extern cl_object cl_string_downcase _ARGS((int narg, ...)); +extern cl_object cl_string_capitalize _ARGS((int narg, ...)); +extern cl_object cl_nstring_upcase _ARGS((int narg, ...)); +extern cl_object cl_nstring_downcase _ARGS((int narg, ...)); +extern cl_object cl_nstring_capitalize _ARGS((int narg, ...)); +extern cl_object si_string_concatenate _ARGS((int narg, ...)); + extern cl_object cl_alloc_simple_string(cl_index l); extern cl_object cl_alloc_adjustable_string(cl_index l); extern cl_object make_simple_string(char *s); #define make_constant_string(s) (make_simple_string((char *)s)) extern cl_object make_string_copy(const char *s); extern cl_object copy_simple_string(cl_object x); -extern cl_object coerce_to_string(cl_object x); extern cl_object coerce_to_string_designator(cl_object x); extern bool string_eq(cl_object x, cl_object y); extern bool string_equal(cl_object x, cl_object y); @@ -720,6 +1229,16 @@ extern void init_string(void); /* structure.c */ +extern cl_object si_structure_subtype_p(cl_object x, cl_object y); +extern cl_object si_copy_structure(cl_object x); +extern cl_object si_structure_name(cl_object s); +extern cl_object si_structure_ref(cl_object x, cl_object type, cl_object index); +extern cl_object si_structure_set(cl_object x, cl_object type, cl_object index, cl_object val); +extern cl_object si_structurep(cl_object s); +extern cl_object si_rplaca_nthcdr(cl_object x, cl_object idx, cl_object v); +extern cl_object si_list_nth(cl_object idx, cl_object x); +extern cl_object si_make_structure _ARGS((int narg, cl_object type, ...)); + extern bool structure_subtypep(cl_object x, cl_object y); extern cl_object structure_to_list(cl_object x); extern cl_object structure_ref(cl_object x, cl_object name, int n); @@ -729,16 +1248,32 @@ extern void init_structure(void); /* symbol.c */ +extern cl_object cl_make_symbol(cl_object str); +extern cl_object cl_remprop(cl_object sym, cl_object prop); +extern cl_object cl_symbol_plist(cl_object sym); +extern cl_object cl_get_properties(cl_object place, cl_object indicator_list); +extern cl_object cl_symbol_name(cl_object sym); +extern cl_object cl_symbol_package(cl_object sym); +extern cl_object cl_keywordp(cl_object sym); +extern cl_object si_put_f(cl_object plist, cl_object value, cl_object indicator); +extern cl_object si_rem_f(cl_object plist, cl_object indicator); +extern cl_object si_set_symbol_plist(cl_object sym, cl_object plist); +extern cl_object si_putprop(cl_object sym, cl_object value, cl_object indicator); +extern cl_object si_Xmake_special(cl_object sym); +extern cl_object si_Xmake_constant(cl_object sym, cl_object val); +extern cl_object cl_get _ARGS((int narg, cl_object sym, cl_object indicator, ...)); +extern cl_object cl_getf _ARGS((int narg, cl_object place, cl_object indicator, ...)); +extern cl_object cl_copy_symbol _ARGS((int narg, cl_object sym, ...)); +extern cl_object cl_gensym _ARGS((int narg, ...)); +extern cl_object cl_gentemp _ARGS((int narg, ...)); +extern cl_object si_put_properties _ARGS((int narg, cl_object sym, ...)); + #ifndef THREADS extern cl_object cl_token; #endif +extern void cl_defvar(cl_object s, cl_object v); +extern void cl_defparameter(cl_object s, cl_object v); extern cl_object make_symbol(cl_object st); -extern cl_object make_ordinary(const char *s); -extern cl_object make_special(const char *s, cl_object v); -extern cl_object make_constant(const char *s, cl_object v); -extern cl_object make_si_ordinary(const char *s); -extern cl_object make_si_special(const char *s, cl_object v); -extern cl_object make_si_constant(const char *s, cl_object v); extern cl_object make_keyword(const char *s); extern cl_object symbol_value(cl_object s); extern cl_object getf(cl_object place, cl_object indicator, cl_object deflt); @@ -791,6 +1326,10 @@ extern void Tcl_ChangeValue(char *var); /* tcp.c */ #ifdef TCP +extern cl_object si_open_client_stream(cl_object host, cl_object port); +extern cl_object si_open_server_stream(cl_object port); +extern cl_object si_open_unix_socket_stream(cl_object path); +extern cl_object si_lookup_host_entry(cl_object host_or_address); extern cl_object make_stream(cl_object host, int fd, enum smmode smm); extern int init_tcp(void); #endif @@ -798,6 +1337,13 @@ extern int init_tcp(void); /* time.c */ +extern cl_object cl_get_universal_time(); +extern cl_object cl_sleep(cl_object z); +extern cl_object cl_get_internal_run_time(); +extern cl_object cl_get_internal_real_time(); +extern cl_object si_get_local_time_zone(); +extern cl_object si_daylight_saving_time_p _ARGS((int narg, ...)); + extern int runtime(void); extern cl_object UTC_time_to_universal_time(int i); extern void init_unixtime(void); @@ -820,6 +1366,14 @@ extern void init_toplevel(void); /* typespec.c */ +extern cl_object TSor_string_symbol; +extern cl_object TSor_symbol_string_package; +extern cl_object TSnon_negative_integer; +extern cl_object TSpositive_number; +extern cl_object TSor_integer_float; +extern cl_object TSor_rational_float; +extern cl_object TSor_pathname_string_symbol; +extern cl_object TSor_pathname_string_symbol_stream; extern void assert_type_integer(cl_object p); extern void assert_type_non_negative_integer(cl_object p); extern void assert_type_character(cl_object p); @@ -834,7 +1388,7 @@ extern void assert_type_array(cl_object p); extern void assert_type_vector(cl_object p); extern void assert_type_list(cl_object p); extern void assert_type_proper_list(cl_object p); -extern cl_object TYPE_OF(cl_object x); +extern cl_object cl_type_of(cl_object x); extern void init_typespec(void); extern void init_typespec_function(void); @@ -855,6 +1409,18 @@ extern void FEtype_error_string(cl_object x) __attribute__((noreturn)); /* unixfsys.c */ +extern cl_object cl_truename(cl_object file); +extern cl_object cl_rename_file(cl_object old_obj, cl_object new_obj); +extern cl_object cl_delete_file(cl_object file); +extern cl_object cl_probe_file(cl_object file); +extern cl_object cl_file_write_date(cl_object file); +extern cl_object cl_file_author(cl_object file); +extern cl_object si_chdir(cl_object directory); +extern cl_object si_mkdir(cl_object directory, cl_object mode); +extern cl_object si_string_match(cl_object string, cl_object pattern); +extern cl_object cl_user_homedir_pathname _ARGS((int narg, ...)); +extern cl_object cl_directory _ARGS((int narg, ...)); + extern const char *expand_pathname(const char *name); extern cl_object string_to_pathname(char *s); extern cl_object truename(cl_object pathname); @@ -868,6 +1434,8 @@ extern void FEfilesystem_error(const char *msg, int narg, ...); /* unixint.c */ +extern cl_object si_catch_bad_signals(); +extern cl_object si_uncatch_bad_signals(); extern int interrupt_enable; extern int interrupt_flag; extern void signal_catcher(int sig, int code, int scp); @@ -877,6 +1445,8 @@ extern void init_interrupt(void); /* unixsys.c */ +extern cl_object si_system(cl_object cmd); +extern cl_object si_open_pipe(cl_object cmd); extern void init_unixsys(void); /* unexec.c */ diff --git a/src/h/lisp_external.h b/src/h/lisp_external.h deleted file mode 100644 index 236d80f72..000000000 --- a/src/h/lisp_external.h +++ /dev/null @@ -1,1058 +0,0 @@ -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef _ARGS -#define _ARGS(x) (int n, ...) -#endif - -/* alloc.c */ - -#if !defined(GBC_BOEHM) -extern cl_object siLallocate _ARGS((int narg, cl_object type, cl_object qty, ...)); -extern cl_object siLmaximum_allocatable_pages _ARGS((int narg, cl_object type)); -extern cl_object siLallocated_pages _ARGS((int narg, cl_object type)); -extern cl_object siLalloc_contpage _ARGS((int narg, cl_object qty, ...)); -extern cl_object siLallocated_contiguous_pages _ARGS((int narg)); -extern cl_object siLmaximum_contiguous_pages _ARGS((int narg)); -extern cl_object siLallocate_contiguous_pages _ARGS((int narg, cl_object qty, ...)); -extern cl_object siLget_hole_size _ARGS((int narg)); -extern cl_object siLset_hole_size _ARGS((int narg, cl_object size)); -extern cl_object siLignore_maximum_pages _ARGS((int narg, ...)); -#endif - -/* alloc_2.c */ - -#ifdef GBC_BOEHM -extern cl_object siVgc_verbose; -extern cl_object siVgc_message; -extern cl_object clLgc _ARGS((int narg, cl_object area)); -extern cl_object siLroom_report _ARGS((int narg)); -#endif /* GBC_BOEHM */ - -/* all_symbols.c */ - -extern cl_object siLmangle_name _ARGS((int narg, cl_object symbol, ...)); - -/* array.c */ - -extern cl_object clSbyte8, clSinteger8; -extern cl_object clLaref _ARGS((int narg, cl_object x, ...)); -extern cl_object siLaset _ARGS((int narg, cl_object v, cl_object x, ...)); -extern cl_object clLrow_major_aref _ARGS((int narg, cl_object x, cl_object i)); -extern cl_object siLrow_major_aset _ARGS((int narg, cl_object x, cl_object i, cl_object v)); -extern cl_object siLmake_pure_array _ARGS((int narg, cl_object etype, cl_object adj, cl_object displ, cl_object disploff, ...)); -extern cl_object siLmake_vector _ARGS((int narg, cl_object etype, cl_object dim, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff)); -extern cl_object clLarray_element_type _ARGS((int narg, cl_object a)); -extern cl_object clLarray_rank _ARGS((int narg, cl_object a)); -extern cl_object clLarray_dimension _ARGS((int narg, cl_object a, cl_object index)); -extern cl_object clLarray_total_size _ARGS((int narg, cl_object a)); -extern cl_object clLadjustable_array_p _ARGS((int narg, cl_object a)); -extern cl_object siLdisplaced_array_p _ARGS((int narg, cl_object a)); -extern cl_object clLsvref _ARGS((int narg, cl_object x, cl_object index)); -extern cl_object siLsvset _ARGS((int narg, cl_object x, cl_object index, cl_object v)); -extern cl_object clLarray_has_fill_pointer_p _ARGS((int narg, cl_object a)); -extern cl_object clLfill_pointer _ARGS((int narg, cl_object a)); -extern cl_object siLfill_pointer_set _ARGS((int narg, cl_object a, cl_object fp)); -extern cl_object siLreplace_array _ARGS((int narg, cl_object old_obj, cl_object new_obj)); - -/* assignment.c */ - -extern cl_object clSsetf, clSpsetf, siSsetf_symbol; -extern cl_object siSsetf_lambda, siSsetf_method, siSsetf_update; -extern cl_object siSclear_compiler_properties; -#ifdef PDE -extern cl_object siVrecord_source_pathname_p; -extern cl_object siSrecord_source_pathname; -#endif -extern cl_object clLset _ARGS((int narg, cl_object var, cl_object val)); -extern cl_object siLsetf_namep _ARGS((int narg, cl_object arg)); -extern cl_object siLfset _ARGS((int narg, cl_object fun, cl_object def, ...)); -extern cl_object clLmakunbound _ARGS((int narg, cl_object sym)); -extern cl_object clLfmakunbound _ARGS((int narg, cl_object sym)); -extern cl_object siLclear_compiler_properties _ARGS((int narg, cl_object sym)); - -/* backq.c */ - -extern cl_object siScomma; -extern cl_object siScomma_at; -extern cl_object siScomma_dot; -extern cl_object clSlistX; -extern cl_object clSappend; -extern cl_object clSnconc; -extern cl_object clLcomma_reader _ARGS((int narg, cl_object in, cl_object c)); -extern cl_object clLbackquote_reader _ARGS((int narg, cl_object in, cl_object c)); - -/* cfun.c */ - -#ifdef PDE -extern cl_object siSdefun; -extern cl_object siSdefmacro; -#endif -extern cl_object siLcompiled_function_name _ARGS((int narg, cl_object fun)); -extern cl_object siLcompiled_function_block _ARGS((int narg, cl_object fun)); -extern cl_object siLcompiled_function_source _ARGS((int narg, cl_object fun)); - -/* character.c */ - -extern cl_object clLstandard_char_p _ARGS((int narg, cl_object c)); -extern cl_object clLgraphic_char_p _ARGS((int narg, cl_object c)); -extern cl_object clLalpha_char_p _ARGS((int narg, cl_object c)); -extern cl_object clLupper_case_p _ARGS((int narg, cl_object c)); -extern cl_object clLlower_case_p _ARGS((int narg, cl_object c)); -extern cl_object clLboth_case_p _ARGS((int narg, cl_object c)); -extern cl_object clLdigit_char_p _ARGS((int narg, cl_object c, ...)); -extern cl_object clLalphanumericp _ARGS((int narg, cl_object c)); -extern cl_object clLcharE _ARGS((int narg, cl_object c, ...)); -extern cl_object clLcharNE _ARGS((int narg, ...)); -extern cl_object clLcharL _ARGS((int narg, ...)); -extern cl_object clLcharG _ARGS((int narg, ...)); -extern cl_object clLcharLE _ARGS((int narg, ...)); -extern cl_object clLcharGE _ARGS((int narg, ...)); -extern cl_object clLchar_equal _ARGS((int narg, cl_object c, ...)); -extern cl_object clLchar_not_equal _ARGS((int narg, ...)); -extern cl_object clLchar_lessp _ARGS((int narg, ...)); -extern cl_object clLchar_greaterp _ARGS((int narg, ...)); -extern cl_object clLchar_not_greaterp _ARGS((int narg, ...)); -extern cl_object clLchar_not_lessp _ARGS((int narg, ...)); -extern cl_object clLcharacter _ARGS((int narg, cl_object x)); -extern cl_object clLchar_code _ARGS((int narg, cl_object c)); -extern cl_object clLcode_char _ARGS((int narg, cl_object c)); -extern cl_object clLchar_upcase _ARGS((int narg, cl_object c)); -extern cl_object clLchar_downcase _ARGS((int narg, cl_object c)); -extern cl_object clLdigit_char _ARGS((int narg, cl_object w, ...)); -extern cl_object clLchar_int _ARGS((int narg, cl_object c)); -extern cl_object clLint_char _ARGS((int narg, cl_object x)); -extern cl_object clLchar_name _ARGS((int narg, cl_object c)); -extern cl_object clLname_char _ARGS((int narg, cl_object s)); - -/* clos.c */ - -#ifdef CLOS -extern cl_object siVclass_name_hash_table; -extern cl_object clSclass; -extern cl_object clSbuilt_in_class; -extern cl_object clLfind_class _ARGS((int narg, cl_object name, ...)); -#endif - -/* cmpaux.c */ - -extern cl_object clSAoptional; -extern cl_object clSArest; -extern cl_object clSAkey; -extern cl_object clSAallow_other_keys; -extern cl_object clSAaux; -extern cl_object Kallow_other_keys; -extern cl_object siLspecialp _ARGS((int narg, cl_object sym)); - -/* compiler.c */ - -extern cl_object clSlambda_block; -extern cl_object clSdeclare; -extern cl_object clScompile; -extern cl_object clSload; -extern cl_object clSeval; -extern cl_object clSprogn; -extern cl_object clSwarn; -extern cl_object clStypep; -extern cl_object Kexecute; -extern cl_object Kcompile_toplevel; -extern cl_object Kload_toplevel; -extern cl_object clSotherwise; -extern cl_object siVkeep_definitions; -extern cl_object siLprocess_declarations _ARGS((int narg, cl_object body, ...)); -extern cl_object siLprocess_lambda_list _ARGS((int narg, cl_object lambda)); -extern cl_object siLmake_lambda _ARGS((int narg, cl_object name, cl_object body)); -extern cl_object siLfunction_block_name _ARGS((int narg, cl_object name)); - -/* disassembler.c */ - -extern cl_object siLbc_disassemble _ARGS((int narg, cl_object v)); -extern cl_object siLbc_split _ARGS((int narg, cl_object v)); - -/* error.c */ - -extern cl_object clSarithmetic_error, clScell_error, clScondition; -extern cl_object clScontrol_error, clSdivision_by_zero, clSend_of_file; -extern cl_object clSerror, clSfile_error, clSfloating_point_inexact; -extern cl_object clSfloating_point_invalid_operation, clSfloating_point_overflow; -extern cl_object clSfloating_point_underflow, clSpackage_error, clSparse_error; -extern cl_object clSprint_not_readable, clSprogram_error, clSreader_error; -extern cl_object clSserious_condition, clSsimple_condition, clSsimple_error; -extern cl_object clSsimple_type_error, clSsimple_warning, clSstorage_condition; -extern cl_object clSstream_error, clSstyle_warning, clStype_error, clSunbound_slot; -extern cl_object clSunbound_variable, clSundefined_function, clSwarning; - -extern cl_object siSsimple_program_error, siSsimple_control_error; - -extern cl_object Kdatum, Kexpected_type; -extern cl_object Kpathname; -extern cl_object Kformat_control, Kformat_arguments; - -extern cl_object siSuniversal_error_handler; -extern cl_object siSterminal_interrupt; -extern cl_object clLerror _ARGS((int narg, cl_object eformat, ...)); -extern cl_object clLcerror _ARGS((int narg, cl_object cformat, cl_object eformat, ...)); - -/* eval.c */ - -extern cl_object clSapply; -extern cl_object clSfuncall; -extern cl_object siLunlink_symbol _ARGS((int narg, cl_object s)); -extern cl_object clLfuncall _ARGS((int narg, cl_object fun, ...)); -extern cl_object clLapply _ARGS((int narg, cl_object fun, cl_object arg, ...)); -extern cl_object clLeval _ARGS((int narg, cl_object form)); -extern cl_object siLeval_with_env _ARGS((int n, cl_object form, cl_object env)); -extern cl_object siLsafe_eval _ARGS((int n, cl_object form, ...)); -extern cl_object clLconstantp _ARGS((int narg, cl_object arg)); - -/* file.c */ - -extern cl_object Kerror; -extern cl_object clVstandard_input; -extern cl_object clVstandard_output; -extern cl_object clVerror_output; -extern cl_object clVquery_io; -extern cl_object clVdebug_io; -extern cl_object clVterminal_io; -extern cl_object clVtrace_output; -extern cl_object Kabort; -extern cl_object Kdirection; -extern cl_object Kinput; -extern cl_object Koutput; -extern cl_object Kio; -extern cl_object Kprobe; -extern cl_object Kelement_type; -extern cl_object Kdefault; -extern cl_object Kif_exists; -extern cl_object Knew_version; -extern cl_object Krename; -extern cl_object Krename_and_delete; -extern cl_object Koverwrite; -extern cl_object Kappend; -extern cl_object Ksupersede; -extern cl_object Kcreate; -extern cl_object Kprint; -extern cl_object Kif_does_not_exist; -extern cl_object Kset_default_pathname; -extern cl_object siVignore_eof_on_terminal_io; -#ifdef ECL_CLOS_STREAMS -extern cl_object clSstream_input_p; -/*extern cl_object clSstream_read_line;*/ -extern cl_object clSstream_read_char; -extern cl_object clSstream_unread_char; -/*extern cl_object clSstream_peek_char;*/ -extern cl_object clSstream_listen; -extern cl_object clSstream_clear_input; -extern cl_object clSstream_output_p; -extern cl_object clSstream_write_char; -/*extern cl_object clSstream_write_string;*/ -extern cl_object clSstream_clear_output; -extern cl_object clSstream_force_output; -extern cl_object clSstream_close; -#endif /* ECL_CLOS_STREAMS */ -extern cl_object clLmake_synonym_stream _ARGS((int narg, cl_object sym)); -extern cl_object clLmake_broadcast_stream _ARGS((int narg, ...)); -extern cl_object clLmake_concatenated_stream _ARGS((int narg, ...)); -extern cl_object clLmake_two_way_stream _ARGS((int narg, cl_object strm1, cl_object strm2)); -extern cl_object clLmake_echo_stream _ARGS((int narg, cl_object strm1, cl_object strm2)); -extern cl_object clLmake_string_input_stream _ARGS((int narg, cl_object strng, ...)); -extern cl_object clLmake_string_output_stream _ARGS((int narg)); -extern cl_object clLget_output_stream_string _ARGS((int narg, cl_object strm)); -extern cl_object siLoutput_stream_string _ARGS((int narg, cl_object strm)); -extern cl_object clLstreamp _ARGS((int narg, cl_object strm)); -extern cl_object clLinput_stream_p _ARGS((int narg, cl_object strm)); -extern cl_object clLoutput_stream_p _ARGS((int narg, cl_object strm)); -extern cl_object clLstream_element_type _ARGS((int narg, cl_object strm)); -extern cl_object clLclose _ARGS((int narg, cl_object strm, ...)); -extern cl_object clLopen _ARGS((int narg, cl_object filename, ...)); -extern cl_object clLfile_position _ARGS((int narg, cl_object file_stream, ...)); -extern cl_object clLfile_length _ARGS((int narg, cl_object strm)); -extern cl_object siLget_string_input_stream_index _ARGS((int narg, cl_object strm)); -extern cl_object siLmake_string_output_stream_from_string _ARGS((int narg, cl_object strng)); -extern cl_object siLcopy_stream _ARGS((int narg, cl_object in, cl_object out)); -extern cl_object clLopen_stream_p _ARGS((int narg, cl_object strm)); - -/* format.c */ - -extern cl_object siVindent_formatted_output; -extern cl_object clLformat _ARGS((int narg, volatile cl_object strm, cl_object string, ...)); - -/* gbc.c */ - -#if !defined(GBC_BOEHM) -extern cl_object siVgc_verbose; -extern cl_object siVgc_message; -extern cl_object clLgc _ARGS((int narg, cl_object area)); -extern cl_object siLroom_report _ARGS((int narg)); -extern cl_object siLreset_gc_count _ARGS((int narg)); -extern cl_object siLgc_time _ARGS((int narg)); -#endif /* !GBC_BOHEM */ - -/* gfun.c */ - -extern cl_object siScompute_applicable_methods; -extern cl_object siScompute_effective_method; -extern cl_object siSgeneric_function_method_combination; -extern cl_object siSgeneric_function_method_combination_args; -extern cl_object siLallocate_gfun _ARGS((int narg, cl_object name, cl_object arg_no, cl_object ht)); -extern cl_object siLgfun_name _ARGS((int narg, cl_object x)); -extern cl_object siLgfun_name_set _ARGS((int narg, cl_object x, cl_object name)); -extern cl_object siLgfun_method_ht _ARGS((int narg, cl_object x)); -extern cl_object siLgfun_method_ht_set _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object siLgfun_spec_how_ref _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object siLgfun_spec_how_set _ARGS((int narg, cl_object x, cl_object y, cl_object spec)); -extern cl_object siLgfun_instance _ARGS((int narg, cl_object x)); -extern cl_object siLgfun_instance_set _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object siLgfunp _ARGS((int narg, cl_object x)); -extern cl_object siLmethod_ht_get _ARGS((int narg, cl_object keylist, cl_object table)); -extern cl_object siLset_compiled_function_name _ARGS((int narg, cl_object keylist, cl_object table)); - -/* hash.c */ - -extern cl_object clSeq; -extern cl_object clSeql; -extern cl_object clSequal; -extern cl_object Ksize; -extern cl_object Krehash_size; -extern cl_object Krehash_threshold; -extern cl_object clLmake_hash_table _ARGS((int narg, ...)); -extern cl_object clLhash_table_p _ARGS((int narg, cl_object ht)); -extern cl_object clLgethash _ARGS((int narg, cl_object key, cl_object ht, ...)); -extern cl_object siLhash_set _ARGS((int narg, cl_object key, cl_object ht, cl_object val)); -extern cl_object clLremhash _ARGS((int narg, cl_object key, cl_object ht)); -extern cl_object clLclrhash _ARGS((int narg, cl_object ht)); -extern cl_object clLhash_table_count _ARGS((int narg, cl_object ht)); -extern cl_object clLsxhash _ARGS((int narg, cl_object key)); -extern cl_object clLmaphash _ARGS((int narg, cl_object fun, cl_object ht)); -extern cl_object clLhash_table_rehash_size _ARGS((int narg, cl_object ht)); -extern cl_object clLhash_table_rehash_threshold _ARGS((int narg, cl_object ht)); - -/* instance.c */ - -#ifdef CLOS -extern cl_object clSprint_object; -extern cl_object siLallocate_instance _ARGS((int narg, cl_object clas, cl_object size)); -extern cl_object siLchange_instance _ARGS((int narg, cl_object x, cl_object clas, cl_object size, cl_object corr)); -extern cl_object siLinstance_class _ARGS((int narg, cl_object x)); -extern cl_object siLinstance_class_set _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object siLinstance_ref _ARGS((int narg, cl_object x, cl_object index)); -extern cl_object siLinstance_ref_safe _ARGS((int narg, cl_object x, cl_object index)); -extern cl_object siLinstance_set _ARGS((int narg, cl_object x, cl_object index, cl_object value)); -extern cl_object siLinstancep _ARGS((int narg, cl_object x)); -extern cl_object siLunbound _ARGS((int narg)); -extern cl_object siLsl_boundp _ARGS((int narg, cl_object x)); -extern cl_object siLsl_makunbound _ARGS((int narg, cl_object x, cl_object index)); -#endif - -/* interpreter.c */ - -extern cl_object siLinterpreter_stack _ARGS((int narg)); - -/* lex.c */ - -extern cl_object Kblock; -extern cl_object Ktag; -extern cl_object Kfunction; -extern cl_object clSblock; -extern cl_object clSmacro; -extern cl_object siSsymbol_macro; -extern cl_object clStag; -extern cl_object siLlex_env _ARGS((int narg)); - -/* list.c */ - -extern cl_object Ktest; -extern cl_object Ktest_not; -extern cl_object Kkey; -extern cl_object Kinitial_element; -extern cl_object clLcar _ARGS((int narg, cl_object x)); -extern cl_object clLcdr _ARGS((int narg, cl_object x)); -extern cl_object clLlist _ARGS((int narg, ...)); -extern cl_object clLlistX _ARGS((int narg, ...)); -extern cl_object clLappend _ARGS((int narg, ...)); -extern cl_object clLcaar _ARGS((int narg, cl_object x)); -extern cl_object clLcadr _ARGS((int narg, cl_object x)); -extern cl_object clLcdar _ARGS((int narg, cl_object x)); -extern cl_object clLcddr _ARGS((int narg, cl_object x)); -extern cl_object clLcaaar _ARGS((int narg, cl_object x)); -extern cl_object clLcaadr _ARGS((int narg, cl_object x)); -extern cl_object clLcadar _ARGS((int narg, cl_object x)); -extern cl_object clLcaddr _ARGS((int narg, cl_object x)); -extern cl_object clLcdaar _ARGS((int narg, cl_object x)); -extern cl_object clLcdadr _ARGS((int narg, cl_object x)); -extern cl_object clLcddar _ARGS((int narg, cl_object x)); -extern cl_object clLcdddr _ARGS((int narg, cl_object x)); -extern cl_object clLcaaaar _ARGS((int narg, cl_object x)); -extern cl_object clLcaaadr _ARGS((int narg, cl_object x)); -extern cl_object clLcaadar _ARGS((int narg, cl_object x)); -extern cl_object clLcaaddr _ARGS((int narg, cl_object x)); -extern cl_object clLcadaar _ARGS((int narg, cl_object x)); -extern cl_object clLcadadr _ARGS((int narg, cl_object x)); -extern cl_object clLcaddar _ARGS((int narg, cl_object x)); -extern cl_object clLcadddr _ARGS((int narg, cl_object x)); -extern cl_object clLcdaaar _ARGS((int narg, cl_object x)); -extern cl_object clLcdaadr _ARGS((int narg, cl_object x)); -extern cl_object clLcdadar _ARGS((int narg, cl_object x)); -extern cl_object clLcdaddr _ARGS((int narg, cl_object x)); -extern cl_object clLcddaar _ARGS((int narg, cl_object x)); -extern cl_object clLcddadr _ARGS((int narg, cl_object x)); -extern cl_object clLcdddar _ARGS((int narg, cl_object x)); -extern cl_object clLcddddr _ARGS((int narg, cl_object x)); -extern cl_object clLfifth _ARGS((int narg, cl_object x)); -extern cl_object clLsixth _ARGS((int narg, cl_object x)); -extern cl_object clLseventh _ARGS((int narg, cl_object x)); -extern cl_object clLeighth _ARGS((int narg, cl_object x)); -extern cl_object clLninth _ARGS((int narg, cl_object x)); -extern cl_object clLtenth _ARGS((int narg, cl_object x)); -extern cl_object clLcons _ARGS((int narg, cl_object car, cl_object cdr)); -extern cl_object clLtree_equal _ARGS((int narg, cl_object x, cl_object y, ...)); -extern cl_object clLendp _ARGS((int narg, cl_object x)); -extern cl_object clLlist_length _ARGS((int narg, cl_object x)); -extern cl_object clLnth _ARGS((int narg, cl_object n, cl_object x)); -extern cl_object clLnthcdr _ARGS((int narg, cl_object n, cl_object x)); -extern cl_object clLlast _ARGS((int narg, cl_object x, ...)); -extern cl_object clLmake_list _ARGS((int narg, cl_object size, ...)); -extern cl_object clLcopy_list _ARGS((int narg, cl_object x)); -extern cl_object clLcopy_alist _ARGS((int narg, cl_object x)); -extern cl_object clLcopy_tree _ARGS((int narg, cl_object x)); -extern cl_object clLrevappend _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLnconc _ARGS((int narg, ...)); -extern cl_object clLnreconc _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLbutlast _ARGS((int narg, cl_object lis, ...)); -extern cl_object clLnbutlast _ARGS((int narg, cl_object lis, ...)); -extern cl_object clLldiff _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLrplaca _ARGS((int narg, cl_object x, cl_object v)); -extern cl_object clLrplacd _ARGS((int narg, cl_object x, cl_object v)); -extern cl_object clLsubst _ARGS((int narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); -extern cl_object clLsubst_if _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); -extern cl_object clLsubst_if_not _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); -extern cl_object clLnsubst _ARGS((int narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); -extern cl_object clLnsubst_if _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); -extern cl_object clLnsubst_if_not _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val)); -extern cl_object clLsublis _ARGS((int narg, cl_object alist, cl_object tree, ...)); -extern cl_object clLnsublis _ARGS((int narg, cl_object alist, cl_object tree, ...)); -extern cl_object clLmember _ARGS((int narg, cl_object item, cl_object list, ...)); -extern cl_object siLmemq _ARGS((int narg, cl_object x, cl_object l)); -extern cl_object clLmember_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); -extern cl_object clLmember_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); -extern cl_object siLmember1 _ARGS((int narg, cl_object item, cl_object list, ...)); -extern cl_object clLtailp _ARGS((int narg, cl_object y, cl_object x)); -extern cl_object clLadjoin _ARGS((int narg, cl_object item, cl_object list, cl_object k1, cl_object v1, cl_object k2, cl_object v2, cl_object k3, cl_object v3)); -extern cl_object clLacons _ARGS((int narg, cl_object x, cl_object y, cl_object z)); -extern cl_object clLpairlis _ARGS((int narg, cl_object keys, cl_object data, ...)); -extern cl_object clLrassoc _ARGS((int narg, cl_object item, cl_object alist, ...)); -extern cl_object clLassoc _ARGS((int narg, cl_object item, cl_object alist, ...)); -extern cl_object clLassoc_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); -extern cl_object clLassoc_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); -extern cl_object clLrassoc_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); -extern cl_object clLrassoc_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val)); - -/* load.c */ - -extern cl_object Kverbose; -extern cl_object clVload_verbose, clVload_print; -extern cl_object siVload_hooks; -extern cl_object siVinit_function_prefix; -extern cl_object clLload _ARGS((int narg, cl_object pathname, ...)); -extern cl_object siLload_source _ARGS((int narg, cl_object file, cl_object verbose, - cl_object print)); -extern cl_object siLload_binary _ARGS((int narg, cl_object file, cl_object verbose, - cl_object print)); - -/* lwp.c */ - -#ifdef THREADS -extern cl_object clSrunning; -extern cl_object clSsuspended; -extern cl_object clSwaiting; -extern cl_object clSstopped; -extern cl_object clSdead; -extern cl_object siSthread_top_level; -extern cl_object siLthread_break_in _ARGS((int narg)); -extern cl_object siLthread_break_quit _ARGS((int narg)); -extern cl_object siLthread_break_resume _ARGS((int narg)); -extern cl_object clLthread_list _ARGS((int narg)); -extern cl_object clLmake_thread _ARGS((int narg, cl_object fun)); -extern cl_object clLdeactivate _ARGS((int narg, cl_object thread)); -extern cl_object clLreactivate _ARGS((int narg, cl_object thread)); -extern cl_object clLkill_thread _ARGS((int narg, cl_object thread)); -extern cl_object clLcurrent_thread _ARGS((int narg)); -extern cl_object clLthread_status _ARGS((int narg, cl_object thread)); -extern cl_object clLmake_continuation _ARGS((int narg, cl_object thread)); -extern cl_object clLthread_of _ARGS((int narg, cl_object cont)); -extern cl_object clLcontinuation_of _ARGS((int narg, cl_object thread)); -extern cl_object clLresume _ARGS((int narg, cl_object cont, ...)); -extern cl_object clLdisable_scheduler _ARGS((int narg)); -extern cl_object clLenable_scheduler _ARGS((int narg)); -extern cl_object clLsuspend _ARGS((int narg)); -extern cl_object clLdelay _ARGS((int narg, cl_object interval)); -extern cl_object clLthread_wait _ARGS((int narg, cl_object fun, ...)); -extern cl_object clLthread_wait_with_timeout _ARGS((int narg, cl_object timeout, cl_object fun, ...)); -#endif - -/* macros.c */ - -extern cl_object clVmacroexpand_hook; -extern cl_object siSexpand_defmacro; -extern cl_object siVinhibit_macro_special; -extern cl_object clLmacroexpand _ARGS((int narg, cl_object form, ...)); -extern cl_object clLmacroexpand_1 _ARGS((int narg, cl_object form, ...)); - -/* main.c */ - -extern cl_object clVfeatures; -extern cl_object clLquit _ARGS((int narg, ...)); -extern cl_object siLargc _ARGS((int narg)); -extern cl_object siLargv _ARGS((int narg, cl_object index)); -extern cl_object siLgetenv _ARGS((int narg, cl_object var)); -extern cl_object siLsetenv _ARGS((int narg, cl_object var, cl_object value)); -extern cl_object siLpointer _ARGS((int narg, cl_object x)); -extern cl_object clLidentity _ARGS((int narg, cl_object x)); - -/* mapfun.c */ - -extern cl_object clLmapcar _ARGS((int narg, cl_object fun, ...)); -extern cl_object clLmaplist _ARGS((int narg, cl_object fun, ...)); -extern cl_object clLmapc _ARGS((int narg, cl_object fun, ...)); -extern cl_object clLmapl _ARGS((int narg, cl_object fun, ...)); -extern cl_object clLmapcan _ARGS((int narg, cl_object fun, ...)); -extern cl_object clLmapcon _ARGS((int narg, cl_object fun, ...)); - -/* multival.c */ - -extern cl_object clLvalues _ARGS((int narg, ...)); -extern cl_object clLvalues_list _ARGS((int narg, cl_object list)); - -/* num_arith.c */ - -extern cl_object clLX _ARGS((int narg, ...)); -extern cl_object clLP _ARGS((int narg, ...)); -extern cl_object clLM _ARGS((int narg, cl_object num, ...)); -extern cl_object clLconjugate _ARGS((int narg, cl_object c)); -extern cl_object clLN _ARGS((int narg, cl_object num, ...)); -extern cl_object clLgcd _ARGS((int narg, ...)); -extern cl_object clL1P _ARGS((int narg, cl_object x)); -extern cl_object clL1M _ARGS((int narg, cl_object x)); -extern cl_object clLlcm _ARGS((int narg, cl_object lcm, ...)); - -/* num_co.c */ - -extern cl_object clLfloat _ARGS((int narg, cl_object x, ...)); -extern cl_object clLnumerator _ARGS((int narg, cl_object x)); -extern cl_object clLdenominator _ARGS((int narg, cl_object x)); -extern cl_object clLfloor _ARGS((int narg, cl_object x, ...)); -extern cl_object clLceiling _ARGS((int narg, cl_object x, ...)); -extern cl_object clLtruncate _ARGS((int narg, cl_object x, ...)); -extern cl_object clLround _ARGS((int narg, cl_object x, ...)); -extern cl_object clLmod _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLrem _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLdecode_float _ARGS((int narg, cl_object x)); -extern cl_object clLscale_float _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLfloat_radix _ARGS((int narg, cl_object x)); -extern cl_object clLfloat_sign _ARGS((int narg, cl_object x, ...)); -extern cl_object clLfloat_digits _ARGS((int narg, cl_object x)); -extern cl_object clLfloat_precision _ARGS((int narg, cl_object x)); -extern cl_object clLinteger_decode_float _ARGS((int narg, cl_object x)); -extern cl_object clLcomplex _ARGS((int narg, cl_object r, ...)); -extern cl_object clLrealpart _ARGS((int narg, cl_object x)); -extern cl_object clLimagpart _ARGS((int narg, cl_object x)); - -/* num_comp.c */ - -extern cl_object clLE _ARGS((int narg, cl_object num, ...)); -extern cl_object clLNE _ARGS((int narg, ...)); -extern cl_object clLL _ARGS((int narg, ...)); -extern cl_object clLG _ARGS((int narg, ...)); -extern cl_object clLGE _ARGS((int narg, ...)); -extern cl_object clLLE _ARGS((int narg, ...)); -extern cl_object clLmax _ARGS((int narg, cl_object max, ...)); -extern cl_object clLmin _ARGS((int narg, cl_object min, ...)); - -/* num_log.c */ - -extern cl_object clLlogior _ARGS((int narg, ...)); -extern cl_object clLlogxor _ARGS((int narg, ...)); -extern cl_object clLlogand _ARGS((int narg, ...)); -extern cl_object clLlogeqv _ARGS((int narg, ...)); -extern cl_object clLlognand _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlognor _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlogandc1 _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlogandc2 _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlogorc1 _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlogorc2 _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlognot _ARGS((int narg, cl_object x)); -extern cl_object clLboole _ARGS((int narg, cl_object o, cl_object x, cl_object y)); -extern cl_object clLlogbitp _ARGS((int narg, cl_object p, cl_object x)); -extern cl_object clLash _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlogcount _ARGS((int narg, cl_object x)); -extern cl_object clLinteger_length _ARGS((int narg, cl_object x)); -extern cl_object siLbit_array_op _ARGS((int narg, cl_object o, cl_object x, cl_object y, cl_object r)); - -/* num_pred.c */ - -extern cl_object clLzerop _ARGS((int narg, cl_object x)); -extern cl_object clLplusp _ARGS((int narg, cl_object x)); -extern cl_object clLminusp _ARGS((int narg, cl_object x)); -extern cl_object clLoddp _ARGS((int narg, cl_object x)); -extern cl_object clLevenp _ARGS((int narg, cl_object x)); - -/* num_rand.c */ - -extern cl_object clVrandom_state; -extern cl_object clLrandom _ARGS((int narg, cl_object x, ...)); -extern cl_object clLmake_random_state _ARGS((int narg, ...)); -extern cl_object clLrandom_state_p _ARGS((int narg, cl_object x)); - -/* num_sfun.c */ - -extern cl_object clLexp _ARGS((int narg, cl_object x)); -extern cl_object clLexpt _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLlog _ARGS((int narg, cl_object x, ...)); -extern cl_object clLsqrt _ARGS((int narg, cl_object x)); -extern cl_object clLsin _ARGS((int narg, cl_object x)); -extern cl_object clLcos _ARGS((int narg, cl_object x)); -extern cl_object clLtan _ARGS((int narg, cl_object x)); -extern cl_object clLatan _ARGS((int narg, cl_object x, ...)); -extern cl_object clLsinh _ARGS((int narg, cl_object x)); -extern cl_object clLcosh _ARGS((int narg, cl_object x)); -extern cl_object clLtanh _ARGS((int narg, cl_object x)); - -/* package.c */ - -extern cl_object clVpackage; -extern cl_object Kinternal; -extern cl_object Kexternal; -extern cl_object Kinherited; -extern cl_object Knicknames; -extern cl_object Kuse; -extern cl_object clLmake_package _ARGS((int narg, cl_object pack_name, ...)); -extern cl_object siLselect_package _ARGS((int narg, cl_object pack_name)); -extern cl_object clLfind_package _ARGS((int narg, cl_object p)); -extern cl_object clLpackage_name _ARGS((int narg, cl_object p)); -extern cl_object clLpackage_nicknames _ARGS((int narg, cl_object p)); -extern cl_object clLrename_package _ARGS((int narg, cl_object pack, cl_object new_name, ...)); -extern cl_object clLpackage_use_list _ARGS((int narg, cl_object p)); -extern cl_object clLpackage_used_by_list _ARGS((int narg, cl_object p)); -extern cl_object clLpackage_shadowing_symbols _ARGS((int narg, cl_object p)); -extern cl_object clLlist_all_packages _ARGS((int narg)); -extern cl_object clLintern _ARGS((int narg, cl_object strng, ...)); -extern cl_object clLfind_symbol _ARGS((int narg, cl_object strng, ...)); -extern cl_object clLunintern _ARGS((int narg, cl_object symbl, ...)); -extern cl_object clLexport _ARGS((int narg, cl_object symbols, ...)); -extern cl_object clLunexport _ARGS((int narg, cl_object symbols, ...)); -extern cl_object clLimport _ARGS((int narg, cl_object symbols, ...)); -extern cl_object clLshadowing_import _ARGS((int narg, cl_object symbols, ...)); -extern cl_object clLshadow _ARGS((int narg, cl_object symbols, ...)); -extern cl_object clLuse_package _ARGS((int narg, cl_object pack, ...)); -extern cl_object clLunuse_package _ARGS((int narg, cl_object pack, ...)); -extern cl_object siLpackage_internal _ARGS((int narg, cl_object p, cl_object index)); -extern cl_object siLpackage_external _ARGS((int narg, cl_object p, cl_object index)); -extern cl_object siLpackage_size _ARGS((int narg, cl_object p)); -extern cl_object siLpackage_lock _ARGS((int narg, cl_object p, cl_object t)); -extern cl_object clLdelete_package _ARGS((int narg, cl_object p)); - -/* pathname.c */ - -extern cl_object clVdefault_pathname_defaults; -extern cl_object Kwild; -extern cl_object Kwild_inferiors; -extern cl_object Knewest; -extern cl_object Khost; -extern cl_object Kdevice; -extern cl_object Kdirectory; -extern cl_object Kname; -extern cl_object Ktype; -extern cl_object Kversion; -extern cl_object Kdefaults; -extern cl_object Kabsolute; -extern cl_object Krelative; -extern cl_object Kup; -extern cl_object Kper; -extern cl_object Kunspecific; -extern cl_object clLpathname _ARGS((int narg, cl_object name)); -extern cl_object clLparse_namestring _ARGS((int narg, cl_object thing, ...)); -extern cl_object clLparse_logical_namestring _ARGS((int narg, cl_object thing, ...)); -extern cl_object clLmerge_pathnames _ARGS((int narg, cl_object path, ...)); -extern cl_object clLmake_pathname _ARGS((int narg, ...)); -extern cl_object clLpathnamep _ARGS((int narg, cl_object pname)); -extern cl_object clLpathname_host _ARGS((int narg, cl_object pname)); -extern cl_object clLpathname_device _ARGS((int narg, cl_object pname)); -extern cl_object clLpathname_directory _ARGS((int narg, cl_object pname)); -extern cl_object clLpathname_name _ARGS((int narg, cl_object pname)); -extern cl_object clLpathname_type _ARGS((int narg, cl_object pname)); -extern cl_object clLpathname_version _ARGS((int narg, cl_object pname)); -extern cl_object clLnamestring _ARGS((int narg, cl_object pname)); -extern cl_object clLfile_namestring _ARGS((int narg, cl_object pname)); -extern cl_object clLdirectory_namestring _ARGS((int narg, cl_object pname)); -extern cl_object clLhost_namestring _ARGS((int narg, cl_object pname)); -extern cl_object clLenough_namestring _ARGS((int narg, cl_object path, ...)); -extern cl_object siLlogical_pathname_p _ARGS((int narg, cl_object pname)); -extern cl_object clLpathname_match_p _ARGS((int narg, cl_object path, cl_object mask)); -extern cl_object siLpathname_translations _ARGS((int narg, cl_object host, ...)); -extern cl_object clLtranslate_pathname _ARGS((int narg, cl_object source, cl_object from, cl_object to)); -extern cl_object clLtranslate_logical_pathname _ARGS((int narg, cl_object source)); - -/* predicate.c */ - -extern cl_object clLnull _ARGS((int narg, cl_object x)); -extern cl_object clLsymbolp _ARGS((int narg, cl_object x)); -extern cl_object clLatom _ARGS((int narg, cl_object x)); -extern cl_object clLconsp _ARGS((int narg, cl_object x)); -extern cl_object clLlistp _ARGS((int narg, cl_object x)); -extern cl_object clLnumberp _ARGS((int narg, cl_object x)); -extern cl_object clLintegerp _ARGS((int narg, cl_object x)); -extern cl_object clLrationalp _ARGS((int narg, cl_object x)); -extern cl_object clLfloatp _ARGS((int narg, cl_object x)); -extern cl_object clLrealp _ARGS((int narg, cl_object x)); -extern cl_object clLcomplexp _ARGS((int narg, cl_object x)); -extern cl_object clLcharacterp _ARGS((int narg, cl_object x)); -extern cl_object clLstringp _ARGS((int narg, cl_object x)); -extern cl_object clLbit_vector_p _ARGS((int narg, cl_object x)); -extern cl_object clLvectorp _ARGS((int narg, cl_object x)); -extern cl_object clLsimple_string_p _ARGS((int narg, cl_object x)); -extern cl_object clLsimple_bit_vector_p _ARGS((int narg, cl_object x)); -extern cl_object clLsimple_vector_p _ARGS((int narg, cl_object x)); -extern cl_object clLarrayp _ARGS((int narg, cl_object x)); -extern cl_object clLpackagep _ARGS((int narg, cl_object x)); -extern cl_object clLfunctionp _ARGS((int narg, cl_object x)); -extern cl_object clLcompiled_function_p _ARGS((int narg, cl_object x)); -extern cl_object clLcommonp _ARGS((int narg, cl_object x)); -extern cl_object clLeq _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLeql _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLequal _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object clLequalp _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object siLfixnump _ARGS((int narg, cl_object x)); - -/* print.c */ - -extern cl_object Kupcase; -extern cl_object Kdowncase; -extern cl_object Kcapitalize; -extern cl_object Kstream; -extern cl_object Kescape; -extern cl_object Kpretty; -extern cl_object Kcircle; -extern cl_object Kbase; -extern cl_object Kradix; -extern cl_object Kcase; -extern cl_object Kgensym; -extern cl_object Klevel; -extern cl_object Klength; -extern cl_object Karray; -extern cl_object clVprint_escape; -extern cl_object clVprint_pretty; -extern cl_object clVprint_circle; -extern cl_object clVprint_base; -extern cl_object clVprint_radix; -extern cl_object clVprint_case; -extern cl_object clVprint_gensym; -extern cl_object clVprint_level; -extern cl_object clVprint_length; -extern cl_object clVprint_array; -extern cl_object siSpretty_print_format; -extern cl_object siSsharp_exclamation; -extern cl_object siVprint_package; -extern cl_object siVprint_structure; -extern cl_object clLwrite _ARGS((int narg, cl_object x, ...)); -extern cl_object clLprin1 _ARGS((int narg, cl_object obj, ...)); -extern cl_object clLprint _ARGS((int narg, cl_object obj, ...)); -extern cl_object clLpprint _ARGS((int narg, cl_object obj, ...)); -extern cl_object clLprinc _ARGS((int narg, cl_object obj, ...)); -extern cl_object clLwrite_char _ARGS((int narg, cl_object c, ...)); -extern cl_object clLwrite_string _ARGS((int narg, cl_object strng, ...)); -extern cl_object clLwrite_line _ARGS((int narg, cl_object strng, ...)); -extern cl_object clLterpri _ARGS((int narg, ...)); -extern cl_object clLfresh_line _ARGS((int narg, ...)); -extern cl_object clLforce_output _ARGS((int narg, ...)); -#define clLfinish_output clLforce_output -extern cl_object clLclear_output _ARGS((int narg, ...)); -extern cl_object clLwrite_byte _ARGS((int narg, cl_object integer, cl_object binary_output_stream)); -extern cl_object siLwrite_bytes _ARGS((int narg, cl_object stream, cl_object string, cl_object start, cl_object end)); - -/* profile.c */ - -extern cl_object siLprofile _ARGS((int narg, cl_object scale, cl_object start_address)); -extern cl_object siLclear_profile _ARGS((int narg)); -extern cl_object siLdisplay_profile _ARGS((int narg)); - -/* read.c */ - -extern cl_object clVreadtable; -extern cl_object clVread_default_float_format; -extern cl_object clVread_base; -extern cl_object clVread_suppress; -extern cl_object Kjunk_allowed; -extern cl_object clLread _ARGS((int narg, ...)); -extern cl_object clLread_preserving_whitespace _ARGS((int narg, ...)); -extern cl_object clLread_delimited_list _ARGS((int narg, cl_object d, ...)); -extern cl_object clLread_line _ARGS((int narg, ...)); -extern cl_object clLread_char _ARGS((int narg, ...)); -extern cl_object clLunread_char _ARGS((int narg, cl_object c, ...)); -extern cl_object clLpeek_char _ARGS((int narg, ...)); -extern cl_object clLlisten _ARGS((int narg, ...)); -extern cl_object clLread_char_no_hang _ARGS((int narg, ...)); -extern cl_object clLclear_input _ARGS((int narg, ...)); -extern cl_object clLparse_integer _ARGS((int narg, cl_object strng, ...)); -extern cl_object clLread_byte _ARGS((int narg, cl_object binary_input_stream, ...)); -extern cl_object siLread_bytes _ARGS((int narg, cl_object stream, cl_object string, cl_object start, cl_object end)); -extern cl_object clLcopy_readtable _ARGS((int narg, ...)); -extern cl_object clLreadtablep _ARGS((int narg, cl_object readtable)); -extern cl_object clLset_syntax_from_char _ARGS((int narg, cl_object tochr, cl_object fromchr, ...)); -extern cl_object clLset_macro_character _ARGS((int narg, cl_object chr, cl_object fnc, ...)); -extern cl_object clLget_macro_character _ARGS((int narg, cl_object chr, ...)); -extern cl_object clLmake_dispatch_macro_character _ARGS((int narg, cl_object chr, ...)); -extern cl_object clLset_dispatch_macro_character _ARGS((int narg, cl_object dspchr, cl_object subchr, cl_object fnc, ...)); -extern cl_object clLget_dispatch_macro_character _ARGS((int narg, cl_object dspchr, cl_object subchr, ...)); -extern cl_object siLstring_to_object _ARGS((int narg, cl_object str)); -extern cl_object siLstandard_readtable _ARGS((int narg)); - -/* reference.c */ - -extern cl_object clLfboundp _ARGS((int narg, cl_object sym)); -extern cl_object clLsymbol_function _ARGS((int narg, cl_object sym)); -extern cl_object siLcoerce_to_function _ARGS((int narg, cl_object form)); -extern cl_object clLsymbol_value _ARGS((int narg, cl_object sym)); -extern cl_object clLboundp _ARGS((int narg, cl_object sym)); -extern cl_object clLmacro_function _ARGS((int narg, cl_object sym, ...)); -extern cl_object clLspecial_form_p _ARGS((int narg, cl_object form)); - -/* sequence.c */ - -extern cl_object clLelt _ARGS((int narg, cl_object x, cl_object i)); -extern cl_object siLelt_set _ARGS((int narg, cl_object seq, cl_object index, cl_object val)); -extern cl_object clLsubseq _ARGS((int narg, cl_object sequence, cl_object start, ...)); -extern cl_object clLcopy_seq _ARGS((int narg, cl_object x)); -extern cl_object clLlength _ARGS((int narg, cl_object x)); -extern cl_object clLreverse _ARGS((int narg, cl_object x)); -extern cl_object clLnreverse _ARGS((int narg, cl_object x)); - -/* stacks.c */ - -extern cl_object Kcatch, Kcatchall, Kprotect; -extern cl_object siLihs_top _ARGS((int narg, cl_object arg)); -extern cl_object siLihs_fun _ARGS((int narg, cl_object arg)); -extern cl_object siLihs_env _ARGS((int narg, cl_object arg)); -extern cl_object siLihs_next _ARGS((int narg, cl_object arg)); -extern cl_object siLihs_prev _ARGS((int narg, cl_object arg)); -extern cl_object siLfrs_top _ARGS((int narg)); -extern cl_object siLfrs_bds _ARGS((int narg, cl_object arg)); -extern cl_object siLfrs_class _ARGS((int narg, cl_object arg)); -extern cl_object siLfrs_tag _ARGS((int narg, cl_object arg)); -extern cl_object siLfrs_ihs _ARGS((int narg, cl_object arg)); -extern cl_object siLbds_top _ARGS((int narg)); -extern cl_object siLbds_var _ARGS((int narg, cl_object arg)); -extern cl_object siLbds_val _ARGS((int narg, cl_object arg)); -extern cl_object siLsch_frs_base _ARGS((int narg, cl_object fr, cl_object ihs)); -extern cl_object siLreset_stack_limits _ARGS((int narg)); - - -/* string.c */ - -extern cl_object Kstart1; -extern cl_object Kend1; -extern cl_object Kstart2; -extern cl_object Kend2; -extern cl_object Kstart; -extern cl_object Kend; -extern cl_object clLmake_string _ARGS((int narg, cl_object size, ...)); -extern cl_object clLchar _ARGS((int narg, cl_object s, cl_object i)); -extern cl_object siLchar_set _ARGS((int narg, cl_object str, cl_object index, cl_object c)); -extern cl_object clLstringE _ARGS((int narg, cl_object string1, cl_object string2, ...)); -extern cl_object clLstring_equal _ARGS((int narg, cl_object string1, cl_object string2, ...)); -extern cl_object clLstringL _ARGS((int narg, ...)); -extern cl_object clLstringG _ARGS((int narg, ...)); -extern cl_object clLstringLE _ARGS((int narg, ...)); -extern cl_object clLstringGE _ARGS((int narg, ...)); -extern cl_object clLstringNE _ARGS((int narg, ...)); -extern cl_object clLstring_lessp _ARGS((int narg, ...)); -extern cl_object clLstring_greaterp _ARGS((int narg, ...)); -extern cl_object clLstring_not_greaterp _ARGS((int narg, ...)); -extern cl_object clLstring_not_lessp _ARGS((int narg, ...)); -extern cl_object clLstring_not_equal _ARGS((int narg, ...)); -extern cl_object clLstring_trim _ARGS((int narg, cl_object char_bag, cl_object strng)); -extern cl_object clLstring_left_trim _ARGS((int narg, cl_object char_bag, cl_object strng)); -extern cl_object clLstring_right_trim _ARGS((int narg, cl_object char_bag, cl_object strng)); -extern cl_object clLstring_trim0 _ARGS((int narg, bool left_trim, bool right_trim, cl_object char_bag, cl_object strng)); -extern cl_object clLstring_upcase _ARGS((int narg, ...)); -extern cl_object clLstring_downcase _ARGS((int narg, ...)); -extern cl_object clLstring_capitalize _ARGS((int narg, ...)); -extern cl_object clLnstring_upcase _ARGS((int narg, ...)); -extern cl_object clLnstring_downcase _ARGS((int narg, ...)); -extern cl_object clLnstring_capitalize _ARGS((int narg, ...)); -extern cl_object clLstring _ARGS((int narg, cl_object x)); -extern cl_object siLstring_concatenate _ARGS((int narg, ...)); - -/* structure.c */ - -extern cl_object siSstructure_print_function; -extern cl_object siSstructure_slot_descriptions; -#ifdef CLOS -extern cl_object clSstructure_object; -#else -extern cl_object siSstructure_include; -#endif -extern cl_object siLstructure_subtype_p _ARGS((int narg, cl_object x, cl_object y)); -extern cl_object siLmake_structure _ARGS((int narg, cl_object type, ...)); -extern cl_object siLcopy_structure _ARGS((int narg, cl_object x)); -extern cl_object siLstructure_name _ARGS((int narg, cl_object s)); -extern cl_object siLstructure_ref _ARGS((int narg, cl_object x, cl_object type, cl_object index)); -extern cl_object siLstructure_set _ARGS((int narg, cl_object x, cl_object type, cl_object index, cl_object val)); -extern cl_object siLstructurep _ARGS((int narg, cl_object s)); -extern cl_object siLrplaca_nthcdr _ARGS((int narg, cl_object x, cl_object idx, cl_object v)); -extern cl_object siLlist_nth _ARGS((int narg, cl_object idx, cl_object x)); - -/* symbol.c */ - -extern cl_object clVgensym_counter; -extern cl_object clLmake_symbol _ARGS((int narg, cl_object str)); -extern cl_object clLget _ARGS((int narg, cl_object sym, cl_object indicator, ...)); -extern cl_object clLremprop _ARGS((int narg, cl_object sym, cl_object prop)); -extern cl_object clLsymbol_plist _ARGS((int narg, cl_object sym)); -extern cl_object clLgetf _ARGS((int narg, cl_object place, cl_object indicator, ...)); -extern cl_object clLget_properties _ARGS((int narg, cl_object place, cl_object indicator_list)); -extern cl_object clLsymbol_name _ARGS((int narg, cl_object sym)); -extern cl_object clLcopy_symbol _ARGS((int narg, cl_object sym, ...)); -extern cl_object clLgensym _ARGS((int narg, ...)); -extern cl_object clLgentemp _ARGS((int narg, ...)); -extern cl_object clLsymbol_package _ARGS((int narg, cl_object sym)); -extern cl_object clLkeywordp _ARGS((int narg, cl_object sym)); -extern cl_object siLput_f _ARGS((int narg, cl_object plist, cl_object value, cl_object indicator)); -extern cl_object siLrem_f _ARGS((int narg, cl_object plist, cl_object indicator)); -extern cl_object siLset_symbol_plist _ARGS((int narg, cl_object sym, cl_object plist)); -extern cl_object siLputprop _ARGS((int narg, cl_object sym, cl_object value, cl_object indicator)); -extern cl_object siLput_properties _ARGS((int narg, cl_object sym, ...)); -extern cl_object siLXmake_special _ARGS((int narg, cl_object sym)); -extern cl_object siLXmake_constant _ARGS((int narg, cl_object sym, cl_object val)); - -/* tcp.c */ - -#ifdef TCP -extern cl_object siLopen_client_stream _ARGS((int narg, cl_object host, cl_object port)); -extern cl_object siLopen_server_stream _ARGS((int narg, cl_object port)); -extern cl_object siLopen_unix_socket_stream _ARGS((int narg, cl_object path)); -extern cl_object siLlookup_host_entry _ARGS((int narg, cl_object host_or_address)); -#endif - -/* time.c */ - -extern cl_object clLget_universal_time _ARGS((int narg)); -extern cl_object clLsleep _ARGS((int narg, cl_object z)); -extern cl_object clLget_internal_run_time _ARGS((int narg)); -extern cl_object clLget_internal_real_time _ARGS((int narg)); -extern cl_object siLget_local_time_zone _ARGS((int narg)); -extern cl_object siLdaylight_saving_time_p _ARGS((int narg, ...)); - -/* typespec.c */ - -extern cl_object clSquote; -extern cl_object clSlambda; -extern cl_object clSspecial; -extern cl_object clSt; -extern cl_object clSnil; -extern cl_object clScommon; -extern cl_object clSsequence; -extern cl_object clSnull; -extern cl_object clScons; -extern cl_object clSlist; -extern cl_object clSsymbol; -extern cl_object clSarray; -extern cl_object clSvector; -extern cl_object clSbit_vector; -extern cl_object clSstring; -extern cl_object clSsimple_array; -extern cl_object clSsimple_vector; -extern cl_object clSsimple_string; -extern cl_object clSsimple_bit_vector; -extern cl_object clSfunction; -extern cl_object clSpathname; -extern cl_object clSlogical_pathname; -extern cl_object clScharacter; -extern cl_object clSbase_char; -extern cl_object clSextended_char; -extern cl_object clScompiled_function; -extern cl_object clSnumber; -extern cl_object clSreal; -extern cl_object clSrational; -extern cl_object clSfloat; -extern cl_object clSinteger; -extern cl_object clSratio; -extern cl_object clSshort_float; -extern cl_object clSstandard_char; -extern cl_object clSfixnum; -extern cl_object clScomplex; -extern cl_object clSsingle_float; -extern cl_object clSpackage; -extern cl_object clSbignum; -extern cl_object clSrandom_state; -extern cl_object clSdouble_float; -extern cl_object clSstream; -extern cl_object clSfile_stream; -extern cl_object clSstring_stream; -extern cl_object clSsynonym_stream; -extern cl_object clStwo_way_stream; -extern cl_object clSbroadcast_stream; -extern cl_object clSconcatenated_stream; -extern cl_object clSecho_stream; -extern cl_object clSbit; -extern cl_object clSreadtable; -extern cl_object clSlong_float; -extern cl_object clShash_table; -extern cl_object clSsigned_char; -extern cl_object clSunsigned_char; -extern cl_object clSsigned_short; -extern cl_object clSunsigned_short; -extern cl_object clSinstance; -extern cl_object clSdispatch_function; -extern cl_object clSstructure; -extern cl_object clSsatisfies; -extern cl_object clSmember; -extern cl_object clSnot; -extern cl_object clSor; -extern cl_object clSand; -extern cl_object clSvalues; -extern cl_object clSmod; -extern cl_object clSsigned_byte; -extern cl_object clSunsigned_byte; -extern cl_object clV; -extern cl_object clSplusp; -extern cl_object clSkeyword; -extern cl_object TSor_string_symbol; -extern cl_object TSor_symbol_string_package; -extern cl_object TSnon_negative_integer; -extern cl_object TSpositive_number; -extern cl_object TSor_integer_float; -extern cl_object TSor_rational_float; -extern cl_object TSor_pathname_string_symbol; -extern cl_object TSor_pathname_string_symbol_stream; -extern cl_object clSsubtypep; -extern cl_object clLtype_of _ARGS((int narg, cl_object x)); - -/* unixfsys.c */ - -extern cl_object Klist_all; -extern cl_object clLtruename _ARGS((int narg, cl_object file)); -extern cl_object clLrename_file _ARGS((int narg, cl_object old_obj, cl_object new_obj)); -extern cl_object clLdelete_file _ARGS((int narg, cl_object file)); -extern cl_object clLprobe_file _ARGS((int narg, cl_object file)); -extern cl_object clLfile_write_date _ARGS((int narg, cl_object file)); -extern cl_object clLfile_author _ARGS((int narg, cl_object file)); -extern cl_object clLuser_homedir_pathname _ARGS((int narg, ...)); -extern cl_object siLchdir _ARGS((int narg, cl_object directory)); -extern cl_object siLmkdir _ARGS((int narg, cl_object directory, cl_object mode)); -extern cl_object siLstring_match _ARGS((int narg, cl_object string, cl_object pattern)); -extern cl_object clLdirectory _ARGS((int narg, ...)); - -/* unixint.c */ - -extern cl_object siLcatch_bad_signals _ARGS((int narg)); -extern cl_object siLuncatch_bad_signals _ARGS((int narg)); - -/* unixsys.c */ - -extern cl_object siLsystem _ARGS((int narg, cl_object cmd)); -extern cl_object siLopen_pipe _ARGS((int narg, cl_object cmd)); - -#ifdef __cplusplus -} -#endif diff --git a/src/h/machines.h b/src/h/machines.h index 538a1dc55..6c5cb6751 100755 --- a/src/h/machines.h +++ b/src/h/machines.h @@ -153,7 +153,7 @@ #ifdef __FreeBSD__ #include #define IEEEFLOAT -#define JB_SP 4 +#define JB_SP 2 #define BRAND "IBM-PC" #define CLIBS -lcompat #define LDFLAGS -Wl,--export-dynamic diff --git a/src/h/object.h b/src/h/object.h index 6cbd0b037..c3d8084f7 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -93,10 +93,10 @@ typedef cl_object (*cl_objectfn)(int narg, ...); #define ARRAYP(x) ((IMMEDIATE(x) == 0) && (x)->d.t >= t_array && (x)->d.t <= t_bitvector) #define VECTORP(x) ((IMMEDIATE(x) == 0) && (x)->d.t >= t_vector && (x)->d.t <= t_bitvector) -#define HEADER byte t, m, padding[2] -#define HEADER1(field) byte t, m, field, padding -#define HEADER2(field1,field2) byte t, m, field1, field2 -#define HEADER3(field1,flag2,flag3) byte t, m, field1; unsigned flag2:4, flag3:4 +#define HEADER int8_t t, m, padding[2] +#define HEADER1(field) int8_t t, m, field, padding +#define HEADER2(field1,field2) int8_t t, m, field1, field2 +#define HEADER3(field1,flag2,flag3) int8_t t, m, field1; unsigned flag2:4, flag3:4 struct shortfloat_struct { HEADER; @@ -278,8 +278,6 @@ struct string { /* string header */ #define SLENGTH(x) (x)->instance.length #define SLOT(x,i) (x)->instance.slots[i] #define SNAME(x) CLASS_NAME(CLASS_OF(x)) -#define STRUCTUREP(x) (type_of(x) == t_instance && \ - structure_subtypep(CLASS_OF(x), clSstructure_object)) #else struct structure { /* structure header */ HEADER; @@ -294,7 +292,6 @@ struct structure { /* structure header */ #define SLENGTH(x) (x)->str.length #define SLOT(x,i) (x)->str.self[i] #define SNAME(x) x->str.name -#define STRUCTUREP(x) (type_of(x) == t_structure) #endif enum smmode { /* stream mode */ @@ -386,7 +383,7 @@ struct bytecodes { }; struct cfun { /* compiled function header */ - HEADER; + HEADER1(narg); cl_object name; /* compiled function name */ cl_objectfn entry; /* entry address */ cl_object block; /* descriptor of C code block for GC */ diff --git a/src/lsp/ansi.lsp b/src/lsp/ansi.lsp index 4d1e04531..47429f0f3 100644 --- a/src/lsp/ansi.lsp +++ b/src/lsp/ansi.lsp @@ -30,10 +30,3 @@ (print-unreadable-object-function ,object ,stream ,type ,identity #'.print-unreadable-object-body.)) `(print-unreadable-object-function ,object ,stream ,type ,identity nil))) - -;;; SPECIAL-OPERATOR-P -- -;;; Added 19951011 Marco Antoniotti - -(eval-when (load eval) - (setf (symbol-function 'special-operator-p) - (symbol-function 'special-form-p))) diff --git a/src/lsp/arraylib.lsp b/src/lsp/arraylib.lsp index b904aaa15..9b9f8f5f3 100644 --- a/src/lsp/arraylib.lsp +++ b/src/lsp/arraylib.lsp @@ -101,6 +101,7 @@ contiguous block." x)))) (defun increment-cursor (cursor dimensions) + (declare (si::c-local)) (if (null cursor) t (let ((carry (increment-cursor (cdr cursor) (cdr dimensions)))) @@ -117,6 +118,7 @@ contiguous block." (defun sequence-cursor (sequence cursor) + (declare (si::c-local)) (if (null cursor) sequence (sequence-cursor (elt sequence (the fixnum (car cursor))) diff --git a/src/lsp/assert.lsp b/src/lsp/assert.lsp index 70749bf87..1a218544a 100644 --- a/src/lsp/assert.lsp +++ b/src/lsp/assert.lsp @@ -46,6 +46,7 @@ for the error message and ARGs are arguments to the format string." (defun ask-for-form (place) + (declare (si::c-local)) `(progn (format *error-output* "Please input the new value for the place ~:@(~S~): " ',place) @@ -70,6 +71,7 @@ for the error message and ARGs are arguments to the format string." keyform value values))) (defun case-values (clauses) + (declare (si::c-local)) (mapcan #'(lambda (x) (if (listp (car x)) (mapcar #'(lambda (y) `',y) (car x)) diff --git a/src/lsp/autoload.lsp b/src/lsp/autoload.lsp index 7b3721006..925fc2899 100644 --- a/src/lsp/autoload.lsp +++ b/src/lsp/autoload.lsp @@ -12,6 +12,8 @@ ;;; Program Development Environment +#+PDE +(progn (in-package "SYSTEM") (setq *record-source-pathname-p* nil) (defun record-source-pathname (symbol type) @@ -33,6 +35,7 @@ (push (cons spec *source-pathname*) alist))) (setq alist (list (cons spec *source-pathname*)))) (putprop symbol alist (car type)))))) +) ;;; Go into LISP. (in-package "LISP") @@ -83,7 +86,7 @@ after compilation." (load "SYS:cmp") (apply 'compile-file-pathname args)) -(defun disassemble (&rest args) +(defun disassemble (f &rest args) "Args: (&optional (thing nil) &key (h-file nil) (data-file nil)) Compiles the form specified by THING and prints the intermediate C language code for that form. But does not install the result of compilation. If THING @@ -93,8 +96,11 @@ disassembled. If THING is a lambda expression, it is disassembled as a function definition. Otherwise, THING itself is disassembled as a top-level form. H-FILE and DATA-FILE specify intermediate files to build a fasl file from the C language code. NIL means \"do not create the file\"." - (load "SYS:cmp") - (apply 'disassemble args)) + (when (or (symbolp f) (si::setf-namep f)) + (setq function (eval `(function ,f)))) + (unless (si::bc-disassemble f) + (load "SYS:cmp") + (apply 'disassemble f args))) ) ;;; Editor. @@ -103,7 +109,7 @@ from the C language code. NIL means \"do not create the file\"." "Args: (&optional filename) Invokes the editor. The action depends on the version of ECL. See the ECL Report for details." - (si:system (format nil "emacs ~A" filename))) + (si:system (format nil "~S ~A" (si::getenv "EDITOR") filename))) ;;; Allocator. @@ -284,8 +290,6 @@ NIL, then all packages are searched." (labels 1) (lambda 1) (lambda-block 2) - (lambda-closure 4) - (lambda-block-closure 5) (let 1) (let* 1) (locally 0) diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index 4ed1c05de..a634bd3d1 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -56,7 +56,8 @@ Returns, as a string, the version of the software under which ECL runs." ;; ;; * Set up some room ;; -(unless (member :boehm-gc *features*) +#-boehm-gc +(progn (sys::allocate 'CONS 200) (sys::allocate 'STRING 40)) diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index 17d9a3c3f..f3e1082b9 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -12,7 +12,8 @@ (si::select-package "SYSTEM") #-ecl-min -(c-declaim (si::c-export-fname find-documentation remove-documentation)) +(c-declaim (si::c-export-fname find-documentation remove-documentation + si::check-keyword)) #-ecl-min (defvar *dl*) @@ -90,15 +91,19 @@ (setq err head))))) (defun dm-bad-key (key) - (error "Defmacro-lambda-list contains illegal use of ~s." key)) + (declare (si::c-local)) + (error "Defmacro-lambda-list contains illegal use of ~s." key)) (defun dm-too-few-arguments () - (error "Too few arguments are supplied to defmacro-lambda-list.")) + (declare (si::c-local)) + (error "Too few arguments are supplied to defmacro-lambda-list.")) (defun dm-too-many-arguments () - (error "Too many arguments are supplied to defmacro-lambda-list.")) + (declare (si::c-local)) + (error "Too many arguments are supplied to defmacro-lambda-list.")) (defun sys::destructure (vl whole macro &aux (*dl* nil) (*key-check* nil) (*arg-check* nil)) + (declare (si::c-local)) (labels ((dm-vl (vl whole top &aux v allow-other-keys-p) (do*((optionalp) (restp) (keyp) (allow-other-keys-p) (auxp) diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 4b27e19da..464c36e3c 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -12,7 +12,8 @@ (in-package "SYSTEM") (defun make-access-function (name conc-name type named slot-descr) - (declare (ignore named)) + (declare (ignore named) + (si::c-local)) (let* ((slot-name (nth 0 slot-descr)) ;; (default-init (nth 1 slot-descr)) ;; (slot-type (nth 2 slot-descr)) @@ -50,7 +51,8 @@ ) (defun make-constructor (name constructor type named slot-descriptions) - (declare (ignore named)) + (declare (ignore named) + (si::c-local)) (let ((slot-names ;; Collect the slot-names. (mapcar #'(lambda (x) @@ -227,6 +229,7 @@ (defun illegal-boa () + (declare (si::c-local)) (error "An illegal BOA constructor.")) @@ -264,6 +267,7 @@ ;;; (slot-name default-init slot-type read-only offset) (defun parse-slot-description (slot-description offset) + (declare (si::c-local)) (let (slot-name default-init slot-type read-only) (cond ((atom slot-description) (setq slot-name slot-description)) @@ -293,6 +297,7 @@ ;;; :include defstruct option. (defun overwrite-slot-descriptions (news olds) + (declare (si::c-local)) (when olds (let ((sds (member (caar olds) news :key #'car))) (cond (sds @@ -587,35 +592,6 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." ',name)))) -;;; The #S reader. - -(defun sharp-s-reader (stream subchar arg) - (declare (ignore subchar)) - (when (and arg (null *read-suppress*)) - (error "An extra argument was supplied for the #S readmacro.")) - (let ((l (read stream))) - (when *read-suppress* - (return-from sharp-s-reader nil)) - (unless (get (car l) 'IS-A-STRUCTURE) - (error "~S is not a structure." (car l))) - ;; Intern keywords in the keyword package. - (do ((ll (cdr l) (cddr ll))) - ((endp ll) - ;; Find an appropriate construtor. - (do ((cs (get (car l) 'STRUCTURE-CONSTRUCTORS) (cdr cs))) - ((endp cs) - (error "The structure ~S has no structure constructor." - (car l))) - (when (symbolp (car cs)) - (return (apply (car cs) (cdr l)))))) - (rplaca ll (intern (string (car ll)) 'KEYWORD))))) - - -;; Set the dispatch macro. -(set-dispatch-macro-character #\# #\s 'sharp-s-reader) -(set-dispatch-macro-character #\# #\S 'sharp-s-reader) - - ;; Examples from Common Lisp Reference Manual. #| diff --git a/src/lsp/describe.lsp b/src/lsp/describe.lsp index 4b6ec350c..63f4c2a79 100644 --- a/src/lsp/describe.lsp +++ b/src/lsp/describe.lsp @@ -20,15 +20,18 @@ (defun inspect-read-line () + (declare (si::c-local)) (do ((char (read-char *query-io*) (read-char *query-io*))) ((or (char= char #\Newline) (char= char #\Return))))) (defun select-P (object) + (declare (si::c-local)) (let ((*print-pretty* t) (*print-level* nil) (*print-length* nil)) (prin1 object) (terpri))) (defun select-E () + (declare (si::c-local)) (dolist (x (multiple-value-list (multiple-value-prog1 (eval (read-preserving-whitespace *query-io*)) @@ -39,11 +42,13 @@ (terpri))) (defun select-U () + (declare (si::c-local)) (prog1 (eval (read-preserving-whitespace *query-io*)) (inspect-read-line))) (defun select-? () + (declare (si::c-local)) (terpri) (format t "Inspect commands:~%~ @@ -59,6 +64,7 @@ ?: prints this.~%~%")) (defun read-inspect-command (label object allow-recursive) + (declare (si::c-local)) (unless *inspect-mode* (inspect-indent-1) (if allow-recursive @@ -125,17 +131,20 @@ (terpri)))) (defun inspect-indent () + (declare (si::c-local)) (fresh-line) (format t "~V@T" (* 4 (if (< *inspect-level* 8) *inspect-level* 8)))) (defun inspect-indent-1 () + (declare (si::c-local)) (fresh-line) (format t "~V@T" (- (* 4 (if (< *inspect-level* 8) *inspect-level* 8)) 3))) (defun inspect-symbol (symbol) + (declare (si::c-local)) (let ((p (symbol-package symbol))) (cond ((null p) (format t "~:@(~S~) - uninterned symbol" symbol)) @@ -177,6 +186,7 @@ ) (defun inspect-package (package) + (declare (si::c-local)) (format t "~S - package" package) (when (package-nicknames package) (inspect-print "nicknames: ~S" (package-nicknames package))) @@ -189,6 +199,7 @@ (package-shadowing-symbols package)))) (defun inspect-character (character) + (declare (si::c-local)) (format t (cond ((standard-char-p character) "~S - standard character") (t "~S - character")) @@ -196,6 +207,7 @@ (inspect-print "code: #x~X" (char-code character))) (defun inspect-number (number) + (declare (si::c-local)) (case (type-of number) (FIXNUM (format t "~S - fixnum (32 bits)" number)) (BIGNUM (format t "~S - bignum" number)) @@ -223,13 +235,8 @@ (inspect-print "mantissa: ~D" signif))))) (defun inspect-cons (cons) - (format t - (case (car cons) - ((LAMBDA LAMBDA-BLOCK LAMBDA-CLOSURE LAMBDA-BLOCK-CLOSURE) - "~S - function") - (QUOTE "~S - constant") - (t "~S - cons")) - cons) + (declare (si::c-local)) + (format t "~S - cons" cons) (when *inspect-mode* (do ((i 0 (1+ i)) (l cons (cdr l))) @@ -240,6 +247,7 @@ (car l) (nth i cons))))) (defun inspect-string (string) + (declare (si::c-local)) (format t (if (simple-string-p string) "~S - simple string" "~S - string") string) (inspect-print "dimension: ~D"(array-dimension string 0)) @@ -254,6 +262,7 @@ (char string i))))) (defun inspect-vector (vector) + (declare (si::c-local)) (format t (if (simple-vector-p vector) "~S - simple vector" "~S - vector") vector) (inspect-print "dimension: ~D" (array-dimension vector 0)) @@ -268,6 +277,7 @@ (aref vector i))))) (defun inspect-array (array) + (declare (si::c-local)) (format t (if (adjustable-array-p array) "~S - adjustable aray" "~S - array") @@ -277,6 +287,7 @@ (inspect-print "total size: ~D" (array-total-size array))) (defun select-ht-N (hashtable) + (declare (si::c-local)) (incf *inspect-level*) (maphash #'(lambda (key val) (inspect-indent-1) @@ -286,6 +297,7 @@ (decf *inspect-level*)) (defun select-ht-L (hashtable) + (declare (si::c-local)) (terpri) (format t "The keys of the hash table are:~%") (maphash #'(lambda (key val) @@ -295,6 +307,7 @@ (terpri)) (defun select-ht-J (hashtable) + (declare (si::c-local)) (let* ((key (prog1 (read-preserving-whitespace *query-io*) (inspect-read-line))) @@ -313,6 +326,7 @@ (terpri))))) (defun select-ht-? () + (declare (si::c-local)) (terpri) (format t "Inspect commands for hash tables:~%~ @@ -328,6 +342,7 @@ q (or Q): quits the inspection.~%~ )) (defun inspect-hashtable (hashtable) + (declare (si::c-local)) (if *inspect-mode* (progn (decf *inspect-level*) @@ -378,11 +393,13 @@ q (or Q): quits the inspection.~%~ #+CLOS (defun inspect-instance (instance) + (declare (si::c-local)) (if *inspect-mode* (clos::inspect-obj instance) (clos::describe-object instance))) (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) + (declare (si::c-local)) (inspect-indent) (when (and (not *inspect-mode*) (or (> *inspect-level* 5) @@ -448,7 +465,7 @@ inspect commands, or type '?' to the inspector." (find-package "SYSTEM") *package*))) - (cond ((special-form-p symbol) + (cond ((special-operator-p symbol) (doc1 (or (si::get-documentation symbol 'FUNCTION) "") (if (macro-function symbol) "[Special form and Macro]" @@ -456,19 +473,7 @@ inspect commands, or type '?' to the inspector." ((macro-function symbol) (doc1 (or (si::get-documentation symbol 'FUNCTION) "") "[Macro]")) ((fboundp symbol) - (doc1 - (or (si::get-documentation symbol 'FUNCTION) - (if (consp (setq x (symbol-function symbol))) - (case (car x) - (LAMBDA (format nil "~%Args: ~S" (cadr x))) - (LAMBDA-BLOCK (format nil "~%Args: ~S" (caddr x))) - (LAMBDA-CLOSURE - (format nil "~%Args: ~S" (car (cddddr x)))) - (LAMBDA-BLOCK-CLOSURE - (format nil "~%Args: ~S" (cadr (cddddr x)))) - (t "")) - "")) - "[Function]")) + (doc1 (or (si::get-documentation symbol 'FUNCTION) "") "[Function]")) ((setq x (si::get-documentation symbol 'FUNCTION)) (doc1 x "[Macro or Function]"))) @@ -516,9 +521,6 @@ inspect commands, or type '?' to the inspector." (case (car x) (LAMBDA `(define-setf-expander ,@(cdr x))) (LAMBDA-BLOCK `(define-setf-expander ,@(cddr x))) - (LAMBDA-CLOSURE `(define-setf-expander ,@(cddddr x))) - (LAMBDA-BLOCK-CLOSURE - `(define-setf-expander ,@(cdr (cddddr x)))) (t nil)) nil)) "[Setf]")))) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 1c8395554..51f514930 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -300,6 +300,7 @@ SECOND-FORM." (defun do/do*-expand (control test result body let psetq &aux (decl nil) (label (gensym)) (vl nil) (step nil)) + (declare (si::c-local)) (multiple-value-setq (decl body) (find-declarations body)) (dolist (c control) @@ -382,7 +383,6 @@ SECOND-FORM." (defmacro the (type value) value) -#+nil (defmacro define-symbol-macro (symbol expansion) (cond ((not (symbolp symbol)) (error "DEFINE-SYMBOL-MACRO: ~A is not a symbol" diff --git a/src/lsp/export.lsp b/src/lsp/export.lsp index 0f6f35ddd..ac73f183b 100644 --- a/src/lsp/export.lsp +++ b/src/lsp/export.lsp @@ -33,14 +33,13 @@ (setq *dump-defmacro-definitions* *dump-defun-definitions*) (si::fset 'defun - (si::bc-disassemble #'(lambda-block defun (def env) (let* ((name (second def)) (function `#'(lambda-block ,@(cdr def)))) (when *dump-defun-definitions* (print function) (setq function `(si::bc-disassemble ,function))) - `(si::fset ',name ,function)))) + `(si::fset ',name ,function))) t) (si::fset 'in-package @@ -49,6 +48,7 @@ t) (defun eval-feature (x) + (declare (si::c-local)) (cond ((symbolp x) (member x *features* :test #'(lambda (a b) @@ -67,6 +67,7 @@ ;;; Revised by G. Attardi (defun check-no-infix (stream subchar arg) + (declare (si::c-local)) (when arg (error "Reading from ~S: no number should appear between # and ~A" stream subchar))) diff --git a/src/lsp/helpfile.lsp b/src/lsp/helpfile.lsp index 65bd2dc14..b0a29b6ee 100644 --- a/src/lsp/helpfile.lsp +++ b/src/lsp/helpfile.lsp @@ -120,7 +120,7 @@ If MERGE is true, merges the contents of this table with the original values in the help file." (let ((dict (first *documentation-pool*))) (when (hash-table-p dict) - (dump-help-file dict file nil) + (dump-help-file dict file merge) (rplaca *documentation-pool* file)))) (defun get-documentation (symbol doc-type &aux output) diff --git a/src/lsp/iolib.lsp b/src/lsp/iolib.lsp index 74217db6e..a6b512fd1 100644 --- a/src/lsp/iolib.lsp +++ b/src/lsp/iolib.lsp @@ -162,13 +162,13 @@ printed. If FORMAT-STRING is NIL, however, no prompt will appear." (set-dispatch-macro-character #\# #\a 'sharp-a-reader) (set-dispatch-macro-character #\# #\A 'sharp-a-reader) -(defun sharp-s-reader-si (stream subchar arg) +(defun sharp-s-reader (stream subchar arg) (declare (ignore subchar)) (when (and arg (null *read-suppress*)) (error "~S is an extra argument for the #s readmacro." arg)) (let ((l (read stream))) (when *read-suppress* - (return-from sharp-s-reader-si nil)) + (return-from sharp-s-reader nil)) (unless (get (car l) 'is-a-structure) (error "~S is not a structure." (car l))) ;; Intern keywords in the keyword package. @@ -183,8 +183,8 @@ printed. If FORMAT-STRING is NIL, however, no prompt will appear." (return (apply (car cs) (cdr l)))))) (rplaca ll (intern (string (car ll)) 'keyword))))) -(set-dispatch-macro-character #\# #\s 'sharp-s-reader-si) -(set-dispatch-macro-character #\# #\S 'sharp-s-reader-si) +(set-dispatch-macro-character #\# #\s 'sharp-s-reader) +(set-dispatch-macro-character #\# #\S 'sharp-s-reader) (defvar *dribble-stream* nil) (defvar *dribble-io* nil) @@ -244,7 +244,7 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, (*print-miser-width* nil) (*print-pretty* nil) (*print-radix* nil) - (*print-radably* t) + (*print-readably* t) (*print-right-margin* nil) (*read-base* 10) (*read-default-float-format* 'single-float) diff --git a/src/lsp/load.lsp.in b/src/lsp/load.lsp.in index ada3f1950..b72d5eee3 100644 --- a/src/lsp/load.lsp.in +++ b/src/lsp/load.lsp.in @@ -27,7 +27,7 @@ (load "@srcdir@/defpackage.lsp" :verbose t) (load "@srcdir@/ffi.lsp" :verbose t) #+threads -(load "@srcdir@/threads.lsp" :verbose t) +(load "@srcdir@/thread.lsp" :verbose t) #+tk (load "@srcdir@/tk-init.lsp" :verbose t) (load "@builddir@/lsp/config.lsp" :verbose t) diff --git a/src/lsp/loop2.lsp b/src/lsp/loop2.lsp index dbb2056f2..ac9deaab0 100755 --- a/src/lsp/loop2.lsp +++ b/src/lsp/loop2.lsp @@ -147,6 +147,7 @@ nil) (defun loop-gentemp (&optional (pref 'loopvar-)) + (declare (si::c-local)) (if *loop-gentemp* (gentemp (string pref)) (gensym))) @@ -157,6 +158,7 @@ (defun loop-optimization-quantities (env) + (declare (si::c-local)) ;; The ANSI conditionalization here is for those lisps that implement ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). ;; It is really commentary on how this code could be written. I don't @@ -186,7 +188,7 @@ ;;; kind of form generated for the above loop construct to step I, simplified, is ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). (defun hide-variable-references (variable-list form) - (declare #-Genera (ignore variable-list)) + (declare #-Genera (ignore variable-list) (si::c-local)) #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form) #-Genera form) @@ -210,7 +212,7 @@ ;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than ;;; for all callers to contain the conditional invisibility construction. (defun hide-variable-reference (really-hide variable form) - (declare #-Genera (ignore really-hide variable)) + (declare #-Genera (ignore really-hide variable) (si::c-local)) #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns `(compiler:invisible-references (,variable) ,form) form) @@ -366,6 +368,7 @@ constructed. (defun make-loop-minimax (answer-variable type) + (declare (si::c-local)) (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable @@ -377,6 +380,7 @@ constructed. (defun loop-note-minimax-operation (operation minimax) + (declare (si::c-local)) (pushnew (the symbol operation) (loop-minimax-operations minimax)) (when (and (cdr (loop-minimax-operations minimax)) (not (loop-minimax-flag-variable minimax))) @@ -443,23 +447,28 @@ code to be loaded. ;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, ;;; the second a symbol to check against. (defun loop-tequal (x1 x2) + (declare (si::c-local)) (and (symbolp x1) (string= x1 x2))) (defun loop-tassoc (kwd alist) + (declare (si::c-local)) (and (symbolp kwd) (assoc kwd alist :test #'string=))) (defun loop-tmember (kwd list) + (declare (si::c-local)) (and (symbolp kwd) (member kwd list :test #'string=))) (defun loop-lookup-keyword (loop-token table) + (declare (si::c-local)) (and (symbolp loop-token) (values (gethash (symbol-name loop-token) table)))) (defmacro loop-store-table-data (symbol table datum) + (declare (si::c-local)) `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) @@ -505,6 +514,7 @@ code to be loaded. (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords type-keywords type-symbols ansi) + (declare (si::c-local)) #-(and CLOE Source-Bootstrap ecl) (check-type ansi (member nil t :extended)) (flet ((maketable (entries) (let* ((size (length entries)) @@ -536,6 +546,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-make-psetq (frobs) + (declare (si::c-local)) (and frobs (loop-make-desetq (list (car frobs) @@ -545,6 +556,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-make-desetq (var-val-pairs) + (declare (si::c-local)) (if (null var-val-pairs) nil (cons (if *loop-destructuring-hooks* @@ -733,6 +745,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-constant-fold-if-possible (form &optional expected-type) + (declare (si::c-local)) #+Genera (declare (values new-form constantp constant-value)) (let ((new-form form) (constantp nil) (constant-value nil)) #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment* @@ -771,6 +784,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-code-duplication-threshold (env) + (declare (si::c-local)) (multiple-value-bind (speed space) (loop-optimization-quantities env) (+ 40 (* (- speed space) 10)))) @@ -782,6 +796,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. after-loop epilogue &aux rbefore rafter flagvar) + (declare (si::c-local)) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists.")) ;;All our work is done from these copies, working backwards from the end: @@ -855,6 +870,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun duplicatable-code-p (expr env) + (declare (si::c-local)) (if (null expr) 0 (let ((ans (estimate-code-size expr env))) (declare (fixnum ans)) @@ -890,16 +906,19 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun destructuring-size (x) + (declare (si::c-local)) (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) ((atom x) (+ n (if (null x) 0 1))))) (defun estimate-code-size (x env) + (declare (si::c-local)) (catch 'estimate-code-size (estimate-code-size-1 x env))) (defun estimate-code-size-1 (x env) + (declare (si::c-local)) (flet ((list-size (l) (let ((n 0)) (declare (fixnum n)) @@ -953,22 +972,26 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-context () + (declare (si::c-local)) (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) ((eq l (cdr *loop-source-code*)) (nreverse new)))) (defun loop-error (format-string &rest format-args) + (declare (si::c-local)) #+(or Genera CLOE) (declare (dbg:error-reporter)) #+Genera (setq format-args (copy-list format-args)) ;Don't ask. (error "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) (defun loop-warn (format-string &rest format-args) + (declare (si::c-local)) (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) (defun loop-check-data-type (specified-type required-type &optional (default-type required-type)) + (declare (si::c-local)) (if (null specified-type) default-type (multiple-value-bind (a b) (subtypep specified-type required-type) @@ -993,6 +1016,7 @@ collected result will be returned as the value of the LOOP." (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) + (declare (si::c-local)) (let ((*loop-original-source-code* *loop-source-code*) (*loop-source-context* nil) (*loop-iteration-variables* nil) @@ -1050,6 +1074,7 @@ collected result will be returned as the value of the LOOP." (defun loop-iteration-driver () + (declare (si::c-local)) (do () ((null *loop-source-code*)) (let ((keyword (car *loop-source-code*)) (tem nil)) (cond ((not (symbolp keyword)) @@ -1070,12 +1095,14 @@ collected result will be returned as the value of the LOOP." (defun loop-pop-source () + (declare (si::c-local)) (if *loop-source-code* (pop *loop-source-code*) (loop-error "LOOP source code ran out when another token was expected."))) (defun loop-get-progn () + (declare (si::c-local)) (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms)) (nextform (car *loop-source-code*) (car *loop-source-code*))) ((atom nextform) @@ -1083,24 +1110,29 @@ collected result will be returned as the value of the LOOP." (defun loop-get-form () + (declare (si::c-local)) (if *loop-source-code* (loop-pop-source) (loop-error "LOOP code ran out where a form was expected."))) (defun loop-construct-return (form) + (declare (si::c-local)) `(return-from ,(car *loop-names*) ,form)) (defun loop-pseudo-body (form) + (declare (si::c-local)) (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) (t (push form *loop-before-loop*) (push form *loop-after-body*)))) (defun loop-emit-body (form) + (declare (si::c-local)) (setq *loop-emitted-body* t) (loop-pseudo-body form)) (defun loop-emit-final-value (form) + (declare (si::c-local)) (push (loop-construct-return form) *loop-after-epilogue*) (when *loop-final-value-culprit* (loop-warn "LOOP clause is providing a value for the iteration,~@ @@ -1110,6 +1142,7 @@ collected result will be returned as the value of the LOOP." (defun loop-disallow-conditional (&optional kwd) + (declare (si::c-local)) #+(or Genera CLOE) (declare (dbg:error-reporter)) (when *loop-inside-conditional* (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) @@ -1119,6 +1152,7 @@ collected result will be returned as the value of the LOOP." (defun loop-typed-init (data-type) + (declare (si::c-local)) (when (and data-type (subtypep data-type 'number)) (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) (coerce 0 data-type) @@ -1126,6 +1160,7 @@ collected result will be returned as the value of the LOOP." (defun loop-optional-type (&optional variable) + (declare (si::c-local)) ;;No variable specified implies that no destructuring is permissible. (and *loop-source-code* ;Don't get confused by NILs... (let ((z (car *loop-source-code*))) @@ -1182,6 +1217,7 @@ collected result will be returned as the value of the LOOP." (defun loop-bind-block () + (declare (si::c-local)) (when (or *loop-variables* *loop-declarations* *loop-wrappers*) (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) *loop-bind-stack*) @@ -1192,6 +1228,7 @@ collected result will be returned as the value of the LOOP." (defun loop-make-variable (name initialization dtype &optional iteration-variable-p) + (declare (si::c-local)) (cond ((null name) (cond ((not (null initialization)) (push (list (setq name (loop-gentemp 'loop-ignore-)) @@ -1232,10 +1269,12 @@ collected result will be returned as the value of the LOOP." (defun loop-make-iteration-variable (name initialization dtype) + (declare (si::c-local)) (loop-make-variable name initialization dtype t)) (defun loop-declare-variable (name dtype) + (declare (si::c-local)) (cond ((or (null name) (null dtype) (eq dtype t)) nil) ((symbolp name) (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) @@ -1256,6 +1295,7 @@ collected result will be returned as the value of the LOOP." (defun loop-maybe-bind-form (form data-type) + (declare (si::c-local)) (if (loop-constantp form) form (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) @@ -1343,6 +1383,7 @@ collected result will be returned as the value of the LOOP." (defun loop-get-collection-info (collector class default-type) + (declare (si::c-local)) (let ((form (loop-get-form)) (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) (name (when (loop-tequal (car *loop-source-code*) 'into) @@ -1485,6 +1526,7 @@ collected result will be returned as the value of the LOOP." ;;;; The iteration driver (defun loop-hack-iteration (entry) + (declare (si::c-local)) (flet ((make-endtest (list-of-forms) (cond ((null list-of-forms) nil) ((member t list-of-forms) '(go end-loop)) @@ -1574,6 +1616,7 @@ collected result will be returned as the value of the LOOP." (defun loop-when-it-variable () + (declare (si::c-local)) (or *loop-when-it-variable* (setq *loop-when-it-variable* (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) @@ -1635,6 +1678,7 @@ collected result will be returned as the value of the LOOP." (defun loop-list-step (listvar) + (declare (si::c-local)) ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used ;; as the stepping function. @@ -1727,6 +1771,7 @@ collected result will be returned as the value of the LOOP." (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) + (declare (si::c-local)) (unless (listp names) (setq names (list names))) ;; Can't do this due to CLOS bootstrapping problems. #-(or Genera (and CLOE Source-Bootstrap) ecl) (check-type universe loop-universe) @@ -1795,6 +1840,7 @@ collected result will be returned as the value of the LOOP." ;;;INTERFACE: Lucid, exported. ;;; i.e., this is part of our extended ansi-loop interface. (defun named-variable (name) + (declare (si::c-local)) (let ((tem (loop-tassoc name *loop-named-variables*))) (declare (list tem)) (cond ((null tem) (values (loop-gentemp) nil)) @@ -1803,6 +1849,7 @@ collected result will be returned as the value of the LOOP." (defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) + (declare (si::c-local)) (flet ((in-group-p (x group) (car (loop-tmember x group)))) (do ((token nil) (prepositional-phrases initial-phrases) @@ -1861,6 +1908,7 @@ collected result will be returned as the value of the LOOP." sequence-variable sequence-type step-hack default-top prep-phrases) + (declare (si::c-local)) (let ((endform nil) ;Form (constant or variable) with limit value. (sequencep nil) ;T if sequence arg has been provided. (testfn nil) ;endtest function @@ -1963,7 +2011,7 @@ collected result will be returned as the value of the LOOP." '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) nil (list (list kwd val))))) - +#+nil (defun loop-sequence-elements-path (variable data-type prep-phrases &key fetch-function size-function sequence-type element-type) (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) @@ -2061,6 +2109,7 @@ collected result will be returned as the value of the LOOP." ;;;; ANSI Loop (defun make-ansi-loop-universe (extended-p) + (declare (si::c-local)) (let ((w (make-standard-loop-universe :keywords `((named (loop-do-named)) (initially (loop-do-initially)) @@ -2144,6 +2193,7 @@ collected result will be returned as the value of the LOOP." (defun loop-standard-expansion (keywords-and-forms environment universe) + (declare (si::c-local)) (if (and keywords-and-forms (symbolp (car keywords-and-forms))) (loop-translate keywords-and-forms environment universe) (let ((tag (gensym))) diff --git a/src/lsp/mislib.lsp b/src/lsp/mislib.lsp index d04069d56..780432b44 100644 --- a/src/lsp/mislib.lsp +++ b/src/lsp/mislib.lsp @@ -54,10 +54,12 @@ Evaluates FORM, outputs the realtime and runtime used for the evaluation to (defconstant seconds-per-day #.(* 24 3600)) (defun leap-year-p (y) + (declare (si::c-local)) (and (zerop (mod y 4)) (or (not (zerop (mod y 100))) (zerop (mod y 400))))) (defun number-of-days-from-1900 (y) + (declare (si::c-local)) (let ((y1 (1- y))) (+ (* (- y 1900) 365) (floor y1 4) (- (floor y1 100)) (floor y1 400) diff --git a/src/lsp/packlib.lsp b/src/lsp/packlib.lsp index f1b54a5c9..5e18c09a1 100644 --- a/src/lsp/packlib.lsp +++ b/src/lsp/packlib.lsp @@ -12,15 +12,6 @@ (in-package "SYSTEM") -(defmacro coerce-to-package (p) - (if (eq p '*package*) - p - (let ((g (gensym))) - `(let ((,g ,p)) - (if (packagep ,g) - ,g - (find-package (string ,g))))))) - (defun find-all-symbols (string-or-symbol) "Args: (string-designator) Returns a list of all symbols that have the specified print name. @@ -108,7 +99,7 @@ to NIL) and returns all values." (defun print-symbol-apropos (symbol) (prin1 symbol) (when (fboundp symbol) - (if (special-form-p symbol) + (if (special-operator-p symbol) (princ " Special form") (if (macro-function symbol) (princ " Macro") diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 4f0ab4da8..22b2017ea 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -322,6 +322,7 @@ Returns T if X belongs to TYPE; NIL otherwise." ;;; KNOWN-TYPE-P answers if the given type is a known base type. ;;; The type MUST be normalized. (defun known-type-p (type) + (declare (si::c-local)) (cond #+clos ((sys::instancep type) t) ((not (symbolp type)) nil) @@ -581,6 +582,7 @@ second value is T." (return-from sub-interval-p t))) (defun in-interval-p (x interval) + (declare (si::c-local)) (let (low high) (if (endp interval) (setq low '* high '*) @@ -598,6 +600,7 @@ second value is T." (return-from in-interval-p t))) (defun match-dimensions (dim pat) + (declare (si::c-local)) (if (null dim) (null pat) (and (or (eq (car pat) '*) diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index 6f981d028..6774012e2 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -26,6 +26,7 @@ (declaim (function seqtype (t) t)) (defun seqtype (sequence) + (declare (si::c-local)) (cond ((listp sequence) 'list) ((stringp sequence) 'string) ((bit-vector-p sequence) 'bit-vector) @@ -34,15 +35,18 @@ (declaim (function call-test (t t t t) t)) (defun call-test (test test-not item keyx) + (declare (si::c-local)) (cond (test (funcall test item keyx)) (test-not (not (funcall test-not item keyx))) (t (eql item keyx)))) (declaim (function test-error() t)) (defun test-error() + (declare (si::c-local)) (error "both test and test are supplied")) (defun bad-seq-limit (x &optional y) + (declare (si::c-local)) (error "bad sequence limit ~a" (if y (list x y) x))) (eval-when (compile eval) @@ -55,6 +59,7 @@ ) (defun the-end (x y) + (declare (si::c-local)) (cond ((fixnump x) (unless (<= (the fixnum x) (the fixnum (length y))) (bad-seq-limit x)) @@ -64,6 +69,7 @@ (t (bad-seq-limit x)))) (defun the-start (x) + (declare (si::c-local)) (cond ((fixnump x) (unless (>= (the fixnum x) 0) (bad-seq-limit x)) diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index 1f31ceebe..1d4e1add3 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -310,6 +310,7 @@ Does not check if the third gang is a single-element list." ;;; The expansion function for SETF. (defun setf-expand-1 (place newvalue env &aux g) + (declare (si::c-local)) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) (declare (ignore access-form)) @@ -320,12 +321,14 @@ Does not check if the third gang is a single-element list." ,store-form))) (defun setf-structure-access (struct type index newvalue) + (declare (si::c-local)) (case type (LIST `(sys:rplaca-nthcdr ,struct ,index ,newvalue)) (VECTOR `(sys:elt-set ,struct ,index ,newvalue)) (t `(sys::structure-set ,struct ',type ,index ,newvalue)))) (defun setf-expand (l env) + (declare (si::c-local)) (cond ((endp l) nil) ((endp (cdr l)) (error "~S is an illegal SETF form." l)) (t diff --git a/src/lsp/trace.lsp b/src/lsp/trace.lsp index 59a792a24..90f038ec7 100644 --- a/src/lsp/trace.lsp +++ b/src/lsp/trace.lsp @@ -56,6 +56,7 @@ SI::ARGS." (defvar *inside-trace* nil) (defun trace-one (spec) + (declare (si::c-local)) (let (break exitbreak (entrycond t) (exitcond t) entry exit step (barfp t) fname oldf) (cond ((atom spec) @@ -89,7 +90,7 @@ SI::ARGS." (when (null (fboundp fname)) (format *trace-output* "The function ~S is not defined.~%" fname) (return-from trace-one nil)) - (when (special-form-p fname) + (when (special-operator-p fname) (format *trace-output* "~S is a special form.~%" fname) (return-from trace-one nil)) (when (macro-function fname) @@ -142,6 +143,7 @@ SI::ARGS." (cons fname nil))) (defun trace-print (direction fname vals &rest extras) + (declare (si::c-local)) (let ((indent (min (* (1- *trace-level*) 2) 20))) (fresh-line *trace-output*) (case direction @@ -173,6 +175,7 @@ SI::ARGS." extras)))) (defun untrace-one (fname) + (declare (si::c-local)) (cond ((get fname 'TRACED) (if (tracing-body fname) (sys:fset fname (symbol-function (get fname 'TRACED))) diff --git a/src/util/ecl-config b/src/util/ecl-config new file mode 100644 index 000000000..6805728e6 --- /dev/null +++ b/src/util/ecl-config @@ -0,0 +1,39 @@ +#!/bin/sh + +usage() +{ + cat <&2 + ;; + esac; +done + +if test "$echo_cflags" = "yes"; then + echo "@CFLAGS@ -D@host@ -I@includedir@" +fi + +if test "$echo_ldflags" = "yes"; then + echo "-L@libdir@ $LDFLAGS -llsp @LDFLAGS@ @CLIBS@" +fi diff --git a/src/util/emacs.el b/src/util/emacs.el index b4041ec80..085b45c85 100644 --- a/src/util/emacs.el +++ b/src/util/emacs.el @@ -42,6 +42,7 @@ (switch-to-buffer b) (beginning-of-buffer))) (print '*) + (setq case-fold-search nil) (if (search-forward string nil t) (return))))) @@ -185,7 +186,6 @@ '( "h/object.h" "h/eval.h" -"h/lisp_external.h" "h/external.h" "c/character.d" "c/gfun.d"