mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-18 15:22:03 -08:00
Code Issues Projects Releases Packages Wiki Activity

+The compiler produced wrong code for RETURN-FROM forms inside an UNWIND-PROTECT.

Browse source 
+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).
This commit is contained in:
jjgarcia 2001-11-17 11:02:12 +00:00
parent 9f28615d7d
commit 9b4bd625f4
56 changed files with 880 additions and 591 deletions
Download patch file Download diff file Expand all files Collapse all files

24
src/CHANGELOG
View file

@ -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:
=====

4
src/Makefile.in
View file

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

2
src/ansi-tests/Makefile.in
View file

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

2
src/c/Makefile.in
View file

@ -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\

6
src/c/all_functions.d
View file

@ -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},

5
src/c/all_keywords.d
View file

@ -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"},

10
src/c/all_symbols.d
View file

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

2
src/c/alloc_2.d
View file

@ -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 */

61
src/c/array.d
View file

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

57
src/c/assignment.d
View file

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

257
src/c/compiler.d
View file

@ -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;

33
src/c/disassembler.d
View file

@ -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; i<ntags; i++, vector++) {
@terpri(0);
printf("\tTAG\t'");
@prin1(1, vector[0]);
printf(" @@ %d", simple_label(vector+1));
vector+=2;
printf("\tTAG\t%d",i);
printf(" @@ %d", simple_label(vector));
}
vector = disassemble(vector);
printf("\t\t\t; tagbody");
@ -391,6 +376,12 @@ disassemble(cl_object *vector) {
n = get_oparg(s);
s = next_code(vector);
goto OPARG_ARG;
case OP_CALLG: string = "FCALL";
n = get_oparg(s);
goto OPARG;
case OP_PCALLG: string = "PFCALL";
n = get_oparg(s);
goto OPARG;
case OP_FCALL: string = "FCALL";
n = get_oparg(s);
goto OPARG;
@ -437,6 +428,8 @@ disassemble(cl_object *vector) {
s = next_code(vector);
n = packed_label(vector-2);
goto OPARG_ARG;
case OP_UNBIND: string = "UNBIND"; n = get_oparg(s); goto OPARG;
case OP_UNBINDS: string = "UNBINDS"; n = get_oparg(s); goto OPARG;
case OP_BIND: string = "BIND"; goto QUOTE;
case OP_BINDS: string = "BINDS"; goto QUOTE;
case OP_PBIND: string = "PBIND"; goto QUOTE;
@ -455,8 +448,6 @@ disassemble(cl_object *vector) {
break;
case OP_PROGV: vector = disassemble_progv(vector);
break;
case OP_PUSHENV: vector = disassemble_pushenv(vector);
break;
case OP_VALUES: string = "VALUES";
n = get_oparg(s);
goto OPARG;

6
src/c/gbc.d
View file

@ -228,6 +228,12 @@ BEGIN:
case aet_lf:
j = x->array.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");
}

4
src/c/init.d
View file

@ -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();
}

327
src/c/interpreter.d
View file

@ -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; i++, aux+=2)
lex_tag_bind(*aux, id);
bind_tagbody(id);
/* 3) Wait here for gotos */
if (frs_push(FRS_CATCH, id) != 0) {
for (aux = vector, i=0; i<ntags; i++, aux+=2)
if (eql(aux[0], nlj_tag)) {
aux++;
break;
}
if (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; i<nfun; i++) {
cl_object f = next_code(vector);
lex_fun_bind(f->bytecodes.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); i<nfun; i++) {
cl_object f = CADDAR(l);
CADDAR(l) = close_around(f, lex);
l = CDR(l);
/* 2) Update the closures so that all functions can call each other */
for (i=0, l=lex_env; i<nfun; i++) {
cl_object record = CADR(l);
CDR(record) = close_around(CDR(record), lex_env);
l = CDDR(l);
}
vector = interpret(vector);
/* 4) Restore environment */
CDR(lex_env) = cl_stack_pop();
return vector;
}
@ -721,7 +706,7 @@ static cl_object *
interpret_mcall(cl_object *vector) {
cl_index sp = cl_stack_index();
vector = interpret(vector);
VALUES(0) = interpret_call(cl_stack_index()-sp, VALUES(0));
VALUES(0) = interpret_funcall(cl_stack_index()-sp, VALUES(0));
return vector;
}
@ -768,7 +753,7 @@ interpret_progv(cl_object *vector) {
/* 1) Save current environment */
bds_ptr old_bds_top = bds_top;
cl_stack_push(CAR(lex_env));
cl_stack_push(lex_env);
/* 2) Add new bindings */
while (!endp(vars)) {
@ -783,22 +768,7 @@ interpret_progv(cl_object *vector) {
vector = interpret(vector);
/* 3) Restore environment */
CAR(lex_env) = cl_stack_pop();
bds_unwind(old_bds_top);
return vector;
}
static cl_object *
interpret_pushenv(cl_object *vector) {
/* 1) Save environment */
bds_ptr old_bds_top = bds_top;
cl_stack_push(CAR(lex_env));
/* 2) Execute */
vector = interpret(vector);
/* 3) Restore environment */
CAR(lex_env) = cl_stack_pop();
lex_env = cl_stack_pop();
bds_unwind(old_bds_top);
return vector;
}
@ -825,13 +795,13 @@ interpret(cl_object *vector) {
cl_stack_push(VALUES(0));
break;
case OP_PUSHV:
cl_stack_push(search_local(next_code(vector)));
cl_stack_push(search_local(next_code(vector), get_oparg(s)));
break;
case OP_PUSHVS:
cl_stack_push(search_global(next_code(vector)));
break;
case OP_VAR:
VALUES(0) = search_local(next_code(vector));
VALUES(0) = search_local(next_code(vector), get_oparg(s));
NValues = 1;
break;
case OP_VARS:
@ -871,12 +841,29 @@ interpret(cl_object *vector) {
cl_stack_push(VALUES(0));
break;
}
case OP_CALLG: {
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);
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;

65
src/c/lex.d
View file

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

23
src/c/load.d
View file

@ -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
}

5
src/c/macros.d
View file

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

2
src/c/num_log.d
View file

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

2
src/c/package.d
View file

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

10
src/c/reference.d
View file

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

23
src/c/sequence.d
View file

@ -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");
}

32
src/c/stacks.d
View file

@ -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 *************************/

2
src/cmp/cmpblock.lsp
View file

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

52
src/cmp/cmpcall.lsp
View file

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

29
src/cmp/cmpdefs.lsp
View file

@ -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.

6
src/cmp/cmpeval.lsp
View file

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

8
src/cmp/cmplam.lsp
View file

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

10
src/cmp/cmplet.lsp
View file

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

10
src/cmp/cmpmain.lsp
View file

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

8
src/cmp/cmptop.lsp
View file

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

54
src/cmp/cmptype.lsp
View file

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

24
src/cmp/cmputil.lsp
View file

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

6
src/cmp/sysfun.lsp
View file

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

22
src/compile.lsp.in
View file

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

32
src/compile_rest.lsp.in
View file

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

5
src/gabriel/test-help.lsp
View file

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

5
src/h/bytecodes.h
View file

@ -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,

11
src/h/external.h
View file

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

8
src/h/lisp_external.h
View file

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

11
src/h/object.h
View file

@ -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;

10
src/h/stacks.h
View file

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

19
src/lsp/defpackage.lsp
View file

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

1
src/lsp/defstruct.lsp
View file

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

1
src/lsp/defsys.lsp.in
View file

@ -33,6 +33,7 @@
#-old-loop
(loop2 () () ())
(defpackage () () ())
(ffi () () ())
#-runtime
(describe () () ())
(top () () ())

3
src/lsp/evalmacros.lsp
View file

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

58
src/lsp/ffi.lsp Normal file
View file

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

1
src/lsp/load.lsp.in
View file

@ -25,6 +25,7 @@
#-old-loop
(load "@srcdir@/loop2.lsp")
(load "@srcdir@/defpackage.lsp")
(load "@srcdir@/ffi.lsp")
#+threads
(load "@srcdir@/threads.lsp")
#+tk

17
src/lsp/predlib.lsp
View file

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

16
src/lsp/setf.lsp
View file

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

31
src/lsp/top.lsp
View file

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

2
src/tests/hashlong.tst
View file

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

2
src/tests/steele7.tst
View file

@ -364,7 +364,7 @@ nil
tag0
(setf a 1)
)a)
1
#-ecls 1 #+ecls error

35
src/util/emacs.el
View file

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

3
src/util/gdbinit
View file

@ -12,4 +12,5 @@ break FEwrong_type_argument
break FEinvalid_function
break FEcondition
break error
set confirm off
set confirm off
handle SIGBUS nostop

7
src/util/system.lsp
View file

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