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

Various minor fixes, and an important set of changes to teach the compiler

Browse source 
and the interpreter to understand (SETF fname) function names, and to handle
them without creating auxiliary symbols.
This commit is contained in:
jjgarcia 2003-04-28 15:55:22 +00:00
parent 057ff71e6a
commit c2aa136143
51 changed files with 1334 additions and 1194 deletions
Download patch file Download diff file Expand all files Collapse all files

59
src/CHANGELOG
View file

@ -1222,6 +1222,21 @@ ECLS 0.9
- Wrong type information about NAME-CHAR, CHAR-NAME and DIGIT-CHAR
lead to compilation errors.
- DEFPACKAGE would ignore the value of :INTERN and, would replace
empty :USE statements with (:USE "CL").
- :CONC-NAME alone is not interpreted as a lack of prefix in
structures. Furthermore, when no prefix is given, the package of
the slot name is not honored.
- MAP-INTO did not recognize strings and bit-vectors as vectors.
- In WITH-PACKAGE-ITERATOR, only symbols which are accessible in the
current package should be output, and the accesibility type returned
should correspond to that of FIND-SYMBOL.
- The expansion of DO/DO* would not enclose the body in a TAGBODY.
* Errors of the interpreter:
- CASE should use EQL to compare objects, not EQ.
@ -1240,6 +1255,12 @@ ECLS 0.9
- Excesive arguments to NOT or NULL were not detected.
- Under some circumstances, FUNCALL would not signal an error when
a symbol naming a macro is passed as a first argument.
- When &ALLOW-OTHER-KEYS was present in the lambda list, any
occurrence of :ALLOW-OTHER-KEYS is ignored.
* Visible changes:
- No "Bye" message in QUIT.
@ -1267,6 +1288,10 @@ ECLS 0.9
- Functions remf(), remprop() and putprop() removed. Use si_rem_f,
cl_remprop and cl_putprop instead.
- A small optimization allows the compiler to produce smaller code
when two functions share the same keywords (Like FIND, POSITION,
etc).
* ANSI compatibility:
- WITH-HASH-TABLE-ITERATOR implemented.
@ -1350,6 +1375,40 @@ ECLS 0.9
- SLOT-UNBOUND now effectively signals an UNBOUND-SLOT condition.
- In structure constructors, lambda variables should not have the
name of slot names. This avoids problems with slots that whose
name is also a special variable or a constant.
- MAKE-SEQUENCE, CONCATENATE, etc (All sequence functions), now
recognize more sequence types and also signal errors when the type
denotes a length and the sequence does not match it.
- COERCE recognizes more types, and also signals an error in most
cases in which the output does not match the required type (For
instance, (COERCE 1 '(INTEGER 2 3)).
- Implemented ARRAY-DISPLACEMENT.
- BOA-constructors for structures should now work as expected (Among
other things, they now support &KEY arguments).
- DELETE and REMOVE now accept negative values of :COUNT.
- SHADOW should work with strings/lists of strings, instead of only
with symbols.
- STRUCTURE-OBJECT is now a STRUCTURE-CLASS.
- DELETE-PACKAGE and MAKE-PACKAGE now signal the right type of errors.
- When a handler refuses to process a condition, the remaining
handlers are processed.
- Both the compiler and the interpreter now properly handle function
names of the form (SETF fname). Instead of creating an uninterened
a symbol with the name "SETF fname", the function definition is
stored directly as a property list.
TODO:
=====

4
src/c/Makefile.in
View file

@ -73,8 +73,8 @@ $(DPP): $(srcdir)/dpp.c symbols_list2.h
$(TRUE_CC) @CFLAGS@ -I../h -I./ -I$(HDIR) $(DEFS) $(srcdir)/dpp.c -o $@
symbols_list2.h: $(srcdir)/symbols_list.h Makefile
cat $(srcdir)/symbols_list.h | \
sed -e 's%{"\(.*\)",.*,[ ]*NULL,.*}%{"\1",NULL}%g' \
-e 's%{"\(.*\)",.*,[ ]*\(.*\),.*}%{"\1","\2"}%g' \
sed -e 's%{\([A-Z ]*.*".*"\),.*,[ ]*NULL,.*}%{\1,NULL}%g' \
-e 's%{\([A-Z ]*.*".*"\),.*,[ ]*\(.*\),.*}%{\1,"\2"}%g' \
-e 's%{NULL.*%{NULL,NULL}};%' > $@
#

4
src/c/all_symbols.d
View file

@ -140,8 +140,8 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
}
switch (code & 12) {
case 0: package = lisp_package; break;
case 4: package = system_package; name = name + 4; break;
case 8: package = keyword_package; name = name + 1; break;
case 4: package = system_package; break;
case 8: package = keyword_package; break;
}
s->symbol.t = t_symbol;
s->symbol.mflag = FALSE;

64
src/c/array.d
View file

@ -318,11 +318,9 @@ si_make_vector(cl_object etype, cl_object dim, cl_object adj,
f = d;
if (aet == aet_ch) {
x = cl_alloc_object(t_string);
d++; /* extra for null terminator */
}
else if (aet == aet_bit)
} else if (aet == aet_bit) {
x = cl_alloc_object(t_bitvector);
else {
} else {
x = cl_alloc_object(t_vector);
x->vector.elttype = (short)aet;
}
@ -368,10 +366,10 @@ array_allocself(cl_object x)
}
case aet_ch: {
char *elts;
elts = (char *)cl_alloc_atomic(d);
elts = (char *)cl_alloc_atomic(d+1);
for (i = 0; i < d; i++)
elts[i] = ' ';
if (type_of(x) == t_string) elts[d-1] = '\0';
elts[d] = '\0';
x->string.self = elts;
break;
}
@ -502,7 +500,7 @@ cl_array_element_type(cl_object a)
The field is a cons; the car of the from-array points to
the to-array and the cdr of the to-array is a list of arrays
displaced to the to-array, so the from-array is pushed to the
cdr of the to-array's a_displaced.
cdr of the to-array's array.displaced.
*/
static void
displace(cl_object from, cl_object to, cl_object offset)
@ -621,10 +619,6 @@ cl_array_dimension(cl_object a, cl_object index)
dim = a->array.dims[i];
break;
case t_string:
if (i != 0)
goto ILLEGAL;
dim = a->string.fillp;
break;
case t_vector:
case t_bitvector:
if (i != 0)
@ -656,10 +650,45 @@ cl_adjustable_array_p(cl_object a)
Internal function for checking if an array is displaced.
*/
cl_object
si_displaced_array_p(cl_object a)
cl_array_displacement(cl_object a)
{
cl_object to_array;
cl_index offset;
assert_type_array(a);
@(return ((CAR(a->array.displaced) != Cnil) ? Ct : Cnil))
to_array = a->array.displaced;
if (Null(to_array))
offset = 0;
else {
to_array = CAR(a->array.displaced);
switch (array_elttype(a)) {
case aet_object:
offset = a->array.self.t - to_array->array.self.t;
break;
case aet_ch:
offset = a->array.self.ch - to_array->array.self.ch;
break;
case aet_bit:
offset = a->array.self.bit - to_array->array.self.bit;
offset = offset * CHAR_BIT + a->array.offset;
break;
case aet_fix:
offset = a->array.self.fix - to_array->array.self.fix;
break;
case aet_sf:
offset = a->array.self.sf - to_array->array.self.sf;
break;
case aet_lf:
offset = a->array.self.lf - to_array->array.self.lf;
break;
case aet_b8:
case aet_i8:
default:
offset = a->array.self.b8 - to_array->array.self.b8;
break;
}
}
@(return to_array MAKE_FIXNUM(offset));
}
cl_object
@ -716,10 +745,11 @@ cl_array_has_fill_pointer_p(cl_object a)
cl_object
cl_fill_pointer(cl_object a)
{
assert_type_vector(a);
if (a->vector.hasfillp)
@(return MAKE_FIXNUM(a->vector.fillp))
FEerror("The vector ~S has no fill pointer.", 1, a);
assert_type_vector(a);
if (!a->vector.hasfillp)
FEwrong_type_argument(c_string_to_object("(AND VECTOR (SATISFIES ARRAY-HAS-FILL-POINTER-P))"),
a);
@(return MAKE_FIXNUM(a->vector.fillp))
}
/*

133
src/c/assignment.d
View file

@ -27,83 +27,36 @@ cl_set(cl_object var, cl_object val)
return1(SYM_VAL(var) = val);
}
cl_object
setf_namep(cl_object fun_spec)
{ cl_object cdr;
int intern_flag;
if (CONSP(fun_spec) && !endp(cdr = CDR(fun_spec)) &&
endp(CDR(cdr)) && CAR(fun_spec) == @'setf') {
cl_object sym, fn_name = CAR(cdr);
sym = si_get_sysprop(fn_name, @'si::setf-symbol');
if (sym == Cnil) {
cl_object fn_str = fn_name->symbol.name;
cl_index l = fn_str->string.fillp + 7;
cl_object string = cl_alloc_simple_string(l);
char *str = string->string.self;
strncpy(str, "(SETF ", 6);
strncpy(str + 6, fn_str->string.self, fn_str->string.fillp);
str[l-1] = ')';
if (fn_name->symbol.hpack == Cnil)
sym = make_symbol(string);
else
sym = intern(string, fn_name->symbol.hpack, &intern_flag);
si_put_sysprop(fn_name, @'si::setf-symbol', sym);
}
return(sym);
} else {
return(OBJNULL);
}
}
cl_object
si_setf_namep(cl_object arg)
{
cl_object x;
x = setf_namep(arg);
@(return ((x != OBJNULL) ? x : Cnil))
}
@(defun si::fset (fun def &optional macro pprint)
@(defun si::fset (fname def &optional macro pprint)
cl_object sym = si_function_block_name(fname);
cl_type t;
bool mflag;
@
mflag = !Null(macro);
if (!SYMBOLP(fun)) {
cl_object sym = setf_namep(fun);
if (sym == OBJNULL)
FEtype_error_symbol(fun);
if (mflag)
FEerror("Cannot define a macro with name (SETF ~S).", 1, fun);
fun = CADR(fun);
si_put_sysprop(fun, @'si::setf-symbol', sym);
si_rem_sysprop(fun, @'si::setf-lambda');
si_rem_sysprop(fun, @'si::setf-method');
si_rem_sysprop(fun, @'si::setf-update');
fun = sym;
}
if (fun->symbol.isform && !mflag)
FEerror("~S, a special form, cannot be redefined as a function.",
1, fun);
clear_compiler_properties(fun);
if (fun->symbol.hpack &&
fun->symbol.hpack->pack.locked &&
SYM_FUN(fun) != OBJNULL)
funcall(3, @'warn', make_simple_string("~S is being redefined."), fun);
t = type_of(def);
if (t == t_bytecodes || t == t_cfun || t == t_cclosure) {
SYM_FUN(fun) = def;
#ifdef CLOS
} else if (t == t_gfun) {
SYM_FUN(fun) = def;
#endif
} else {
if (Null(cl_functionp(def)))
FEinvalid_function(def);
if (sym->symbol.hpack != Cnil && sym->symbol.hpack->pack.locked)
funcall(3, @'warn', make_simple_string("~S is being redefined."), fname);
mflag = !Null(macro);
if (sym->symbol.isform && !mflag)
FEerror("Given that ~S is a special form, ~S cannot be defined as a function.",
2, sym, fname);
if (SYMBOLP(fname)) {
sym->symbol.mflag = mflag;
SYM_FUN(sym) = def;
clear_compiler_properties(sym);
if (pprint == Cnil)
si_rem_sysprop(sym, @'si::pretty-print-format');
else
si_put_sysprop(sym, @'si::pretty-print-format', pprint);
} else {
if (mflag)
FEerror("~S is not a valid name for a macro.", 1, fname);
si_put_sysprop(sym, @'si::setf-symbol', def);
si_rem_sysprop(sym, @'si::setf-lambda');
si_rem_sysprop(sym, @'si::setf-method');
si_rem_sysprop(sym, @'si::setf-update');
}
fun->symbol.mflag = !Null(macro);
if (pprint != Cnil)
si_put_sysprop(fun, @'si::pretty-print-format', pprint);
@(return fun)
@(return fname)
@)
cl_object
@ -118,31 +71,27 @@ cl_makunbound(cl_object sym)
}
cl_object
cl_fmakunbound(cl_object sym)
cl_fmakunbound(cl_object fname)
{
if (!SYMBOLP(sym)) {
cl_object sym1 = setf_namep(sym);
if (sym1 == OBJNULL)
FEtype_error_symbol(sym);
sym = CADR(sym);
cl_object sym = si_function_block_name(fname);
if (sym->symbol.hpack != Cnil && sym->symbol.hpack->pack.locked)
funcall(3, @'warn', make_simple_string("~S is being redefined."),
fname);
if (SYMBOLP(fname)) {
clear_compiler_properties(sym);
#ifdef PDE
cl_remprop(fname, @'defun');
#endif
SYM_FUN(sym) = OBJNULL;
sym->symbol.mflag = FALSE;
} else {
cl_remprop(sym, @'si::setf-symbol');
cl_remprop(sym, @'si::setf-lambda');
cl_remprop(sym, @'si::setf-method');
cl_remprop(sym, @'si::setf-update');
cl_fmakunbound(sym1);
@(return sym)
}
clear_compiler_properties(sym);
#ifdef PDE
cl_remprop(sym, @'defun');
#endif
if (sym->symbol.hpack &&
sym->symbol.hpack->pack.locked &&
SYM_FUN(sym) != OBJNULL)
funcall(3, @'warn', make_simple_string("~S is being redefined."),
sym);
SYM_FUN(sym) = OBJNULL;
sym->symbol.mflag = FALSE;
@(return sym)
@(return fname)
}
void

22
src/c/cfun.d
View file

@ -103,19 +103,15 @@ cl_function_lambda_expression(cl_object fun)
switch(type_of(fun)) {
case t_bytecodes:
if (!Null(fun->bytecodes.lex))
output = Cnil;
else {
lex = fun->bytecodes.lex;
output = fun->bytecodes.definition;
name = fun->bytecodes.name;
if (!CONSP(output))
output = Cnil;
else if (name == Cnil)
output = cl_cons(@'lambda', output);
else
output = @list*(3, @'lambda-block', name, output);
}
lex = fun->bytecodes.lex;
name = fun->bytecodes.name;
output = fun->bytecodes.definition;
if (!CONSP(output))
output = Cnil;
else if (name == Cnil)
output = cl_cons(@'lambda', output);
else
output = @list*(3, @'lambda-block', name, output);
break;
case t_cfun:
name = fun->cfun.name;

70
src/c/compiler.d
View file

@ -435,7 +435,8 @@ c_tag_ref(cl_object the_tag, cl_object the_type)
CDR(assql(the_tag, name)));
n++;
} else if (type == @':block' || type == @':function') {
if (type == the_type && name == the_tag)
/* We compare with EQUAL, because of (SETF fname) */
if (type == the_type && equal(name, the_tag))
return MAKE_FIXNUM(n);
n++;
} else if (Null(name)) {
@ -678,6 +679,8 @@ c_arguments(cl_object args) {
return nargs;
}
static int asm_function(cl_object args, int flags);
static int
c_call(cl_object args, int flags) {
cl_object name;
@ -686,31 +689,15 @@ c_call(cl_object args, int flags) {
name = pop(&args);
nargs = c_arguments(args);
if (ATOM(name)) {
cl_object ndx;
if (!SYMBOLP(name))
goto ERROR;
ndx = c_tag_ref(name, @':function');
if (Null(ndx) || (flags & FLAG_GLOBAL)) {
/* Globally defined function */
asm_op2(push? OP_PCALLG : OP_CALLG, nargs);
asm1(name);
} else {
/* Function from a FLET/LABELS form */
asm_op2(OP_LFUNCTION, fix(ndx));
asm_op2(push? OP_PCALL : OP_CALL, nargs);
}
} else if (CAR(name) == @'lambda') {
asm_op(OP_CLOSE);
asm1(make_lambda(Cnil, CDR(name)));
asm_op2(push? OP_PCALL : OP_CALL, nargs);
if (SYMBOLP(name) &&
((flags & FLAG_GLOBAL) || Null(c_tag_ref(name, @':function'))))
{
/* Globally defined function */
asm_op2(push? OP_PCALLG : OP_CALLG, nargs);
asm1(name);
} else {
cl_object aux = setf_namep(name);
if (aux == OBJNULL)
ERROR: FEprogram_error("FUNCALL: Invalid function name ~S.",
1, name);
/* The outcome of (SETF ...) may be a macro name */
return compile_form(CONS(aux, CDR(args)), flags);
asm_function(name, FLAG_VALUES);
asm_op2(push? OP_PCALL : OP_CALL, nargs);
}
return flags;
}
@ -1209,7 +1196,12 @@ c_function(cl_object args, int flags) {
cl_object setf_function, function = pop(&args);
if (!endp(args))
FEprogram_error("FUNCTION: Too many arguments.", 0);
if (SYMBOLP(function)) {
return asm_function(function, flags);
}
static int
asm_function(cl_object function, int flags) {
if (!Null(si_valid_function_name_p(function))) {
cl_object ndx = c_tag_ref(function, @':function');
if (Null(ndx)) {
/* Globally defined function */
@ -1227,11 +1219,9 @@ c_function(cl_object args, int flags) {
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
} else {
FEprogram_error("FUNCTION: Not a valid argument ~S.", 1, function);
}
return FLAG_VALUES;
}
@ -1483,7 +1473,7 @@ c_multiple_value_call(cl_object args, int flags) {
name = pop(&args);
if (endp(args)) {
/* If no arguments, just use ordinary call */
return c_call(cl_list(1, name), flags);
return c_funcall(cl_list(1, name), flags);
}
compile_form(name, FLAG_PUSH);
for (op = OP_PUSHVALUES; !endp(args); op = OP_PUSHMOREVALUES) {
@ -2440,7 +2430,7 @@ make_lambda(cl_object name, cl_object lambda) {
handle = asm_begin();
/* Transform (SETF fname) => fname */
if (CONSP(name) && setf_namep(name) == OBJNULL)
if (Null(si_valid_function_name_p(name)))
FEprogram_error("LAMBDA: Not a valid function name ~S",1,name);
asm_list(reqs); /* Special arguments */
@ -2521,7 +2511,21 @@ si_function_block_name(cl_object 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);
FEinvalid_function_name(name);
}
cl_object
si_valid_function_name_p(cl_object name)
{
cl_object output = Cnil;
if (SYMBOLP(name))
output = Ct;
else if (CONSP(name) && CAR(name) == @'setf') {
name = CDR(name);
if (CONSP(name) && SYMBOLP(CAR(name)) && ENDP(CDR(name)))
output = Ct;
}
@(return output);
}
cl_object

10
src/c/error.d
View file

@ -207,6 +207,16 @@ FEinvalid_function(cl_object obj)
FEwrong_type_argument(@'function', obj);
}
void
FEinvalid_function_name(cl_object fname)
{
cl_error(9, @'simple-type-error', @':format-control',
make_simple_string("Not a valid function name ~D"),
@':format-arguments', cl_list(1, fname),
@':expected-type', Ct,
@':datum', fname);
}
/* bootstrap version */
static
@(defun "universal_error_handler" (c err args)

10
src/c/eval.d
View file

@ -73,7 +73,7 @@ cl_apply_from_stack(cl_index narg, cl_object x)
cl_object fun = x;
AGAIN:
if (fun == OBJNULL)
FEundefined_function(fun);
FEundefined_function(x);
switch (type_of(fun)) {
case t_cfun:
if (fun->cfun.narg >= 0) {
@ -91,12 +91,14 @@ cl_apply_from_stack(cl_index narg, cl_object x)
goto AGAIN;
#endif
case t_symbol:
if (fun->symbol.mflag)
FEundefined_function(x);
fun = SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
return lambda_apply(narg, fun);
default:
FEinvalid_function(fun);
FEinvalid_function(x);
}
}
@ -108,7 +110,7 @@ cl_object
link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args)
{
cl_index sp;
cl_object out, fun = symbol_function(sym);
cl_object out, fun = ecl_fdefinition(sym);
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
@ -206,6 +208,8 @@ si_unlink_symbol(cl_object s)
goto AGAIN;
#endif
case t_symbol:
if (fun->symbol.mflag)
FEundefined_function(fun);
fun = SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:

3
src/c/gfun.d
View file

@ -202,8 +202,7 @@ compute_method(int narg, cl_object fun, cl_object *args)
cl_object argtype[narg]; /* __GNUC__ */
if (narg < fun->gfun.arg_no)
FEerror("Generic function ~S requires more than ~R argument~:p.",
2, fun->gfun.name, MAKE_FIXNUM(narg));
FEwrong_num_arguments(fun->gfun.name);
for (i = 0, spec_no = 0; i < fun->gfun.arg_no; i++, spec_how++) {
if (*spec_how != Cnil)
argtype[spec_no++] = (ATOM(*spec_how) ||

13
src/c/instance.d
View file

@ -182,3 +182,16 @@ si_sl_makunbound(cl_object x, cl_object index)
x->instance.slots[i] = OBJNULL;
@(return x)
}
cl_object
ecl_copy_instance(cl_object x)
{
cl_object y;
if (type_of(x) != t_instance)
FEwrong_type_argument(@'instance', x);
y = ecl_allocate_instance(x->instance.clas, x->instance.length);
memcpy(y->instance.slots, x->instance.slots,
x->instance.length * sizeof(cl_object));
@(return y)
}

28
src/c/interpreter.d
View file

@ -232,8 +232,8 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
cl_object *data = lambda_list->bytecodes.data;
cl_object specials = lambda_list->bytecodes.specials;
int i, n;
bool other_keys = FALSE;
bool check_remaining = TRUE;
bool allow_other_keys = FALSE;
bool allow_other_keys_found = FALSE;
/* 1) REQUIRED ARGUMENTS: N var1 ... varN */
@ -274,14 +274,14 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
/* 4) ALLOW-OTHER-KEYS: { T | NIL | 0} */
if (data[0] == MAKE_FIXNUM(0)) {
data++; other_keys = 0;
data++; allow_other_keys = 0;
goto NO_KEYS;
}
other_keys = !Null(next_code(data));
allow_other_keys = allow_other_keys_found = !Null(next_code(data));
/* 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN */
n = fix(next_code(data));
if (n != 0 || other_keys) {
if (n != 0 || allow_other_keys) {
cl_object *keys;
cl_object spp[n];
bool other_found = FALSE;
@ -296,7 +296,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
if (key == @':allow-other-keys') {
if (!allow_other_keys_found) {
allow_other_keys_found = TRUE;
other_keys = !Null(value);
allow_other_keys = !Null(value);
}
}
for (i = 0; i < n; i++, keys += 4) {
@ -311,7 +311,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
FOUND:
(void)0;
}
if (other_found && !other_keys)
if (other_found && !allow_other_keys)
FEprogram_error("LAMBDA: Unknown keys found in function ~S.",
1, lambda_list->bytecodes.name);
for (i=0; i<n; i++, data+=4) {
@ -330,7 +330,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
}
}
NO_KEYS:
if (narg && !other_keys && check_remaining)
if (narg && !allow_other_keys && check_remaining)
FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1,
lambda_list->bytecodes.name);
/* Skip documentation and declarations */
@ -440,7 +440,7 @@ interpret_funcall(int narg, cl_object fun) {
break;
case t_symbol: {
cl_object function = SYM_FUN(fun);
if (function == OBJNULL)
if (function == OBJNULL || fun->symbol.mflag)
FEundefined_function(fun);
fun = function;
goto AGAIN;
@ -785,7 +785,7 @@ interpret(cl_object *vector) {
case OP_CALLG: {
cl_fixnum n = get_oparg(s);
cl_object fun = next_code(vector);
if (fun->symbol.gfdef == OBJNULL)
if (fun->symbol.gfdef == OBJNULL || fun->symbol.mflag)
FEundefined_function(fun);
VALUES(0) = interpret_funcall(n, fun->symbol.gfdef);
break;
@ -905,15 +905,11 @@ interpret(cl_object *vector) {
may be defined in the global environment or in the local
environment. This last value takes precedence.
*/
case OP_FUNCTION: {
cl_object fun_name = next_code(vector);
cl_object fun_object = SYM_FUN(fun_name);
if (fun_object == OBJNULL || fun_name->symbol.mflag)
FEundefined_function(fun_name);
VALUES(0) = fun_object;
case OP_FUNCTION:
VALUES(0) = cl_fdefinition(next_code(vector));
NValues = 1;
break;
}
/* OP_CLOSE name{symbol}
Extracts the function associated to a symbol. The function
may be defined in the global environment or in the local

14
src/c/list.d
View file

@ -527,11 +527,17 @@ cl_ldiff(cl_object x, cl_object y)
cl_object res = Cnil, *fill = &res;
loop_for_on(x) {
if (x == y)
break;
if (eql(x, y))
@(return res)
else
fill = &CDR(*fill = CONS(CAR(x), Cnil));
} end_loop_for_on;
/* INV: At the end of a loop_for_on(x), x has the CDR of the last cons
in the list. When Y was not a member of the list, LDIFF must set
this value in the output, because it produces an exact copy of the
dotted list. */
if (!eql(x, y))
*fill = x;
@(return res)
}
@ -757,10 +763,10 @@ cl_object
cl_tailp(cl_object y, cl_object x)
{
loop_for_on(x) {
if (x == y)
if (eql(x, y))
@(return Ct)
} end_loop_for_on;
@(return ((x == y)? Ct : Cnil))
return cl_eql(x, y);
}
cl_return

25
src/c/package.d
View file

@ -211,10 +211,12 @@ find_package(cl_object name)
cl_object
si_coerce_to_package(cl_object p)
{
/* INV: find_package() signals an error if "p" is neither a package
nor a string */
cl_object pp = find_package(p);
if (!Null(pp))
@(return pp);
FEwrong_type_argument(@'package', p);
FEpackage_error("There exists no package with name ~S", p, 0);
}
cl_object
@ -225,7 +227,7 @@ current_package(void)
x = symbol_value(@'*package*');
if (type_of(x) != t_package) {
SYM_VAL(@'*package*') = user_package;
FEerror("The value of *PACKAGE*, ~S, was not a package.",
FEerror("The value of *PACKAGE*, ~S, was not a package",
1, x);
}
return(x);
@ -465,7 +467,10 @@ cl_unexport2(cl_object s, cl_object p)
CEpackage_error("Cannot unexport symbol ~S from locked package ~S.",
p, 2, s, p);
x = find_symbol(s, p, &intern_flag);
if (intern_flag != EXTERNAL || x != s)
if (intern_flag == 0)
FEpackage_error("Cannot unexport ~S because it does not belong to package ~S.",
p, 2, s, p);
if (intern_flag != EXTERNAL)
/* According to ANSI & Cltl, internal symbols are
ignored in unexport */
return;
@ -539,7 +544,8 @@ shadow(cl_object s, cl_object p)
int intern_flag;
cl_object x;
assert_type_symbol(s);
/* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */
s = cl_string(s);
p = si_coerce_to_package(p);
if (p->pack.locked)
CEpackage_error("Cannot shadow symbol ~S in locked package ~S.",
@ -814,20 +820,22 @@ BEGIN:
@
BEGIN:
switch (type_of(symbols)) {
case t_string:
case t_symbol:
case t_character:
/* Arguments to SHADOW may be: string designators ... */
if (Null(symbols))
break;
shadow(symbols, pack);
break;
case t_cons:
/* ... or lists of string designators */
pack = si_coerce_to_package(pack);
for (l = symbols; !endp(l); l = CDR(l))
shadow(CAR(l), pack);
break;
default:
assert_type_symbol(symbols);
assert_type_string(symbols);
goto BEGIN;
}
@(return Ct)
@ -841,6 +849,7 @@ BEGIN:
case t_symbol:
if (Null(pack))
break;
case t_character:
case t_string:
case t_package:
use_package(pack, pa);
@ -867,7 +876,7 @@ BEGIN:
case t_symbol:
if (Null(pack))
break;
case t_character:
case t_string:
case t_package:
unuse_package(pack, pa);

2
src/c/pathname.d
View file

@ -538,7 +538,7 @@ push_c_string(cl_object buffer, const char *s, cl_index length)
for (; length; length--, s++) {
dest[fillp++] = *s;
if (fillp >= dim) {
char *new_dest = (char *)cl_alloc_atomic(dim += 32);
char *new_dest = (char *)cl_alloc_atomic((dim += 32)+1);
memcpy(new_dest, dest, fillp);
buffer->string.dim = dim;
buffer->string.self = new_dest;

2
src/c/predicate.d
View file

@ -174,7 +174,7 @@ cl_functionp(cl_object x)
cl_object output;
t = type_of(x);
if (t == t_bytecodes || t == t_cfun || t == t_cclosure)
if (t == t_bytecodes || t == t_cfun || t == t_cclosure || t == t_gfun)
output = Ct;
else
output = Cnil;

6
src/c/read.d
View file

@ -414,11 +414,11 @@ MAKE_FLOAT:
exponent_marker = ecl_current_read_default_float_format();
goto MAKE_FLOAT;
case 's': case 'S':
case 'f': case 'F': case 's': case 'S':
x = make_shortfloat((float)fraction);
break;
case 'f': case 'F': case 'd': case 'D': case 'l': case 'L':
case 'd': case 'D': case 'l': case 'L':
x = make_longfloat((double)fraction);
break;
@ -1255,7 +1255,7 @@ ecl_current_read_default_float_format(void)
if (x == @'single-float' || x == @'short-float')
return 'S';
if (x == @'double-float' || x == @'long-float')
return 'F';
return 'D';
SYM_VAL(@'*read-default-float-format*') = @'single-float';
FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.",
1, x);

128
src/c/reference.d
View file

@ -17,51 +17,11 @@
#include "ecl.h"
#include "ecl-inl.h"
cl_object
cl_fboundp(cl_object sym)
{
cl_object output;
if (!SYMBOLP(sym)) {
cl_object sym1 = setf_namep(sym);
if (sym1 != OBJNULL)
sym = sym1;
else
FEtype_error_symbol(sym);
}
if (sym->symbol.isform)
output = Ct;
else if (SYM_FUN(sym) == OBJNULL)
output = Cnil;
else
output = Ct;
@(return output)
}
cl_object
symbol_function(cl_object sym)
{
if (!SYMBOLP(sym)) {
cl_object sym1 = setf_namep(sym);
if (sym1 != OBJNULL)
sym = sym1;
else
FEtype_error_symbol(sym);
}
if (sym->symbol.isform || sym->symbol.mflag)
FEinvalid_function(sym);
if (SYM_FUN(sym) == OBJNULL)
FEundefined_function(sym);
return(SYM_FUN(sym));
}
/*
Symbol-function returns
function-closure for function
(macro . function-closure) for macros
(special . address) for special forms.
(if defined CLOS it returns also
generic-function for generic functions)
special for special forms.
*/
cl_object
cl_symbol_function(cl_object sym)
@ -83,34 +43,76 @@ cl_symbol_function(cl_object sym)
cl_object
cl_fdefinition(cl_object fname)
{
if (!SYMBOLP(fname)) {
cl_object sym = setf_namep(fname);
if (sym == OBJNULL)
FEtype_error_symbol(fname);
fname = sym;
@(return ((SYMBOLP(fname))? cl_symbol_function(fname) : ecl_fdefinition(fname)))
}
cl_object
cl_fboundp(cl_object fname)
{
cl_object output;
if (SYMBOLP(fname)) {
@(return ((fname->symbol.isform || SYM_FUN(fname) != OBJNULL)? Ct : Cnil))
} else if (CONSP(fname)) {
if (CAR(fname) == @'setf') {
cl_object sym = CDR(fname);
if (CONSP(sym)) {
sym = CAR(sym);
if (SYMBOLP(sym))
return si_get_sysprop(sym, @'si::setf-symbol');
}
}
}
return cl_symbol_function(fname);
FEinvalid_function_name(fname);
}
cl_object
ecl_fdefinition(cl_object fun)
{
cl_type t = type_of(fun);
cl_object output;
if (t == t_symbol) {
output = SYM_FUN(fun);
if (output == OBJNULL)
FEundefined_function(fun);
if (fun->symbol.isform || fun->symbol.mflag)
FEundefined_function(fun);
} else if (t == t_cons) {
if (!CONSP(CDR(fun)))
FEinvalid_function_name(fun);
if (CAR(fun) == @'setf') {
output = si_get_sysprop(CADR(fun), @'si::setf-symbol');
if (Null(output))
FEundefined_function(fun);
} else if (CAR(fun) == @'lambda') {
return si_make_lambda(Cnil, CDR(fun));
} else {
FEinvalid_function(fun);
}
} else {
FEinvalid_function(fun);
}
return output;
}
cl_object
ecl_coerce_to_function(cl_object fun)
{
cl_type t = type_of(fun);
if (t == t_cfun || t == t_cclosure
#ifdef CLOS
|| t == t_gfun
#endif
)
@(return fun)
@(return ecl_fdefinition(fun))
}
cl_object
si_coerce_to_function(cl_object fun)
{
cl_type t = type_of(fun);
if (t == t_symbol) {
if ((SYM_FUN(fun) == OBJNULL) || fun->symbol.mflag)
FEundefined_function(fun);
else
@(return SYM_FUN(fun))
} else if (t == t_cons && CAR(fun) == @'lambda') {
return si_make_lambda(Cnil, CDR(fun));
} else {
cl_object setf_sym = setf_namep(fun);
if ((setf_sym != OBJNULL) && (SYM_FUN(setf_sym) != OBJNULL))
@(return SYM_FUN(setf_sym))
else
FEinvalid_function(fun);
}
@(return ecl_coerce_to_function(fun))
}
cl_object

7
src/c/sequence.d
View file

@ -94,8 +94,11 @@ elt(cl_object seq, cl_fixnum index)
goto E;
return(CODE_CHAR(seq->string.self[index]));
case t_symbol:
if (Null(seq))
break;
default:
FEerror("~S is not a sequence.", 1, seq);
FEwrong_type_argument(@'sequence', seq);
}
E:
FEtype_error_index(MAKE_FIXNUM(index));
@ -141,7 +144,7 @@ elt_set(cl_object seq, cl_fixnum index, cl_object val)
return(val);
default:
FEerror("~S is not a sequence.", 1, seq);
FEwrong_type_argument(@'sequence', seq);
}
E:
FEtype_error_index(MAKE_FIXNUM(index));

24
src/c/structure.d
View file

@ -89,8 +89,11 @@ structure_to_list(cl_object x)
@(return x)
@)
#ifdef CLOS
#define ecl_copy_structure ecl_copy_instance
#else
cl_object
si_copy_structure(cl_object x)
ecl_copy_structure(cl_object x)
{
cl_index j, size;
cl_object y;
@ -106,6 +109,25 @@ si_copy_structure(cl_object x)
memcpy(SLOTS(y), SLOTS(x), size);
@(return y)
}
#endif /* !CLOS */
cl_object
cl_copy_structure(cl_object s)
{
switch (type_of(s)) {
case t_instance:
s = ecl_copy_structure(s);
break;
case t_cons:
case t_vector:
s = cl_copy_seq(s);
break;
default:
FEwrong_type_argument(@'structure', s);
}
@(return s)
}
/* Kept only for compatibility. One should use class-of or type-of. */
cl_object

591
src/c/symbols_list.h
View file

@ -1,8 +1,12 @@
#ifdef DPP
#define SYS_ "SI::"
#define KEY_ ":"
struct {
const char *name, *translation;
}
#else
#define SYS_
#define KEY_
cl_symbol_initializer
#endif
cl_symbols[] = {
@ -100,6 +104,7 @@ cl_symbols[] = {
{"ARRAY-DIMENSION", CL_ORDINARY, cl_array_dimension, 2},
{"ARRAY-DIMENSION-LIMIT", CL_CONSTANT, NULL, -1},
{"ARRAY-DIMENSIONS", CL_ORDINARY, NULL, -1},
{"ARRAY-DISPLACEMENT", CL_ORDINARY, cl_array_displacement, 1},
{"ARRAY-ELEMENT-TYPE", CL_ORDINARY, cl_array_element_type, 1},
{"ARRAY-HAS-FILL-POINTER-P", CL_ORDINARY, cl_array_has_fill_pointer_p, 1},
{"ARRAY-IN-BOUNDS-P", CL_ORDINARY, NULL, -1},
@ -263,6 +268,7 @@ cl_symbols[] = {
{"COPY-LIST", CL_ORDINARY, cl_copy_list, 1},
{"COPY-READTABLE", CL_ORDINARY, cl_copy_readtable, -1},
{"COPY-SEQ", CL_ORDINARY, cl_copy_seq, 1},
{"COPY-STRUCTURE", CL_ORDINARY, cl_copy_structure, 1},
{"COPY-SYMBOL", CL_ORDINARY, cl_copy_symbol, -1},
{"COPY-TREE", CL_ORDINARY, cl_copy_tree, 1},
{"COS", CL_ORDINARY, cl_cos, 1},
@ -275,7 +281,7 @@ cl_symbols[] = {
{"DECF", CL_ORDINARY, NULL, -1},
{"DECLAIM", CL_ORDINARY, NULL, -1},
{"DECLARATION", CL_ORDINARY, NULL, -1},
{"DECLARE", FORM_ORDINARY, NULL, -1},
{"DECLARE", CL_ORDINARY, NULL, -1},
{"DECODE-FLOAT", CL_ORDINARY, cl_decode_float, 1},
{"DECODE-UNIVERSAL-TIME", CL_ORDINARY, NULL, -1},
{"DEFCONSTANT", CL_ORDINARY, NULL, -1},
@ -867,6 +873,8 @@ cl_symbols[] = {
{"TWO-WAY-STREAM-OUTPUT-STREAM", CL_ORDINARY, NULL, -1},
{"TYPE", CL_ORDINARY, NULL, -1},
{"TYPE-ERROR", CL_ORDINARY, NULL, -1},
{"TYPE-ERROR-DATUM", CL_ORDINARY, NULL, -1},
{"TYPE-ERROR-EXPECTED-TYPE", CL_ORDINARY, NULL, -1},
{"TYPE-OF", CL_ORDINARY, cl_type_of, 1},
{"TYPECASE", CL_ORDINARY, NULL, -1},
{"TYPEP", CL_ORDINARY, NULL, -1},
@ -983,187 +991,186 @@ cl_symbols[] = {
#endif
/* SYSTEM PACKAGE */
{"SI::#!", SI_ORDINARY, NULL, -1},
{"SI::*BACKQ-LEVEL*", SI_SPECIAL, NULL, -1},
{"SI::*CBLOCK*", SI_SPECIAL, NULL, -1},
{"SI::*CLASS-NAME-HASH-TABLE*", SI_SPECIAL, NULL, -1},
{"SI::*GC-MESSAGE*", SI_SPECIAL, NULL, -1},
{"SI::*GC-VERBOSE*", SI_SPECIAL, NULL, -1},
{"SI::*IGNORE-ERRORS*", SI_SPECIAL, NULL, -1},
{"SI::*IGNORE-EOF-ON-TERMINAL-IO*", SI_SPECIAL, NULL, -1},
{"SI::*INDENT-FORMATTED-OUTPUT*", SI_SPECIAL, NULL, -1},
{"SI::*INIT-FUNCTION-PREFIX*", SI_SPECIAL, NULL, -1},
{"SI::*INTERRUPT-ENABLE*", SI_SPECIAL, NULL, 1},
{"SI::*KEEP-DEFINITIONS*", SI_SPECIAL, NULL, -1},
{"SI::*LOAD-HOOKS*", SI_SPECIAL, NULL, -1},
{"SI::*MAKE-CONSTANT", SI_ORDINARY, si_Xmake_constant, 2},
{"SI::*MAKE-SPECIAL", SI_ORDINARY, si_Xmake_special, 1},
{"SI::*PRINT-PACKAGE*", SI_SPECIAL, NULL, -1},
{"SI::*PRINT-STRUCTURE*", SI_SPECIAL, NULL, -1},
{"SI::*SHARP-EQ-CONTEXT*", SI_SPECIAL, NULL, -1},
{"SI::.", SI_ORDINARY, NULL, -1},
{"SI::,", SI_ORDINARY, NULL, -1},
{"SI::,.", SI_ORDINARY, NULL, -1},
{"SI::,@", SI_ORDINARY, NULL, -1},
{"SI::ALLOCATE-RAW-INSTANCE", SI_ORDINARY, si_allocate_raw_instance, 2},
{"SI::ARGC", SI_ORDINARY, si_argc, 0},
{"SI::ARGV", SI_ORDINARY, si_argv, 1},
{"SI::ASET", SI_ORDINARY, si_aset, -1},
{"SI::BC-DISASSEMBLE", SI_ORDINARY, si_bc_disassemble, 1},
{"SI::BC-SPLIT", SI_ORDINARY, si_bc_split, 1},
{"SI::BDS-TOP", SI_ORDINARY, si_bds_top, 0},
{"SI::BDS-VAL", SI_ORDINARY, si_bds_val, 1},
{"SI::BDS-VAR", SI_ORDINARY, si_bds_var, 1},
{"SI::BIT-ARRAY-OP", SI_ORDINARY, si_bit_array_op, 4},
{"SI::C-ARGUMENTS-LIMIT", SI_ORDINARY, NULL, -1},
{"SI::CHAR-SET", SI_ORDINARY, si_char_set, 3},
{"SI::CHDIR", SI_ORDINARY, si_chdir, 1},
{"SI::CLEAR-COMPILER-PROPERTIES", SI_ORDINARY, cl_identity, 1},
{"SI::COERCE-TO-FUNCTION", SI_ORDINARY, si_coerce_to_function, 1},
{"SI::COERCE-TO-PACKAGE", SI_ORDINARY, si_coerce_to_package, 1},
{"SI::COMPILED-FUNCTION-BLOCK", SI_ORDINARY, si_compiled_function_block, 1},
{"SI::COMPILED-FUNCTION-NAME", SI_ORDINARY, si_compiled_function_name, 1},
{"SI::COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY, NULL, -1},
{"SI::COPY-STREAM", SI_ORDINARY, si_copy_stream, 1},
{"SI::COPY-STRUCTURE", SI_ORDINARY, si_copy_structure, 1},
{"SI::DAYLIGHT-SAVING-TIME-P", SI_ORDINARY, si_daylight_saving_time_p, -1},
{"SI::DISPATCH-FUNCTION-P", SI_ORDINARY, si_dispatch_function_p, 1},
{"SI::DISPLACED-ARRAY-P", SI_ORDINARY, si_displaced_array_p, 1},
{"SI::ELT-SET", SI_ORDINARY, si_elt_set, 3},
{"SI::EVAL-WITH-ENV", SI_ORDINARY, si_eval_with_env, 2},
{"SI::EXPAND-DEFMACRO", SI_ORDINARY, NULL, -1},
{"SI::FILE-EXISTS", SI_ORDINARY, si_file_exists, 1},
{"SI::FILL-POINTER-SET", SI_ORDINARY, si_fill_pointer_set, 2},
{"SI::FIXNUMP", SI_ORDINARY, si_fixnump, 1},
{"SI::FRS-BDS", SI_ORDINARY, si_frs_bds, 1},
{"SI::FRS-CLASS", SI_ORDINARY, si_frs_class, 1},
{"SI::FRS-IHS", SI_ORDINARY, si_frs_ihs, 1},
{"SI::FRS-TAG", SI_ORDINARY, si_frs_tag, 1},
{"SI::FRS-TOP", SI_ORDINARY, si_frs_top, 0},
{"SI::FSET", SI_ORDINARY, si_fset, -1},
{"SI::FUNCTION-BLOCK-NAME", SI_ORDINARY, si_function_block_name, 1},
{"SI::GENERIC-FUNCTION-METHOD-COMBINATION", SI_ORDINARY, NULL, -1},
{"SI::GENERIC-FUNCTION-METHOD-COMBINATION-ARGS", SI_ORDINARY, NULL, -1},
{"SI::GET-LOCAL-TIME-ZONE", SI_ORDINARY, si_get_local_time_zone, 0},
{"SI::GET-SYSPROP", SI_ORDINARY, si_get_sysprop, 2},
{"SI::GET-STRING-INPUT-STREAM-INDEX", SI_ORDINARY, si_get_string_input_stream_index, 1},
{"SI::GETENV", SI_ORDINARY, si_getenv, 1},
{"SI::HASH-SET", SI_ORDINARY, si_hash_set, 3},
{"SI::HASH-TABLE-ITERATOR", SI_ORDINARY, si_hash_table_iterator, 1},
{"SI::IHS-ENV", SI_ORDINARY, si_ihs_env, 1},
{"SI::IHS-FUN", SI_ORDINARY, si_ihs_fun, 1},
{"SI::IHS-NEXT", SI_ORDINARY, si_ihs_next, 1},
{"SI::IHS-PREV", SI_ORDINARY, si_ihs_prev, 1},
{"SI::IHS-TOP", SI_ORDINARY, si_ihs_top, 1},
{"SI::INTERPRETER-STACK", SI_ORDINARY, si_interpreter_stack, -1},
{"SI::LINK-FROM", SI_ORDINARY, NULL, -1},
{"SI::LINK-TO", SI_ORDINARY, NULL, -1},
{"SI::LIST-NTH", SI_ORDINARY, si_list_nth, 2},
{"SI::LOAD-SOURCE", SI_ORDINARY, si_load_source, 3},
{"SI::LOGICAL-PATHNAME-P", SI_ORDINARY, si_logical_pathname_p, 1},
{"SI::MACRO", SI_ORDINARY, NULL, -1},
{"SI::MAKE-LAMBDA", SI_ORDINARY, si_make_lambda, 2},
{"SI::MAKE-PURE-ARRAY", SI_ORDINARY, si_make_pure_array, -1},
{"SI::MAKE-STRING-OUTPUT-STREAM-FROM-STRING", SI_ORDINARY, si_make_string_output_stream_from_string, 1},
{"SI::MAKE-STRUCTURE", SI_ORDINARY, si_make_structure, -1},
{"SI::MAKE-VECTOR", SI_ORDINARY, si_make_vector, 6},
{"SI::MANGLE-NAME", SI_ORDINARY, si_mangle_name, -1},
{"SI::MEMBER1", SI_ORDINARY, si_member1, -1},
{"SI::MEMQ", SI_ORDINARY, si_memq, 2},
{"SI::MKDIR", SI_ORDINARY, si_mkdir, 2},
{"SI::MKSTEMP", SI_ORDINARY, si_mkstemp, 1},
{"SI::OPEN-PIPE", SI_ORDINARY, si_open_pipe, 1},
{"SI::OUTPUT-STREAM-STRING", SI_ORDINARY, si_output_stream_string, 1},
{"SI::PACKAGE-LOCK", SI_ORDINARY, si_package_lock, 2},
{"SI::PACKAGE-HASH-TABLES", SI_ORDINARY, si_package_hash_tables, 1},
{"SI::PATHNAME-TRANSLATIONS", SI_ORDINARY, si_pathname_translations, -1},
{"SI::POINTER", SI_ORDINARY, si_pointer, 1},
{"SI::PRETTY-PRINT-FORMAT", SI_ORDINARY, NULL, -1},
{"SI::PROCESS-DECLARATIONS", SI_ORDINARY, si_process_declarations, -1},
{"SI::PROCESS-LAMBDA", SI_ORDINARY, si_process_lambda, 1},
{"SI::PROCESS-LAMBDA-LIST", SI_ORDINARY, si_process_lambda_list, 2},
{"SI::PUT-F", SI_ORDINARY, si_put_f, 3},
{"SI::PUT-PROPERTIES", SI_ORDINARY, si_put_properties, -1},
{"SI::PUT-SYSPROP", SI_ORDINARY, si_put_sysprop, 3},
{"SI::PUTPROP", SI_ORDINARY, si_putprop, 3},
{"SI::READ-BYTES", SI_ORDINARY, si_read_bytes, 4},
{"SI::REM-F", SI_ORDINARY, si_rem_f, 2},
{"SI::REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2},
{"SI::REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2},
{"SI::RESET-STACK-LIMITS", SI_ORDINARY, si_reset_stack_limits, 0},
{"SI::ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3},
{"SI::RPLACA-NTHCDR", SI_ORDINARY, si_rplaca_nthcdr, 3},
{"SI::SAFE-EVAL", SI_ORDINARY, si_safe_eval, -1},
{"SI::SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2},
{"SI::SCHAR-SET", SI_ORDINARY, si_char_set, 3},
{"SI::SHARP-A-READER", SI_ORDINARY, NULL, -1},
{"SI::SHARP-S-READER", SI_ORDINARY, NULL, -1},
{"SI::SELECT-PACKAGE", SI_ORDINARY, si_select_package, 1},
{"SI::SET-SYMBOL-PLIST", SI_ORDINARY, si_set_symbol_plist, 2},
{"SI::SETENV", SI_ORDINARY, si_setenv, 2},
{"SI::SETF-LAMBDA", SI_ORDINARY, NULL, -1},
{"SI::SETF-METHOD", SI_ORDINARY, NULL, -1},
{"SI::SETF-NAMEP", SI_ORDINARY, si_setf_namep, 1},
{"SI::SETF-SYMBOL", SI_ORDINARY, NULL, -1},
{"SI::SETF-UPDATE", SI_ORDINARY, NULL, -1},
{"SI::SIMPLE-CONTROL-ERROR", SI_ORDINARY, NULL, -1},
{"SI::SIMPLE-PACKAGE-ERROR", SI_ORDINARY, NULL, -1},
{"SI::SIMPLE-PROGRAM-ERROR", SI_ORDINARY, NULL, -1},
{"SI::SIMPLE-READER-ERROR", SI_ORDINARY, NULL, -1},
{"SI::SPECIALP", SI_ORDINARY, si_specialp, 1},
{"SI::STANDARD-READTABLE", SI_ORDINARY, si_standard_readtable, 0},
{"SI::STRING-CONCATENATE", SI_ORDINARY, si_string_concatenate, -1},
{"SI::STRING-MATCH", SI_ORDINARY, si_string_match, 2},
{"SI::STRING-TO-OBJECT", SI_ORDINARY, si_string_to_object, 1},
{"SI::STRUCTURE-NAME", SI_ORDINARY, si_structure_name, 1},
{"SI::STRUCTURE-PRINT-FUNCTION", SI_ORDINARY, NULL, -1},
{"SI::STRUCTURE-REF", SI_ORDINARY, si_structure_ref, 3},
{"SI::STRUCTURE-SET", SI_ORDINARY, si_structure_set, 4},
{"SI::STRUCTURE-SLOT-DESCRIPTIONS", SI_ORDINARY, NULL, -1},
{"SI::STRUCTURE-SUBTYPE-P", SI_ORDINARY, si_structure_subtype_p, 2},
{"SI::STRUCTUREP", SI_ORDINARY, si_structurep, 1},
{"SI::SVSET", SI_ORDINARY, si_svset, 3},
{"SI::SYMBOL-MACRO", SI_ORDINARY, NULL, -1},
{"SI::SYSTEM", SI_ORDINARY, si_system, 1},
{"SI::TERMINAL-INTERRUPT", SI_ORDINARY, NULL, -1},
{"SI::TOP-LEVEL", SI_ORDINARY, NULL, -1},
{"SI::UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1},
{"SI::UNLINK-SYMBOL", SI_ORDINARY, si_unlink_symbol, 1},
{"SI::WRITE-BYTES", SI_ORDINARY, si_write_bytes, 4},
{SYS_ "#!", SI_ORDINARY, NULL, -1},
{SYS_ "*BACKQ-LEVEL*", SI_SPECIAL, NULL, -1},
{SYS_ "*CBLOCK*", SI_SPECIAL, NULL, -1},
{SYS_ "*CLASS-NAME-HASH-TABLE*", SI_SPECIAL, NULL, -1},
{SYS_ "*GC-MESSAGE*", SI_SPECIAL, NULL, -1},
{SYS_ "*GC-VERBOSE*", SI_SPECIAL, NULL, -1},
{SYS_ "*IGNORE-ERRORS*", SI_SPECIAL, NULL, -1},
{SYS_ "*IGNORE-EOF-ON-TERMINAL-IO*", SI_SPECIAL, NULL, -1},
{SYS_ "*INDENT-FORMATTED-OUTPUT*", SI_SPECIAL, NULL, -1},
{SYS_ "*INIT-FUNCTION-PREFIX*", SI_SPECIAL, NULL, -1},
{SYS_ "*INTERRUPT-ENABLE*", SI_SPECIAL, NULL, 1},
{SYS_ "*KEEP-DEFINITIONS*", SI_SPECIAL, NULL, -1},
{SYS_ "*LOAD-HOOKS*", SI_SPECIAL, NULL, -1},
{SYS_ "*MAKE-CONSTANT", SI_ORDINARY, si_Xmake_constant, 2},
{SYS_ "*MAKE-SPECIAL", SI_ORDINARY, si_Xmake_special, 1},
{SYS_ "*PRINT-PACKAGE*", SI_SPECIAL, NULL, -1},
{SYS_ "*PRINT-STRUCTURE*", SI_SPECIAL, NULL, -1},
{SYS_ "*SHARP-EQ-CONTEXT*", SI_SPECIAL, NULL, -1},
{SYS_ ".", SI_ORDINARY, NULL, -1},
{SYS_ ",", SI_ORDINARY, NULL, -1},
{SYS_ ",.", SI_ORDINARY, NULL, -1},
{SYS_ ",@", SI_ORDINARY, NULL, -1},
{SYS_ "ALLOCATE-RAW-INSTANCE", SI_ORDINARY, si_allocate_raw_instance, 2},
{SYS_ "ARGC", SI_ORDINARY, si_argc, 0},
{SYS_ "ARGV", SI_ORDINARY, si_argv, 1},
{SYS_ "ASET", SI_ORDINARY, si_aset, -1},
{SYS_ "BC-DISASSEMBLE", SI_ORDINARY, si_bc_disassemble, 1},
{SYS_ "BC-SPLIT", SI_ORDINARY, si_bc_split, 1},
{SYS_ "BDS-TOP", SI_ORDINARY, si_bds_top, 0},
{SYS_ "BDS-VAL", SI_ORDINARY, si_bds_val, 1},
{SYS_ "BDS-VAR", SI_ORDINARY, si_bds_var, 1},
{SYS_ "BIT-ARRAY-OP", SI_ORDINARY, si_bit_array_op, 4},
{SYS_ "C-ARGUMENTS-LIMIT", SI_ORDINARY, NULL, -1},
{SYS_ "CHAR-SET", SI_ORDINARY, si_char_set, 3},
{SYS_ "CHDIR", SI_ORDINARY, si_chdir, 1},
{SYS_ "CLEAR-COMPILER-PROPERTIES", SI_ORDINARY, cl_identity, 1},
{SYS_ "COERCE-TO-FUNCTION", SI_ORDINARY, si_coerce_to_function, 1},
{SYS_ "COERCE-TO-PACKAGE", SI_ORDINARY, si_coerce_to_package, 1},
{SYS_ "COMPILED-FUNCTION-BLOCK", SI_ORDINARY, si_compiled_function_block, 1},
{SYS_ "COMPILED-FUNCTION-NAME", SI_ORDINARY, si_compiled_function_name, 1},
{SYS_ "COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY, NULL, -1},
{SYS_ "COPY-STREAM", SI_ORDINARY, si_copy_stream, 1},
{SYS_ "DAYLIGHT-SAVING-TIME-P", SI_ORDINARY, si_daylight_saving_time_p, -1},
{SYS_ "DISPATCH-FUNCTION-P", SI_ORDINARY, si_dispatch_function_p, 1},
{SYS_ "ELT-SET", SI_ORDINARY, si_elt_set, 3},
{SYS_ "EVAL-WITH-ENV", SI_ORDINARY, si_eval_with_env, 2},
{SYS_ "EXPAND-DEFMACRO", SI_ORDINARY, NULL, -1},
{SYS_ "FILE-EXISTS", SI_ORDINARY, si_file_exists, 1},
{SYS_ "FILL-POINTER-SET", SI_ORDINARY, si_fill_pointer_set, 2},
{SYS_ "FIXNUMP", SI_ORDINARY, si_fixnump, 1},
{SYS_ "FRS-BDS", SI_ORDINARY, si_frs_bds, 1},
{SYS_ "FRS-CLASS", SI_ORDINARY, si_frs_class, 1},
{SYS_ "FRS-IHS", SI_ORDINARY, si_frs_ihs, 1},
{SYS_ "FRS-TAG", SI_ORDINARY, si_frs_tag, 1},
{SYS_ "FRS-TOP", SI_ORDINARY, si_frs_top, 0},
{SYS_ "FSET", SI_ORDINARY, si_fset, -1},
{SYS_ "FUNCTION-BLOCK-NAME", SI_ORDINARY, si_function_block_name, 1},
{SYS_ "GENERIC-FUNCTION-METHOD-COMBINATION", SI_ORDINARY, NULL, -1},
{SYS_ "GENERIC-FUNCTION-METHOD-COMBINATION-ARGS", SI_ORDINARY, NULL, -1},
{SYS_ "GET-LOCAL-TIME-ZONE", SI_ORDINARY, si_get_local_time_zone, 0},
{SYS_ "GET-SYSPROP", SI_ORDINARY, si_get_sysprop, 2},
{SYS_ "GET-STRING-INPUT-STREAM-INDEX", SI_ORDINARY, si_get_string_input_stream_index, 1},
{SYS_ "GETENV", SI_ORDINARY, si_getenv, 1},
{SYS_ "HASH-SET", SI_ORDINARY, si_hash_set, 3},
{SYS_ "HASH-TABLE-ITERATOR", SI_ORDINARY, si_hash_table_iterator, 1},
{SYS_ "IHS-ENV", SI_ORDINARY, si_ihs_env, 1},
{SYS_ "IHS-FUN", SI_ORDINARY, si_ihs_fun, 1},
{SYS_ "IHS-NEXT", SI_ORDINARY, si_ihs_next, 1},
{SYS_ "IHS-PREV", SI_ORDINARY, si_ihs_prev, 1},
{SYS_ "IHS-TOP", SI_ORDINARY, si_ihs_top, 1},
{SYS_ "INTERPRETER-STACK", SI_ORDINARY, si_interpreter_stack, -1},
{SYS_ "LINK-FROM", SI_ORDINARY, NULL, -1},
{SYS_ "LINK-TO", SI_ORDINARY, NULL, -1},
{SYS_ "LIST-NTH", SI_ORDINARY, si_list_nth, 2},
{SYS_ "LOAD-SOURCE", SI_ORDINARY, si_load_source, 3},
{SYS_ "LOGICAL-PATHNAME-P", SI_ORDINARY, si_logical_pathname_p, 1},
{SYS_ "MACRO", SI_ORDINARY, NULL, -1},
{SYS_ "MAKE-LAMBDA", SI_ORDINARY, si_make_lambda, 2},
{SYS_ "MAKE-PURE-ARRAY", SI_ORDINARY, si_make_pure_array, -1},
{SYS_ "MAKE-STRING-OUTPUT-STREAM-FROM-STRING", SI_ORDINARY, si_make_string_output_stream_from_string, 1},
{SYS_ "MAKE-STRUCTURE", SI_ORDINARY, si_make_structure, -1},
{SYS_ "MAKE-VECTOR", SI_ORDINARY, si_make_vector, 6},
{SYS_ "MANGLE-NAME", SI_ORDINARY, si_mangle_name, -1},
{SYS_ "MEMBER1", SI_ORDINARY, si_member1, -1},
{SYS_ "MEMQ", SI_ORDINARY, si_memq, 2},
{SYS_ "MKDIR", SI_ORDINARY, si_mkdir, 2},
{SYS_ "MKSTEMP", SI_ORDINARY, si_mkstemp, 1},
{SYS_ "OPEN-PIPE", SI_ORDINARY, si_open_pipe, 1},
{SYS_ "OUTPUT-STREAM-STRING", SI_ORDINARY, si_output_stream_string, 1},
{SYS_ "PACKAGE-LOCK", SI_ORDINARY, si_package_lock, 2},
{SYS_ "PACKAGE-HASH-TABLES", SI_ORDINARY, si_package_hash_tables, 1},
{SYS_ "PATHNAME-TRANSLATIONS", SI_ORDINARY, si_pathname_translations, -1},
{SYS_ "POINTER", SI_ORDINARY, si_pointer, 1},
{SYS_ "PRETTY-PRINT-FORMAT", SI_ORDINARY, NULL, -1},
{SYS_ "PROCESS-DECLARATIONS", SI_ORDINARY, si_process_declarations, -1},
{SYS_ "PROCESS-LAMBDA", SI_ORDINARY, si_process_lambda, 1},
{SYS_ "PROCESS-LAMBDA-LIST", SI_ORDINARY, si_process_lambda_list, 2},
{SYS_ "PUT-F", SI_ORDINARY, si_put_f, 3},
{SYS_ "PUT-PROPERTIES", SI_ORDINARY, si_put_properties, -1},
{SYS_ "PUT-SYSPROP", SI_ORDINARY, si_put_sysprop, 3},
{SYS_ "PUTPROP", SI_ORDINARY, si_putprop, 3},
{SYS_ "READ-BYTES", SI_ORDINARY, si_read_bytes, 4},
{SYS_ "REM-F", SI_ORDINARY, si_rem_f, 2},
{SYS_ "REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2},
{SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2},
{SYS_ "RESET-STACK-LIMITS", SI_ORDINARY, si_reset_stack_limits, 0},
{SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3},
{SYS_ "RPLACA-NTHCDR", SI_ORDINARY, si_rplaca_nthcdr, 3},
{SYS_ "SAFE-EVAL", SI_ORDINARY, si_safe_eval, -1},
{SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2},
{SYS_ "SCHAR-SET", SI_ORDINARY, si_char_set, 3},
{SYS_ "SHARP-A-READER", SI_ORDINARY, NULL, -1},
{SYS_ "SHARP-S-READER", SI_ORDINARY, NULL, -1},
{SYS_ "SELECT-PACKAGE", SI_ORDINARY, si_select_package, 1},
{SYS_ "SET-SYMBOL-PLIST", SI_ORDINARY, si_set_symbol_plist, 2},
{SYS_ "SETENV", SI_ORDINARY, si_setenv, 2},
{SYS_ "SETF-LAMBDA", SI_ORDINARY, NULL, -1},
{SYS_ "SETF-METHOD", SI_ORDINARY, NULL, -1},
{SYS_ "SETF-NAMEP", SI_ORDINARY, NULL, -1},
{SYS_ "SETF-SYMBOL", SI_ORDINARY, NULL, -1},
{SYS_ "SETF-UPDATE", SI_ORDINARY, NULL, -1},
{SYS_ "SIMPLE-CONTROL-ERROR", SI_ORDINARY, NULL, -1},
{SYS_ "SIMPLE-PACKAGE-ERROR", SI_ORDINARY, NULL, -1},
{SYS_ "SIMPLE-PROGRAM-ERROR", SI_ORDINARY, NULL, -1},
{SYS_ "SIMPLE-READER-ERROR", SI_ORDINARY, NULL, -1},
{SYS_ "SPECIALP", SI_ORDINARY, si_specialp, 1},
{SYS_ "STANDARD-READTABLE", SI_ORDINARY, si_standard_readtable, 0},
{SYS_ "STRING-CONCATENATE", SI_ORDINARY, si_string_concatenate, -1},
{SYS_ "STRING-MATCH", SI_ORDINARY, si_string_match, 2},
{SYS_ "STRING-TO-OBJECT", SI_ORDINARY, si_string_to_object, 1},
{SYS_ "STRUCTURE-NAME", SI_ORDINARY, si_structure_name, 1},
{SYS_ "STRUCTURE-PRINT-FUNCTION", SI_ORDINARY, NULL, -1},
{SYS_ "STRUCTURE-REF", SI_ORDINARY, si_structure_ref, 3},
{SYS_ "STRUCTURE-SET", SI_ORDINARY, si_structure_set, 4},
{SYS_ "STRUCTURE-SLOT-DESCRIPTIONS", SI_ORDINARY, NULL, -1},
{SYS_ "STRUCTURE-SUBTYPE-P", SI_ORDINARY, si_structure_subtype_p, 2},
{SYS_ "STRUCTUREP", SI_ORDINARY, si_structurep, 1},
{SYS_ "SVSET", SI_ORDINARY, si_svset, 3},
{SYS_ "SYMBOL-MACRO", SI_ORDINARY, NULL, -1},
{SYS_ "SYSTEM", SI_ORDINARY, si_system, 1},
{SYS_ "TERMINAL-INTERRUPT", SI_ORDINARY, NULL, -1},
{SYS_ "TOP-LEVEL", SI_ORDINARY, NULL, -1},
/*{SYS_ "VALID-FUNCTION-NAME-P", SI_ORDINARY, si_valid_function_name_p, 1},*/
{SYS_ "UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1},
{SYS_ "UNLINK-SYMBOL", SI_ORDINARY, si_unlink_symbol, 1},
{SYS_ "WRITE-BYTES", SI_ORDINARY, si_write_bytes, 4},
#ifndef CLOS
{"SI::STRUCTURE-INCLUDE", SI_ORDINARY, NULL, -1},
{SYS_ "STRUCTURE-INCLUDE", SI_ORDINARY, NULL, -1},
#else
{"SI::ALLOCATE-GFUN", SI_ORDINARY, si_allocate_gfun, 3},
{"SI::CHANGE-INSTANCE", SI_ORDINARY, si_change_instance, 4},
{"SI::GFUN-NAME", SI_ORDINARY, si_gfun_name, 1},
{"SI::GFUN-NAME-SET", SI_ORDINARY, si_gfun_name_set, 2},
{"SI::GFUN-METHOD-HT", SI_ORDINARY, si_gfun_method_ht, 1},
{"SI::GFUN-METHOD-HT-SET", SI_ORDINARY, si_gfun_method_ht_set, 2},
{"SI::GFUN-SPEC-HOW-REF", SI_ORDINARY, si_gfun_spec_how_ref, 2},
{"SI::GFUN-SPEC-HOW-SET", SI_ORDINARY, si_gfun_spec_how_set, 3},
{"SI::GFUN-INSTANCE", SI_ORDINARY, si_gfun_instance, 1},
{"SI::GFUN-INSTANCE-SET", SI_ORDINARY, si_gfun_instance_set, 2},
{"SI::GFUNP", SI_ORDINARY, si_gfunp, 1},
{"SI::INSTANCE-REF-SAFE", SI_ORDINARY, si_instance_ref_safe, 2},
{"SI::INSTANCE-REF", SI_ORDINARY, si_instance_ref, 2},
{"SI::INSTANCE-SET", SI_ORDINARY, si_instance_set, 3},
{"SI::INSTANCE-CLASS", SI_ORDINARY, si_instance_class, 1},
{"SI::INSTANCE-CLASS-SET", SI_ORDINARY, si_instance_class_set, 2},
{"SI::INSTANCEP", SI_ORDINARY, si_instancep, 1},
{"SI::METHOD-HT-GET", SI_ORDINARY, si_method_ht_get, 2},
{"SI::SET-COMPILED-FUNCTION-NAME", SI_ORDINARY, si_set_compiled_function_name, 2},
{"SI::SL-BOUNDP", SI_ORDINARY, si_sl_boundp, 1},
{"SI::SL-MAKUNBOUND", SI_ORDINARY, si_sl_makunbound, 2},
{"SI::UNBOUND", SI_ORDINARY, si_unbound, 0},
{SYS_ "ALLOCATE-GFUN", SI_ORDINARY, si_allocate_gfun, 3},
{SYS_ "CHANGE-INSTANCE", SI_ORDINARY, si_change_instance, 4},
{SYS_ "GFUN-NAME", SI_ORDINARY, si_gfun_name, 1},
{SYS_ "GFUN-NAME-SET", SI_ORDINARY, si_gfun_name_set, 2},
{SYS_ "GFUN-METHOD-HT", SI_ORDINARY, si_gfun_method_ht, 1},
{SYS_ "GFUN-METHOD-HT-SET", SI_ORDINARY, si_gfun_method_ht_set, 2},
{SYS_ "GFUN-SPEC-HOW-REF", SI_ORDINARY, si_gfun_spec_how_ref, 2},
{SYS_ "GFUN-SPEC-HOW-SET", SI_ORDINARY, si_gfun_spec_how_set, 3},
{SYS_ "GFUN-INSTANCE", SI_ORDINARY, si_gfun_instance, 1},
{SYS_ "GFUN-INSTANCE-SET", SI_ORDINARY, si_gfun_instance_set, 2},
{SYS_ "GFUNP", SI_ORDINARY, si_gfunp, 1},
{SYS_ "INSTANCE-REF-SAFE", SI_ORDINARY, si_instance_ref_safe, 2},
{SYS_ "INSTANCE-REF", SI_ORDINARY, si_instance_ref, 2},
{SYS_ "INSTANCE-SET", SI_ORDINARY, si_instance_set, 3},
{SYS_ "INSTANCE-CLASS", SI_ORDINARY, si_instance_class, 1},
{SYS_ "INSTANCE-CLASS-SET", SI_ORDINARY, si_instance_class_set, 2},
{SYS_ "INSTANCEP", SI_ORDINARY, si_instancep, 1},
{SYS_ "METHOD-HT-GET", SI_ORDINARY, si_method_ht_get, 2},
{SYS_ "SET-COMPILED-FUNCTION-NAME", SI_ORDINARY, si_set_compiled_function_name, 2},
{SYS_ "SL-BOUNDP", SI_ORDINARY, si_sl_boundp, 1},
{SYS_ "SL-MAKUNBOUND", SI_ORDINARY, si_sl_makunbound, 2},
{SYS_ "UNBOUND", SI_ORDINARY, si_unbound, 0},
#endif
#ifdef PROFILE
{"SI::*PROFILE-ARRAY*", SI_SPECIAL, NULL, -1},
{SYS_ "*PROFILE-ARRAY*", SI_SPECIAL, NULL, -1},
#endif
#ifdef ENABLE_DLOPEN
{"SI::LOAD-BINARY", SI_ORDINARY, si_load_binary, 3},
{SYS_ "LOAD-BINARY", SI_ORDINARY, si_load_binary, 3},
#endif
#ifdef ECL_CLOS_STREAMS
@ -1180,9 +1187,9 @@ cl_symbols[] = {
#endif
#ifdef PDE
{"SI::*RECORD-SOURCE-PATHNAME-P*", SI_SPECIAL, NULL, -1},
{"SI::*SOURCE-PATHNAME*", SI_SPECIAL, NULL, -1},
{"SI::RECORD-SOURCE-PATHNAME", SI_ORDINARY, NULL, -1},
{SYS_ "*RECORD-SOURCE-PATHNAME-P*", SI_SPECIAL, NULL, -1},
{SYS_ "*SOURCE-PATHNAME*", SI_SPECIAL, NULL, -1},
{SYS_ "RECORD-SOURCE-PATHNAME", SI_ORDINARY, NULL, -1},
#endif
#ifdef THREADS
@ -1193,10 +1200,10 @@ cl_symbols[] = {
{"SUSPENDED", CL_ORDINARY, NULL, -1},
{"THREAD", CL_ORDINARY, NULL, -1},
{"WAITING", CL_ORDINARY, NULL, -1},
{"SI::THREAD-BREAK-IN", SI_ORDINARY, si_thread_break_in, -1},
{"SI::THREAD-BREAK-QUIT", SI_ORDINARY, si_thread_break_quit, -1},
{"SI::THREAD-BREAK-RESUME", SI_ORDINARY, si_thread_break_resume, -1},
{"SI::THREAD-TOP-LEVEL", SI_ORDINARY, NULL, -1},
{SYS_ "THREAD-BREAK-IN", SI_ORDINARY, si_thread_break_in, -1},
{SYS_ "THREAD-BREAK-QUIT", SI_ORDINARY, si_thread_break_quit, -1},
{SYS_ "THREAD-BREAK-RESUME", SI_ORDINARY, si_thread_break_resume, -1},
{SYS_ "THREAD-TOP-LEVEL", SI_ORDINARY, NULL, -1},
{"MAKE-THREAD", CL_ORDINARY, cl_make_thread, -1},
{"DEACTIVATE", CL_ORDINARY, cl_deactivate, -1},
{"REACTIVATE", CL_ORDINARY, cl_reactivate, -1},
@ -1217,133 +1224,135 @@ cl_symbols[] = {
#endif
#ifdef PROFILE
{"SI::PROFILE", SI_ORDINARY, si_profile, -1},
{"SI::CLEAR-PROFILE", SI_ORDINARY, si_clear_profile, -1},
{"SI::DISPLAY-PROFILE", SI_ORDINARY, si_display_profile, -1},
{SYS_ "PROFILE", SI_ORDINARY, si_profile, -1},
{SYS_ "CLEAR-PROFILE", SI_ORDINARY, si_clear_profile, -1},
{SYS_ "DISPLAY-PROFILE", SI_ORDINARY, si_display_profile, -1},
#endif /* PROFILE */
#ifdef TCP
{"SI::OPEN-CLIENT-STREAM", SI_ORDINARY, si_open_client_stream, 2},
{"SI::OPEN-SERVER-STREAM", SI_ORDINARY, si_open_server_stream, 1},
{"SI::OPEN-UNIX-SOCKET-STREAM", SI_ORDINARY, si_open_unix_socket_stream, 1},
{"SI::LOOKUP-HOST-ENTRY", SI_ORDINARY, si_lookup_host_entry, 1},
{SYS_ "OPEN-CLIENT-STREAM", SI_ORDINARY, si_open_client_stream, 2},
{SYS_ "OPEN-SERVER-STREAM", SI_ORDINARY, si_open_server_stream, 1},
{SYS_ "OPEN-UNIX-SOCKET-STREAM", SI_ORDINARY, si_open_unix_socket_stream, 1},
{SYS_ "LOOKUP-HOST-ENTRY", SI_ORDINARY, si_lookup_host_entry, 1},
#endif
#ifdef unix
{"SI::CATCH-BAD-SIGNALS", SI_ORDINARY, si_catch_bad_signals, 0},
{"SI::UNCATCH-BAD-SIGNALS", SI_ORDINARY, si_uncatch_bad_signals, 0},
{SYS_ "CATCH-BAD-SIGNALS", SI_ORDINARY, si_catch_bad_signals, 0},
{SYS_ "UNCATCH-BAD-SIGNALS", SI_ORDINARY, si_uncatch_bad_signals, 0},
#endif /* unix */
/* KEYWORD PACKAGE */
{":ABORT", KEYWORD, NULL, -1},
{":ABSOLUTE", KEYWORD, NULL, -1},
{":ALLOW-OTHER-KEYS", KEYWORD, NULL, -1},
{":APPEND", KEYWORD, NULL, -1},
{":ARRAY", KEYWORD, NULL, -1},
{":BASE", KEYWORD, NULL, -1},
{":BLOCK", KEYWORD, NULL, -1},
{":CAPITALIZE", KEYWORD, NULL, -1},
{":CASE", KEYWORD, NULL, -1},
{":CATCH", KEYWORD, NULL, -1},
{":CATCHALL", KEYWORD, NULL, -1},
{":CIRCLE", KEYWORD, NULL, -1},
{":COMPILE-TOPLEVEL", KEYWORD, NULL, -1},
{":CREATE", KEYWORD, NULL, -1},
{":DATUM", KEYWORD, NULL, -1},
{":DEFAULT", KEYWORD, NULL, -1},
{":DEFAULTS", KEYWORD, NULL, -1},
{":DEVICE", KEYWORD, NULL, -1},
{":DIRECTION", KEYWORD, NULL, -1},
{":DIRECTORY", KEYWORD, NULL, -1},
{":DOWNCASE", KEYWORD, NULL, -1},
{":ELEMENT-TYPE", KEYWORD, NULL, -1},
{":END", KEYWORD, NULL, -1},
{":END1", KEYWORD, NULL, -1},
{":END2", KEYWORD, NULL, -1},
{":ERROR", KEYWORD, NULL, -1},
{":ESCAPE", KEYWORD, NULL, -1},
{":EXECUTE", KEYWORD, NULL, -1},
{":EXPECTED-TYPE", KEYWORD, NULL, -1},
{":EXTERNAL", KEYWORD, NULL, -1},
{":FORMAT-ARGUMENTS", KEYWORD, NULL, -1},
{":FORMAT-CONTROL", KEYWORD, NULL, -1},
{":FUNCTION", KEYWORD, NULL, -1},
{":GENSYM", KEYWORD, NULL, -1},
{":HOST", KEYWORD, NULL, -1},
{":IF-DOES-NOT-EXIST", KEYWORD, NULL, -1},
{":IF-EXISTS", KEYWORD, NULL, -1},
{":INHERITED", KEYWORD, NULL, -1},
{":INITIAL-ELEMENT", KEYWORD, NULL, -1},
{":INPUT", KEYWORD, NULL, -1},
{":INTERNAL", KEYWORD, NULL, -1},
{":IO", KEYWORD, NULL, -1},
{":JUNK-ALLOWED", KEYWORD, NULL, -1},
{":KEY", KEYWORD, NULL, -1},
{":LENGTH", KEYWORD, NULL, -1},
{":LEVEL", KEYWORD, NULL, -1},
{":LIST-ALL", KEYWORD, NULL, -1},
{":LOAD-TOPLEVEL", KEYWORD, NULL, -1},
{":NAME", KEYWORD, NULL, -1},
{":NEW-VERSION", KEYWORD, NULL, -1},
{":NEWEST", KEYWORD, NULL, -1},
{":NICKNAMES", KEYWORD, NULL, -1},
{":OBJECT", KEYWORD, NULL, -1},
{":OUTPUT", KEYWORD, NULL, -1},
{":OVERWRITE", KEYWORD, NULL, -1},
{":PACKAGE", KEYWORD, NULL, -1},
{":PATHNAME", KEYWORD, NULL, -1},
{":PRETTY", KEYWORD, NULL, -1},
{":PRINT", KEYWORD, NULL, -1},
{":PROBE", KEYWORD, NULL, -1},
{":PROTECT", KEYWORD, NULL, -1},
{":RADIX", KEYWORD, NULL, -1},
{":READABLY", KEYWORD, NULL, -1},
{":REHASH-SIZE", KEYWORD, NULL, -1},
{":REHASH-THRESHOLD", KEYWORD, NULL, -1},
{":RELATIVE", KEYWORD, NULL, -1},
{":RENAME", KEYWORD, NULL, -1},
{":RENAME-AND-DELETE", KEYWORD, NULL, -1},
{":SET-DEFAULT-PATHNAME", KEYWORD, NULL, -1},
{":SIZE", KEYWORD, NULL, -1},
{":START", KEYWORD, NULL, -1},
{":START1", KEYWORD, NULL, -1},
{":START2", KEYWORD, NULL, -1},
{":STREAM", KEYWORD, NULL, -1},
{":SUPERSEDE", KEYWORD, NULL, -1},
{":TAG", KEYWORD, NULL, -1},
{":TEST", KEYWORD, NULL, -1},
{":TEST-NOT", KEYWORD, NULL, -1},
{":TYPE", KEYWORD, NULL, -1},
{":UNSPECIFIC", KEYWORD, NULL, -1},
{":UP", KEYWORD, NULL, -1},
{":UPCASE", KEYWORD, NULL, -1},
{":USE", KEYWORD, NULL, -1},
{":VERBOSE", KEYWORD, NULL, -1},
{":VERSION", KEYWORD, NULL, -1},
{":WILD", KEYWORD, NULL, -1},
{":WILD-INFERIORS", KEYWORD, NULL, -1},
{KEY_ "ABORT", KEYWORD, NULL, -1},
{KEY_ "ABSOLUTE", KEYWORD, NULL, -1},
{KEY_ "ALLOW-OTHER-KEYS", KEYWORD, NULL, -1},
{KEY_ "APPEND", KEYWORD, NULL, -1},
{KEY_ "ARRAY", KEYWORD, NULL, -1},
{KEY_ "BASE", KEYWORD, NULL, -1},
{KEY_ "BLOCK", KEYWORD, NULL, -1},
{KEY_ "CAPITALIZE", KEYWORD, NULL, -1},
{KEY_ "CASE", KEYWORD, NULL, -1},
{KEY_ "CATCH", KEYWORD, NULL, -1},
{KEY_ "CATCHALL", KEYWORD, NULL, -1},
{KEY_ "CIRCLE", KEYWORD, NULL, -1},
{KEY_ "COMPILE-TOPLEVEL", KEYWORD, NULL, -1},
{KEY_ "CREATE", KEYWORD, NULL, -1},
{KEY_ "DATUM", KEYWORD, NULL, -1},
{KEY_ "DEFAULT", KEYWORD, NULL, -1},
{KEY_ "DEFAULTS", KEYWORD, NULL, -1},
{KEY_ "DEVICE", KEYWORD, NULL, -1},
{KEY_ "DIRECTION", KEYWORD, NULL, -1},
{KEY_ "DIRECTORY", KEYWORD, NULL, -1},
{KEY_ "DOWNCASE", KEYWORD, NULL, -1},
{KEY_ "ELEMENT-TYPE", KEYWORD, NULL, -1},
{KEY_ "END", KEYWORD, NULL, -1},
{KEY_ "END1", KEYWORD, NULL, -1},
{KEY_ "END2", KEYWORD, NULL, -1},
{KEY_ "ERROR", KEYWORD, NULL, -1},
{KEY_ "ESCAPE", KEYWORD, NULL, -1},
{KEY_ "EXECUTE", KEYWORD, NULL, -1},
{KEY_ "EXPECTED-TYPE", KEYWORD, NULL, -1},
{KEY_ "EXTERNAL", KEYWORD, NULL, -1},
{KEY_ "FORMAT-ARGUMENTS", KEYWORD, NULL, -1},
{KEY_ "FORMAT-CONTROL", KEYWORD, NULL, -1},
{KEY_ "FUNCTION", KEYWORD, NULL, -1},
{KEY_ "GENSYM", KEYWORD, NULL, -1},
{KEY_ "HOST", KEYWORD, NULL, -1},
{KEY_ "IF-DOES-NOT-EXIST", KEYWORD, NULL, -1},
{KEY_ "IF-EXISTS", KEYWORD, NULL, -1},
{KEY_ "INHERITED", KEYWORD, NULL, -1},
{KEY_ "INITIAL-ELEMENT", KEYWORD, NULL, -1},
{KEY_ "INPUT", KEYWORD, NULL, -1},
{KEY_ "INTERNAL", KEYWORD, NULL, -1},
{KEY_ "IO", KEYWORD, NULL, -1},
{KEY_ "JUNK-ALLOWED", KEYWORD, NULL, -1},
{KEY_ "KEY", KEYWORD, NULL, -1},
{KEY_ "LENGTH", KEYWORD, NULL, -1},
{KEY_ "LEVEL", KEYWORD, NULL, -1},
{KEY_ "LIST-ALL", KEYWORD, NULL, -1},
{KEY_ "LOAD-TOPLEVEL", KEYWORD, NULL, -1},
{KEY_ "NAME", KEYWORD, NULL, -1},
{KEY_ "NEW-VERSION", KEYWORD, NULL, -1},
{KEY_ "NEWEST", KEYWORD, NULL, -1},
{KEY_ "NICKNAMES", KEYWORD, NULL, -1},
{KEY_ "OBJECT", KEYWORD, NULL, -1},
{KEY_ "OUTPUT", KEYWORD, NULL, -1},
{KEY_ "OVERWRITE", KEYWORD, NULL, -1},
{KEY_ "PACKAGE", KEYWORD, NULL, -1},
{KEY_ "PATHNAME", KEYWORD, NULL, -1},
{KEY_ "PRETTY", KEYWORD, NULL, -1},
{KEY_ "PRINT", KEYWORD, NULL, -1},
{KEY_ "PROBE", KEYWORD, NULL, -1},
{KEY_ "PROTECT", KEYWORD, NULL, -1},
{KEY_ "RADIX", KEYWORD, NULL, -1},
{KEY_ "READABLY", KEYWORD, NULL, -1},
{KEY_ "REHASH-SIZE", KEYWORD, NULL, -1},
{KEY_ "REHASH-THRESHOLD", KEYWORD, NULL, -1},
{KEY_ "RELATIVE", KEYWORD, NULL, -1},
{KEY_ "RENAME", KEYWORD, NULL, -1},
{KEY_ "RENAME-AND-DELETE", KEYWORD, NULL, -1},
{KEY_ "SET-DEFAULT-PATHNAME", KEYWORD, NULL, -1},
{KEY_ "SIZE", KEYWORD, NULL, -1},
{KEY_ "START", KEYWORD, NULL, -1},
{KEY_ "START1", KEYWORD, NULL, -1},
{KEY_ "START2", KEYWORD, NULL, -1},
{KEY_ "STREAM", KEYWORD, NULL, -1},
{KEY_ "SUPERSEDE", KEYWORD, NULL, -1},
{KEY_ "TAG", KEYWORD, NULL, -1},
{KEY_ "TEST", KEYWORD, NULL, -1},
{KEY_ "TEST-NOT", KEYWORD, NULL, -1},
{KEY_ "TYPE", KEYWORD, NULL, -1},
{KEY_ "UNSPECIFIC", KEYWORD, NULL, -1},
{KEY_ "UP", KEYWORD, NULL, -1},
{KEY_ "UPCASE", KEYWORD, NULL, -1},
{KEY_ "USE", KEYWORD, NULL, -1},
{KEY_ "VERBOSE", KEYWORD, NULL, -1},
{KEY_ "VERSION", KEYWORD, NULL, -1},
{KEY_ "WILD", KEYWORD, NULL, -1},
{KEY_ "WILD-INFERIORS", KEYWORD, NULL, -1},
#ifdef GBC_BOEHM
{"SI::GC", SI_ORDINARY, si_gc, 1},
{"SI::GC-DUMP", SI_ORDINARY, si_gc_dump, 0},
{SYS_ "GC", SI_ORDINARY, si_gc, 1},
{SYS_ "GC-DUMP", SI_ORDINARY, si_gc_dump, 0},
#endif
#if !defined(GBC_BOEHM)
{"SI::GC", SI_ORDINARY, si_gc, 1},
{"SI::ALLOCATE", SI_ORDINARY, si_allocate, -1},
{"SI::ALLOCATED-PAGES", SI_ORDINARY, si_allocated_pages, -1},
{"SI::MAXIMUM-ALLOCATABLE-PAGES", SI_ORDINARY, si_maximum_allocatable_pages, -1},
{"SI::ALLOCATE-CONTIGUOUS-PAGES", SI_ORDINARY, si_allocate_contiguous_pages, -1},
{"SI::ALLOCATED-CONTIGUOUS-PAGES", SI_ORDINARY, si_allocated_contiguous_pages, -1},
{"SI::MAXIMUM-CONTIGUOUS-PAGES", SI_ORDINARY, si_maximum_contiguous_pages, -1},
{"SI::GC-TIME", SI_ORDINARY, si_gc_time, -1},
{"SI::GET-HOLE-SIZE", SI_ORDINARY, si_get_hole_size, -1},
{"SI::SET-HOLE-SIZE", SI_ORDINARY, si_set_hole_size, -1},
{"SI::IGNORE-MAXIMUM-PAGES", SI_ORDINARY, si_ignore_maximum_pages, -1},
{"SI::ROOM-REPORT", SI_ORDINARY, si_room_report, -1},
{"SI::RESET-GC-COUNT", SI_ORDINARY, si_reset_gc_count, -1},
{SYS_ "GC", SI_ORDINARY, si_gc, 1},
{SYS_ "ALLOCATE", SI_ORDINARY, si_allocate, -1},
{SYS_ "ALLOCATED-PAGES", SI_ORDINARY, si_allocated_pages, -1},
{SYS_ "MAXIMUM-ALLOCATABLE-PAGES", SI_ORDINARY, si_maximum_allocatable_pages, -1},
{SYS_ "ALLOCATE-CONTIGUOUS-PAGES", SI_ORDINARY, si_allocate_contiguous_pages, -1},
{SYS_ "ALLOCATED-CONTIGUOUS-PAGES", SI_ORDINARY, si_allocated_contiguous_pages, -1},
{SYS_ "MAXIMUM-CONTIGUOUS-PAGES", SI_ORDINARY, si_maximum_contiguous_pages, -1},
{SYS_ "GC-TIME", SI_ORDINARY, si_gc_time, -1},
{SYS_ "GET-HOLE-SIZE", SI_ORDINARY, si_get_hole_size, -1},
{SYS_ "SET-HOLE-SIZE", SI_ORDINARY, si_set_hole_size, -1},
{SYS_ "IGNORE-MAXIMUM-PAGES", SI_ORDINARY, si_ignore_maximum_pages, -1},
{SYS_ "ROOM-REPORT", SI_ORDINARY, si_room_report, -1},
{SYS_ "RESET-GC-COUNT", SI_ORDINARY, si_reset_gc_count, -1},
#endif /* !GBC_BOEHM */
{SYS_ "VALID-FUNCTION-NAME-P", SI_ORDINARY, si_valid_function_name_p, 1},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1}};

2
src/clos/builtin.lsp
View file

@ -191,8 +191,8 @@
(list sequence)
(cons list)
(array t)
(string array sequence)
(vector array sequence)
(string vector)
(bit-vector vector)
(stream t)
(file-stream stream)

1
src/clos/conditions.lsp
View file

@ -377,7 +377,6 @@ strings."
(dolist (handler cluster)
(when (typep condition (car handler))
(funcall (cdr handler) condition)
(return nil) ;?
))))
nil))

6
src/clos/generic.lsp
View file

@ -61,9 +61,10 @@
;)
)))))
#|
(defmacro generic-function (&rest args)
(multiple-value-bind (lambda-list options)
(parse--generic-function args)
(parse-generic-function args)
(parse-lambda-list lambda-list)
;; process options
@ -92,6 +93,7 @@
;; add methods specified by defgeneric
;)
gf-object)))))
|#
;;; ----------------------------------------------------------------------
;;; parsing
@ -112,12 +114,14 @@
(error "Illegal defgeneric form: missing lambda-list"))
(values function-specifier (first args) (rest args))))
#|
(defun parse-generic-function (args)
(declare (si::c-local))
;; (values lambda-list options)
(unless args
(error "Illegal generic-function form: missing lambda-list"))
(values (first args) (rest args)))
|#
(defun parse-generic-options (options lambda-list)
(declare (si::c-local))

2
src/clos/macros.lsp
View file

@ -56,7 +56,7 @@
(defun legal-class-name-p (x)
(and (symbolp x)
(not (keywordp x))))
#+nil(not (keywordp x))))
;;; ----------------------------------------------------------------------

2
src/clos/method.lsp
View file

@ -421,7 +421,7 @@
;;; parsing
(defun legal-generic-function-name-p (name)
(or (symbolp name) (si:setf-namep name)))
(si::valid-function-name-p name))
(defun parse-defmethod (args)
(declare (si::c-local))

50
src/cmp/cmpcall.lsp
View file

@ -45,7 +45,7 @@
(let ((x (c1expr fun)) (info (make-info :sp-change t)))
(add-info info (second x))
(list 'ORDINARY info x)))
((symbolp (setq function (second fun)))
((si::valid-function-name-p (setq function (second fun)))
(or (c1call-local function)
(list 'GLOBAL
(make-info :sp-change
@ -63,12 +63,8 @@
(consp (rest function)))
;; Don't create closure boundary like in c1function
;; since funob is used in this same environment
(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)))
(let* ((block-name (second function)))
(let ((lambda-expr (c1lambda-expr (cddr function) block-name)))
(list 'LAMBDA (second lambda-expr) lambda-expr (next-cfun)))))
(t (cmperr "Malformed function: ~A" fun))))
@ -228,7 +224,7 @@
(if (and (inline-possible fname)
(not (eq 'ARGS-PUSHED args))
*tail-recursion-info*
(eq (first *tail-recursion-info*) fname)
(same-fname-p (first *tail-recursion-info*) fname)
(last-call-p)
(tail-recursion-possible)
(= (length args) (length (cdr *tail-recursion-info*))))
@ -275,7 +271,8 @@
(cond
;; It is not possible to inline the function call
((not (inline-possible fname))
(if *compile-to-linking-call*
;; We can only emit linking calls when function name is a symbol.
(if (and (symbolp fname) *compile-to-linking-call*)
(emit-linking-call fname locs narg)
(c2call-unknown-global fname locs loc t narg)))
@ -286,7 +283,7 @@
(unwind-exit (fix-loc loc)))
;; Call to a function defined in the same file.
((setq fd (assoc fname *global-funs*))
((setq fd (assoc fname *global-funs* :test #'same-fname-p))
(let ((cfun (second fd)))
(unwind-exit (call-loc fname
(if (numberp cfun)
@ -297,8 +294,9 @@
;; Call to a function whose C language function name is known,
;; either because it has been proclaimed so, or because it belongs
;; to the runtime.
((or (setq maxarg -1 fd (get-sysprop fname 'Lfun))
(multiple-value-setq (found fd maxarg) (si::mangle-name fname t)))
((and (symbolp fname)
(or (setq maxarg -1 fd (get-sysprop fname 'Lfun))
(multiple-value-setq (found fd maxarg) (si::mangle-name fname t))))
(multiple-value-bind (val found)
(gethash fd *compiler-declared-globals*)
;; We only write declarations for functions which are not
@ -311,8 +309,9 @@
(call-loc fname fd locs narg)
(call-loc-fixed fname fd locs narg maxarg))))
;; Linking call
(*compile-to-linking-call* ; disabled within init_code
;; Linking calls can only be made to symbols
((and (symbolp fname)
*compile-to-linking-call*) ; disabled within init_code
(emit-linking-call fname locs narg))
(t (c2call-unknown-global fname locs loc t narg)))
@ -324,14 +323,14 @@
(case (first funob)
((LAMBDA LOCAL))
(GLOBAL
(unless (and (inline-possible (third funob))
(or (get-sysprop (third funob) 'Lfun)
(assoc (third funob) *global-funs*)))
(let ((temp (list 'TEMP (next-temp))))
(if *safe-compile*
(wt-nl temp "=symbol_function(" (add-symbol (third funob)) ");")
(wt-nl temp "=" (add-symbol (third funob)) "->symbol.gfdef;"))
temp)))
(let ((fun-name (third funob)))
(unless (and (inline-possible fun-name)
(or (and (symbolp fun-name) (get-sysprop fun-name 'Lfun))
(assoc fun-name *global-funs* :test #'same-fname-p)))
(let* ((temp (list 'TEMP (next-temp)))
(fdef (list 'FDEFINITION fun-name)))
(wt-nl temp "=" fdef ";")
temp))))
(ORDINARY (let* ((temp (list 'TEMP (next-temp)))
(*destination* temp))
(c2expr* (third funob))
@ -390,12 +389,7 @@
;;;
(defun c2call-unknown-global (fname args loc inline-p narg)
(unless loc
(setq loc
(if *compiler-push-events*
(add-symbol fname)
(format nil
(if *safe-compile* "symbol_function(~A)" "~A->symbol.gfdef")
(add-symbol fname)))))
(setq loc (list 'FDEFINITION fname)))
(unwind-exit
(if (eq args 'ARGS-PUSHED)
(list 'CALL "cl_apply_from_stack" narg (list loc) fname)

47
src/cmp/cmpenv.lsp
View file

@ -63,32 +63,12 @@
(defun add-symbol (symbol)
(add-object symbol))
#+nil
(defun add-keywords (keywords)
;; We have to build, in the vector VV[], a sequence with all
;; the keywords that this function uses. It does not matter
;; whether the same keywords appeared before, because
;; cl_parse_key() needs the whole list. However, we can optimize
;; the case of a single keyword, reusing the value of a previous
;; occurrence.
(let ((x (assoc keywords *keywords* :test #'equalp)))
(cond (x
(second x))
((and (setq x (assoc (first keywords) *objects*))
(= (length keywords) 1))
(second x))
(t
(flet ((add-keyword (keyword)
(let ((x (format nil "VV[~d]" (incf *next-vv*))))
(push (list keyword x *next-vv*) *objects*)
(wt-data keyword)
x)))
(setq x (add-keyword (first keywords)))
(dolist (k keywords)
(add-keyword k))
x)))))
(defun add-keywords (keywords)
;; whether each keyword has appeared separately before, because
;; cl_parse_key() needs the whole list. However, we can reuse
;; keywords lists from other functions when they coincide with ours.
(flet ((add-keyword (keyword &aux x)
(incf *next-vv*)
(setq x (format nil "VV[~d]" *next-vv*))
@ -98,10 +78,17 @@
(wt-data keyword)))
(push (list keyword x *next-vv*) *objects*)
x))
(let ((x (add-keyword (first keywords))))
(dolist (k (rest keywords))
(add-keyword k))
x)))
;; We search for keyword lists that are similar. However, the list
;; *OBJECTS* contains elements in decreasing order!!!
(let ((x (search (reverse keywords) *objects*
:test #'(lambda (k rec) (eq k (first rec))))))
(if x
(progn
(cmpnote "Reusing keywords lists for ~S" keywords)
(second (elt *objects* (+ x (length keywords) -1))))
(let ((x (add-keyword (first keywords))))
(dolist (k (rest keywords) x)
(add-keyword k))))))))
(defun add-object (object &aux x found)
(cond ((setq x (assoc object *objects* :test 'equalp))
@ -206,9 +193,9 @@
;;; Proclamation and declaration handling.
(defun inline-possible (fname)
(not (or ; *compiler-push-events*
(member fname *notinline*)
(get-sysprop fname 'CMP-NOTINLINE))))
(not (or ; *compiler-push-events*
(member fname *notinline* :test #'same-fname-p)
(and (symbolp fname) (get-sysprop fname 'CMP-NOTINLINE)))))
#-:CCL
(defun proclaim (decl)

5
src/cmp/cmpeval.lsp
View file

@ -38,12 +38,9 @@
setf-symbol)
(cond ((symbolp fun)
(c1call-symbol fun (cdr form)))
;; #+cltl2
((setq setf-symbol (si::setf-namep fun))
(c1call-symbol setf-symbol (cdr form)))
((and (consp fun) (eq (car fun) 'LAMBDA))
(c1call-lambda (cdr fun) (cdr form)))
(t (cmperr "The function ~s is illegal." fun)))))
(t (cmperr "~s is not a legal function name." fun)))))
(t (c1constant-value form t)))))
(if (eq form '*cmperr-tag*) (c1nil) form))

23
src/cmp/cmpflet.lsp
View file

@ -38,7 +38,7 @@
(let ((*funs* *funs*))
(dolist (def (car args))
(cmpck (or (endp def)
(not (symbolp (car def)))
(not (si::valid-function-name-p (car def)))
(endp (cdr def)))
"The function definition ~s is illegal." def)
(let ((fun (make-fun :name (car def))))
@ -62,7 +62,8 @@
(*vars* (cons CB/LB *vars*))
(*blocks* (cons CB/LB *blocks*))
(*tags* (cons CB/LB *tags*)))
(c1lambda-expr (second def) (fun-name fun))))
(c1lambda-expr (second def)
(si::function-block-name (fun-name fun)))))
(add-info info (second lam) CB/LB)
(push (list fun lam) local-funs)
(setf (fun-cfun fun) (next-cfun)))))
@ -156,7 +157,9 @@
;;; bind local-functions
(dolist (def (car args))
(cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def)))
(cmpck (or (endp def)
(not (si::valid-function-name-p (car def)))
(endp (cdr def)))
"The local function definition ~s is illegal." def)
(cmpck (member (car def) fnames)
"The function ~s was already defined." (car def))
@ -189,7 +192,8 @@
(*funs* (cons 'LB *funs*))
(*blocks* (cons 'LB *blocks*))
(*tags* (cons 'LB *tags*)))
(let ((lam (c1lambda-expr (third def) (fun-name fun))))
(let ((lam (c1lambda-expr (third def)
(si::function-block-name (fun-name fun)))))
(add-info info (second lam) 'LB)
(push (list fun lam) local-funs)))
(setf (second def) T)))
@ -211,7 +215,8 @@
(*funs* (cons 'CB *funs*))
(*blocks* (cons 'CB *blocks*))
(*tags* (cons 'CB *tags*)))
(let ((lam (c1lambda-expr (third def) (fun-name fun))))
(let ((lam (c1lambda-expr (third def)
(si::function-block-name (fun-name fun)))))
(add-info info (second lam) 'CB)
(push (list fun lam) local-funs)))
(setf (car def) NIL))) ; def processed
@ -257,10 +262,10 @@
(dolist (fun *funs*)
(cond ((eq fun 'CB) (setq ccb t))
((eq fun 'LB) (setq clb t))
((consp fun) ; macro
((and (symbolp fname) (consp fun)) ; macro
(when (eq fname (car fun))
(return nil)))
((eq (fun-name fun) fname)
((same-fname-p (fun-name fun) fname)
(incf (fun-ref fun))
;; we introduce a variable to hold the funob
(let ((var (or (fun-var fun)
@ -286,7 +291,7 @@
(dolist (fun *funs* fname)
(when (and (not (eq fun 'CB))
(not (consp fun))
(eq (fun-name fun) fname))
(same-fname-p (fun-name fun) fname))
(return fun))))
(defun sch-local-macro (fname)
@ -306,7 +311,7 @@
(cond
((and (listp args)
*tail-recursion-info*
(eq (car *tail-recursion-info*) (fun-name fun))
(same-fname-p (car *tail-recursion-info*) (fun-name fun))
(eq *exit* 'RETURN)
(tail-recursion-possible)
(= (length args) (length (cdr *tail-recursion-info*))))

15
src/cmp/cmplam.lsp
View file

@ -133,8 +133,7 @@
(defun c2lambda-expr (lambda-list body cfun fname
&optional closure-p call-lambda)
(let ((*tail-recursion-info* ;;; Tail recursion possible if
(and fname (symbolp fname) ;;; named function (a list is used for
;;; lambda-block's),
(and fname ;;; named function
;;; no required appears in closure,
(dolist (var (car lambda-list) t)
(declare (type var var))
@ -424,8 +423,11 @@
(wt-nl "narg -= i;")
(wt-nl "narg -=" nreq ";"))
(wt-nl "{ cl_object keyvars[" (* 2 nkey) "];")
(wt-nl "cl_parse_key(args," nkey ",L" cfun "keys,keyvars")
(cond (keywords
(wt-nl "{ cl_object keyvars[" (* 2 nkey) "];")
(wt-nl "cl_parse_key(args," nkey ",L" cfun "keys,keyvars"))
(t
(wt-nl "cl_parse_key(args,0,NULL,NULL")))
(if rest (wt ",&" rest-loc) (wt ",NULL"))
(wt (if allow-other-keys ",TRUE);" ",FALSE);"))
(when rest (bind rest-loc rest))
@ -436,7 +438,9 @@
(KEYVARS[i] `(KEYVARS 0))
(i 0 (1+ i)))
((endp kwd)
(wt-h "#define L" cfun "keys (&" (add-keywords (nreverse all-kwd)) ")"))
(when all-kwd
(wt-h "#define L" cfun "keys (&" (add-keywords (nreverse all-kwd)) ")")
(wt-nl "}")))
(declare (fixnum i))
(push (first kwd) all-kwd)
(let ((key (first kwd))
@ -461,7 +465,6 @@
(when flag
(setf (second KEYVARS[i]) (+ nkey i))
(bind KEYVARS[i] flag))))
(wt-nl "}")
;;; Now the parameters are ready, after all!
(c2expr body)

2
src/cmp/cmploc.lsp
View file

@ -31,7 +31,7 @@
;;; ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs )
;;; ( 'CAR' lcl )
;;; ( 'CADR' lcl )
;;; ( 'SYMBOL-FUNCTION' vv-index )
;;; ( 'FDEFINITION' vv-index )
;;; ( 'MAKE-CCLOSURE' cfun )
;;; ( 'FIXNUM-VALUE' fixnum-value )
;;; ( 'CHARACTER-VALUE' character-code )

2
src/cmp/cmpmac.lsp
View file

@ -4,6 +4,8 @@
(in-package "COMPILER")
(import 'sys::arglist "COMPILER")
(defun same-fname-p (name1 name2) (equal name1 name2))
;;; from cmpenv.lsp
(defmacro next-cmacro () '(incf *next-cmacro*))
(defmacro next-cfun () '(incf *next-cfun*))

4
src/cmp/cmpmain.lsp
View file

@ -492,8 +492,8 @@ Cannot compile ~a."
&aux def disassembled-form
(*compiler-in-use* *compiler-in-use*)
(*print-pretty* nil))
(when (or (symbolp thing) (si::setf-namep thing))
(setq thing (eval `(function ,thing))))
(when (si::valid-function-name-p thing)
(setq thing (fdefinition thing)))
(cond ((null thing))
((functionp thing)
(unless (si::bc-disassemble thing)

32
src/cmp/cmpspecial.lsp
View file

@ -75,17 +75,17 @@
(*funs* (cons 'CB *funs*))
(*blocks* (cons 'CB *blocks*))
(*tags* (cons 'CB *tags*)))
(setq fun (or (si:setf-namep fun) fun))
(cond ((symbolp fun)
(cond ((si::valid-function-name-p fun)
(let ((funob (local-closure fun)))
(if funob
(let ((vars (list (fun-var funob))))
(let* ((vars (list (fun-var funob))))
(incf (var-ref (fun-var funob)))
(list 'VAR (make-info :referred-vars vars
:local-referred vars)
vars))
`(FUNCTION ,(make-info :sp-change
(not (get-sysprop fun 'NO-SP-CHANGE)))
`(FUNCTION ,(make-info :sp-change
(not (and (symbolp fun)
(get-sysprop fun 'NO-SP-CHANGE))))
GLOBAL nil ,fun))))
((and (consp fun) (eq (car fun) 'LAMBDA))
(cmpck (endp (cdr fun))
@ -94,12 +94,7 @@
(info (second funob))
(closure (closure-p funob))
(body (cddr fun))
(fun (make-fun :name
(when (and (consp body)
(null (cdr body))
(consp (first body))
(eq 'BLOCK (first (first body))))
(list (second (first body))))
(fun (make-fun :name NIL
:cfun (next-cfun)
:closure closure)))
(if closure
@ -115,7 +110,7 @@
(funob (c1lambda-expr (cddr fun) name))
(info (second funob))
(closure (closure-p funob))
(fun (make-fun :name (list name)
(fun (make-fun :name NIL
:cfun (next-cfun)
:closure closure)))
(if closure
@ -129,7 +124,7 @@
(defun c2function (kind funob fun)
(case kind
(GLOBAL
(unwind-exit (list 'SYMBOL-FUNCTION (add-symbol fun))))
(unwind-exit (list 'FDEFINITION fun)))
(CLOSURE
(setf (fun-closure fun) (> *env* 0))
(new-local 0 fun funob) ; 0 was *level*
@ -161,10 +156,11 @@
(push (list closure fun funob) *local-funs*)
NIL))))
(defun wt-symbol-function (vv)
(if *safe-compile*
(wt "symbol_function(" vv ")")
(wt "(" vv "->symbol.gfdef)")))
(defun wt-fdefinition (fun-name)
(let ((vv (add-object fun-name)))
(if (and (symbolp fun-name) (not *safe-compile*))
(wt "(" vv "->symbol.gfdef)")
(wt "ecl_fdefinition(" vv ")"))))
(defun wt-make-closure (fun &aux (cfun (fun-cfun fun)))
(declare (type fun fun))
@ -185,5 +181,5 @@
(put-sysprop 'compiler-let 'c1special 'c1compiler-let)
(put-sysprop 'compiler-let 'c2 'c2compiler-let)
(put-sysprop 'symbol-function 'wt-loc 'wt-symbol-function)
(put-sysprop 'fdefinition 'wt-loc 'wt-fdefinition)
(put-sysprop 'make-cclosure 'wt-loc 'wt-make-closure)

28
src/cmp/cmptop.lsp
View file

@ -43,9 +43,6 @@
(t1expr* (cmp-expand-macro (third fd) fun (cdr form))))
(t (t1ordinary form))
))
;; #+cltl2
((setq setf-symbol (si::setf-namep fun))
(t1ordinary form))
((consp fun) (t1ordinary form))
(t (cmperr "~s is illegal function." fun)))
))))
@ -221,14 +218,12 @@
(mapcar #'t3expr args))
(defun exported-fname (name)
(or (get-sysprop name 'Lfun)
(or (and (symbolp name) (get-sysprop name 'Lfun))
(next-cfun)))
(defun t1defun (args &aux (setjmps *setjmps*))
(when (or (endp args) (endp (cdr args)))
(too-few-args 'defun 2 (length args)))
(when (not (symbolp (car args)))
(return-from t1defun (t1expr* (macroexpand (cons 'defun args)))))
(when *compile-time-too* (cmp-eval (cons 'DEFUN args)))
(let* (lambda-expr
(fname (car args))
@ -237,7 +232,7 @@
(doc nil)
output)
(setq lambda-expr (c1lambda-expr (cdr args) fname))
(setq lambda-expr (c1lambda-expr (cdr args) (si::function-block-name fname)))
(unless (eql setjmps *setjmps*)
(setf (info-volatile (second lambda-expr)) t))
(multiple-value-bind (decl body doc)
@ -250,6 +245,7 @@
(setq output (new-defun fname cfun lambda-expr *special-binding* no-entry))
(when
(and
(symbolp fname)
(get-sysprop fname 'PROCLAIMED-FUNCTION)
(let ((lambda-list (third lambda-expr)))
(declare (list lambda-list))
@ -282,9 +278,10 @@
output))
;;; Mechanism for sharing code:
;;; FIXME! Revise this 'DEFUN stuff.
(defun new-defun (fname cfun lambda-expr special-binding &optional no-entry)
(let ((previous (dolist (form *global-funs*)
(when (and (eq 'DEFUN (car form))
(when (and #+nil(eq 'DEFUN (car form))
(equal special-binding (fifth form))
(similar lambda-expr (third form)))
(return (second form))))))
@ -336,11 +333,11 @@
(declare (ignore sp funarg-vars))
(if no-entry
(return-from t2defun nil))
(let ((vv (add-symbol fname)))
(let ((vv (add-object fname)))
(if (numberp cfun)
(wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)L" cfun ");")
(wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)" cfun ");"))
(when (get-sysprop fname 'PROCLAIMED-FUNCTION)
(when (and (symbolp fname) (get-sysprop fname 'PROCLAIMED-FUNCTION))
(wt-if-proclaimed fname cfun vv lambda-expr))))
(defun t3defun (fname cfun lambda-expr sp funarg-vars no-entry
@ -358,9 +355,7 @@
requireds (car lambda-list))
(analyze-regs (info-referred-vars (second lambda-expr)))
(if (dolist (v *inline-functions*)
(and (eq (car v) fname)
(return (setq inline-info v))))
(if (setq inline-info (assoc fname *inline-functions* :test #'same-fname-p))
;; Local entry
(let* ((*exit* (case (third inline-info)
@ -518,7 +513,8 @@
(analyze-regs1 data *free-data-registers*))))
(defun wt-global-entry (fname cfun arg-types return-type)
(when (get-sysprop fname 'NO-GLOBAL-ENTRY) (return-from wt-global-entry nil))
(when (and (symbolp fname) (get-sysprop fname 'NO-GLOBAL-ENTRY))
(return-from wt-global-entry nil))
(wt-comment "global entry for the function " fname)
(wt-nl1 "static cl_object L" cfun "(int narg")
(wt-h "static cl_object L" cfun "(int")
@ -761,9 +757,7 @@
(fourth lambda-list))))
(declare (fixnum level nenvs))
(wt-comment (if (fun-closure fun) "closure " "local function ")
(let ((name (fun-name fun)))
;; a list is used for lambda-block's
(if (symbolp name) (or name 'CLOSURE) (first name))))
(or (fun-name fun) 'CLOSURE))
(wt-h "static cl_object LC" (fun-cfun fun) "(")
(wt-nl1 "static cl_object LC" (fun-cfun fun) "(")
(wt-h1 "int")

12
src/cmp/cmpwt.lsp
View file

@ -20,19 +20,21 @@
;;; rest of it. This way it is possible to save some space by writing the
;;; symbol's package only when it does not belong to the current package.
(defun wt-comment (message &optional symbol)
(if symbol
(defun wt-comment (message &optional extra)
(if extra
;; Message is a prefix string for EXTRA. All fits in a single line.
(progn
(terpri *compiler-output1*)
(princ "/* " *compiler-output1*)
(princ message *compiler-output1*))
(if (symbol-package message)
;; Message is a symbol.
(if (or (not (symbolp message)) (symbol-package message))
(progn
(format *compiler-output1* "~50T/* ")
(setq symbol message))
(setq extra message))
;; useless to show gensym's
(return-from wt-comment)))
(let* ((s (symbol-name symbol))
(let* ((s (if (symbolp extra) (symbol-name extra) (format nil "~A" extra)))
(l (1- (length s)))
c)
(declare (string s) (fixnum l) (character c))

36
src/cmp/sysfun.lsp
View file

@ -180,7 +180,7 @@
(ARRAY-TOTAL-SIZE (array) T nil nil
:inline-unsafe ((t) fixnum nil nil "((#0)->string.dim)"))
(ADJUSTABLE-ARRAY-P (array) T nil t)
(si::DISPLACED-ARRAY-P (array) T nil t)
(ARRAY-DISPLACEMENT (array) (VALUES T FIXNUM) nil t)
(SVREF (simple-vector fixnum) T nil nil
:inline-always ((t t) t nil t "aref1(#0,fixint(#1))")
:inline-always ((t fixnum) t nil t "aref1(#0,#1)")
@ -455,18 +455,18 @@
:inline-unsafe ((t t) t nil nil "nthcdr(fix(#0),#1)")
:inline-unsafe ((fixnum t) t nil nil "nthcdr(#0,#1)"))
(LAST (T) T)
(LIST (*) T NIL NIL
(LIST (*) LIST NIL NIL
:inline-always (nil t nil nil "Cnil")
:inline-always ((t) t nil t "CONS(#0,Cnil)"))
(LIST* (T *) T NIL NIL
(LIST* (T *) LIST NIL NIL
:inline-always ((t) t nil nil "#0")
:inline-always ((t t) t nil t "CONS(#0,#1)"))
(MAKE-LIST (fixnum *) T)
(APPEND (*) T NIL NIL
:inline-always ((t t) t nil t "append(#0,#1)"))
(COPY-LIST (T) T)
(COPY-ALIST (T) T)
(COPY-TREE (T) T)
(COPY-LIST (T) LIST)
(COPY-ALIST (T) LIST)
(COPY-TREE (T) LIST)
(REVAPPEND (T T) T)
(NCONC (*) T NIL NIL
:inline-always ((t t) t t nil "nconc(#0,#1)"))
@ -474,8 +474,8 @@
(BUTLAST (T *) T)
(NBUTLAST (T *) T)
(LDIFF (T T) T)
(RPLACA (cons T) T)
(RPLACD (cons T) T)
(RPLACA (cons T) CONS)
(RPLACD (cons T) CONS)
(SUBST (T T T *) T)
(SUBST-IF (T T T *) T)
(SUBST-IF-NOT (T T T *) T)
@ -492,12 +492,12 @@
(ADJOIN (T T *) T)
(ACONS (T T T) T)
(PAIRLIS (T T *) T)
(ASSOC (T T *) T)
(ASSOC-IF (T T) T)
(ASSOC-IF-NOT (T T) T)
(RASSOC (T T *) T)
(RASSOC-IF (T T) T)
(RASSOC-IF-NOT (T T) T)
(ASSOC (T T *) LIST)
(ASSOC-IF (T T) LIST)
(ASSOC-IF-NOT (T T) LIST)
(RASSOC (T T *) LIST)
(RASSOC-IF (T T) LIST)
(RASSOC-IF-NOT (T T) LIST)
(si::MEMQ (T T T) T)
; file lwp.c
@ -842,8 +842,7 @@ type_of(#0)==t_bitvector"))
(GET-DISPATCH-MACRO-CHARACTER nil T)
(SI::STRING-TO-OBJECT (T) T)
(si::STANDARD-READTABLE (T) T)
(SYMBOL-FUNCTION (T) T NIL NIL
:inline-always ((t) t nil t "symbol_function(#0)"))
(SYMBOL-FUNCTION (T) T NIL NIL)
(FBOUNDP (symbol) T nil t)
(SYMBOL-VALUE (symbol) T)
(BOUNDP (symbol) T nil t
@ -935,7 +934,7 @@ type_of(#0)==t_bitvector"))
; file structure.d
(si::MAKE-STRUCTURE (T *) T)
(si::COPY-STRUCTURE (T T) T)
(COPY-STRUCTURE (T) T)
(SI::STRUCTURE-NAME (T) SYMBOL NIL NIL
:inline-always ((structure) symbol nil nil "SNAME(#0)"))
(si::STRUCTURE-REF (t t fixnum) T nil nil
@ -1030,9 +1029,6 @@ type_of(#0)==t_bitvector"))
#+clos
(mapcar #'(lambda (x) (apply #'defsysfun x)) '(
; file setf.c
(si::SETF-NAMEP nil T nil t)
; file instance.c
(si::ALLOCATE-RAW-INSTANCE (t fixnum) T)
(si::INSTANCE-REF (t fixnum) T nil nil

13
src/h/external.h
View file

@ -92,7 +92,7 @@ extern cl_object cl_array_rank(cl_object a);
extern cl_object cl_array_dimension(cl_object a, cl_object index);
extern cl_object cl_array_total_size(cl_object a);
extern cl_object cl_adjustable_array_p(cl_object a);
extern cl_object si_displaced_array_p(cl_object a);
extern cl_object cl_array_displacement(cl_object a);
extern cl_object cl_svref(cl_object x, cl_object index);
extern cl_object si_svset(cl_object x, cl_object index, cl_object v);
extern cl_object cl_array_has_fill_pointer_p(cl_object a);
@ -118,7 +118,6 @@ extern void init_array(void);
/* assignment.c */
extern cl_object cl_set(cl_object var, cl_object val);
extern cl_object si_setf_namep(cl_object arg);
extern cl_object cl_makunbound(cl_object sym);
extern cl_object cl_fmakunbound(cl_object sym);
extern cl_object si_fset _ARGS((int narg, cl_object fun, cl_object def, ...));
@ -126,7 +125,6 @@ extern cl_object si_get_sysprop(cl_object sym, cl_object prop);
extern cl_object si_put_sysprop(cl_object sym, cl_object prop, cl_object value);
extern cl_object si_rem_sysprop(cl_object sym, cl_object prop);
extern cl_object setf_namep(cl_object fun_spec);
extern void clear_compiler_properties(cl_object sym);
extern void init_assignment(void);
@ -250,6 +248,7 @@ extern cl_object si_process_lambda_list(cl_object lambda_list, cl_object context
extern cl_object si_process_lambda(cl_object lambda);
extern cl_object si_make_lambda(cl_object name, cl_object body);
extern cl_object si_function_block_name(cl_object name);
extern cl_object si_valid_function_name_p(cl_object name);
extern cl_object si_process_declarations _ARGS((int narg, cl_object body, ...));
extern cl_object make_lambda(cl_object name, cl_object lambda);
@ -308,6 +307,7 @@ extern void FEinvalid_variable(char *s, cl_object obj) __attribute__((noreturn,r
extern void FEassignment_to_constant(cl_object v) __attribute__((noreturn,regparm(2)));
extern void FEundefined_function(cl_object fname) __attribute__((noreturn,regparm(2)));
extern void FEinvalid_function(cl_object obj) __attribute__((noreturn,regparm(2)));
extern void FEinvalid_function_name(cl_object obj) __attribute__((noreturn,regparm(2)));
extern cl_object CEerror(char *err_str, int narg, ...);
extern void illegal_index(cl_object x, cl_object i);
extern void FEtype_error_symbol(cl_object obj) __attribute__((noreturn,regparm(2)));
@ -485,7 +485,7 @@ extern cl_object si_sl_makunbound(cl_object x, cl_object index);
extern cl_object ecl_allocate_instance(cl_object clas, int size);
extern cl_object instance_ref(cl_object x, int i);
extern cl_object instance_set(cl_object x, int i, cl_object v);
extern void init_instance(void);
extern cl_object ecl_copy_instance(cl_object x);
#endif /* CLOS */
@ -1054,8 +1054,7 @@ extern cl_object cl_boundp(cl_object sym);
extern cl_object cl_special_operator_p(cl_object form);
extern cl_object cl_macro_function _ARGS((int narg, cl_object sym, ...));
extern cl_object symbol_function(cl_object sym);
extern cl_object ecl_fdefinition(cl_object fname);
/* sequence.c */
@ -1147,7 +1146,7 @@ extern void get_string_start_end(cl_object s, cl_object start, cl_object end, cl
/* structure.c */
extern cl_object si_structure_subtype_p(cl_object x, cl_object y);
extern cl_object si_copy_structure(cl_object x);
extern cl_object cl_copy_structure(cl_object s);
extern cl_object si_structure_name(cl_object s);
extern cl_object si_structure_ref(cl_object x, cl_object type, cl_object index);
extern cl_object si_structure_set(cl_object x, cl_object type, cl_object index, cl_object val);

14
src/lsp/assert.lsp
View file

@ -27,12 +27,18 @@ value is used to indicate the expected type in the error message."
(tagbody ,tag2
(if (typep ,place ',type) (return-from ,tag1 nil))
(restart-case ,(if type-string
`(error "The value of ~S is ~S, ~
`(error 'SIMPLE-TYPE-ERROR
:FORMAT-CONTROL "The value of ~S is ~S, ~
which is not ~A."
',place ,place ,type-string)
`(error "The value of ~S is ~S, ~
:FORMAT-ARGUMENTS (list ',place ,place, type-string)
:DATUM ,place
:EXPECTED-TYPE ',type)
`(error 'SIMPLE-TYPE-ERROR
:FORMAT-CONTROL "The value of ~S is ~S, ~
which is not of type ~S."
',place ,place ',type))
:FORMAT-ARGUMENTS (list ',place ,place ',type)
:DATUM ,place
:EXPECTED-TYPE ',type))
(store-value (value)
:REPORT (lambda (stream)
(format stream "Supply a new value of ~S."

4
src/lsp/autoload.lsp
View file

@ -100,8 +100,8 @@ disassembled. If THING is a lambda expression, it is disassembled as a
function definition. Otherwise, THING itself is disassembled as a top-level
form. H-FILE and DATA-FILE specify intermediate files to build a fasl file
from the C language code. NIL means \"do not create the file\"."
(when (or (symbolp f) (si::setf-namep f))
(setq function (eval `(function ,f))))
(when (si::valid-function-name-p f)
(setq function (fdefinition f)))
(unless (si::bc-disassemble f)
(load "SYS:cmp")
(apply 'disassemble f args)))

98
src/lsp/defpackage.lsp
View file

@ -107,8 +107,6 @@
(cerror "Proceed, ignoring this option."
"~s is not a valid DEFPACKAGE option." option)))
(labels ((to-string (x) (if (numberp x) x (string x)))
(option-test (arg1 arg2)
(when (consp arg2) (equal (car arg2) arg1)))
(option-values-list (option options &aux output)
(dolist (o options)
(let ((o-option (first o)))
@ -131,8 +129,9 @@
output))
(dolist (option '(:SIZE :DOCUMENTATION))
(when (<= 2 (count option options ':key #'car))
(warn "DEFPACKAGE option ~s specified more than once. The first value \"~a\" will be used."
option (first (option-values option options)))))
(error 'simple-program-error
:format-control "DEFPACKAGE option ~s specified more than once."
:format-arguments (list option))))
(setq name (string name))
(let* ((nicknames (option-values ':nicknames options))
(documentation (option-values ':documentation options))
@ -148,27 +147,35 @@
interned-symbol-names
(loop for list in shadowing-imported-from-symbol-names-list append (rest list))
(loop for list in imported-from-symbol-names-list append (rest list))))
(error "The symbol ~s cannot coexist in these lists:~{ ~s~}"
(first duplicate)
(loop for num in (rest duplicate)
collect (case num
(1 ':SHADOW)
(2 ':INTERN)
(3 ':SHADOWING-IMPORT-FROM)
(4 ':IMPORT-FROM)))))
(error 'simple-program-error
:format-control
"The symbol ~s cannot coexist in these lists:~{ ~s~}"
:format-arguments
(list
(first duplicate)
(loop for num in (rest duplicate)
collect (case num
(1 ':SHADOW)
(2 ':INTERN)
(3 ':SHADOWING-IMPORT-FROM)
(4 ':IMPORT-FROM))))))
(dolist (duplicate (find-duplicates exported-symbol-names
interned-symbol-names))
(error "The symbol ~s cannot coexist in these lists:~{ ~s~}"
(first duplicate)
(loop for num in (rest duplicate) collect
(case num
(1 ':EXPORT)
(2 ':INTERN)))))
(error 'simple-program-error
:format-control
"The symbol ~s cannot coexist in these lists:~{ ~s~}"
:format-arguments
(list
(first duplicate)
(loop for num in (rest duplicate) collect
(case num
(1 ':EXPORT)
(2 ':INTERN))))))
`(si::%defpackage
,name
',nicknames
,(car documentation)
',(option-values ':use options)
',(if (assoc ':use options) (option-values ':use options) "CL")
',shadowed-symbol-names
',interned-symbol-names
',exported-symbol-names
@ -198,28 +205,40 @@
(when documentation ((put-sysprop (intern name :keyword) :package-documentation
documentation)))
(let ((*package* (find-package name)))
(when shadowed-symbol-names
(shadow (mapcar #'intern shadowed-symbol-names)))
(when shadowing-imported-from-symbol-names-list
(shadowing-import (rest shadowing-imported-from-symbol-names-list)
(first shadowing-imported-from-symbol-names-list)))
(use-package (or use "CL"))
(when imported-from-symbol-names-list
(dolist (item imported-from-symbol-names-list)
(let ((package (find-package (car item))))
(dolist (name (cdr item))
(import (find-symbol name package) *package*)))))
(when exported-symbol-names
(export (mapcar #'intern exported-symbol-names)))
(when exported-from-package-names
(dolist (package exported-from-package-names)
(do-external-symbols (symbol (find-package package))
(when (nth 1 (multiple-value-list
(find-symbol (string symbol))))
(export (list (intern (string symbol)))))))))
(shadow shadowed-symbol-names)
(dolist (item shadowing-imported-from-symbol-names-list)
(let ((package (find-package (first item))))
(dolist (name (rest item))
(shadowing-import (find-or-make-symbol name package)))))
(use-package use)
(dolist (item imported-from-symbol-names-list)
(let ((package (find-package (first item))))
(dolist (name (rest item))
(import (find-or-make-symbol name package)))))
(mapc #'intern interned-symbol-names)
(export (mapcar #'intern exported-symbol-names))
(dolist (package exported-from-package-names)
(do-external-symbols (symbol (find-package package))
(when (nth 1 (multiple-value-list
(find-symbol (string symbol))))
(export (list (intern (string symbol))))))))
(find-package name))
(defun find-or-make-symbol (name package)
(declare (si::c-local))
(multiple-value-bind (symbol found)
(find-symbol name package)
(unless found
(cerror "INTERN it."
'simple-package-error
:format-control "Cannot find symbol ~S in package ~S"
:format-arguments (list name package)
:package package)
(setq symbol (intern name package)))
symbol))
(defun find-duplicates (&rest lists)
(declare (si::c-local))
(let (results)
(loop for list in lists
for more on (cdr lists)
@ -237,7 +256,8 @@
(if entry
(nconc entry (list j))
(setq entry (car (push (list elt i j)
results))))))))))
results))))))))
results))
;;;; ------------------------------------------------------------
;;;; End of File

272
src/lsp/defstruct.lsp
View file

@ -19,8 +19,9 @@
;; (slot-type (nth 2 slot-descr))
(read-only (nth 3 slot-descr))
(offset (nth 4 slot-descr))
(access-function (intern (sys:string-concatenate (string conc-name)
(string slot-name)))))
(access-function (if conc-name
(intern (string-concatenate conc-name slot-name))
slot-name)))
(cond ((null type)
;; If TYPE is NIL,
;; the slot is at the offset in the structure-body.
@ -50,168 +51,89 @@
))
)
(defun process-boa-lambda-list (slot-names slot-descriptions boa-list)
(declare (si::c-local))
(let ((mentioned-slots '())
(aux))
;; With a call to PROCESS-LAMBDA-LIST we ensure that the lambda list is
;; syntactically correct. This simplifies notably the code in the loop.
(process-lambda-list (setq boa-list (copy-list boa-list)) 'FUNCTION)
;; Search for &optional or &key arguments without initialization. Also,
;; record all slot names which are initialized by means of the BOA call.
(do* ((i boa-list (rest i))
(slot (first i) (first i))
(modify nil))
((endp i))
(cond ((or (eq slot '&optional) (eq slot '&key))
(setq modify t))
((eq slot '&rest)
(setq modify nil))
((eq slot '&aux)
(setq aux t modify nil))
((eq slot '&allow-other-keys)
)
((atom slot)
(push slot mentioned-slots)
(when modify
(setf (first i)
(list slot (second (assoc slot slot-descriptions))))))
(t
(let ((slot-name (first slot)))
(when (consp slot-name)
(setq slot-name (second slot-name)))
(push slot-name mentioned-slots)
(when (and modify (endp (rest slot)))
(setf (rest slot)
(list (second (assoc slot-name slot-descriptions)))))))))
;; For all slots not mentioned above, add the default values from
;; the DEFSTRUCT slot description.
(let ((other-slots (nset-difference
(delete-if #'consp (copy-list slot-names))
mentioned-slots)))
(do ((l other-slots (cdr l)))
((endp l))
(let* ((slot (assoc (car l) slot-descriptions))
(slot-init (second slot)))
(when slot-init
(setf (car l) (list (car l) slot-init)))))
(cond (other-slots
(unless aux
(push '&aux other-slots))
(append boa-list other-slots))
(t
boa-list)))))
(defun make-constructor (name constructor type named slot-descriptions)
(declare (ignore named)
(si::c-local))
(let*((slot-names
;; Collect the slot-names.
(mapcar #'(lambda (x)
(cond ((null x)
;; If the slot-description is NIL,
;; it is in the padding of initial-offset.
nil)
((null (car x))
;; If the slot name is NIL,
;; it is the structure name.
;; This is for typed structures with names.
(list 'QUOTE (cadr x)))
(t (car x))))
slot-descriptions))
(keys
;; Make the keyword parameters.
(mapcan #'(lambda (x)
(cond ((null x) nil)
((null (car x)) nil)
((null (cadr x)) (list (car x)))
(t (list (list (car x) (cadr x))))))
slot-descriptions)))
(cond ((consp constructor)
;; The case for a BOA constructor.
;; Dirty code!!
;; We must add an initial value for an optional parameter,
;; if the default value is not specified
;; in the given parameter list and yet the initial value
;; is supplied in the slot description.
(do ((a (cadr constructor) (cdr a)) (l nil) (vs nil))
((endp a)
;; Add those options that do not appear in the parameter list
;; as auxiliary paramters.
;; The parameters are accumulated in the variable VS.
(setq keys
(nreconc (cons '&aux l)
(mapcan #'(lambda (k)
(if (member (if (atom k) k (car k))
vs)
nil
(list k)))
keys))))
;; Skip until &OPTIONAL appears.
(cond ((eq (car a) '&optional)
(setq l (cons '&optional l))
(do ((aa (cdr a) (cdr aa)) (ov) (y))
((endp aa)
;; Add those options that do not appear in the
;; parameter list.
(setq keys
(nreconc (cons '&aux l)
(mapcan #'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil))
(when (member (car aa) lambda-list-keywords)
(when (eq (car aa) '&rest)
;; &REST is found.
(setq l (cons '&rest l))
(setq aa (cdr aa))
(unless (and (not (endp aa))
(symbolp (car aa)))
(illegal-boa))
(setq vs (cons (car aa) vs))
(setq l (cons (car aa) l))
(setq aa (cdr aa))
(when (endp aa)
(setq keys
(nreconc
(cons '&aux l)
(mapcan
#'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil)))
;; &AUX should follow.
(unless (eq (car aa) '&aux)
(illegal-boa))
(setq l (cons '&aux l))
(do ((aaa (cdr aa) (cdr aaa)))
((endp aaa))
(setq l (cons (car aaa) l))
(cond ((and (atom (car aaa))
(symbolp (car aaa)))
(setq vs (cons (car aaa) vs)))
((and (symbolp (caar aaa))
(or (endp (cdar aaa))
(endp (cddar aaa))))
(setq vs (cons (caar aaa) vs)))
(t (illegal-boa))))
;; End of the parameter list.
(setq keys
(nreconc l
(mapcan
#'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil))
;; Checks if the optional paramter without a default
;; value has a default value in the slot-description.
(if (and (cond ((atom (car aa)) (setq ov (car aa)) t)
((endp (cdar aa)) (setq ov (caar aa)) t)
(t nil))
(setq y (member ov
keys
:key
#'(lambda (x)
(if (consp x)
;; With default value.
(car x))))))
;; If no default value is supplied for
;; the optional parameter and yet appears
;; in KEYS with a default value,
;; then cons the pair to L,
(setq l (cons (car y) l))
;; otherwise cons just the parameter to L.
(setq l (cons (car aa) l)))
;; Checks the form of the optional parameter.
(cond ((atom (car aa))
(unless (symbolp (car aa))
(illegal-boa))
(setq vs (cons (car aa) vs)))
((not (symbolp (caar aa)))
(illegal-boa))
((or (endp (cdar aa)) (endp (cddar aa)))
(setq vs (cons (caar aa) vs)))
((not (symbolp (caddar aa)))
(illegal-boa))
((not (endp (cdddar aa)))
(illegal-boa))
(t
(setq vs (cons (caar aa) vs))
(setq vs (cons (caddar aa) vs)))))
;; RETURN from the outside DO.
(return nil))
(t
(unless (symbolp (car a))
(illegal-boa))
(setq l (cons (car a) l))
(setq vs (cons (car a) vs)))))
(setq constructor (car constructor)))
(t
;; If not a BOA constructor, just cons &KEY.
(setq keys (cons '&key keys))))
(let* (slot-names keys)
(dolist (slot slot-descriptions
(setq slot-names (nreverse slot-names) keys (nreverse keys)))
(push
(cond ((null slot)
;; If slot-description is NIL, it is padding for initial-offset.
nil)
((null (first slot))
;; If slot-name is NIL, it is the structure name of a typed
;; structure with name.
(list 'QUOTE (second slot)))
(t
(let* ((slot-name (first slot))
(init-form (second slot)))
;; Unless BOA constructors are used, we should avoid using
;; slot names as lambda variables in the constructor.
(unless (consp constructor)
(setq slot-name (copy-symbol slot-name)))
(push (if init-form (list slot-name init-form) slot-name)
keys)
slot-name)))
slot-names))
;; CONSTRUCTOR := constructor-name | (constructor-name boa-lambda-list)
(if (atom constructor)
(setq keys (cons '&key keys))
(setq keys (process-boa-lambda-list slot-names slot-descriptions
(second constructor))
constructor (first constructor)))
(cond ((null type)
`(defun ,constructor ,keys
#-CLOS
@ -228,11 +150,6 @@
((error "~S is an illegal structure type" type)))))
(defun illegal-boa ()
(declare (si::c-local))
(error "An illegal BOA constructor."))
(defun make-predicate (name type named name-offset)
(cond ((null type)
#'(lambda (x)
@ -339,12 +256,7 @@
(and x (car x)
(funcall #'make-access-function name conc-name type named x)))
(when copier
(fset copier
(ecase type
((NIL) #'sys::copy-structure)
(LIST #'copy-list)
(VECTOR #'copy-seq))))
)
(fset copier #'copy-structure)))
;;; The DEFSTRUCT macro.
@ -384,17 +296,17 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(setq name (car name)))
;; The default conc-name.
(setq conc-name (sys:string-concatenate (string name) "-"))
(setq conc-name (string-concatenate name "-"))
;; The default constructor.
(setq default-constructor
(intern (sys:string-concatenate "MAKE-" (string name))))
(intern (string-concatenate "MAKE-" name)))
;; The default copier and predicate.
(setq copier
(intern (sys:string-concatenate "COPY-" (string name)))
(intern (string-concatenate "COPY-" name))
predicate
(intern (sys:string-concatenate (string name) "-P")))
(intern (string-concatenate name "-P")))
;; Parse the defstruct options.
(do ((os options (cdr os)) (o) (v))
@ -404,7 +316,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(case o
(:CONC-NAME
(if (null v)
(setq conc-name "")
(setq conc-name nil)
(setq conc-name v)))
(:CONSTRUCTOR
(if (null v)
@ -432,12 +344,12 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(:CONSTRUCTOR
(setq constructors
(cons default-constructor constructors)))
((:CONC-NAME :COPIER :PREDICATE :PRINT-FUNCTION))
(:CONC-NAME
(setq conc-name nil))
((:COPIER :PREDICATE :PRINT-FUNCTION))
(:NAMED (setq named t))
(t (error "~S is an illegal defstruct option." o))))))
(setq conc-name (intern (string conc-name)))
;; Skip the documentation string.
(when (and (not (endp slot-descriptions))
(stringp (car slot-descriptions)))

24
src/lsp/evalmacros.lsp
View file

@ -296,7 +296,7 @@ SECOND-FORM."
)
(defun do/do*-expand (control test result body let psetq
&aux (decl nil) (label (gensym))
&aux (decl nil) (label (gensym)) (exit (gensym))
(vl nil) (step nil))
(declare (si::c-local))
(multiple-value-setq (decl body)
@ -312,25 +312,17 @@ SECOND-FORM."
(push (third c) step))
(t
(error "Too many arguments in init form of do/do*"))))
;; This macroexpansion produces tinier code.
`(BLOCK NIL
(,let ,(nreverse vl)
,@decl
(TAGBODY
,label (UNLESS ,test
,@body
,@(when step (list (cons psetq (nreverse step))))
(GO ,label)))
,@result))
#+nil
`(BLOCK NIL
(,let ,(nreverse vl)
,@decl
(TAGBODY
,label (IF ,test (RETURN (PROGN ,@result)))
,@body
,@(when step (list (cons psetq (nreverse step))))
(GO ,label)))))
(GO ,exit)
,label
,@body
,@(when step (list (cons psetq (nreverse step))))
,exit
(UNLESS ,test (GO ,label)))
,@result)))
(defmacro do (control (test . result) &rest body)
(do/do*-expand control test result body 'LET 'PSETQ))

7
src/lsp/listlib.lsp
View file

@ -18,7 +18,6 @@ Returns, as a list, the union of elements in LIST1 and in LIST2."
((null x)
(when last (rplacd last list2))
(or first list2))
(unless (consp x) (error "UNION not passed a list"))
(unless (apply #'member1 (car x) list2 rest)
(if last
(progn (rplacd last (cons (car x) nil))
@ -34,7 +33,6 @@ Destructive UNION. Both LIST1 and LIST2 may be destroyed."
((null x)
(when last (rplacd last list2))
(or first list2))
(unless (consp x) (error "NUNION not passed a list"))
(unless (apply #'member1 (car x) list2 rest)
(if last
(rplacd last x)
@ -49,7 +47,6 @@ LIST2."
(ans))
((null x)
(nreverse ans)) ; optional nreverse: not required by CLtL
(unless (consp x) (error "INTERSECTION not passed a list"))
(when (apply #'member1 (car x) list2 rest)
(push (car x) ans))))
@ -61,7 +58,6 @@ Destructive INTERSECTION. Only LIST1 may be destroyed."
((null x)
(when last (rplacd last nil))
first)
(unless (consp x) (error "NINTERSECTION not passed a list"))
(when (apply #'member1 (car x) list2 rest)
(if last
(rplacd last x)
@ -74,7 +70,6 @@ Returns, as a list, those elements of LIST1 that are not elements of LIST2."
(do ((x list1 (cdr x))
(ans))
((null x) (nreverse ans))
(unless (consp x) (error "SET-DIFFERENCE not passed a list"))
(unless (apply #'member1 (car x) list2 rest)
(push (car x) ans))))
@ -86,7 +81,6 @@ Destructive SET-DIFFERENCE. Only LIST1 may be destroyed."
((null x)
(when last (rplacd last nil))
first)
(unless (consp x) (error "NSET-DIFFERENCE not passed a list"))
(unless (apply #'member1 (car x) list2 rest)
(if last
(rplacd last x)
@ -115,7 +109,6 @@ otherwise."
(declare (ignore test test-not key))
(do ((l list1 (cdr l)))
((null l) t)
(unless (consp l) (error "SUBSETP not passed a list"))
(unless (apply #'member1 (car l) list2 rest)
(return nil))))

80
src/lsp/packlib.lsp
View file

@ -31,37 +31,59 @@ is used."
(let ((all-symbols nil))
(when (or (atom packages) (not maybe-list))
(setq packages (list packages)))
(dolist (package packages)
(multiple-value-bind (hash-ext hash-int packages-used)
(si::package-hash-tables (si::coerce-to-package package))
(when (member :external options :test #'eq)
(push (list package :external hash-ext) all-symbols))
(when (member :internal options :test #'eq)
(push (list package :internal hash-int) all-symbols))
(when (member :inherited options :test #'eq)
(dolist (p packages-used)
(push (list package :internal (si::package-hash-tables p))
all-symbols)))))
(dolist (p packages)
(let ((package (si::coerce-to-package p)))
(multiple-value-bind (hash-ext hash-int packages-used)
(si::package-hash-tables package)
(when (member :external options)
(push (list package :external hash-ext) all-symbols))
(when (member :internal options)
(push (list package :internal hash-int) all-symbols))
(when (member :inherited options)
(dolist (p packages-used)
(push (list package :inherited (si::package-hash-tables p))
all-symbols))))))
(unless all-symbols
(return-from packages-iterator #'(lambda () (values nil nil nil nil))))
(let* ((current (pop all-symbols))
(package (first current))
(type (second current))
(iterator (si::hash-table-iterator (third current))))
(flet ((iterate ()
(do () (nil)
(multiple-value-bind (found key value)
(funcall iterator)
(cond (found (return (values t value type package)))
((null all-symbols) (return (values nil nil nil nil)))
(t
(setq current (pop all-symbols))
(setq package (first current)
type (second current)
iterator (si::hash-table-iterator (third current))
)))))))
(tagbody
AGAIN
(multiple-value-bind (found key value)
(funcall iterator)
(cond
(found
(when (eq type :inherited)
(multiple-value-bind (s access)
(find-symbol (symbol-name value) package)
(unless (and (eq s value) (eq access type))
(go AGAIN))))
(return-from iterate (values t value type package)))
((null all-symbols)
(return-from iterate (values nil nil nil nil)))
(t
(setq current (pop all-symbols))
(setq package (first current)
type (second current)
iterator (si::hash-table-iterator (third current))
))))
(go AGAIN))))
#'iterate))))
(defmacro with-package-iterator ((iterator package-list &rest conditions)
&rest body)
(if conditions
(let ((aux (set-difference conditions '(:external :internal :inherited))))
(when aux
(error 'simple-program-error
:format-control "Clauses ~{~S~} are not allowed."
:format-arguments aux)))
(error 'simple-program-error
:format-control "Must supply at least one of :inherited, :external~
or :internal"))
`(let ((,iterator (packages-iterator ,package-list ',conditions t)))
(macrolet ((,iterator () (list 'funcall ',iterator)))
,@body)))
@ -73,13 +95,13 @@ is used."
declaration)
(multiple-value-setq (declaration body doc)
(find-declarations body nil))
`(let* ((,i (packages-iterator ,package ',options t)))
(loop
(multiple-value-bind (,found ,var)
(funcall ,i)
,@declaration
(unless ,found (return ,result-form))
,@body)))))
`(do* ((,i (packages-iterator ,package ',options t))
,found ,var)
(nil)
,@declaration
(multiple-value-setq (,found ,var) (funcall ,i))
(unless ,found (return ,result-form))
,@body)))
(defmacro do-symbols ((var &optional (package '*package*) (result-form nil))
&rest body)

270
src/lsp/predlib.lsp
View file

@ -165,7 +165,7 @@ has no fill-pointer, and is not adjustable."
(and (arrayp x)
(not (adjustable-array-p x))
(not (array-has-fill-pointer-p x))
(not (sys:displaced-array-p x))))
(not (array-displacement x))))
(dolist (l '((ARRAY . ARRAYP)
(ATOM . ATOM)
@ -256,9 +256,10 @@ has no fill-pointer, and is not adjustable."
((atom pat)
(error "~S does not describe array dimensions." pat))))))
(defun typep (object type &aux tp i c)
(defun typep (object type &optional env &aux tp i c)
"Args: (object type)
Returns T if X belongs to TYPE; NIL otherwise."
(declare (ignore env))
(cond ((symbolp type)
(let ((f (get-sysprop type 'TYPE-PREDICATE)))
(cond (f (return-from typep (funcall f object)))
@ -397,53 +398,74 @@ Returns T if X belongs to TYPE; NIL otherwise."
(values tp (list (car i) (1- (caadr i)))))
(t (values tp i))))
(defun expand-deftype (type)
(cond ((symbolp type)
(let ((fd (get-sysprop type 'DEFTYPE-DEFINITION)))
(if fd
(expand-deftype (funcall fd))
type)))
((and (consp type)
(symbolp type))
(let ((fd (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
(if fd
(expand-deftype (funcall fd (rest type)))
type)))
(t
type)))
;;************************************************************
;; COERCE
;;************************************************************
(defun coerce (object type &aux name args)
(defun error-coerce (object type)
(error "Cannot coerce ~S to type ~S." object type))
(defun coerce (object type &aux aux)
"Args: (x type)
Coerces X to an object of the specified type, if possible. Signals an error
if not possible."
(when (typep object type)
;; Just return as it is.
(return-from coerce object))
(when (eq type 'LIST)
(do ((l nil (cons (elt object i) l))
(i (1- (length object)) (1- i)))
((< i 0) (return-from coerce l))
(declare (fixnum i))))
(multiple-value-setq (name args) (normalize-type type))
(case name
(FUNCTION
(coerce-to-function object))
((ARRAY SIMPLE-ARRAY)
(unless (or (endp args)
(endp (cdr args))
(atom (cadr args))
(endp (cdadr args)))
(error "Cannot coerce to a multi-dimensional array."))
(do* ((l (length object))
(seq (make-sequence type l))
(i 0 (1+ i)))
((>= i l) seq)
(declare (fixnum i l))
(setf (elt seq i) (coerce (elt object i)
(if (eq (car args) '*)
'T
(car args))))))
((CHARACTER BASE-CHAR) (character object))
(FLOAT (float object))
((SINGLE-FLOAT SHORT-FLOAT) (float object 0.0S0))
((DOUBLE-FLOAT LONG-FLOAT) (float object 0.0L0))
(COMPLEX
(if (or (null args) (null (car args)) (eq (car args) '*))
(complex (realpart object) (imagpart object))
(complex (coerce (realpart object) (car args))
(coerce (imagpart object) (car args)))))
(t (error "Cannot coerce ~S to ~S." object type))))
;; Just return as it is.
(return-from coerce object))
(setq type (expand-deftype type))
(cond ((atom type)
(case type
((T) object)
(LIST
(do ((l nil (cons (elt object i) l))
(i (1- (length object)) (1- i)))
((< i 0) l)
(declare (fixnum i))))
((CHARACTER BASE-CHAR) (character object))
(FLOAT (float object))
((SINGLE-FLOAT SHORT-FLOAT) (float object 0.0S0))
((DOUBLE-FLOAT LONG-FLOAT) (float object 0.0L0))
(COMPLEX (complex (realpart object) (imagpart object)))
(FUNCTION (coerce-to-function object))
((VECTOR SIMPLE-VECTOR SIMPLE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)
(concatenate type object))
(t
(if (or (listp object) (vector object))
(concatenate type object)
(error-coerce object type)))))
((eq (setq aux (first type)) 'COMPLEX)
(if type
(complex (coerce (realpart object) (second type))
(coerce (imagpart object) (second type)))
(complex (realpart object) (imagpart object))))
((member aux '(SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
(setq aux (coerce object aux))
(unless (typep object type)
(error-coerce object type)))
((eq aux 'AND)
(coerce object (second type))
(unless (typep object type)
(error-coerce object type)))
((or (listp object) (vector object))
(concatenate type object))
(t
(error-coerce object type))))
;;************************************************************
;; SUBTYPEP
;;************************************************************
@ -487,8 +509,7 @@ if not possible."
(defparameter *elementary-types*
#+ecl-min
'((T -1)
(NIL 0))
'()
#-ecl-min
'#.*elementary-types*)
@ -499,10 +520,10 @@ if not possible."
;; Find out the tag for a certain type, if it has been already registered.
;;
(defun find-registered-tag (type)
(defun find-registered-tag (type &optional (test #'equal))
(declare (si::c-local))
(let* ((pos (assoc type *elementary-types* :test #'equal)))
(and pos (second pos))))
(let* ((pos (assoc type *elementary-types* :test test)))
(and pos (cdr pos))))
;; We are going to make changes in the types database. Save a copy if this
;; will cause trouble.
@ -523,9 +544,8 @@ if not possible."
(declare (si::c-local))
(maybe-save-types)
(dolist (i *elementary-types*)
(unless (or (eq (first i) 'T)
(zerop (logand (second i) type-mask)))
(setf (second i) (logior new-tag (second i))))))
(unless (zerop (logand (cdr i) type-mask))
(setf (cdr i) (logior new-tag (cdr i))))))
;; FIND-TYPE-BOUNDS => (VALUES TAG-SUPER TAG-SUB)
;;
@ -543,20 +563,24 @@ if not possible."
(defun find-type-bounds (type in-our-family-p type-<= minimize-super)
(declare (si::c-local))
(let* ((subtype-tag 0)
(disjoint-tag 0)
(supertype-tag (if minimize-super -1 0)))
(dolist (i *elementary-types*)
(let ((other-type (first i))
(other-tag (second i)))
(when (and (not (eq other-type 'T))
(funcall in-our-family-p other-type))
(let ((other-type (car i))
(other-tag (cdr i)))
(when (funcall in-our-family-p other-type)
(cond ((funcall type-<= type other-type)
(if minimize-super
(when (zerop (logandc2 other-tag supertype-tag))
(setq supertype-tag other-tag))
(setq supertype-tag (logior other-tag supertype-tag))))
((funcall type-<= other-type type)
(setq subtype-tag (logior other-tag subtype-tag)))))))
(values (if (= supertype-tag -1) 0 supertype-tag) subtype-tag)))
(setq subtype-tag (logior other-tag subtype-tag)))
(t
(setq disjoint-tag (logior disjoint-tag other-tag)))))))
(values (if (= supertype-tag -1) 0
(logandc2 supertype-tag (logior disjoint-tag subtype-tag)))
subtype-tag)))
;; A new type is to be registered, which is not simply a composition of
;; previous types. A new tag has to be created, and all supertypes are to be
@ -573,7 +597,7 @@ if not possible."
(find-type-bounds type in-our-family-p type-<= nil)
(let ((tag (logior (new-type-tag) tag-sub)))
(update-types (logandc2 tag-super tag-sub) tag)
(push (list type tag) *elementary-types*)
(push (cons type tag) *elementary-types*)
tag))))
;;----------------------------------------------------------------------
@ -584,18 +608,21 @@ if not possible."
(declare (si::c-local))
(let ((pos (assoc object *member-types*)))
(or (and pos (cdr pos))
;; We convert number into intervals, so that (AND INTEGER (NOT
;; (EQL 10))) is detected as a subtype of (OR (INTEGER * 9)
;; (INTEGER 11 *)).
(and (numberp object)
(let* ((base-type (if (integerp object) 'INTEGER (type-of object)))
(type (list base-type object object)))
(or (find-registered-tag type)
(register-interval-type type))))
(let* ((tag (new-type-tag)))
(maybe-save-types)
(setq *member-types* (acons object tag *member-types*))
;;
;; FIXME! We should convert number into intervals, so that
;; (AND INTEGER (NOT (EQL 10))) is detected as a subtype of
;; (OR (INTEGER * 9) (INTEGER 11 *)).
;;
(dolist (i *elementary-types*)
(let ((type (first i)))
(let ((type (car i)))
(when (typep object type)
(setf (second i) (logior tag (second i))))))
(setf (cdr i) (logior tag (cdr i))))))
tag))))
;;----------------------------------------------------------------------
@ -611,35 +638,43 @@ if not possible."
;;
(defun register-class (class)
(declare (si::c-local))
(let* ((name (class-name class))
(pos (and name
(eq class (find-class name 'nil))
(assoc name *elementary-types*))))
(if pos
;; We do not need to register classes which belong to the core type
;; system of LISP (ARRAY, NUMBER, etc).
(second pos)
(register-type class
#'(lambda (c) (or (si::instancep c) (symbolp c)))
#'(lambda (c1 c2)
(when (symbolp c1)
(setq c1 (find-class c1 nil)))
(when (symbolp c2)
(setq c2 (find-class c2 nil)))
(and c1 c2 (subclassp c1 c2)))))))
(or (find-registered-tag class)
;; We do not need to register classes which belong to the core type
;; system of LISP (ARRAY, NUMBER, etc).
(let* ((name (class-name class)))
(and name
(eq class (find-class name 'nil))
(if (eq name 'T) -1 (find-registered-tag name))))
(register-type class
#'(lambda (c) (or (si::instancep c) (symbolp c)))
#'(lambda (c1 c2)
(when (symbolp c1)
(setq c1 (find-class c1 nil)))
(when (symbolp c2)
(setq c2 (find-class c2 nil)))
(and c1 c2 (subclassp c1 c2))))))
;;----------------------------------------------------------------------
;; ARRAY types.
;;
(defun register-array-type (type)
(declare (si::c-local))
(setq type (parse-array-type type))
(if (eq (second type) '*)
(let* ((array-class (first type))
(dimensions (third type)))
(canonical-type `(OR ,@(mapcar #'(lambda (type) `(,array-class ,type ,dimensions))
+upgraded-array-element-types+))))
(register-type type #'array-type-p #'array-type-<=)))
(multiple-value-bind (array-class elt-type dimensions)
(parse-array-type type)
(cond ((eq elt-type '*)
(canonical-type `(OR ,@(mapcar #'(lambda (type) `(,array-class ,type ,dimensions))
+upgraded-array-element-types+))))
((find-registered-tag (setq type (list array-class elt-type dimensions))))
(t
#+nil
(when (and (consp dimensions) (> (count-if #'numberp dimensions) 1))
(dotimes (i (length dimensions))
(when (numberp (elt dimensions i))
(let ((dims (make-list (length dimensions) :initial-element '*)))
(setf (elt dims i) (elt dimensions i))
(register-type (list array-class elt-type dims)
#'array-type-p #'array-type-<=)))))
(register-type type #'array-type-p #'array-type-<=)))))
;;
;; We look for the most specialized type which is capable of containing
@ -673,14 +708,14 @@ if not possible."
(cond ((numberp dims)
(unless (< -1 dims array-rank-limit)
(error "Wrong rank size array type ~S." input))
(setq dims (nthcdr (- array-rank-limit rank)
#.(make-list array-rank-limit :initial-element '*))))
(setq dims (nthcdr (- array-rank-limit dims)
'#.(make-list array-rank-limit :initial-element '*))))
((consp dims)
(dolist (i dims)
(unless (or (eq i '*)
(and (integerp i) (< -1 i array-dimension-limit)))
(error "Wrong dimension size in array type ~S." input)))))
(list name elt-type dims)))
(values name elt-type dims)))
;;
;; This function checks whether the array type T1 is a subtype of the array
@ -699,9 +734,8 @@ if not possible."
(b pat (cdr b)))
((or (endp a)
(endp b)
(not (or (eq (car pat) '*)
(eq (car dim) '*)
(eql (car pat) (car dim)))))
(not (or (eq (car b) '*)
(eql (car b) (car a)))))
(and (null a) (null b)))
)))))
@ -722,7 +756,7 @@ if not possible."
(defun register-elementary-interval (type b)
(declare (si::c-local))
(setq type (list type b))
(or (find-registered-tag type)
(or (find-registered-tag type #'equalp)
(multiple-value-bind (tag-super tag-sub)
(find-type-bounds type
#'(lambda (other-type)
@ -735,7 +769,7 @@ if not possible."
(let ((tag (new-type-tag)))
(update-types (logandc2 tag-super tag-sub) tag)
(setq tag (logior tag tag-sub))
(push (list type tag) *elementary-types*)
(push (cons type tag) *elementary-types*)
tag))))
(defun register-interval-type (interval)
@ -764,7 +798,7 @@ if not possible."
(ceiling low)))))
(tag (logandc2 tag-low tag-high)))
(unless (eq high '*)
(push (list interval tag) *elementary-types*))
(push (cons interval tag) *elementary-types*))
tag))
;; All comparisons between intervals operations may be defined in terms of
@ -809,6 +843,20 @@ if not possible."
(declare (si::c-local))
(canonical-type `(COMPLEX ,(upgraded-complex-part-type (or real-type 'REAL)))))
;;----------------------------------------------------------------------
;; CONS types. Only (CONS T T) and variants, as well as (CONS NIL *), etc
;; are strictly supported.
;;
(defun register-cons-type (&optional (car-type '*) (cdr-type '*))
(let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type)))
(cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type))))
(cond ((or (zerop car-tag) (zerop cdr-tag))
0)
((and (= car-tag -1) (= cdr-tag -1))
(canonical-type 'CONS))
(t
(throw '+canonical-type-failure+ 'cons)))))
;;----------------------------------------------------------------------
;; (CANONICAL-TYPE TYPE)
;;
@ -818,8 +866,11 @@ if not possible."
;; *ELEMENTARY-TYPES* and *MEMBER-TYPES*.
;;
(defun canonical-type (type)
(declare (notinline clos::classp))
(declare (notinline clos::classp)
(si::cl-local))
(cond ((find-registered-tag type))
((eq type 'T) -1)
((eq type 'NIL) 0)
((symbolp type)
(let ((expander (get-sysprop type 'DEFTYPE-DEFINITION)))
(if expander
@ -849,6 +900,7 @@ if not possible."
(canonical-type `(OR (INTEGER ,@(rest type))
(RATIO ,@(rest type)))))
(COMPLEX (canonical-complex-type (second type)))
(CONS (apply #'register-cons-type (rest type)))
((ARRAY SIMPLE-ARRAY) (register-array-type type))
(t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
(if expander
@ -861,11 +913,12 @@ if not possible."
(error-type-specifier type))))
(defun safe-canonical-type (type)
(declare (si::c-local))
(catch '+canonical-type-failure+
(canonical-type type)))
(defun subtypep (t1 t2 &optional env)
(when (equal t1 t2)
(when (eq t1 t2)
(return-from subtypep (values t t)))
(let* ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
@ -899,28 +952,29 @@ if not possible."
(let ((tag (canonical-type type))
(out))
(setq tag (canonical-type type))
(print-types-database *elementary-types* #'second)
(print-types-database *elementary-types*)
(print-types-database *member-types*)
(dolist (i *member-types*)
(unless (zerop (logand (cdr i) tag))
(push (car i) out)))
(when out
(setq out `((MEMBER ,@out))))
(dolist (i *elementary-types*)
(unless (zerop (logand (second i) tag))
(print (list tag (second i) (logand tag (second i))))
(push (first i) out)))
(unless (zerop (logand (cdr i) tag))
(print (list tag (cdr i) (logand tag (cdr i))))
(push (car i) out)))
(values tag `(OR ,@out)))))
(defun print-types-database (types func)
(defun print-types-database (types)
(format t "~%-------------------------")
(dolist (i types)
(format t "~%~20A~%~79,' B" (car i) (funcall func i))))
(format t "~%~20A~%~79,' B" (car i) (cdr i))))
(defun extend-type-tag (tag minimal-supertype-tag)
(dolist (type *elementary-types*)
(let ((other-tag (second type)))
(let ((other-tag (cdr type)))
(when (zerop (logandc2 minimal-supertype-tag other-tag))
(setf (second type) (logior tag other-tag))))))
(setf (cdr type) (logior tag other-tag))))))
(dolist (i '((SYMBOL)
(KEYWORD NIL SYMBOL)
@ -1005,7 +1059,7 @@ if not possible."
(FILE-STREAM)
(STRING-STREAM)
(SYNONYM-STREAM)
(TWO-WAY-STREAM)
(TWO-WAY-STREAM)
(STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM
FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM))
@ -1021,13 +1075,13 @@ if not possible."
(setq tag (new-type-tag))
(unless (eq strict-supertype 't)
(extend-type-tag tag strict-supertype-tag))))
(push (let ((*print-base* 2)) (print (list type tag))) *elementary-types*)
(push (let ((*print-base* 2)) (print (cons type tag))) *elementary-types*)
))
#+nil
(let ((tag (new-type-tag)))
(extend-type-tag tag (canonical-type 'symbol))
(setq *member-types* (acons 'NIL tag *member-types*))
(push (list 'NULL tag) *elementary-types*))
(print-types-database *elementary-types* #'second)
(push (cons 'NULL tag) *elementary-types*))
(print-types-database *elementary-types*)
(format t "~%~70B" *highest-type-tag*)
); ngorp

112
src/lsp/seq.lsp
View file

@ -12,38 +12,94 @@
(in-package "SYSTEM")
(defun make-sequence (type size &key (initial-element nil iesp)
&aux element-type sequence)
(defun error-sequence-type (type)
(declare (si::c-local))
(error 'simple-type-error
:datum type
:expected-type 'sequence
:format-control "~S does not specify a sequence type"
:format-arguments (list type)))
(defun error-sequence-length (type size)
(declare (si::c-local))
(error 'simple-type-error
:format-control
"Cannot create a sequnce of size ~S which matches type ~S."
:format-arguments (list size type)
:expected-type type
:datum NIL))
(defun closest-vector-type (type)
(declare (si::c-local))
(let (elt-type length name args)
(if (atom type)
(setq name type args nil)
(setq name (first type) args (cdr type)))
(case name
((VECTOR SIMPLE-VECTOR)
(setq elt-type (if (endp args) '* (first args))
length (if (endp (rest args)) '* (second args))))
((STRING SIMPLE-STRING)
(setq elt-type 'BASE-CHAR
length (if (endp args) '* (first args))))
((BIT-VECTOR SIMPLE-BIT-VECTOR)
(setq elt-type 'BIT
length (if (endp args) '* (first args))))
((ARRAY SIMPLE-ARRAY)
(when (or (endp (rest args))
(atom (setq length (second args)))
(endp length)
(not (endp (rest length))))
(error-sequence-type type))
(setq elt-type (upgraded-array-element-type (first args))
length (first (second args))))
(t
(dolist (i '((SIMPLE-STRING . BASE-CHAR)
(STRING . BASE-CHAR)
(BIT-VECTOR . BIT)
((VECTOR BYTE8) . BYTE8)
((VECTOR INTEGER8) . INTEGER8)
((VECTOR FIXNUM) . FIXNUM)
((VECTOR SHORT-FLOAT) . SHORT-FLOAT)
((VECTOR LONG-FLOAT) . LONG-FLOAT)
(VECTOR . T))
(error-sequence-type type))
(when (subtypep type (car i))
(setq elt-type (cdr i) length '*)
(return)))))
(values elt-type length)))
(defun make-sequence (type size &key (initial-element nil iesp) &aux sequence)
"Args: (type length &key initial-element)
Creates and returns a sequence of the given TYPE and LENGTH. If INITIAL-
ELEMENT is given, then it becomes the elements of the created sequence. The
default value of INITIAL-ELEMENT depends on TYPE."
(when (subtypep type 'LIST)
(return-from make-sequence
(if iesp
(make-list size :initial-element initial-element)
(make-list size))))
(setq element-type
(dolist (i '((SIMPLE-STRING . BASE-CHAR)
(STRING . BASE-CHAR)
(BIT-VECTOR . BIT)
((VECTOR BYTE8) . BYTE8)
((VECTOR INTEGER8) . INTEGER8)
((VECTOR SHORT-FLOAT) . SHORT-FLOAT)
((VECTOR LONG-FLOAT) . LONG-FLOAT)
(VECTOR . T))
(error "Not a valid sequence type ~S." type))
(when (subtypep type (car i))
(return (cdr i)))))
(setq sequence (sys:make-vector element-type size nil nil nil nil))
(when iesp
(do ((i 0 (1+ i))
(size size))
((>= i size))
(declare (fixnum i size))
(setf (elt sequence i) initial-element)))
sequence)
(if (subtypep type 'LIST)
(progn
(cond ((subtypep 'LIST type)
(make-list size :initial-element initial-element))
((subtypep type 'NIL)
(error-sequence-type type))
((subtypep type 'NULL)
(unless (zerop size)
(error-sequence-length type size)))
((subtypep type 'CONS)
(when (zerop size)
(error-sequence-length type size))))
(make-list size :initial-element initial-element))
(multiple-value-bind (element-type length)
(closest-vector-type type)
(setq sequence (sys:make-vector (if (eq element-type '*) T element-type)
size nil nil nil nil))
(unless (or (eql length '*) (eql length size))
(error-sequence-length type size))
(when iesp
(do ((i 0 (1+ i))
(size size))
((>= i size))
(declare (fixnum i size))
(setf (elt sequence i) initial-element)))
sequence)))
(defun concatenate (result-type &rest sequences)
"Args: (type &rest sequences)

142
src/lsp/seqlib.lsp
View file

@ -34,45 +34,44 @@
(declare (si::c-local))
(error "both test and test are supplied"))
(defun bad-seq-limit (x &optional y)
(defun sequence-limits (start end seq)
(declare (si::c-local))
(error "bad sequence limit ~a" (if y (list x y) x)))
(let* (x0 x1 (l (length seq)))
(declare (fixnum x0 x1 l))
(unless (and (fixnump start) (>= (setq x0 start) 0))
(error 'simple-type-error
:format-control "~S is not a valid :START for sequence ~S"
:format-arguments (list start seq)
:datum start
:expected-type `(integer 0 ,l)))
(if end
(unless (and (fixnump end) (>= (setq x1 end) 0))
(error 'simple-type-error
:format-control "~S is not a valid :END for sequence ~S"
:format-arguments (list end seq)
:datum end
:expected-type `(or nil (integer 0 ,l))))
(setq x1 l))
(unless (<= x0 x1)
(error ":START = ~S should be smaller or equal to :END = ~S"
start end))
(values x0 x1)))
#+ecl-min
(eval-when (compile eval)
(defmacro with-start-end (start end seq &body body)
`(let* ((,start (if ,start (the-start ,start) 0))
(,end (the-end ,end ,seq)))
(declare (fixnum ,start ,end))
(unless (<= ,start ,end) (bad-seq-limit ,start ,end))
,@ body))
)
(defun the-end (x y)
(declare (si::c-local))
(cond ((fixnump x)
(unless (<= (the fixnum x) (the fixnum (length y)))
(bad-seq-limit x))
x)
((null x)
(length y))
(t (bad-seq-limit x))))
(defun the-start (x)
(declare (si::c-local))
(cond ((fixnump x)
(unless (>= (the fixnum x) 0)
(bad-seq-limit x))
(the fixnum x))
((null x) 0)
(t (bad-seq-limit x))))
`(multiple-value-bind (,start ,end)
(sequence-limits ,start ,end ,seq)
(declare (fixnum ,start ,end))
,@body)))
(defun reduce (function sequence
&key from-end
start
(start 0)
end
(initial-value nil ivsp)
(key #'identity))
key (initial-value nil ivsp))
(with-start-end start end sequence
(unless key (setq key #'identity))
(cond ((not from-end)
(when (null ivsp)
(when (>= start end)
@ -96,16 +95,14 @@
((>= start end) x)
(decf end))))))
(defun fill (sequence item &key start end)
(defun fill (sequence item &key (start 0) end)
(with-start-end start end sequence
(do ((i start (1+ i)))
((>= i end) sequence)
(declare (fixnum i))
(setf (elt sequence i) item))))
(defun replace (sequence1 sequence2
&key start1 end1
start2 end2 )
(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
(with-start-end start1 end1 sequence1
(with-start-end start2 end2 sequence2
(if (and (eq sequence1 sequence2)
@ -173,18 +170,22 @@
(endp-i-everywhere '(< i 0)))
(setq from-end-form ,(or from-end-form normal-form)))
`(defun ,f (,@args item sequence
&key from-end test test-not
start end
&key test test-not
from-end (start 0) end
key
,@(if countp '(count))
(key #'identity)
,@(if everywherep
(list '&aux '(l (length sequence)))
nil))
,@(if everywherep '((declare (fixnum l))))
(unless key (setq key #'identity))
(with-start-end start end sequence
(let ,@(if countp
'(((count (if (null count)
most-positive-fixnum count)))))
'(((count (cond ((null count)
most-positive-fixnum)
((minusp count)
0)
(t count))))))
,@(if countp '((declare (fixnum count))))
nil
(and test test-not (test-error))
@ -195,9 +196,9 @@
(symbol-package f))
(,@args predicate sequence
&key from-end
start end
,@(if countp '(count))
(key #'identity))
(start 0) end
key
,@(if countp '(count)))
(,f ,@args predicate sequence
:from-end from-end
:test #'funcall
@ -207,9 +208,8 @@
(defun ,(intern (si:string-concatenate (string f) "-IF-NOT")
(symbol-package f))
(,@args predicate sequence
&key from-end start end
,@(if countp '(count))
(key #'identity))
&key from-end (start 0) end
key ,@(if countp '(count)))
(,f ,@args predicate sequence
:from-end from-end
:test-not #'funcall
@ -290,7 +290,7 @@
(do ((newseq
(make-sequence (seqtype sequence) (the fixnum (- l count))))
,iterate-i-everywhere
(j (- (the fixnum (1- end)) n))
(j (- (the fixnum (1- l)) n))
,kount-0)
(,endp-i-everywhere newseq)
(declare (fixnum i j k))
@ -357,12 +357,9 @@
(defun remove-duplicates (sequence
&key from-end
test test-not
start end
(key #'identity))
&key test test-not from-end (start 0) end key)
"Args: (sequence
&key (key '#'identity) (test '#'eql) test-not
&key key (test '#'eql) test-not
(start 0) (end (length sequence)) (from-end nil))
Returns a copy of SEQUENCE without duplicated elements."
(and test test-not (test-error))
@ -383,13 +380,9 @@ Returns a copy of SEQUENCE without duplicated elements."
(defun delete-duplicates (sequence
&key from-end
test test-not
start
end
(key #'identity)
&key test test-not from-end (start 0) end key
&aux (l (length sequence)))
"Args: (sequence &key (key '#'identity)
"Args: (sequence &key key
(test '#'eql) test-not
(start 0) (end (length sequence)) (from-end nil))
Destructive REMOVE-DUPLICATES. SEQUENCE may be destroyed."
@ -407,6 +400,7 @@ Destructive REMOVE-DUPLICATES. SEQUENCE may be destroyed."
(rplacd l (cddr l)))
(t (setq l (cdr l))))))
(with-start-end start end sequence
(unless key (setq key #'identity))
(if (not from-end)
(do ((n 0)
(i start (1+ i)))
@ -473,12 +467,11 @@ Destructive REMOVE-DUPLICATES. SEQUENCE may be destroyed."
(defun mismatch (sequence1 sequence2
&key from-end test test-not
(key #'identity)
start1 start2
&key from-end test test-not key
(start1 0) (start2 0)
end1 end2)
"Args: (sequence1 sequence2
&key (key '#'identity) (test '#'eql) test-not
&key key (test '#'eql) test-not
(start1 0) (end1 (length sequence1))
(start2 0) (end2 (length sequence2))
(from-end nil))
@ -489,6 +482,7 @@ element that does not match."
(and test test-not (test-error))
(with-start-end start1 end1 sequence1
(with-start-end start2 end2 sequence2
(unless key (setq key #'identity))
(if (not from-end)
(do ((i1 start1 (1+ i1))
(i2 start2 (1+ i2)))
@ -511,12 +505,11 @@ element that does not match."
(defun search (sequence1 sequence2
&key from-end test test-not
(key #'identity)
start1 start2
&key from-end test test-not key
(start1 0) (start2 0)
end1 end2)
"Args: (sequence1 sequence2
&key (key '#'identity) (test '#'eql) test-not
&key key (test '#'eql) test-not
(start1 0) (end1 (length sequence1))
(start2 0) (end2 (length sequence2))
(from-end nil))
@ -526,6 +519,7 @@ subsequence is found. Returns NIL otherwise."
(and test test-not (test-error))
(with-start-end start1 end1 sequence1
(with-start-end start2 end2 sequence2
(unless key (setq key #'identity))
(if (not from-end)
(loop
(do ((i1 start1 (1+ i1))
@ -551,8 +545,8 @@ subsequence is found. Returns NIL otherwise."
(decf end2))))))
(defun sort (sequence predicate &key (key #'identity))
"Args: (sequence test &key (key '#'identity))
(defun sort (sequence predicate &key key)
"Args: (sequence test &key key)
Destructively sorts SEQUENCE and returns the result. TEST should return non-
NIL if its first argument is to precede its second argument. The order of two
elements X and Y is arbitrary if both
@ -565,6 +559,7 @@ evaluates to NIL. See STABLE-SORT."
(defun list-merge-sort (l predicate key)
(unless key (setq key #'identity))
(labels
((sort (l)
(prog ((i 0) left right l0 l1 key-left key-right)
@ -621,7 +616,8 @@ evaluates to NIL. See STABLE-SORT."
(declaim (ftype (function (t fixnum fixnum t t) t) quick-sort))
(defun quick-sort (seq start end pred key)
(declare (fixnum start end))
(declare (fixnum start end))
(unless key (setq key #'identity))
(if (<= end (the fixnum (1+ start)))
seq
(let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
@ -644,8 +640,8 @@ evaluates to NIL. See STABLE-SORT."
(quick-sort seq (1+ j) end pred key))))
(defun stable-sort (sequence predicate &key (key #'identity))
"Args: (sequence test &key (key '#'identity))
(defun stable-sort (sequence predicate &key key)
"Args: (sequence test &key key)
Destructively sorts SEQUENCE and returns the result. TEST should return non-
NIL if its first argument is to precede its second argument. For two elements
X and Y, if both
@ -663,15 +659,15 @@ SEQUENCE. See SORT."
(seqtype sequence)))))
(defun merge (result-type sequence1 sequence2 predicate
&key (key #'identity)
(defun merge (result-type sequence1 sequence2 predicate &key key
&aux (l1 (length sequence1)) (l2 (length sequence2)))
"Args: (type sequence1 sequence2 test &key (key '#'identity))
"Args: (type sequence1 sequence2 test &key key)
Merges two sequences in the way specified by TEST and returns the result as a
sequence of TYPE. Both SEQUENCEs may be destroyed. If both SEQUENCE1 and
SEQUENCE2 are sorted in the sense of TEST, then the result is also sorted in
the sense of TEST."
(declare (fixnum l1 l2))
(unless key (setq key #'identity))
(do ((newseq (make-sequence result-type (the fixnum (+ l1 l2))))
(j 0 (1+ j))
(i1 0)

2
src/lsp/setf.lsp
View file

@ -141,7 +141,7 @@ Does not check if the third gang is a single-element list."
((setq f (get-sysprop (car form) 'SETF-LAMBDA))
(apply f store all))
(t
`(,(si::setf-namep (list 'SETF name)) ,store ,@all))))
`(funcall #'(SETF ,name) ,store ,@all))))
(values vars inits (list store) writer (cons name all))))))))
;;;; SETF definitions.

2
src/tests/symbol10.tst
View file

@ -14,7 +14,7 @@ NIL
#+ALLEGRO (and (not (constantp var)) (eval `(let ((,var (list nil))) (and (boundp ',var) (eq (symbol-value ',var) ,var)))))
(and (fboundp var) t) ; funktion. Eigenschaft
(and (fboundp var) (macro-function var) t) ; Macro?
(and (fboundp var) (special-form-p var) t) ; Spezialform?
(and (fboundp var) (special-operator-p var) t) ; Spezialform?
#-(or ECL CLISP) (and (symbol-plist var) t) ; p-Liste?
#+(or ECL CLISP) (and (or (get var 'i1) (get var 'i2) (get var 'i3)) t) ; p-Liste?
(get var 'i1) ; i1