Commit ea7b544a authored by jjgarcia's avatar jjgarcia

Xmas fixes. See CHANGELOG for list of changes.

parent b6c8edfb
......@@ -14,6 +14,10 @@ ECL 1.0
- Fixes in the documentation and error messages (J. Stecklina)
- The reader was not able to interpret RANDOM-STATE objects.
- The routines in the pretty printer now check the type of the arguments.
* Visible changes:
- SI:MKSTEMP now accepts and returns pathnames.
......@@ -28,6 +32,9 @@ ECL 1.0
- ECL now checks whether the lambda list of a DEFMETHOD is compatible in
length with a previously specified one.
- When parsing a physical pathname, version is NIL unless the pathname
has a name or a type components, in which case version is :NEWEST.
* Internals:
- The compiler now uses a more detailed tree to represent the code, keeping
......@@ -36,8 +43,8 @@ ECL 1.0
- The compiler structures now print unreadably to simplify inspection.
- New algorithm for computing whether a function has to have a lexical
environment, a full environment or none.
- New algorithm for computing whether a function has to have a
stack-allocated lexical environment, a full environment or none.
- Do not replace LET/LET* variables whose value has side effects.
......@@ -50,11 +57,12 @@ ECL 1.0
- Floats are properly read even when *read-base* is not 10.
- Support for binary streams of arbitrary byte size. By default, streams are
now of type CHARACTER which is equivalent to (UNSIGNED-BYTE 8). Streams of
other types, such as UNSIGNED-BYTE, (UNSIGNED-BYTE 100), (SIGNED-BYTE 2),
etc, are also supported, except for the function FILE-POSITION, which
will reject to work if the byte size is not a multiple of 8.
- Support for binary streams of arbitrary byte size. By default, binary
streams are written with an octet as header, which is used to determine
the actual length of the file. However, if you pass the argument
:use-header-p = NIL to the function OPEN, the header is not used and
instead the size in bits of the stream element type is rounded to a
multiple of 8 (M. Goffioul)
- Fixed the order of evaluation of arguments in INCF,DECF,etc (M.Goffioul).
......@@ -66,6 +74,98 @@ ECL 1.0
- The space should print as #\ instead of #\Space.
- The implementation of (SETF VALUES) now produces the right result
when there are nested (SETF VALUES) forms.
- DEFGENERIC now signals a PROGRAM-ERROR when the syntax is incorrect.
- The sequence functions now also accept class objects.
- DESCRIBE takes an additional (in ECL optional) argument denoting the
stream to which the description is written (M. Goffioul)
- Important fixes in how arrays are printed with *print-readably* = T.
Displaced bitvectors now print properly. (M. Goffioul)
- SETF-functions can now be traced.
- In PATHNAME-MATCH-P, mask's missing components become :WILD.
- A physical namestring without file name/type has now version NIL.
Otherwise version defaults to :NEWEST. This ensures that directory
names have version set to NIL.
- The constants in the code created by COMPILE are now EQ to those in the
original forms.
- FIND-METHOD checks the validity of the specializers list.
* The indentation value in PPRINT-INDENT is a real number. We round it to the
nearest integer.
* PRINT-UNREADABLE-OBJECT always outputs a space before the identity and
after the type, even if the forms have been omitted.
* PPRINT-LOGICAL-BLOCK only accepts strings as :PREFIX and :SUFFIX arguments
and these strings need not be simple.
- All non graphic characters now have a name "A~D" where ~D is the character
code in hexadecimal form.
* The code for handling *PRINT-LINES* was broken.
- WRITE now accepts the keyword arguments :LINES, :MISER-WIDTH,
:PPRINT-DISPATCH, and :RIGHT-MARGIN.
* *PRINT-LEVEL* and *PRINT-LENGTH now affect printing of structures and
instances, as well as PPRINT-LOGICAL-BLOCK.
* In format directives, a negative value of "minpad" is converted to zero.
* PPRINT-LOGICAL-BLOCK now includes support for printing circular
structures when *PRINT-CIRCLE* = T.
- FLOAT-PRECISION now really returns the number of siginificant digits
in a denormalized float.
- PPRINT-TAB did not compute the tab positions properly in any case.
- "~<~>" removed all padding when the line length exceeded the minimal
number of columns.
- FORMAT now signals an error (as per ANSI 22.3.5.2) when a format string
mixes ~<...~:;...~> with ~W, ~I, ~_, ~<...~:> or ~T.
- DOCUMENTATION now works on generic functions and methods.
- Improved initarg checking in SHARED-INITIALIZE, REINITIALIZE-INSTANCE,
MAKE-INSTANCE, UPDATE-INSTANCE-FOR-{DIFFERENT-CLASS,REDEFINED-CLASS}.
Now the keyword arguments of the applicable methods are considered to
be valid initargs (ANSI 7.1.2)
* MOP compliance:
- ADD-METHOD is now a generic function and implements most of the protocol in
the specification except for the calls to ADD-DIRECT-METHOD, because we do
not have specializer objects, and for the call to
COMPUTE-DISCRIMINATING-FUNCTION because of the differences in the function
calling protocol.
- Implemented all of the generic function initialization protocol including
ENSURE-GENERIC-FUNCTION, ENSURE-GENERIC-FUNCTION-USING-CLASS, and
(RE)INITIALIZE-INSTANCE specializations. Generic functions can now be
redefined and there are better checks to ensure the consistency between the
lambda lists of a generic function and it methods.
- Implemented SLOT-{EXISTS-P,VALUE,MAKUNBOUND,BOUNDP}-USING-CLASS.
---
NOTES:
- Remarks preceded by (*) apply only when ECL is configured with CMU CL's
format and pretty printing routines (configure flag --with-cmuformat).
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:79 ***
......
......@@ -660,10 +660,11 @@ cl_array_displacement(cl_object a)
assert_type_array(a);
to_array = a->array.displaced;
if (Null(to_array))
if (Null(to_array)) {
offset = 0;
else {
to_array = CAR(a->array.displaced);
} else if (Null(to_array = CAR(a->array.displaced))) {
offset = 0;
} else {
switch (array_elttype(a)) {
case aet_object:
offset = a->array.self.t - to_array->array.self.t;
......
......@@ -129,7 +129,6 @@ cl_object
si_put_sysprop(cl_object sym, cl_object prop, cl_object value)
{
cl_object plist;
assert_type_symbol(sym);
plist = gethash_safe(sym, cl_core.system_properties, Cnil);
sethash(sym, cl_core.system_properties, si_put_f(plist, value, prop));
@(return value);
......@@ -139,7 +138,6 @@ cl_object
si_rem_sysprop(cl_object sym, cl_object prop)
{
cl_object plist, found;
assert_type_symbol(sym);
plist = gethash_safe(sym, cl_core.system_properties, Cnil);
plist = si_rem_f(plist, prop);
found = VALUES(1);
......
......@@ -408,12 +408,32 @@ cl_char_int(cl_object c)
cl_object
cl_char_name(cl_object c)
{
assert_type_character(c);
@(return gethash_safe(c, cl_core.char_names, Cnil))
cl_index code = char_code(c);
cl_object output;
if (code > 127) {
char name[] = "A00";
name[2] = ecl_digit_char(code & 0xF, 16);
name[1] = ecl_digit_char(code / 16, 16);
output = make_string_copy(name);
} else {
output = gethash_safe(c, cl_core.char_names, Cnil);
}
@(return output);
}
cl_object
cl_name_char(cl_object s)
cl_name_char(cl_object name)
{
@(return gethash_safe(cl_string(s), cl_core.char_names, Cnil))
cl_object c = gethash_safe((name = cl_string(name)), cl_core.char_names, Cnil);
if (c == Cnil && length(name) == 3) {
char *s = name->string.self;
if (s[0] == 'A' || s[0] == 'a') {
int d2 = digitp(s[2], 16);
int d1 = digitp(s[1], 16);
if (d1 >= 0 && d2 >= 0) {
c = CODE_CHAR(d1 * 16 + d2);
}
}
}
@(return c);
}
......@@ -68,6 +68,9 @@ disassemble_lambda(cl_object bytecodes) {
bds_bind(@'*print-pretty*', Cnil);
if (bytecodes->bytecodes.name == OBJNULL)
goto NO_ARGS;
/* Name of LAMBDA */
print_arg("\nName:\t\t", bytecodes->bytecodes.name);
......@@ -98,7 +101,7 @@ NO_KEYS:
/* Print aux arguments */
print_arg("\nDocumentation:\t", *(data++));
print_arg("\nDeclarations:\t", *(data++));
NO_ARGS:
base = vector = (cl_opcode *)bytecodes->bytecodes.code;
disassemble(bytecodes, vector);
......
This diff is collapsed.
......@@ -252,7 +252,7 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
/* INV: if "source" is not a valid stream, file.d will complain */
strm = source;
} else {
strm = open_stream(source, smm_input, Cnil, Cnil, 8, 1);
strm = open_stream(source, smm_input, Cnil, Cnil, 8, 1, 1);
if (Null(strm))
@(return Cnil)
}
......
......@@ -263,7 +263,7 @@ cl_boot(int argc, char **argv)
cl_core.null_stream = @make_broadcast_stream(0);
cl_core.system_properties =
cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */
cl__make_hash_table(@'equal', MAKE_FIXNUM(1024), /* size */
make_shortfloat(1.5f), /* rehash-size */
make_shortfloat(0.75f), /* rehash-threshold */
Ct); /* thread-safe */
......
......@@ -797,17 +797,42 @@ cl_float_digits(cl_object x)
cl_object
cl_float_precision(cl_object x)
{
int precision;
switch (type_of(x)) {
case t_shortfloat:
x = (sf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(24);
case t_shortfloat: {
float f = sf(x);
if (f == 0.0) {
precision = 0;
} else {
int exp;
frexpf(f, &exp);
if (exp >= FLT_MIN_EXP) {
precision = FLT_MANT_DIG;
} else {
precision = FLT_MANT_DIG - (FLT_MIN_EXP - exp);
}
}
break;
case t_longfloat:
x = (lf(x) == 0.0) ? MAKE_FIXNUM(0) : MAKE_FIXNUM(53);
}
case t_longfloat: {
double f = lf(x);
if (f == 0.0) {
precision = 0;
} else {
int exp;
frexp(f, &exp);
if (exp >= DBL_MIN_EXP) {
precision = DBL_MANT_DIG;
} else {
precision = DBL_MANT_DIG - (DBL_MIN_EXP - exp);
}
}
break;
}
default:
FEtype_error_float(x);
}
@(return x)
@(return MAKE_FIXNUM(precision))
}
cl_object
......@@ -825,7 +850,7 @@ cl_integer_decode_float(cl_object x)
} else {
if (d < 0.0) {
s = -1;
d = -frexp(d, &e);
d = frexp(-d, &e);
} else {
s = 1;
d = frexp(d, &e);
......@@ -844,7 +869,7 @@ cl_integer_decode_float(cl_object x)
} else {
if (d < 0.0) {
s = -1;
d = -frexpf(d, &e);
d = frexpf(-d, &e);
} else {
s = 1;
d = frexpf(d, &e);
......
......@@ -52,23 +52,20 @@ rando(cl_object x, cl_object rs)
cl_object
make_random_state(cl_object rs)
{
cl_object z;
cl_object z = cl_alloc_object(t_random);
if (Null(rs)) {
z = cl_alloc_object(t_random);
z->random.value = symbol_value(@'*random-state*')->random.value;
return(z);
} else if (rs == Ct) {
z = cl_alloc_object(t_random);
if (rs == Ct) {
z->random.value = time(0);
return(z);
} else if (type_of(rs) != t_random)
FEwrong_type_argument(@'random-state', rs);
else {
z = cl_alloc_object(t_random);
} else {
if (Null(rs)) {
rs = symbol_value(@'*random-state*');
}
if (type_of(rs) != t_random) {
FEwrong_type_argument(@'random-state', rs);
}
z->random.value = rs->random.value;
return(z);
}
return(z);
}
static void
......
......@@ -525,7 +525,10 @@ parse_namestring(const char *s, cl_index start, cl_index end, cl_index *ep,
if (type == @':error')
return Cnil;
}
version = @':newest';
if (name != Cnil || type != Cnil)
version = @':newest';
else
version = Cnil;
make_it:
if (*ep >= end) *ep = end;
path = make_pathname(host, device, path, name, type, version);
......@@ -889,8 +892,16 @@ NO_DIRECTORY:
}
}
}
} else if (y != @':newest' && !truncate_if_unreadable) {
return Cnil;
} else if (!truncate_if_unreadable) {
/* Namestrings of physical pathnames have restrictions... */
if (Null(x->pathname.name) && Null(x->pathname.type)) {
/* Directories cannot have a version number */
if (y != Cnil)
return Cnil;
} else if (y != @':newest') {
/* Filenames have an implicit version :newest */
return Cnil;
}
}
return get_output_stream_string(buffer);
}
......@@ -1112,6 +1123,8 @@ static bool
path_item_match(cl_object a, cl_object mask) {
if (mask == @':wild')
return TRUE;
/* If a component in the tested path is a wildcard field, this
can only be matched by the same wildcard field in the mask */
if (type_of(a) != t_string || mask == Cnil)
return (a == mask);
if (type_of(mask) != t_string)
......@@ -1153,24 +1166,31 @@ path_list_match(cl_object a, cl_object mask) {
cl_object
cl_pathname_match_p(cl_object path, cl_object mask)
{
cl_object output = Cnil;
path = cl_pathname(path);
mask = cl_pathname(mask);
if (path->pathname.logical != mask->pathname.logical)
return Cnil;
goto OUTPUT;
#if 0
/* INV: This was checked in the calling routine */
if (!path_item_match(path->pathname.host, mask->pathname.host))
return Cnil;
goto OUTPUT;
#endif
if (!path_list_match(path->pathname.directory, mask->pathname.directory))
return Cnil;
if (!path_item_match(path->pathname.name, mask->pathname.name))
return Cnil;
if (!path_item_match(path->pathname.type, mask->pathname.type))
return Cnil;
if (!path_item_match(path->pathname.version, mask->pathname.version))
return Cnil;
return Ct;
/* Missing components default to :WILD */
if (!Null(mask->pathname.directory) &&
!path_list_match(path->pathname.directory, mask->pathname.directory))
goto OUTPUT;
if (!Null(mask->pathname.name) &&
!path_item_match(path->pathname.name, mask->pathname.name))
goto OUTPUT;
if (!Null(mask->pathname.type) &&
!path_item_match(path->pathname.type, mask->pathname.type))
goto OUTPUT;
if (Null(mask->pathname.version) ||
path_item_match(path->pathname.version, mask->pathname.version))
output = Ct;
OUTPUT:
@(return output)
}
/* --------------- PATHNAME TRANSLATIONS ------------------ */
......
This diff is collapsed.
......@@ -19,6 +19,7 @@
#include <math.h>
#include <ctype.h>
#include <string.h>
#include <stdlib.h>
#include "ecl.h"
#include "internal.h"
#include "ecl-inl.h"
......@@ -318,207 +319,96 @@ read_object(cl_object in)
cl_object
parse_number(const char *s, cl_index end, cl_index *ep, int radix)
{
#ifdef mingw32
/* FIXME! Why does Mingw32 insist on using a float pow() ? */
#define pow powl
#endif
cl_object x, y;
int sign;
cl_object integer_part;
double fraction, fraction_unit, f;
char exponent_marker;
int exponent, d;
cl_index i, j, k;
if (radix != 10) {
/* Floating point numbers are read always in base 10 */
for (i=0; i < end; i++) {
if (s[i] == '.') {
radix = 10;
break;
cl_index i, j, exp_marker_loc = 0;
bool is_float = 0;
for (i=0; i < end; i++) {
char c = s[i];
if (c == '/') {
cl_object num, den;
num = parse_number(s, i, &j, radix);
if (num == OBJNULL || (j < i) ||
(!FIXNUMP(num) && type_of(num) != t_bignum))
{
*ep = j;
return OBJNULL;
}
}
}
/*
DIRTY CODE!!
*/
BEGIN:
exponent_marker = 'E';
i = 0;
sign = 1;
if (s[i] == '+')
i++;
else if (s[i] == '-') {
sign = -1;
i++;
}
integer_part = big_register0_get();
if (i >= end)
goto NO_NUMBER;
if (s[i] == '.') {
i++;
goto FRACTION;
}
if (!basep(radix) || (d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
do {
big_mul_ui(integer_part, radix);
big_add_ui(integer_part, d);
i++;
} while (i < end && (d = digitp(s[i], radix)) >= 0);
if (i >= end)
goto MAKE_INTEGER;
if (s[i] == '.') {
if (radix != 10) {
i++;
den = parse_number(s+i, end-i, ep, radix);
*ep += i;
if (num == OBJNULL || (*ep < end) ||
(!FIXNUMP(num) && type_of(num) != t_bignum))
{
return OBJNULL;
}
return make_ratio(num, den);
} else if (c == '.') {
radix = 10;
goto BEGIN;
if (i == (end-1)) {
cl_object aux = parse_integer(s, end-1, ep, radix);
(*ep)++;
return aux;
} else {
is_float = 1;
}
} else if ((digitp(c, radix) < 0) && is_exponent_marker(c)) {
exp_marker_loc = i;
is_float = 1;
break;
}
if (++i >= end)
goto MAKE_INTEGER;
else if (digitp(s[i], radix) >= 0)
goto FRACTION;
else if (is_exponent_marker(s[i])) {
fraction = (double)sign * big_to_double(integer_part);
goto EXPONENT;
} else
goto MAKE_INTEGER;
}
if (s[i] == '/') {
i++;
if (sign < 0)
big_complement(integer_part);
x = big_register_normalize(integer_part);
/* DENOMINATOR */
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
integer_part = big_register0_get();
do {
big_mul_ui(integer_part, radix);
big_add_ui(integer_part, d);
i++;
} while (i < end && (d = digitp(s[i], radix)) >= 0);
y = big_register_normalize(integer_part);
x = make_ratio(x, y);
goto END;
}
if (is_exponent_marker(s[i])) {
fraction = (double)sign * big_to_double(integer_part);
goto EXPONENT;
}
goto NO_NUMBER;
MAKE_INTEGER:
if (sign < 0)
big_complement(integer_part);
x = big_register_normalize(integer_part);
goto END;
FRACTION:
if (radix != 10)
goto NO_NUMBER;
radix = 10;
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
fraction = 0.0;
fraction_unit = 1000000000.0;
for (;;) {
k = j = 0;
do {
j = 10*j + d;
i++;
k++;
if (i < end)
d = digitp(s[i], radix);
else
break;
} while (k < 9 && d >= 0);
while (k++ < 9)
j *= 10;
fraction += ((double)j /fraction_unit);
if (i >= end || d < 0)
if (!is_float) {
return parse_integer(s, end, ep, radix);
} else {
/* We use strtod() for parsing floating point numbers
* accurately. However, this routine only accepts character
* 'e' or 'E' as exponent markers and we have to make a copy
* of the number with this exponent marker. */
#ifdef __GNUC__
char buffer[end+1];
#else
char *buffer = cl_alloc_atomic(end+1);
#endif
char *parse_end;
char exp_marker;
cl_object output;
double d;
memcpy(buffer, s, end);
buffer[end] = '\0';
if (exp_marker_loc) {
buffer[exp_marker_loc] = 'e';
exp_marker = s[exp_marker_loc];
} else {
exp_marker = ecl_current_read_default_float_format();
}
d = strtod(buffer, &parse_end);
*ep = (parse_end - buffer);
if (*ep == 0) {
output = OBJNULL;
goto OUTPUT;
}
/* make_{short|long}float signals an error when an overflow
occurred while reading the number. Thus, no safety check
is required here. */
MAKE_FLOAT:
switch (exp_marker) {
case 'e': case 'E':
exp_marker = ecl_current_read_default_float_format();
goto MAKE_FLOAT;
case 'f': case 'F': case 's': case 'S':
output = make_shortfloat(d);
break;
fraction_unit *= 1000000000.0;
}
fraction += big_to_double(integer_part);
fraction *= (double)sign;
if (i >= end)
goto MAKE_FLOAT;
if (is_exponent_marker(s[i]))
goto EXPONENT;
goto MAKE_FLOAT;
EXPONENT:
if (radix != 10)
goto NO_NUMBER;
radix = 10;
exponent_marker = s[i];
i++;
if (i >= end)
goto NO_NUMBER;
sign = 1;
if (s[i] == '+')
i++;
else if (s[i] == '-') {
sign = -1;
i++;
}
if (i >= end)
goto NO_NUMBER;
if ((d = digitp(s[i], radix)) < 0)
goto NO_NUMBER;
exponent = 0;
do {
exponent = 10 * exponent + d;
i++;
} while (i < end && (d = digitp(s[i], radix)) >= 0);
d = exponent * sign;
f = 10.0;
if (d < (DBL_MIN_10_EXP - 1)) {
fraction /= pow(10.0, (DBL_MIN_10_EXP - 1) - d);
d = DBL_MIN_10_EXP - 1;
} else if (d > (DBL_MAX_10_EXP - 1)) {
fraction *= pow(10.0, d - (DBL_MAX_10_EXP - 1));
d = DBL_MAX_10_EXP - 1;
}
fraction *= pow(10.0, d);
MAKE_FLOAT:
/* make_{short|long}float signals an error when an overflow
occurred while reading the number. Thus, no safety check
is required here. */
switch (exponent_marker) {
case 'e': case 'E':
exponent_marker = ecl_current_read_default_float_format();
goto MAKE_FLOAT;
case 'f': case 'F': case 's': case 'S':
x = make_shortfloat((float)fraction);
break;
case 'd': case 'D': case 'l': case 'L':
x = make_longfloat((double)fraction);
break;
case 'b': case 'B':
goto NO_NUMBER;
case 'd': case 'D': case 'l': case 'L':
output = make_longfloat(d);
break;
default:
output = OBJNULL;
}