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))