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

Merged in changes from sealed_slot branch

Browse source
This commit is contained in:
jgarcia 2008-05-09 09:48:29 +00:00
parent f10cae5563
commit f3b1febf4e
42 changed files with 1215 additions and 404 deletions
Download patch file Download diff file Expand all files Collapse all files

25
src/CHANGELOG
View file

@ -100,6 +100,9 @@ ECL 0.9k:
- LAST, BUTLAST, NBUTLAST and COPY-LIST no longer detect circularities. Speed
improvements in these and other functions.
- The compiler now optimizes calls to TYPE when the type name is constant and
has a simple way to be checked.
* CLOS:
- When caching generic function calls, ECL now uses a thread-local hash table
@ -109,6 +112,22 @@ ECL 0.9k:
STANDARD-WRITER-METHOD have been implemented. These methods are created
to access the slots of a standard class.
- ECL now permits direct slots with an allocation of type :INSTANCE to have an
explicit location index. These are called SEALED SLOTS. This location is
enforced by COMPUTE-SLOTS and it is inherited by other subclasses. Conflicts
are detected and the slot index is used to optimize the slot accessor
methods.
- ECL now adds another MOP extension, which is an option :SEALEDP that applies
to classes and which seals all its slots, creating additional direct slot
definitions for slots that were not sealed in parent classes.
- The compiler now recognizes access to sealed slots when the associated classes
have already been defined and the type of arguments to the accessors is known
(either by some explicit declaration or by induction). For low safety or large
speed settings, this leads to inline access to such slots using the precomputed
location.
* Bugs fixed:
- ASDF:MAKE-BUILD now handles better the case of a monolithic FASL that
@ -177,6 +196,10 @@ ECL 0.9k:
LOAD-TIME-VALUE. LOAD-TIME-VALUE is now implemented as a special operator
and not as a macro.
* Optimization and performance:
- TYPEP now can be optimized if the type argument is a constant.
* System design:
- We introduce a new kind of lisp objects, the stack frames. These are objects
@ -188,7 +211,7 @@ ECL 0.9k:
routines that implement APPLY in various forms (fixed # arguments, variable
#, closures) They save about 40kb code in Mac OSX, for instance, and do not
impact performance. This has to be activated with --enable-asmapply at
configuration time.
configuration time (Still experimental)
- ECL now offers the possibility to use conses which do not carry type
information. These conses have a size of two words and lead to significantly

9
src/c/arch/apply_x86.d
View file

@ -21,6 +21,8 @@ APPLY(cl_narg n, cl_objectfn fn, cl_object *x)
{
cl_object output;
asm volatile (
"movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */
"pushl %%edx\n\t"
"pushl %%ebp\n\t"
"movl %%ecx, %%edx\n\t" /* Here we compute the new address of the stack pointer */
"movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 4) & -16 */
@ -34,6 +36,7 @@ APPLY(cl_narg n, cl_objectfn fn, cl_object *x)
"call *%%eax\n\t" /* At this point the stack must be aligned */
"movl %%ebp, %%esp\n\t"
"popl %%ebp\n\t"
"popl %%edx\n\t"
: "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi");
return output;
}
@ -43,6 +46,8 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
{
cl_object output;
asm volatile (
"movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */
"pushl %%edx\n\t"
"pushl %%ebp\n\t"
"movl %%ecx, %%edx\n\t" /* Here we compute the new address of the stack pointer */
"movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4) & -16 */
@ -55,6 +60,7 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
"call *%%eax\n\t" /* At this point the stack must be aligned */
"movl %%ebp, %%esp\n\t"
"popl %%ebp\n\t"
"popl %%edx\n\t"
: "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi");
return output;
}
@ -64,6 +70,8 @@ APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x)
{
cl_object output;
asm volatile (
"movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */
"pushl %%edx\n\t"
"pushl %%ebp\n\t"
"movl %%ecx, %%edx\n\t" /* Here we compute the new address of the stack pointer */
"movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 8) & -16 */
@ -78,6 +86,7 @@ APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x)
"call *%%eax\n\t" /* At this point the stack must be aligned */
"movl %%ebp, %%esp\n\t"
"popl %%ebp\n\t"
"popl %%edx\n\t"
: "=a" (output) : "c" (n), "a" (fn), "S" (x), "D" (cl) : "%edx");
return output;
}

8
src/c/dpp.c
View file

