From 9b4bd625f446885700c90bb36be6b4558741f720 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 17 Nov 2001 11:02:12 +0000 Subject: [PATCH] +The compiler produced wrong code for RETURN-FROM forms inside an UNWIND-PROTECT. +Deftype BIT-VECTOR would not expand to a vector type. +Each compiled file has an entry point whose name is either init_CODE() or another name based on the name of the source file. The algorithm for computing these names has been slightly changed so that the entry points of ECLS's own library do not conflict with user defined entry points. +A LET/LET* form in which the initializers for a variable have not the expected type produce a warning, but the code is accepted. For instance (LET (V) (DECLARE (TYPE FIXNUM V)) (SETQ V 1)) now compiles. +(SETF name), where name is a symbol, is now a valid function name in all contexts. It is accepted by DEFUN, FUNCTION, FBOUNDP, FMAKUNBOUND, etc, and it can be the on the function position in any form. +New specialized arrays for (UNSIGNED-BYTE 8) and (SIGNED-BYTE 8). --- src/CHANGELOG | 24 ++- src/Makefile.in | 4 +- src/ansi-tests/Makefile.in | 2 +- src/c/Makefile.in | 2 +- src/c/all_functions.d | 6 +- src/c/all_keywords.d | 5 + src/c/all_symbols.d | 10 ++ src/c/alloc_2.d | 2 + src/c/array.d | 61 ++++++- src/c/assignment.d | 57 ++++--- src/c/compiler.d | 257 +++++++++++++++++++++++------ src/c/disassembler.d | 33 ++-- src/c/gbc.d | 6 + src/c/init.d | 4 +- src/c/interpreter.d | 327 ++++++++++++++++++------------------- src/c/lex.d | 65 -------- src/c/load.d | 23 ++- src/c/macros.d | 5 +- src/c/num_log.d | 2 +- src/c/package.d | 2 +- src/c/reference.d | 10 +- src/c/sequence.d | 23 ++- src/c/stacks.d | 32 ++-- src/cmp/cmpblock.lsp | 2 +- src/cmp/cmpcall.lsp | 52 +++--- src/cmp/cmpdefs.lsp | 29 +--- src/cmp/cmpeval.lsp | 6 +- src/cmp/cmplam.lsp | 8 +- src/cmp/cmplet.lsp | 10 +- src/cmp/cmpmain.lsp | 10 +- src/cmp/cmptop.lsp | 8 +- src/cmp/cmptype.lsp | 54 +++++- src/cmp/cmputil.lsp | 24 +-- src/cmp/sysfun.lsp | 6 +- src/compile.lsp.in | 22 +-- src/compile_rest.lsp.in | 32 +--- src/gabriel/test-help.lsp | 5 +- src/h/bytecodes.h | 5 +- src/h/external.h | 11 +- src/h/lisp_external.h | 8 + src/h/object.h | 11 +- src/h/stacks.h | 10 +- src/lsp/defpackage.lsp | 19 ++- src/lsp/defstruct.lsp | 1 + src/lsp/defsys.lsp.in | 1 + src/lsp/evalmacros.lsp | 3 +- src/lsp/ffi.lsp | 58 +++++++ src/lsp/load.lsp.in | 1 + src/lsp/predlib.lsp | 17 +- src/lsp/setf.lsp | 16 +- src/lsp/top.lsp | 31 ++-- src/tests/hashlong.tst | 2 +- src/tests/steele7.tst | 2 +- src/util/emacs.el | 35 +++- src/util/gdbinit | 3 +- src/util/system.lsp | 7 +- 56 files changed, 880 insertions(+), 591 deletions(-) delete mode 100644 src/c/lex.d create mode 100644 src/lsp/ffi.lsp diff --git a/src/CHANGELOG b/src/CHANGELOG index 47c78c459..794c12712 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -816,10 +816,21 @@ ECLS 0.5 - The compiler produced wrong code for CATCH forms in which the tag is not constant. + - The compiler produced wrong code for RETURN-FROM forms inside an + UNWIND-PROTECT. + + - Deftype BIT-VECTOR would not expand to a vector type. + * System design and portability: - Remove function_entry_table. + - Each compiled file has an entry point whose name is either + init_CODE() or another name based on the name of the source file. + The algorithm for computing these names has been slightly changed + so that the entry points of ECLS's own library do not conflict with + user defined entry points. + * Visible changes and ANSI compatibility: - The value of *package* is correctly set and restored while loading @@ -845,7 +856,7 @@ ECLS 0.5 the interpreter and the compiler. - New, undocumented implementation of documentation strings which - uses hash tables instead of property lists. The gloal variable + uses hash tables instead of property lists. The global variable si::*keep-documentation* determines whether documentation strings are stored in memory. It is possible to dump documentation strings to a help file. @@ -858,6 +869,17 @@ ECLS 0.5 - Symbolic's update of the MIT LOOP macro imported. + - A LET/LET* form in which the initializers for a variable have not + the expected type produce a warning, but the code is accepted. For + instance (LET (V) (DECLARE (TYPE FIXNUM V)) (SETQ V 1)) now + compiles. + + - (SETF name), where name is a symbol, is now a valid function name in all + contexts. It is accepted by DEFUN, FUNCTION, FBOUNDP, FMAKUNBOUND, etc, + and it can be the on the function position in any form. + + - New specialized arrays for (UNSIGNED-BYTE 8) and (SIGNED-BYTE 8). + TODO: ===== diff --git a/src/Makefile.in b/src/Makefile.in index bacd8e9b7..1b70d219f 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -47,8 +47,8 @@ all: $(TARGETS) doc %Makefile: $(srcdir)/%Makefile.in config.status ./config.status -eclx$(EXE): ecls$(EXE) compile_rest.lsp - ./ecls < compile_rest.lsp +eclx$(EXE): ecls_min$(EXE) compile_rest.lsp + ./ecls_min < compile_rest.lsp ecls$(EXE): ecls_min$(EXE) compile.lsp ./ecls_min < compile.lsp diff --git a/src/ansi-tests/Makefile.in b/src/ansi-tests/Makefile.in index 26a223569..3c032ee14 100644 --- a/src/ansi-tests/Makefile.in +++ b/src/ansi-tests/Makefile.in @@ -22,7 +22,7 @@ ecls_min: echo '(setf (logical-pathname-translations "SYS")'; \ echo " '"'(("*.*" "../*.*")))'; \ echo '(sys::chdir "ansi-tests")'; \ - echo '(in-package "CL-USER"); \ + echo '(in-package "CL-USER")'; \ echo '(load "$(srcdir)/tests")'; \ echo "(run-all-tests \"$(srcdir)/\")"; \ echo "(quit)") | (cd ..; ./ecls_min) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 337a972e2..9673953aa 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -32,7 +32,7 @@ HFILES = ../h/config.h $(HDIR)/ecls.h $(HDIR)/ecls-cmp.h\ $(HDIR)/lwp.h $(HDIR)/critical.h OBJS = main.o symbol.o package.o list.o\ apply.o eval.o interpreter.o compiler.o disassembler.o \ - clos.o instance.o gfun.o lex.o reference.o character.o\ + clos.o instance.o gfun.o reference.o character.o\ file.o read.o print.o error.o string.o cfun.o\ typespec.o assignment.o \ predicate.o big.o number.o\ diff --git a/src/c/all_functions.d b/src/c/all_functions.d index f3b946fac..3ccdb91c8 100644 --- a/src/c/all_functions.d +++ b/src/c/all_functions.d @@ -243,6 +243,7 @@ const struct function_info all_functions[] = { /* interpreter.c */ {"INTERPRETER-STACK", siLinterpreter_stack, si}, {"MAKE-LAMBDA", siLmake_lambda, si}, + {"FUNCTION-BLOCK-NAME", siLfunction_block_name, si}, /* iteration.c */ @@ -251,10 +252,6 @@ const struct function_info all_functions[] = { {"DOLIST", NULL, form}, {"DOTIMES", NULL, form}, - /* lex.c */ - - {"LEX-ENV", siLlex_env, si}, - /* let.c */ {"LET", NULL, form}, @@ -484,6 +481,7 @@ const struct function_info all_functions[] = { {"LOGANDC2", clLlogandc1, cl}, {"LOGORC1", clLlogorc1, cl}, {"LOGORC2", clLlogorc2, cl}, + {"LOGNOT", clLlognot, cl}, {"BOOLE", clLboole, cl}, {"LOGBITP", clLlogbitp, cl}, {"ASH", clLash, cl}, diff --git a/src/c/all_keywords.d b/src/c/all_keywords.d index ba8f52ad6..f1a4c2c4f 100644 --- a/src/c/all_keywords.d +++ b/src/c/all_keywords.d @@ -53,6 +53,11 @@ const struct keyword_info all_keywords[] = { {&Krehash_size, "REHASH-SIZE"}, {&Krehash_threshold, "REHASH-THRESHOLD"}, +/* lex.c */ +{&Kfunction, "FUNCTION"}, +{&Ktag, "TAG"}, +{&Kblock, "BLOCK"}, + /* list.c */ {&Ktest, "TEST"}, {&Ktest_not, "TEST-NOT"}, diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 45b5cef4f..efe9daf9c 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -2,10 +2,17 @@ #include "page.h" const struct symbol_info all_symbols[] = { +/* array.c */ +{&clSbyte8, "BYTE8", CL_ORDINARY}, +{&clSinteger8, "INTEGER8", CL_ORDINARY}, + /* assignment.c */ {&clSsetf, "SETF", CL_ORDINARY}, {&clSpsetf, "PSETF", CL_ORDINARY}, {&siSsetf_symbol, "SETF-SYMBOL", SI_ORDINARY}, +{&siSsetf_lambda, "SETF-LAMBDA", SI_ORDINARY}, +{&siSsetf_method, "SETF-METHOD", SI_ORDINARY}, +{&siSsetf_update, "SETF-UPDATE", SI_ORDINARY}, {&siSclear_compiler_properties, "CLEAR-COMPILER-PROPERTIES", SI_ORDINARY}, #ifdef PDE {&siVrecord_source_pathname_p, "*RECORD-SOURCE-PATHNAME-P*", SI_SPECIAL}, @@ -127,6 +134,9 @@ const struct symbol_info all_symbols[] = { {&clVload_verbose, "*LOAD-VERBOSE*", CL_SPECIAL}, {&clVload_print, "*LOAD-PRINT*", CL_SPECIAL}, {&siVload_hooks, "*LOAD-HOOKS*", SI_SPECIAL}, +#ifdef ENABLE_DLOPEN +{&siVinit_function_prefix, "*INIT-FUNCTION-PREFIX*", SI_SPECIAL}, +#endif #ifdef PDE {&siVsource_pathname, "*SOURCE-PATHNAME*", CL_SPECIAL}, #endif diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 255dd4fdc..0c01a8ff4 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -164,6 +164,8 @@ init_alloc(void) if (alloc_initialized) return; alloc_initialized = TRUE; + GC_no_dls = 1; + init_tm(t_shortfloat, "SHORT-FLOAT", /* 8 */ sizeof(struct shortfloat_struct)); init_tm(t_cons, "CONS", sizeof(struct cons)); /* 12 */ diff --git a/src/c/array.d b/src/c/array.d index f056510db..ce5e2117a 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -20,6 +20,9 @@ #define CHAR_BIT (sizeof(char)*8) #endif +cl_object @'byte8'; +cl_object @'integer8'; + 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); @@ -118,6 +121,12 @@ aref(cl_object x, cl_index index) case aet_lf: return(make_longfloat(x->array.self.lf[index])); + case aet_b8: + return(MAKE_FIXNUM(x->array.self.b8[index])); + + case aet_i8: + return(MAKE_FIXNUM(x->array.self.i8[index])); + default: internal_error("aref"); } @@ -219,6 +228,19 @@ aset(cl_object x, cl_index index, cl_object value) case aet_lf: x->array.self.lf[index] = object_to_double(value); break; + + case aet_b8: { + cl_index i = fixnnint(value); + if (i > 0xFF) FEerror("~S is not a (INTEGER 0 255)",1,value); + x->array.self.b8[index] = i; + break; + } + case aet_i8: { + cl_fixnum i = fixint(value); + if (i > 127 || i < -128) FEerror("~S is not a (INTEGER -128 127)",1,value); + x->array.self.i8[index] = i; + break; + } } return(value); } @@ -370,7 +392,7 @@ array_allocself(cl_object x) } case aet_fix: { cl_fixnum *elts; - elts = alloc_atomic_align(sizeof(cl_fixnum)*d, sizeof(cl_fixnum)); + elts = alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0; x->array.self.fix = elts; @@ -378,7 +400,7 @@ array_allocself(cl_object x) } case aet_sf: { float *elts; - elts = alloc_atomic_align(sizeof(float)*d, sizeof(float)); + elts = alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0.0; x->array.self.sf = elts; @@ -386,12 +408,28 @@ array_allocself(cl_object x) } case aet_lf: { double *elts; - elts = alloc_atomic_align(sizeof(double)*d, sizeof(double)); + elts = alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0.0; x->array.self.lf = elts; break; } + case aet_b8: { + u_int8_t *elts; + elts = alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + for (i = 0; i < d; i++) + elts[i] = 0; + x->array.self.b8 = elts; + break; + } + case aet_i8: { + int8_t *elts; + elts = alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + for (i = 0; i < d; i++) + elts[i] = 0; + x->array.self.i8 = elts; + break; + } } #ifdef THREADS end_critical_section(); @@ -411,11 +449,11 @@ get_elttype(cl_object x) return(aet_sf); else if (x == @'long-float' || x == @'double-float') return(aet_lf); -/* else if (x == @'signed-char') - return(aet_char); - else if (x == @'unsigned-char') - return(aet_uchar); - else if (x == @'signed-short') + else if (x == @'byte8') + return(aet_b8); + else if (x == @'integer8') + return(aet_i8); +/* else if (x == @'signed-short') return(aet_short); else if (x == @'unsigned-short') return(aet_ushort); @@ -437,7 +475,10 @@ array_address(cl_object x, cl_index inc) return x->string.self + inc; case aet_lf: return x->array.self.lf + inc; - + case aet_b8: + return x->array.self.b8 + inc; + case aet_i8: + return x->array.self.i8 + inc; default: FEerror("Bad array type", 0); } @@ -453,6 +494,8 @@ array_address(cl_object x, cl_index inc) case aet_fix: output = @'fixnum'; break; case aet_sf: output = @'short-float'; break; case aet_lf: output = @'long-float'; break; + case aet_b8: output = @'byte8'; break; + case aet_i8: output = @'integer8'; break; } @(return output) @) diff --git a/src/c/assignment.d b/src/c/assignment.d index bee6a1f18..48d3064b8 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -20,6 +20,9 @@ cl_object @'setf'; cl_object @'psetf'; cl_object @'si::setf-symbol'; +cl_object @'si::setf-lambda'; +cl_object @'si::setf-method'; +cl_object @'si::setf-update'; cl_object @'si::clear-compiler-properties'; #ifdef PDE cl_object @'si::*record-source-pathname-p*'; @@ -46,23 +49,17 @@ setf_namep(cl_object fun_spec) { cl_object cdr; if (CONSP(fun_spec) && !endp(cdr = CDR(fun_spec)) && endp(CDR(cdr)) && CAR(fun_spec) == @'setf') { - cl_object fn_name, sym; - fn_name = CAR(cdr); - sym = getf(fn_name->symbol.plist, @'si::setf-symbol', Cnil); - if (Null(sym) || !SYMBOLP(sym)) { - cl_object fn_str = fn_name->symbol.name; - int l = fn_str->string.fillp + 7; - cl_object string = alloc_simple_string(l); - char *str = alloc_atomic(l+1); - string->string.self = str; - strncpy(str, "(SETF ", 6); - strncpy(str + 6, fn_str->string.self, fn_str->string.fillp); - str[l-1] = ')'; - str[l] = '\0'; - sym = intern(string, fn_name->symbol.hpack); - fn_name->symbol.plist = - putf(fn_name->symbol.plist, sym, @'si::setf-symbol'); - } + cl_object sym, fn_name = CAR(cdr); + cl_object fn_str = fn_name->symbol.name; + int l = fn_str->string.fillp + 7; + cl_object string = alloc_simple_string(l); + char *str = alloc_atomic(l+1); + string->string.self = str; + strncpy(str, "(SETF ", 6); + strncpy(str + 6, fn_str->string.self, fn_str->string.fillp); + str[l-1] = ')'; + str[l] = '\0'; + sym = intern(string, fn_name->symbol.hpack); return(sym); } else return(OBJNULL); } @@ -78,11 +75,15 @@ setf_namep(cl_object fun_spec) cl_type t; @ if (!SYMBOLP(fun)) { - cl_object sym; - if ((sym=setf_namep(fun)) != OBJNULL) - fun = sym; - else - FEtype_error_symbol(fun); + cl_object sym = setf_namep(fun); + if (sym == OBJNULL) + FEtype_error_symbol(fun); + fun = CADR(fun); + putprop(fun, sym, @'si::setf-symbol'); + remprop(fun, @'si::setf-lambda'); + remprop(fun, @'si::setf-method'); + remprop(fun, @'si::setf-update'); + fun = sym; } if (fun->symbol.isform) { if (fun->symbol.mflag) { @@ -124,11 +125,15 @@ setf_namep(cl_object fun_spec) @(defun fmakunbound (sym) @ if (!SYMBOLP(sym)) { - cl_object sym1; - if ((sym1=setf_namep(sym)) != OBJNULL) - sym = sym1; - else + cl_object sym1 = setf_namep(sym); + if (sym1 == OBJNULL) FEtype_error_symbol(sym); + sym = CADR(sym); + remprop(sym, @'si::setf-lambda'); + remprop(sym, @'si::setf-method'); + remprop(sym, @'si::setf-update'); + @fmakunbound(1, sym1); + @(return sym) } if (sym->symbol.isform) { if (sym->symbol.mflag) { diff --git a/src/c/compiler.d b/src/c/compiler.d index f52d9353f..c0537c5e4 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -32,6 +32,15 @@ cl_object @'&key'; cl_object @'&allow-other-keys'; cl_object @'&aux'; +cl_object @'si::symbol-macro'; +cl_object @'tag'; +cl_object @'block'; +cl_object @'macro'; +cl_object @'function'; +cl_object @':block'; +cl_object @':tag'; +cl_object @':function'; + cl_object @':allow-other-keys'; typedef struct { @@ -352,20 +361,39 @@ c_new_env() c_env.lexical_level = 0; } +static void +c_register_block(cl_object name) +{ + c_env.variables = CONS(list(2, @':block', name), c_env.variables); +} + +static void +c_register_tags(cl_object all_tags) +{ + c_env.variables = CONS(list(2, @':tag', all_tags), c_env.variables); +} + +static void +c_register_function(cl_object name) +{ + c_env.variables = CONS(list(2, @':function', name), c_env.variables); + c_env.macros = CONS(list(2, name, @'function'), c_env.macros); +} + static cl_object c_macro_expand1(cl_object stmt) { return macro_expand1(stmt, CONS(c_env.variables, c_env.macros)); } -void +static void c_register_symbol_macro(cl_object name, cl_object exp_fun) { c_env.variables = CONS(list(3, name, @'si::symbol-macro', exp_fun), c_env.variables); } -void +static void c_register_macro(cl_object name, cl_object exp_fun) { c_env.macros = CONS(list(3, name, @'macro', exp_fun), c_env.macros); @@ -378,6 +406,32 @@ c_register_var(register cl_object var, bool special) c_env.variables); } +static cl_object +c_tag_ref(cl_object the_tag, cl_object the_type) +{ + cl_fixnum n = 0; + cl_object l; + for (l = c_env.variables; CONSP(l); l = CDR(l)) { + cl_object record = CAR(l); + cl_object type = CAR(record); + cl_object name = CADR(record); + if (type == @':tag') { + if (type == the_type && !Null(assq(the_tag, name))) + return CONS(MAKE_FIXNUM(n), + CDR(assq(the_tag, name))); + n++; + } else if (type == @':block' || type == @':function') { + if (type == the_type && name == the_tag) + return Ct; + n++; + } else if (Null(name)) { + /* We are counting only locals */ + n++; + } + } + return Cnil; +} + static cl_fixnum c_var_ref(cl_object var) { @@ -387,9 +441,11 @@ c_var_ref(cl_object var) cl_object record = CAR(l); cl_object name = CAR(record); cl_object special = CADR(record); - if (name != var) { - /* Symbol not yet found. Only count locals. */ + if (name == @':block' || name == @':tag' || name == @':function') n++; + else if (name != var) { + /* Symbol not yet found. Only count locals. */ + if (Null(special)) n++; } else if (special == @'si::symbol-macro') { /* We should never get here. The variable should have been macro expanded. */ @@ -408,12 +464,13 @@ special_variablep(register cl_object var, register cl_object specials) return ((var->symbol.stype == stp_special) || member_eq(var, specials)); } -static void +static bool c_pbind(cl_object var, cl_object specials) { + bool special; if (!SYMBOLP(var)) FEillegal_variable_name(var); - else if (special_variablep(var, specials)) { + else if (special = special_variablep(var, specials)) { c_register_var(var, TRUE); asm_op(OP_PBINDS); } else { @@ -421,14 +478,16 @@ c_pbind(cl_object var, cl_object specials) asm_op(OP_PBIND); } asm1(var); + return special; } -static void +static bool c_bind(cl_object var, cl_object specials) { + bool special; if (!SYMBOLP(var)) FEillegal_variable_name(var); - else if (special_variablep(var, specials)) { + else if (special = special_variablep(var, specials)) { c_register_var(var, TRUE); asm_op(OP_BINDS); } else { @@ -436,6 +495,30 @@ c_bind(cl_object var, cl_object specials) asm_op(OP_BIND); } asm1(var); + return special; +} + +static void +c_undo_bindings(cl_object old_env) +{ + cl_object env; + cl_index num_lexical = 0; + cl_index num_special = 0; + + for (env = c_env.variables; env != old_env && !Null(env); env = CDR(env)) { + cl_object record = CAR(env); + cl_object name = CAR(record); + cl_object special = CADR(record); + if (name == @':block' || name == @':tag') + FEerror("Internal error: cannot undo BLOCK/TAGBODY.",0); + else if (name == @':function' || Null(special)) + num_lexical++; + else if (special != @'si::symbol-macro') + num_special++; + } + if (num_lexical) asm_op2(OP_UNBIND, num_lexical); + if (num_special) asm_op2(OP_UNBINDS, num_special); + c_env.variables = old_env; } static void @@ -494,12 +577,17 @@ static void c_block(cl_object body) { cl_object name = pop(&body); cl_index labelz = asm_jmp(OP_BLOCK); + cl_object old_env = c_env.variables; + if (!SYMBOLP(name)) FEprogram_error("BLOCK: Not a valid block name, ~S", 1, name); + + c_register_block(name); asm1(name); compile_body(body); asm_op(OP_EXIT); asm_complete(OP_BLOCK, labelz); + c_env.variables = old_env; } /* @@ -533,7 +621,13 @@ c_call(cl_object args, bool push) { compile_form(pop(&args),TRUE); } if (ATOM(name)) { - asm_op2(push? OP_PCALL : OP_CALL, nargs); + cl_object ndx = c_tag_ref(name, @':function'); + if (Null(ndx)) + /* Globally defined function */ + asm_op2(push? OP_PCALLG : OP_CALLG, nargs); + else + /* Function from a FLET/LABELS form */ + asm_op2(push? OP_PCALL : OP_CALL, nargs); asm1(name); } else if (CAR(name) == @'lambda') { asm_op(OP_CLOSE); @@ -544,8 +638,8 @@ c_call(cl_object args, bool push) { if (aux == OBJNULL) FEprogram_error("FUNCALL: Invalid function name ~S.", 1, name); - asm_op2(push? OP_PCALL : OP_CALL, nargs); - asm1(aux); + /* The outcome of (SETF ...) may be a macro name */ + compile_form(CONS(aux, CDR(args)), push); } } @@ -743,6 +837,9 @@ c_do_doa(int op, cl_object args) { labelz = asm_jmp(OP_DO); + /* Bind block */ + c_register_block(Cnil); + /* Compile initial bindings */ if (length(bindings) == 1) op = OP_BIND; @@ -865,6 +962,9 @@ c_dolist_dotimes(int op, cl_object args) { compile_form(list, FALSE); labelz = asm_jmp(op); + /* Bind block */ + c_register_block(Cnil); + /* Initialize the variable */ compile_form((op == OP_DOLIST)? Cnil : MAKE_FIXNUM(0), FALSE); c_bind(var, specials); @@ -927,26 +1027,58 @@ c_eval_when(cl_object args) { OP_EXIT labelz: */ +static cl_index +c_register_functions(cl_object l) +{ + cl_index nfun; + for (nfun = 0; !endp(l); nfun++) { + cl_object definition = pop(&l); + cl_object name = pop(&definition); + c_register_function(name); + } + return nfun; +} + static void c_labels_flet(int op, cl_object args) { - cl_object def_list = pop(&args); - int nfun = length(def_list); + cl_object l, def_list = pop(&args); + cl_compiler_env old_c_env = c_env; + cl_index nfun; /* Remove declarations */ @si::process-declarations(1, args); args = VALUES(1); - if (nfun == 0) { - compile_body(args); - return; - } + + /* If compiling a LABELS form, add the function names to the lexical + environment before compiling the functions */ + if (op == OP_FLET) + nfun = length(def_list); + else + nfun = c_register_functions(def_list); + + /* Push the operator (OP_LABELS/OP_FLET) with the number of functions */ asm_op2(op, nfun); - do { - cl_object definition = pop(&def_list); + + /* Compile the local functions now. */ + for (l = def_list; !endp(l); ) { + cl_object definition = pop(&l); cl_object name = pop(&definition); asm1(make_lambda(name, definition)); - } while (!endp(def_list)); + } + + /* If compiling a FLET form, add the function names to the lexical + environment after compiling the functions */ + if (op == OP_FLET) + c_register_functions(def_list); + + /* Compile the body of the form with the local functions in the lexical + environment. */ compile_body(args); - asm_op(OP_EXIT); + + c_undo_bindings(old_c_env.variables); + + /* Restore and return */ + c_env = old_c_env; } @@ -969,7 +1101,7 @@ c_flet(cl_object args) { */ static void c_function(cl_object args) { - cl_object function = pop(&args); + cl_object setf_function, function = pop(&args); if (!endp(args)) FEprogram_error("FUNCTION: Too many arguments.", 0); if (SYMBOLP(function)) { @@ -983,6 +1115,9 @@ c_function(cl_object args) { cl_object body = CDDR(function); asm_op(OP_CLOSE); asm1(make_lambda(name, body)); + } else if ((setf_function = setf_namep(function)) != OBJNULL) { + asm_op(OP_FUNCTION); + asm1(setf_function); } else FEprogram_error("FUNCTION: Not a valid argument ~S.", 1, function); } @@ -990,10 +1125,14 @@ c_function(cl_object args) { static void c_go(cl_object args) { - asm_op(OP_GO); - asm1(pop(&args)); + cl_object tag = pop(&args); + cl_object info = c_tag_ref(tag, @':tag'); + if (Null(info)) + FEprogram_error("GO: Unknown tag ~S.", 1, tag); if (!Null(args)) FEprogram_error("GO: Too many arguments.",0); + asm_op2(OP_GO, fix(CAR(info))); + asm1(CDR(info)); } @@ -1089,7 +1228,6 @@ c_let_leta(int op, cl_object args) { default: } - asm_op(OP_PUSHENV); for (vars=Cnil, l=bindings; !endp(l); ) { cl_object aux = pop(&l); cl_object var, value; @@ -1115,9 +1253,8 @@ c_let_leta(int op, cl_object args) { while (!endp(vars)) c_pbind(pop(&vars), specials); compile_body(body); - asm_op(OP_EXIT); - c_env.variables = old_variables; + c_undo_bindings(old_variables); } static void @@ -1174,7 +1311,6 @@ c_multiple_value_bind(cl_object args) { cl_object vars, value, body, specials; cl_index save_pc, n; - cl_object old_variables = c_env.variables; vars = pop(&args); value = pop(&args); @@ -1187,7 +1323,7 @@ c_multiple_value_bind(cl_object args) if (n == 0) { compile_body(body); } else { - asm_op(OP_PUSHENV); + cl_object old_variables = c_env.variables; asm_op2(OP_MBIND, n); for (vars=reverse(vars); n; n--){ cl_object var = pop(&vars); @@ -1201,9 +1337,8 @@ c_multiple_value_bind(cl_object args) asm1(var); } compile_body(body); - asm_op(OP_EXIT); + c_undo_bindings(old_variables); } - c_env.variables = old_variables; } @@ -1244,6 +1379,7 @@ c_multiple_value_setq(cl_object args) { cl_object vars = Cnil; cl_object temp_vars = Cnil; cl_object late_assignment = Cnil; + cl_object old_variables; cl_index nvars = 0; /* Look for symbol macros, building the list of variables @@ -1265,7 +1401,7 @@ c_multiple_value_setq(cl_object args) { } if (!Null(temp_vars)) { - asm_op(OP_PUSHENV); + old_variables = c_env.variables; do { compile_form(Cnil, FALSE); c_bind(CAR(temp_vars), Cnil); @@ -1303,7 +1439,7 @@ c_multiple_value_setq(cl_object args) { /* Assign to symbol-macros */ if (!Null(late_assignment)) { compile_body(late_assignment); - asm_op(OP_EXIT); + c_undo_bindings(old_variables); } } @@ -1442,29 +1578,30 @@ c_psetq(cl_object old_args) { tag ; object which names the block */ static void -c_return(cl_object stmt) { +c_return_aux(cl_object name, cl_object stmt) +{ + cl_object ndx = c_tag_ref(name, @':block'); cl_object output = pop_maybe_nil(&stmt); + if (!SYMBOLP(name) || Null(ndx)) + FEprogram_error("RETURN-FROM: Unknown block name ~S.", 1, name); + if (stmt != Cnil) + FEprogram_error("RETURN-FROM: Too many arguments.", 0); compile_form(output, FALSE); asm_op(OP_RETURN); - asm1(Cnil); - if (stmt != Cnil) - FEprogram_error("RETURN: Too many arguments.", 0); + asm1(name); +} + +static void +c_return(cl_object stmt) { + c_return_aux(Cnil, stmt); } static void c_return_from(cl_object stmt) { cl_object name = pop(&stmt); - cl_object output = pop_maybe_nil(&stmt); - - compile_form(output, FALSE); - asm_op(OP_RETURN); - if (!SYMBOLP(name)) - FEprogram_error("RETURN-FROM: Not a valid tag ~S.", 1, name); - asm1(name); - if (stmt != Cnil) - FEprogram_error("RETURN-FROM: Too many arguments.", 0); + c_return_aux(name, stmt); } @@ -1519,8 +1656,9 @@ declared special and appear in a symbol-macrolet.", 1, name); static void c_tagbody(cl_object args) { + cl_object old_env = c_env.variables; cl_fixnum tag_base; - cl_object label, body; + cl_object labels = Cnil, label, body; cl_type item_type; int nt, i; @@ -1530,6 +1668,7 @@ c_tagbody(cl_object args) item_type = type_of(CAR(body)); if (item_type == t_symbol || item_type == t_fixnum || item_type == t_bignum) { + labels = CONS(CONS(label,MAKE_FIXNUM(nt)), labels); nt += 1; } } @@ -1538,9 +1677,10 @@ c_tagbody(cl_object args) compile_form(Cnil, FALSE); return; } + c_register_tags(labels); asm_op2(OP_TAGBODY, nt); tag_base = current_pc(); - for (i = 2*nt; i; i--) + for (i = nt; i; i--) asm1(Cnil); for (body = args; !endp(body); body = CDR(body)) { @@ -1548,8 +1688,6 @@ c_tagbody(cl_object args) item_type = type_of(label); if (item_type == t_symbol || item_type == t_fixnum || item_type == t_bignum) { - asm_at(tag_base, label); - tag_base++; asm_at(tag_base, MAKE_FIXNUM(current_pc()-tag_base)); tag_base++; } else { @@ -1557,6 +1695,7 @@ c_tagbody(cl_object args) } } asm_op(OP_EXIT); + c_env.variables = old_env; } @@ -2069,6 +2208,10 @@ make_lambda(cl_object name, cl_object lambda) { handle = asm_begin(); + /* Transform (SETF fname) => fname */ + if (CONSP(name) && setf_namep(name) == OBJNULL) + FEprogram_error("LAMBDA: Not a valid function name ~S",1,name); + asm1(name); /* Name of the function */ specials_pc = current_pc(); /* Which variables are declared special */ asm1(specials); @@ -2110,6 +2253,9 @@ make_lambda(cl_object name, cl_object lambda) { keys_pc+=4; } + if (!Null(name)) + c_register_block(name); + if ((current_pc() - label) == 1) set_pc(label); else @@ -2122,6 +2268,7 @@ make_lambda(cl_object name, cl_object lambda) { c_bind(var, specials); } asm_at(specials_pc, specials); + compile_body(body); asm_op(OP_HALT); @@ -2133,6 +2280,16 @@ make_lambda(cl_object name, cl_object lambda) { return asm_end(handle, Cnil); } +@(defun si::function-block-name (name) +@ + if (SYMBOLP(name)) + @(return name) + if (CONSP(name) && CAR(name) == @'setf' && CONSP(CDR(name)) && + SYMBOLP(CADR(name)) && Null(CDDR(name))) + @(return CADR(name)) + FEerror("Not a valid function name ~S",1,name); +@) + @(defun si::make_lambda (name rest) cl_object lambda; cl_compiler_env old_c_env = c_env; diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 1843782eb..3a8a13b1e 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -291,19 +291,6 @@ disassemble_progv(cl_object *vector) { return vector; } -static cl_object * -disassemble_pushenv(cl_object *vector) { - cl_object lex_old = lex_env; - lex_copy(); - - printf("PUSHENV"); - vector = disassemble(vector); - printf("\t\t\t; pushenv"); - - lex_env = lex_old; - return vector; -} - /* OP_TAGBODY n-tags tag1 addr1 tag2 addr2 @@ -315,17 +302,15 @@ disassemble_pushenv(cl_object *vector) { static cl_object * disassemble_tagbody(cl_object *vector) { - cl_index ntags = get_oparg(vector[-1]); + cl_index i, ntags = get_oparg(vector[-1]); cl_object lex_old = lex_env; lex_copy(); printf("TAGBODY"); - while (ntags--) { + for (i=0; iarray.dim * sizeof(double); break; + case aet_b8: + j = x->array.dim * sizeof(u_int8_t); + break; + case aet_i8: + j = x->array.dim * sizeof(int8_t); + break; default: error("Allocation botch: unknown array element type"); } diff --git a/src/c/init.d b/src/c/init.d index 22a63059d..ddfeb5886 100644 --- a/src/c/init.d +++ b/src/c/init.d @@ -82,7 +82,6 @@ init_lisp(void) init_compiler(); init_interpreter(); init_eval(); -/* init_lex(); */ /* init_reference(); */ init_assignment(); /* init_stacks(); */ @@ -104,7 +103,8 @@ init_lisp(void) #ifdef RUNTIME SYM_VAL(@'*features*') = CONS(make_keyword("RUNTIME"), SYM_VAL(@'*features*')); #endif - ihs_push(_intern("TOP-LEVEL", system_package), Cnil); + lex_env = Cnil; + ihs_push(_intern("TOP-LEVEL", system_package)); init_LSP(); init_CLOS(); } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index f62935141..b08b9c0a1 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -103,12 +103,32 @@ cl_stack_pop_n(cl_index index) { cl_stack_top = new_top; } -/* -------------------- LAMBDA FUNCTIONS -------------------- */ +/* ------------------------------ LEXICAL ENV. ------------------------------ */ + +cl_object lex_env; static void bind_var(register cl_object var, register cl_object val) { - CAR(lex_env) = CONS(var, CONS(val, CAR(lex_env))); + lex_env = CONS(var, CONS(val, lex_env)); +} + +static void +bind_function(cl_object name, cl_object fun) +{ + lex_env = CONS(@':function', CONS(CONS(name, fun), lex_env)); +} + +static void +bind_tagbody(cl_object id) +{ + lex_env = CONS(@':tag', CONS(id, lex_env)); +} + +static void +bind_block(cl_object name, cl_object id) +{ + lex_env = CONS(@':block', CONS(CONS(name, id), lex_env)); } static void @@ -117,6 +137,55 @@ bind_special(register cl_object var, register cl_object val) bds_bind(var, val); } +static cl_object +search_local(register cl_object name, register int s) { + cl_object x; + for (x = lex_env; s-- && !Null(x); x = CDDR(x)); + if (Null(x) || CAR(x) != name) + FEerror("Internal error: local not found.", 0); + return CADR(x); +} + +static cl_object +setq_local(register cl_object s, register cl_object v) { + cl_object x; + for (x = lex_env; CONSP(x); x = CDDR(x)) + if (CAR(x) == s) { + CADR(x) = v; + return; + } + FEerror("Internal error: local ~S not found.", 1, s); +} + +static cl_object +search_tag(cl_object name, cl_object type) +{ + cl_object x; + + for (x = lex_env; CONSP(x); x = CDDR(x)) + if (CAR(x) == type) { + cl_object record = CADR(x); + cl_object the_name = CAR(record); + cl_object the_value = CDR(record); + if (name == the_name) + return the_value; + } + return Cnil; +} + +static cl_object +search_symbol_function(register cl_object fun) { + cl_object output = search_tag(fun, @':function'); + if (!Null(output)) + return output; + output = SYM_FUN(fun); + if (output == OBJNULL || fun->symbol.mflag) + FEundefined_function(fun); + return output; +} + +/* -------------------- LAMBDA FUNCTIONS -------------------- */ + static void lambda_bind_var(cl_object var, cl_object val, cl_object specials) { @@ -233,18 +302,14 @@ lambda_apply(int narg, cl_object fun, cl_object *args) { cl_object output, name, *body; bds_ptr old_bds_top; - volatile bool block, closure; + volatile bool block; if (type_of(fun) != t_bytecodes) FEinvalid_function(fun); /* 1) Save the lexical environment and set up a new one */ - cl_stack_push(lex_env); - if (Null(fun->bytecodes.lex)) - lex_env = CONS(Cnil, Cnil); - else - lex_env = CONS(CAR(fun->bytecodes.lex),CDR(fun->bytecodes.lex)); - ihs_push(fun, lex_env); + ihs_push(fun); + lex_env = fun->bytecodes.lex; old_bds_top = bds_top; /* Establish bindings */ @@ -257,8 +322,10 @@ lambda_apply(int narg, cl_object fun, cl_object *args) block = FALSE; else { block = TRUE; + /* Accept (SETF name) */ + if (CONSP(name)) name = CADR(name); fun = new_frame_id(); - lex_block_bind(name, fun); + bind_block(name, fun); if (frs_push(FRS_CATCH, fun)) { output = VALUES(0); goto END; @@ -273,7 +340,6 @@ lambda_apply(int narg, cl_object fun, cl_object *args) END: if (block) frs_pop(); bds_unwind(old_bds_top); ihs_pop(); - lex_env = cl_stack_pop(); returnn(VALUES(0)); } @@ -323,39 +389,6 @@ simple_label(cl_object *v) { return v + fix(v[0]); } -static cl_object -search_symbol_function(register cl_object fun) { - cl_object output = lex_fun_sch(fun); - if (!Null(output)) - return output; - output = SYM_FUN(fun); - if (output == OBJNULL || fun->symbol.mflag) - FEundefined_function(fun); - return output; -} - -static cl_object -search_local(register cl_object s) { - cl_object x; - - for (x = CAR(lex_env); CONSP(x); x = CDDR(x)) - if (CAR(x) == s) { - return CADR(x); - } - FEerror("Internal error: local ~S not found.", 1, s); -} - -static cl_object -setq_local(register cl_object s, register cl_object v) { - cl_object x; - for (x = CAR(lex_env); CONSP(x); x = CDDR(x)) - if (CAR(x) == s) { - CADR(x) = v; - return; - } - FEerror("Internal error: local ~S not found.", 1, s); -} - static cl_object search_global(register cl_object s) { cl_object x = SYM_VAL(s); @@ -369,40 +402,19 @@ interpret_call(int narg, cl_object fun) { cl_object *args; cl_object x; + fun = search_tag(fun, @':function'); args = cl_stack_top - narg; - AGAIN: - switch (type_of(fun)) { - case t_cfun: - ihs_push(fun->cfun.name, Cnil); - x = APPLY(narg, fun->cfun.entry, args); - ihs_pop(); - break; - case t_cclosure: - /* FIXME! Shouldn't we register this call somehow? */ - x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args); - break; -#ifdef CLOS - case t_gfun: - ihs_push(fun->gfun.name, Cnil); - x = gcall(narg, fun, args); - ihs_pop(); - break; -#endif - case t_bytecodes: - x = lambda_apply(narg, fun, args); - break; - case t_symbol: - fun = search_symbol_function(fun); - goto AGAIN; - default: - FEinvalid_function(fun); + if (type_of(fun) != t_bytecodes) { + if (Null(fun)) + FEerror("Internal error: local ~S not found.", 1, fun); + FEerror("Internal error: local function not of type bytecodes.",0); } + x = lambda_apply(narg, fun, args); cl_stack_pop_n(narg); return x; } -/* Similar to interpret_call(), but looks for symbol functions in the - global environment. */ +/* Similar to funcall(), but registers calls in the IHS stack. */ static cl_object interpret_funcall(int narg, cl_object fun) { @@ -413,7 +425,8 @@ interpret_funcall(int narg, cl_object fun) { AGAIN: switch (type_of(fun)) { case t_cfun: - ihs_push(fun->cfun.name, Cnil); + ihs_push(fun->cfun.name); + lex_env = Cnil; x = APPLY(narg, fun->cfun.entry, args); ihs_pop(); break; @@ -423,7 +436,8 @@ interpret_funcall(int narg, cl_object fun) { break; #ifdef CLOS case t_gfun: - ihs_push(fun->gfun.name, Cnil); + ihs_push(fun->gfun.name); + lex_env = Cnil; x = gcall(narg, fun, args); ihs_pop(); break; @@ -453,17 +467,17 @@ interpret_block(cl_object *vector) { cl_object id = new_frame_id(); /* 1) Save current environment */ - cl_stack_push(CDR(lex_env)); + cl_stack_push(lex_env); /* 2) Set up a block with given name */ exit = packed_label(vector - 1); - lex_block_bind(next_code(vector), id); + bind_block(next_code(vector), id); if (frs_push(FRS_CATCH,id) == 0) vector = interpret(vector); frs_pop(); /* 3) Restore environment */ - CDR(lex_env) = cl_stack_pop(); + lex_env = cl_stack_pop(); return exit; } @@ -484,30 +498,24 @@ interpret_tagbody(cl_object *vector) { cl_object *aux, *tag_list = vector; /* 1) Save current environment */ - cl_stack_push(CDR(lex_env)); + cl_stack_push(lex_env); /* 2) Bind tags */ - aux = vector; - for (i=0; i= ntags) - FEerror("Internal error: TAGBODY id used for RETURN-FROM.",0); - else - aux = simple_label(aux); - } + /* 3) Wait here for gotos. Each goto sets nlj_tag to a integer + which ranges from 0 to ntags-1, depending on the tag. These + numbers are indices into the jump table and are computed + at compile time. + */ + aux = vector + ntags; + if (frs_push(FRS_CATCH, id) != 0) + aux = simple_label(vector + fix(nlj_tag)); vector = interpret(aux); frs_pop(); /* 4) Restore environment */ - CDR(lex_env) = cl_stack_pop(); + lex_env = cl_stack_pop(); VALUES(0) = Cnil; NValues = 0; return vector; @@ -515,9 +523,9 @@ interpret_tagbody(cl_object *vector) { static cl_object * interpret_unwind_protect(cl_object *vector) { - bool unwinding; - int nr; + volatile int nr; cl_object * volatile exit; + bool unwinding; exit = packed_label(vector-1); if (frs_push(FRS_PROTECT, Cnil)) @@ -543,11 +551,10 @@ interpret_do(cl_object *vector) { /* 1) Save all environment */ bds_ptr old_bds_top = bds_top; - cl_stack_push(CAR(lex_env)); - cl_stack_push(CDR(lex_env)); + cl_stack_push(lex_env); /* 2) Set up new block name */ - lex_block_bind(Cnil, id); + bind_block(Cnil, id); exit = packed_label(vector-1); if (frs_push(FRS_CATCH,id) == 0) interpret(vector); @@ -555,8 +562,7 @@ interpret_do(cl_object *vector) { /* 3) Restore all environment */ bds_unwind(old_bds_top); - CDR(lex_env) = cl_stack_pop(); - CAR(lex_env) = cl_stack_pop(); + lex_env = cl_stack_pop(); return exit; } @@ -568,11 +574,10 @@ interpret_dolist(cl_object *vector) { /* 1) Save all environment */ bds_ptr old_bds_top = bds_top; - cl_stack_push(CAR(lex_env)); - cl_stack_push(CDR(lex_env)); + cl_stack_push(lex_env); /* 2) Set up a nil block */ - lex_block_bind(Cnil, id); + bind_block(Cnil, id); if (frs_push(FRS_CATCH,id) == 0) { list = VALUES(0); exit = packed_label(vector - 1); @@ -595,8 +600,7 @@ interpret_dolist(cl_object *vector) { frs_pop(); /* 5) Restore environment */ - CDR(lex_env) = cl_stack_pop(); - CAR(lex_env) = cl_stack_pop(); + lex_env = cl_stack_pop(); bds_unwind(old_bds_top); return exit; } @@ -610,11 +614,10 @@ interpret_dotimes(cl_object *vector) { /* 1) Save all environment */ bds_ptr old_bds_top = bds_top; - cl_stack_push(CAR(lex_env)); - cl_stack_push(CDR(lex_env)); + cl_stack_push(lex_env); /* 2) Set up a nil block */ - lex_block_bind(Cnil, id); + bind_block(Cnil, id); if (frs_push(FRS_CATCH,id) == 0) { /* 3) Retrieve number and bind variables */ length = fix(VALUES(0)); @@ -633,8 +636,7 @@ interpret_dotimes(cl_object *vector) { frs_pop(); /* 5) Restore environment */ - CDR(lex_env) = cl_stack_pop(); - CAR(lex_env) = cl_stack_pop(); + lex_env = cl_stack_pop(); bds_unwind(old_bds_top); return exit; } @@ -644,10 +646,7 @@ close_around(cl_object fun, cl_object lex) { cl_object v = alloc_object(t_bytecodes); v->bytecodes.size = fun->bytecodes.size; v->bytecodes.data = fun->bytecodes.data; - if (!Null(CAR(lex)) || !Null(CDR(lex))) - v->bytecodes.lex = CONS(CAR(lex),CDR(lex)); - else - v->bytecodes.lex = Cnil; + v->bytecodes.lex = lex; return v; } @@ -655,50 +654,36 @@ static cl_object * interpret_flet(cl_object *vector) { cl_index nfun = get_oparg(vector[-1]); - /* 1) Copy the environment so that functions get it */ - cl_object lex = CONS(CAR(lex_env), CDR(lex_env)); - - /* 2) Save current environment */ - cl_stack_push(CDR(lex_env)); + /* 1) Copy the environment so that functions get it without references + to themselves. */ + cl_object lex = lex_env; /* 3) Add new closures to environment */ while (nfun--) { cl_object fun = next_code(vector); cl_object f = close_around(fun,lex); - lex_fun_bind(f->bytecodes.data[0], f); + bind_function(f->bytecodes.data[0], f); } - vector = interpret(vector); - - /* 4) Restore environment */ - CDR(lex_env) = cl_stack_pop(); return vector; } static cl_object * interpret_labels(cl_object *vector) { cl_index i, nfun = get_oparg(vector[-1]); - cl_object l, lex; + cl_object l; - /* 1) Save current environment */ - cl_stack_push(CDR(lex_env)); - - /* 2) Build up a new environment with all functions */ + /* 1) Build up a new environment with all functions */ for (i=0; ibytecodes.data[0], f); + bind_function(f->bytecodes.data[0], f); } - lex = CONS(CAR(lex_env), CDR(lex_env)); - /* 3) Update the closures so that all functions can call each other */ - for (i=0, l=CDR(lex_env); isymbol.gfdef == OBJNULL) + FEundefined_function(fun); + VALUES(0) = interpret_funcall(n, fun->symbol.gfdef); + break; + } case OP_FCALL: { cl_fixnum n = get_oparg(s); cl_object fun = VALUES(0); VALUES(0) = interpret_funcall(n, fun); break; } + case OP_PCALLG: { + cl_fixnum n = get_oparg(s); + cl_object fun = next_code(vector); + if (fun->symbol.gfdef == OBJNULL) + FEundefined_function(fun); + VALUES(0) = interpret_funcall(n, fun->symbol.gfdef); + cl_stack_push(VALUES(0)); + break; + } case OP_PFCALL: { cl_fixnum n = get_oparg(s); cl_object fun = VALUES(0); @@ -907,9 +894,7 @@ interpret(cl_object *vector) { break; case OP_GO: { cl_object tag = next_code(vector); - cl_object id = lex_tag_sch(tag); - if (Null(id)) - FEcontrol_error("GO: Undefined tag ~S.", 1, tag); + cl_object id = search_local(@':tag',get_oparg(s)); VALUES(0) = Cnil; NValues = 0; go(id, tag); @@ -917,7 +902,7 @@ interpret(cl_object *vector) { } case OP_RETURN: { cl_object tag = next_code(vector); - cl_object id = lex_block_sch(tag); + cl_object id = search_tag(tag, @':block'); if (Null(id)) FEcontrol_error("RETURN-FROM: Unknown block ~S.", 1, tag); return_from(id, tag); @@ -945,6 +930,15 @@ interpret(cl_object *vector) { if (VALUES(0) != next_code(vector)) vector = vector + get_oparg(s) - 2; break; + case OP_UNBIND: { + cl_index n = get_oparg(s); + while (n--) + lex_env = CDDR(lex_env); + break; + } + case OP_UNBINDS: + bds_unwind(bds_top - get_oparg(s)); + break; case OP_BIND: bind_var(next_code(vector), VALUES(0)); break; @@ -995,9 +989,6 @@ interpret(cl_object *vector) { case OP_PROGV: vector = interpret_progv(vector); break; - case OP_PUSHENV: - vector = interpret_pushenv(vector); - break; case OP_VALUES: { cl_fixnum n = get_oparg(s); NValues = n; diff --git a/src/c/lex.d b/src/c/lex.d deleted file mode 100644 index 2c17c1289..000000000 --- a/src/c/lex.d +++ /dev/null @@ -1,65 +0,0 @@ -/* - lex.c -- Lexical environment. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECLS 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 "ecls.h" - -/******** EXPORTS ********/ - -#ifndef THREADS -cl_object lex_env = OBJNULL; -#endif - -cl_object @'si::symbol-macro'; -cl_object @'macro'; -cl_object @'block'; -cl_object @'tag'; - -/******** ------- ********/ - -void -lex_fun_bind(cl_object name, cl_object fun) -{ - CDR(lex_env) = CONS(list(3, name, @'function', fun), CDR(lex_env)); -} - -void -lex_tag_bind(cl_object tag, cl_object id) -{ - CDR(lex_env) = CONS(list(3, tag, @'tag', id), CDR(lex_env)); -} - -void -lex_block_bind(cl_object name, cl_object id) -{ - CDR(lex_env) = CONS(list(3, name, @'block', id), CDR(lex_env)); -} - -cl_object -lex_sch(cl_object alist, cl_object name, cl_object type) -{ - while (!endp(alist)) { - if (CAAR(alist) == name && CADAR(alist) == type) - return(CADDAR(alist)); - alist = CDR(alist); - } - return(Cnil); -} - -@(defun si::lex_env () -@ - @(return lex_env) -@) diff --git a/src/c/load.d b/src/c/load.d index 87614596e..b7fbe1ea8 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -29,6 +29,9 @@ cl_object @'si::*load-hooks*'; #ifdef PDE cl_object @'si::*source-pathname*'; #endif PDE +#ifdef ENABLE_DLOPEN +cl_object @'si::*init-function-prefix*'; +#endif /******************************* ------- ******************************/ @@ -36,6 +39,7 @@ cl_object @'si::*source-pathname*'; @(defun si::load_binary (filename verbose print) cl_object block; cl_object basename; + cl_object prefix; @ /* We need the full pathname */ filename = coerce_to_filename(truename(filename)); @@ -55,17 +59,25 @@ cl_object @'si::*source-pathname*'; goto GO_ON; /* 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_"); + else + prefix = @si::string-concatenate(3, + make_simple_string("init_"), + prefix, + make_simple_string("_")); basename = coerce_to_pathname(filename); basename = @pathname-name(1,basename); - basename = @si::string-concatenate(2, - make_simple_string("init_"), - @string-upcase(1,basename)); + basename = @si::string-concatenate(2, prefix, @string-upcase(1,basename)); block->cblock.entry = dlsym(block->cblock.handle, basename->string.self); - if (block->cblock.entry == "NULL") { + + if (block->cblock.entry == NULL) { dlclose(block->cblock.handle); @(return make_string_copy(dlerror())) } - if (1 || !Null(verbose)) { + + if (!Null(verbose)) { setupPRINT(filename, symbol_value(@'*standard-output*')); write_str(";;; Address = "); PRINTescape = FALSE; @@ -229,5 +241,6 @@ init_load(void) #ifdef ENABLE_DLOPEN if (dlopen(NULL, RTLD_NOW|RTLD_GLOBAL) == NULL) printf(";;; Error dlopening self file\n;;; Error: %s\n", dlerror()); + SYM_VAL(@'si::*init-function-prefix*') = Cnil; #endif } diff --git a/src/c/macros.d b/src/c/macros.d index a7d11a699..f0c65bcf3 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -45,7 +45,10 @@ search_symbol_macro(cl_object name, cl_object env) cl_object search_macro(cl_object name, cl_object env) { - return lex_sch(CDR(env), name, @'macro'); + cl_object record = assq(name, CDR(env)); + if (CONSP(record) && CADR(record) == @'macro') + return CADDR(record); + return Cnil; } cl_object diff --git a/src/c/num_log.d b/src/c/num_log.d index 3e9881ee3..9229ea459 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -254,7 +254,7 @@ b_c2_op(cl_fixnum i, cl_fixnum j) @(defun lognot (x) @ - return @logxor(1,x,MAKE_FIXNUM(-1)); + return @logxor(2,x,MAKE_FIXNUM(-1)); @) static cl_fixnum diff --git a/src/c/package.d b/src/c/package.d index 4a3b7fce4..681e4623f 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -211,7 +211,7 @@ coerce_to_package(cl_object p) pp = find_package(p); if (!Null(pp)) return (pp); - FEwrong_type_argument(@'*package*', p); + FEwrong_type_argument(@'package', p); } cl_object diff --git a/src/c/reference.d b/src/c/reference.d index 029b8d646..97c20e805 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -69,10 +69,9 @@ symbol_function(cl_object sym) @ if (!SYMBOLP(sym)) { cl_object sym1 = setf_namep(sym); - if (sym1 != OBJNULL) - sym = sym1; - else + if (sym1 == OBJNULL) FEtype_error_symbol(sym); + sym = sym1; } if (sym->symbol.isform) output = @'special'; @@ -89,10 +88,7 @@ symbol_function(cl_object sym) cl_type t = type_of(fun); @ if (t == t_symbol) { - cl_object fd = lex_fun_sch(fun); - if (!Null(fd)) - return CADDR(fd); - else if (FBOUNDP(fun) || fun->symbol.mflag) + if (FBOUNDP(fun) || fun->symbol.mflag) FEundefined_function(fun); else @(return SYM_FUN(fun)) diff --git a/src/c/sequence.d b/src/c/sequence.d index 7559cf2e0..8508f3ce1 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -335,11 +335,18 @@ reverse(cl_object seq) for (j = k - 1, i = 0; j >=0; --j, i++) y->vector.self.t[j] = x->vector.self.t[i]; break; - case aet_lf: for (j = k - 1, i = 0; j >=0; --j, i++) y->array.self.lf[j] = x->array.self.lf[i]; break; + case aet_b8: + for (j = k - 1, i = 0; j >=0; --j, i++) + y->array.self.b8[j] = x->array.self.b8[i]; + break; + case aet_i8: + for (j = k - 1, i = 0; j >=0; --j, i++) + y->array.self.i8[j] = x->array.self.i8[i]; + break; default: internal_error("reverse"); } @@ -428,6 +435,20 @@ nreverse(cl_object seq) x->array.self.lf[j] = y; } return(seq); + case aet_b8: + for (i = 0, j = k - 1; i < j; i++, --j) { + u_int8_t y = x->array.self.b8[i]; + x->array.self.b8[i] = x->array.self.b8[j]; + x->array.self.b8[j] = y; + } + return(seq); + case aet_i8: + for (i = 0, j = k - 1; i < j; i++, --j) { + int8_t y = x->array.self.i8[i]; + x->array.self.i8[i] = x->array.self.i8[j]; + x->array.self.i8[j] = y; + } + return(seq); default: internal_error("subseq"); } diff --git a/src/c/stacks.d b/src/c/stacks.d index ba1d3adf7..e0cddec4b 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -120,10 +120,10 @@ ihs_function_name(cl_object x) } void -ihs_push(cl_object function, cl_object env) +ihs_push(cl_object function) { cl_stack_push(function); - cl_stack_push(env); + cl_stack_push(lex_env); cl_stack_push(MAKE_FIXNUM(ihs_top)); ihs_top = cl_stack_index(); } @@ -133,6 +133,7 @@ ihs_pop() { cl_stack_set_index(ihs_top); ihs_top = fix(cl_stack_top[-1]); + lex_env = cl_stack_top[-2]; cl_stack_pop_n(3); } @@ -154,6 +155,19 @@ ihs_prev(cl_index n) return n; } +static cl_index +ihs_next(cl_index n) +{ + cl_index h1 = ihs_top, h2 = ihs_top; + while (h2 > n) { + h1 = h2; + h2 = ihs_prev(h1); + } + if (h2 == n) + return h1; + FEerror("Internal error: ihs record ~S not found.", 1, MAKE_FIXNUM(n)); +} + cl_object ihs_top_function_name(void) { @@ -194,16 +208,8 @@ ihs_top_function_name(void) @) @(defun si::ihs-next (x) - cl_index h1 = ihs_top, h2 = ihs_top; - cl_index n = fixnnint(x); @ - while (h2 > n) { - h1 = h2; - h2 = ihs_prev(h1); - } - if (h2 == n) - @(return MAKE_FIXNUM(h1)) - FEerror("Internal error: ihs record ~S not found.", 1, x); + @(return MAKE_FIXNUM(ihs_next(fixnnint(x)))) @) @(defun si::ihs_fun (arg) @@ -214,8 +220,8 @@ ihs_top_function_name(void) @(defun si::ihs_env (arg) cl_object lex; @ - lex = get_ihs_ptr(fixnnint(arg))[-2]; - @(return CONS(car(lex),cdr(lex))) + lex = get_ihs_ptr(ihs_next(fixnnint(arg)))[-2]; + @(return lex) @) /********************** FRAME STACK *************************/ diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index 2d3c6bc3d..25a762f14 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -130,7 +130,7 @@ (wt-nl "return_from(" (blk-var blk) "," (add-symbol (blk-name blk)) ");")) ((CLB UNWIND-PROTECT) (let ((*destination* 'VALUES)) (c2expr* val)) - (wt-nl "return_from(") (blk-var blk) (wt ",Cnil);")) + (wt-nl "return_from(" (blk-var blk) ",Cnil);")) (T (let ((*destination* (blk-destination blk)) (*exit* (blk-exit blk))) (c2expr val)))) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index db3650fb8..ce3c42bfb 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -63,8 +63,13 @@ (consp (rest function))) ;; Don't create closure boundary like in c1function ;; since funob is used in this same environment - (let ((lambda-expr (c1lambda-expr (cddr function) (second function)))) - (list 'LAMBDA (second lambda-expr) lambda-expr (next-cfun)))) + (let ((name (second function))) + (unless (symbolp name) + (if (si::setf-namep name) + (setq name (si::setf-namep name)) + (error "~S is not a valid function name" name))) + (let ((lambda-expr (c1lambda-expr (cddr function) name))) + (list 'LAMBDA (second lambda-expr) lambda-expr (next-cfun))))) (t (cmperr "Malformed function: ~A" fun)))) (defun c1funcall (args &aux funob (info (make-info))) @@ -165,34 +170,31 @@ (unless (eq 'ARGS-PUSHED args) (case fname (AREF - (let ((etype (info-type (cadar args)))) - (when (or (and (eq etype 'STRING) - (setq etype 'CHARACTER)) - (and (consp etype) - (or (eq (car etype) 'ARRAY) - (eq (car etype) 'VECTOR)) - (setq etype (second etype)))) - (setq etype (type-and return-type etype)) + (let (etype (elttype (info-type (cadar args)))) + (when (or (and (eq elttype 'STRING) + (setq elttype 'CHARACTER)) + (and (consp elttype) + (or (eq (car elttype) 'ARRAY) + (eq (car elttype) 'VECTOR)) + (setq elttype (second elttype)))) + (setq etype (type-and return-type elttype)) (unless etype - (cmpwarn "Type mismatch was found in ~s." - (cons fname args)) + (cmpwarn "Type mismatch found in AREF. Expected output type ~s, array element type ~s." return-type elttype) (setq etype T)) ; assume no information (setf return-type etype)))) (SYS:ASET ; (sys:aset value array i0 ... in) - (let ((etype (info-type (cadr (second args))))) - (when (or (and (eq etype 'STRING) - (setq etype 'CHARACTER)) - (and (consp etype) - (or (eq (car etype) 'ARRAY) - (eq (car etype) 'VECTOR)) - (setq etype (second etype)))) - (setq etype - (type-and return-type - (type-and (info-type (cadr (first args))) - etype))) + (let (etype + (valtype (info-type (cadr (first args)))) + (elttype (info-type (cadr (second args))))) + (when (or (and (eq elttype 'STRING) + (setq elttype 'CHARACTER)) + (and (consp elttype) + (or (eq (car elttype) 'ARRAY) + (eq (car elttype) 'VECTOR)) + (setq elttype (second elttype)))) + (setq etype (type-and return-type (type-and valtype elttype))) (unless etype - (cmpwarn "Type mismatch was found in ~s." - (cons fname args)) + (cmpwarn "Type mismatch found in (SETF AREF). Expected output type ~s, array element type ~s, value type ~s." return-type elttype valtype) (setq etype T)) (setf return-type etype) (setf (info-type (cadr (first args))) etype)))))) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index a3e620be7..81cc6b5c5 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -10,23 +10,6 @@ ;;;; CMPDEF Definitions -(defpackage "FFI" - (:export clines - defcfun - defentry - defla - defcbody ; Beppe - definline ; Beppe - defunC ; Beppe - void - object - char* ; Beppe - ;;char - int - ;;float - double - )) - (defpackage "C" (:nicknames "COMPILER") (:use "FFI" "CL") @@ -49,7 +32,7 @@ ;;; Use structures of type vector to avoid creating ;;; normal structures before booting CLOS. -(defstruct (ref (:type vector)) +(defstruct (ref) name ;;; Identifier of reference. (ref 0 :type fixnum) ;;; Number of references. ref-ccb ;;; Cross closure reference. @@ -57,7 +40,7 @@ ;;; During Pass2, the index into the closure env ) -(defstruct (var (:type vector) (:include ref) :named) +(defstruct (var (:include ref)) ; name ;;; Variable name. ; (ref 0 :type fixnum) ;;; Number of references to the variable (-1 means IGNORE). @@ -118,7 +101,7 @@ ;;; (flet ((foo (z) (bar z))) #'(lambda () #'foo))) ;;; therefore we need field funob. -(defstruct (fun (:type vector) (:include ref) :named) +(defstruct (fun (:include ref)) ; name ;;; Function name. ; (ref 0 :type fixnum) ;;; Number of references. ; ref-ccb ;;; Cross closure reference. @@ -131,7 +114,7 @@ ) (deftype fun () '(satisifes fun-p)) -(defstruct (blk (:type vector) (:include ref) :named) +(defstruct (blk (:include ref)) ; name ;;; Block name. ; (ref 0 :type fixnum) ;;; Number of references. ; ref-ccb ;;; Cross closure reference. @@ -148,7 +131,7 @@ ) (deftype blk () '(satisfies blk-p)) -(defstruct (tag (:type vector) (:include ref) :named) +(defstruct (tag (:include ref)) ; name ;;; Tag name. ; (ref 0 :type fixnum) ;;; Number of references. ; ref-ccb ;;; Cross closure reference. @@ -161,7 +144,7 @@ ) (deftype tag () '(satisfies tag-p)) -(defstruct (info (:type vector) :named) +(defstruct (info) (changed-vars nil) ;;; List of var-objects changed by the form. (referred-vars nil) ;;; List of var-objects referred in the form. (type t) ;;; Type of the form. diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 191268b3e..2ad9dd587 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -70,7 +70,7 @@ (dolist (form forms) (cond ((endp arg-types) (push form fl)) (t (push (and-form-type (car arg-types) form (car args) - "In a call to ~a" fname) + :safe "In a call to ~a" fname) fl) (pop arg-types) (pop args)))) @@ -117,7 +117,7 @@ (setq forms (nreverse fl1))) (cond ((endp arg-types) (push (car fl) fl1)) (t (push (and-form-type (car arg-types) (car fl) (car al) - "In a call to ~a" fname) + :safe "In a call to ~a" fname) fl1) (pop arg-types)))))) (let ((arg-types (get fname 'ARG-TYPES))) @@ -126,7 +126,7 @@ (do ((fl forms (cdr fl)) (al args (cdr al))) ((or (endp arg-types) (endp fl))) - (and-form-type (car arg-types) (car fl) (car al) + (and-form-type (car arg-types) (car fl) (car al) :safe "In a call to ~a" fname) (pop arg-types)))) #| diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index fd78e00eb..904e00acf 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -111,7 +111,7 @@ (v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (setf (car specs) - (list v (and-form-type (var-type v) init (second spec) + (list v (and-form-type (var-type v) init (second spec) :safe "In (LAMBDA ~a...)" block-name) nil)) (push-vars v))) @@ -124,7 +124,7 @@ (push (car spec) vnames) (push (third spec) vnames) (setf (car specs) - (list v (and-form-type (var-type v) init (second spec) + (list v (and-form-type (var-type v) init (second spec) :safe "In (LAMBDA ~a...)" block-name) sv)) (push-vars v) @@ -155,7 +155,7 @@ (push (second spec) vnames) (setf (car specs) (list (car spec) v - (and-form-type (var-type v) init (third spec) + (and-form-type (var-type v) init (third spec) :safe "In (LAMBDA ~a...)" block-name) (make-var :kind 'DUMMY))) (push-vars v))) @@ -168,7 +168,7 @@ (push (fourth spec) vnames) (setf (car specs) (list (car spec) v - (and-form-type (var-type v) init (third spec) + (and-form-type (var-type v) init (third spec) :safe "In (LAMBDA ~a...)" block-name) sv)) (push-vars v) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index 1042e0eec..b1e33279c 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -38,7 +38,8 @@ (and-form-type (var-type v) (c1expr* (second x) info) (second x) - "In LET form")))) + :unsafe + "In LET bindings")))) ;; :read-only variable handling. Beppe ; (when (read-only-variable-p vname ts) ; (setf (var-type v) (info-type (second form)))) @@ -66,7 +67,7 @@ (setq var (first vars) form (first forms)) (setf (car forms) - (and-form-type (var-type var) form (var-name var) "In LET form")) + (and-form-type (var-type var) form (var-name var) :unsafe "In LET body")) (when (member (info-type (second (car forms))) '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT) :test #'eq) (incf (var-ref var))) ; force unboxing @@ -228,7 +229,8 @@ (and-form-type (var-type v) (c1expr* (second x) info) (second x) - "In LET* form")))) + :unsafe + "In LET* bindings")))) ;; :read-only variable handling. ; (when (read-only-variable-p (car x) ts) ; (setf (var-type v) (info-type (second form)))) @@ -251,7 +253,7 @@ ((null vs)) (setq var (car vs) form (and-form-type (var-type var) (car fs) (cadar args) - "~&;;; In LET* form.")) + :unsafe "~&;;; In LET* body")) ;; Automatic treatement for READ-ONLY variables: (let ((rest-forms (cons body (cdr fs)))) (unless (var-changed-in-forms var rest-forms) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index eccb43f09..836665e54 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -125,6 +125,12 @@ init_~A(cl_object foo) ~A }") +(defun init-function-name (s) + (setq s (string-upcase s)) + (if si::*init-function-prefix* + (concatenate 'string si::*init-function-prefix* "_" s) + s)) + (defun builder (target output-name &key lisp-files ld-flags (prologue-code "") (epilogue-code (if (eq target :program) " funcall(1,_intern(\"TOP-LEVEL\",system_package)); @@ -135,11 +141,11 @@ init_~A(cl_object foo) (dolist (item (reverse lisp-files)) (cond ((symbolp item) (push (format nil "-l~A" (string-downcase item)) ld-flags) - (push (string-upcase item) init-name)) + (push (init-function-name item) init-name)) (t (push (namestring (merge-pathnames ".o" item)) ld-flags) (setq item (pathname-name item)) - (push (string-upcase item) init-name)))) + (push (init-function-name item) init-name)))) (setq c-name (namestring (merge-pathnames ".c" output-name)) o-name (namestring (merge-pathnames ".o" output-name))) (ecase target diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index ce5e9f6aa..707592ccd 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -113,7 +113,7 @@ #+PDE (optimize-space (>= *space* 3))) (wt-nl1 "static const char *compiler_data_text;") (wt-nl1 "void") - (wt-nl1 "init_" name "(cl_object flag)") + (wt-nl1 "init_" (init-function-name name) "(cl_object flag)") (wt-nl1 "{ VT" *reservation-cmacro* " CLSR" *reservation-cmacro*) (wt-nl "cl_object value0;") (wt-nl "if (!FIXNUMP(flag)){") @@ -224,8 +224,8 @@ (defun t1defun (args &aux (setjmps *setjmps*)) (when (or (endp args) (endp (cdr args))) (too-few-args 'defun 2 (length args))) - (cmpck (not (symbolp (car args))) - "The function name ~s is not a symbol." (car args)) + (when (not (symbolp (car args))) + (return-from t1defun (t1expr* (macroexpand (cons 'defun args))))) (when *compile-time-too* (cmp-eval (cons 'DEFUN args))) (setq *non-package-operation* t) (let* (lambda-expr @@ -883,7 +883,7 @@ (setq narg (length cdar s)) (cond ((setq fd (assoc (caar s) *global-funs*)) (cond (*compiler-push-events* - (wt-nl1 "ihs_push(" (add-symbol (caar s)) ",&narg);") + (wt-nl1 "ihs_push(" (add-symbol (caar s)) ");") (wt-nl1 "L" (cdr fd) "();") (wt-nl1 "ihs_pop();")) (t (wt-nl1 "L" (cdr fd) "(" narg)))) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 4dd056889..4ddb270f4 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -64,7 +64,7 @@ ((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR) ((NIL T) t) ((SIMPLE-ARRAY ARRAY) - (cond ((endp type-args) '(ARRAY T)) ; Beppe + (cond ((endp type-args) '(ARRAY *)) ; Beppe ((eq '* (car type-args)) t) (t (let ((element-type (sys::type-for-array (car type-args)))) @@ -107,6 +107,7 @@ (t t)))))) ;;; The algebra of types should be more complete. Beppe +#+nil (defun type-and (type1 type2) (cond ((equal type1 type2) type1) ((eq type1 t) type2) @@ -195,15 +196,15 @@ ((LONG-FLOAT SHORT-FLOAT) (if (member type2 '(FIXNUM-FLOAT FLOAT)) type1 nil)) -;;; ((SIGNED-CHAR UNSIGNED-CHAR SIGNED-SHORT) -;;; (if (eq type2 'FIXNUM) type1 nil)) + ((BYTE8 INTEGER8 BIT) + (if (eq type2 'FIXNUM) type1 nil)) ;;; ((UNSIGNED-SHORT) ;;; (if (subtypep type1 type2) type1 nil)) (FIXNUM (case type2 ((bit FIXNUM-FLOAT) 'FIXNUM) -;;; ((SIGNED-CHAR UNSIGNED-CHAR SIGNED-SHORT BIT) -;;; type2) + ((BYTE8 INTEGER8 BIT) + type2) ;;; ((UNSIGNED-SHORT) ;;; (if (subtypep type2 type1) type2 nil)) )) @@ -214,9 +215,45 @@ (STRUCTURE-OBJECT (if (subtypep type2 'STRUCTURE-OBJECT) type2 nil)))))) +;;; The algebra of types should be more complete. Beppe +(defun type-and (type1 type2 &optional finish &aux out t2 args2) + (when (or (eq type1 type2) (eq type1 'OBJECT) (eq type1 '*)) + (return-from type-and type2)) + (when (or (eq type2 'OBJECT) (eq type2 '*)) + (return-from type-and type1)) + (when (subtypep type1 type2) + (return-from type-and type1)) + (when (subtypep type2 type1) + (return-from type-and type2)) + (multiple-value-setq (name2 args2) (sys::normalize-type type2)) + (case name2 + (VALUES (type-and type1 (car args2))) + (AND (loop for i in args2 + when (setq t2 (type-and type1 i)) + collect i into out + finally (return (and out (cons 'AND out))))) + (OR (loop for i in args2 + when (setq t2 (type-and type1 i)) + collect i into out + finally (return (and out (cons 'OR out))))) + (MEMBER (loop for i in args2 + when (setq t2 (typep i type1)) + collect i into out + finally (return (and out (cons 'MEMBER out))))) + (NOT (setq t2 (type-and type1 (car args2))) + (cond ((null t2) type1) + ((eq t2 type1) nil) + (t (list 'AND type1 type2)))) + (otherwise + (if finish nil (type-and type2 type1 t))))) + +#+nil (defun type>= (type1 type2) (equal (type-and type1 type2) type2)) +(defun type>= (type1 type2) + (subtypep type2 type1)) + (defun reset-info-type (info) (if (info-type info) (let ((info1 (copy-info info))) @@ -229,14 +266,15 @@ ;;; returns a copy of form whose type is the type-and of type and the form's ;;; type ;;; -(defun and-form-type (type form original-form &optional +(defun and-form-type (type form original-form &optional (mode :safe) (format-string "") &rest format-args) (let* ((type2 (info-type (cadr form))) (type1 (or (type-and type type2) (when (subtypep type2 type) type2)))) ; class types. Beppe (unless type1 - (cmperr "~?, the type of the form ~s is ~s, not ~s." format-string - format-args original-form type2 type)) + (funcall (if (eq mode :safe) #'cmperr #'cmpwarn) + "~?, the type of the form ~s is ~s, not ~s." format-string + format-args original-form type2 type)) (if (eq type1 type2) form (let ((info (copy-info (cadr form)))) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 3e2c440e9..9d8cd3445 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -100,8 +100,7 @@ (defun cmp-macroexpand (form &aux env (throw-flag t)) ;; Obtain the local macro environment for expansion. (dolist (v *funs*) - (when (consp v) - (push v env))) + (when (consp v) (push v env))) (when env (setq env (cons nil (nreverse env)))) (unwind-protect (prog1 @@ -115,28 +114,9 @@ ~%;;; You are recommended to compile again.~%" form))))) - -(defun cmp-macroexpand-1 (form &aux env (throw-flag t)) - (dolist (v *funs*) - (when (consp v) - (push (list (car v) 'MACRO (cadr v)) env))) - (when env (setq env (cons nil (nreverse env)))) - (unwind-protect - (prog1 - (cmp-toplevel-eval `(macroexpand-1 ',form ',env)) - (setq throw-flag nil)) - (when throw-flag - (let ((*print-case* :upcase)) - (print-current-form) - (format t - "~&;;; The macro form ~s was not expanded successfully.~ - ~%;;; You are recommended to compile again.~%" - form))))) - - (defun cmp-expand-macro (fd fname args &aux env (throw-flag t)) (dolist (v *funs*) - (if (consp v) (push (list (car v) 'MACRO (cadr v)) env))) + (when (consp v) (push v env))) (when env (setq env (cons nil (nreverse env)))) (unwind-protect (prog1 diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index a99648b79..4ab030593 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -871,7 +871,6 @@ type_of(#0)==t_bitvector")) :inline-always (nil t t nil "terpri(Cnil)")) (WRITE (T *) T) (WRITE-BYTE (fixnum stream) T) -(si::WRITE-BYTES (stream string fixnum fixnum) T) (WRITE-CHAR (T *) T NIL NIL :inline-always ((t) t t nil "@0;(princ_char(char_code(#0),Cnil),(#0))")) (WRITE-LINE (T *) T) @@ -880,7 +879,6 @@ type_of(#0)==t_bitvector")) (CLEAR-INPUT (*) T) (PARSE-INTEGER (T *)) (READ-BYTE (T *) T) -(si::READ-BYTES (stream string fixnum fixnum) T) (COPY-READTABLE (*) T NIL NIL :inline-always ((null null) t nil nil "standard_readtable")) (READTABLEP (T) T NIL T) @@ -1055,8 +1053,8 @@ type_of(#0)==t_bitvector")) :inline-always ((t) t nil t "TYPE_OF(#0)")) ;;; Beppe's additions -(READ-BYTES (stream string fixnum fixnum) T) -(WRITE-BYTES (stream string fixnum fixnum) T) +(READ-BYTES (stream vector fixnum fixnum) T) +(WRITE-BYTES (stream vector fixnum fixnum) T) ;;; AKCL additions: (SI::COPY-STREAM (T T) T) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index e652c5172..60e4fa8ef 100644 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -16,17 +16,6 @@ (si::pathname-translations "SYS" '(("*.*" "./*.*"))) (setq compiler::*cc-flags* (concatenate 'string compiler::*cc-flags* " -I@srcdir@/h -I@srcdir@/gmp -I@builddir@/h")) -;;; -;;; * Compile, load and link Common-Lisp to C compiler -;;; -#+WANTS-CMP -(progn -(load "cmp/defsys.lsp") -(proclaim '(optimize (safety 2) (space 3))) -(sbt::operate-on-system cmp #-dlopen :library #+dlopen :shared-library) -;(sbt::operate-on-system cmp :load) -) - ;;; ;;; * Compile, load and link PCL based Common-Lisp Object System ;;; @@ -38,6 +27,17 @@ ;(sbt::operate-on-system clos :load) ) +;;; +;;; * Compile, load and link Common-Lisp to C compiler +;;; +#+WANTS-CMP +(progn +(load "cmp/defsys.lsp") +(proclaim '(optimize (safety 2) (space 3))) +(sbt::operate-on-system cmp #-dlopen :library #+dlopen :shared-library) +;(sbt::operate-on-system cmp :load) +) + (compiler::build-ecls "ecls" :lisp-files '(#+(and (not dlopen) WANTS-CMP) cmp)) (quit) diff --git a/src/compile_rest.lsp.in b/src/compile_rest.lsp.in index fd7b7d82f..573b6f21d 100644 --- a/src/compile_rest.lsp.in +++ b/src/compile_rest.lsp.in @@ -1,38 +1,18 @@ ;;; ;;; Configuration file for the remaining libraires of ECLS ;;; -;;; -;;; * Learn where we come from and where we go to -;;; -(in-package "SYSTEM") -(si::pathname-translations "SYS" '(("*.*" "./*.*"))) -(setq compiler::*cc-flags* (concatenate 'string compiler::*cc-flags* " -I@srcdir@/h -I@srcdir@/gmp -I@builddir@/h")) - -;;; -;;; * Load system builder tool -;;; -(in-package "CL-USER") -(load "@srcdir@/util/system.lsp") - -;;; -;;; * We redefine this to force generation of source files -;;; in the object directory -- source files help debugging -;;; with GDB. -;;; -(defun sbt::sbt-compile-file (&rest s) - (apply #'compiler::compile-file - (car s) - :c-file t :h-file t :data-file t :system-p t - (cdr s))) +(load "bare.lsp") ;;; ;;; * Compile and link MIT CLX extensions ;;; +(setq si::*keep-documentation* nil) +(in-package "COMMON-LISP-USER") #+WANTS-CLX (progn (push :clx-ansi-common-lisp *features*) -(load "defsys.lsp") +(load "clx/defsys.lsp") (sbt::operate-on-system clx :library) -(compiler::build-ecls "eclx" :components '(#+WANTS-CMP cmp clx)) +(compiler::build-ecls "eclx" :lisp-files '(#+(and (not DLOPEN) WANTS-CMP) cmp clx)) ) - +(print "HOLA") \ No newline at end of file diff --git a/src/gabriel/test-help.lsp b/src/gabriel/test-help.lsp index 4591d1e45..60cb3f97b 100644 --- a/src/gabriel/test-help.lsp +++ b/src/gabriel/test-help.lsp @@ -73,9 +73,8 @@ (system::gc) #+ecls (system::gc t) - (let ((source-file (merge-pathnames (merge-pathnames file *source-dir*) - "foo.cl")) - (fasl-file (compile-file-pathname (merge-pathnames file *output-dir*))) + (let ((source-file (merge-pathnames (merge-pathnames file *source-dir*) "foo.cl")) + (fasl-file (and compile (compile-file-pathname (merge-pathnames file *output-dir*)))) (*package* (make-package "TESTING"))) (cond (compile (proclaim-file source-file) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index d1456caae..ab4956a05 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -123,8 +123,10 @@ enum { OP_VARS, OP_MCALL, OP_CALL, + OP_CALLG, OP_FCALL, OP_PCALL, + OP_PCALLG, OP_PFCALL, OP_CATCH, OP_EXIT, @@ -147,10 +149,11 @@ enum { OP_PBINDS, OP_PSETQ, OP_PSETQS, + OP_UNBIND, + OP_UNBINDS, OP_MBIND, OP_MSETQ, OP_PROGV, - OP_PUSHENV, OP_VALUES, OP_NTHVAL, OP_MPROG1, diff --git a/src/h/external.h b/src/h/external.h index 12a1baebd..1da109e77 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -191,6 +191,7 @@ extern cl_object eval(cl_object form, cl_object *bytecodes, cl_object env); /* interpreter.c */ +extern cl_object lex_env; extern cl_object lambda_apply(int narg, cl_object fun, cl_object *args); extern cl_object *interpret(cl_object *memory); @@ -372,16 +373,6 @@ extern void let_bindings(cl_object var_list, struct let *let); extern void init_let(void); -/* lex.c */ - -extern void lex_fun_bind(cl_object name, cl_object fun); -extern void lex_tag_bind(cl_object tag, cl_object id); -extern void lex_block_bind(cl_object name, cl_object id); -extern cl_object lex_sch(cl_object lex_list, cl_object name, cl_object type); -extern cl_object lex_symbol_macro_sch(cl_object name); -extern void init_lex(void); - - /* list.c */ extern cl_object list_length(cl_object x); diff --git a/src/h/lisp_external.h b/src/h/lisp_external.h index 8bf0350b7..5efbbd913 100644 --- a/src/h/lisp_external.h +++ b/src/h/lisp_external.h @@ -34,6 +34,7 @@ extern cl_object siLmangle_name _ARGS((int narg, cl_object symbol, ...)); /* array.c */ +extern cl_object clSbyte8, clSinteger8; extern cl_object clLaref _ARGS((int narg, cl_object x, ...)); extern cl_object siLaset _ARGS((int narg, cl_object v, cl_object x, ...)); extern cl_object clLrow_major_aref _ARGS((int narg, cl_object x, cl_object i)); @@ -56,6 +57,7 @@ extern cl_object siLreplace_array _ARGS((int narg, cl_object old, cl_object new) /* assignment.c */ extern cl_object clSsetf, clSpsetf, siSsetf_symbol; +extern cl_object siSsetf_lambda, siSsetf_method, siSsetf_update; extern cl_object siSclear_compiler_properties; #ifdef PDE extern cl_object siVrecord_source_pathname_p; @@ -158,6 +160,7 @@ extern cl_object siVkeep_definitions; extern cl_object siLprocess_declarations _ARGS((int narg, cl_object body, ...)); extern cl_object siLprocess_lambda_list _ARGS((int narg, cl_object lambda)); extern cl_object siLmake_lambda _ARGS((int narg, cl_object name, cl_object body)); +extern cl_object siLfunction_block_name _ARGS((int narg, cl_object name)); /* disassembler.c */ @@ -328,6 +331,9 @@ extern cl_object siLinterpreter_stack _ARGS((int narg)); /* lex.c */ +extern cl_object Kblock; +extern cl_object Ktag; +extern cl_object Kfunction; extern cl_object clSblock; extern cl_object clSmacro; extern cl_object siSsymbol_macro; @@ -427,6 +433,7 @@ extern cl_object clLrassoc_if_not _ARGS((int narg, cl_object pred, cl_object arg extern cl_object Kverbose; extern cl_object clVload_verbose, clVload_print; extern cl_object siVload_hooks; +extern cl_object siVinit_function_prefix; extern cl_object clLload _ARGS((int narg, cl_object pathname, ...)); extern cl_object siLload_source _ARGS((int narg, cl_object file, cl_object verbose, cl_object print)); @@ -554,6 +561,7 @@ extern cl_object clLlogandc1 _ARGS((int narg, cl_object x, cl_object y)); extern cl_object clLlogandc2 _ARGS((int narg, cl_object x, cl_object y)); extern cl_object clLlogorc1 _ARGS((int narg, cl_object x, cl_object y)); extern cl_object clLlogorc2 _ARGS((int narg, cl_object x, cl_object y)); +extern cl_object clLlognot _ARGS((int narg, cl_object x)); extern cl_object clLboole _ARGS((int narg, cl_object o, cl_object x, cl_object y)); extern cl_object clLlogbitp _ARGS((int narg, cl_object p, cl_object x)); extern cl_object clLash _ARGS((int narg, cl_object x, cl_object y)); diff --git a/src/h/object.h b/src/h/object.h index aa9c35f49..bcc7ebde8 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -212,10 +212,10 @@ typedef enum { /* array element type */ aet_bit, /* bit */ aet_fix, /* fixnum */ aet_sf, /* short-float */ - aet_lf /* long-float */ + aet_lf, /* long-float */ + aet_b8, /* byte8 */ + aet_i8, /* integer8 */ #if 0 - ,aet_char, /* signed char */ - aet_uchar, /* unsigned char */ aet_short, /* signed short */ aet_ushort /* unsigned short */ #endif @@ -223,8 +223,9 @@ typedef enum { /* array element type */ union array_data { cl_object *t; - unsigned char *ch; - signed char *sch; + char *ch; + u_int8_t *b8; + int8_t *i8; float *sf; double *lf; cl_fixnum *fix; diff --git a/src/h/stacks.h b/src/h/stacks.h index ee6c23c96..8ffbb18a0 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -74,7 +74,7 @@ extern bds_ptr bds_top; /* bind stack top */ cl_index ihs_top; -extern void ihs_push(cl_object fun, cl_object env); +extern void ihs_push(cl_object fun); extern cl_object ihs_top_function_name(); extern void ihs_pop(); @@ -229,8 +229,6 @@ where 'FUN' is the LISP symbol with pname FUN, etc. extern cl_object lex_env; #endif -#define lex_copy() lex_env = CONS(car(lex_env),cdr(lex_env)) -#define lex_new() lex_env = CONS(Cnil,Cnil) -#define lex_fun_sch(name) lex_sch(CDR(lex_env),(name),clSfunction) -#define lex_tag_sch(name) lex_sch(CDR(lex_env),(name),clStag) -#define lex_block_sch(name) lex_sch(CDR(lex_env),(name),clSblock) +#define lex_copy() (void)0 +#define lex_new() lex_env = Cnil + diff --git a/src/lsp/defpackage.lsp b/src/lsp/defpackage.lsp index ef97df77e..f7f9694d8 100644 --- a/src/lsp/defpackage.lsp +++ b/src/lsp/defpackage.lsp @@ -110,18 +110,21 @@ (when (consp arg2) (equal (car arg2) arg1))) (option-values-list (option options &aux output) (dolist (o options) - (let ((o-option (string (first o))) - (o-package (string (second o))) - (o-symbols (mapcar #'string (cddr o)))) + (let ((o-option (first o))) (when (string= o-option option) - (setf (cdr (assoc output o-package)) - (union o-symbols (cdr (assoc output o-package)) - :test #'equal))))) + (let* ((o-package (string (second o))) + (o-symbols (mapcar #'(lambda (x) + (if (numberp x) x (string x))) + (cddr o)))) + (setf (cdr (assoc output o-package)) + (union o-symbols (cdr (assoc output o-package)) + :test #'equal)))))) output) (option-values (option options &aux output) (dolist (o options) - (let ((o-option (string (first o))) - (o-symbols (mapcar #'string (cdr o)))) + (let ((o-option (first o)) + (o-symbols (mapcar #'(lambda (x) (if (numberp x) x (string x))) + (cdr o)))) (when (string= o-option option) (setq output (union o-symbols output :test #'equal))))) output)) diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 0d28371de..4b27e19da 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -40,6 +40,7 @@ (progn (remprop access-function 'SETF-UPDATE-FN) (remprop access-function 'SETF-LAMBDA) + (remprop access-function 'SETF-SYMBOL) (sys::set-documentation access-function 'SETF nil)) (progn ;; The following is used by the compiler to expand inline diff --git a/src/lsp/defsys.lsp.in b/src/lsp/defsys.lsp.in index 8844d4240..b55c57ee7 100644 --- a/src/lsp/defsys.lsp.in +++ b/src/lsp/defsys.lsp.in @@ -33,6 +33,7 @@ #-old-loop (loop2 () () ()) (defpackage () () ()) + (ffi () () ()) #-runtime (describe () () ()) (top () () ()) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 86491b63d..d127a8dca 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -150,7 +150,8 @@ terminated by a non-local exit." (multiple-value-bind (decl body doc) (si::process-declarations lambda-body) (when decl (setq decl (list (cons 'declare decl)))) - `(lambda ,lambda-list ,@doc ,@decl (block ,name ,@body)))) + `(lambda ,lambda-list ,@doc ,@decl + (block ,(si::function-block-name name) ,@body)))) ; assignment diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp new file mode 100644 index 000000000..d2d8a99a9 --- /dev/null +++ b/src/lsp/ffi.lsp @@ -0,0 +1,58 @@ +;;;; Copyright (c) 2001, Juan Jose Garcia-Ripoll +;;;; +;;;; This program 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. + +;;;; FFI Symbols used in the foreign function interface + +(defpackage "FFI" + (:export clines + defcfun + defentry + defla + defcbody ; Beppe + definline ; Beppe + defunC ; Beppe + void + object + char* ; Beppe + ;;char + int + ;;float + double + )) + +(in-package "FFI") + +(defmacro clines (&whole all) + (error "The FFI special form ~S cannot be used in the interpreter." + (car all))) + +(defmacro defcfun (&whole all) + (error "The FFI special form ~S cannot be used in the interpreter." + (car all))) + +(defmacro defentry (&whole all) + (error "The FFI special form ~S cannot be used in the interpreter." + (car all))) + +(defmacro defla (&whole all) + (error "The FFI special form ~S cannot be used in the interpreter." + (car all))) + +(defmacro defcbody (&whole all) + (error "The FFI special form ~S cannot be used in the interpreter." + (car all))) + +(defmacro definline (&whole all) + (error "The FFI special form ~S cannot be used in the interpreter." + (car all))) + +(defmacro defunC (&whole all) + (error "The FFI special form ~S cannot be used in the interpreter." + (car all))) + diff --git a/src/lsp/load.lsp.in b/src/lsp/load.lsp.in index e6361e198..9c23faf66 100644 --- a/src/lsp/load.lsp.in +++ b/src/lsp/load.lsp.in @@ -25,6 +25,7 @@ #-old-loop (load "@srcdir@/loop2.lsp") (load "@srcdir@/defpackage.lsp") +(load "@srcdir@/ffi.lsp") #+threads (load "@srcdir@/threads.lsp") #+tk diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 90cbda478..df3e9b9c7 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -52,7 +52,10 @@ by (documentation 'NAME 'type)." "A FIXNUM is an integer between MOST-NEGATIVE-FIXNUM (= - 2^29 in ECL) and MOST-POSITIVE-FIXNUM (= 2^29 - 1 in ECL) inclusive. Other integers are bignums." - `(INTEGER ,most-negative-fixnum ,most-positive-fixnum)) + `(INTEGER #.most-negative-fixnum #.most-positive-fixnum)) + +(deftype byte8 () `(INTEGER 0 255)) +(deftype integer8 () `(INTEGER -128 127)) (deftype real (&rest foo) '(OR RATIONAL FLOAT)) (deftype bit () @@ -118,7 +121,7 @@ called simple-strings." (deftype base-string (&optional size) (if size `(array base-char ,size) '(array base-char (*)))) (deftype bit-vector (&optional size) - (if size `(array bit ,size) '(array bit (*)))) + (if size `(array bit (,size)) '(array bit (*)))) (deftype simple-vector (&optional size) "A simple-vector is a vector that is not displaced to another array, has no @@ -175,7 +178,7 @@ has no fill-pointer, and is not adjustable." (case element-type ((t nil) t) ((base-char standard-char extended-char character) 'base-char) - (t (dolist (v '(BIT BASE-CHAR + (t (dolist (v '(BIT BASE-CHAR BYTE8 INTEGER8 (SIGNED-BYTE 32) (UNSIGNED-BYTE 32) SHORT-FLOAT LONG-FLOAT) T) (when (subtypep element-type v) @@ -347,10 +350,9 @@ Returns T if X belongs to TYPE; NIL otherwise." Returns T if TYPE1 is a subtype of TYPE2; NIL otherwise. If this is not determined, then returns NIL as the first and second values. Otherwise, the second value is T." - (multiple-value-setq (t1 i1) (normalize-type type1)) - (multiple-value-setq (t2 i2) (normalize-type type2)) - (when (and (equal t1 t2) (equal i1 i2)) + (when (equal type1 type2) (return-from subtypep (values t t))) + (multiple-value-setq (t1 i1) (normalize-type type1)) (case t1 (MEMBER (dolist (e i1) (unless (typep e type2) (return-from subtypep (values nil t)))) @@ -365,6 +367,9 @@ second value is T." (return-from subtypep (values nil nil))) (NOT (multiple-value-bind (tv flag) (subtypep (car i1) type2) (return-from subtypep (values (and flag (not tv)) flag))))) + (multiple-value-setq (t2 i2) (normalize-type type2)) + (when (and (equal t1 t2) (equal i1 i2)) + (return-from subtypep (values t t))) (case t2 (MEMBER (return-from subtypep (values nil nil))) (OR (dolist (tt i2) diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index fdb6c8d3d..ac37952d9 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -34,6 +34,7 @@ by (documentation 'SYMBOL 'setf)." (sys:putprop ',access-fn ',(car rest) 'SETF-UPDATE-FN) (remprop ',access-fn 'SETF-LAMBDA) (remprop ',access-fn 'SETF-METHOD) + (remprop ',access-fn 'SETF-SYMBOL) ,@(si::expand-set-documentation access-fn 'setf (cadr rest)) ',access-fn)) (t @@ -44,6 +45,7 @@ by (documentation 'SYMBOL 'setf)." (sys:putprop ',access-fn #',rest 'SETF-LAMBDA) (remprop ',access-fn 'SETF-UPDATE-FN) (remprop ',access-fn 'SETF-METHOD) + (remprop ',access-fn 'SETF-SYMBOL) ,@(si::expand-set-documentation access-fn 'setf (find-documentation (cddr rest))) ',access-fn)))) @@ -83,6 +85,7 @@ by (DOCUMENTATION 'SYMBOL 'SETF)." (sys:putprop ',access-fn #'(lambda ,args ,@body) 'SETF-METHOD) (remprop ',access-fn 'SETF-LAMBDA) (remprop ',access-fn 'SETF-UPDATE-FN) + (remprop ',access-fn 'SETF-SYMBOL) ,@(si::expand-set-documentation access-fn 'setf (find-documentation body)) ',access-fn)) @@ -147,11 +150,7 @@ Does not check if the third gang is a single-element list." (cons (car form) vars)))) ((macro-function (car form)) (get-setf-method-multiple-value (macroexpand form))) - #+clos - ((special-form-p (car form)) - (error "Cannot expand the SETF form ~S." form)) - #+clos - ((get (car form) 'SETF-SYMBOL) + (t (let ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) @@ -159,10 +158,8 @@ Does not check if the third gang is a single-element list." (store (gensym))) (values vars (cdr form) (list store) ;; use the symbol here, otherwise the CLOS walker punts. - `(funcall #',(get (car form) 'SETF-SYMBOL) ,store ,@vars) - (cons (car form) vars)))) - (t - (error "Cannot expand the SETF form ~S." form)))) + `(,(si::setf-namep (list 'SETF (car form))) ,store ,@vars) + (cons (car form) vars)))))) ;;;; SETF definitions. @@ -390,7 +387,6 @@ Each PLACE may be any one of the following: ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env)) (t (cons 'progn (setf-expand rest env))))) - ;;; PSETF macro. (defmacro psetf (&environment env &rest rest) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 5c1e388a1..e3a9ec7bb 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -630,23 +630,22 @@ file. When the saved image is invoked, it will start the redefined top-level." (*print-length* 4) (*print-pretty* t) (fun (ihs-fun *ihs-current*)) + (functions) (blocks) (variables) name args) - (format t - "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" - (mapcan #'(lambda (x) (and (eq (second x) 'FUNCTION) (list (car x)))) - (cdr *break-env*))) - (format t - "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" - (mapcan #'(lambda (x) (and (eq (second x) 'BLOCK) (list (car x)))) - (cdr *break-env*))) - (format t - "~:[~;Tags: ~:*~{~s~^, ~}.~%~]" - (mapcan #'(lambda (x) (when (eq (second x) 'TAG) (list (car x)))) - (cdr *break-env*))) - (format t - "Local variables:~:[ ~:[none~;~:*~{~s~1*~:@{, ~s~1*~}~}~]~;~ - ~:[ none~;~:*~{~% ~s: ~s~}~]~]~%" - (not no-values) (car *break-env*))) + (do* ((env *break-env* (cddr env)) + (type (first env) (first env)) + (data (second env) (second env))) + ((endp env)) + (case type + (:function (push (car data) functions)) + (:block (push (car data) blocks)) + (:tag) + (otherwise (setq variables (list* type data variables))))) + (format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions) + (format t "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" blocks) + (format t "Local variables: ~:[~:[none~;~:*~{~s~1*~:@{, ~s~1*~}~}~]~;~ + ~:[none~;~:*~{~% ~s: ~s~}~]~]~%" + (not no-values) variables) (values))) (defun tpl-bds-command (&optional var) diff --git a/src/tests/hashlong.tst b/src/tests/hashlong.tst index 8cef25ee4..0719baec9 100644 --- a/src/tests/hashlong.tst +++ b/src/tests/hashlong.tst @@ -30,7 +30,7 @@ (PRINT (HASH-TABLE-COUNT HASH-TABLE)) (PRINT "hval:") (PRINT HVAL) (PRINT "lval:") (PRINT LVAL) - (return-from symbols 'error)) + (return-from symbole 'error)) (REMHASH (CAR LISTE) HASH-TABLE) #+XCL (WHEN (< (ROOM) 30000.) (SYSTEM::%GARBAGE-COLLECTION)) (SETF-GETHASH X HASH-TABLE (SETQ B (+ 1. B))) diff --git a/src/tests/steele7.tst b/src/tests/steele7.tst index fc5623514..06e75f038 100644 --- a/src/tests/steele7.tst +++ b/src/tests/steele7.tst @@ -364,7 +364,7 @@ nil tag0 (setf a 1) )a) -1 +#-ecls 1 #+ecls error diff --git a/src/util/emacs.el b/src/util/emacs.el index c5235e274..5c085fa5b 100644 --- a/src/util/emacs.el +++ b/src/util/emacs.el @@ -208,7 +208,6 @@ "c/time.d" "c/alloc_2.d" "c/dosdummy.d" -"c/lex.d" "c/package.d" "c/tkMain.d" "c/apply.d" @@ -224,7 +223,7 @@ "c/earith.d" "c/lwp.d" "c/print.d" -"c/unify.d" +;"c/unify.d" "c/backq.d" "c/error.d" "c/macros.d" @@ -325,7 +324,37 @@ "cmp/cmputil.lsp" "cmp/cmpvar.lsp" "cmp/cmpwt.lsp" -"cmp/sysfun.lsp"))) +"cmp/sysfun.lsp" +; "clx/attributes.lsp" +; "clx/buffer.lsp" +; "clx/bufmac.lsp" +; "clx/clx.lsp" +; "clx/clxmain.lsp" +; "clx/cmpinit.lsp" +; "clx/defsystem.lsp" +; "clx/depdefs.lsp" +; "clx/dependent.lsp" +; "clx/display.lsp" +; "clx/doc.lsp" +; "clx/ecldep.lsp" +; "clx/ecllock.lsp" +; "clx/fonts.lsp" +; "clx/gcontext.lsp" +; "clx/graphics.lsp" +; "clx/image.lsp" +; "clx/init.lsp" +; "clx/input.lsp" +; "clx/keysyms.lsp" +; "clx/macros.lsp" +; "clx/manager.lsp" +; "clx/package.lsp" +; "clx/provide.lsp" +; "clx/requests.lsp" +; "clx/resource.lsp" +; "clx/sockcl.lsp" +; "clx/text.lsp" +; "clx/translate.lsp" +))) (mapcar 'find-file ecl-files) diff --git a/src/util/gdbinit b/src/util/gdbinit index b28d57b9b..22254aaa0 100644 --- a/src/util/gdbinit +++ b/src/util/gdbinit @@ -12,4 +12,5 @@ break FEwrong_type_argument break FEinvalid_function break FEcondition break error -set confirm off \ No newline at end of file +set confirm off +handle SIGBUS nostop diff --git a/src/util/system.lsp b/src/util/system.lsp index de95784d6..0fa80f996 100644 --- a/src/util/system.lsp +++ b/src/util/system.lsp @@ -172,7 +172,9 @@ (defun sbt-compile-file (&rest a) (apply #'compiler::compile-file a)) -(defun operate-on-system (system mode &optional arg print-only) +(defun operate-on-system (system mode &optional arg print-only + &aux (si::*init-function-prefix* + (string-upcase (system-name system)))) (let (transformations) (flet ((load-module (m s) (let ((name (module-name m))) @@ -206,7 +208,6 @@ (setq transformations (ecase mode ((:LIBRARY :SHARED-LIBRARY) - (operate-on-system system :COMPILE) (let* ((transforms (make-transformations system #'true #'make-load-transformation)) @@ -215,7 +216,7 @@ transforms))) (shared (eq mode :shared-library)) (library (make-library-pathname system shared))) - (print (cons library objects)) + (operate-on-system system :COMPILE) (funcall (if shared #'c::build-shared-library #'c::build-static-library) library :lisp-files objects))