diff --git a/src/CHANGELOG b/src/CHANGELOG index cd080a076..10ebfe860 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1747,6 +1747,9 @@ ECL 0.9d - (VALUES (FOO)) was compiled as a simple call (FOO), without truncating the number of values output by the latter. + - The printer of floating point numbers was inaccurate and could not + represent MOST-POSITIVE-LONG-FLOAT reliably. + * Documentation: - New manual page documents the scripting facilities of ECL diff --git a/src/Makefile.in b/src/Makefile.in index 885973aca..b8ff015c3 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -57,7 +57,7 @@ ecl_min$(EXE): $(LIBRARIES) .gdbinit libecl.a if [ -f CROSS-COMPILER ]; then \ touch $@; \ else \ - $(CC) $(LDFLAGS) -o $@ c/cinit.o -L./ @LIBPREFIX@ecl.@LIBEXT@ -lgmp -lgc $(LIBS);\ + $(CC) $(LDFLAGS) -o $@ c/cinit.o -L./ @LIBPREFIX@ecl.@LIBEXT@ -lgmp @GCLIB@ $(LIBS);\ fi .gdbinit: $(srcdir)/util/gdbinit diff --git a/src/c/Makefile.in b/src/c/Makefile.in index b1fcf2001..5f7e34ee4 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -9,7 +9,10 @@ VPATH = @srcdir@ # TRUE_CC = @CC@ CC = @ECL_CC@ -CFLAGS = -c -I$(srcdir) -I$(HDIR) -I../h @BOEHM_HEADERS@ @CFLAGS@ @ECL_CFLAGS@ +CFLAGS = -c -I$(srcdir) -I$(HDIR) -I../h @BOEHM_HEADERS@ @CFLAGS@ @ECL_CFLAGS@ \ + -Wall -W -Wfloat-equal -Wundef -Wendif-labels -Wpointer-arith -Wcast-align \ + -Wwrite-strings -Wconversion -Wsign-compare -Wmissing-prototypes -Wredundant-decls \ + -Wunreachable-code -Winline SHELL = /bin/sh RM = @RM@ diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 3612aa515..b10ebcddd 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -84,9 +84,9 @@ mangle_name(cl_object output, char *source, int l) cl_fixnum p; if (symbol == Cnil) - @(return Ct make_simple_string("Cnil")) + @(return Ct make_constant_string("Cnil")) else if (symbol == Ct) - @(return Ct make_simple_string("Ct")) + @(return Ct make_constant_string("Ct")) p = (cl_symbol_initializer*)symbol - cl_symbols; if (p >= 0 && p <= cl_num_symbols_in_core) { found = Ct; @@ -113,9 +113,9 @@ mangle_name(cl_object output, char *source, int l) } package= symbol->symbol.hpack; if (package == cl_core.lisp_package) - package = make_simple_string("cl"); + package = make_constant_string("cl"); else if (package == cl_core.system_package) - package = make_simple_string("si"); + package = make_constant_string("si"); else if (package == cl_core.keyword_package) package = Cnil; else diff --git a/src/c/alloc.d b/src/c/alloc.d index 262988409..664b128ef 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -35,6 +35,7 @@ #include #include #include "ecl.h" +#include "internal.h" #include "page.h" #define USE_MMAP @@ -167,8 +168,8 @@ alloc_page(cl_index n) { cl_ptr e = heap_end; if (n >= holepage) { - ecl_gc(t_contiguous); - cl_resize_hole(new_holepage+n); + ecl_gc(t_contiguous); + cl_resize_hole(new_holepage+n); } holepage -= n; heap_end += LISP_PAGESIZE*n; @@ -219,7 +220,7 @@ cl_alloc_object(cl_type t) return MAKE_FIXNUM(0); /* Immediate fixnum */ case t_character: return CODE_CHAR('\0'); /* Immediate character */ - default: + default:; } start_critical_section(); @@ -267,8 +268,8 @@ ONCE_MORE: break; case t_symbol: obj->symbol.plist = OBJNULL; - obj->gfdef = OBJNULL; - obj->value = OBJNULL; + obj->symbol.gfdef = OBJNULL; + obj->symbol.value = OBJNULL; obj->symbol.name = OBJNULL; break; case t_package: @@ -494,7 +495,7 @@ cl_alloc(cl_index n) volatile cl_ptr p; struct contblock **cbpp; cl_index i, m; - bool g, gg; + bool g; g = FALSE; n = round_up(n); @@ -588,7 +589,7 @@ cl_alloc_align(cl_index size, cl_index align) } static void -init_tm(cl_type t, char *name, cl_index elsize, cl_index maxpage) +init_tm(cl_type t, const char *name, cl_index elsize, cl_index maxpage) { int i, j; struct typemanager *tm = &tm_table[(int)t]; @@ -669,7 +670,7 @@ init_alloc(void) /* Initialization must be done in increasing size order: */ init_tm(t_shortfloat, "FSHORT-FLOAT", /* 8 */ sizeof(struct ecl_shortfloat), 1); - init_tm(t_cons, ".CONS", sizeof(struct cons), 384); /* 12 */ + init_tm(t_cons, ".CONS", sizeof(struct ecl_cons), 384); /* 12 */ init_tm(t_longfloat, "LLONG-FLOAT", /* 16 */ sizeof(struct ecl_longfloat), 1); init_tm(t_bytecodes, "bBYTECODES", sizeof(struct ecl_bytecodes), 64); @@ -741,7 +742,7 @@ t_from_type(cl_object type) if (available_pages() < tm->tm_maxpage - tm->tm_npage || (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) FEerror("Can't allocate ~D pages for ~A.", 2, type, - make_simple_string(tm->tm_name+1)); + make_constant_string(tm->tm_name+1)); for (; tm->tm_npage < tm->tm_maxpage; pp += LISP_PAGESIZE) add_page_to_freelist(pp, tm); @(return Ct) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 5c3ccf136..f8bf0dc02 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -42,8 +42,10 @@ finalize(cl_object o, cl_object data) case t_codeblock: cl_mapc(2, @'si::unlink-symbol', o->cblock.links); if (o->cblock.handle != NULL) { - printf("\n;;; Freeing library %s\n", o->cblock.name? - o->cblock.name->string.self : ""); + const char *name = o->cblock.name? + (const char *)o->cblock.name->string.self : + ""; + printf("\n;;; Freeing library %s\n", name); ecl_library_close(o); } #ifdef ECL_DYNAMIC_VV @@ -131,7 +133,7 @@ cl_alloc_instance(cl_index slots) } static void -init_tm(cl_type t, char *name, cl_index elsize) +init_tm(cl_type t, const char *name, cl_index elsize) { struct typemanager *tm = &tm_table[(int)t]; tm->tm_name = name; diff --git a/src/c/apply.d b/src/c/apply.d index bc0a29f6e..3f2836141 100644 --- a/src/c/apply.d +++ b/src/c/apply.d @@ -17,7 +17,7 @@ #include "ecl.h" cl_object -APPLY(int n, cl_objectfn fn, cl_object *x) +APPLY(cl_narg n, cl_objectfn fn, cl_object *x) { switch (n) { case 0: return (*fn)(n); @@ -342,7 +342,7 @@ APPLY(int n, cl_objectfn fn, cl_object *x) } cl_object -APPLY_closure(int n, cl_objectfn fn, cl_object cl, cl_object *x) +APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x) { switch (n) { case 0: return (*fn)(n, cl); @@ -667,7 +667,7 @@ APPLY_closure(int n, cl_objectfn fn, cl_object cl, cl_object *x) } cl_object -APPLY_fixed(int n, cl_object (*fn)(), cl_object *x) +APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) { switch (n) { case 0: return (*fn)(); diff --git a/src/c/array.d b/src/c/array.d index d7e485694..072044fdf 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -19,7 +19,6 @@ static void displace (cl_object from, cl_object to, cl_object offset); static void check_displaced (cl_object dlist, cl_object orig, cl_index newdim); -extern cl_elttype get_elttype (cl_object x); cl_index object_to_index(cl_object n) diff --git a/src/c/assignment.d b/src/c/assignment.d index 670d311af..e6c50923c 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -29,13 +29,12 @@ cl_set(cl_object var, cl_object val) @(defun si::fset (fname def &optional macro pprint) cl_object sym = si_function_block_name(fname); - cl_type t; bool mflag; @ if (Null(cl_functionp(def))) FEinvalid_function(def); if (sym->symbol.hpack != Cnil && sym->symbol.hpack->pack.locked) - funcall(3, @'warn', make_simple_string("~S is being redefined."), fname); + funcall(3, @'warn', make_constant_string("~S is being redefined."), fname); mflag = !Null(macro); if (sym->symbol.isform && !mflag) FEerror("Given that ~S is a special form, ~S cannot be defined as a function.", @@ -78,7 +77,7 @@ cl_fmakunbound(cl_object fname) cl_object sym = si_function_block_name(fname); if (sym->symbol.hpack != Cnil && sym->symbol.hpack->pack.locked) - funcall(3, @'warn', make_simple_string("~S is being redefined."), + funcall(3, @'warn', make_constant_string("~S is being redefined."), fname); if (SYMBOLP(fname)) { clear_compiler_properties(sym); diff --git a/src/c/backq.d b/src/c/backq.d index 754852cbe..56b2517e7 100644 --- a/src/c/backq.d +++ b/src/c/backq.d @@ -15,6 +15,7 @@ */ #include "ecl.h" +#include "internal.h" /******************************* ------- ******************************/ diff --git a/src/c/big.d b/src/c/big.d index d77990820..ba9fa8a26 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -15,6 +15,7 @@ #include #include "ecl.h" +#include "internal.h" /* * Using GMP multiple precision integers: diff --git a/src/c/bind.d b/src/c/bind.d deleted file mode 100644 index 19764940c..000000000 --- a/src/c/bind.d +++ /dev/null @@ -1,126 +0,0 @@ -/* - bind.c -- Lambda bindings. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ - - -#include "ecl.h" -#include "ecl-inl.h" - -#define NOT_YET 10 -#define FOUND 11 -#define NOT_KEYWORD 1 - -void -parse_key( - int narg, /* number of actual args */ - cl_object *args, /* actual args */ - int nkey, /* number of keywords */ - cl_object *keys, /* keywords for the function */ - cl_object *vars, /* where to put values (vars[0..nkey-1]) - and suppliedp (vars[nkey..2*nkey-1]) */ - cl_object rest, /* rest variable or NULL */ - bool allow_other_keys) /* whether other key are allowed */ -{ cl_object *p; - int i; - cl_object k; - - /* fill in the rest arg list */ - if (rest != OBJNULL) - for (i = narg, p = args; i > 0; i--) { - CAR(rest) = *p++; - rest = CDR(rest); - } - - for (i = 0; i < 2*nkey; i++) - vars[i] = Cnil; /* default values: NIL, supplied: NIL */ - if (narg <= 0) return; - - /* scan backwards, so that if a keyword is duplicated, first one is used */ - args = args + narg; - top: - while (narg >= 2) { - args = args - 2; - k = args[0]; - for (i = 0; i < nkey; i++) { - if (keys[i] == k) { - vars[i] = args[1]; - vars[nkey+i] = Ct; - narg = narg-2; - goto top; - } - } - /* the key is a new one */ - if (allow_other_keys) - narg = narg-2; - else { - /* look for :allow-other-keys t */ - for ( i = narg-2, p = args; i >= 0; i -= 2, p -=2) - if (*p == Kallow_other_keys) { - allow_other_keys = (p[1] != Cnil); break; - } - if (allow_other_keys) narg = narg-2; - else FEerror("Unrecognized key ~a", 1, k); - } - } - if (narg != 0) FEerror("Odd number of keys", 0); -} - -/* Used in compiled macros */ -void -check_other_key(cl_object l, int n, ...) -{ - cl_object other_key = OBJNULL; - cl_object k; - int i; - bool allow_other_keys = FALSE; - va_list ap; - va_start(ap, n); /* extracting arguments */ - - for (; !endp(l); l = CDDR(l)) { - k = CAR(l); - if (!keywordp(k)) - FEerror("~S is not a keyword.", 1, k); - if (endp(CDR(l))) - FEerror("Odd number of arguments for keywords.", 0); - if (k == Kallow_other_keys && CADR(l) != Cnil) { - allow_other_keys = TRUE; - } else { -#ifndef NO_ARG_ARRAY - cl_object *ktab = (cl_object *)ap; - for (i = 0; i < n; i++) - if (ktab[i] == k) { - ktab[i] = Cnil; /* remember seen */ - break; - } - if (i >= n) other_key = k; -#else - Rewrite this! -#endif NO_ARG_ARRAY - } - } - if (other_key != OBJNULL && !allow_other_keys) - FEerror("The keyword ~S is not allowed or is duplicated.", - 1, other_key); -} - -void -init_bind(void) -{ - make_constant("LAMBDA-LIST-KEYWORDS", - list(8, SAoptional, SArest, SAkey, SAallow_other_keys, SAaux, - make_ordinary("&WHOLE"), make_ordinary("&ENVIRONMENT"), make_ordinary("&BODY"))); - - make_constant("LAMBDA-PARAMETERS-LIMIT", MAKE_FIXNUM(64)); -} diff --git a/src/c/character.d b/src/c/character.d index 2d280798d..bdbe081f2 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -30,19 +30,15 @@ cl_standard_char_p(cl_object c) { /* INV: char_code() checks the type */ cl_fixnum i = char_code(c); - if ((' ' <= i && i < '\177') || i == '\n') - return1(Ct); - return1(Cnil); + @(return (((' ' <= i && i < '\177') || i == '\n')? Ct : Cnil)) } cl_object cl_graphic_char_p(cl_object c) { /* INV: char_code() checks the type */ - cl_fixnum i = char_code(c); - if (' ' <= i && i < '\177') /* ' ' < '\177' ??? Beppe*/ - return1(Ct); - return1(Cnil); + cl_fixnum i = char_code(c); /* ' ' < '\177' ??? Beppe*/ + @(return ((' ' <= i && i < '\177')? Ct : Cnil)) } cl_object @@ -50,28 +46,21 @@ cl_alpha_char_p(cl_object c) { /* INV: char_code() checks the type */ cl_fixnum i = char_code(c); - if (isalpha(i)) - return1(Ct); - else - return1(Cnil); + @(return (isalpha(i)? Ct : Cnil)) } cl_object cl_upper_case_p(cl_object c) { /* INV: char_code() checks the type */ - if (isupper(char_code(c))) - return1(Ct); - return1(Cnil); + @(return (isupper(char_code(c))? Ct : Cnil)) } cl_object cl_lower_case_p(cl_object c) { /* INV: char_code() checks the type */ - if (islower(char_code(c))) - return1(Ct); - return1(Cnil); + @(return (islower(char_code(c))? Ct : Cnil)) } cl_object @@ -79,21 +68,25 @@ cl_both_case_p(cl_object c) { /* INV: char_code() checks the type */ cl_fixnum code = char_code(c); - return1((isupper(code) || islower(code)) ? Ct : Cnil); + @(return ((isupper(code) || islower(code)) ? Ct : Cnil)) } #define basep(d) (d <= 36) @(defun digit_char_p (c &optional (r MAKE_FIXNUM(10))) - cl_fixnum d; + cl_object output; @ /* INV: char_code() checks `c' and fixnnint() checks `r' */ - if (type_of(r) == t_bignum) - @(return Cnil) - d = fixnnint(r); - if (!basep(d) || (d = digitp(char_code(c), d)) < 0) - @(return Cnil) - @(return MAKE_FIXNUM(d)) + if (type_of(r) == t_bignum) { + output = Cnil; + } else { + cl_fixnum d = fixnnint(r); + if (!basep(d) || (d = digitp(char_code(c), d)) < 0) + output = Cnil; + else + output = MAKE_FIXNUM(d); + } + @(return output) @) /* @@ -118,7 +111,7 @@ cl_alphanumericp(cl_object c) { /* INV: char_code() checks type of `c' */ cl_fixnum i = char_code(c); - return1(isalnum(i)? Ct : Cnil); + @(return (isalnum(i)? Ct : Cnil)) } @(defun char= (c &rest cs) @@ -155,8 +148,8 @@ char_eq(cl_object x, cl_object y) @(return Ct) @) -static cl_return -Lchar_cmp(int narg, int s, int t, cl_va_list args) +static cl_object +Lchar_cmp(cl_narg narg, int s, int t, cl_va_list args) { cl_object c, d; @@ -166,9 +159,9 @@ Lchar_cmp(int narg, int s, int t, cl_va_list args) for (; --narg; c = d) { d = cl_va_arg(args); if (s*char_cmp(d, c) < t) - return1(Cnil); + @(return Cnil) } - return1(Ct); + @(return Ct) } int @@ -182,22 +175,22 @@ char_cmp(cl_object x, cl_object y) @(defun char< (&rest args) @ - @(return Lchar_cmp(narg, 1, 1, args)) + return Lchar_cmp(narg, 1, 1, args); @) @(defun char> (&rest args) @ - @(return Lchar_cmp(narg,-1, 1, args)) + return Lchar_cmp(narg,-1, 1, args); @) @(defun char<= (&rest args) @ - @(return Lchar_cmp(narg, 1, 0, args)) + return Lchar_cmp(narg, 1, 0, args); @) @(defun char>= (&rest args) @ - @(return Lchar_cmp(narg,-1, 0, args)) + return Lchar_cmp(narg,-1, 0, args); @) @(defun char_equal (c &rest cs) @@ -243,8 +236,8 @@ char_equal(cl_object x, cl_object y) @(return Ct) @) -static cl_return -Lchar_compare(int narg, int s, int t, cl_va_list args) +static cl_object +Lchar_compare(cl_narg narg, int s, int t, cl_va_list args) { cl_object c, d; @@ -255,9 +248,9 @@ Lchar_compare(int narg, int s, int t, cl_va_list args) for (; --narg; c = d) { d = cl_va_arg(args); if (s*char_compare(d, c) < t) - return1(Cnil); + @(return Cnil) } - return1(Ct); + @(return Ct) } int @@ -280,22 +273,22 @@ char_compare(cl_object x, cl_object y) @(defun char-lessp (&rest args) @ - @(return Lchar_compare(narg, 1, 1, args)) + return Lchar_compare(narg, 1, 1, args); @) @(defun char-greaterp (&rest args) @ - @(return Lchar_compare(narg,-1, 1, args)) + return Lchar_compare(narg,-1, 1, args); @) @(defun char-not-greaterp (&rest args) @ - @(return Lchar_compare(narg, 1, 0, args)) + return Lchar_compare(narg, 1, 0, args); @) @(defun char-not-lessp (&rest args) @ - @(return Lchar_compare(narg,-1, 0, args)) + return Lchar_compare(narg,-1, 0, args); @) @@ -350,9 +343,7 @@ cl_char_upcase(cl_object c) { /* INV: char_code() checks the type of `c' */ cl_fixnum code = char_code(c); - return1(islower(code) ? - CODE_CHAR(toupper(code)) : - c); + @(return (islower(code) ? CODE_CHAR(toupper(code)) : c)) } cl_object @@ -360,25 +351,24 @@ cl_char_downcase(cl_object c) { /* INV: char_code() checks the type of `c' */ cl_fixnum code = char_code(c); - return1(isupper(code) ? - CODE_CHAR(tolower(code)) : - c); + @(return (isupper(code) ? CODE_CHAR(tolower(code)) : c)) } @(defun digit_char (w &optional (r MAKE_FIXNUM(10))) - int dw; + cl_object output; @ /* INV: fixnnint() checks the types of `w' and `r' */ - if (type_of(w) == t_bignum || type_of(r) == t_bignum) - @(return Cnil) - dw = digit_weight(fixnnint(w), fixnnint(r)); - if (dw < 0) - @(return Cnil) - @(return CODE_CHAR(dw)) + if (type_of(w) == t_bignum) { + output = Cnil; + } else { + int dw = ecl_digit_char(fixnnint(w), fixnnint(r)); + output = (dw < 0)? Cnil : CODE_CHAR(dw); + } + @(return output) @) short -digit_weight(int w, int r) +ecl_digit_char(cl_fixnum w, cl_fixnum r) { if (r < 2 || r > 36 || w < 0 || w >= r) return(-1); @@ -398,50 +388,47 @@ cl_char_int(cl_object c) cl_object cl_char_name(cl_object c) { + cl_object s; /* INV: char_code() checks the type of `c' */ switch (char_code(c)) { - case '\000': - return1(cl_core.string_null); - case '\r': - return1(cl_core.string_return); - case ' ': - return1(cl_core.string_space); - case '\177': - return1(cl_core.string_rubout); - case '\f': - return1(cl_core.string_page); - case '\t': - return1(cl_core.string_tab); - case '\b': - return1(cl_core.string_backspace); - case '\n': - return1(cl_core.string_newline); + case '\000': s = cl_core.string_null; break; + case '\b': s = cl_core.string_backspace; break; + case '\t': s = cl_core.string_tab; break; + case '\n': s = cl_core.string_newline; break; + case '\f': s = cl_core.string_page; break; + case '\r': s = cl_core.string_return; break; + case ' ': s = cl_core.string_space; break; + case '\177': s = cl_core.string_rubout; break; + default: s = Cnil; } - return1(Cnil); + @(return s) } cl_object cl_name_char(cl_object s) { - char c; + cl_object c; s = cl_string(s); - if (string_equal(s, cl_core.string_return)) - c = '\r'; else - if (string_equal(s, cl_core.string_space)) - c = ' '; else - if (string_equal(s, cl_core.string_rubout)) - c = '\177'; else - if (string_equal(s, cl_core.string_page)) - c = '\f'; else - if (string_equal(s, cl_core.string_tab)) - c = '\t'; else - if (string_equal(s, cl_core.string_backspace)) - c = '\b'; else - if (string_equal(s, cl_core.string_linefeed) || string_equal(s, cl_core.string_newline)) - c = '\n'; else - if (string_equal(s, cl_core.string_null)) - c = '\000'; else - return1(Cnil); - return1(CODE_CHAR(c)); + if (string_equal(s, cl_core.string_return)) { + c = CODE_CHAR('\r'); + } else if (string_equal(s, cl_core.string_space)) { + c = CODE_CHAR(' '); + } else if (string_equal(s, cl_core.string_rubout)) { + c = CODE_CHAR('\177'); + } else if (string_equal(s, cl_core.string_page)) { + c = CODE_CHAR('\f'); + } else if (string_equal(s, cl_core.string_tab)) { + c = CODE_CHAR('\t'); + } else if (string_equal(s, cl_core.string_backspace)) { + c = CODE_CHAR('\b'); + } else if (string_equal(s, cl_core.string_linefeed) || + string_equal(s, cl_core.string_newline)) { + c = CODE_CHAR('\n'); + } else if (string_equal(s, cl_core.string_null)) { + c = CODE_CHAR('\000'); + } else { + c = Cnil; + } + @(return c) } diff --git a/src/c/cinit.d b/src/c/cinit.d index 3d511d52e..45e6520ec 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -14,6 +14,7 @@ */ #include "ecl.h" +#include "internal.h" static cl_object si_simple_toplevel () { diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index 81fd0e299..f1262963a 100644 --- a/src/c/cmpaux.d +++ b/src/c/cmpaux.d @@ -60,8 +60,6 @@ object_to_char(cl_object x) switch (type_of(x)) { case t_fixnum: return fix(x); - case t_bignum: - return big_to_long(x) & (CHAR_CODE_LIMIT - 1); case t_character: return CHAR_CODE(x); default: @@ -74,11 +72,10 @@ object_to_fixnum(cl_object x) { switch (type_of(x)) { case t_fixnum: - return fix(x); + case t_bignum: + return fixint(x); case t_character: return (cl_fixnum)CHAR_CODE(x); - case t_bignum: - return (cl_fixnum)big_to_long(x); case t_ratio: return (cl_fixnum)number_to_double(x); case t_shortfloat: diff --git a/src/c/compiler.d b/src/c/compiler.d index 91d68a2e8..345a555b4 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -831,7 +831,7 @@ c_compiler_let(cl_object args, int flags) { static int c_cond(cl_object args, int flags) { cl_object test, clause; - cl_fixnum label_nil, label_exit; + cl_index label_nil, label_exit; if (Null(args)) return compile_form(Cnil, flags); @@ -1241,7 +1241,7 @@ c_go(cl_object args, int flags) { */ static int c_if(cl_object form, int flags) { - cl_fixnum label_nil, label_true; + cl_index label_nil, label_true; /* Compile test */ compile_form(pop(&form), FLAG_VALUES); @@ -1500,7 +1500,7 @@ c_multiple_value_setq(cl_object args, int flags) { cl_object vars = Cnil; cl_object temp_vars = Cnil; cl_object late_assignment = Cnil; - cl_object old_variables; + cl_object old_variables = ENV->variables; cl_index nvars = 0; /* Look for symbol macros, building the list of variables @@ -1522,7 +1522,6 @@ c_multiple_value_setq(cl_object args, int flags) { } if (!Null(temp_vars)) { - old_variables = ENV->variables; do { compile_form(Cnil, FLAG_REG0); c_bind(CAR(temp_vars), Cnil); @@ -1560,8 +1559,8 @@ c_multiple_value_setq(cl_object args, int flags) { asm_op(OP_PUSHVALUES); compile_body(late_assignment, FLAG_VALUES); asm_op(OP_POPVALUES); - c_undo_bindings(old_variables); } + c_undo_bindings(old_variables); return FLAG_VALUES; } @@ -1807,7 +1806,7 @@ static int c_tagbody(cl_object args, int flags) { cl_object old_env = ENV->variables; - cl_fixnum tag_base; + cl_index tag_base; cl_object labels = Cnil, label, body; cl_type item_type; int nt, i; @@ -2026,10 +2025,11 @@ for special form ~S.", 1, function); if (new_flags & (FLAG_REG0 | FLAG_VALUES)) asm_op(OP_PUSH); } else if (flags & FLAG_VALUES) { - if (new_flags & FLAG_REG0) + if (new_flags & FLAG_REG0) { asm_op(OP_VALUEREG0); - else if (new_flags & FLAG_PUSH) + } else if (new_flags & FLAG_PUSH) { FEerror("Internal error in bytecodes compiler", 0); + } } else if (new_flags & FLAG_PUSH) { FEerror("Internal error in bytecodes compiler", 0); } @@ -2370,7 +2370,7 @@ ILLEGAL_LAMBDA: } static cl_object -c_default(cl_fixnum base_pc, cl_object deflt) { +c_default(cl_index base_pc, cl_object deflt) { cl_type t = type_of(deflt); if (((t == t_symbol) && (deflt->symbol.stype == stp_constant) && !FIXNUMP(SYM_VAL(deflt)))) { @@ -2379,7 +2379,7 @@ c_default(cl_fixnum base_pc, cl_object deflt) { } else if (CONSP(deflt) && (CAR(deflt) == @'quote') && !FIXNUMP(CADR(deflt))) { deflt = CADR(deflt); } else if ((t == t_symbol) || (t == t_cons) || (t == t_fixnum)) { - cl_fixnum pc = current_pc()-base_pc; + cl_index pc = current_pc()-base_pc; compile_form(deflt, FLAG_VALUES); asm_op(OP_EXIT); deflt = MAKE_FIXNUM(pc); @@ -2527,7 +2527,7 @@ si_valid_function_name_p(cl_object name) output = Ct; else if (CONSP(name) && CAR(name) == @'setf') { name = CDR(name); - if (CONSP(name) && SYMBOLP(CAR(name)) && ENDP(CDR(name))) + if (CONSP(name) && SYMBOLP(CAR(name)) && endp(CDR(name))) output = Ct; } @(return output); diff --git a/src/c/dpp.c b/src/c/dpp.c index a5501a2a1..3d8567c4f 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -597,7 +597,7 @@ put_fhead(void) int i; put_lineno(); - fprintf(out, "cl_object %s(int narg", function_c_name); + fprintf(out, "cl_object %s(cl_narg narg", function_c_name); for (i = 0; i < nreq; i++) fprintf(out, ", cl_object %s", required[i]); if (nopt > 0 || rest_flag || key_flag) diff --git a/src/c/error.d b/src/c/error.d index 07b5658d3..f3a1c4284 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -15,6 +15,7 @@ */ #include "ecl.h" +#include "internal.h" #include #include #include @@ -60,7 +61,7 @@ internal_error(const char *s) /*****************************************************************************/ void -FEerror(char *s, int narg, ...) +FEerror(const char *s, int narg, ...) { cl_va_list args; cl_va_start(args, narg, narg, 0); @@ -71,7 +72,7 @@ FEerror(char *s, int narg, ...) } cl_object -CEerror(char *err, int narg, ...) +CEerror(const char *err, int narg, ...) { cl_va_list args; cl_va_start(args, narg, narg, 0); @@ -183,7 +184,7 @@ FEinvalid_macro_call(cl_object name) } void -FEinvalid_variable(char *s, cl_object obj) +FEinvalid_variable(const char *s, cl_object obj) { FEerror(s, 1, obj); } @@ -204,7 +205,7 @@ void FEinvalid_function_name(cl_object fname) { cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("Not a valid function name ~D"), + make_constant_string("Not a valid function name ~D"), @':format-arguments', cl_list(1, fname), @':expected-type', Ct, @':datum', fname); diff --git a/src/c/eval.d b/src/c/eval.d index aaee5096b..59e7a358b 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -77,7 +77,7 @@ cl_apply_from_stack(cl_index narg, cl_object x) switch (type_of(fun)) { case t_cfun: if (fun->cfun.narg >= 0) { - if (narg != fun->cfun.narg) + if (narg != (cl_index)fun->cfun.narg) FEwrong_num_arguments(fun); return APPLY_fixed(narg, fun->cfun.entry, cl_env.stack_top - narg); } diff --git a/src/c/file.d b/src/c/file.d index 2147e2d0f..502dc7985 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -799,7 +799,7 @@ si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) (stream->stream.mode == smm_io || stream->stream.mode == smm_output)) { - int towrite = end - start; + size_t towrite = end - start; if (fwrite(seq->vector.self.ch + start, sizeof(char), towrite, stream->stream.file) < towrite) { io_error(stream); @@ -853,9 +853,9 @@ si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) (stream->stream.mode == smm_io || stream->stream.mode == smm_output)) { - int toread = end - start; - int n = fread(seq->vector.self.ch + start, sizeof(char), - toread, stream->stream.file); + size_t toread = end - start; + size_t n = fread(seq->vector.self.ch + start, sizeof(char), + toread, stream->stream.file); if (n < toread && ferror(stream->stream.file)) io_error(stream); start += n; @@ -1671,28 +1671,26 @@ cl_output_stream_p(cl_object strm) @(return strm) @) -@(defun file_position (file_stream &o position) - int i; +@(defun file-position (file_stream &o position) + long i; + cl_object output; @ if (Null(position)) { i = file_position(file_stream); - if (i < 0) - @(return Cnil) - @(return MAKE_FIXNUM(i)) + output = (i < 0)? Cnil : MAKE_FIXNUM(i); } else { - if (position == @':start') + if (position == @':start') { i = 0; - else if (position == @':end') + } else if (position == @':end') { i = file_length(file_stream); - else if (!FIXNUMP(position) || - (i = fix((position))) < 0) + } else if (!FIXNUMP(position) || (i = fix((position))) < 0) { FEerror("~S is an illegal file position~%\ for the file-stream ~S.", 2, position, file_stream); - if (file_position_set(file_stream, i) < 0) - @(return Cnil) - @(return Ct) + } + output = (file_position_set(file_stream, i) < 0)? Cnil : Ct; } + @(return output) @) cl_object @@ -1797,7 +1795,7 @@ init_file(void) standard_input->stream.mode = (short)smm_input; standard_input->stream.file = stdin; standard_input->stream.object0 = @'base-char'; - standard_input->stream.object1 = make_simple_string("stdin"); + standard_input->stream.object1 = make_constant_string("stdin"); standard_input->stream.int0 = 0; standard_input->stream.int1 = 0; @@ -1805,7 +1803,7 @@ init_file(void) standard_output->stream.mode = (short)smm_output; standard_output->stream.file = stdout; standard_output->stream.object0 = @'base-char'; - standard_output->stream.object1= make_simple_string("stdout"); + standard_output->stream.object1= make_constant_string("stdout"); standard_output->stream.int0 = 0; standard_output->stream.int1 = 0; diff --git a/src/c/format.d b/src/c/format.d index 55f45f408..76525882f 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -73,7 +73,7 @@ static const char *fmt_ordinal[] = { }; static void format(format_stack, const char *s, cl_index); -static cl_object doformat(int narg, cl_object strm, cl_object string, cl_va_list args, bool in_formatter); +static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, cl_va_list args, bool in_formatter); static cl_object get_aux_stream(void) @@ -1778,7 +1778,7 @@ fmt_semicolon(format_stack fmt, bool colon, bool atsign) static cl_object -doformat(int narg, cl_object strm, cl_object string, cl_va_list args, bool in_formatter) +doformat(cl_narg narg, cl_object strm, cl_object string, cl_va_list args, bool in_formatter) { struct format_stack_struct fmt; jmp_buf fmt_jmp_buf0; diff --git a/src/c/gbc.d b/src/c/gbc.d index da4be20c7..f30074664 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -22,8 +22,6 @@ #include "internal.h" #include "bytecodes.h" -#ifndef GBC_BOEHM - /******************************* EXPORTS ******************************/ bool GC_enable; @@ -61,8 +59,9 @@ static int gc_time; /* Beppe */ We must register location, since value may be reassigned (e.g. malloc_list) */ -static void _mark_object (cl_object x); -static void _mark_contblock (void *p, cl_index s); +static void _mark_object(cl_object x); +static void _mark_contblock(void *p, cl_index s); +static void mark_cl_env(struct cl_env_struct *env); extern void sigint (void); void @@ -158,6 +157,7 @@ BEGIN: break; case t_symbol: + mark_object(x->symbol.hpack); mark_object(x->symbol.name); mark_object(x->symbol.plist); mark_object(SYM_FUN(x)); @@ -188,7 +188,7 @@ BEGIN: mark_object(x->hash.data[i].key); mark_object(x->hash.data[i].value); } - mark_contblock(x->hash.data, j * sizeof(struct hashtable_entry)); + mark_contblock(x->hash.data, j * sizeof(struct ecl_hashtable_entry)); break; case t_array: @@ -261,7 +261,7 @@ BEGIN: #endif /* CLOS */ case t_stream: - switch ((enum smmode)x->stream.mode) { + switch ((enum ecl_smmode)x->stream.mode) { case smm_closed: /* Rest of fields are NULL */ mark_next(x->stream.object1); @@ -307,7 +307,7 @@ BEGIN: if (x->readtable.table == NULL) break; mark_contblock((cl_ptr)(x->readtable.table), - RTABSIZE*sizeof(struct readtable_entry)); + RTABSIZE*sizeof(struct ecl_readtable_entry)); for (i = 0; i < RTABSIZE; i++) { cl_object *p = x->readtable.table[i].dispatch_table; mark_object(x->readtable.table[i].macro); @@ -352,13 +352,12 @@ BEGIN: case t_process: /* Already marked by malloc: x->process.env */ -#error "The old garbage collector does not support threads" - mark_contblock(x->process.pthread, sizeof(*x->process.thread)); + mark_object(x->process.interrupt); mark_object(x->process.function); + mark_cl_env(x->process.env); mark_next(x->process.args); break; case t_lock: - mark_contblock(x->lock.mutex, sizeof(*x->lock.mutex)); mark_next(x->lock.name); break; #endif /* THREADS */ @@ -372,6 +371,7 @@ BEGIN: case t_codeblock: mark_object(x->cblock.name); mark_object(x->cblock.next); + mark_object(x->cblock.links); i = x->cblock.data_size; p = x->cblock.data; goto MARK_DATA; @@ -381,7 +381,7 @@ BEGIN: mark_contblock(x->foreign.data, x->foreign.size); mark_next(x->foreign.tag); break; -#endif ECL_FFI +#endif /* ECL_FFI */ MARK_DATA: if (p) { mark_contblock(p, i * sizeof(cl_object)); @@ -430,13 +430,78 @@ mark_stack_conservative(cl_ptr bottom, cl_ptr top) if (debug) {printf(". done.\n"); fflush(stdout); } } +static void +mark_cl_env(struct cl_env_struct *env) +{ + int i; + cl_object where; + bds_ptr bdp; + frame_ptr frp; + + mark_contblock(env, sizeof(*env)); + + mark_object(env->lex_env); + + mark_contblock(env->stack, env->stack_size * sizeof(cl_object)); + mark_stack_conservative((cl_ptr)env->stack, (cl_ptr)env->stack_top); + + if (bdp = env->bds_org) { + mark_contblock(bdp, env->bds_size * sizeof(*bdp)); + for (; bdp <= env->bds_top; bdp++) { + mark_object(bdp->symbol); + mark_object(bdp->value); + } + } + + if (frp = env->frs_org) { + mark_contblock(frp, env->frs_size * sizeof(*frp)); + for (; frp <= env->frs_top; frp++) { + mark_object(frp->frs_val); + } + } + + for (i=0; invalues; i++) + mark_object(env->values[i]); + + mark_object(env->token); + +/* mark_object(env->c_env->variables); + mark_object(env->c_env->macros); + mark_object(env->c_env->constants); */ + + mark_object(env->fmt_aux_stream); + + mark_object(env->print_case); + mark_object(env->print_package); + mark_object(env->print_stream); + mark_object(env->circle_stack); + mark_contblock(env->queue, sizeof(short) * ECL_PPRINT_QUEUE_SIZE); + mark_contblock(env->indent_stack, sizeof(short) * ECL_PPRINT_INDENTATION_STACK_SIZE); + + mark_object(env->big_register[0]); + mark_object(env->big_register[1]); + mark_object(env->big_register[2]); + + mark_object(env->print_case); + mark_object(env->print_package); + mark_object(env->print_stream); + +#ifdef THREADS +/* We should mark the stacks of the threads somehow!!! */ +#error "The old garbage collector does not support threads" +#else +# if DOWN_STACK + mark_stack_conservative((cl_ptr)(&where), (cl_ptr)env->cs_org); +# else + mark_stack_conservative((cl_ptr)env->cs_org, (cl_ptr)(&where)); +# endif /* DOWN_STACK */ +#endif /* THREADS */ +} + static void mark_phase(void) { int i; - cl_object p; - bds_ptr bdp; - frame_ptr frp; /* mark registered symbols & keywords */ for (i=0; ipd_next) { - - clwp = pdp->pd_lpd; -#endif /* THREADS */ - - mark_contblock(cl_env.stack, cl_env.stack_size * sizeof(cl_object)); - mark_stack_conservative(cl_env.stack, cl_env.stack_top); - - for (i=0; ibds_sym); - mark_object(bdp->bds_val); - } - - for (frp = cl_env.frs_org; frp <= cl_env.frs_top; frp++) { - mark_object(frp->frs_val); - } - - mark_object(cl_env.lex_env); - mark_object(cl_env.token); - mark_object(cl_env.fmt_aux_stream); - mark_object(cl_env.print_case); - mark_object(cl_env.print_package); - mark_object(cl_env.print_stream); - mark_object(cl_env.circle_stack); - mark_contblock(cl_env.queue, sizeof(short) * ECL_PPRINT_QUEUE_SIZE); - mark_contblock(cl_env.indent_stack, sizeof(short) * ECL_PPRINT_INDENT_STACK_SIZE); - mark_object(cl_env.big_register[0]); - mark_object(cl_env.big_register[1]); - mark_object(cl_env.big_register[2]); - -#ifdef THREADS - /* added to mark newly allocated objects */ - mark_object(clwp->lwp_alloc_temporary); - mark_object(clwp->lwp_fmt_temporary_stream); - mark_object(clwp->lwp_PRINTstream); - mark_object(clwp->lwp_PRINTcase); - mark_object(clwp->lwp_READtable); - mark_object(clwp->lwp_token); - mark_object(clwp->lwp_CIRCLEstack); - - /* (current-thread) can return it at any time - */ - mark_object(clwp->lwp_thread); -#endif /* THREADS */ - - /* now collect from the c-stack of the thread ... */ - - { int *where; - volatile jmp_buf buf; - - /* ensure flushing of register caches */ - if (ecl_setjmp(buf) == 0) ecl_longjmp(buf, 1); - -#ifdef THREADS - if (clwp != old_clwp) /* is not the executing stack */ -# ifdef __linux - where = (int *)pdp->pd_env[0].__jmpbuf[0].__sp; -# else - where = (int *)pdp->pd_env[JB_SP]; -# endif - else -#endif /* THREADS */ - where = (int *)&where ; - - /* If the locals of type object in a C function could be - aligned other than on multiples of sizeof (char *) - we would have to mark twice */ -#if DOWN_STACK - /* if (where < cs_org) */ - mark_stack_conservative((cl_ptr)where, (cl_ptr)cs_org); -#else - /* if (where > cs_org) */ - mark_stack_conservative((cl_ptr)cs_org, (cl_ptr)where); -#endif - mark_stack_conservative(&buf, (&buf) + 1); - } -#ifdef THREADS - } - clwp = old_clwp; - } -#endif /* THREADS */ - - for (p = &cl_core.packages; p <= &cl_core.Jan1st1970UT; p++) { - mark_object(*p); - } + mark_stack_conservative((cl_ptr)&cl_core.packages, + (cl_ptr)(&cl_core.system_properties + 1)); /* mark roots */ for (i = 0; i < gc_roots; i++) mark_object(*gc_root[i]); + +#ifdef THREADS + mark_object(cl_core.processes); +#else + mark_cl_env(&cl_env); +#endif } static void @@ -599,24 +576,25 @@ sweep_phase(void) switch (x->d.t) { #ifdef ENABLE_DLOPEN case t_codeblock: - cl_mapc(2, @'si::unlink-symbol', o->cblock.links); - if (o->cblock.handle != NULL) { - printf("\n;;; Freeing library %s\n", o->cblock.name? - o->cblock.name->string.self : ""); - dlclose(o->cblock.handle); + cl_mapc(2, @'si::unlink-symbol', x->cblock.links); + if (x->cblock.handle != NULL) { + printf("\n;;; Freeing library %s\n", x->cblock.name? + (const char *)x->cblock.name->string.self : + ""); + ecl_library_close(x); } break; #endif case t_stream: - if (o->stream.file != NULL) - fclose(o->stream.file); - o->stream.file = NULL; + if (x->stream.file != NULL) + fclose(x->stream.file); + x->stream.file = NULL; #ifdef ECL_THREADS case t_lock: - if (o->lock.mutex != NULL) - pthread_mutex_destroy(o->lock.mutex); + pthread_mutex_destroy(&x->lock.mutex); break; #endif + default:; } ((struct freelist *)x)->f_link = f; x->d.m = FREE; @@ -678,221 +656,146 @@ contblock_sweep_phase(void) cl_object (*GC_enter_hook)() = NULL; cl_object (*GC_exit_hook)() = NULL; - -#ifdef THREADS -/* - * We execute the GC routine in the main stack. - * The idea is to switch over the main stack that is stopped in the intha - * and to call the GC from there on garbage_parameter. Then you can switch - * back after. - * In addition the interrupt is disabled. - */ -static int i, j; -static sigjmp_buf old_env; -static int val; -static lpd *old_clwp; -static cl_type t; -static bool stack_switched = FALSE; - -static cl_type garbage_parameter; - -void -ecl_gc(cl_type new_name) -{ - int tm; - int gc_start = runtime(); - cl_object old_interrupt_enable; - - start_critical_section(); - t = new_name; - garbage_parameter = new_name; -#else - void ecl_gc(cl_type t) { - int i, j; - int tm; - int gc_start = runtime(); - cl_object old_interrupt_enable; -#endif /* THREADS */ + int i, j; + int tm; + int gc_start = ecl_runtime(); + bool interrupts; - if (!GC_enabled()) - return; + if (!GC_enabled()) + return; - CL_SAVE_ENVIRONMENT; + CL_NEWENV_BEGIN { + if (SYM_VAL(@'si::*gc-verbose*') != Cnil) { + printf("\n[GC .."); + /* To use this should add entries in tm_table for reloc and contig. + fprintf(stdout, "\n[GC for %d %s pages ..", + tm_of(t)->tm_npage, + tm_table[(int)t].tm_name + 1); */ + fflush(stdout); + } - if (SYM_VAL(@'si::*gc-verbose*') != Cnil) { - printf("\n[GC .."); - /* To use this should add entries in tm_table for reloc and contig. - fprintf(stdout, "\n[GC for %d %s pages ..", - tm_of(t)->tm_npage, - tm_table[(int)t].tm_name + 1); */ - fflush(stdout); - } + debug = symbol_value(@'si::*gc-message*') != Cnil; - debug = symbol_value(@'si::*gc-message*') != Cnil; + if (GC_enter_hook != NULL) + (*GC_enter_hook)(); #ifdef THREADS - if (clwp != &main_lpd) { - if (debug) { - printf("*STACK SWITCH*\n"); - fflush (stdout); - } - - stack_switched = TRUE; - val = sigsetjmp(old_env, 1); - if (val == 0) { - /* informations used by the garbage collector need to be updated */ -# ifdef __linux - running_head->pd_env[0].__jmpbuf[0].__sp = old_env[0].__jmpbuf[0].__sp; -# else - running_head->pd_env[JB_SP] = old_env[JB_SP]; -# endif - old_clwp = clwp; - Values = main_lpd.lwp_Values; - clwp = &main_lpd; - siglongjmp(main_pd.pd_env, 2); /* new line */ - } - } - - else val = 1; - - if (val == 1) { - +#error "We need to stop all other threads" #endif /* THREADS */ - if (GC_enter_hook != NULL) - (*GC_enter_hook)(); + interrupts = ecl_interrupt_enable; + ecl_interrupt_enable = 0; - old_interrupt_enable = ecl_enable_interrupt(Cnil); + collect_blocks = t > t_end; + if (collect_blocks) + cbgccount++; + else + tm_table[(int)t].tm_gccount++; - collect_blocks = t > t_end; - if (collect_blocks) - cbgccount++; - else - tm_table[(int)t].tm_gccount++; + if (debug) { + if (collect_blocks) + printf("GC entered for collecting blocks\n"); + else + printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); + fflush(stdout); + } - if (debug) { - if (collect_blocks) - printf("GC entered for collecting blocks\n"); - else - printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name); - fflush(stdout); - } + maxpage = page(heap_end); - maxpage = page(heap_end); + if (collect_blocks) { + /* + 1 page = 512 word + 512 bit = 16 word + */ + int mark_table_size = maxpage * (LISP_PAGESIZE / 32); + extern void cl_resize_hole(cl_index); + + if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1) + new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; + if (new_holepage < HOLEPAGE) + new_holepage = HOLEPAGE; + cl_resize_hole(new_holepage); - if (collect_blocks) { - /* - 1 page = 512 word - 512 bit = 16 word - */ - int mark_table_size = maxpage * (LISP_PAGESIZE / 32); - extern void cl_resize_hole(cl_index); + mark_table = (int*)heap_end; + for (i = 0; i < mark_table_size; i++) + mark_table[i] = 0; + } - if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1) - new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1; - if (new_holepage < HOLEPAGE) - new_holepage = HOLEPAGE; - cl_resize_hole(new_holepage); + if (debug) { + printf("mark phase\n"); + fflush(stdout); + tm = ecl_runtime(); + } + mark_phase(); + if (debug) { + printf("mark ended (%d)\n", ecl_runtime() - tm); + printf("sweep phase\n"); + fflush(stdout); + tm = ecl_runtime(); + } + sweep_phase(); + if (debug) { + printf("sweep ended (%d)\n", ecl_runtime() - tm); + fflush(stdout); + } - mark_table = (int*)heap_end; - for (i = 0; i < mark_table_size; i++) - mark_table[i] = 0; - } + if (t == t_contiguous) { + if (debug) { + printf("contblock sweep phase\n"); + fflush(stdout); + tm = ecl_runtime(); + } + contblock_sweep_phase(); + if (debug) + printf("contblock sweep ended (%d)\n", ecl_runtime() - tm); + } + + if (debug) { + for (i = 0, j = 0; i < (int)t_end; i++) { + if (tm_table[i].tm_type == (cl_type)i) { + printf("%13s: %8d used %8d free %4d/%d pages\n", + tm_table[i].tm_name, + tm_table[i].tm_nused, + tm_table[i].tm_nfree, + tm_table[i].tm_npage, + tm_table[i].tm_maxpage); + j += tm_table[i].tm_npage; + } else + printf("%13s: linked to %s\n", + tm_table[i].tm_name, + tm_table[(int)tm_table[i].tm_type].tm_name); + } + printf("contblock: %d blocks %d pages\n", ncb, ncbpage); + printf("hole: %d pages\n", holepage); + printf("GC ended\n"); + fflush(stdout); + } - if (debug) { - printf("mark phase\n"); - fflush(stdout); - tm = runtime(); - } - mark_phase(); - if (debug) { - printf("mark ended (%d)\n", runtime() - tm); - printf("sweep phase\n"); - fflush(stdout); - tm = runtime(); - } - sweep_phase(); - if (debug) { - printf("sweep ended (%d)\n", runtime() - tm); - fflush(stdout); - } + ecl_interrupt_enable = interrupts; - if (t == t_contiguous) { - if (debug) { - printf("contblock sweep phase\n"); - fflush(stdout); - tm = runtime(); - } - contblock_sweep_phase(); - if (debug) - printf("contblock sweep ended (%d)\n", runtime() - tm); - } + if (GC_exit_hook != NULL) + (*GC_exit_hook)(); - if (debug) { - for (i = 0, j = 0; i < (int)t_end; i++) { - if (tm_table[i].tm_type == (cl_type)i) { - printf("%13s: %8d used %8d free %4d/%d pages\n", - tm_table[i].tm_name, - tm_table[i].tm_nused, - tm_table[i].tm_nfree, - tm_table[i].tm_npage, - tm_table[i].tm_maxpage); - j += tm_table[i].tm_npage; - } else - printf("%13s: linked to %s\n", - tm_table[i].tm_name, - tm_table[(int)tm_table[i].tm_type].tm_name); - } - printf("contblock: %d blocks %d pages\n", ncb, ncbpage); - printf("hole: %d pages\n", holepage); - printf("GC ended\n"); - fflush(stdout); - } - - ecl_enable_interrupt(old_enable_interrupt); - - if (GC_exit_hook != NULL) - (*GC_exit_hook)(); - - CL_RESTORE_ENVIRONMENT; + } CL_NEWENV_END; #ifdef THREADS - - /* - * Back in the right stack - */ - - if (stack_switched) { - if (debug) { - printf("*STACK BACK*\n"); - fflush (stdout); - } - - stack_switched = FALSE; - - end_critical_section(); /* we get here from the GC call in scheduler */ - - clwp = old_clwp; - Values = clwp->lwp_Values; - siglongjmp(old_env, 2); - } - } +#error "We need to activate all other threads again" #endif /* THREADS */ - gc_time += (gc_start = runtime() - gc_start); + gc_time += (gc_start = ecl_runtime() - gc_start); - if (SYM_VAL(@'si::*gc-verbose*') != Cnil) { - /* Don't use fprintf since on Linux it calls malloc() */ - printf(". finished in %.2f\"]", gc_start/60.0); - fflush(stdout); - } + if (SYM_VAL(@'si::*gc-verbose*') != Cnil) { + /* Don't use fprintf since on Linux it calls malloc() */ + printf(". finished in %.2f\"]", gc_start/60.0); + fflush(stdout); + } - if (cl_env.interrupts_pending) si_check_pending_interrupts(); - - end_critical_section(); + if (cl_env.interrupt_pending) si_check_pending_interrupts(); + + end_critical_section(); } /* @@ -914,7 +817,7 @@ ecl_gc(cl_type t) static void _mark_contblock(void *x, cl_index s) { - cl_ptr p = x, q; + cl_ptr p = x; if (p >= heap_start && p < data_end) { ptrdiff_t pg = page(p); if ((cl_type)type_map[pg] == t_contiguous) { @@ -984,5 +887,3 @@ init_GC(void) GC_enable(); gc_time = 0; } - -#endif diff --git a/src/c/gfun.d b/src/c/gfun.d index 2b6f3b4d3..af66a0456 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -93,7 +93,7 @@ set_meth_hash(cl_object *keys, int argno, cl_object hashtable, cl_object value) } cl_object -compute_method(int narg, cl_object gf, cl_object *args) +compute_method(cl_narg narg, cl_object gf, cl_object *args) { cl_object func; int i, spec_no; diff --git a/src/c/hash.d b/src/c/hash.d index d653a3978..73172eb62 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -386,7 +386,7 @@ ecl_extend_hashtable(cl_object hashtable) if (new_size <= old_size) new_size = old_size + 1; old = cl_alloc_object(t_hashtable); - *old = *hashtable; + old->pack = hashtable->pack; hashtable->hash.data = NULL; /* for GC sake */ hashtable->hash.entries = 0; hashtable->hash.size = new_size; @@ -574,7 +574,7 @@ cl_hash_table_count(cl_object ht) } static cl_object -si_hash_table_iterate(int narg, cl_object env) +si_hash_table_iterate(cl_narg narg, cl_object env) { cl_object index = CAR(env); cl_object ht = CADR(env); diff --git a/src/c/instance.d b/src/c/instance.d index 1a10dda83..fff16bd5a 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -17,10 +17,10 @@ #include cl_object -ecl_allocate_instance(cl_object clas, int size) +ecl_allocate_instance(cl_object clas, cl_index size) { cl_object x = cl_alloc_instance(size); - int i; + cl_index i; CLASS_OF(x) = clas; for (i = 0; i < size; i++) x->instance.slots[i] = ECL_UNBOUND; @@ -73,12 +73,12 @@ si_instance_class_set(cl_object x, cl_object y) } cl_object -instance_ref(cl_object x, int i) +instance_ref(cl_object x, cl_fixnum i) { if (type_of(x) != t_instance) FEwrong_type_argument(@'ext::instance', x); - if (i >= x->instance.length || i < 0) - FEerror("~S is an illegal slot index1.",1,i); + if (i < 0 || i >= (cl_fixnum)x->instance.length) + FEtype_error_index(x, MAKE_FIXNUM(i)); return(x->instance.slots[i]); } @@ -90,8 +90,8 @@ si_instance_ref(cl_object x, cl_object index) if (type_of(x) != t_instance) FEwrong_type_argument(@'ext::instance', x); if (!FIXNUMP(index) || - (i = fix(index)) < 0 || i >= x->instance.length) - FEerror("~S is an illegal slot index.", 1, index); + (i = fix(index)) < 0 || i >= (cl_fixnum)x->instance.length) + FEtype_error_index(x, index); @(return x->instance.slots[i]) } @@ -104,20 +104,20 @@ si_instance_ref_safe(cl_object x, cl_object index) FEwrong_type_argument(@'ext::instance', x); if (!FIXNUMP(index) || (i = fix(index)) < 0 || i >= x->instance.length) - FEerror("~S is an illegal slot index.", 1, index); + FEtype_error_index(x, index); x = x->instance.slots[i]; if (x == ECL_UNBOUND) - FEerror("Slot index ~S unbound", 1, index); + cl_error(5, @'unbound-slot', @':name', index, @':instance', x); @(return x) } cl_object -instance_set(cl_object x, int i, cl_object v) +instance_set(cl_object x, cl_fixnum i, cl_object v) { if (type_of(x) != t_instance) FEwrong_type_argument(@'ext::instance', x); if (i >= x->instance.length || i < 0) - FEerror("~S is an illegal slot index2.", 1, i); + FEtype_error_index(x, MAKE_FIXNUM(i)); x->instance.slots[i] = v; return(v); } @@ -130,8 +130,8 @@ si_instance_set(cl_object x, cl_object index, cl_object value) if (type_of(x) != t_instance) FEwrong_type_argument(@'ext::instance', x); if (!FIXNUMP(index) || - (i = fix(index)) >= x->instance.length || i < 0) - FEerror("~S is an illegal slot index.", 1, index); + (i = fix(index)) >= (cl_fixnum)x->instance.length || i < 0) + FEtype_error_index(x, index); x->instance.slots[i] = value; @(return value) } @@ -165,7 +165,7 @@ si_sl_makunbound(cl_object x, cl_object index) FEwrong_type_argument(@'ext::instance', x); if (!FIXNUMP(index) || (i = fix(index)) >= x->instance.length || i < 0) - FEerror("~S is an illegal slot index.", 1, index); + FEtype_error_index(x, index); x->instance.slots[i] = ECL_UNBOUND; @(return x) } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index eefdf2b20..03ace7d0b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -105,16 +105,16 @@ cl_stack_pop_n(cl_index index) { cl_env.stack_top = new_top; } -int +cl_index cl_stack_push_values(void) { - int i; + cl_index i; for (i=0; i 0) VALUES(--n) = cl_stack_pop(); @@ -221,7 +221,7 @@ lambda_bind_var(cl_object var, cl_object val, cl_object specials) } static void -lambda_bind(int narg, cl_object lambda, cl_index sp) +lambda_bind(cl_narg narg, cl_object lambda, cl_index sp) { cl_object *data = lambda->bytecodes.data; cl_object specials = lambda->bytecodes.specials; @@ -331,7 +331,7 @@ lambda_bind(int narg, cl_object lambda, cl_index sp) } cl_object -lambda_apply(int narg, cl_object fun) +lambda_apply(cl_narg narg, cl_object fun) { cl_index args = cl_stack_index() - narg; cl_object name; @@ -382,7 +382,7 @@ search_global(register cl_object s) { /* Similar to funcall(), but registers calls in the IHS stack. */ static cl_object -interpret_funcall(int narg, cl_object fun) { +interpret_funcall(cl_narg narg, cl_object fun) { cl_object *args; cl_object x; @@ -431,7 +431,7 @@ interpret_funcall(int narg, cl_object fun) { } @(defun apply (fun lastarg &rest args) - int i; + cl_index i; @ narg -= 2; for (i = 0; narg; i++,narg--) { @@ -641,7 +641,7 @@ static cl_opcode * interpret_msetq(cl_object bytecodes, cl_opcode *vector) { cl_object value; - int i, n = GET_OPARG(vector); + cl_index i, n = GET_OPARG(vector); for (i=0; i= NVALUES) + if (n < 0) { + FEerror("Wrong index passed to NTH-VAL", 1, MAKE_FIXNUM(n)); + } else if ((cl_index)n >= NVALUES) { VALUES(0) = reg0 = Cnil; - else + } else { VALUES(0) = reg0 = VALUES(n); + } NVALUES = 1; break; } @@ -1312,7 +1315,7 @@ interpret(cl_object bytecodes, void *pc) { case OP_STEPIN: { cl_object form = GET_DATA(vector, bytecodes); cl_object a = SYM_VAL(@'si::*step-action*'); - int n = cl_stack_push_values(); + cl_index n = cl_stack_push_values(); if (a == Ct) { /* We are stepping in, but must first ask the user * what to do. */ @@ -1345,7 +1348,7 @@ interpret(cl_object bytecodes, void *pc) { } case OP_STEPOUT: { cl_object a = SYM_VAL(@'si::*step-action*'); - int n = cl_stack_push_values(); + cl_index n = cl_stack_push_values(); if (a == Ct) { /* We exit one stepping level */ ECL_SETQ(@'si::*step-level*', diff --git a/src/c/list.d b/src/c/list.d index 929234c74..b07040007 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -17,81 +17,77 @@ #include "ecl.h" #include "ecl-inl.h" -#ifdef THREADS -#define test_function clwp->lwp_test_function -#define item_compared clwp->lwp_item_compared -#define tf clwp->lwp_tf -#define key_function clwp->lwp_key_function -#define kf clwp->lwp_kf -#else -static cl_object test_function; -static cl_object item_compared; -static bool (*tf)(cl_object); -static cl_object key_function; -static cl_object (*kf)(cl_object); -#endif /* THREADS */ +struct cl_test { + bool (*test_c_function)(struct cl_test *, cl_object); + cl_object (*key_c_function)(struct cl_test *, cl_object); + cl_object test_function; + cl_object item_compared; + cl_object key_function; +}; -#define TEST(x) (*tf)(x) +static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree); +static void nsubst(struct cl_test *t, cl_object new_obj, cl_object *tree); +static cl_object sublis(struct cl_test *t, cl_object alist, cl_object tree); +static void nsublis(struct cl_test *t, cl_object alist, cl_object *treep); -#define saveTEST \ - cl_object old_test_function = test_function; \ - cl_object old_item_compared = item_compared; \ - bool (*old_tf)(cl_object) = tf; \ - cl_object old_key_function = key_function; \ - cl_object (*old_kf)(cl_object) = kf - -#define restoreTEST \ - test_function = old_test_function; \ - item_compared = old_item_compared; \ - tf = old_tf; \ - key_function = old_key_function; \ - kf = old_kf +#define TEST(t,k) ((t)->test_c_function)((t),(k)) static bool -test_compare(cl_object x) +test_compare(struct cl_test *t, cl_object x) { - cl_object test = funcall(3, test_function, item_compared, (*kf)(x)); - return (test != Cnil); + cl_object outcome = funcall(3, t->test_function, t->item_compared, + (t->key_c_function)(t, x)); + return (outcome != Cnil); } static bool -test_compare_not(cl_object x) +test_compare_not(struct cl_test *t, cl_object x) { - cl_object test = funcall(3, test_function, item_compared, (*kf)(x)); - return (test == Cnil); + cl_object outcome = funcall(3, t->test_function, t->item_compared, + (t->key_c_function)(t, x)); + return (outcome == Cnil); } static bool -test_eql(cl_object x) +test_eql(struct cl_test *t, cl_object x) { - return(eql(item_compared, (*kf)(x))); + return eql(t->item_compared, (t->key_c_function)(t, x)); } static cl_object -apply_key_function(cl_object x) +key_function(struct cl_test *t, cl_object x) { - return funcall(2, key_function, x); + return funcall(2, t->key_function, x); +} + +static cl_object +key_identity(struct cl_test *t, cl_object x) +{ + return x; } static void -setupTEST(cl_object item, cl_object test, cl_object test_not, cl_object key) +setupTEST(struct cl_test *t, cl_object item, cl_object test, + cl_object test_not, cl_object key) { - item_compared = item; + t->item_compared = item; if (test != Cnil) { if (test_not != Cnil) FEerror("Both :TEST and :TEST-NOT are specified.", 0); - test_function = test; - tf = test_compare; + t->test_function = test; + t->test_c_function = test_compare; } else if (test_not != Cnil) { - test_function = test_not; - tf = test_compare_not; - } else - tf = test_eql; + t->test_function = test_not; + t->test_c_function = test_compare_not; + } else { + t->test_c_function = test_eql; + } if (key != Cnil) { - key_function = key; - kf = apply_key_function; - } else - kf = cl_identity; + t->key_function = key; + t->key_c_function = key_function; + } else { + t->key_c_function = key_identity; + } } cl_object @@ -230,31 +226,33 @@ defcxr(cddddr, x, cdr(cdr(cdr(cdr(x))))) #define LENTH(n) (cl_object x) {\ return1(nth(n, x));\ } -cl_return @fifth LENTH(4) -cl_return @sixth LENTH(5) -cl_return @seventh LENTH(6) -cl_return @eighth LENTH(7) -cl_return @ninth LENTH(8) -cl_return @tenth LENTH(9) +cl_object @fifth LENTH(4) +cl_object @sixth LENTH(5) +cl_object @seventh LENTH(6) +cl_object @eighth LENTH(7) +cl_object @ninth LENTH(8) +cl_object @tenth LENTH(9) #undef LENTH static bool -tree_equal(cl_object x, cl_object y) +tree_equal(struct cl_test *t, cl_object x, cl_object y) { BEGIN: - if (CONSP(x)) - if (CONSP(y)) - if (tree_equal(CAR(x), CAR(y))) { + if (CONSP(x)) { + if (CONSP(y)) { + if (tree_equal(t, CAR(x), CAR(y))) { x = CDR(x); y = CDR(y); goto BEGIN; - } else + } else { return(FALSE); - else + } + } else { return(FALSE); - else { - item_compared = x; - if (TEST(y)) + } + } else { + t->item_compared = x; + if (TEST(t, y)) return(TRUE); else return(FALSE); @@ -262,12 +260,10 @@ BEGIN: } @(defun tree_equal (x y &key test test_not) + struct cl_test t; @ - setupTEST(Cnil, test, test_not, Cnil); - if (tree_equal(x, y)) - @(return Ct) - else - @(return Cnil) + setupTEST(&t, Cnil, test, test_not, Cnil); + @(return (tree_equal(&t, x, y)? Ct : Cnil)) @) cl_object @@ -343,7 +339,7 @@ nthcdr(cl_fixnum n, cl_object x) { if (n < 0) FEtype_error_index(x, MAKE_FIXNUM(n)); - while (n-- > 0 && !ENDP(x)) + while (n-- > 0 && !endp(x)) x = CDR(x); return(x); } @@ -555,15 +551,10 @@ cl_rplacd(cl_object x, cl_object v) } @(defun subst (new_obj old_obj tree &key test test_not key) - saveTEST; + struct cl_test t; @ - CL_UNWIND_PROTECT_BEGIN { - setupTEST(old_obj, test, test_not, key); - tree = subst(new_obj, tree); - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; - @(return tree) + setupTEST(&t, old_obj, test, test_not, key); + @(return subst(&t, new_obj, tree)) @) @@ -571,26 +562,24 @@ cl_rplacd(cl_object x, cl_object v) Subst(new, tree) returns the result of substituting new in tree. */ -cl_object -subst(cl_object new_obj, cl_object tree) +static cl_object +subst(struct cl_test *t, cl_object new_obj, cl_object tree) { - if (TEST(tree)) - return(new_obj); - else if (CONSP(tree)) - return(CONS(subst(new_obj, CAR(tree)), subst(new_obj, CDR(tree)))); - else - return(tree); + if (TEST(t, tree)) { + return new_obj; + } else if (CONSP(tree)) { + return CONS(subst(t, new_obj, CAR(tree)), + subst(t, new_obj, CDR(tree))); + } else { + return tree; + } } @(defun nsubst (new_obj old_obj tree &key test test_not key) - saveTEST; + struct cl_test t; @ - CL_UNWIND_PROTECT_BEGIN { - setupTEST(old_obj, test, test_not, key); - nsubst(new_obj, &tree); - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; + setupTEST(&t, old_obj, test, test_not, key); + nsubst(&t, new_obj, &tree); @(return tree) @) @@ -599,26 +588,22 @@ subst(cl_object new_obj, cl_object tree) the result of nsubstituting new in *treep to *treep. */ -void -nsubst(cl_object new_obj, cl_object *treep) +static void +nsubst(struct cl_test *t, cl_object new_obj, cl_object *treep) { - if (TEST(*treep)) + if (TEST(t, *treep)) { *treep = new_obj; - else if (CONSP(*treep)) { - nsubst(new_obj, &CAR(*treep)); - nsubst(new_obj, &CDR(*treep)); + } else if (CONSP(*treep)) { + nsubst(t, new_obj, &CAR(*treep)); + nsubst(t, new_obj, &CDR(*treep)); } } @(defun sublis (alist tree &key test test_not key) - saveTEST; + struct cl_test t; @ - CL_UNWIND_PROTECT_BEGIN { - setupTEST(Cnil, test, test_not, key); - tree = sublis(alist, tree); - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; + setupTEST(&t, Cnil, test, test_not, key); + tree = sublis(&t, alist, tree); @(return tree) @) @@ -626,36 +611,32 @@ nsubst(cl_object new_obj, cl_object *treep) Sublis(alist, tree) returns result of substituting tree by alist. */ -cl_object -sublis(cl_object alist, cl_object tree) +static cl_object +sublis(struct cl_test *t, cl_object alist, cl_object tree) { cl_object x = alist; - cl_object (*old_kf)(cl_object) = kf; - kf = cl_identity; - item_compared = (*old_kf)(tree); + struct cl_test local_t = *t; + local_t.key_c_function = key_identity; + local_t.item_compared = (t->key_c_function)(t, tree); loop_for_in(x) { cl_object node = CAR(x); - if (TEST(cl_car(node))) { - kf = old_kf; + if (TEST(&local_t, cl_car(node))) { return CDR(node); } } end_loop_for_in; - kf = old_kf; - if (CONSP(tree)) - return(CONS(sublis(alist, CAR(tree)), sublis(alist, CDR(tree)))); - else - return(tree); + if (CONSP(tree)) { + return CONS(sublis(t, alist, CAR(tree)), + sublis(t, alist, CDR(tree))); + } else { + return tree; + } } @(defun nsublis (alist tree &key test test_not key) - saveTEST; + struct cl_test t; @ - CL_UNWIND_PROTECT_BEGIN { - setupTEST(Cnil, test, test_not, key); - nsublis(alist, &tree); - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; + setupTEST(&t, Cnil, test, test_not, key); + nsublis(&t, alist, &tree); @(return tree) @) @@ -664,40 +645,34 @@ sublis(cl_object alist, cl_object tree) the result of substiting *treep by alist to *treep. */ -void -nsublis(cl_object alist, cl_object *treep) +static void +nsublis(struct cl_test *t, cl_object alist, cl_object *treep) { cl_object x = alist; - cl_object (*old_kf)(cl_object) = kf; - kf = cl_identity; - item_compared = (*old_kf)(*treep); + struct cl_test local_t = *t; + local_t.key_c_function = key_identity; + local_t.item_compared = (t->key_c_function)(t, *treep); loop_for_in(x) { cl_object node = CAR(x); - if (TEST(cl_car(node))) { + if (TEST(&local_t, cl_car(node))) { *treep = CDR(node); - kf = old_kf; return; } } end_loop_for_in; - kf = old_kf; if (CONSP(*treep)) { - nsublis(alist, &CAR(*treep)); - nsublis(alist, &CDR(*treep)); + nsublis(t, alist, &CAR(*treep)); + nsublis(t, alist, &CDR(*treep)); } } @(defun member (item list &key test test_not key) - saveTEST; + struct cl_test t; @ - CL_UNWIND_PROTECT_BEGIN { - setupTEST(item, test, test_not, key); - loop_for_in(list) { - if (TEST(CAR(list))) - break; - } end_loop_for_in; - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; + setupTEST(&t, item, test, test_not, key); + loop_for_in(list) { + if (TEST(&t, CAR(list))) + break; + } end_loop_for_in; @(return list) @) @@ -746,19 +721,15 @@ member(cl_object x, cl_object l) cl_object si_member1(cl_object item, cl_object list, cl_object test, cl_object test_not, cl_object key) { - saveTEST; + struct cl_test t; - CL_UNWIND_PROTECT_BEGIN { - if (key != Cnil) - item = funcall(2, key, item); - setupTEST(item, test, test_not, key); - loop_for_in(list) { - if (TEST(CAR(list))) - break; - } end_loop_for_in; - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; + if (key != Cnil) + item = funcall(2, key, item); + setupTEST(&t, item, test, test_not, key); + loop_for_in(list) { + if (TEST(&t, CAR(list))) + break; + } end_loop_for_in; @(return list) } @@ -803,12 +774,12 @@ cl_acons(cl_object x, cl_object y, cl_object z) k = keys; d = data; loop_for_in(k) { - if (ENDP(d)) + if (endp(d)) goto error; a_list = CONS(CONS(CAR(k), CAR(d)), a_list); d = CDR(d); } end_loop_for_in; - if (!ENDP(d)) + if (!endp(d)) error: FEerror("The keys ~S and the data ~S are not of the same length", 2, keys, data); @(return a_list) @@ -816,46 +787,38 @@ error: FEerror("The keys ~S and the data ~S are not of the same length", @(defun assoc (item a_list &key test test_not key) - saveTEST; + struct cl_test t; @ - CL_UNWIND_PROTECT_BEGIN { - setupTEST(item, test, test_not, key); - loop_for_in(a_list) { - cl_object pair = CAR(a_list); - if (Null(pair)) - ; - else if (ATOM(pair)) - FEtype_error_alist(pair); - else if (TEST(CAAR(a_list))) { - a_list = CAR(a_list); - break; - } - } end_loop_for_in; - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; + setupTEST(&t, item, test, test_not, key); + loop_for_in(a_list) { + cl_object pair = CAR(a_list); + if (Null(pair)) { + ; + } else if (ATOM(pair)) { + FEtype_error_alist(pair); + } else if (TEST(&t, CAAR(a_list))) { + a_list = CAR(a_list); + break; + } + } end_loop_for_in; @(return a_list) @) @(defun rassoc (item a_list &key test test_not key) - saveTEST; + struct cl_test t; @ - CL_UNWIND_PROTECT_BEGIN { - setupTEST(item, test, test_not, key); - loop_for_in(a_list) { - cl_object pair = CAR(a_list); - if (Null(pair)) - ; - else if (ATOM(pair)) - FEtype_error_alist(pair); - else if (TEST(CDAR(a_list))) { + setupTEST(&t, item, test, test_not, key); + loop_for_in(a_list) { + cl_object pair = CAR(a_list); + if (Null(pair)) { + ; + } else if (ATOM(pair)) { + FEtype_error_alist(pair); + } else if (TEST(&t, CDAR(a_list))) { a_list = CAR(a_list); break; } - } end_loop_for_in; - } CL_UNWIND_PROTECT_EXIT { - restoreTEST; - } CL_UNWIND_PROTECT_END; + } end_loop_for_in; @(return a_list) @) diff --git a/src/c/load.d b/src/c/load.d index 8d5c953ff..052df1b84 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -15,6 +15,7 @@ #include "ecl.h" #include "ecl-inl.h" +#include "internal.h" #ifdef ENABLE_DLOPEN #ifdef HAVE_DLFCN_H @@ -136,12 +137,12 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print) /* Next try to call "init_FILE()" where FILE is the file name */ prefix = symbol_value(@'si::*init-function-prefix*'); if (Null(prefix)) - prefix = make_simple_string(INIT_PREFIX); + prefix = make_constant_string(INIT_PREFIX); else prefix = @si::string-concatenate(3, - make_simple_string(INIT_PREFIX), + make_constant_string(INIT_PREFIX), prefix, - make_simple_string("_")); + make_constant_string("_")); basename = cl_pathname_name(1,filename); basename = @si::string-concatenate(2, prefix, @string-upcase(1,basename)); block->cblock.entry = ecl_library_symbol(block, basename->string.self); @@ -267,7 +268,7 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) } NOT_A_FILENAME: if (verbose != Cnil) { - cl_format(3, Ct, make_simple_string("~&;;; Loading ~s~%"), + cl_format(3, Ct, make_constant_string("~&;;; Loading ~s~%"), filename); } bds_bind(@'*package*', symbol_value(@'*package*')); @@ -282,7 +283,7 @@ NOT_A_FILENAME: FEerror("LOAD: Could not load file ~S (Error: ~S)", 2, filename, ok); if (print != Cnil) { - cl_format(3, Ct, make_simple_string("~&;;; Loading ~s~%"), + cl_format(3, Ct, make_constant_string("~&;;; Loading ~s~%"), filename); } @(return filename) diff --git a/src/c/macros.d b/src/c/macros.d index 2d1002f6e..cf1def6f8 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -15,6 +15,7 @@ */ #include "ecl.h" +#include "internal.h" /******************************* REQUIRES ******************************/ diff --git a/src/c/main.d b/src/c/main.d index 06345d4d2..e53fdb80b 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -42,14 +42,6 @@ static char stdin_buf[BUFSIZ]; static char stdout_buf[BUFSIZ]; #endif -#ifdef __cplusplus -extern "C" void init_LSP(void); -extern "C" void init_CLOS(void); -#else -extern void init_LSP(); -extern void init_CLOS(); -#endif - void ecl_init_env(struct cl_env_struct *env) { @@ -81,12 +73,23 @@ ecl_init_env(struct cl_env_struct *env) env->circle_counter = -2; env->circle_stack = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), - make_shortfloat(1.5), - make_shortfloat(0.7), Cnil); + make_shortfloat(1.5f), + make_shortfloat(0.75f), Cnil); #ifndef ECL_CMU_FORMAT env->fmt_aux_stream = make_string_output_stream(64); #endif +#if !defined(GBC_BOEHM) +# if defined(THREADS) +# error "No means to mark the stack of a thread :-/" +# else + /* Rough estimate. Not very safe. We assume that cl_boot() + * is invoked from the main() routine of the program. + */ + env->cs_org = (cl_object*)(&env); +# endif /* THREADS */ +#endif /* !GBC_BOEHM */ + init_stacks(&i); } @@ -122,7 +125,7 @@ cl_boot(int argc, char **argv) Cnil->symbol.t = (short)t_symbol; Cnil->symbol.dynamic = 0; Cnil->symbol.value = Cnil; - Cnil->symbol.name = make_simple_string("NIL"); + Cnil->symbol.name = make_constant_string("NIL"); Cnil->symbol.gfdef = OBJNULL; Cnil->symbol.plist = Cnil; Cnil->symbol.hpack = Cnil; @@ -134,7 +137,7 @@ cl_boot(int argc, char **argv) Ct->symbol.t = (short)t_symbol; Ct->symbol.dynamic = 0; Ct->symbol.value = Ct; - Ct->symbol.name = make_simple_string("T"); + Ct->symbol.name = make_constant_string("T"); Ct->symbol.gfdef = OBJNULL; Ct->symbol.plist = Cnil; Ct->symbol.hpack = Cnil; @@ -147,34 +150,34 @@ cl_boot(int argc, char **argv) cl_core.packages_to_be_created = OBJNULL; cl_core.lisp_package = - make_package(make_simple_string("COMMON-LISP"), - CONS(make_simple_string("CL"), - CONS(make_simple_string("LISP"),Cnil)), + make_package(make_constant_string("COMMON-LISP"), + CONS(make_constant_string("CL"), + CONS(make_constant_string("LISP"),Cnil)), Cnil); cl_core.user_package = - make_package(make_simple_string("COMMON-LISP-USER"), - CONS(make_simple_string("CL-USER"), - CONS(make_simple_string("USER"),Cnil)), + make_package(make_constant_string("COMMON-LISP-USER"), + CONS(make_constant_string("CL-USER"), + CONS(make_constant_string("USER"),Cnil)), CONS(cl_core.lisp_package, Cnil)); - cl_core.keyword_package = make_package(make_simple_string("KEYWORD"), + cl_core.keyword_package = make_package(make_constant_string("KEYWORD"), Cnil, Cnil); - cl_core.system_package = make_package(make_simple_string("SI"), - CONS(make_simple_string("SYSTEM"), - CONS(make_simple_string("SYS"), - CONS(make_simple_string("EXT"), + cl_core.system_package = make_package(make_constant_string("SI"), + CONS(make_constant_string("SYSTEM"), + CONS(make_constant_string("SYS"), + CONS(make_constant_string("EXT"), Cnil))), CONS(cl_core.lisp_package, Cnil)); #ifdef CLOS - cl_core.clos_package = make_package(make_simple_string("CLOS"), + cl_core.clos_package = make_package(make_constant_string("CLOS"), Cnil, CONS(cl_core.lisp_package, Cnil)); #endif #ifdef TK - cl_core.tk_package = make_package(make_simple_string("TK"), + cl_core.tk_package = make_package(make_constant_string("TK"), Cnil, CONS(cl_core.lisp_package, Cnil)); #endif #ifdef ECL_THREADS - cl_core.mp_package = make_package(make_simple_string("MP"), - CONS(make_simple_string("MULTIPROCESSING"), Cnil), + cl_core.mp_package = make_package(make_constant_string("MP"), + CONS(make_constant_string("MULTIPROCESSING"), Cnil), CONS(cl_core.lisp_package, Cnil)); #endif @@ -200,27 +203,27 @@ cl_boot(int argc, char **argv) * 2) Initialize constants (strings, numbers and time). */ - cl_core.string_return = make_simple_string("Return"); - cl_core.string_space = make_simple_string("Space"); - cl_core.string_rubout = make_simple_string("Rubout"); - cl_core.string_page = make_simple_string("Page"); - cl_core.string_tab = make_simple_string("Tab"); - cl_core.string_backspace = make_simple_string("Backspace"); - cl_core.string_linefeed = make_simple_string("Linefeed"); - cl_core.string_null = make_simple_string("Null"); - cl_core.string_newline = make_simple_string("Newline"); + cl_core.string_return = make_constant_string("Return"); + cl_core.string_space = make_constant_string("Space"); + cl_core.string_rubout = make_constant_string("Rubout"); + cl_core.string_page = make_constant_string("Page"); + cl_core.string_tab = make_constant_string("Tab"); + cl_core.string_backspace = make_constant_string("Backspace"); + cl_core.string_linefeed = make_constant_string("Linefeed"); + cl_core.string_null = make_constant_string("Null"); + cl_core.string_newline = make_constant_string("Newline"); cl_core.null_string = make_constant_string(""); cl_core.null_stream = @make_broadcast_stream(0); cl_core.system_properties = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */ - make_shortfloat(1.5), /* rehash-size */ - make_shortfloat(0.7), /* rehash-threshold */ + make_shortfloat(1.5f), /* rehash-size */ + make_shortfloat(0.75f), /* rehash-threshold */ Ct); /* thread-safe */ - cl_core.gensym_prefix = make_simple_string("G"); - cl_core.gentemp_prefix = make_simple_string("T"); + cl_core.gensym_prefix = make_constant_string("G"); + cl_core.gentemp_prefix = make_constant_string("T"); cl_core.gentemp_counter = MAKE_FIXNUM(0); init_number(); @@ -234,8 +237,8 @@ cl_boot(int argc, char **argv) ecl_init_env(&cl_env); #ifdef ECL_THREADS cl_env.bindings_hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), - make_shortfloat(1.5), - make_shortfloat(0.7), + make_shortfloat(1.5f), + make_shortfloat(0.75f), Cnil); /* no locking */ ECL_SET(@'mp::*current-process*', cl_env.own_process); #endif @@ -257,9 +260,9 @@ cl_boot(int argc, char **argv) make_pathname(Cnil, Cnil, Cnil, Cnil, Cnil, Cnil)); #endif - @si::pathname-translations(2,make_simple_string("SYS"), - cl_list(1,cl_list(2,make_simple_string("*.*"), - make_simple_string("./*.*")))); + @si::pathname-translations(2,make_constant_string("SYS"), + cl_list(1,cl_list(2,make_constant_string("*.*"), + make_constant_string("./*.*")))); /* * 5) Set up hooks for LOAD, errors and macros. @@ -270,12 +273,12 @@ cl_boot(int argc, char **argv) #endif aux = cl_list( #ifdef ENABLE_DLOPEN - 4,CONS(make_simple_string("fas"), @'si::load-binary'), + 4,CONS(make_constant_string("fas"), @'si::load-binary'), #else 3, #endif - CONS(make_simple_string("lsp"), @'si::load-source'), - CONS(make_simple_string("lisp"), @'si::load-source'), + CONS(make_constant_string("lsp"), @'si::load-source'), + CONS(make_constant_string("lisp"), @'si::load-source'), CONS(Cnil, @'si::load-source')); ECL_SET(@'si::*load-hooks*', aux); #ifdef PDE @@ -290,8 +293,8 @@ cl_boot(int argc, char **argv) #ifdef CLOS ECL_SET(@'si::*class-name-hash-table*', cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */ - make_shortfloat(1.5), /* rehash-size */ - make_shortfloat(0.7), /* rehash-threshold */ + make_shortfloat(1.5f), /* rehash-size */ + make_shortfloat(0.75f), /* rehash-threshold */ Ct)); /* thread safe */ #endif @@ -431,7 +434,7 @@ si_setenv(cl_object var, cl_object value) ret_val = setenv(var->string.self, value->string.self, 1); #else cl_object temp = - cl_format(4, Cnil, make_simple_string("~A=~A"), var, + cl_format(4, Cnil, make_constant_string("~A=~A"), var, value); putenv(temp->string.self); #endif diff --git a/src/c/num_arith.d b/src/c/num_arith.d index 2f0c7300a..1a2547e46 100644 --- a/src/c/num_arith.d +++ b/src/c/num_arith.d @@ -33,12 +33,7 @@ fixnum_times(cl_fixnum i, cl_fixnum j) cl_object x = big_register0_get(); mpz_set_si(x->big.big_num, i); - if (j > 0) - mpz_mul_ui(x->big.big_num, x->big.big_num, j); - else { - mpz_mul_ui(x->big.big_num, x->big.big_num, -j); - mpz_neg(x->big.big_num, x->big.big_num); - } + mpz_mul_si(x->big.big_num, x->big.big_num, (long int)j); return big_register_normalize(x); } @@ -52,9 +47,7 @@ big_times_fix(cl_object b, cl_fixnum i) if (i == -1) return(big_minus(b)); z = big_register0_get(); - mpz_mul_ui(z->big.big_num, b->big.big_num, abs(i)); - if (i < 0) - big_complement(z); + mpz_mul_si(z->big.big_num, b->big.big_num, (long int)i); z = big_register_normalize(z); return(z); } @@ -220,9 +213,9 @@ number_plus(cl_object x, cl_object y) return(y); z = big_register0_get(); if (i > 0) - mpz_add_ui(z->big.big_num, y->big.big_num, i); + mpz_add_ui(z->big.big_num, y->big.big_num, (unsigned long)i); else - mpz_sub_ui(z->big.big_num, y->big.big_num, -i); + mpz_sub_ui(z->big.big_num, y->big.big_num, (unsigned long)(-i)); z = big_register_normalize(z); return(z); case t_ratio: @@ -248,9 +241,9 @@ number_plus(cl_object x, cl_object y) return(x); z = big_register0_get(); if (j > 0) - mpz_add_ui(z->big.big_num, x->big.big_num, j); + mpz_add_ui(z->big.big_num, x->big.big_num, (unsigned long)j); else - mpz_sub_ui(z->big.big_num, x->big.big_num, -j); + mpz_sub_ui(z->big.big_num, x->big.big_num, (unsigned long)(-j)); z = big_register_normalize(z); return(z); case t_bignum: @@ -373,9 +366,9 @@ number_minus(cl_object x, cl_object y) z = big_register0_get(); i = fix(x); if (i > 0) - mpz_sub_ui(z->big.big_num, y->big.big_num, i); + mpz_sub_ui(z->big.big_num, y->big.big_num, (unsigned long)i); else - mpz_add_ui(z->big.big_num, y->big.big_num, -i); + mpz_add_ui(z->big.big_num, y->big.big_num, (unsigned long)(-i)); big_complement(z); z = big_register_normalize(z); return(z); @@ -400,9 +393,9 @@ number_minus(cl_object x, cl_object y) return(x); z = big_register0_get(); if (j > 0) - mpz_sub_ui(z->big.big_num, x->big.big_num, j); + mpz_sub_ui(z->big.big_num, x->big.big_num, (unsigned long)j); else - mpz_add_ui(z->big.big_num, x->big.big_num, -j); + mpz_add_ui(z->big.big_num, x->big.big_num, (unsigned long)(-j)); z = big_register_normalize(z); return(z); case t_bignum: @@ -725,10 +718,10 @@ integer_divide(cl_object x, cl_object y) if (ty == t_bignum) { mpz_tdiv_q(q->big.big_num, x->big.big_num, y->big.big_num); } else if (ty == t_fixnum) { - cl_fixnum j = fix(y); - mpz_tdiv_q_ui(q->big.big_num, x->big.big_num, abs(j)); + long j = fix(y); + mpz_tdiv_q_ui(q->big.big_num, x->big.big_num, (unsigned long)labs(j)); if (j < 0) - mpz_neg(q->big.big_num, q->big.big_num); + mpz_neg(q->big.big_num, q->big.big_num); } else { FEtype_error_integer(y); } diff --git a/src/c/num_comp.d b/src/c/num_comp.d index 9d664e2ba..6eb404fbb 100644 --- a/src/c/num_comp.d +++ b/src/c/num_comp.d @@ -282,7 +282,7 @@ monotonic(int s, int t, int narg, cl_va_list nums) return1(Ct); } -#define MONOTONIC(i, j) (int narg, ...) \ +#define MONOTONIC(i, j) (cl_narg narg, ...) \ { cl_va_list nums; cl_va_start(nums, narg, narg, 0); \ return monotonic(i, j, narg, nums); } diff --git a/src/c/num_log.d b/src/c/num_log.d index e1ce55c43..906c95122 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -267,7 +267,7 @@ static bignum_bit_operator bignum_operations[16] = { static cl_object log_op2(cl_object x, cl_object y, int op); static cl_object -log_op(int narg, int op, cl_va_list ARGS) +log_op(cl_narg narg, int op, cl_va_list ARGS) { #if 1 cl_object x, y; @@ -462,7 +462,7 @@ ecl_ash(cl_object x, cl_fixnum w) mpz_set_si(y->big.big_num, fix(x)); x = y; } - mpz_mul_2exp(y->big.big_num, x->big.big_num, w); + mpz_mul_2exp(y->big.big_num, x->big.big_num, (unsigned long)w); } return(big_register_normalize(y)); } @@ -570,7 +570,7 @@ cl_logbitp(cl_object p, cl_object x) assert_type_integer(x); if (FIXNUMP(p)) { - cl_fixnum n = fixnnint(p); + cl_index n = fixnnint(p); if (FIXNUMP(x)) { cl_fixnum y = fix(x); if (n >= FIXNUM_BITS) { diff --git a/src/c/num_sfun.d b/src/c/num_sfun.d index 4e5fbcd58..366c79fb8 100644 --- a/src/c/num_sfun.d +++ b/src/c/num_sfun.d @@ -36,8 +36,6 @@ # endif #endif -cl_object imag_unit, minus_imag_unit, imag_two; - cl_fixnum fixnum_expt(cl_fixnum x, cl_fixnum y) { diff --git a/src/c/number.d b/src/c/number.d index 80196aa84..418003c19 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -37,8 +37,9 @@ fixint(cl_object x) if (FIXNUMP(x)) return fix(x); if (type_of(x) == t_bignum) { - if (x->big.big_size == 1 || x->big.big_size == -1) - return big_to_long(x); + if (mpz_fits_slong_p(x->big.big_num)) { + return mpz_get_si(x->big.big_num); + } } FEwrong_type_argument(@'fixnum', x); } @@ -51,11 +52,12 @@ fixnnint(cl_object x) if (i >= 0) return i; } else if (type_of(x) == t_bignum) { - if (x->big.big_size == 1) - return big_to_ulong(x); + if (mpz_fits_ulong_p(x->big.big_num)) { + return mpz_get_ui(x->big.big_num); + } } cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("Not a non-negative fixnum ~S"), + make_constant_string("Not a non-negative fixnum ~S"), @':format-arguments', cl_list(1,x), @':expected-type', @'fixnum', @':datum', x); } diff --git a/src/c/package.d b/src/c/package.d index 8108a1bbe..e42f4cd1d 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -36,27 +36,27 @@ #define INHERITED 3 static void -FEpackage_error(char *message, cl_object package, int narg, ...) +FEpackage_error(const char *message, cl_object package, int narg, ...) { cl_va_list args; cl_va_start(args, narg, narg, 0); cl_error(7, @'si::simple-package-error', - @':format-control', make_simple_string(message), + @':format-control', make_constant_string(message), @':format-arguments', narg? cl_grab_rest_args(args) : cl_list(1,package), @':package', package); } static void -CEpackage_error(char *message, cl_object package, int narg, ...) +CEpackage_error(const char *message, cl_object package, int narg, ...) { cl_va_list args; cl_va_start(args, narg, narg, 0); cl_cerror(8, - make_simple_string("Ignore error message"), + make_constant_string("Ignore error message"), @'si::simple-package-error', - @':format-control', make_simple_string(message), + @':format-control', make_constant_string(message), @':format-arguments', narg? cl_grab_rest_args(args) : cl_list(1,package), @':package', package); @@ -89,8 +89,8 @@ make_package_hashtable() h->hash.lockable = 0; h->hash.test = htt_pack; h->hash.size = hsize; - h->hash.rehash_size = make_shortfloat(1.5); - h->hash.threshold = make_shortfloat(0.7); + h->hash.rehash_size = make_shortfloat(1.5f); + h->hash.threshold = make_shortfloat(0.75f); h->hash.factor = 0.7; h->hash.entries = 0; h->hash.data = NULL; /* for GC sake */ @@ -129,10 +129,10 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) if ((other = ecl_find_package_nolock(name)) != Cnil) { ERROR: PACKAGE_OP_UNLOCK(); cl_cerror(8, - make_simple_string("Return existing package"), + make_constant_string("Return existing package"), @'si::simple-package-error', @':format-control', - make_simple_string("A package with the name ~A already exists."), + make_constant_string("A package with the name ~A already exists."), @':format-arguments', cl_list(1,name), @':package', other); return other; diff --git a/src/c/pathname.d b/src/c/pathname.d index 282d3b782..2e45ca156 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -185,7 +185,7 @@ static int is_null(int c) { return c == '\0'; } static int is_all_upper(cl_object s) { - int i; + cl_index i; const char *text; for (i = 0, text = s->string.self; i <= s->string.dim; i++) { if (!isupper(text[i])) @@ -197,7 +197,7 @@ is_all_upper(cl_object s) static int is_all_lower(cl_object s) { - int i; + cl_index i; const char *text; for (i = 0, text = s->string.self; i <= s->string.dim; i++) { if (!islower(text[i])) @@ -609,7 +609,7 @@ cl_logical_pathname(cl_object x) x = cl_pathname(x); if (!x->pathname.logical) { cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("~S cannot be coerced to a logical pathname."), + make_constant_string("~S cannot be coerced to a logical pathname."), @':format-arguments', cl_list(1, x), @':expected-type', @'logical-pathname', @':datum', x); diff --git a/src/c/print.d b/src/c/print.d index c6582d3e9..176f8fa02 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -214,7 +214,7 @@ write_ch(int c) } static void -write_str(char *s) +write_str(const char *s) { while (*s != '\0') write_ch(*s++); @@ -280,9 +280,7 @@ write_base(void) If this is too small, then the rounded off fraction, may be too big to read */ -#ifndef FPRC -#define FPRC 16 -#endif +#define FPRC 17 void edit_double(int n, double d, int *sp, char *s, int *ep) @@ -492,15 +490,15 @@ call_structure_print_function(cl_object x, int level) } static void -write_fixnum(cl_fixnum i) +write_positive_fixnum(cl_index i) { /* The maximum number of digits is achieved for base 2 and it is always < FIXNUM_BITS, since we use at least one bit for tagging */ short digits[FIXNUM_BITS]; - int j; - for (j = 0; j < FIXNUM_BITS && i != 0; i /= cl_env.print_base) - digits[j++] = digit_weight(i%cl_env.print_base, cl_env.print_base); + int j, base = cl_env.print_base; + for (j = 0; i != 0; i /= base) + digits[j++] = ecl_digit_char(i % base, base); while (j-- > 0) write_ch(digits[j]); } @@ -513,7 +511,7 @@ write_bignum(cl_object x) char *s = str; mpz_get_str(str, cl_env.print_base, x->big.big_num); while (*s) - write_ch(*s++); + write_ch(*s++); } static void @@ -682,9 +680,10 @@ _write_object(cl_object x, int level) write_ch('0'); } else if (FIXNUM_MINUSP(x)) { write_ch('-'); - write_fixnum(-fix(x)); - } else - write_fixnum(fix(x)); + write_positive_fixnum(-fix(x)); + } else { + write_positive_fixnum(fix(x)); + } if (cl_env.print_radix && cl_env.print_base == 10) write_ch('.'); return; diff --git a/src/c/profile.d b/src/c/profile.d index 136f9d64c..8a12c8560 100644 --- a/src/c/profile.d +++ b/src/c/profile.d @@ -36,10 +36,10 @@ static unsigned int profile_scale; *---------------------------------------------------------------------- */ -extern int siLmake_vector (int narg, object etype, object dim, object adj, object fillp, object displ, object disploff, object staticp); +extern int siLmake_vector (cl_narg narg, object etype, object dim, object adj, object fillp, object displ, object disploff, object staticp); extern void profil (short unsigned int *, size_t, int, unsigned int); -siLprofile(int narg, object scale, object start_address) +siLprofile(cl_narg narg, object scale, object start_address) { int size; object ar = sSAprofile_arrayA->symbol.dbind; @@ -72,7 +72,7 @@ siLprofile(int narg, object scale, object start_address) RETURN(1); } -siLclear_profile(int narg) +siLclear_profile(cl_narg narg) { int i; object ar = sSAprofile_arrayA->symbol.dbind; @@ -92,7 +92,7 @@ total_ticks(unsigned short *aar, unsigned int dim) return count; } -siLdisplay_profile(int narg) +siLdisplay_profile(cl_narg narg) { caddr_t prev, next; unsigned upto, dim; diff --git a/src/c/read.d b/src/c/read.d index f73ee85f1..6ad2c1343 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -15,6 +15,7 @@ */ #include +#include #include #include #include @@ -397,17 +398,16 @@ EXPONENT: exponent = 10 * exponent + d; i++; } while (i < end && (d = digitp(s[i], radix)) >= 0); - d = exponent; + d = exponent * sign; f = 10.0; - /* Use pow because it is more accurate */ - { - double po = pow(10.0, (double)(sign * d)); - if (po == 0.0) { - fraction *= pow(10.0, (double)(sign * (d-1))); - fraction /= 10.0; - } else - fraction *= po; + if (d < (DBL_MIN_10_EXP - 1)) { + fraction /= pow(10.0, (DBL_MIN_10_EXP - 1) - d); + d = DBL_MIN_10_EXP - 1; + } else if (d > (DBL_MAX_10_EXP - 1)) { + fraction *= pow(10.0, d - (DBL_MAX_10_EXP - 1)); + d = DBL_MAX_10_EXP - 1; } + fraction *= pow(10.0, d); MAKE_FLOAT: /* make_{short|long}float signals an error when an overflow diff --git a/src/c/reference.d b/src/c/reference.d index c36208617..75746e032 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -94,23 +94,18 @@ ecl_fdefinition(cl_object fun) return output; } -cl_object -ecl_coerce_to_function(cl_object fun) -{ - cl_type t = type_of(fun); - if (t == t_cfun || t == t_cclosure -#ifdef CLOS - || (t == t_instance && fun->instance.isgf) -#endif - ) - @(return fun) - @(return ecl_fdefinition(fun)) -} - cl_object si_coerce_to_function(cl_object fun) { - @(return ecl_coerce_to_function(fun)) + cl_type t = type_of(fun); + if (!(t == t_cfun || t == t_cclosure +#ifdef CLOS + || (t == t_instance && fun->instance.isgf) +#endif + )) { + fun = ecl_fdefinition(fun); + } + @(return fun) } cl_object diff --git a/src/c/sequence.d b/src/c/sequence.d index 8dc8cf861..bfacb2251 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -18,12 +18,6 @@ #include "ecl.h" #include "ecl-inl.h" -#undef endp - -#define endp(obje) (endp_temp = (obje), CONSP(endp_temp) ? \ - FALSE : endp_temp == Cnil ? TRUE : \ - (FEwrong_type_argument(@'list', endp_temp), FALSE)) - /* I know the following name is not good. */ @@ -68,7 +62,6 @@ elt(cl_object seq, cl_fixnum index) { cl_fixnum i; cl_object l; - cl_object endp_temp; if (index < 0) goto E; @@ -115,7 +108,6 @@ elt_set(cl_object seq, cl_fixnum index, cl_object val) { cl_fixnum i; cl_object l; - cl_object endp_temp; if (index < 0) goto E; @@ -310,7 +302,6 @@ cl_reverse(cl_object seq) { cl_object x, y; cl_fixnum i, j, k; - cl_object endp_temp; switch (type_of(seq)) { case t_symbol: @@ -386,7 +377,6 @@ cl_nreverse(cl_object seq) { cl_object x, y, z; cl_fixnum i, j, k; - cl_object endp_temp; switch (type_of(seq)) { case t_symbol: diff --git a/src/c/string.d b/src/c/string.d index 3cea16bdb..4619611a9 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -130,19 +130,19 @@ cl_string(cl_object x) switch (type_of(x)) { case t_symbol: - return1(x->symbol.name); - + x = x->symbol.name; + break; case t_character: y = cl_alloc_simple_string(1); y->string.self[0] = CHAR_CODE(x); - return1(y); - + x = y; + break; case t_string: - return1(x); - + break; default: FEtype_error_string(x); } + @(return x) } cl_object @@ -234,7 +234,7 @@ string_eq(cl_object x, cl_object y) @(defun string_equal (string1 string2 &key (start1 MAKE_FIXNUM(0)) end1 (start2 MAKE_FIXNUM(0)) end2) cl_index s1, e1, s2, e2; - cl_index i1, i2; + char i1, i2; @ string1 = cl_string(string1); string2 = cl_string(string2); @@ -274,8 +274,8 @@ string_equal(cl_object x, cl_object y) return(TRUE); } -static cl_return -string_cmp(int narg, int sign, int boundary, cl_va_list ARGS) +static cl_object +string_cmp(cl_narg narg, int sign, int boundary, cl_va_list ARGS) { cl_object string1 = cl_va_arg(ARGS); cl_object string2 = cl_va_arg(ARGS); @@ -335,31 +335,31 @@ string_cmp(int narg, int sign, int boundary, cl_va_list ARGS) @(defun string< (&rest args) @ - @(return string_cmp(narg, 1, 1, args)) + return string_cmp(narg, 1, 1, args); @) @(defun string> (&rest args) @ - @(return string_cmp(narg,-1, 1, args)) + return string_cmp(narg,-1, 1, args); @) @(defun string<= (&rest args) @ - @(return string_cmp(narg, 1, 0, args)) + return string_cmp(narg, 1, 0, args); @) @(defun string>= (&rest args) @ - @(return string_cmp(narg,-1, 0, args)) + return string_cmp(narg,-1, 0, args); @) @(defun string/= (&rest args) @ - @(return string_cmp(narg, 0, 1, args)) + return string_cmp(narg, 0, 1, args); @) -static cl_return -string_compare(int narg, int sign, int boundary, cl_va_list ARGS) +static cl_object +string_compare(cl_narg narg, int sign, int boundary, cl_va_list ARGS) { cl_object string1 = cl_va_arg(ARGS); cl_object string2 = cl_va_arg(ARGS); @@ -422,27 +422,27 @@ string_compare(int narg, int sign, int boundary, cl_va_list ARGS) @(defun string-lessp (&rest args) @ - @(return string_compare(narg, 1, 1, args)) + return string_compare(narg, 1, 1, args); @) @(defun string-greaterp (&rest args) @ - @(return string_compare(narg,-1, 1, args)) + return string_compare(narg,-1, 1, args); @) @(defun string-not-greaterp (&rest args) @ - @(return string_compare(narg, 1, 0, args)) + return string_compare(narg, 1, 0, args); @) @(defun string-not-lessp (&rest args) @ - @(return string_compare(narg,-1, 0, args)) + return string_compare(narg,-1, 0, args); @) @(defun string-not-equal (&rest args) @ - @(return string_compare(narg, 0, 1, args)) + return string_compare(narg, 0, 1, args); @) bool @@ -482,7 +482,7 @@ member_char(int c, cl_object char_bag) } } -static cl_return +static cl_object string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strng) { cl_object res; @@ -502,22 +502,30 @@ string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strn k = j - i + 1; res = cl_alloc_simple_string(k); memcpy(res->string.self, strng->string.self+i, k); - return1(res); + @(return res) } -cl_return +cl_object cl_string_trim(cl_object char_bag, cl_object strng) - { return string_trim0(TRUE, TRUE, char_bag, strng); } -cl_return +{ + return string_trim0(TRUE, TRUE, char_bag, strng); +} + +cl_object cl_string_left_trim(cl_object char_bag, cl_object strng) - { return string_trim0(TRUE, FALSE, char_bag, strng); } -cl_return +{ + return string_trim0(TRUE, FALSE, char_bag, strng); +} + +cl_object cl_string_right_trim(cl_object char_bag, cl_object strng) - { return string_trim0(FALSE, TRUE, char_bag, strng);} +{ + return string_trim0(FALSE, TRUE, char_bag, strng); +} -static cl_return -string_case(int narg, int (*casefun)(int c, bool *bp), cl_va_list ARGS) +static cl_object +string_case(cl_narg narg, int (*casefun)(int c, bool *bp), cl_va_list ARGS) { cl_object strng = cl_va_arg(ARGS); cl_index s, e, i; @@ -541,7 +549,7 @@ string_case(int narg, int (*casefun)(int c, bool *bp), cl_va_list ARGS) b = TRUE; for (i = s; i < e; i++) conv->string.self[i] = (*casefun)(conv->string.self[i], &b); - return1(conv); + @(return conv) #undef startp #undef start #undef end @@ -555,18 +563,18 @@ char_upcase(int c, bool *bp) @(defun string-upcase (&rest args) @ - @(return string_case(narg, char_upcase, args)) + return string_case(narg, char_upcase, args); @) static int char_downcase(int c, bool *bp) { - return(tolower(c)); + return tolower(c); } @(defun string-downcase (&rest args) @ - @(return string_case(narg, char_downcase, args)) + return string_case(narg, char_downcase, args); @) static int @@ -588,12 +596,12 @@ char_capitalize(int c, bool *bp) @(defun string-capitalize (&rest args) @ - @(return string_case(narg, char_capitalize, args)) + return string_case(narg, char_capitalize, args); @) -static cl_return -nstring_case(int narg, int (*casefun)(int, bool *), cl_va_list ARGS) +static cl_object +nstring_case(cl_narg narg, int (*casefun)(int, bool *), cl_va_list ARGS) { cl_object strng = cl_va_arg(ARGS); cl_index s, e, i; @@ -615,7 +623,7 @@ nstring_case(int narg, int (*casefun)(int, bool *), cl_va_list ARGS) b = TRUE; for (i = s; i < e; i++) strng->string.self[i] = (*casefun)(strng->string.self[i], &b); - return1(strng); + @(return strng) #undef startp #undef start #undef end @@ -623,17 +631,17 @@ nstring_case(int narg, int (*casefun)(int, bool *), cl_va_list ARGS) @(defun nstring-upcase (&rest args) @ - @(return nstring_case(narg, char_upcase, args)) + return nstring_case(narg, char_upcase, args); @) @(defun nstring-downcase (&rest args) @ - @(return nstring_case(narg, char_downcase, args)) + return nstring_case(narg, char_downcase, args); @) @(defun nstring-capitalize (&rest args) @ - @(return nstring_case(narg, char_capitalize, args)) + return nstring_case(narg, char_capitalize, args); @) @(defun si::string_concatenate (&rest args) diff --git a/src/c/symbol.d b/src/c/symbol.d index d01acdad1..60ecfeb9a 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -95,7 +95,7 @@ static void FEtype_error_plist(cl_object x) { cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("Not a valid property list ~D"), + make_constant_string("Not a valid property list ~D"), @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 88b3ce9da..d42a4d1b2 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -7,9 +7,6 @@ struct { const char *name, *translation; } #else -#ifndef ECL_CMU_FORMAT -extern cl_object si_formatter_aux _ARGS((int narg, cl_object strm, cl_object string, ...)); -#endif #define EXT_ #define SYS_ #define MP_ @@ -18,8 +15,8 @@ cl_symbol_initializer #endif cl_symbols[] = { -{"NIL", CL_ORDINARY, NULL, -1}, -{"T", CL_ORDINARY, NULL, -1}, +{"NIL", CL_ORDINARY, NULL, -1, OBJNULL}, +{"T", CL_ORDINARY, NULL, -1, OBJNULL}, #ifdef CLOS {SYS_ "UNBOUND", SI_ORDINARY, si_unbound, 0, OBJNULL}, #else @@ -1288,6 +1285,7 @@ cl_symbols[] = { {KEY_ "INITIAL-ELEMENT", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "INPUT", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "INTERNAL", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "INSTANCE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "IO", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "JUNK-ALLOWED", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "KEY", KEYWORD, NULL, -1, OBJNULL}, diff --git a/src/c/tclBasic.d b/src/c/tclBasic.d index fa8bc97b8..be4862446 100644 --- a/src/c/tclBasic.d +++ b/src/c/tclBasic.d @@ -431,7 +431,7 @@ TkResult2Lisp(Tcl_Interp *interp) } #endif -tclMethodDispatch(int narg, cl_object env, ...) +tclMethodDispatch(cl_narg narg, cl_object env, ...) { va_list args; cl_object W = CAR(env); diff --git a/src/c/threads.d b/src/c/threads.d index c96be7907..a60f72173 100644 --- a/src/c/threads.d +++ b/src/c/threads.d @@ -120,7 +120,7 @@ thread_entry_point(cl_object process) @) cl_object -mp_process_preset(int narg, cl_object process, cl_object function, ...) +mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...) { cl_va_list args; cl_va_start(args, function, narg, 2); @@ -210,7 +210,7 @@ mp_process_whostate(cl_object process) } cl_object -mp_process_run_function(int narg, cl_object name, cl_object function, ...) +mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) { cl_object process; cl_va_list args; diff --git a/src/c/time.d b/src/c/time.d index bb40fd787..016b4747d 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -15,6 +15,7 @@ */ #include "ecl.h" +#include "internal.h" #include #include #ifdef HAVE_TIMES @@ -37,8 +38,8 @@ static time_t beginning; -int -runtime(void) +cl_fixnum +ecl_runtime(void) /* tms_utime is the CPU time used while executing instructions in the user space of the calling process, measured in 1/HZ seconds. @@ -76,7 +77,7 @@ cl_sleep(cl_object z) /* INV: number_minusp() makes sure `z' is real */ if (number_minusp(z)) cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("Not a non-negative number ~S"), + make_constant_string("Not a non-negative number ~S"), @':format-arguments', cl_list(1, z), @':expected-type', @'real', @':datum', z); #ifdef HAVE_NANOSLEEP @@ -144,26 +145,17 @@ si_get_local_time_zone() * */ @(defun si::daylight-saving-time-p (&optional UT) - struct tm *ltm; - time_t when; + struct tm *ltm; + time_t when; @ - if (narg == 0) - when = time(0); - else { /* narg == 1 */ - cl_object UTC = number_minus(UT, cl_core.Jan1st1970UT); - switch (type_of(UTC)) { - case t_fixnum: - when = fix(UTC); - break; - case t_bignum: - when = big_to_long(UTC); - break; - default: - FEerror("Universal Time out of range: ~A.", 1, UT); - } - } - ltm = localtime(&when); - @(return (ltm->tm_isdst ? Ct : Cnil)) + if (narg == 0) { + when = time(0); + } else { /* narg == 1 */ + cl_object UTC = number_minus(UT, cl_core.Jan1st1970UT); + when = fixint(UTC); + } + ltm = localtime(&when); + @(return (ltm->tm_isdst ? Ct : Cnil)) @) void diff --git a/src/c/typespec.d b/src/c/typespec.d index 2224479b5..48b4055f6 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -55,7 +55,7 @@ FEtype_error_list(cl_object x) { void FEtype_error_proper_list(cl_object x) { cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("Not a proper list ~D"), + make_constant_string("Not a proper list ~D"), @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); @@ -65,7 +65,7 @@ void FEtype_error_alist(cl_object x) { cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("Not a valid association list ~D"), + make_constant_string("Not a valid association list ~D"), @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); @@ -77,7 +77,7 @@ FEcircular_list(cl_object x) /* FIXME: Is this the right way to rebind it? */ bds_bind(@'*print-circle*', Ct); cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("Circular list ~D"), + make_constant_string("Circular list ~D"), @':format-arguments', cl_list(1, x), @':expected-type', @'list', @':datum', x); @@ -87,7 +87,7 @@ void FEtype_error_index(cl_object seq, cl_object ndx) { cl_error(9, @'simple-type-error', @':format-control', - make_simple_string("~S is not a valid index within the sequence ~S"), + make_constant_string("~S is not a valid index into the object ~S"), @':format-arguments', cl_list(2, seq, ndx), @':expected-type', @'fixnum', @':datum', ndx); diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index aa7565928..acee8b095 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -114,7 +114,7 @@ si_follow_symlink(cl_object filename) { * have been resolved. */ cl_object output, kind; - int size = 128, written; + cl_index size = 128, written; output = si_coerce_to_filename(filename); kind = file_kind(output->string.self, FALSE); @@ -294,7 +294,7 @@ cl_file_author(cl_object file) struct stat filestatus; if (stat(filename->string.self, &filestatus) < 0) FElibc_error("Cannot get the file status of ~S.", 1, file); - @(return make_simple_string("UNKNOWN")) + @(return make_constant_string("UNKNOWN")) #endif } @@ -333,9 +333,8 @@ homedir_pathname(cl_object user) cl_object namestring; if (Null(user)) { - extern char *getenv(); char *h = getenv("HOME"); - namestring = (h == NULL)? make_simple_string("/") + namestring = (h == NULL)? make_constant_string("/") : make_string_copy(h); } else { #ifdef HAVE_PWD_H @@ -364,7 +363,7 @@ homedir_pathname(cl_object user) i = namestring->string.fillp; if (namestring->string.self[i-1] != '/') namestring = si_string_concatenate(2, namestring, - make_simple_string("/")); + make_constant_string("/")); return cl_parse_namestring(3, namestring, Cnil, Cnil); } diff --git a/src/c/unixint.d b/src/c/unixint.d index fe9fdbdfd..41745dc56 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -15,6 +15,7 @@ */ #include "ecl.h" +#include "internal.h" #include #include #ifdef ECL_THREADS @@ -23,7 +24,9 @@ /******************************* ------- ******************************/ -void +bool ecl_interrupt_enable; + +static void handle_signal(int sig) { switch (sig) { @@ -49,7 +52,8 @@ handle_signal(int sig) static void signal_catcher(int sig) { - if (symbol_value(@'si::*interrupt-enable*') == Cnil) { + if (!ecl_interrupt_enable || + symbol_value(@'si::*interrupt-enable*') == Cnil) { signal(sig, signal_catcher); cl_env.interrupt_pending = sig; return; @@ -131,4 +135,5 @@ init_unixint(void) signal(SIGUSR1, signal_catcher); #endif ECL_SET(@'si::*interrupt-enable*', Ct); + ecl_interrupt_enable = 1; } diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 2c7a53efa..34831dd92 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -158,8 +158,8 @@ (when *linking-calls* (dotimes (i (length *linking-calls*)) (declare (fixnum i)) - (wt-h "static cl_object LKF" i "(int, ...);") - (wt-h "static cl_object (*LK" i ")(int, ...)=LKF" i ";")) + (wt-h "static cl_object LKF" i "(cl_narg, ...);") + (wt-h "static cl_object (*LK" i ")(cl_narg, ...)=LKF" i ";")) ) ;;; Global entries for directly called functions. (dolist (x *global-entries*) @@ -169,7 +169,7 @@ (dolist (x *linking-calls*) (let ((i (second x))) (wt-nl1 "static cl_object LKF" i - "(int narg, ...) {TRAMPOLINK(narg," (third x) ",&LK" i ",Cblock);}"))) + "(cl_narg narg, ...) {TRAMPOLINK(narg," (third x) ",&LK" i ",Cblock);}"))) (wt-h "#ifdef __cplusplus") (wt-h "}") @@ -406,11 +406,11 @@ (wt-comment "function definition for " fname) (if (numberp cfun) (progn - (wt-nl1 "static cl_object L" cfun "(int narg") - (wt-h "static cl_object L" cfun "(int narg")) + (wt-nl1 "static cl_object L" cfun "(cl_narg narg") + (wt-h "static cl_object L" cfun "(cl_narg narg")) (progn - (wt-nl1 "cl_object " cfun "(int narg") - (wt-h "cl_object " cfun "(int narg"))) + (wt-nl1 "cl_object " cfun "(cl_narg narg") + (wt-h "cl_object " cfun "(cl_narg narg"))) (do ((vl requireds (cdr vl)) (lcl (1+ *lcl*) (1+ lcl))) ((endp vl)) @@ -466,8 +466,8 @@ (when (and (symbolp fname) (get-sysprop fname 'NO-GLOBAL-ENTRY)) (return-from wt-global-entry nil)) (wt-comment "global entry for the function " fname) - (wt-nl1 "static cl_object L" cfun "(int narg") - (wt-h "static cl_object L" cfun "(int") + (wt-nl1 "static cl_object L" cfun "(cl_narg narg") + (wt-h "static cl_object L" cfun "(cl_narg") (do ((vl arg-types (cdr vl)) (lcl (1+ *lcl*) (1+ lcl))) ((endp vl) (wt1 ")")) @@ -711,8 +711,8 @@ (or (fun-name fun) (fun-description fun) 'CLOSURE)) (wt-h "static cl_object LC" (fun-cfun fun) "(") (wt-nl1 "static cl_object LC" (fun-cfun fun) "(") - (wt-h1 "int") - (wt "int narg") + (wt-h1 "cl_narg") + (wt "cl_narg narg") (dotimes (n level) (wt-h1 ",cl_object *") (wt ",cl_object *lex" n)) @@ -812,7 +812,7 @@ (defun t3defCbody (fname cfun arg-types type body) (when *compile-print* (print-emitting fname)) (wt-comment "function definition for " fname) - (wt-nl1 "static cl_object L" cfun "(int narg") + (wt-nl1 "static cl_object L" cfun "(cl_narg narg") (do ((vl arg-types (cdr vl)) (lcl 1 (1+ lcl))) ((endp vl)) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 410d8f13b..88ed0ad26 100644 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -41,7 +41,7 @@ "~A -o ~A -L@true_builddir@~* ~{~A ~} ~@?") #-dlopen (setf c::*ld-flags* - "@LDFLAGS@ @LDRPATH@ @LIBPREFIX@ecl.@LIBEXT@ -lgmp -lgc @CLIBS@") + "@LDFLAGS@ @LDRPATH@ @LIBPREFIX@ecl.@LIBEXT@ -lgmp @GCLIB@ @CLIBS@") #+dlopen (setf c::*ld-flags* "@LDFLAGS@ @LDRPATH@ @SHAREDPREFIX@ecl.@SHAREDEXT@ @CLIBS@" @@ -84,8 +84,7 @@ cd ..; rm -rf tmp/*'"))) (c::shared-cc (compile-file-pathname "ecl" :type :dll) "c/main.@OBJEXT@" (compile-file-pathname "ecl" :type :lib) - #+boehm-gc "-lgc" - "-lgmp" + "-lgmp @GCLIB@" . #.(unless (equalp "@LDINSTALLNAME@" "") '("@LDINSTALLNAME@")))) diff --git a/src/configure.in b/src/configure.in index 02cfa7fc3..5ef66560f 100644 --- a/src/configure.in +++ b/src/configure.in @@ -183,6 +183,7 @@ SUBDIR=c CLIBS="${CLIBS} -lm" if test ${boehm} = "no" ; then EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}" + GCLIB="" else if test ${local_boehm} = "no"; then SUBDIR="${SUBDIR} gc" @@ -191,6 +192,7 @@ else BOEHM_HEADERS="" fi EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" + GCLIB="-lgc" AC_DEFINE(GBC_BOEHM) fi if test ${shared} = "yes"; then diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index c52e5f117..2a676af5c 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -5,14 +5,14 @@ #define loop_for_in(list) { \ cl_object __slow; \ bool __flag = TRUE; \ - for (__slow = list; !ENDP(list); list = CDR(list)) { \ + for (__slow = list; !endp(list); list = CDR(list)) { \ if ((__flag = !__flag)) { \ if (__slow == list) FEcircular_list(list); \ __slow = CDR(__slow); \ } #else #define loop_for_in(list) { \ - for (; !ENDP(list); list = CDR(list)) { + for (; !endp(list); list = CDR(list)) { #endif #define end_loop_for_in }} diff --git a/src/h/external.h b/src/h/external.h index 9538cebf6..2e831ca64 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -3,7 +3,7 @@ extern "C" { #endif #ifndef _ARGS -#define _ARGS(x) (int n, ...) +#define _ARGS(x) (cl_narg n, ...) #endif /* @@ -191,7 +191,7 @@ extern cl_object make_cons(cl_object a, cl_object d); extern void cl_dealloc(void *p, cl_index s); #ifdef GBC_BOEHM extern cl_object si_gc(cl_object area); -extern cl_object si_gc_dump(); +extern cl_object si_gc_dump(void); extern void *GC_malloc(size_t size); extern void *GC_malloc_atomic_ignore_off_page(size_t size); extern void GC_free(void *); @@ -202,17 +202,16 @@ extern void GC_free(void *); #define cl_dealloc(p,s) #define ecl_register_static_root(x) ecl_register_root(x) #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, ...)); +extern cl_object si_allocate _ARGS((cl_narg narg, cl_object type, cl_object qty, ...)); +extern cl_object si_maximum_allocatable_pages _ARGS((cl_narg narg, cl_object type)); +extern cl_object si_allocated_pages _ARGS((cl_narg narg, cl_object type)); +extern cl_object si_alloc_contpage _ARGS((cl_narg narg, cl_object qty, ...)); +extern cl_object si_allocated_contiguous_pages _ARGS((cl_narg narg)); +extern cl_object si_maximum_contiguous_pages _ARGS((cl_narg narg)); +extern cl_object si_allocate_contiguous_pages _ARGS((cl_narg narg, cl_object qty, ...)); +extern cl_object si_get_hole_size _ARGS((cl_narg narg)); +extern cl_object si_set_hole_size _ARGS((cl_narg narg, cl_object size)); +extern cl_object si_ignore_maximum_pages _ARGS((cl_narg narg, ...)); extern void *cl_alloc(cl_index n); extern void *cl_alloc_align(cl_index size, cl_index align); #define cl_alloc_atomic(x) cl_alloc(x) @@ -222,7 +221,7 @@ extern void *cl_alloc_align(cl_index size, cl_index align); /* all_symbols */ -extern cl_object si_mangle_name _ARGS((int narg, cl_object symbol, ...)); +extern cl_object si_mangle_name _ARGS((cl_narg narg, cl_object symbol, ...)); typedef union { struct { @@ -239,9 +238,9 @@ extern cl_index cl_num_symbols_in_core; /* 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); +extern cl_object APPLY_fixed(cl_narg n, cl_object (*f)(), cl_object *x); +extern cl_object APPLY(cl_narg n, cl_objectfn, cl_object *x); +extern cl_object APPLY_closure(cl_narg n, cl_objectfn, cl_object cl, cl_object *x); /* array.c */ @@ -261,9 +260,9 @@ 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_object cl_aref _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object si_aset _ARGS((cl_narg narg, cl_object v, cl_object x, ...)); +extern cl_object si_make_pure_array _ARGS((cl_narg 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); @@ -281,7 +280,7 @@ extern cl_elttype get_elttype(cl_object x); extern cl_object cl_set(cl_object var, cl_object val); extern cl_object cl_makunbound(cl_object sym); extern cl_object cl_fmakunbound(cl_object sym); -extern cl_object si_fset _ARGS((int narg, cl_object fun, cl_object def, ...)); +extern cl_object si_fset _ARGS((cl_narg narg, cl_object fun, cl_object def, ...)); extern cl_object si_get_sysprop(cl_object sym, cl_object prop); extern cl_object si_put_sysprop(cl_object sym, cl_object prop, cl_object value); extern cl_object si_rem_sysprop(cl_object sym, cl_object prop); @@ -304,7 +303,6 @@ extern cl_object big_minus(cl_object x); extern cl_object big_plus(cl_object x, cl_object y); extern cl_object big_normalize(cl_object x); extern double big_to_double(cl_object x); -extern long big_to_long(cl_object x); /* cfun.c */ @@ -314,29 +312,29 @@ extern cl_object si_compiled_function_block(cl_object fun); extern cl_object cl_function_lambda_expression(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 cl_object cl_make_cfun_va(cl_object (*self)(cl_narg narg,...), cl_object name, cl_object block); +extern cl_object cl_make_cclosure_va(cl_object (*self)(cl_narg 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(cl_object sym, cl_object (*self)(cl_object, cl_object)); -extern void cl_def_c_function_va(cl_object sym, cl_object (*self)(int narg,...)); +extern void cl_def_c_function_va(cl_object sym, cl_object (*self)(cl_narg narg,...)); /* 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_digit_char_p _ARGS((cl_narg narg, cl_object c, ...)); +extern cl_object cl_charE _ARGS((cl_narg narg, cl_object c, ...)); +extern cl_object cl_charNE _ARGS((cl_narg narg, ...)); +extern cl_object cl_charL _ARGS((cl_narg narg, ...)); +extern cl_object cl_charG _ARGS((cl_narg narg, ...)); +extern cl_object cl_charLE _ARGS((cl_narg narg, ...)); +extern cl_object cl_charGE _ARGS((cl_narg narg, ...)); +extern cl_object cl_char_equal _ARGS((cl_narg narg, cl_object c, ...)); +extern cl_object cl_char_not_equal _ARGS((cl_narg narg, ...)); +extern cl_object cl_char_lessp _ARGS((cl_narg narg, ...)); +extern cl_object cl_char_greaterp _ARGS((cl_narg narg, ...)); +extern cl_object cl_char_not_greaterp _ARGS((cl_narg narg, ...)); +extern cl_object cl_char_not_lessp _ARGS((cl_narg narg, ...)); +extern cl_object cl_digit_char _ARGS((cl_narg narg, cl_object w, ...)); extern cl_object cl_alpha_char_p(cl_object c); extern cl_object cl_alphanumericp(cl_object c); @@ -360,17 +358,13 @@ extern bool char_eq(cl_object x, cl_object y); extern int char_cmp(cl_object x, cl_object y); extern bool char_equal(cl_object x, cl_object y); extern int char_compare(cl_object x, cl_object y); -extern short digit_weight(int w, int r); +extern short ecl_digit_char(cl_fixnum w, cl_fixnum r); /* clos.c */ #ifdef CLOS -extern cl_object cl_find_class _ARGS((int narg, cl_object name, ...)); +extern cl_object cl_find_class _ARGS((cl_narg narg, cl_object name, ...)); extern cl_object cl_class_of(cl_object x); - -extern cl_object class_class; -extern cl_object class_object; -extern cl_object class_built_in; #endif /* cmpaux.c */ @@ -399,14 +393,14 @@ extern cl_object si_process_lambda(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_valid_function_name_p(cl_object name); -extern cl_object si_process_declarations _ARGS((int narg, cl_object body, ...)); +extern cl_object si_process_declarations _ARGS((cl_narg narg, cl_object body, ...)); extern cl_object make_lambda(cl_object name, cl_object lambda); -extern cl_object si_eval_with_env _ARGS((int narg, cl_object form, ...)); +extern cl_object si_eval_with_env _ARGS((cl_narg narg, cl_object form, ...)); /* interpreter.c */ -extern cl_object si_interpreter_stack _ARGS((int narg)); +extern cl_object si_interpreter_stack _ARGS((cl_narg narg)); extern void cl_stack_push(cl_object o); extern cl_object cl_stack_pop(void); @@ -418,10 +412,10 @@ extern void cl_stack_insert(cl_index where, cl_index n); extern cl_index cl_stack_push_list(cl_object list); extern cl_index cl_stack_push_va_list(cl_va_list args); extern void cl_stack_push_n(cl_index n, cl_object *args); -extern int cl_stack_push_values(void); -extern void cl_stack_pop_values(int n); +extern cl_index cl_stack_push_values(void); +extern void cl_stack_pop_values(cl_index n); -extern cl_object lambda_apply(int narg, cl_object fun); +extern cl_object lambda_apply(cl_narg narg, cl_object fun); extern void *interpret(cl_object bytecodes, void *pc); /* disassembler.c */ @@ -431,8 +425,8 @@ extern cl_object si_bc_split(cl_object v); /* error.c */ -extern cl_object cl_error _ARGS((int narg, cl_object eformat, ...)) __attribute__((noreturn)); -extern cl_object cl_cerror _ARGS((int narg, cl_object cformat, cl_object eformat, ...)); +extern cl_object cl_error _ARGS((cl_narg narg, cl_object eformat, ...)) __attribute__((noreturn)); +extern cl_object cl_cerror _ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...)); extern void internal_error(const char *s) __attribute__((noreturn)); extern void cs_overflow(void) __attribute__((noreturn)); @@ -441,7 +435,7 @@ extern void FEprogram_error(const char *s, int narg, ...) __attribute__((noretur extern void FEcontrol_error(const char *s, int narg, ...) __attribute__((noreturn)); extern void FEreader_error(const char *s, cl_object stream, int narg, ...) __attribute__((noreturn)); #define FEparse_error FEreader_error -extern void FEerror(char *s, int narg, ...) __attribute__((noreturn)); +extern void FEerror(const char *s, int narg, ...) __attribute__((noreturn)); extern void FEcannot_open(cl_object fn) __attribute__((noreturn)); extern void FEend_of_file(cl_object strm) __attribute__((noreturn)); extern void FEclosed_stream(cl_object strm) __attribute__ ((noreturn)); @@ -450,21 +444,21 @@ extern void FEwrong_num_arguments(cl_object fun) __attribute__((noreturn)); extern void FEwrong_num_arguments_anonym(void) __attribute__((noreturn)); extern void FEunbound_variable(cl_object sym) __attribute__((noreturn)); extern void FEinvalid_macro_call(cl_object obj) __attribute__((noreturn)); -extern void FEinvalid_variable(char *s, cl_object obj) __attribute__((noreturn)); +extern void FEinvalid_variable(const char *s, cl_object obj) __attribute__((noreturn)); extern void FEassignment_to_constant(cl_object v) __attribute__((noreturn)); extern void FEundefined_function(cl_object fname) __attribute__((noreturn)); extern void FEinvalid_function(cl_object obj) __attribute__((noreturn)); extern void FEinvalid_function_name(cl_object obj) __attribute__((noreturn)); -extern cl_object CEerror(char *err_str, int narg, ...); +extern cl_object CEerror(const char *err_str, int narg, ...); extern void illegal_index(cl_object x, cl_object i); extern void FEtype_error_symbol(cl_object obj) __attribute__((noreturn)); extern void FElibc_error(const char *msg, int narg, ...) __attribute__((noreturn)); /* eval.c */ -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, ...)); +extern cl_object cl_funcall _ARGS((cl_narg narg, cl_object fun, ...)); +extern cl_object cl_apply _ARGS((cl_narg narg, cl_object fun, cl_object arg, ...)); +extern cl_object si_safe_eval _ARGS((cl_narg narg, 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); @@ -472,7 +466,7 @@ 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 cl_constantp(int narg, cl_object arg, ...); +extern cl_object cl_constantp(cl_narg narg, cl_object arg, ...); #define funcall cl_funcall extern cl_object cl_apply_from_stack(cl_index narg, cl_object fun); @@ -498,7 +492,7 @@ extern cl_object cl_two_way_stream_output_stream(cl_object strm); extern cl_object cl_make_echo_stream(cl_object strm1, cl_object strm2); extern cl_object cl_echo_stream_input_stream(cl_object strm); extern cl_object cl_echo_stream_output_stream(cl_object strm); -extern cl_object cl_make_string_output_stream(); +extern cl_object cl_make_string_output_stream(void); 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); @@ -511,14 +505,14 @@ 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_broadcast_stream _ARGS((cl_narg narg, ...)); extern cl_object cl_broadcast_stream_streams(cl_object strm); -extern cl_object cl_make_concatenated_stream _ARGS((int narg, ...)); +extern cl_object cl_make_concatenated_stream _ARGS((cl_narg narg, ...)); extern cl_object cl_concatenated_stream_streams(cl_object strm); -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 cl_object cl_make_string_input_stream _ARGS((cl_narg narg, cl_object strng, ...)); +extern cl_object cl_close _ARGS((cl_narg narg, cl_object strm, ...)); +extern cl_object cl_open _ARGS((cl_narg narg, cl_object filename, ...)); +extern cl_object cl_file_position _ARGS((cl_narg narg, cl_object file_stream, ...)); extern cl_object cl_file_string_length(cl_object string); extern cl_object si_do_write_sequence(cl_object string, cl_object stream, cl_object start, cl_object end); extern cl_object si_do_read_sequence(cl_object string, cl_object stream, cl_object start, cl_object end); @@ -553,14 +547,14 @@ extern int file_column(cl_object strm); /* format.c */ -extern cl_object cl_format _ARGS((int narg, cl_object stream, cl_object string, ...)); +extern cl_object cl_format _ARGS((cl_narg narg, cl_object stream, cl_object string, ...)); /* gbc.c */ #if !defined(GBC_BOEHM) -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)); +extern cl_object si_room_report _ARGS((cl_narg narg)); +extern cl_object si_reset_gc_count _ARGS((cl_narg narg)); +extern cl_object si_gc_time _ARGS((cl_narg narg)); extern cl_object si_gc(cl_object area); #define GC_enabled() GC_enable #define GC_enable() GC_enable = TRUE; @@ -588,7 +582,7 @@ extern cl_object si_set_funcallable(cl_object instance, cl_object flag); extern cl_object si_generic_function_p(cl_object instance); 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 cl_object compute_method(cl_narg narg, cl_object fun, cl_object *args); #endif /* CLOS */ @@ -607,8 +601,8 @@ extern cl_object cl_hash_table_rehash_threshold(cl_object ht); extern cl_object cl_hash_table_size(cl_object ht); extern cl_object cl_hash_table_test(cl_object ht); extern cl_object si_hash_table_iterator(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_object cl_make_hash_table _ARGS((cl_narg narg, ...)); +extern cl_object cl_gethash _ARGS((cl_narg narg, cl_object key, cl_object ht, ...)); extern cl_object si_copy_hash_table(cl_object orig); extern cl_hashkey hash_eq(cl_object x); @@ -630,15 +624,15 @@ 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_unbound(void); extern cl_object si_sl_boundp(cl_object x); extern cl_object si_sl_makunbound(cl_object x, cl_object index); extern cl_object si_instance_sig(cl_object x); extern cl_object si_instance_sig_set(cl_object x); -extern cl_object ecl_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); +extern cl_object ecl_allocate_instance(cl_object clas, cl_index size); +extern cl_object instance_ref(cl_object x, cl_fixnum i); +extern cl_object instance_set(cl_object x, cl_fixnum i, cl_object v); extern cl_object si_copy_instance(cl_object x); #endif /* CLOS */ @@ -702,25 +696,25 @@ extern cl_object si_memq(cl_object x, cl_object l); extern cl_object cl_nreconc(cl_object x, cl_object y); extern cl_object cl_cons(cl_object x, cl_object y); extern cl_object cl_acons(cl_object x, cl_object y, cl_object z); -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_tree_equal _ARGS((int narg, cl_object x, cl_object y, ...)); -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_nconc _ARGS((int narg, ...)); -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_subst _ARGS((int narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); -extern cl_object cl_nsubst _ARGS((int narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); -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 cl_list _ARGS((cl_narg narg, ...)); +extern cl_object cl_listX _ARGS((cl_narg narg, ...)); +extern cl_object cl_append _ARGS((cl_narg narg, ...)); +extern cl_object cl_tree_equal _ARGS((cl_narg narg, cl_object x, cl_object y, ...)); +extern cl_object cl_last _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_make_list _ARGS((cl_narg narg, cl_object size, ...)); +extern cl_object cl_nconc _ARGS((cl_narg narg, ...)); +extern cl_object cl_butlast _ARGS((cl_narg narg, cl_object lis, ...)); +extern cl_object cl_nbutlast _ARGS((cl_narg narg, cl_object lis, ...)); +extern cl_object cl_subst _ARGS((cl_narg narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); +extern cl_object cl_nsubst _ARGS((cl_narg narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...)); +extern cl_object cl_sublis _ARGS((cl_narg narg, cl_object alist, cl_object tree, ...)); +extern cl_object cl_nsublis _ARGS((cl_narg narg, cl_object alist, cl_object tree, ...)); +extern cl_object cl_member _ARGS((cl_narg narg, cl_object item, cl_object list, ...)); extern cl_object si_member1 (cl_object item, cl_object list, cl_object test, cl_object test_not, cl_object key); -extern cl_object cl_adjoin _ARGS((int narg, cl_object item, cl_object list, ...)); -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_adjoin _ARGS((cl_narg narg, cl_object item, cl_object list, ...)); +extern cl_object cl_pairlis _ARGS((cl_narg narg, cl_object keys, cl_object data, ...)); +extern cl_object cl_rassoc _ARGS((cl_narg narg, cl_object item, cl_object alist, ...)); +extern cl_object cl_assoc _ARGS((cl_narg narg, cl_object item, cl_object alist, ...)); extern cl_object list_length(cl_object x); extern cl_object append(cl_object x, cl_object y); @@ -728,10 +722,6 @@ 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); extern cl_object nconc(cl_object x, cl_object y); -extern cl_object subst(cl_object new_object, cl_object tree); -extern void nsubst(cl_object new_object, cl_object *treep); -extern cl_object sublis(cl_object alist, cl_object tree); -extern void nsublis(cl_object alist, cl_object *treep); extern bool member_eq(cl_object x, cl_object l); extern cl_object memql(cl_object x, cl_object l); extern cl_object member(cl_object x, cl_object l); @@ -747,13 +737,13 @@ extern void ecl_delete_eq(cl_object x, cl_object *l); 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 cl_object cl_load _ARGS((cl_narg narg, cl_object pathname, ...)); /* 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 cl_macroexpand _ARGS((cl_narg narg, cl_object form, ...)); +extern cl_object cl_macroexpand_1 _ARGS((cl_narg 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); @@ -762,12 +752,12 @@ extern cl_object macro_expand(cl_object form, cl_object env); /* main.c */ -extern cl_object si_argc(); +extern cl_object si_argc(void); 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 si_quit _ARGS((int narg, ...)) __attribute__((noreturn)); +extern cl_object si_quit _ARGS((cl_narg narg, ...)) __attribute__((noreturn)); extern bool ecl_booted; extern const char *ecl_self; @@ -776,18 +766,18 @@ extern int cl_boot(int argc, char **argv); /* 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 cl_object cl_mapcar _ARGS((cl_narg narg, cl_object fun, ...)); +extern cl_object cl_maplist _ARGS((cl_narg narg, cl_object fun, ...)); +extern cl_object cl_mapc _ARGS((cl_narg narg, cl_object fun, ...)); +extern cl_object cl_mapl _ARGS((cl_narg narg, cl_object fun, ...)); +extern cl_object cl_mapcan _ARGS((cl_narg narg, cl_object fun, ...)); +extern cl_object cl_mapcon _ARGS((cl_narg narg, cl_object fun, ...)); /* multival.c */ extern cl_object cl_values_list(cl_object list); -extern cl_object cl_values _ARGS((int narg, ...)); +extern cl_object cl_values _ARGS((cl_narg narg, ...)); /* num_arith.c */ @@ -795,12 +785,12 @@ extern cl_object cl_values _ARGS((int narg, ...)); 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, ...)); +extern cl_object cl_X _ARGS((cl_narg narg, ...)); +extern cl_object cl_P _ARGS((cl_narg narg, ...)); +extern cl_object cl_M _ARGS((cl_narg narg, cl_object num, ...)); +extern cl_object cl_N _ARGS((cl_narg narg, cl_object num, ...)); +extern cl_object cl_gcd _ARGS((cl_narg narg, ...)); +extern cl_object cl_lcm _ARGS((cl_narg narg, ...)); extern cl_object fixnum_times(cl_fixnum i, cl_fixnum j); extern cl_object number_times(cl_object x, cl_object y); @@ -841,13 +831,13 @@ 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 cl_float _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_floor _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_ceiling _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_truncate _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_round _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_float_sign _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_complex _ARGS((cl_narg narg, cl_object r, ...)); extern cl_object double_to_integer(double d); extern cl_object float_to_integer(float d); @@ -863,14 +853,14 @@ extern cl_object round2(cl_object x, cl_object y); /* 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 cl_object cl_E _ARGS((cl_narg narg, cl_object num, ...)); +extern cl_object cl_NE _ARGS((cl_narg narg, ...)); +extern cl_object cl_L _ARGS((cl_narg narg, ...)); +extern cl_object cl_G _ARGS((cl_narg narg, ...)); +extern cl_object cl_GE _ARGS((cl_narg narg, ...)); +extern cl_object cl_LE _ARGS((cl_narg narg, ...)); +extern cl_object cl_max _ARGS((cl_narg narg, cl_object max, ...)); +extern cl_object cl_min _ARGS((cl_narg narg, cl_object min, ...)); extern int number_equalp(cl_object x, cl_object y); extern int number_compare(cl_object x, cl_object y); @@ -891,10 +881,10 @@ 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 cl_logior _ARGS((cl_narg narg, ...)); +extern cl_object cl_logxor _ARGS((cl_narg narg, ...)); +extern cl_object cl_logand _ARGS((cl_narg narg, ...)); +extern cl_object cl_logeqv _ARGS((cl_narg narg, ...)); extern cl_object ecl_ash(cl_object x, cl_fixnum w); @@ -917,8 +907,8 @@ extern int number_evenp(cl_object x); /* 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 cl_random _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_make_random_state _ARGS((cl_narg narg, ...)); extern cl_object make_random_state(cl_object rs); @@ -938,8 +928,8 @@ 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 cl_object cl_atan _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_log _ARGS((cl_narg narg, cl_object x, ...)); /* package.c */ @@ -951,22 +941,22 @@ 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 cl_list_all_packages(void); extern cl_object si_package_hash_tables(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 cl_object cl_make_package _ARGS((cl_narg narg, cl_object pack_name, ...)); +extern cl_object cl_intern _ARGS((cl_narg narg, cl_object strng, ...)); +extern cl_object cl_find_symbol _ARGS((cl_narg narg, cl_object strng, ...)); +extern cl_object cl_unintern _ARGS((cl_narg narg, cl_object symbl, ...)); +extern cl_object cl_export _ARGS((cl_narg narg, cl_object symbols, ...)); +extern cl_object cl_unexport _ARGS((cl_narg narg, cl_object symbols, ...)); +extern cl_object cl_import _ARGS((cl_narg narg, cl_object symbols, ...)); +extern cl_object cl_rename_package _ARGS((cl_narg narg, cl_object pack, cl_object new_name, ...)); +extern cl_object cl_shadowing_import _ARGS((cl_narg narg, cl_object symbols, ...)); +extern cl_object cl_shadow _ARGS((cl_narg narg, cl_object symbols, ...)); +extern cl_object cl_use_package _ARGS((cl_narg narg, cl_object pack, ...)); +extern cl_object cl_unuse_package _ARGS((cl_narg narg, cl_object pack, ...)); 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); @@ -991,11 +981,11 @@ extern void unuse_package(cl_object x0, cl_object p); extern cl_object cl_pathname(cl_object name); extern cl_object cl_logical_pathname(cl_object pname); extern cl_object cl_pathnamep(cl_object pname); -extern cl_object cl_pathname_host _ARGS((int narg, cl_object pname, ...)); -extern cl_object cl_pathname_device _ARGS((int narg, cl_object pname, ...)); -extern cl_object cl_pathname_directory _ARGS((int narg, cl_object pname, ...)); -extern cl_object cl_pathname_name _ARGS((int narg, cl_object pname, ...)); -extern cl_object cl_pathname_type _ARGS((int narg, cl_object pname, ...)); +extern cl_object cl_pathname_host _ARGS((cl_narg narg, cl_object pname, ...)); +extern cl_object cl_pathname_device _ARGS((cl_narg narg, cl_object pname, ...)); +extern cl_object cl_pathname_directory _ARGS((cl_narg narg, cl_object pname, ...)); +extern cl_object cl_pathname_name _ARGS((cl_narg narg, cl_object pname, ...)); +extern cl_object cl_pathname_type _ARGS((cl_narg narg, 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); @@ -1003,16 +993,16 @@ 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 _ARGS((int narg, cl_object source, cl_object from, cl_object to, ...)); -extern cl_object cl_translate_logical_pathname _ARGS((int narg, 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 cl_translate_pathname _ARGS((cl_narg narg, cl_object source, cl_object from, cl_object to, ...)); +extern cl_object cl_translate_logical_pathname _ARGS((cl_narg narg, cl_object source, ...)); +extern cl_object cl_parse_namestring _ARGS((cl_narg narg, cl_object thing, ...)); +extern cl_object cl_parse_logical_namestring _ARGS((cl_narg narg, cl_object thing, ...)); +extern cl_object cl_merge_pathnames _ARGS((cl_narg narg, cl_object path, ...)); +extern cl_object cl_make_pathname _ARGS((cl_narg narg, ...)); +extern cl_object cl_enough_namestring _ARGS((cl_narg narg, cl_object path, ...)); +extern cl_object si_pathname_translations _ARGS((cl_narg narg, cl_object host, ...)); extern cl_object si_default_pathname_defaults(void); -extern cl_object cl_wild_pathname_p _ARGS((int narg, cl_object pathname, ...)); +extern cl_object cl_wild_pathname_p _ARGS((cl_narg narg, cl_object pathname, ...)); 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); @@ -1064,20 +1054,20 @@ extern bool equalp(cl_object x, cl_object y); /* print.c */ extern cl_object cl_write_byte(cl_object integer, cl_object binary_output_stream); -extern cl_object cl_write_sequence _ARGS((int narg, cl_object seq, cl_object stream, ...)); -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, ...)); +extern cl_object cl_write_sequence _ARGS((cl_narg narg, cl_object seq, cl_object stream, ...)); +extern cl_object cl_write _ARGS((cl_narg narg, cl_object x, ...)); +extern cl_object cl_prin1 _ARGS((cl_narg narg, cl_object obj, ...)); +extern cl_object cl_print _ARGS((cl_narg narg, cl_object obj, ...)); +extern cl_object cl_pprint _ARGS((cl_narg narg, cl_object obj, ...)); +extern cl_object cl_princ _ARGS((cl_narg narg, cl_object obj, ...)); +extern cl_object cl_write_char _ARGS((cl_narg narg, cl_object c, ...)); +extern cl_object cl_write_string _ARGS((cl_narg narg, cl_object strng, ...)); +extern cl_object cl_write_line _ARGS((cl_narg narg, cl_object strng, ...)); +extern cl_object cl_terpri _ARGS((cl_narg narg, ...)); +extern cl_object cl_fresh_line _ARGS((cl_narg narg, ...)); +extern cl_object cl_force_output _ARGS((cl_narg narg, ...)); #define cl_finish_output cl_force_output -extern cl_object cl_clear_output _ARGS((int narg, ...)); +extern cl_object cl_clear_output _ARGS((cl_narg narg, ...)); extern cl_object princ(cl_object obj, cl_object strm); extern cl_object prin1(cl_object obj, cl_object strm); @@ -1090,9 +1080,9 @@ extern void princ_char(int c, cl_object sym); /* 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 cl_object si_profile _ARGS((cl_narg narg, cl_object scale, cl_object start_address)); +extern cl_object si_clear_profile _ARGS((cl_narg narg)); +extern cl_object si_display_profile _ARGS((cl_narg narg)); extern int total_ticks(unsigned short *aar, unsigned int dim); extern int init_profile(void); #endif @@ -1100,31 +1090,30 @@ extern int init_profile(void); /* read.c */ -extern cl_object cl_read_sequence _ARGS((int narg, cl_object seq, cl_object stream, ...)); +extern cl_object cl_read_sequence _ARGS((cl_narg narg, cl_object seq, cl_object stream, ...)); 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 si_standard_readtable(void); +extern cl_object cl_read _ARGS((cl_narg narg, ...)); +extern cl_object cl_read_preserving_whitespace _ARGS((cl_narg narg, ...)); +extern cl_object cl_read_delimited_list _ARGS((cl_narg narg, cl_object d, ...)); +extern cl_object cl_read_line _ARGS((cl_narg narg, ...)); +extern cl_object cl_read_char _ARGS((cl_narg narg, ...)); +extern cl_object cl_unread_char _ARGS((cl_narg narg, cl_object c, ...)); +extern cl_object cl_peek_char _ARGS((cl_narg narg, ...)); +extern cl_object cl_listen _ARGS((cl_narg narg, ...)); +extern cl_object cl_read_char_no_hang _ARGS((cl_narg narg, ...)); +extern cl_object cl_clear_input _ARGS((cl_narg narg, ...)); +extern cl_object cl_parse_integer _ARGS((cl_narg narg, cl_object strng, ...)); +extern cl_object cl_read_byte _ARGS((cl_narg narg, cl_object binary_input_stream, ...)); +extern cl_object cl_copy_readtable _ARGS((cl_narg narg, ...)); +extern cl_object cl_set_syntax_from_char _ARGS((cl_narg narg, cl_object tochr, cl_object fromchr, ...)); +extern cl_object cl_set_macro_character _ARGS((cl_narg narg, cl_object chr, cl_object fnc, ...)); +extern cl_object cl_get_macro_character _ARGS((cl_narg narg, cl_object chr, ...)); +extern cl_object cl_make_dispatch_macro_character _ARGS((cl_narg narg, cl_object chr, ...)); +extern cl_object cl_set_dispatch_macro_character _ARGS((cl_narg narg, cl_object dspchr, cl_object subchr, cl_object fnc, ...)); +extern cl_object cl_get_dispatch_macro_character _ARGS((cl_narg narg, cl_object dspchr, cl_object subchr, ...)); -extern cl_object standard_readtable; extern cl_object read_char(cl_object in); extern void unread_char(cl_object c, cl_object in); extern cl_object read_object_non_recursive(cl_object in); @@ -1148,7 +1137,7 @@ 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 cl_macro_function _ARGS((cl_narg narg, cl_object sym, ...)); extern cl_object ecl_fdefinition(cl_object fname); @@ -1160,7 +1149,7 @@ 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_subseq _ARGS((cl_narg narg, cl_object sequence, cl_object start, ...)); extern cl_object cl_alloc_simple_vector(cl_index l, cl_elttype aet); extern cl_object cl_alloc_simple_bitvector(cl_index l); @@ -1176,16 +1165,16 @@ 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_top(void); 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_top(void); 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 cl_object si_reset_stack_limits(void); extern void bds_overflow(void) __attribute__((noreturn)); extern void bds_unwind(bds_ptr new_bds_top); @@ -1203,26 +1192,26 @@ 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_make_string _ARGS((cl_narg narg, cl_object size, ...)); +extern cl_object cl_stringE _ARGS((cl_narg narg, cl_object string1, cl_object string2, ...)); +extern cl_object cl_string_equal _ARGS((cl_narg narg, cl_object string1, cl_object string2, ...)); +extern cl_object cl_stringL _ARGS((cl_narg narg, ...)); +extern cl_object cl_stringG _ARGS((cl_narg narg, ...)); +extern cl_object cl_stringLE _ARGS((cl_narg narg, ...)); +extern cl_object cl_stringGE _ARGS((cl_narg narg, ...)); +extern cl_object cl_stringNE _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_lessp _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_greaterp _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_not_greaterp _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_not_lessp _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_not_equal _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_upcase _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_downcase _ARGS((cl_narg narg, ...)); +extern cl_object cl_string_capitalize _ARGS((cl_narg narg, ...)); +extern cl_object cl_nstring_upcase _ARGS((cl_narg narg, ...)); +extern cl_object cl_nstring_downcase _ARGS((cl_narg narg, ...)); +extern cl_object cl_nstring_capitalize _ARGS((cl_narg narg, ...)); +extern cl_object si_string_concatenate _ARGS((cl_narg narg, ...)); extern cl_object cl_alloc_simple_string(cl_index l); extern cl_object cl_alloc_adjustable_string(cl_index l); @@ -1248,7 +1237,7 @@ extern cl_object si_structure_set(cl_object x, cl_object type, cl_object index, 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 cl_object si_make_structure _ARGS((cl_narg narg, cl_object type, ...)); #ifndef CLOS extern cl_object structure_to_list(cl_object x); @@ -1272,12 +1261,12 @@ 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, ...)); +extern cl_object cl_get _ARGS((cl_narg narg, cl_object sym, cl_object indicator, ...)); +extern cl_object cl_getf _ARGS((cl_narg narg, cl_object place, cl_object indicator, ...)); +extern cl_object cl_copy_symbol _ARGS((cl_narg narg, cl_object sym, ...)); +extern cl_object cl_gensym _ARGS((cl_narg narg, ...)); +extern cl_object cl_gentemp _ARGS((cl_narg narg, ...)); +extern cl_object si_put_properties _ARGS((cl_narg narg, cl_object sym, ...)); extern void cl_defvar(cl_object s, cl_object v); extern void cl_defparameter(cl_object s, cl_object v); @@ -1302,7 +1291,7 @@ extern char *Tcl_GetVar2(Tcl_Interp *interp, char *name1, char *name2, int flags extern char *Tcl_SetVar(Tcl_Interp *interp, char *var, char *val, int flags); extern char *Tcl_SetVar2(Tcl_Interp *interp, char *name1, char *name2, char *val, int flags); extern int Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName); -extern int tclMethodDispatch(int narg, cl_object env, ...); +extern int tclMethodDispatch(cl_narg narg, cl_object env, ...); extern void Tcl_CreateCommand(Tcl_Interp *interp, char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); extern int Tcl_GetCommandInfo(Tcl_Interp *interp, char *cmdName, Tcl_CmdInfo *infoPtr); extern Tcl_Interp *Tcl_CreateInterp(void); @@ -1342,29 +1331,29 @@ extern cl_object mp_own_process(void) __attribute__((const)); extern cl_object mp_all_processes(void); extern cl_object mp_exit_process(void) __attribute__((noreturn)); extern cl_object mp_interrupt_process(cl_object process, cl_object function); -extern cl_object mp_make_process _ARGS((int narg, ...)); +extern cl_object mp_make_process _ARGS((cl_narg narg, ...)); extern cl_object mp_process_active_p(cl_object process); extern cl_object mp_process_enable(cl_object process); extern cl_object mp_process_interrupt(cl_object process, cl_object function); extern cl_object mp_process_kill(cl_object process); extern cl_object mp_process_name(cl_object process); -extern cl_object mp_process_preset _ARGS((int narg, cl_object process, cl_object function, ...)); -extern cl_object mp_process_run_function _ARGS((int narg, cl_object name, cl_object function, ...)); +extern cl_object mp_process_preset _ARGS((cl_narg narg, cl_object process, cl_object function, ...)); +extern cl_object mp_process_run_function _ARGS((cl_narg narg, cl_object name, cl_object function, ...)); extern cl_object mp_process_whostate(cl_object process); -extern cl_object mp_make_lock _ARGS((int narg, ...)); -extern cl_object mp_get_lock _ARGS((int narg, cl_object lock, ...)); +extern cl_object mp_make_lock _ARGS((cl_narg narg, ...)); +extern cl_object mp_get_lock _ARGS((cl_narg narg, cl_object lock, ...)); extern cl_object mp_giveup_lock(cl_object lock); #endif /* time.c */ -extern cl_object cl_get_universal_time(); +extern cl_object cl_get_universal_time(void); 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 cl_object cl_get_internal_run_time(void); +extern cl_object cl_get_internal_real_time(void); +extern cl_object si_get_local_time_zone(void); +extern cl_object si_daylight_saving_time_p _ARGS((cl_narg narg, ...)); extern cl_object UTC_time_to_universal_time(cl_fixnum i); @@ -1422,10 +1411,10 @@ extern cl_object cl_file_write_date(cl_object file); extern cl_object cl_file_author(cl_object file); extern cl_object si_file_kind(cl_object pathname, cl_object follow_links); extern cl_object si_getcwd(void); -extern cl_object si_chdir _ARGS((int narg, cl_object directory, ...)); +extern cl_object si_chdir _ARGS((cl_narg narg, cl_object directory, ...)); extern cl_object si_mkdir(cl_object directory, cl_object mode); -extern cl_object cl_directory _ARGS((int narg, cl_object directory, ...)); -extern cl_object cl_user_homedir_pathname _ARGS((int narg, ...)); +extern cl_object cl_directory _ARGS((cl_narg narg, cl_object directory, ...)); +extern cl_object cl_user_homedir_pathname _ARGS((cl_narg narg, ...)); extern cl_object si_mkstemp(cl_object template); extern const char *expand_pathname(const char *name); @@ -1437,9 +1426,9 @@ extern cl_object homedir_pathname(cl_object user); /* unixint.c */ -extern cl_object si_catch_bad_signals(); -extern cl_object si_uncatch_bad_signals(); -extern cl_object si_check_pending_interrupts(); +extern cl_object si_catch_bad_signals(void); +extern cl_object si_uncatch_bad_signals(void); +extern cl_object si_check_pending_interrupts(void); /* unixsys.c */ diff --git a/src/h/internal.h b/src/h/internal.h index 3aab9a382..b8aa47a97 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -40,11 +40,9 @@ extern void init_read(void); extern void init_stacks(int *); extern void init_unixint(void); extern void init_unixtime(void); - - -/* all_symbols.d */ - -extern cl_index cl_num_symbols_in_core; +extern void ecl_init_env(struct cl_env_struct *); +extern void init_LSP(void); +extern void init_CLOS(void); /* all_functions.d */ @@ -78,6 +76,12 @@ extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); #define OPEN_A "ab" #define OPEN_RA "a+b" +/* format.d */ + +#ifndef ECL_CMU_FORMAT +extern cl_object si_formatter_aux _ARGS((cl_narg narg, cl_object strm, cl_object string, ...)); +#endif + /* hash.d */ extern void ecl_extend_hashtable(cl_object hashtable); @@ -163,6 +167,14 @@ extern void cl_write_object(cl_object x); /* read.d */ #define RTABSIZE CHAR_CODE_LIMIT /* read table size */ +/* time.d */ + +extern cl_fixnum ecl_runtime(void); + +/* unixint.d */ + +extern bool ecl_interrupt_enable; + #ifdef __cplusplus } #endif diff --git a/src/h/object.h b/src/h/object.h index 31bccb1a0..000a90b9a 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -37,7 +37,8 @@ typedef unsigned char byte; */ typedef union cl_lispunion *cl_object; typedef cl_object cl_return; -typedef cl_object (*cl_objectfn)(int narg, ...); +typedef cl_fixnum cl_narg; +typedef cl_object (*cl_objectfn)(cl_narg narg, ...); /* OBJect NULL value. @@ -536,10 +537,6 @@ typedef enum { */ #define type_of(obje) ((cl_type)(IMMEDIATE(obje) ? IMMEDIATE(obje) : (((cl_object)(obje)) ->d.t))) -#define ENDP(x) (type_of(x) == t_cons ? \ - FALSE : x == Cnil ? TRUE : \ - (FEtype_error_list(x), FALSE)) - /* This is used to retrieve optional arguments */ diff --git a/src/h/stacks.h b/src/h/stacks.h index f8de8cfff..7fbf828a3 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -168,7 +168,7 @@ cl_env.lex_env ------> ( tag0 value0 tag1 value1 ... ) *********************************/ #define CL_NEWENV_BEGIN {\ - int __i = cl_stack_push_values(); \ + cl_index __i = cl_stack_push_values(); \ cl_object __env = cl_env.lex_env; #define CL_NEWENV_END \