@ -136,6 +136,7 @@ int naux;
char *result[MAXRES];
int nres;
void
put_lineno(void)
{
static int flag = 0;
@ -147,12 +148,14 @@ put_lineno(void)
}
}
void
error(char *s)
{
printf("Error in line %d: %s.\n", lineno, s);
exit(1);
}
void
error_symbol(char *s)
{
printf("Error in line %d: illegal symbol %s.\n", lineno, s);
@ -278,7 +281,6 @@ char *
read_symbol()
{
char c, *name = poolp;
int i;
c = readc();
while (c != '\'') {
@ -317,7 +319,6 @@ char *
read_function()
{
char c, *name = poolp;
int i;
c = readc();
if (c == '"') {
@ -694,7 +695,7 @@ put_declaration(void)
fprintf(out, ") FEwrong_num_arguments(%s);\n", function_symbol);
for (i = 0; i < nopt; i++) {
put_lineno();
fprintf(out, "\tif (narg > %d) {\n", nreq+i, optional[i].o_var);
fprintf(out, "\tif (narg > %d) {\n", nreq+i);
put_lineno();
fprintf(out, simple_varargs?
"\t\t%s = va_arg(%s,cl_object);\n":
@ -855,7 +856,6 @@ LOOP:
int
main(int argc, char **argv)
{
char *p, *q;
char outfile[BUFSIZ];
if (argc < 2 || !strcmp(argv[1],"-")) {

38
src/c/file.d
View file

@ -86,7 +86,7 @@ ecl_input_stream_p(cl_object strm)
{
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance)
if (ECL_INSTANCEP(strm))
return !Null(funcall(2, @'gray::input-stream-p', strm));
#endif
if (type_of(strm) != t_stream)
@ -134,7 +134,7 @@ ecl_output_stream_p(cl_object strm)
{
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance)
if (ECL_INSTANCEP(strm))
return !Null(funcall(2, @'gray::output-stream-p', strm));
#endif
if (type_of(strm) != t_stream)
@ -184,7 +184,7 @@ cl_stream_element_type(cl_object strm)
cl_object output = @'base-char';
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance)
if (ECL_INSTANCEP(strm))
return funcall(2, @'gray::stream-element-type', strm);
#endif
if (type_of(strm) != t_stream)
@ -515,7 +515,7 @@ static void flush_output_stream_binary(cl_object strm);
FILE *fp;
@
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
return funcall(2, @'gray::close', strm);
}
#endif
@ -674,7 +674,7 @@ ecl_write_byte(cl_object c, cl_object strm)
*/
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
funcall(3, @'gray::stream-write-byte', strm, c);
return;
}
@ -921,7 +921,7 @@ ecl_read_byte(cl_object strm)
*/
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
return funcall(2, @'gray::stream-read-byte', strm);
}
#endif
@ -1059,7 +1059,7 @@ ecl_read_char(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
cl_object c = funcall(2, @'gray::stream-read-char', strm);
return CHARACTERP(c)? CHAR_CODE(c) : EOF;
}
@ -1175,7 +1175,7 @@ ecl_peek_char(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
cl_object c = funcall(2, @'gray::stream-peek-char', strm);
return CHARACTERP(c)? CHAR_CODE(c) : EOF;
}
@ -1284,7 +1284,7 @@ ecl_unread_char(int c, cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
funcall(3, @'gray::stream-unread-char', strm, CODE_CHAR(c));
return;
}
@ -1368,7 +1368,7 @@ ecl_write_char(int c, cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
funcall(3, @'gray::stream-write-char', strm, CODE_CHAR(c));
return c;
}
@ -1649,7 +1649,7 @@ ecl_force_output(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
funcall(2, @'gray::stream-force-output', strm);
return;
}
@ -1716,7 +1716,7 @@ ecl_clear_input(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
funcall(2, @'gray::stream-clear-input', strm);
return;
}
@ -1790,7 +1790,7 @@ ecl_clear_output(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
funcall(2, @'gray::stream-clear-output',strm);
return;
}
@ -1953,7 +1953,7 @@ ecl_listen_stream(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
cl_object flag = funcall(2, @'gray::stream-listen', strm);
return !(flag == Cnil);
}
@ -2043,7 +2043,7 @@ ecl_file_position(cl_object strm)
cl_object output;
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance)
if (ECL_INSTANCEP(strm))
FEerror("file-position not implemented for CLOS streams", 0);
#endif
if (type_of(strm) != t_stream)
@ -2129,7 +2129,7 @@ ecl_file_position_set(cl_object strm, cl_object large_disp)
cl_index disp, extra = 0;
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance)
if (ECL_INSTANCEP(strm))
FEerror("file-position not implemented for CLOS streams", 0);
#endif
if (type_of(strm) != t_stream)
@ -2234,7 +2234,7 @@ cl_file_length(cl_object strm)
cl_object output;
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance)
if (ECL_INSTANCEP(strm))
FEwrong_type_argument(c_string_to_object("(OR BROADCAST-STREAM SYNONYM-STREAM FILE-STREAM)"),
strm);
#endif
@ -2309,7 +2309,7 @@ ecl_file_column(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
cl_object col = funcall(2, @'gray::stream-line-column', strm);
/* FIXME! The Gray streams specifies NIL is a valid
* value but means "unknown". Should we make it
@ -2564,7 +2564,7 @@ cl_object
cl_streamp(cl_object strm)
{
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance) {
if (ECL_INSTANCEP(strm)) {
return funcall(2, @'gray::streamp', strm);
}
#endif

7
src/c/gfun.d
View file

@ -36,7 +36,7 @@ reshape_instance(cl_object x, int delta)
cl_object
si_set_raw_funcallable(cl_object instance, cl_object function)
{
if (type_of(instance) != t_instance)
if (!ECL_INSTANCEP(instance))
FEwrong_type_argument(@'ext::instance', instance);
if (Null(function)) {
if (instance->instance.isgf == 2) {
@ -65,7 +65,7 @@ si_set_raw_funcallable(cl_object instance, cl_object function)
cl_object
clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
{
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (x->instance.isgf == ECL_USER_DISPATCH) {
reshape_instance(x, -1);
@ -89,8 +89,7 @@ clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
cl_object
si_generic_function_p(cl_object x)
{
@(return (((type_of(x) != t_instance) &&
(x->instance.isgf))? Ct : Cnil))
@(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? Ct : Cnil))
}
/**********************************************************************

201
src/c/instance.d
View file

@ -57,7 +57,7 @@ si_instance_sig_set(cl_object x)
cl_object
si_instance_class(cl_object x)
{
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
@(return CLASS_OF(x))
}
@ -65,9 +65,9 @@ si_instance_class(cl_object x)
cl_object
si_instance_class_set(cl_object x, cl_object y)
{
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (type_of(y) != t_instance)
if (!ECL_INSTANCEP(y))
FEwrong_type_argument(@'ext::instance', y);
CLASS_OF(x) = y;
@(return x)
@ -76,7 +76,7 @@ si_instance_class_set(cl_object x, cl_object y)
cl_object
ecl_instance_ref(cl_object x, cl_fixnum i)
{
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (i < 0 || i >= (cl_fixnum)x->instance.length)
FEtype_error_index(x, MAKE_FIXNUM(i));
@ -88,7 +88,7 @@ si_instance_ref(cl_object x, cl_object index)
{
cl_fixnum i;
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (!FIXNUMP(index) ||
(i = fix(index)) < 0 || i >= (cl_fixnum)x->instance.length)
@ -101,7 +101,7 @@ si_instance_ref_safe(cl_object x, cl_object index)
{
cl_fixnum i;
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (!FIXNUMP(index) ||
(i = fix(index)) < 0 || i >= x->instance.length)
@ -115,7 +115,7 @@ si_instance_ref_safe(cl_object x, cl_object index)
cl_object
ecl_instance_set(cl_object x, cl_fixnum i, cl_object v)
{
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (i >= x->instance.length || i < 0)
FEtype_error_index(x, MAKE_FIXNUM(i));
@ -128,7 +128,7 @@ si_instance_set(cl_object x, cl_object index, cl_object value)
{
cl_fixnum i;
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (!FIXNUMP(index) ||
(i = fix(index)) >= (cl_fixnum)x->instance.length || i < 0)
@ -140,7 +140,7 @@ si_instance_set(cl_object x, cl_object index, cl_object value)
cl_object
si_instancep(cl_object x)
{
@(return ((type_of(x) == t_instance) ? Ct : Cnil))
@(return (ECL_INSTANCEP(x) ? Ct : Cnil))
}
cl_object
@ -162,7 +162,7 @@ si_sl_makunbound(cl_object x, cl_object index)
{
cl_fixnum i;
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
if (!FIXNUMP(index) ||
(i = fix(index)) >= x->instance.length || i < 0)
@ -176,7 +176,7 @@ si_copy_instance(cl_object x)
{
cl_object y;
if (type_of(x) != t_instance)
if (!ECL_INSTANCEP(x))
FEwrong_type_argument(@'ext::instance', x);
y = ecl_allocate_instance(x->instance.clas, x->instance.length);
y->instance.sig = x->instance.sig;
@ -196,8 +196,9 @@ si_copy_instance(cl_object x)
@(return class)
@)
cl_object
cl_class_of(cl_object x)
/*
static cl_object
old_cl_class_of(cl_object x)
{
cl_object t;
@ -218,7 +219,6 @@ cl_class_of(cl_object x)
case t_longfloat:
#endif
t = @'float'; break;
/* XXX t = @'long-float'; break; */
case t_complex:
t = @'complex'; break;
case t_character:
@ -294,6 +294,7 @@ cl_class_of(cl_object x)
t = cl_find_class(1, Ct);
@(return t)
}
*/
cl_object
ecl_slot_value(cl_object x, const char *slot)
@ -309,3 +310,175 @@ ecl_slot_value_set(cl_object x, const char *slot, cl_object value)
cl_object slot_setter = c_string_to_object("(SETF SLOT-VALUE)");
return funcall(4, ecl_fdefinition(slot_setter), value, x, slot_name);
}
enum ecl_built_in_classes {
ECL_BUILTIN_T = 0,
ECL_BUILTIN_SEQUENCE,
ECL_BUILTIN_LIST,
ECL_BUILTIN_CONS,
ECL_BUILTIN_ARRAY,
ECL_BUILTIN_VECTOR,
ECL_BUILTIN_STRING,
#ifdef ECL_UNICODE
ECL_BUILTIN_BASE_STRING,
#endif
ECL_BUILTIN_BIT_VECTOR,
ECL_BUILTIN_STREAM,
ECL_BUILTIN_ANSI_STREAM,
ECL_BUILTIN_FILE_STREAM,
ECL_BUILTIN_ECHO_STREAM,
ECL_BUILTIN_STRING_STREAM,
ECL_BUILTIN_TWO_WAY_STREAM,
ECL_BUILTIN_SYNONYM_STREAM,
ECL_BUILTIN_BROADCAST_STREAM,
ECL_BUILTIN_CONCATENATED_STREAM,
ECL_BUILTIN_CHARACTER,
ECL_BUILTIN_NUMBER,
ECL_BUILTIN_REAL,
ECL_BUILTIN_RATIONAL,
ECL_BUILTIN_INTEGER,
ECL_BUILTIN_RATIO,
ECL_BUILTIN_FLOAT,
ECL_BUILTIN_COMPLEX,
ECL_BUILTIN_SYMBOL,
ECL_BUILTIN_NULL,
ECL_BUILTIN_KEYWORD,
ECL_BUILTIN_METHOD_COMBINATION,
ECL_BUILTIN_PACKAGE,
ECL_BUILTIN_FUNCTION,
ECL_BUILTIN_PATHNAME,
ECL_BUILTIN_LOGICAL_PATHNAME,
ECL_BUILTIN_HASH_TABLE,
ECL_BUILTIN_RANDOM_STATE,
ECL_BUILTIN_READTABLE,
ECL_BUILTIN_CODE_BLOCK,
ECL_BUILTIN_FOREIGN_DATA,
ECL_BUILTIN_FRAME,
#ifdef ECL_THREADS
ECL_BUILTIN_PROCESS,
ECL_BUILTIN_LOCK,
ECL_BUILTIN_CONDITION_VARIABLE
#endif
};
cl_object
cl_class_of(cl_object x)
{
size_t index;
cl_type tp = type_of(x);
if (tp == t_instance)
@(return CLASS_OF(x));
switch (tp) {
case t_fixnum:
case t_bignum:
index = ECL_BUILTIN_INTEGER; break;
case t_ratio:
index = ECL_BUILTIN_RATIO; break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
#endif
case t_singlefloat:
case t_doublefloat:
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
index = ECL_BUILTIN_FLOAT; break;
/* XXX index = ECL_BUILTIN_long-float; break; */
case t_complex:
index = ECL_BUILTIN_COMPLEX; break;
case t_character:
index = ECL_BUILTIN_CHARACTER; break;
case t_symbol:
if (x->symbol.hpack == cl_core.keyword_package)
index = ECL_BUILTIN_KEYWORD;
else
index = ECL_BUILTIN_SYMBOL;
break;
case t_package:
index = ECL_BUILTIN_PACKAGE; break;
case t_list:
index = Null(x)? ECL_BUILTIN_NULL : ECL_BUILTIN_CONS; break;
case t_hashtable:
index = ECL_BUILTIN_HASH_TABLE; break;
case t_array:
index = ECL_BUILTIN_ARRAY; break;
case t_vector:
index = ECL_BUILTIN_VECTOR; break;
#ifdef ECL_UNICODE
case t_string:
index = ECL_BUILTIN_STRING; break;
case t_base_string:
index = ECL_BUILTIN_BASE_STRING; break;
#else
case t_base_string:
index = ECL_BUILTIN_STRING; break;
#endif
case t_bitvector:
index = ECL_BUILTIN_BIT_VECTOR; break;
case t_stream:
switch (x->stream.mode) {
case smm_synonym: index = ECL_BUILTIN_SYNONYM_STREAM; break;
case smm_broadcast: index = ECL_BUILTIN_BROADCAST_STREAM; break;
case smm_concatenated: index = ECL_BUILTIN_CONCATENATED_STREAM; break;
case smm_two_way: index = ECL_BUILTIN_TWO_WAY_STREAM; break;
case smm_string_input:
case smm_string_output: index = ECL_BUILTIN_STRING_STREAM; break;
case smm_echo: index = ECL_BUILTIN_ECHO_STREAM; break;
default: index = ECL_BUILTIN_FILE_STREAM; break;
}
break;
case t_readtable:
index = ECL_BUILTIN_READTABLE; break;
case t_pathname:
index = ECL_BUILTIN_PATHNAME; break;
case t_random:
index = ECL_BUILTIN_RANDOM_STATE; break;
case t_bytecodes:
case t_cfun:
case t_cclosure:
index = ECL_BUILTIN_FUNCTION; break;
#ifdef ECL_THREADS
case t_process:
index = ECL_BUILTIN_PROCESS; break;
case t_lock:
index = ECL_BUILTIN_LOCK; break;
case t_condition_variable:
index = ECL_BUILTIN_CONDITION_VARIABLE; break;
#endif
case t_codeblock:
index = ECL_BUILTIN_CODE_BLOCK; break;
case t_foreign:
index = ECL_BUILTIN_FOREIGN_DATA; break;
case t_frame:
index = ECL_BUILTIN_FRAME; break;
default:
ecl_internal_error("not a lisp data object");
}
if (0) {
cl_object y = old_cl_class_of(x);
cl_object output;
x = SYM_VAL(@'clos::*builtin-classes*');
/* We have to be careful because *builtin-classes* might be empty! */
if (Null(x)) {
output = cl_find_class(1,@'t');
} else {
output = ecl_aref(x, index);
}
if (output != y) {
cl_print(1,CLASS_NAME(output));
ecl_internal_error("BOO");
}
@(return output)
} else {
cl_object output;
x = SYM_VAL(@'clos::*builtin-classes*');
/* We have to be careful because *builtin-classes* might be empty! */
if (Null(x)) {
output = cl_find_class(1,@'t');
} else {
output = ecl_aref(x, index);
}
@(return output)
}
}

11
src/c/main.d
View file

@ -553,11 +553,12 @@ si_argc()
cl_object
si_argv(cl_object index)
{
cl_fixnum i;
if (!FIXNUMP(index) || (i = fix(index)) < 0 || i >= ARGC)
FEerror("Illegal argument index: ~S.", 1, index);
@(return make_base_string_copy(ARGV[i]))
if (FIXNUMP(index)) {
cl_fixnum i = fix(index);
if (i >= 0 && i < ARGC)
@(return make_base_string_copy(ARGV[i]));
}
FEerror("Illegal argument index: ~S.", 1, index);
}
cl_object

6
src/c/package.d
View file

@ -80,7 +80,7 @@ member_string_eq(cl_object x, cl_object l)
#define INLINE
#endif
static INLINE
static INLINE void
symbol_remove_package(cl_object s, cl_object p)
{
if (Null(s))
@ -89,7 +89,7 @@ symbol_remove_package(cl_object s, cl_object p)
s->symbol.hpack = Cnil;
}
static INLINE
static INLINE void
symbol_add_package(cl_object s, cl_object p)
{
if (Null(s))
@ -226,7 +226,7 @@ ecl_rename_package(cl_object x, cl_object name, cl_object nicknames)
PACKAGE_OP_LOCK();
y = ecl_find_package_nolock(name);
if ((y != Cnil) && (y != x)) {
ERROR: PACKAGE_OP_UNLOCK();
PACKAGE_OP_UNLOCK();
FEpackage_error("A package with name ~S already exists.", x,
1, name);
}

2
src/c/print.d
View file

@ -1525,7 +1525,7 @@ si_write_ugly_object(cl_object x, cl_object stream)
break;
#ifdef CLOS
case t_instance:
if (type_of(CLASS_OF(x)) != t_instance)
if (!ECL_INSTANCEP(CLASS_OF(x)))
FEwrong_type_argument(@'ext::instance', CLASS_OF(x));
call_print_object(x, stream);
break;

3
src/c/structure.d
View file

@ -177,8 +177,7 @@ cl_object
si_structurep(cl_object s)
{
#ifdef CLOS
if (type_of(s) == t_instance &&
structure_subtypep(CLASS_OF(s), @'structure-object'))
if (ECL_INSTANCEP(s) && structure_subtypep(CLASS_OF(s), @'structure-object'))
return Ct;
#else
if (type_of(s) == t_structure)

3
src/c/symbol.d
View file

@ -261,8 +261,9 @@ ecl_keywordp(cl_object s)
}
@(defun get (sym indicator &optional deflt)
cl_object *plist = ecl_symbol_plist(sym);
cl_object *plist;
@
plist = ecl_symbol_plist(sym);
@(return ecl_getf(*plist, indicator, deflt))
@)

4
src/c/symbols_list.h
View file

@ -1219,7 +1219,8 @@ cl_symbols[] = {
{SYS_ "INSTANCEP", SI_ORDINARY, si_instancep, 1, OBJNULL},
{SYS_ "SL-BOUNDP", SI_ORDINARY, si_sl_boundp, 1, OBJNULL},
{SYS_ "SL-MAKUNBOUND", SI_ORDINARY, si_sl_makunbound, 2, OBJNULL},
{SYS_ "SUBCLASSP", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "SUBCLASSP", SI_ORDINARY, ECL_NAME(si_subclassp), -1, OBJNULL},
{SYS_ "OF-CLASS-P", SI_ORDINARY, ECL_NAME(si_of_class_p), -1, OBJNULL},
/*{SYS_ "UNBOUND", SI_ORDINARY, si_unbound, 0, OBJNULL}, */
#endif
@ -1502,6 +1503,7 @@ cl_symbols[] = {
{SYS_ "*EXIT-HOOKS*", SI_SPECIAL, NULL, -1, Cnil},
#ifdef CLOS
{CLOS_ "*BUILTIN-CLASSES*", CLOS_SPECIAL, NULL, -1, Cnil},
{CLOS_ "*OPTIMIZE-SLOT-ACCESS*", CLOS_SPECIAL, NULL, -1, Ct},
{CLOS_ "ACCESSOR-METHOD-SLOT-DEFINITION", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "ADD-DEPENDENT", CLOS_ORDINARY, NULL, -1, OBJNULL},

4
src/c/symbols_list2.h
View file

@ -1219,7 +1219,8 @@ cl_symbols[] = {
{SYS_ "INSTANCEP","si_instancep"},
{SYS_ "SL-BOUNDP","si_sl_boundp"},
{SYS_ "SL-MAKUNBOUND","si_sl_makunbound"},
{SYS_ "SUBCLASSP",NULL},
{SYS_ "SUBCLASSP","ECL_NAME(si_subclassp)"},
{SYS_ "OF-CLASS-P","ECL_NAME(si_of_class_p)"},
/*{SYS_ "UNBOUND","si_unbound"}, */
#endif
@ -1502,6 +1503,7 @@ cl_symbols[] = {
{SYS_ "*EXIT-HOOKS*",NULL},
#ifdef CLOS
{CLOS_ "*BUILTIN-CLASSES*",NULL},
{CLOS_ "*OPTIMIZE-SLOT-ACCESS*",NULL},
{CLOS_ "ACCESSOR-METHOD-SLOT-DEFINITION",NULL},
{CLOS_ "ADD-DEPENDENT",NULL},

2
src/clos/boot.lsp
View file

@ -66,9 +66,11 @@
(setf (slot-definition-location slotd)
(slot-definition-location (gethash (slot-definition-name slotd) hash-table))))
(setf (class-slots the-class) (copy-list class-slots)
(class-size the-class) (length class-slots)
(slot-table the-class) hash-table
(class-direct-slots the-class) class-slots
(class-slots standard-class) standard-slots
(class-size standard-class) (length standard-slots)
(slot-table standard-class) hash-table
(class-direct-slots standard-class) (set-difference standard-slots class-slots))

44
src/clos/builtin.lsp
View file

@ -35,22 +35,13 @@
(si:instance-class-set (find-class 't) (find-class 'built-in-class))
(defun create-built-in-class (options)
(let* ((name (first options))
(direct-superclasses (mapcar #'find-class (or (rest options)
'(t)))))
(setf (find-class name)
(make-instance (find-class 'built-in-class)
:name name
:direct-superclasses direct-superclasses
:direct-slots nil))))
(defmethod make-instance ((class built-in-class) &rest initargs)
(declare (ignore initargs))
(error "The built-in class (~A) cannot be instantiated" class))
(mapcar #'create-built-in-class
'(;(t object)
(eval-when (:compile-toplevel :execute)
(defconstant +builtin-classes+
'(;(t object)
(sequence)
(list sequence)
(cons list)
@ -92,7 +83,21 @@
(si::foreign-data)
(si::frame)
#+threads (mp::process)
#+threads (mp::lock)))
#+threads (mp::lock)
#+threads (mp::condition-variable))))
(loop for (name . rest) in '#.+builtin-classes+
with index = 1
with built-in-class = (find-class 'built-in-class)
with array = (setf *builtin-classes* (make-array #.(1+ (length +builtin-classes+))
:initial-element (find-class 't)))
do (let* ((direct-superclasses (mapcar #'find-class (or rest '(t))))
(class (make-instance built-in-class :name name
:direct-superclasses direct-superclasses
:direct-slots nil)))
(setf (find-class name) class
(aref array index) class
index (1+ index))))
(defmethod ensure-class-using-class ((class null) name &rest rest)
(multiple-value-bind (metaclass direct-superclasses options)
@ -129,8 +134,14 @@
;;;
(defclass structure-class (class)
(slot-descriptions initial-offset defstruct-form constructors documentation
copier predicate print-function))
(slot-descriptions
initial-offset
defstruct-form
constructors
documentation
copier
predicate
print-function))
;;; structure-classes cannot be instantiated
(defmethod make-instance ((class structure-class) &rest initargs)
@ -146,9 +157,7 @@
;;; ----------------------------------------------------------------------
;;; Structure-object
;;;
;;; Structure-object has no slots and inherits only from t:
;;; (defclass structure-object (t) ())
(defclass structure-object (t) ()
(:metaclass structure-class))
@ -159,6 +168,7 @@
(defmethod print-object ((obj structure-object) stream)
(let* ((class (si:instance-class obj))
(slotds (class-slots class)))
(declare (:read-only class))
(when (and slotds
*print-level*
;; *p-readably* effectively disables *p-level*

12
src/clos/change.lsp
View file

@ -53,7 +53,7 @@
(defmethod change-class ((instance standard-object) (new-class standard-class)
&rest initargs)
(let* ((old-instance (si::copy-instance instance))
(new-size (count-instance-slots new-class))
(new-size (class-size new-class))
(instance (si::allocate-raw-instance instance new-class new-size)))
(si::instance-sig-set instance)
;; "The values of local slots specified by both the class Cto and
@ -132,8 +132,7 @@
(added-slots '())
(property-list '()))
(unless (equal old-slotds new-slotds)
(setf instance (si::allocate-raw-instance instance class
(count-instance-slots class)))
(setf instance (si::allocate-raw-instance instance class (class-size class)))
(si::instance-sig-set instance)
(let* ((new-i 0)
(old-local-slotds (remove :instance old-slotds :test-not #'eq
@ -168,9 +167,8 @@
(defmethod reinitialize-instance ((class class) &rest initargs
&key direct-superclasses (direct-slots nil direct-slots-p))
(let ((name (class-name class)))
(if (member name '(CLASS BUILT-IN-CLASS) :test #'eq)
(error "The kernel CLOS class ~S cannot be changed." name)
(warn "Redefining class ~S" name)))
(when (member name '(CLASS BUILT-IN-CLASS) :test #'eq)
(error "The kernel CLOS class ~S cannot be changed." name)))
;; remove previous defined accessor methods
(when (class-finalized-p class)
@ -201,6 +199,8 @@
class)
(defun remove-optional-slot-accessors (class)
(declare (si::c-local)
(class class))
(let ((class-name (class-name class)))
(dolist (slotd (class-slots class))
;; remove previous defined reader methods

4
src/clos/defclass.lsp
View file

@ -249,7 +249,9 @@
(defun class-ordering-error (root element path precedence-alist)
(declare (si::c-local))
(setq path (cons element (reverse (member element (reverse path) :test #'eq))))
(flet ((pretty (class) (or (class-name class) class)))
(flet ((pretty (class)
(declare (type class class))
(or (class-name class) class)))
(let ((explanations ()))
(do ((tail path (cdr tail)))
((null (cdr tail)))

3
src/clos/inspect.lsp
View file

@ -272,6 +272,7 @@ q (or Q): quits the inspection.~%~
(let* ((class (si:instance-class instance))
(local-slotds (slot-value class 'CLOS::SLOTS))
(class-slotds (slot-value class 'CLOS::CLASS-CLASS-SLOTS)))
(declare (type class class))
(loop
(format t "~S - clos object:" instance)
(incf si::*inspect-level*)
@ -323,6 +324,7 @@ q (or Q): quits the inspection.~%~
(decf si::*inspect-level*)
(let* ((class (si:instance-class instance))
(local-slotds (slot-value class 'CLOS::SLOTS)))
(declare (type class class))
(loop
(format t "~S - clos object:" instance)
(incf si::*inspect-level*)
@ -373,6 +375,7 @@ q (or Q): quits the inspection.~%~
(decf si::*inspect-level*)
(let* ((class (si:instance-class instance))
(local-slotds (slot-value class 'CLOS::SLOTS)))
(declare (type class))
(loop
(format t "~S - clos object:" instance)
(incf si::*inspect-level*)

37
src/clos/kernel.lsp
View file

@ -65,6 +65,8 @@
(default-initargs :accessor class-default-initargs)
(finalized :initform nil :accessor class-finalized-p)
(documentation :initarg :documentation :initform nil)
(size :accessor class-size)
(sealedp :initarg :sealedp :initform nil :accessor class-sealedp)
(prototype))))
#.(create-accessors +class-slots+ 'class)
@ -219,7 +221,11 @@
;;; ----------------------------------------------------------------------
;;; COMPUTE-APPLICABLE-METHODS
;;;
;;; FIXME! This should be split int an internal function, like
;;; raw-compute-... and a higher level interface, because the current
;;; version does not check _any_ of the arguments but it is
;;; nevertheless exported by the ANSI specification!
;;;
(defun compute-applicable-methods (gf args)
(declare (optimize (safety 0) (speed 3)))
(let* ((methods (generic-function-methods gf))
@ -239,10 +245,12 @@
((null scan-args) (push method applicable-list))
(setq arg (first scan-args)
spec (first scan-specializers))
(unless (or (null spec)
(and (consp spec) (eql arg (second spec)))
(typep arg spec))
(return))))
(cond ((null spec))
((listp spec)
(unless (eql arg (second spec))
(return)))
((not (si::of-class-p arg spec))
(return)))))
(dolist (arg args)
(push (class-of arg) args-specializers))
(setq args-specializers (nreverse args-specializers))
@ -295,14 +303,29 @@
(car args-specializers)))))
)
(defun fast-subtypep (spec1 spec2)
(declare (si::c-local))
;; Specialized version of subtypep which uses the fact that spec1
;; and spec2 are either classes or of the form (EQL x)
(if (atom spec1)
(if (atom spec2)
(si::subclassp spec1 spec2)
;; There is only one class with a single element, which
;; is NIL = (MEMBER NIL).
(and (null (second spec2))
(eq (class-name (first spec1)) 'nil)))
(if (atom spec2)
(si::of-class-p (second spec1) spec2)
(eql (second spec1) (second spec2)))))
(defun compare-specializers (spec-1 spec-2 arg-class)
(declare (si::c-local))
(let* ((cpl (class-precedence-list arg-class)))
(cond ((equal spec-1 spec-2) '=)
((null spec-1) '2)
((null spec-2) '1)
((subtypep spec-1 spec-2) '1)
((subtypep spec-2 spec-1) '2)
((fast-subtypep spec-1 spec-2) '1)
((fast-subtypep spec-2 spec-1) '2)
((and (listp spec-1) (eq (car spec-1) 'eql)) '1) ; is this engough?
((and (listp spec-2) (eq (car spec-2) 'eql)) '2) ; Beppe
((member spec-1 (member spec-2 cpl)) '2)

195
src/clos/standard.lsp
View file

@ -83,14 +83,22 @@
;;; CLASSES INITIALIZATION AND REINITIALIZATION
;;;
(defun count-instance-slots (class)
(count :instance (class-slots class) :key #'slot-definition-allocation))
(defun compute-instance-size (slots)
(loop for slotd in slots
with last-location = 0
with num-slots = 0
when (eq (slot-definition-allocation slotd) :instance)
do (let ((new-loc (safe-slot-definition-location slotd)))
(incf num-slots)
(when (and new-loc (> new-loc last-location))
(setf last-location new-loc)))
finally (return (max num-slots (1+ last-location)))))
(defmethod allocate-instance ((class class) &key)
;; FIXME! Inefficient! We should keep a list of dependent classes.
(unless (class-finalized-p class)
(finalize-inheritance class))
(let ((x (si::allocate-raw-instance nil class (count-instance-slots class))))
(let ((x (si::allocate-raw-instance nil class (class-size class))))
(si::instance-sig-set x)
x))
@ -134,7 +142,7 @@
(find-class 'standard-effective-slot-definition nil))
(defmethod initialize-instance ((class class) &rest initargs
&key direct-superclasses direct-slots)
&key sealedp direct-superclasses direct-slots)
;; this sets up all the slots of the class
(call-next-method)
@ -154,8 +162,10 @@
)
(defmethod shared-initialize :after ((class standard-class) slot-names &rest initargs &key
(optimize-slot-access (list *optimize-slot-access*)))
(setf (slot-value class 'optimize-slot-access) (first optimize-slot-access)))
(optimize-slot-access (list *optimize-slot-access*))
sealedp)
(setf (slot-value class 'optimize-slot-access) (first optimize-slot-access)
(slot-value class 'sealedp) (and sealedp t)))
(defmethod add-direct-subclass ((parent class) child)
(pushnew child (class-direct-subclasses parent)))
@ -185,6 +195,12 @@ argument was supplied for metaclass ~S." (class-of class))))))))
(let ((y (find-class 'FORWARD-REFERENCED-CLASS nil)))
(and y (si::subclassp (class-of x) y))))
(defun find-slot-definition (class slot-name)
(declare (si::c-local))
(if (eq (si:instance-class class) +the-standard-class+)
(gethash (class-slot-table class) slot-name nil)
(find slot-name (class-slots class) :key #'slot-definition-name)))
(defmethod finalize-inheritance ((class class))
;; FINALIZE-INHERITANCE computes the guts of what defines a class: the
;; slots, the list of parent class, etc. It is called when either the
@ -210,10 +226,49 @@ because it contains a reference to the undefined class~% ~A"
(unless (or (null x) (eq x class))
(return-from finalize-inheritance
(finalize-inheritance x))))
(setf (class-precedence-list class) cpl
(class-slots class) (compute-slots class)
(class-default-initargs class) (compute-default-initargs class)
(class-finalized-p class) t)
(setf (class-precedence-list class) cpl)
(let ((slots (compute-slots class)))
(setf (class-slots class) slots
(class-size class) (compute-instance-size slots)
(class-default-initargs class) (compute-default-initargs class)
(class-finalized-p class) t))
;;
;; When a class is sealed we rewrite the list of direct slots to fix
;; their locations. This may imply adding _new_ direct slots.
;;
(when (class-sealedp class)
(let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class)))))
;;
;; We first search all slots that belonged to unsealed classes and which
;; therefore have no fixed position.
;;
(loop for c in cpl
do (loop for slotd in (class-direct-slots c)
when (safe-slot-definition-location slotd)
do (setf free-slots (delete (slot-definition-name slotd) free-slots))))
;;
;; We now copy the locations of the effective slots in this class to
;; the class direct slots.
;;
(loop for slotd in (class-direct-slots class)
do (let ((name (slot-definition-name slotd)))
(setf (slot-definition-location slotd)
(slot-definition-location (find-slot-definition class name))
free-slots (delete name free-slots))))
;;
;; And finally we add one direct slot for each inherited slot that did
;; not have a fixed location.
;;
(loop for name in free-slots
with direct-slots = (class-direct-slots class)
do (let* ((effective-slotd (find-slot-definition class name))
(def (loop for (name . rest) in +slot-definition-slots+
nconc (list (getf rest :initarg)
(funcall (getf rest :accessor) effective-slotd)))))
(push (apply #'make-instance (direct-slot-definition-class class def)
def)
direct-slots))
finally (setf (class-direct-slots class) direct-slots))))
;;
;; This is not really needed, because when we modify the list of slots
;; all instances automatically become obsolete (See change.lsp)
@ -275,6 +330,11 @@ because it contains a reference to the undefined class~% ~A"
:documentation (slot-definition-documentation slotd)
:location (slot-definition-location slotd)))
(defun safe-slot-definition-location (slotd &optional default)
(if (or (listp slotd) (slot-boundp slotd 'location))
(slot-definition-location slotd)
default))
(defmethod compute-effective-slot-definition ((class class) name direct-slots)
(flet ((direct-to-effective (old-slot)
(if (consp old-slot)
@ -285,7 +345,20 @@ because it contains a reference to the undefined class~% ~A"
initargs))))
(combine-slotds (new-slotd old-slotd)
(let* ((new-type (slot-definition-type new-slotd))
(old-type (slot-definition-type old-slotd)))
(old-type (slot-definition-type old-slotd))
(loc1 (safe-slot-definition-location new-slotd))
(loc2 (safe-slot-definition-location old-slotd)))
(when loc2
(if loc1
(unless (eql loc1 loc2)
(error 'simple-error
:format-control "You have specified two conflicting slot locations:~%~D and ~F~%for slot ~A"
:format-args (list loc1 loc2 name)))
(progn
#+(or)
(format t "~%Assigning a default location ~D for ~A in ~A."
loc2 name (class-name class))
(setf (slot-definition-location new-slotd) loc2))))
(setf (slot-definition-initargs new-slotd)
(union (slot-definition-initargs new-slotd)
(slot-definition-initargs old-slotd)))
@ -357,11 +430,30 @@ because it contains a reference to the undefined class~% ~A"
;;;
(defun class-compute-slots (class slots)
(let ((local-index -1))
(declare (fixnum local-index))
(dolist (slotd slots)
(when (eq (slot-definition-allocation slotd) :instance)
(setf (slot-definition-location slotd) (incf local-index))))
;; This an ECL extension. We are allowed to specify the location of
;; a direct slot. Consequently we have to first sort the ones which
;; have been predefined and then assign locations _after_ the last
;; assigned slot. Note the generalized comparison, which pushes all
;; slots without a defined location to the end of the list.
(let* ((size (compute-instance-size slots))
(instance-slots (remove :instance slots :key #'slot-definition-allocation
:test-not #'eq))
(numbered-slots (remove-if-not #'safe-slot-definition-location instance-slots))
(other-slots (remove-if #'safe-slot-definition-location instance-slots))
(aux (make-array size :element-type 't :adjustable nil :initial-element nil)))
(loop for i in numbered-slots
do (let ((loc (slot-definition-location i)))
(when (aref aux loc)
(error 'simple-error
:format-control "Slots ~A and ~A are said to have the same location in class ~A."
:format-ars (list (aref aux loc) i class)))
(setf (aref aux loc) i)))
(loop for i in other-slots
with index = 0
do (loop while (aref aux index)
do (incf index)
finally (setf (aref aux index) i
(slot-definition-location i) index)))
slots))
(defmethod compute-slots :around ((class class))
@ -395,6 +487,16 @@ because it contains a reference to the undefined class~% ~A"
;;; ----------------------------------------------------------------------
;;; Optional accessors
;;;
(defun safe-instance-ref (object index)
(declare (fixnum index))
(let ((value (si:instance-ref object index)))
(if (si:sl-boundp value)
value
(let ((class (class-of object))
(slotd (find index (class-slots class) :key #'slot-definition-location)))
(values (slotd-unbound class object (slot-definition-name slotd)))))))
;;; The following does not get as fast as it should because we are not
;;; allowed to memoize the position of a slot. The problem is that the
;;; AMOP specifies that slot accessors are created from the direct
@ -408,23 +510,37 @@ because it contains a reference to the undefined class~% ~A"
;;;
(defun std-class-optimized-accessors (slot-name)
(declare (si::c-local))
(macrolet ((slot-table (class)
`(si::instance-ref ,class #.(position 'slot-table +standard-class-slots+
:key #'first)))
(slot-definition-location (slotd)
`(si::instance-ref ,slotd #.(position 'location +slot-definition-slots+
:key #'first))))
(values #'(lambda (self)
(let* ((class (si:instance-class self))
(table (slot-table class))
(slotd (gethash slot-name table))
(index (slot-definition-location slotd))
(value (si:instance-ref self index)))
(declare (fixnum index))
(if (si:sl-boundp value)
value
(values (slot-unbound (class-of self) self slot-name)))))
#'(lambda (value self)
(let* ((class (si:instance-class self))
(table (slot-table class))
(slotd (gethash slot-name table))
(index (slot-definition-location slotd)))
(declare (fixnum index))
(si:instance-set self index value))))))
(defun std-class-sealed-accessors (index)
(declare (si::c-local)
(fixnum slot-index))
(values #'(lambda (self)
(let* ((class (si:instance-class self))
(table (slot-table class))
(slotd (gethash slot-name table))
(index (slot-definition-location slotd))
(value (si:instance-ref self index)))
(declare (fixnum index))
(if (si:sl-boundp value)
value
(values (slot-unbound (class-of self) self slot-name)))))
(safe-instance-ref self index))
#'(lambda (value self)
(let* ((class (si:instance-class self))
(table (slot-table class))
(slotd (gethash slot-name table))
(index (slot-definition-location slotd)))
(declare (fixnum index))
(si:instance-set self index value)))))
(si:instance-set self index value))))
(defun std-class-accessors (slot-name)
(declare (si::c-local))
@ -444,12 +560,19 @@ because it contains a reference to the undefined class~% ~A"
;; the instance.
;;
(dolist (slotd (class-direct-slots standard-class))
#+(or)
(print (slot-definition-name slotd))
(multiple-value-bind (reader writer)
(let ((name (slot-definition-name slotd)))
(if (and (slot-value standard-class 'optimize-slot-access)
(eq (slot-definition-allocation slotd) :instance))
(std-class-optimized-accessors name)
(std-class-accessors name)))
(let ((name (slot-definition-name slotd))
(allocation (slot-definition-allocation slotd))
(location (safe-slot-definition-location slotd)))
(cond ((and (eq allocation :instance) (typep location 'fixnum))
(std-class-sealed-accessors (slot-definition-location slotd)))
((and (eq allocation :instance)
(slot-value standard-class 'optimize-slot-access))
(std-class-optimized-accessors name))
(t
(std-class-accessors name))))
(let* ((reader-args (list :function reader
:generic-function nil
:qualifiers nil

100
src/clos/streams.lsp
View file

@ -246,7 +246,9 @@
(defun bug-or-error (stream fun)
(declare (ext::c-local))
(error "The stream ~S has no suitable method for ~S." stream fun))
(if (typep stream 'stream)
(error "The stream ~S has no suitable method for ~S." stream fun)
(error 'type-error :datum stream :expected-type 'stream)))
;; STREAM-ADVANCE-TO-COLUMN
@ -264,17 +266,25 @@
(defmethod stream-clear-input ((stream fundamental-character-input-stream))
nil)
(defmethod stream-clear-input ((stream ansi-stream))
(cl:clear-input stream))
(defmethod stream-clear-input ((stream t))
(bug-or-error stream 'stream-clear-input))
;; CLEAR-OUTPUT
(defmethod stream-clear-output ((stream fundamental-output-stream))
nil)
(defmethod stream-clear-output ((stream ansi-stream))
(cl:clear-output stream))
(defmethod stream-clear-output ((stream t))
(bug-or-error stream 'stream-clear-output))
;; CLOSE
@ -286,6 +296,10 @@
(defmethod close ((stream ansi-stream) &key abort)
(cl:close stream :abort abort))
(defmethod close ((stream t) &key abort)
(bug-or-error stream 'close))
;; STREAM-ELEMENT-TYPE
(defmethod stream-element-type ((stream fundamental-character-stream))
@ -294,22 +308,32 @@
(defmethod stream-element-type ((stream ansi-stream))
(cl:stream-element-type stream))
(defmethod stream-element-type ((stream t))
(bug-or-error stream 'stream-element-type))
;; FINISH-OUTPUT
(defmethod stream-finish-output ((stream fundamental-output-stream))
nil)
(defmethod stream-finish-output ((stream ansi-stream))
(cl:finish-output stream))
(defmethod stream-finish-output ((stream t))
(bug-or-error stream 'stream-finish-output))
;; FORCE-OUTPUT
(defmethod stream-force-output ((stream fundamental-output-stream))
nil)
(defmethod stream-force-output ((stream ansi-stream))
(cl:force-output stream))
(defmethod stream-force-output ((stream t))
(bug-or-error stream 'stream-force-output))
;; FRESH-LINE
@ -333,12 +357,18 @@
(defmethod input-stream-p ((stream ansi-stream))
(cl:input-stream-p stream))
(defmethod input-stream-p ((stream t))
(bug-or-error stream 'input-stream-p))
;; INTERACTIVE-STREAM-P
(defmethod stream-interactive-p ((stream ansi-stream))
(cl:interactive-stream-p stream))
(defmethod stream-interactive-p ((stream t))
(bug-or-error stream 'stream-interactive-p))
;; LINE-COLUMN
@ -357,12 +387,18 @@
(defmethod stream-listen ((stream ansi-stream))
(cl:listen stream))
(defmethod stream-listen ((stream t))
(bug-or-error stream 'stream-listen))
;; OPEN-STREAM-P
(defmethod open-stream-p ((stream ansi-stream))
(cl:open-stream-p stream))
(defmethod open-stream-p ((stream t))
(bug-or-error stream 'open-stream-p))
;; OUTPUT-STREAM-P
@ -375,6 +411,9 @@
(defmethod output-stream-p ((stream ansi-stream))
(cl:output-stream-p stream))
(defmethod output-stream-p ((stream t))
(bug-or-error stream 'output-stream-p))
;; PEEK-CHAR
@ -387,24 +426,36 @@
(defmethod stream-peek-char ((stream ansi-stream))
(cl:peek-char stream))
(defmethod stream-peek-char ((stream t))
(bug-or-error stream 'stream-peek-char))
;; READ-BYTE
(defmethod stream-read-byte ((stream ansi-stream))
(cl:read-byte stream))
(defmethod stream-read-byte ((stream t))
(bug-or-error stream 'stream-read-byte))
;; READ-CHAR
(defmethod stream-read-char ((stream ansi-stream))
(cl:read-char stream))
(defmethod stream-read-char ((stream t))
(bug-or-error stream 'stream-read-char))
;; UNREAD-CHAR
(defmethod stream-unread-char ((stream ansi-stream) (c character))
(defmethod stream-unread-char ((stream ansi-stream) c)
(cl:unread-char stream c))
(defmethod stream-unread-char ((stream ansi-stream) c)
(bug-or-error stream 'stream-unread-char))
;; READ-CHAR-NO-HANG
@ -414,6 +465,9 @@
(defmethod stream-read-char-no-hang ((stream ansi-stream))
(cl:read-char-no-hang stream))
(defmethod stream-read-char-no-hang ((stream t))
(bug-or-error stream 'stream-read-char-no-hang))
;; READ-LINE
@ -439,23 +493,27 @@
(defmethod stream-read-line ((stream ansi-stream))
(cl:read-line stream))
(defmethod stream-read-line ((stream t))
(bug-or-error stream 'stream-read-line))
;; READ-SEQUENCE
(defmethod stream-read-sequence ((stream fundamental-character-input-stream)
(seq sequence)
&optional (start 0) (end nil))
seq &optional (start 0) (end nil))
(si::do-read-sequence seq stream start end))
(defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
(seq sequence)
&optional (start 0) (end nil))
seq &optional (start 0) (end nil))
(si::do-read-sequence seq stream start end))
(defmethod stream-read-sequence ((stream ansi-stream) (seq sequence)
(defmethod stream-read-sequence ((stream ansi-stream) seq
&optional (start 0) (end nil))
(si:do-read-sequence stream seq start end))
(defmethod stream-read-sequence ((stream t) seq &optional start end)
(bug-or-error stream 'stream-read-sequence))
;; START-LINE-P
@ -477,29 +535,35 @@
(defmethod stream-write-byte ((stream ansi-stream) integer)
(cl:write-byte stream integer))
(defmethod stream-write-byte ((stream t) integer)
(bug-or-error stream 'stream-write-byte))
;; WRITE-CHAR
(defmethod stream-write-char ((stream ansi-stream) (c character))
(cl:write-char stream))
(defmethod stream-write-char ((stream ansi-stream) c)
(cl:write-char stream c))
(defmethod stream-write-char ((stream t) c)
(bug-or-error stream 'stream-write-char))
;; WRITE-SEQUENCE
(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
(seq sequence)
(defmethod stream-write-sequence ((stream fundamental-character-output-stream) seq
&optional (start 0) end)
(si::do-write-sequence seq stream start end))
(defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
(seq sequence)
(defmethod stream-write-sequence ((stream fundamental-binary-output-stream) seq
&optional (start 0) end)
(si::do-write-sequence seq stream start end))
(defmethod stream-write-sequence ((stream ansi-stream) (seq sequence)
&optional (start 0) end)
(defmethod stream-write-sequence ((stream ansi-stream) seq &optional (start 0) end)
(si::do-write-sequence seq stream start end))
(defmethod stream-write-sequence ((stream t) seq &optional start end)
(bug-or-error stream 'stream-write-sequence))
;; WRITE-STRING
@ -518,6 +582,9 @@
(defmethod stream-write-string ((stream ansi-stream) string &optional (start 0) end)
(cl:write-string string stream :start start :end end))
(defmethod stream-write-string ((stream t) string &optional start end)
(bug-or-error stream 'stream-write-string))
;; TERPRI
@ -527,6 +594,9 @@
(defmethod stream-terpri ((stream ansi-stream))
(cl:terpri stream))
(defmethod stream-terpri ((stream t))
(bug-or-error stream 'stream-terpri))
(eval-when (:compile-toplevel :execute)
(defconstant +conflicting-symbols+ '(cl:close cl:stream-element-type cl:input-stream-p
cl:open-stream-p cl:output-stream-p cl:streamp)))

116
src/cmp/cmpclos.lsp Normal file
View file

@ -0,0 +1,116 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; CMPCLOS. CLOS related optimizations.
;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "COMPILER")
;;;
;;; GENERIC OPTIMIZATION
;;;
(defun maybe-optimize-generic-function (fname args)
(when (fboundp fname)
(let ((gf (fdefinition fname)))
(when (typep gf 'standard-generic-function)
;;(check-generic-function-args gf args)
(when (policy-inline-slot-access-p)
(maybe-optimize-slot-accessor fname gf args))))))
;;;
;;; PRECOMPUTE APPLICABLE METHODS
;;;
;;; Computes a list of methods that would apply given what we know
;;; about their arguments. Since the types are not exact, we have to
;;; use subtypep. We could speed this up if we could precompute the
;;; classes for the c-args.
;;;
(defun precompute-applicable-methods (methods c-args)
(flet ((applicable-method-p (m)
(loop for specializer in (clos:method-specializers m)
for arg in c-args
always (let ((arg-type (c1form-type arg)))
(subtypep arg-type (if (consp specializer)
`(member ,(second specializer))
specializer))))))
(delete-if-not #'applicable-method-p methods)))
;;;
;;; SLOT ACCESSORS
;;;
;;; The following functions deal with an ECL extension, which are
;;; sealed slots. These slots have a fixed location which is
;;; inherited by subclasses. They normally appear when you add the
;;; option (:sealedp t) to a class definition.
;;;
;;; When ECL detects that you call an accessor to such a slot, it can
;;; optimize the operation, using a direct access based on the
;;; position of the slot. This optimization is only active when the
;;; safety levels are low, because it prevents you from changing the
;;; class hierarchy.
;;;
(defun find-slot-accessors (gf)
(loop for method in (clos:generic-function-methods gf)
with readers = '()
with writers = '()
with reader-class = (find-class 'clos:standard-reader-method)
with writer-class = (find-class 'clos:standard-writer-method)
do (let ((method-class (class-of method)))
(cond ((si::subclassp method-class reader-class)
(push method readers))
((si::subclassp method-class writer-class)
(push method writers))))
finally (return (values readers writers))))
(defun maybe-optimize-slot-accessor (fname gf args)
(multiple-value-bind (readers writers)
(find-slot-accessors gf)
;(format t "~%;;; Found ~D readers and ~D writers for ~A" (length readers) (length writers) fname)
(cond ((and readers writers)
(cmpwarn "When analyzing generic function ~A found both slot reader and writer methods"
fname))
((not gf)
nil)
((/= (length args) (length (clos::generic-function-spec-list gf)))
(cmpwarn "Too many arguments for generic function ~A" fname)
nil)
(readers
(try-optimize-slot-reader readers args))
(writers
(try-optimize-slot-writer writers args)))))
(defun try-optimize-slot-reader (readers args)
(let* ((object (first args))
(c-object (c1expr object))
(readers (precompute-applicable-methods readers (list c-object))))
;(format t "~%;;; Found ~D really applicable reader" (length readers))
(when (= (length readers) 1)
(let ((reader (first readers)))
(when (typep reader 'clos:standard-reader-method)
(let* ((slotd (clos:accessor-method-slot-definition reader))
(index (clos::safe-slot-definition-location slotd)))
(when (si::fixnump index)
(c1expr `(clos::safe-instance-ref ,object ,index)))))))))
(defun try-optimize-slot-writer (orig-writers args)
(let* ((c-args (mapcar #'c1expr args))
(writers (precompute-applicable-methods orig-writers c-args)))
;(format t "~%;;; Found ~D really applicable writer" (length writers))
(when (= (length writers) 1)
(let ((writer (first writers)))
(when (typep writer 'clos:standard-writer-method)
(let* ((slotd (clos:accessor-method-slot-definition writer))
(index (clos::safe-slot-definition-location slotd)))
(when (si::fixnump index)
(c1expr `(si::instance-set ,(second args) ,index ,(first args))))))))))

1
src/cmp/cmpdefs.lsp
View file

@ -399,6 +399,7 @@ object at the end.")
;;; Do we debug the compiler? Then we need files not to be deleted.
(defvar *debug-compiler* nil)
(defvar *delete-files* t)
(defvar *files-to-be-deleted* '())
;;; This is copied into each .h file generated, EXCEPT for system-p calls.

18
src/cmp/cmpenv.lsp
View file

@ -328,7 +328,8 @@
(OBJECT
(declare-variables 'OBJECT decl-args))
;; read-only variable treatment. obsolete!
(:READ-ONLY)
(:READ-ONLY
(push decl others))
((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
DYNAMIC-EXTENT IGNORABLE VALUES)
(push decl others))
@ -407,6 +408,7 @@
((DYNAMIC-EXTENT IGNORABLE)
;; FIXME! SOME ARE IGNORED!
)
(:READ-ONLY)
(otherwise
(unless (member (car decl) si:*alien-declarations*)
(cmpwarn "The declaration specifier ~s is unknown." (car decl)))))))
@ -572,3 +574,17 @@
(cmp-env-variables old-env))
when (and (consp i) (var-p (fourth i)))
collect (fourth i)))
(defmacro cmp-env-optimization (property &optional env)
(case (eval property)
(speed '*speed*)
(safety '*safety*)
(space '*space*)
(debug '*debug*)))
(defmacro policy-inline-slot-access-p (&optional env)
`(or (< (cmp-env-optimization 'safety env) 2)
(<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
(defmacro policy-check-all-arguments-p (&optional env)
`(> (cmp-env-optimization 'safety env) 1))

138
src/cmp/cmpeval.lsp
View file

@ -66,19 +66,6 @@
(c1expr fd))
((setq fd (macro-function fname))
(c1expr (cmp-expand-macro fd (list* fname args))))
((and (setq fd (get-sysprop fname 'SYS::STRUCTURE-ACCESS))
(inline-possible fname)
;;; Structure hack.
(consp fd)
(sys::fixnump (cdr fd))
(not (endp args))
(endp (cdr args)))
(case (car fd)
(VECTOR (c1expr `(svref ,(car args) ,(cdr fd)))) ; Beppe3
(LIST (c1expr `(elt ,(car args) ,(cdr fd))))
(t (c1structure-ref1 (car args) (car fd) (cdr fd)))
)
)
(t (c1call-global fname args))))
(defun c1call-local (fname args)
@ -110,18 +97,23 @@
:args fun forms)))))
(defun c1call-global (fname args)
(let ((l (length args)))
(if (> l si::c-arguments-limit)
(c1expr (let ((frame (gensym)))
`(with-stack ,frame
,@(loop for i in args collect `(stack-push ,frame ,i))
(si::apply-from-stack-frame ,frame #',fname))))
(let* ((forms (c1args* args))
(return-type (propagate-types fname forms args)))
(make-c1form* 'CALL-GLOBAL
:sp-change (function-may-change-sp fname)
:type return-type
:args fname forms)))))
(let ((l (length args))
forms)
(cond ((> l si::c-arguments-limit)
(c1expr (let ((frame (gensym)))
`(with-stack ,frame
,@(loop for i in args collect `(stack-push ,frame ,i))
(si::apply-from-stack-frame ,frame #',fname)))))
((maybe-optimize-structure-access fname args))
#+clos
((maybe-optimize-generic-function fname args))
(t
(let* ((forms (c1args* args))
(return-type (propagate-types fname forms args)))
(make-c1form* 'CALL-GLOBAL
:sp-change (function-may-change-sp fname)
:type return-type
:args fname forms))))))
(defun c2expr (form &aux (name (c1form-name form)) (args (c1form-args form)))
(if (eq name 'CALL-GLOBAL)
@ -164,96 +156,6 @@
(defun c1args* (forms)
(mapcar #'(lambda (form) (c1expr form)) forms))
;;; Structures
(defun c1structure-ref (args)
(if (and (not (safe-compile)) ; Beppe
(not (endp args))
(not (endp (cdr args)))
(consp (second args))
(eq (caadr args) 'QUOTE)
(not (endp (cdadr args)))
(symbolp (cadadr args))
(endp (cddadr args))
(not (endp (cddr args)))
(sys::fixnump (third args))
(endp (cdddr args)))
(c1structure-ref1 (car args) (cadadr args) (third args))
(c1call-global 'SYS:STRUCTURE-REF args)))
(defun c1structure-ref1 (form name index)
;;; Explicitly called from c1expr and c1structure-ref.
(make-c1form* 'SYS:STRUCTURE-REF :type (get-slot-type name index)
:args (c1expr form) (add-symbol name) index))
(defun get-slot-type (name index)
;; default is t
(type-filter
(or (third (nth index (get-sysprop name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T)))
(defun c2structure-ref (form name-vv index
&aux (*inline-blocks* 0))
(let ((loc (first (coerce-locs (inline-args (list form))))))
(unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index)))
(close-inline-blocks)
)
(defun wt-structure-ref (loc name-vv index)
(if (safe-compile)
(wt "ecl_structure_ref(" loc "," name-vv "," `(COERCE-LOC :fixnum ,index) ")")
#+clos
(wt "(" loc ")->instance.slots[" `(COERCE-LOC :fixnum ,index) "]")
#-clos
(wt "(" loc ")->str.self[" `(COERCE-LOC :fixnum ,index) "]")))
(defun c1structure-set (args)
(if (and (not (safe-compile)) ; Beppe
(not (endp args))
(not (endp (cdr args)))
(consp (second args))
(eq (caadr args) 'QUOTE)
(not (endp (cdadr args)))
(symbolp (cadadr args))
(endp (cddadr args))
(not (endp (cddr args)))
(sys::fixnump (third args))
(not (endp (cdddr args)))
(endp (cddddr args)))
(let ((x (c1expr (car args)))
(y (c1expr (fourth args)))
(name (cadadr args))) ; remove QUOTE.
;; Beppe. Type check added:
(let* ((slot-type (get-slot-type name (third args)))
(new-type (type-and slot-type (c1form-primary-type y))))
(if (null new-type)
(cmpwarn "The type of the form ~s is not ~s."
(fourth args) slot-type)
(progn
(when (eq 'VAR (c1form-name y))
;; it's a variable, propagate type
(setf (var-type (c1form-arg 0 y)) new-type))
(setf (c1form-type y) new-type))))
(make-c1form* 'SYS:STRUCTURE-SET :type (c1form-primary-type y)
:args x (add-symbol name) (third args) y))
(c1call-global 'SYS:STRUCTURE-SET args)))
(defun c2structure-set (x name-vv index y
&aux locs (*inline-blocks* 0))
;; the third argument here *c1t* is just a hack to ensure that
;; a variable is introduced for y if it is an expression with side effects
(setq locs (inline-args (list x y *c1t*)))
(setq x (second (first locs)))
(setq y `(coerce-loc :object ,(second (second locs))))
(if (safe-compile)
(wt-nl "ecl_structure_set(" x "," name-vv "," index "," y ");")
#+clos
(wt-nl "(" x ")->instance.slots[" index "]= " y ";")
#-clos
(wt-nl "(" x ")->str.self[" index "]= " y ";"))
(unwind-exit y)
(close-inline-blocks)
)
;;; ----------------------------------------------------------------------
(defvar *compiler-temps*
@ -281,9 +183,3 @@
(put-sysprop 'PROGN 'C1SPECIAL 'c1progn)
(put-sysprop 'PROGN 'C2 'c2progn)
(put-sysprop 'SYS:STRUCTURE-REF 'C1 'c1structure-ref)
(put-sysprop 'SYS:STRUCTURE-REF 'C2 'c2structure-ref)
(put-sysprop 'SYS:STRUCTURE-REF 'WT-LOC 'wt-structure-ref)
(put-sysprop 'SYS:STRUCTURE-SET 'C1 'c1structure-set)
(put-sysprop 'SYS:STRUCTURE-SET 'C2 'c2structure-set)

3
src/cmp/cmpinline.lsp
View file

@ -118,7 +118,8 @@
(first (coerce-locs
(inline-args (list (c1form-arg 0 form)))))
(c1form-arg 1 form)
(c1form-arg 2 form)))
(c1form-arg 2 form)
(c1form-arg 3 form)))
locs))))
#+clos
(SYS:INSTANCE-REF

14
src/cmp/cmplet.lsp
View file

@ -40,8 +40,8 @@
:unsafe
"In LET bindings"))))
;; :read-only variable handling. Beppe
; (when (read-only-variable-p vname ts)
; (setf (var-type v) (c1form-primary-type form)))
(when (read-only-variable-p vname other-decls)
(setf (var-type v) (c1form-primary-type form)))
(push vname vnames)
(push v vars)
(push form forms)))))
@ -129,7 +129,11 @@
(t
(update-var-type var type (c1form-args x)))))
;(defun read-only-variable-p (v l) (eq 'READ-ONLY (cdr (assoc v l))))
(defun read-only-variable-p (v other-decls)
(dolist (i other-decls nil)
(when (and (eq (car i) :READ-ONLY)
(member v (rest i)))
(return t))))
(defun c2let (vars forms body
&aux (block-p nil) (bindings nil)
@ -268,8 +272,8 @@
:unsafe
"In LET* bindings"))))
;; :read-only variable handling.
; (when (read-only-variable-p (car x) ts)
; (setf (var-type v) (c1form-primary-type form)))
(when (read-only-variable-p (car x) other-decls)
(setf (var-type v) (c1form-primary-type form)))
(push (car x) vnames)
(push form forms)
(push v vars)

11
src/cmp/cmpmain.lsp
View file

@ -56,11 +56,12 @@
(cmp-delete-file the-pathname)))))
(defun cmp-delete-file (file)
(if *debug-compiler*
(progn
(format t "~%Postponing deletion of ~A" file)
(push file *files-to-be-deleted*))
(delete-file file)))
(cond ((null *delete-files*))
(*debug-compiler*
(format t "~%Postponing deletion of ~A" file)
(push file *files-to-be-deleted*))
(t
(delete-file file))))
(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*))
si::*exit-hooks*)

132
src/cmp/cmpopt.lsp Normal file
View file

@ -0,0 +1,132 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; CMPOPT. Optimization of library functions
;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "COMPILER")
;;;
;;; TYPEP
;;;
;;; Some of the type checks can be expanded inline if we know the name
;;; of the type and it corresponds to either a Common-Lisp base type
;;; or to some class.
;;;
(defun expand-in-interval-p (var interval)
(declare (si::c-local))
(let ((forms '()))
(destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
interval
(unless (eq lower-limit '*)
(push (if (consp lower-limit)
`(> ,var ,(first lower-limit))
`(>= ,var ,lower-limit))
forms))
(unless (eq upper-limit '*)
(push (if (consp upper-limit)
`(< ,var ,(first upper-limit))
`(<= ,var ,upper-limit))
forms)))
forms))
(defun expand-typep (form object type env)
(declare (si::c-local))
;; This function is reponsible for expanding (TYPEP object type)
;; forms into a reasonable set of system calls. When it fails to
;; match the compiler constraints on speed and space, it simply
;; returns the original form. Note that for successful recursion we
;; have to output indeed the ORIGINAL FORM, not some intermediate
;; step. Otherwise the compiler macro will enter an infinite loop.
(let* ((space (cmp-env-optimization 'space env))
(speed (cmp-env-optimization 'speed env))
aux function
first rest)
(declare (si::fixnum space speed))
(cond ((not (and (constantp type) (setf type (cmp-eval type)) t))
form)
;; Simple ones
((eq type 'T) T)
((eq type 'NIL) NIL)
((eq aux 'SATISFIES)
`(funcall #',function ,object))
;;
;; There exists a function which checks for this type?
((setf function (get-sysprop type 'si::type-predicate))
`(,function ,object))
;;
;; The following are not real functions, but are expanded by the
;; compiler into C forms.
((setf function (assoc type '((SINGLE-FLOAT . SINGLE-FLOAT-P)
(SHORT-FLOAT . SHORT-FLOAT-P)
(DOUBLE-FLOAT . DOUBLE-FLOAT-P)
(LONG-FLOAT . LONG-FLOAT-P))))
`(,(cdr function) ,object))
;;
;; Complex types defined with DEFTYPE.
((and (atom type)
(get-sysprop type 'SI::DEFTYPE-DEFINITION)
(setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION)))
(expand-typep form object `',(funcall function) env))
;;
;; No optimizations that take up too much space unless requested.
((and (>= space 2) (> space speed))
form)
;;
;; The type denotes a known class and we can check it
#+clos
((setf aux (find-class type nil))
`(si::of-class-p ,object ',type))
;;
;; There are no other atomic types to optimize
((atom type)
form)
;;
;; Complex types with arguments.
((setf rest (rest type)
first (first type)
function (get-sysprop first 'SI::DEFTYPE-DEFINITION))
(expand-typep form object (apply function rest) env))
;;
;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't))
((eq first 'NOT)
`(not (typep ,object ',(first rest))))
;;
;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...)
;; (TYPEP o '(OR t1 t2 ...)) => (OR (TYPEP o 't1) (TYPEP o 't2) ...)
((member first '(OR AND))
(let ((var (gensym)))
`(let ((,var ,object))
(,first ,@(loop for type in rest
collect `(typep ,var ',type))))))
;;
;; (TYPEP o '(MEMBER a1 a2 ...)) => (MEMBER o '(a1 a2 ...))
((eq first 'MEMBER)
`(MEMBER ,object ',rest))
;;
;; (INTEGER * *), etc
((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT
DOUBLE-FLOAT #+long-float LONG-FLOAT
#+short-float SHORT-FLOAT))
(let ((var (gensym)))
;; Small optimization: it is easier to check for fixnum
;; than for integer. Use it when possible.
(when (and (eq first 'integer)
(subtypep type 'fixnum))
(setf first 'fixnum))
`(LET ((,var ,object))
(AND (TYPEP ,var ',first)
,@(expand-in-interval-p `(the ,first ,var) rest)))))
(t
form))))
(define-compiler-macro typep (&whole form object type &environment env)
(expand-typep form object type env))

144
src/cmp/cmpstructures.lsp Normal file
View file

@ -0,0 +1,144 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; CMPSTRUCT. STRUCTURE related optimizations.
;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "COMPILER")
;;;
;;; GET-SLOT-TYPE
;;;
;;; Given a structure type and a slot index, infer the type of the output.
;;;
(defun get-slot-type (name index)
;; default is t
(type-filter
(or (third (nth index (get-sysprop name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T)))
;;;
;;; STRUCTURE SLOT READING
;;;
;;; By looking at the name of a function we may infer whether it is a
;;; reader for a structure slot. If this is the case and the policy
;;; allows us, we will inline the slot access and infer the type of
;;; the output.
;;;
(defun maybe-optimize-structure-access (fname args)
(let* ((slot-description (get-sysprop fname 'SYS::STRUCTURE-ACCESS)))
(when (and slot-description
(inline-possible fname)
(policy-inline-slot-access-p))
;(format t "~%;;; Optimizing structure accessor ~A" fname)
(let (struture-type slot-index)
(unless (and (consp slot-description)
(setf structure-type (car slot-description)
slot-index (cdr slot-description))
(typep slot-index 'fixnum))
(cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A"
fname slot-index)
(return-from maybe-optimize-structure-access nil))
(unless (= (length args) 1)
(cmpwarn "Too many arguments for structure slot accessor ~A" fname)
(return-from maybe-optimize-structure-access nil))
(setf args (first args))
(case structure-type
(vector (c1expr `(svref ,args ,slot-index))) ; Beppe3
(list (c1expr `(elt ,args ,slot-index)))
(t (c1structure-ref `(,args ',structure-type ,slot-index))))))))
(defun c1structure-ref (args)
(check-args-number 'sys:structure-ref args 3)
;(format t "~%;;; Optimizing structure-ref for ~A" args)
(let* ((form (first args))
(c-form (c1expr form))
(name (second args))
(index (third args)))
(if (and (constantp name)
(constantp index))
(let* ((name (cmp-eval name))
(index (cmp-eval index))
(type (get-slot-type name index)))
(make-c1form* 'SYS:STRUCTURE-REF :type type
:args c-form (add-symbol name) index
(if (or (subtypep (c1form-type c-form) structure-type)
(not (policy-check-all-arguments-p)))
:unsafe
nil)))
(c1call-global 'sys:structure-ref args))))
(defun c2structure-ref (form name-vv index unsafe)
(let* ((*inline-blocks* 0)
(loc (first (coerce-locs (inline-args (list form))))))
(unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index unsafe))
(close-inline-blocks)))
(defun wt-structure-ref (loc name-vv index unsafe)
(if unsafe
#+clos
(wt "(" loc ")->instance.slots[" `(COERCE-LOC :fixnum ,index) "]")
#-clos
(wt "(" loc ")->str.self[" `(COERCE-LOC :fixnum ,index) "]")
(wt "ecl_structure_ref(" loc "," name-vv "," `(COERCE-LOC :fixnum ,index) ")")))
(defun c1structure-set (args)
(if (and (not (safe-compile)) ; Beppe
(not (endp args))
(not (endp (cdr args)))
(consp (second args))
(eq (caadr args) 'QUOTE)
(not (endp (cdadr args)))
(symbolp (cadadr args))
(endp (cddadr args))
(not (endp (cddr args)))
(sys::fixnump (third args))
(not (endp (cdddr args)))
(endp (cddddr args)))
(let ((x (c1expr (car args)))
(y (c1expr (fourth args)))
(name (cadadr args))) ; remove QUOTE.
;; Beppe. Type check added:
(let* ((slot-type (get-slot-type name (third args)))
(new-type (type-and slot-type (c1form-primary-type y))))
(if (null new-type)
(cmpwarn "The type of the form ~s is not ~s."
(fourth args) slot-type)
(progn
(when (eq 'VAR (c1form-name y))
;; it's a variable, propagate type
(setf (var-type (c1form-arg 0 y)) new-type))
(setf (c1form-type y) new-type))))
(make-c1form* 'SYS:STRUCTURE-SET :type (c1form-primary-type y)
:args x (add-symbol name) (third args) y))
(c1call-global 'SYS:STRUCTURE-SET args)))
(defun c2structure-set (x name-vv index y
&aux locs (*inline-blocks* 0))
;; the third argument here *c1t* is just a hack to ensure that
;; a variable is introduced for y if it is an expression with side effects
(setq locs (inline-args (list x y *c1t*)))
(setq x (second (first locs)))
(setq y `(coerce-loc :object ,(second (second locs))))
(if (safe-compile)
(wt-nl "ecl_structure_set(" x "," name-vv "," index "," y ");")
#+clos
(wt-nl "(" x ")->instance.slots[" index "]= " y ";")
#-clos
(wt-nl "(" x ")->str.self[" index "]= " y ";"))
(unwind-exit y)
(close-inline-blocks)
)
(put-sysprop 'SYS:STRUCTURE-REF 'C1 'c1structure-ref)
(put-sysprop 'SYS:STRUCTURE-REF 'C2 'c2structure-ref)
(put-sysprop 'SYS:STRUCTURE-REF 'WT-LOC 'wt-structure-ref)
(put-sysprop 'SYS:STRUCTURE-SET 'C1 'c1structure-set)
(put-sysprop 'SYS:STRUCTURE-SET 'C2 'c2structure-set)

28
src/cmp/cmptop.lsp
View file

@ -424,9 +424,7 @@
(when *compile-time-too* (cmp-eval form))
(let ((*compile-toplevel* nil)
(*compile-time-too* nil))
(setq form (c1expr form))
(add-load-time-values)
(make-c1form* 'ORDINARY :args form)))
(add-load-time-values (make-c1form* 'ORDINARY :args (c1expr form)))))
(defun t2ordinary (form)
(let* ((*exit* (next-label))
@ -435,20 +433,26 @@
(c2expr form)
(wt-label *exit*)))
(defun add-load-time-values ()
(when (listp *load-time-values*)
(setq *top-level-forms* (nconc *load-time-values* *top-level-forms*))
(setq *load-time-values* nil))
(when (listp *make-forms*)
(setq *top-level-forms*
(nconc (nreverse *make-forms*) *top-level-forms*))
(setq *make-forms* nil)))
(defun add-load-time-values (form)
(let ((previous (append (and (consp *load-time-values*)
(nreverse *load-time-values*))
*make-forms*)))
(when previous
(setf *load-time-values* nil
*make-forms* nil)
(setf form (make-c1form* 'PROGN :args (nconc previous (list form))))))
form)
(defun c1load-time-value (args)
(check-args-number 'LOAD-TIME-VALUE args 1 2)
(let ((form (first args))
loc)
(cond ((typep form '(or list symbol))
(cond ((not (listp *load-time-values*))
;; When using COMPILE, we set *load-time-values* to 'VALUES and
;; thus signal that we do not want to compile these forms, but
;; just to retain their value.
(return-from c1load-time-value (c1constant-value (cmp-eval form) :always t)))
((typep form '(or list symbol))
(setf loc (data-empty-loc))
(push (make-c1form* 'LOAD-TIME-VALUE :args loc (c1expr form))
*load-time-values*))

3
src/cmp/load.lsp.in
View file

@ -32,6 +32,9 @@
"src:cmp;cmpct.lsp"
"src:cmp;cmpnum.lsp"
"src:cmp;cmpname.lsp"
"src:cmp;cmpopt.lsp"
"src:cmp;cmpclos.lsp"
"src:cmp;cmpstructures.lsp"
"src:cmp;cmpmain.lsp"))
(let ((si::*keep-documentation* nil))

8
src/cmp/sysfun.lsp
View file

@ -1337,9 +1337,9 @@ type_of(#0)==t_bitvector")
(proclaim-function si:instance-class (t) t :no-side-effects t)
(def-inline si:instance-class :always (standard-object) t "CLASS_OF(#0)")
(proclaim-function si:instance-class-set (t t) t)
(proclaim-function si:instancep (t) t :predicate t)
(def-inline si::instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)")
(proclaim-function si:unbound (*) t :predicate t :no-side-effects t)
(def-inline si:unbound :always nil t "ECL_UNBOUND")
@ -1427,12 +1427,13 @@ type_of(#0)==t_bitvector")
invalid-method-error
#-(or) standard-instance-access ; this function is a synonym for si:instance-ref
#-(or) funcallable-standard-instance-access ; same for this one
subclassp of-class-p
)
))
(proclaim
`(si::c-export-fname #+ecl-min ,@c::*in-all-symbols-functions*
si::ecase-error si::etypecase-error
si::ecase-error si::etypecase-error si::do-check-type
ccase-error typecase-error-string find-documentation find-declarations
si::check-keyword si::check-arg-length si::dm-too-few-arguments si::dm-bad-key
remove-documentation si::get-documentation
@ -1440,7 +1441,7 @@ type_of(#0)==t_bitvector")
si::closest-vector-type si::packages-iterator
si::pprint-logical-block-helper si::pprint-pop-helper
si::make-seq-iterator si::seq-iterator-ref si::seq-iterator-set si::seq-iterator-next
si::assert-slot-type si::define-structure
si::structure-type-error si::define-structure
#+formatter
,@'(
format-princ format-prin1 format-print-named-character
@ -1462,6 +1463,7 @@ type_of(#0)==t_bitvector")
;; combin.lsp
clos::simple-code-walker
;; standard.lsp
clos::safe-instance-ref
clos::standard-instance-set
;; kernel.lsp
clos::install-method

2
src/h/external.h
View file

@ -1662,6 +1662,8 @@ extern ECL_API cl_object si_find_relative_package _ARGS((cl_narg narg, cl_object
/* predlib.lsp */
extern ECL_API cl_object si_subclassp _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object si_of_class_p _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object si_do_deftype _ARGS((cl_narg narg, cl_object V1, cl_object V2, cl_object V3, ...));
extern ECL_API cl_object cl_upgraded_array_element_type _ARGS((cl_narg narg, cl_object V1, ...));
extern ECL_API cl_object cl_upgraded_complex_part_type _ARGS((cl_narg narg, cl_object V1, ...));

1
src/h/object.h
View file

@ -637,6 +637,7 @@ struct ecl_condition_variable {
#define CLASS_INFERIORS(x) (x)->instance.slots[2]
#define CLASS_SLOTS(x) (x)->instance.slots[3]
#define CLASS_CPL(x) (x)->instance.slots[4]
#define ECL_INSTANCEP(x) ((IMMEDIATE(x)==0) && ((x)->d.t==t_instance))
#define ECL_NOT_FUNCALLABLE 0
#define ECL_STANDARD_DISPATCH 1
#define ECL_USER_DISPATCH 2

48
src/lsp/assert.lsp
View file

@ -41,31 +41,29 @@ type. Before continuing, receives a new value of PLACE from the user and
checks the type again. Repeats this process until the value of PLACE becomes
of the specified type. STRING-FORM, if given, is evaluated only once and the
value is used to indicate the expected type in the error message."
(let* ((tag1 (gensym))
(tag2 (gensym)))
`(block ,tag1
(tagbody ,tag2
(if (typep ,place ',type) (return-from ,tag1 nil))
(restart-case ,(if type-string
`(error 'SIMPLE-TYPE-ERROR
:FORMAT-CONTROL "The value of ~S is ~S, ~
which is not ~A."
: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."
: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."
',place))
:INTERACTIVE read-evaluated-form
(setf ,place value)
(go ,tag2)))))))
(let ((aux (gensym)))
`(let ((,aux ,place))
(declare (:read-only ,aux))
(unless (typep ,aux ',type)
(setf ,place (do-check-type ,aux ',type ',type-string ',place)))
nil)))
(defun do-check-type (value type type-string place)
(tagbody again
(unless (typep value type)
(restart-case
(error 'simple-type-error
:datum value
:expected-type type
:format-control "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]."
:format-arguments (list place value type-string type))
(store-value (new-value)
:report (lambda (stream)
(format stream "Supply a new value of ~S" place))
:interactive read-evaluated-form
(setf value new-value)
(go again)))))
value)
(defun assert-report (names stream)
(format stream "Retry assertion")

2
src/lsp/config.lsp.in
View file

@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs."
(defun lisp-implementation-version ()
"Args:()
Returns the version of your ECL as a string."
"@PACKAGE_VERSION@ (CVS 2008-05-08 10:55)")
"@PACKAGE_VERSION@ (CVS 2008-05-09 09:55)")
(defun machine-type ()
"Args: ()

64
src/lsp/defstruct.lsp
View file

@ -13,14 +13,12 @@
(in-package "SYSTEM")
(defun si::assert-slot-type (value slot-type struct-name slot-name)
(unless (or (eq slot-type 'T)
(typep value slot-type))
(error 'simple-type-error
:format-control "Slot ~A in structure ~A only admits values of type ~A."
:format-arguments (list slot-name struct-name slot-type)
:datum value
:expected-type slot-type)))
(defun si::structure-type-error (value slot-type struct-name slot-name)
(error 'simple-type-error
:format-control "Slot ~A in structure ~A only admits values of type ~A."
:format-arguments (list slot-name struct-name slot-type)
:datum value
:expected-type slot-type))
(defun make-access-function (name conc-name type named slot-descr)
(declare (ignore named)
@ -86,7 +84,7 @@
(setf (first i)
(list slot (second (assoc slot slot-descriptions)))))
(when aux
(setf assertions (delete slot assertions :key 'second))))
(setf assertions (delete slot assertions :key 'cadadr))))
(t
(let ((slot-name (first slot)))
(when (consp slot-name)
@ -97,7 +95,7 @@
(setf (rest slot)
(list (second (assoc slot-name slot-descriptions)))))
(when aux
(setf assertions (delete slot assertions :key 'second))))))))
(setf assertions (delete slot assertions :key 'cadadr))))))))
;; For all slots not mentioned above, add the default values from
;; the DEFSTRUCT slot description.
(let ((other-slots (nset-difference
@ -149,7 +147,8 @@
;; case of BOA lists we remove some of these checks for
;; uninitialized slots.
(unless (eq 'T slot-type)
(push `(si::assert-slot-type ,var-name ',slot-type ',name ',slot-name)
(push `(unless (typep ,var-name ',slot-type)
(structure-type-error ,var-name ',slot-type ',name ',slot-name))
assertions))
var-name)))
slot-names))
@ -163,7 +162,8 @@
#-CLOS
(sys:make-structure ',name ,@slot-names)
#+CLOS
(sys:make-structure (find-class ',name) ,@slot-names)))
;; the class is defined by an enclosing LET form
(sys:make-structure .structure-constructor-class. ,@slot-names)))
((subtypep type '(VECTOR T))
`(defun ,constructor-name ,keys
(vector ,@slot-names)))
@ -319,7 +319,10 @@
(not (eql (car x) 'TYPED-STRUCTURE-NAME))
(funcall #'make-access-function name conc-name type named x)))
(when copier
(fset copier #'copy-structure)))
(fset copier #'copy-structure))
#+clos
(unless type
(find-class name)))
;;; The DEFSTRUCT macro.
@ -483,13 +486,28 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
(when (and print-function type)
(error "An print function is supplied to a typed structure."))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(define-structure ',name ',conc-name ',type ',named ',slots
',slot-descriptions ',copier ',include
',print-function ',print-object ',constructors ',offset ',name-offset
',documentation ',predicate)
,@(mapcar #'(lambda (constructor)
(make-constructor name constructor type named
slot-descriptions))
constructors)
',name)))
;;
;; The constructors rely on knowing the structure class. For toplevel
;; forms we can use LOAD-TIME-VALUE. For non-toplevel forms, we can not
;; as the class might be defined _after_ the system decides to evaluate
;; LOAD-TIME-VALUE.
;;
(let ((core `(define-structure ',name ',conc-name ',type ',named ',slots
',slot-descriptions ',copier ',include
',print-function ',print-object ',constructors
',offset ',name-offset
',documentation ',predicate))
(constructors (mapcar #'(lambda (constructor)
(make-constructor name constructor type named
slot-descriptions))
constructors)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(eval-when (:compile-toplevel :load-toplevel)
,core
,@(subst `(load-time-value (find-class ',name))
'.structure-constructor-class.
constructors))
(eval-when (:execute)
(let ((.structure-constructor-class. ,core))
,@constructors))
',name))))

111
src/lsp/pprint.lsp
View file

@ -12,6 +12,8 @@
(in-package "SI")
(declaim (optimize (safety 1)))
;;;; Pretty streams
;;; There are three different units for measuring character positions:
@ -95,7 +97,9 @@
;;
;; Block-start queue entries in effect at the queue head.
(pending-blocks :initform nil :type list :accessor pretty-stream-pending-blocks)
))
)
(:sealedp t)
)
(defun pretty-stream-p (stream)
(typep stream 'pretty-stream))
@ -136,6 +140,7 @@
)
(defmethod gray::stream-clear-output ((stream pretty-stream))
(declare (type pretty-stream stream))
(clear-output (pretty-stream-target stream)))
(defun pretty-out (stream char)
@ -207,7 +212,8 @@
(section-start-line 0 :type index))
(defun really-start-logical-block (stream column prefix suffix)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let* ((blocks (pretty-stream-blocks stream))
(prev-block (car blocks))
(per-line-end (logical-block-per-line-prefix-end prev-block))
@ -249,7 +255,8 @@
nil)
(defun set-indentation (stream column)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let* ((prefix (pretty-stream-prefix stream))
(prefix-len (length prefix))
(block (car (pretty-stream-blocks stream)))
@ -270,7 +277,8 @@
(setf (logical-block-prefix-length block) column)))
(defun really-end-logical-block (stream)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let* ((old (pop (pretty-stream-blocks stream)))
(old-indent (logical-block-prefix-length old))
(new (car (pretty-stream-blocks stream)))
@ -295,16 +303,16 @@
(entry `(,constructor :posn
(index-posn
(pretty-stream-buffer-fill-pointer
,stream)
(the pretty-stream ,stream))
,stream)
,@args))
(op `(list ,entry))
(head `(pretty-stream-queue-head ,stream)))
(head `(pretty-stream-queue-head (the pretty-stream ,stream))))
`(progn
(if ,head
(setf (cdr ,head) ,op)
(setf (pretty-stream-queue-tail ,stream) ,op))
(setf (pretty-stream-queue-head ,stream) ,op)
(setf (pretty-stream-queue-tail (the pretty-stream ,stream)) ,op))
(setf (pretty-stream-queue-head (the pretty-stream ,stream)) ,op)
,entry))))
)
@ -319,7 +327,8 @@
:type (member :linear :fill :miser :literal :mandatory)))
(defun enqueue-newline (stream kind)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let* ((depth (length (pretty-stream-pending-blocks stream)))
(newline (enqueue stream newline :kind kind :depth depth)))
(dolist (entry (pretty-stream-queue-tail stream))
@ -347,21 +356,12 @@
(defun start-logical-block (stream prefix per-line-p suffix)
(declare (si::c-local)
(type string prefix))
(type string prefix)
(type pretty-stream stream))
#+ecl
(unless (stringp prefix)
(error 'simple-type-error
:format-control "Not a valid PPRINT-LOGICAL-BLOCK prefix: ~A"
:format-arguments (list prefix)
:datum prefix
:expected-type 'string))
#+ecl
(unless (stringp suffix)
(error 'simple-type-error
:format-control "Not a valid PPRINT-LOGICAL-BLOCK suffix: ~A"
:format-arguments (list suffix)
:datum suffix
:expected-type 'string))
(progn
(check-type prefix string)
(check-type suffix string))
(let ((prefix-len (length prefix)))
(when (plusp prefix-len)
(pretty-sout stream prefix 0 prefix-len))
@ -378,7 +378,8 @@
(suffix nil :type (or null string)))
(defun end-logical-block (stream)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let* ((start (pop (pretty-stream-pending-blocks stream)))
(suffix (block-start-suffix start))
(end (enqueue stream block-end :suffix suffix)))
@ -431,7 +432,8 @@
0))))
(defun index-column (index stream)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let ((column (pretty-stream-buffer-start-column stream))
(section-start (logical-block-section-column
(first (pretty-stream-blocks stream))))
@ -454,7 +456,8 @@
(+ column index)))
(defun expand-tabs (stream through)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let ((insertions nil)
(additional 0)
(column (pretty-stream-buffer-start-column stream))
@ -602,7 +605,8 @@
*print-miser-width*)))
(defun fits-on-line-p (stream until force-newlines-p)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let ((available (pretty-stream-line-length stream)))
(when (and (not *print-readably*) *print-lines*
(= *print-lines* (pretty-stream-line-number stream)))
@ -683,7 +687,8 @@
(setf (logical-block-section-start-line block) line-number))))))
(defun output-partial-line (stream)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
(tail (pretty-stream-queue-tail stream))
(count
@ -702,7 +707,8 @@
(incf (pretty-stream-buffer-offset stream) count)))
(defun force-pretty-output (stream)
(declare (si::c-local))
(declare (si::c-local)
(type pretty-stream stream))
(maybe-output stream nil)
(expand-tabs stream nil)
(write-string (pretty-stream-buffer stream)
@ -927,12 +933,9 @@
(type (or stream (member t nil)) stream)
(values null))
#+ecl
(unless (member kind '(:linear :miser :fill :mandatory))
(error 'simple-type-error
:format-control "~A is not a valid argument to PPRINT-NEWLINE"
:format-arguments (list kind)
:datum kind
:expected-type '(member :linear :miser :fill :mandatory)))
(progn
(check-type kind (member :linear :miser :fill :mandatory))
(check-type stream (or stream (member t nil))))
(let ((stream (case stream
((t) *terminal-io*)
((nil) *standard-output*)
@ -956,12 +959,10 @@
(type (or stream (member t nil)) stream)
(values null))
#+ecl
(unless (member relative-to '(:block :current))
(error 'simple-type-error
:format-control "~A is not a valid argument to PPRINT-INDENT"
:format-arguments (list kind)
:datum kind
:expected-type '(member :block :current)))
(progn
(check-type relative-to (member :block :current))
(check-type n real)
(check-type stream (or stream (member t nil))))
(let ((stream (case stream
((t) *terminal-io*)
((nil) *standard-output*)
@ -987,12 +988,11 @@
(type (or stream (member t nil)) stream)
(values null))
#+ecl
(unless (member kind '(:line :section :line-relative :section-relative))
(error 'simple-type-error
:format-control "~A is not a valid argument to PPRINT-TAB"
:format-arguments (list kind)
:datum kind
:expected-type '(member :line :section :line-relative :section-relative)))
(progn
(check-type kind (member :line :section :line-relative
:section-relative))
(check-type colinc unsigned-byte)
(check-type colnum unsigned-byte))
(let ((stream (case stream
((t) *terminal-io*)
((nil) *standard-output*)
@ -1126,14 +1126,15 @@
(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
(declare (type (or pprint-dispatch-table null) table))
(let* ((orig (or table *initial-pprint-dispatch*))
(new (make-pprint-dispatch-table
:entries (copy-list (pprint-dispatch-table-entries orig))))
(new-cons-entries (pprint-dispatch-table-cons-entries new)))
(maphash #'(lambda (key value)
(setf (gethash key new-cons-entries) value))
(pprint-dispatch-table-cons-entries orig))
new))
(let* ((orig (or table *initial-pprint-dispatch*)))
(check-type orig pprint-dispatch-table)
(let* ((new (make-pprint-dispatch-table
:entries (copy-list (pprint-dispatch-table-entries orig))))
(new-cons-entries (pprint-dispatch-table-cons-entries new)))
(maphash #'(lambda (key value)
(setf (gethash key new-cons-entries) value))
(pprint-dispatch-table-cons-entries orig))
new)))
(defun default-pprint-dispatch (stream object)
(write-ugly-object object stream))

45
src/lsp/predlib.lsp
View file

@ -251,12 +251,14 @@ has no fill-pointer, and is not adjustable."
(put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
(defconstant +upgraded-array-element-types+
'(NIL BASE-CHAR CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SINGLE-FLOAT DOUBLE-FLOAT T))
'(NIL BASE-CHAR #+unicode CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SINGLE-FLOAT DOUBLE-FLOAT T))
(defun upgraded-array-element-type (element-type &optional env)
(dolist (v +upgraded-array-element-types+ 'T)
(when (subtypep element-type v)
(return v))))
(if (member element-type +upgraded-array-element-types+ :test #'eq)
element-type
(dolist (v +upgraded-array-element-types+ 'T)
(when (subtypep element-type v)
(return v)))))
(defun upgraded-complex-part-type (real-type &optional env)
;; ECL does not have specialized complex types. If we had them, the
@ -426,14 +428,33 @@ Returns T if X belongs to TYPE; NIL otherwise."
(error-type-specifier type))))))
#+clos
(defun si::subclassp (low high)
(defun subclassp (low high)
(or (eq low high)
(member high (sys:instance-ref low 4))) ; (class-precedence-list low)
(member high (sys:instance-ref low 4) :test #'eq)) ; (class-precedence-list low)
#+(or)
(or (eq low high)
(dolist (class (sys:instance-ref low 1)) ; (class-superiors low)
(when (si::subclassp class high) (return t)))))
#+clos
(defun of-class-p (object class)
(declare (optimize (speed 3) (safety 0)))
(macrolet ((class-precedence-list (x)
`(instance-ref ,x 4))
(class-name (x)
`(instance-ref ,x 0)))
(let* ((x-class (class-of object)))
(declare (class x-class))
(if (eq x-class class)
t
(let ((x-cpl (class-precedence-list x-class)))
(if (instancep class)
(member class x-cpl :test #'eq)
(dolist (c x-cpl nil)
(declare (class c))
(when (eq (class-name c) class)
(return t)))))))))
#+(and clos ecl-min)
(defun clos::classp (foo)
(declare (ignore foo))
@ -762,11 +783,13 @@ if not possible."
;;
(defun fast-upgraded-array-element-type (type)
(declare (si::c-local))
(if (eql type '*)
'*
(dolist (other-type +upgraded-array-element-types+ 'T)
(when (fast-subtypep type other-type)
(return other-type)))))
(cond ((eql type '*) '*)
((member type +upgraded-array-element-types+ :test #'eq)
type)
(t
(dolist (other-type +upgraded-array-element-types+ 'T)
(when (fast-subtypep type other-type)
(return other-type))))))
;;
;; This canonicalizes the array type into the form

2
src/lsp/seq.lsp
View file

@ -36,7 +36,7 @@
(cond ((consp type)
(setq name (first type) args (cdr type)))
((si::instancep type)
(setf name (class-name type) args nil))
(setf name (class-name (the class type)) args nil))
(t
(setq name type args nil)))
(case name

10
src/lsp/setf.lsp
View file

@ -493,7 +493,9 @@ retrieved by (DOCUMENTATION 'SYMBOL 'FUNCTION)."
(IF (SYMBOLP GETTER)
(SUBST (LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS))
(CAR STORES)
`(LET* ,ALL-VARS ,SETTER))
`(LET* ,ALL-VARS
(DECLARE (:READ-ONLY ,@(mapcar #'first all-vars)))
,SETTER))
(DO ((D VARS (CDR D))
(V VALS (CDR V))
(LET-LIST NIL (CONS (LIST (CAR D) (CAR V)) LET-LIST)))
@ -507,7 +509,11 @@ retrieved by (DOCUMENTATION 'SYMBOL 'FUNCTION)."
(LIST* (QUOTE ,function) GETTER ,@varlist ,restvar))
(LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS))))
LET-LIST)
`(LET* ,(NREVERSE LET-LIST) ,SETTER)))))))))
`(LET* ,(NREVERSE LET-LIST)
(DECLARE (:READ-ONLY ,@(mapcar #'first all-vars)
,@vars))
,SETTER)))))))))
#|
(defmacro define-modify-macro (name lambda-list function &optional doc-string)
(let ((update-form