From 5e8ec11bdd8f4ade1eb98884dce4de8a07609548 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 6 May 2016 08:41:52 +0200 Subject: [PATCH] cosmetic: fix indent (rest of C) --- src/c/numbers/abs.d | 2 +- src/c/numbers/atan.d | 243 +- src/c/numbers/ceiling.d | 409 ++- src/c/numbers/conjugate.d | 33 +- src/c/numbers/cos.d | 53 +- src/c/numbers/cosh.d | 59 +- src/c/numbers/divide.d | 568 ++--- src/c/numbers/exp.d | 51 +- src/c/numbers/expt.d | 184 +- src/c/numbers/float_fix_compare.d | 103 +- src/c/numbers/floor.d | 431 ++-- src/c/numbers/log.d | 203 +- src/c/numbers/minmax.d | 75 +- src/c/numbers/minus.d | 591 +++-- src/c/numbers/minusp.d | 43 +- src/c/numbers/negate.d | 43 +- src/c/numbers/number_compare.d | 339 ++- src/c/numbers/number_equalp.d | 328 ++- src/c/numbers/one_minus.d | 49 +- src/c/numbers/one_plus.d | 50 +- src/c/numbers/plus.d | 584 +++-- src/c/numbers/plusp.d | 40 +- src/c/numbers/round.d | 230 +- src/c/numbers/sin.d | 56 +- src/c/numbers/sinh.d | 58 +- src/c/numbers/sqrt.d | 84 +- src/c/numbers/tan.d | 42 +- src/c/numbers/tanh.d | 42 +- src/c/numbers/times.d | 594 +++-- src/c/numbers/truncate.d | 124 +- src/c/numbers/zerop.d | 40 +- src/c/package.d | 1569 ++++++------ src/c/pathname.d | 2706 ++++++++++---------- src/c/predicate.d | 579 +++-- src/c/print.d | 517 ++-- src/c/printer/float_string_old.d | 431 ++-- src/c/printer/float_to_digits.d | 347 ++- src/c/printer/float_to_string.d | 169 +- src/c/printer/print_unreadable.d | 121 +- src/c/printer/write_array.d | 331 ++- src/c/printer/write_code.d | 107 +- src/c/printer/write_list.d | 213 +- src/c/printer/write_object.d | 229 +- src/c/printer/write_sse.d | 128 +- src/c/printer/write_symbol.d | 346 ++- src/c/printer/write_ugly.d | 579 +++-- src/c/read.d | 3822 ++++++++++++++-------------- src/c/reader/parse_integer.d | 189 +- src/c/reader/parse_number.d | 373 ++- src/c/reference.d | 235 +- src/c/sequence.d | 411 ++- src/c/serialize.d | 829 +++--- src/c/sse2.d | 197 +- src/c/stacks.d | 822 +++--- src/c/string.d | 1225 ++++----- src/c/structure.d | 165 +- src/c/symbol.d | 576 +++-- src/c/tcp.d | 336 ++- src/c/threads/atomic.d | 73 +- src/c/threads/barrier.d | 237 +- src/c/threads/condition_variable.d | 129 +- src/c/threads/ecl_atomics.h | 23 +- src/c/threads/mailbox.d | 219 +- src/c/threads/mutex.d | 245 +- src/c/threads/process.d | 979 ++++--- src/c/threads/queue.d | 519 ++-- src/c/threads/rwlock.d | 263 +- src/c/threads/semaphore.d | 167 +- src/c/time.d | 281 +- src/c/typespec.d | 499 ++-- src/c/unixfsys.d | 1812 +++++++------ src/c/unixsys.d | 1177 +++++---- 72 files changed, 14819 insertions(+), 15107 deletions(-) diff --git a/src/c/numbers/abs.d b/src/c/numbers/abs.d index 65aa2f82d..bba6282d0 100644 --- a/src/c/numbers/abs.d +++ b/src/c/numbers/abs.d @@ -2,7 +2,7 @@ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - * abs.d -- absolute value + * abs.d - absolute value * * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya * Copyright (c) 1990 Giuseppe Attardi diff --git a/src/c/numbers/atan.d b/src/c/numbers/atan.d index e1096d034..bfcd008cd 100644 --- a/src/c/numbers/atan.d +++ b/src/c/numbers/atan.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - atan1.d -- Trascendental functions: arc tangent -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * atan1.d - Trascendental functions: arc tangent + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,136 +22,138 @@ static double ecl_atan2_double(double y, double x) { - if (signbit(x)) { - if (signbit(y)) { - return -ECL_PI_D + atan(-y / -x); - } else if (y == 0) { - return ECL_PI_D; - } else { - return ECL_PI_D - atan(y / -x); - } - } else if (x == 0) { - if (signbit(y)) { - return -ECL_PI2_D; - } else if (y == 0) { - return x / y; /* Produces a NaN */ - } else { - return ECL_PI2_D; - } - } else { - if (signbit(y)) { - return -atan(-y / x); - } else if (y == 0) { - return (double)0; - } else { - return atan(y / x); - } - } + if (signbit(x)) { + if (signbit(y)) { + return -ECL_PI_D + atan(-y / -x); + } else if (y == 0) { + return ECL_PI_D; + } else { + return ECL_PI_D - atan(y / -x); + } + } else if (x == 0) { + if (signbit(y)) { + return -ECL_PI2_D; + } else if (y == 0) { + return x / y; /* Produces a NaN */ + } else { + return ECL_PI2_D; + } + } else { + if (signbit(y)) { + return -atan(-y / x); + } else if (y == 0) { + return (double)0; + } else { + return atan(y / x); + } + } } #ifdef ECL_LONG_FLOAT static long double ecl_atan2_long_double(long double y, long double x) { - if (signbit(x)) { - if (signbit(y)) { - return -ECL_PI_L + atanl(-y / -x); - } else if (y == 0) { - return ECL_PI_L; - } else { - return ECL_PI_L - atanl(y / -x); - } - } else if (x == 0) { - if (signbit(y)) { - return -ECL_PI2_L; - } else if (y == 0) { - return x / y; /* Produces a NaN */ - } else { - return ECL_PI2_L; - } - } else { - if (signbit(y)) { - return -atanl(-y / x); - } else if (y == 0) { - return (long double)0; - } else { - return atanl(y / x); - } - } + if (signbit(x)) { + if (signbit(y)) { + return -ECL_PI_L + atanl(-y / -x); + } else if (y == 0) { + return ECL_PI_L; + } else { + return ECL_PI_L - atanl(y / -x); + } + } else if (x == 0) { + if (signbit(y)) { + return -ECL_PI2_L; + } else if (y == 0) { + return x / y; /* Produces a NaN */ + } else { + return ECL_PI2_L; + } + } else { + if (signbit(y)) { + return -atanl(-y / x); + } else if (y == 0) { + return (long double)0; + } else { + return atanl(y / x); + } + } } #endif cl_object ecl_atan2(cl_object y, cl_object x) { - cl_object output; - ECL_MATHERR_CLEAR; - { + cl_object output; + ECL_MATHERR_CLEAR; + { #ifdef ECL_LONG_FLOAT - int tx = ecl_t_of(x); - int ty = ecl_t_of(y); - if (tx < ty) - tx = ty; - if (tx == t_longfloat) { - long double d = ecl_atan2_long_double(ecl_to_long_double(y), - ecl_to_long_double(x)); - output = ecl_make_long_float(d); - } else { - double dx = ecl_to_double(x); - double dy = ecl_to_double(y); - double dz = ecl_atan2_double(dy, dx); - if (tx == t_doublefloat) { - output = ecl_make_double_float(dz); - } else { - output = ecl_make_single_float(dz); - } - } + int tx = ecl_t_of(x); + int ty = ecl_t_of(y); + if (tx < ty) + tx = ty; + if (tx == t_longfloat) { + long double d = ecl_atan2_long_double(ecl_to_long_double(y), + ecl_to_long_double(x)); + output = ecl_make_long_float(d); + } else { + double dx = ecl_to_double(x); + double dy = ecl_to_double(y); + double dz = ecl_atan2_double(dy, dx); + if (tx == t_doublefloat) { + output = ecl_make_double_float(dz); + } else { + output = ecl_make_single_float(dz); + } + } #else - double dy = ecl_to_double(y); - double dx = ecl_to_double(x); - double dz = ecl_atan2_double(dy, dx); - if (ECL_DOUBLE_FLOAT_P(x) || ECL_DOUBLE_FLOAT_P(y)) { - output = ecl_make_double_float(dz); - } else { - output = ecl_make_single_float(dz); - } + double dy = ecl_to_double(y); + double dx = ecl_to_double(x); + double dz = ecl_atan2_double(dy, dx); + if (ECL_DOUBLE_FLOAT_P(x) || ECL_DOUBLE_FLOAT_P(y)) { + output = ecl_make_double_float(dz); + } else { + output = ecl_make_single_float(dz); + } #endif - } - ECL_MATHERR_TEST; - return output; + } + ECL_MATHERR_TEST; + return output; } cl_object ecl_atan1(cl_object y) { - if (ECL_COMPLEXP(y)) { + if (ECL_COMPLEXP(y)) { #if 0 /* ANSI states it should be this first part */ - cl_object z = ecl_times(cl_core.imag_unit, y); - z = ecl_plus(ecl_log1(ecl_one_plus(z)), - ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); - z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), - cl_core.imag_unit)); + cl_object z = ecl_times(cl_core.imag_unit, y); + z = ecl_plus(ecl_log1(ecl_one_plus(z)), + ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); + z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), + cl_core.imag_unit)); #else - cl_object z1, z = ecl_times(cl_core.imag_unit, y); - z = ecl_one_plus(z); - z1 = ecl_times(y, y); - z1 = ecl_one_plus(z1); - z1 = ecl_sqrt(z1); - z = ecl_divide(z, z1); - z = ecl_log1(z); - z = ecl_times(cl_core.minus_imag_unit, z); + cl_object z1, z = ecl_times(cl_core.imag_unit, y); + z = ecl_one_plus(z); + z1 = ecl_times(y, y); + z1 = ecl_one_plus(z1); + z1 = ecl_sqrt(z1); + z = ecl_divide(z, z1); + z = ecl_log1(z); + z = ecl_times(cl_core.minus_imag_unit, z); #endif /* ANSI */ - return z; - } else { - return ecl_atan2(y, ecl_make_fixnum(1)); - } + return z; + } else { + return ecl_atan2(y, ecl_make_fixnum(1)); + } } @(defun atan (x &optional (y OBJNULL)) -@ /* INV: type check in ecl_atan() & ecl_atan2() */ - /* FIXME ecl_atan() and ecl_atan2() produce generic errors - without recovery and function information. */ - if (y == OBJNULL) - @(return ecl_atan1(x)) - @(return ecl_atan2(x, y)) -@) + @ + /* INV: type check in ecl_atan() & ecl_atan2() */ + /* FIXME ecl_atan() and ecl_atan2() produce generic errors + without recovery and function information. */ + if (y == OBJNULL) { + @(return ecl_atan1(x)); + } + @(return ecl_atan2(x, y)); + @) diff --git a/src/c/numbers/ceiling.d b/src/c/numbers/ceiling.d index 7c128026d..60d370029 100644 --- a/src/c/numbers/ceiling.d +++ b/src/c/numbers/ceiling.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ceiling.d -- Implementation of CL:CEILING -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * ceiling.d - implementation of CL:CEILING + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -24,214 +19,214 @@ #include @(defun ceiling (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_ceiling1(x); - else - return ecl_ceiling2(x, y); -@) + @ + if (narg == 1) + return ecl_ceiling1(x); + else + return ecl_ceiling2(x, y); + @) cl_object ecl_ceiling1(cl_object x) { - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: { - const cl_env_ptr the_env = ecl_process_env(); - v0 = ecl_ceiling2(x->ratio.num, x->ratio.den); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - } - case t_singlefloat: { - float d = ecl_single_float(x); - float y = ceilf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = ceil(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: { + const cl_env_ptr the_env = ecl_process_env(); + v0 = ecl_ceiling2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + } + case t_singlefloat: { + float d = ecl_single_float(x); + float y = ceilf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = ceil(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = ceill(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = ceill(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: - FEwrong_type_nth_arg(@[ceiling],1,x,@[real]); - } - @(return v0 v1) + default: + FEwrong_type_nth_arg(@[ceiling],1,x,@[real]); + } + @(return v0 v1); } cl_object ecl_ceiling2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - cl_type ty; - ty = ecl_t_of(y); - if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) { - FEwrong_type_nth_arg(@[ceiling],2, y, @[real]); - } - switch(ecl_t_of(x)) { - case t_fixnum: - switch(ty) { - case t_fixnum: { /* FIX / FIX */ - cl_fixnum a = ecl_fixnum(x); cl_fixnum b = ecl_fixnum(y); - cl_fixnum q = a / b; cl_fixnum r = a % b; - if ((r^b) > 0 && r) { /* same signs and some remainder */ - v0 = ecl_make_fixnum(q+1); - v1 = ecl_make_fixnum(r-b); - } else { - v0 = ecl_make_fixnum(q); - v1 = ecl_make_fixnum(r); - } - break; - } - case t_bignum: { /* FIX / BIG */ - /* We must perform the division because there is the - * pathological case - * x = MOST_NEGATIVE_FIXNUM - * y = - MOST_NEGATIVE_FIXNUM - */ - ECL_WITH_TEMP_BIGNUM(bx,4); - _ecl_big_set_fixnum(bx, ecl_fixnum(x)); - v0 = _ecl_big_ceiling(bx, y, &v1); - break; - } - case t_ratio: /* FIX / RAT */ - v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - case t_singlefloat: { /* FIX / SF */ - float n = ecl_single_float(y); - float p = ecl_fixnum(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* FIX / DF */ - double n = ecl_double_float(y); - double p = ecl_fixnum(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + cl_type ty; + ty = ecl_t_of(y); + if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) { + FEwrong_type_nth_arg(@[ceiling],2, y, @[real]); + } + switch(ecl_t_of(x)) { + case t_fixnum: + switch(ty) { + case t_fixnum: { /* FIX / FIX */ + cl_fixnum a = ecl_fixnum(x); cl_fixnum b = ecl_fixnum(y); + cl_fixnum q = a / b; cl_fixnum r = a % b; + if ((r^b) > 0 && r) { /* same signs and some remainder */ + v0 = ecl_make_fixnum(q+1); + v1 = ecl_make_fixnum(r-b); + } else { + v0 = ecl_make_fixnum(q); + v1 = ecl_make_fixnum(r); + } + break; + } + case t_bignum: { /* FIX / BIG */ + /* We must perform the division because there is the + * pathological case + * x = MOST_NEGATIVE_FIXNUM + * y = - MOST_NEGATIVE_FIXNUM + */ + ECL_WITH_TEMP_BIGNUM(bx,4); + _ecl_big_set_fixnum(bx, ecl_fixnum(x)); + v0 = _ecl_big_ceiling(bx, y, &v1); + break; + } + case t_ratio: /* FIX / RAT */ + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + case t_singlefloat: { /* FIX / SF */ + float n = ecl_single_float(y); + float p = ecl_fixnum(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* FIX / DF */ + double n = ecl_double_float(y); + double p = ecl_fixnum(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* FIX / LF */ - long double n = ecl_long_float(y); - long double p = ecl_fixnum(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* FIX / LF */ + long double n = ecl_long_float(y); + long double p = ecl_fixnum(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - (void)0; /*Never reached */ - } - break; - case t_bignum: - switch(ecl_t_of(y)) { - case t_fixnum: { /* BIG / FIX */ - ECL_WITH_TEMP_BIGNUM(by,4); - _ecl_big_set_fixnum(by, ecl_fixnum(y)); - v0 = _ecl_big_ceiling(x, by, &v1); - break; - } - case t_bignum: { /* BIG / BIG */ - v0 = _ecl_big_ceiling(x, y, &v1); - break; - } - case t_ratio: /* BIG / RAT */ - v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - case t_singlefloat: { /* BIG / SF */ - float n = ecl_single_float(y); - float p = _ecl_big_to_double(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* BIG / DF */ - double n = ecl_double_float(y); - double p = _ecl_big_to_double(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + default: + (void)0; /*Never reached */ + } + break; + case t_bignum: + switch(ecl_t_of(y)) { + case t_fixnum: { /* BIG / FIX */ + ECL_WITH_TEMP_BIGNUM(by,4); + _ecl_big_set_fixnum(by, ecl_fixnum(y)); + v0 = _ecl_big_ceiling(x, by, &v1); + break; + } + case t_bignum: { /* BIG / BIG */ + v0 = _ecl_big_ceiling(x, y, &v1); + break; + } + case t_ratio: /* BIG / RAT */ + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + case t_singlefloat: { /* BIG / SF */ + float n = ecl_single_float(y); + float p = _ecl_big_to_double(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* BIG / DF */ + double n = ecl_double_float(y); + double p = _ecl_big_to_double(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* BIG / LF */ - long double n = ecl_long_float(y); - long double p = _ecl_big_to_double(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* BIG / LF */ + long double n = ecl_long_float(y); + long double p = _ecl_big_to_double(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - (void)0; /*Never reached */ - } - break; - case t_ratio: - switch(ecl_t_of(y)) { - case t_ratio: /* RAT / RAT */ - v0 = ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); - break; - default: /* RAT / ANY */ - v0 = ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); - v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); - } - break; - case t_singlefloat: { /* SF / ANY */ - float n = ecl_to_double(y); - float p = ecl_single_float(x)/n; - float q = ceilf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(p*n - q*n); - break; - } - case t_doublefloat: { /* DF / ANY */ - double n = ecl_to_double(y); - double p = ecl_double_float(x)/n; - double q = ceil(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + default: + (void)0; /*Never reached */ + } + break; + case t_ratio: + switch(ecl_t_of(y)) { + case t_ratio: /* RAT / RAT */ + v0 = ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); + break; + default: /* RAT / ANY */ + v0 = ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); + } + break; + case t_singlefloat: { /* SF / ANY */ + float n = ecl_to_double(y); + float p = ecl_single_float(x)/n; + float q = ceilf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(p*n - q*n); + break; + } + case t_doublefloat: { /* DF / ANY */ + double n = ecl_to_double(y); + double p = ecl_double_float(x)/n; + double q = ceil(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { /* LF / ANY */ - long double n = ecl_to_long_double(y); - long double p = ecl_long_float(x)/n; - long double q = ceill(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + case t_longfloat: { /* LF / ANY */ + long double n = ecl_to_long_double(y); + long double p = ecl_long_float(x)/n; + long double q = ceill(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: - FEwrong_type_nth_arg(@[ceiling], 1, x, @[real]); - } - ecl_return2(the_env, v0, v1); + default: + FEwrong_type_nth_arg(@[ceiling], 1, x, @[real]); + } + ecl_return2(the_env, v0, v1); } diff --git a/src/c/numbers/conjugate.d b/src/c/numbers/conjugate.d index 044b65ac6..18bc665fd 100644 --- a/src/c/numbers/conjugate.d +++ b/src/c/numbers/conjugate.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - conjugate.d -- Trascendental functions: conjugateine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * conjugate.d - trascendental functions: conjugateine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,19 +18,19 @@ cl_object cl_conjugate(cl_object x) { - @(return ecl_conjugate(x)); + @(return ecl_conjugate(x)); } static cl_object ecl_conjugate_real(cl_object x) { - return x; + return x; } static cl_object ecl_conjugate_complex(cl_object x) { - return ecl_make_complex(x->complex.real, ecl_negate(x->complex.imag)); + return ecl_make_complex(x->complex.real, ecl_negate(x->complex.imag)); } MATH_DEF_DISPATCH1_NE(conjugate, @[conjugate], @[number], diff --git a/src/c/numbers/cos.d b/src/c/numbers/cos.d index 019f812a3..625e6f572 100644 --- a/src/c/numbers/cos.d +++ b/src/c/numbers/cos.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cos.d -- Trascendental functions: cosine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * cos.d - trascendental functions: cosine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,46 +22,46 @@ cl_object cl_cos(cl_object x) { - @(return ecl_cos(x)); + @(return ecl_cos(x)); } static cl_object ecl_cos_rational(cl_object x) { - return ecl_make_single_float(cosf(ecl_to_float(x))); + return ecl_make_single_float(cosf(ecl_to_float(x))); } static cl_object ecl_cos_single_float(cl_object x) { - return ecl_make_single_float(cosf(ecl_single_float(x))); + return ecl_make_single_float(cosf(ecl_single_float(x))); } static cl_object ecl_cos_double_float(cl_object x) { - return ecl_make_double_float(cos(ecl_double_float(x))); + return ecl_make_double_float(cos(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_cos_long_float(cl_object x) { - return ecl_make_long_float(cosl(ecl_long_float(x))); + return ecl_make_long_float(cosl(ecl_long_float(x))); } #endif static cl_object ecl_cos_complex(cl_object x) { - /* z = x + I y - cos(z) = cosh(I z) = cosh(-y + I x) - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_cos(dx), ecl_cosh(dy)); - cl_object b = ecl_times(ecl_negate(ecl_sin(dx)), ecl_sinh(dy)); - return ecl_make_complex(a, b); + /* z = x + I y + cos(z) = cosh(I z) = cosh(-y + I x) + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_cos(dx), ecl_cosh(dy)); + cl_object b = ecl_times(ecl_negate(ecl_sin(dx)), ecl_sinh(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(cos, @[cos], @[number], diff --git a/src/c/numbers/cosh.d b/src/c/numbers/cosh.d index 936f605fe..6d8c7b715 100644 --- a/src/c/numbers/cosh.d +++ b/src/c/numbers/cosh.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - cosh.d -- Trascendental functions: hyperbolic cosine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * ecl_constants.h - contstant values for all_symbols.d + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,49 +22,49 @@ cl_object cl_cosh(cl_object x) { - @(return ecl_cosh(x)); + @(return ecl_cosh(x)); } static cl_object ecl_cosh_rational(cl_object x) { - return ecl_make_single_float(coshf(ecl_to_float(x))); + return ecl_make_single_float(coshf(ecl_to_float(x))); } static cl_object ecl_cosh_single_float(cl_object x) { - return ecl_make_single_float(coshf(ecl_single_float(x))); + return ecl_make_single_float(coshf(ecl_single_float(x))); } static cl_object ecl_cosh_double_float(cl_object x) { - return ecl_make_double_float(cosh(ecl_double_float(x))); + return ecl_make_double_float(cosh(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_cosh_long_float(cl_object x) { - return ecl_make_long_float(coshl(ecl_long_float(x))); + return ecl_make_long_float(coshl(ecl_long_float(x))); } #endif static cl_object ecl_cosh_complex(cl_object x) { - /* - z = x + I y - cosh(z) = (exp(z)+exp(-z))/2 - = (exp(x)*(cos(y)+Isin(y))+exp(-x)*(cos(y)-Isin(y)))/2 - = cosh(x)*cos(y) + Isinh(x)*sin(y); - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_cosh(dx), ecl_cos(dy)); - cl_object b = ecl_times(ecl_sinh(dx), ecl_sin(dy)); - return ecl_make_complex(a, b); + /* + z = x + I y + cosh(z) = (exp(z)+exp(-z))/2 + = (exp(x)*(cos(y)+Isin(y))+exp(-x)*(cos(y)-Isin(y)))/2 + = cosh(x)*cos(y) + Isinh(x)*sin(y); + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_cosh(dx), ecl_cos(dy)); + cl_object b = ecl_times(ecl_sinh(dx), ecl_sin(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(cosh, @[cosh], @[number], diff --git a/src/c/numbers/divide.d b/src/c/numbers/divide.d index 8f95dbe85..a83963c77 100644 --- a/src/c/numbers/divide.d +++ b/src/c/numbers/divide.d @@ -1,180 +1,178 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - divde.d -- Implementation of CL:/ -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * divde.d - implementation of CL:/ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @(defun / (num &rest nums) -@ - /* INV: type check is in ecl_divide() */ - if (narg == 0) - FEwrong_num_arguments(@[/]); - if (narg == 1) - @(return ecl_divide(ecl_make_fixnum(1), num)) - while (--narg) - num = ecl_divide(num, ecl_va_arg(nums)); - @(return num) -@) + @ + /* INV: type check is in ecl_divide() */ + if (narg == 0) + FEwrong_num_arguments(@[/]); + if (narg == 1) { + @(return ecl_divide(ecl_make_fixnum(1), num)); + } + while (--narg) + num = ecl_divide(num, ecl_va_arg(nums)); + @(return num); + @) #ifdef MATH_DISPATCH2_BEGIN static cl_object complex_divide(cl_object ar, cl_object ai, cl_object br, cl_object bi) { - /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ - cl_object z1 = ecl_plus(ecl_times(ar, br), ecl_times(ai, bi)); - cl_object z2 = ecl_minus(ecl_times(ai, br), ecl_times(ar, bi)); - cl_object absB = ecl_plus(ecl_times(br, br), ecl_times(bi, bi)); - return ecl_make_complex(ecl_divide(z1, absB), ecl_divide(z2, absB)); + /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ + cl_object z1 = ecl_plus(ecl_times(ar, br), ecl_times(ai, bi)); + cl_object z2 = ecl_minus(ecl_times(ai, br), ecl_times(ar, bi)); + cl_object absB = ecl_plus(ecl_times(br, br), ecl_times(bi, bi)); + return ecl_make_complex(ecl_divide(z1, absB), ecl_divide(z2, absB)); } cl_object ecl_divide(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM; - CASE_BIGNUM_FIXNUM { - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - } - CASE_FIXNUM_BIGNUM; - CASE_BIGNUM_BIGNUM { - return ecl_make_ratio(x, y); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - return ecl_make_ratio(ecl_times(x, y->ratio.den), - y->ratio.num); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) / ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) / ecl_double_float(y)); - } - CASE_BIGNUM_SINGLE_FLOAT; - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) / ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT; - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); - } - CASE_RATIO_FIXNUM { - if (y == ecl_make_fixnum(0)) { - FEdivision_by_zero(x,y); - } - } - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.den, y); - return ecl_make_ratio(x->ratio.num, z); - } - CASE_RATIO_RATIO { - cl_object num = ecl_times(x->ratio.num,y->ratio.den); - cl_object den = ecl_times(x->ratio.den,y->ratio.num); - return ecl_make_ratio(num, den); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) / ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM; + CASE_BIGNUM_FIXNUM { + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + } + CASE_FIXNUM_BIGNUM; + CASE_BIGNUM_BIGNUM { + return ecl_make_ratio(x, y); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + return ecl_make_ratio(ecl_times(x, y->ratio.den), + y->ratio.num); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) / ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) / ecl_double_float(y)); + } + CASE_BIGNUM_SINGLE_FLOAT; + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) / ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT; + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + } + CASE_RATIO_FIXNUM { + if (y == ecl_make_fixnum(0)) { + FEdivision_by_zero(x,y); } + } + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.den, y); + return ecl_make_ratio(x->ratio.num, z); + } + CASE_RATIO_RATIO { + cl_object num = ecl_times(x->ratio.num,y->ratio.den); + cl_object den = ecl_times(x->ratio.den,y->ratio.num); + return ecl_make_ratio(num, den); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) / ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) / ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT; - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) / ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) / ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) / ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT; + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) / ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) / ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { - return ecl_make_complex(ecl_divide(x->complex.real, y), - ecl_divide(x->complex.imag, y)); - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return complex_divide(x, ecl_make_fixnum(0), y->complex.real, y->complex.imag); - } - CASE_COMPLEX_COMPLEX { - return complex_divide(x->complex.real, x->complex.imag, - y->complex.real, y->complex.imag); - } - CASE_UNKNOWN(@[/],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { + return ecl_make_complex(ecl_divide(x->complex.real, y), + ecl_divide(x->complex.imag, y)); + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return complex_divide(x, ecl_make_fixnum(0), y->complex.real, y->complex.imag); + } + CASE_COMPLEX_COMPLEX { + return complex_divide(x->complex.real, x->complex.imag, + y->complex.real, y->complex.imag); + } + CASE_UNKNOWN(@[/],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -182,146 +180,146 @@ MATH_DISPATCH2_END; cl_object ecl_divide(cl_object x, cl_object y) { - cl_object z, z1, z2; + cl_object z, z1, z2; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - case t_bignum: - if (ecl_minusp(y) == TRUE) { - x = ecl_negate(x); - y = ecl_negate(y); - } - return ecl_make_ratio(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - return ecl_make_ratio(z, y->ratio.num); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + case t_bignum: + if (ecl_minusp(y) == TRUE) { + x = ecl_negate(x); + y = ecl_negate(y); + } + return ecl_make_ratio(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + return ecl_make_ratio(z, y->ratio.num); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - if (y == ecl_make_fixnum(0)) - FEdivision_by_zero(x, y); - case t_bignum: - z = ecl_times(x->ratio.den, y); - return ecl_make_ratio(x->ratio.num, z); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.den); - z1 = ecl_times(x->ratio.den,y->ratio.num); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + if (y == ecl_make_fixnum(0)) + FEdivision_by_zero(x, y); + case t_bignum: + z = ecl_times(x->ratio.den, y); + return ecl_make_ratio(x->ratio.num, z); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.den); + z1 = ecl_times(x->ratio.den,y->ratio.num); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) / ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[/], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) / ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[/], 2, y, @[number]); + } #endif - case t_complex: - if (ecl_t_of(y) != t_complex) { - z1 = ecl_divide(x->complex.real, y); - z2 = ecl_divide(x->complex.imag, y); - return ecl_make_complex(z1, z2); - } else if (1) { - /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ - z1 = ecl_plus(ecl_times(x->complex.real, y->complex.real), - ecl_times(x->complex.imag, y->complex.imag)); - z2 = ecl_minus(ecl_times(x->complex.imag, y->complex.real), - ecl_times(x->complex.real, y->complex.imag)); - } else { - COMPLEX: /* INV: x is real, y is complex */ - /* #C(z1 z2) = x * #C(yr -yi) */ - z1 = ecl_times(x, y->complex.real); - z2 = ecl_negate(ecl_times(x, y->complex.imag)); - } - z = ecl_plus(ecl_times(y->complex.real, y->complex.real), - ecl_times(y->complex.imag, y->complex.imag)); - z = ecl_make_complex(ecl_divide(z1, z), ecl_divide(z2, z)); - return(z); - default: - FEwrong_type_nth_arg(@[/], 1, x, @[number]); - } + case t_complex: + if (ecl_t_of(y) != t_complex) { + z1 = ecl_divide(x->complex.real, y); + z2 = ecl_divide(x->complex.imag, y); + return ecl_make_complex(z1, z2); + } else if (1) { + /* #C(z1 z2) = #C(xr xi) * #C(yr -yi) */ + z1 = ecl_plus(ecl_times(x->complex.real, y->complex.real), + ecl_times(x->complex.imag, y->complex.imag)); + z2 = ecl_minus(ecl_times(x->complex.imag, y->complex.real), + ecl_times(x->complex.real, y->complex.imag)); + } else { + COMPLEX: /* INV: x is real, y is complex */ + /* #C(z1 z2) = x * #C(yr -yi) */ + z1 = ecl_times(x, y->complex.real); + z2 = ecl_negate(ecl_times(x, y->complex.imag)); + } + z = ecl_plus(ecl_times(y->complex.real, y->complex.real), + ecl_times(y->complex.imag, y->complex.imag)); + z = ecl_make_complex(ecl_divide(z1, z), ecl_divide(z2, z)); + return(z); + default: + FEwrong_type_nth_arg(@[/], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/exp.d b/src/c/numbers/exp.d index 3cf19334b..86b1f4083 100644 --- a/src/c/numbers/exp.d +++ b/src/c/numbers/exp.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sinh.d -- Trascendental functions: exponential -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * sinh.d - trascendental functions: exponential + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -27,45 +22,45 @@ cl_object cl_exp(cl_object x) { - @(return ecl_exp(x)); + @(return ecl_exp(x)); } static cl_object ecl_exp_rational(cl_object x) { - return ecl_make_single_float(expf(ecl_to_float(x))); + return ecl_make_single_float(expf(ecl_to_float(x))); } static cl_object ecl_exp_single_float(cl_object x) { - return ecl_make_single_float(expf(ecl_single_float(x))); + return ecl_make_single_float(expf(ecl_single_float(x))); } static cl_object ecl_exp_double_float(cl_object x) { - return ecl_make_double_float(exp(ecl_double_float(x))); + return ecl_make_double_float(exp(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_exp_long_float(cl_object x) { - return ecl_make_long_float(expl(ecl_long_float(x))); + return ecl_make_long_float(expl(ecl_long_float(x))); } #endif static cl_object ecl_exp_complex(cl_object x) { - cl_object y, y1; - y = x->complex.imag; - x = ecl_exp(x->complex.real); - y1 = ecl_cos(y); - y = ecl_sin(y); - y = ecl_make_complex(y1, y); - return ecl_times(x, y); + cl_object y, y1; + y = x->complex.imag; + x = ecl_exp(x->complex.real); + y1 = ecl_cos(y); + y = ecl_sin(y); + y = ecl_make_complex(y1, y); + return ecl_times(x, y); } MATH_DEF_DISPATCH1(exp, @[exp], @[number], diff --git a/src/c/numbers/expt.d b/src/c/numbers/expt.d index 7b735fcb1..15eae4edf 100644 --- a/src/c/numbers/expt.d +++ b/src/c/numbers/expt.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - expt.d -- Exponentiate. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * expt.d - exponentiate + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -31,22 +27,22 @@ cl_fixnum ecl_fixnum_expt(cl_fixnum x, cl_fixnum y) { - cl_fixnum z = 1; - while (y > 0) - if (y%2 == 0) { - x *= x; - y /= 2; - } else { - z *= x; - --y; - } - return(z); + cl_fixnum z = 1; + while (y > 0) + if (y%2 == 0) { + x *= x; + y /= 2; + } else { + z *= x; + --y; + } + return(z); } cl_object cl_expt(cl_object x, cl_object y) { - @(return ecl_expt(x, y)); + @(return ecl_expt(x, y)); } ecl_def_ct_single_float(singlefloat_one,1,static,const); @@ -58,79 +54,79 @@ ecl_def_ct_long_float(longfloat_one,1,static,const); static cl_object expt_zero(cl_object x, cl_object y) { - cl_type ty, tx; - cl_object z; - ty = ecl_t_of(y); - tx = ecl_t_of(x); - if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { - FEwrong_type_nth_arg(@[expt], 1, x, @[number]); - } - /* INV: The most specific numeric types come first. */ - switch ((ty > tx)? ty : tx) { - case t_fixnum: - case t_bignum: - case t_ratio: - return ecl_make_fixnum(1); - case t_singlefloat: - return singlefloat_one; - case t_doublefloat: - return doublefloat_one; + cl_type ty, tx; + cl_object z; + ty = ecl_t_of(y); + tx = ecl_t_of(x); + if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { + FEwrong_type_nth_arg(@[expt], 1, x, @[number]); + } + /* INV: The most specific numeric types come first. */ + switch ((ty > tx)? ty : tx) { + case t_fixnum: + case t_bignum: + case t_ratio: + return ecl_make_fixnum(1); + case t_singlefloat: + return singlefloat_one; + case t_doublefloat: + return doublefloat_one; #ifdef ECL_LONG_FLOAT - case t_longfloat: - return longfloat_one; + case t_longfloat: + return longfloat_one; #endif - case t_complex: - z = expt_zero((tx == t_complex)? x->complex.real : x, - (ty == t_complex)? y->complex.real : y); - return ecl_make_complex(z, ecl_make_fixnum(0)); - default: - /* We will never reach this */ - abort(); - } + case t_complex: + z = expt_zero((tx == t_complex)? x->complex.real : x, + (ty == t_complex)? y->complex.real : y); + return ecl_make_complex(z, ecl_make_fixnum(0)); + default: + /* We will never reach this */ + abort(); + } } cl_object ecl_expt(cl_object x, cl_object y) { - cl_type ty, tx; - cl_object z; - if (ecl_unlikely(ecl_zerop(y))) { - return expt_zero(x, y); - } - ty = ecl_t_of(y); - tx = ecl_t_of(x); - if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { - FEwrong_type_nth_arg(@[expt], 1, x, @[number]); - } - if (ecl_zerop(x)) { - z = ecl_times(x, y); - if (!ecl_plusp(ty==t_complex?y->complex.real:y)) - z = ecl_divide(ecl_make_fixnum(1), z); - } else if (ty != t_fixnum && ty != t_bignum) { - /* The following could be just - z = ecl_log1(x); - however, Maxima expects EXPT to have double accuracy - when the first argument is integer and the second - is double-float */ - z = ecl_log1(ecl_times(x, expt_zero(x, y))); - z = ecl_times(z, y); - z = ecl_exp(z); - } else if (ecl_minusp(y)) { - z = ecl_negate(y); - z = ecl_expt(x, z); - z = ecl_divide(ecl_make_fixnum(1), z); - } else { - ECL_MATHERR_CLEAR; - z = ecl_make_fixnum(1); - do { - /* INV: ecl_integer_divide outputs an integer */ - if (!ecl_evenp(y)) - z = ecl_times(z, x); - y = ecl_integer_divide(y, ecl_make_fixnum(2)); - if (ecl_zerop(y)) break; - x = ecl_times(x, x); - } while (1); - ECL_MATHERR_TEST; - } - return z; + cl_type ty, tx; + cl_object z; + if (ecl_unlikely(ecl_zerop(y))) { + return expt_zero(x, y); + } + ty = ecl_t_of(y); + tx = ecl_t_of(x); + if (ecl_unlikely(!ECL_NUMBER_TYPE_P(tx))) { + FEwrong_type_nth_arg(@[expt], 1, x, @[number]); + } + if (ecl_zerop(x)) { + z = ecl_times(x, y); + if (!ecl_plusp(ty==t_complex?y->complex.real:y)) + z = ecl_divide(ecl_make_fixnum(1), z); + } else if (ty != t_fixnum && ty != t_bignum) { + /* The following could be just + z = ecl_log1(x); + however, Maxima expects EXPT to have double accuracy + when the first argument is integer and the second + is double-float */ + z = ecl_log1(ecl_times(x, expt_zero(x, y))); + z = ecl_times(z, y); + z = ecl_exp(z); + } else if (ecl_minusp(y)) { + z = ecl_negate(y); + z = ecl_expt(x, z); + z = ecl_divide(ecl_make_fixnum(1), z); + } else { + ECL_MATHERR_CLEAR; + z = ecl_make_fixnum(1); + do { + /* INV: ecl_integer_divide outputs an integer */ + if (!ecl_evenp(y)) + z = ecl_times(z, x); + y = ecl_integer_divide(y, ecl_make_fixnum(2)); + if (ecl_zerop(y)) break; + x = ecl_times(x, x); + } while (1); + ECL_MATHERR_TEST; + } + return z; } diff --git a/src/c/numbers/float_fix_compare.d b/src/c/numbers/float_fix_compare.d index 8b76ad4f3..20537246d 100644 --- a/src/c/numbers/float_fix_compare.d +++ b/src/c/numbers/float_fix_compare.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - num_comp.c -- Comparisons on numbers. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * ecnum_comp.c - comparisons on numbers + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ /* * In Common Lisp, comparisons between floats and integers are performed @@ -28,50 +23,50 @@ static int double_fix_compare(cl_fixnum n, double d) { - if ((double)n < d) { - return -1; - } else if ((double)n > d) { - return +1; - } else if (sizeof(double) > sizeof(cl_fixnum)) { - return 0; - } else { - /* When we reach here, the double type has no - * significant decimal part. However, as explained - * above, the double type is too small and integers - * may coerce to the same double number giving a false - * positive. Hence we perform the comparison in - * integer space. */ - cl_fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; - } - } + if ((double)n < d) { + return -1; + } else if ((double)n > d) { + return +1; + } else if (sizeof(double) > sizeof(cl_fixnum)) { + return 0; + } else { + /* When we reach here, the double type has no + * significant decimal part. However, as explained + * above, the double type is too small and integers + * may coerce to the same double number giving a false + * positive. Hence we perform the comparison in + * integer space. */ + cl_fixnum m = d; + if (n == m) { + return 0; + } else if (n > m) { + return +1; + } else { + return -1; + } + } } #ifdef ECL_LONG_FLOAT static int long_double_fix_compare(cl_fixnum n, long double d) { - if ((long double)n < d) { - return -1; - } else if ((long double)n > d) { - return +1; - } else if (sizeof(long double) > sizeof(cl_fixnum)) { - return 0; - } else { - cl_fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; - } - } + if ((long double)n < d) { + return -1; + } else if ((long double)n > d) { + return +1; + } else if (sizeof(long double) > sizeof(cl_fixnum)) { + return 0; + } else { + cl_fixnum m = d; + if (n == m) { + return 0; + } else if (n > m) { + return +1; + } else { + return -1; + } + } } #endif diff --git a/src/c/numbers/floor.d b/src/c/numbers/floor.d index 4d31143de..ebbe4ea26 100644 --- a/src/c/numbers/floor.d +++ b/src/c/numbers/floor.d @@ -1,19 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - floor.d -- Implementation of CL:FLOOR -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * ecfloor.d - implementation of CL:FLOOR + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -25,233 +22,233 @@ #include @(defun floor (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_floor1(x); - else - return ecl_floor2(x, y); -@) + @ + if (narg == 1) + return ecl_floor1(x); + else + return ecl_floor2(x, y); + @) cl_object ecl_floor1(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - v0 = ecl_floor2(x->ratio.num, x->ratio.den); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - case t_singlefloat: { - float d = ecl_single_float(x); - float y = floorf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = floor(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + v0 = ecl_floor2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + case t_singlefloat: { + float d = ecl_single_float(x); + float y = floorf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = floor(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = floorl(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = floorl(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: - FEwrong_type_nth_arg(@[floor],1,x,@[real]); - } - ecl_return2(the_env, v0, v1); + default: + FEwrong_type_nth_arg(@[floor],1,x,@[real]); + } + ecl_return2(the_env, v0, v1); } cl_object ecl_floor2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - cl_fixnum a = ecl_fixnum(x), b = ecl_fixnum(y); - cl_fixnum q = a / b, r = a % b; - if ((r^b) < 0 && r) { /* opposite sign and some remainder*/ - v0 = ecl_make_fixnum(q-1); - v1 = ecl_make_fixnum(r+b); - } else { - v0 = ecl_make_fixnum(q); - v1 = ecl_make_fixnum(r); - } - break; - } - CASE_FIXNUM_BIGNUM { - /* We must perform the division because there is the - * pathological case - * x = MOST_NEGATIVE_FIXNUM - * y = - MOST_NEGATIVE_FIXNUM - */ - ECL_WITH_TEMP_BIGNUM(bx,4); - _ecl_big_set_fixnum(bx, ecl_fixnum(x)); - v0 = _ecl_big_floor(bx, y, &v1); - break; - } - CASE_FIXNUM_RATIO { - v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - } - CASE_FIXNUM_SINGLE_FLOAT { - float n = ecl_single_float(y); - float p = ecl_fixnum(x) / n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float((p - q)*n); - break; - } - CASE_FIXNUM_DOUBLE_FLOAT { - double n = ecl_double_float(y); - double p = ecl_fixnum(x) / n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float((p - q)*n); - break; + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + cl_fixnum a = ecl_fixnum(x), b = ecl_fixnum(y); + cl_fixnum q = a / b, r = a % b; + if ((r^b) < 0 && r) { /* opposite sign and some remainder*/ + v0 = ecl_make_fixnum(q-1); + v1 = ecl_make_fixnum(r+b); + } else { + v0 = ecl_make_fixnum(q); + v1 = ecl_make_fixnum(r); } + break; + } + CASE_FIXNUM_BIGNUM { + /* We must perform the division because there is the + * pathological case + * x = MOST_NEGATIVE_FIXNUM + * y = - MOST_NEGATIVE_FIXNUM + */ + ECL_WITH_TEMP_BIGNUM(bx,4); + _ecl_big_set_fixnum(bx, ecl_fixnum(x)); + v0 = _ecl_big_floor(bx, y, &v1); + break; + } + CASE_FIXNUM_RATIO { + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + } + CASE_FIXNUM_SINGLE_FLOAT { + float n = ecl_single_float(y); + float p = ecl_fixnum(x) / n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float((p - q)*n); + break; + } + CASE_FIXNUM_DOUBLE_FLOAT { + double n = ecl_double_float(y); + double p = ecl_fixnum(x) / n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float((p - q)*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { /* FIX / LF */ - long double n = ecl_long_float(y); - long double p = ecl_fixnum(x) / n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float((p - q)*n); - break; - } + CASE_FIXNUM_LONG_FLOAT { /* FIX / LF */ + long double n = ecl_long_float(y); + long double p = ecl_fixnum(x) / n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float((p - q)*n); + break; + } #endif - CASE_BIGNUM_FIXNUM { - ECL_WITH_TEMP_BIGNUM(by,4); - _ecl_big_set_fixnum(by, ecl_fixnum(y)); - v0 = _ecl_big_floor(x, by, &v1); - break; - } - CASE_BIGNUM_BIGNUM { - v0 = _ecl_big_floor(x, y, &v1); - break; - } - CASE_BIGNUM_RATIO { - v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); - break; - } - CASE_BIGNUM_SINGLE_FLOAT { - float n = ecl_single_float(y); - float p = _ecl_big_to_double(x) / n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float((p - q)*n); - break; - } - CASE_BIGNUM_DOUBLE_FLOAT { - double n = ecl_double_float(y); - double p = _ecl_big_to_double(x) / n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float((p - q)*n); - break; - } + CASE_BIGNUM_FIXNUM { + ECL_WITH_TEMP_BIGNUM(by,4); + _ecl_big_set_fixnum(by, ecl_fixnum(y)); + v0 = _ecl_big_floor(x, by, &v1); + break; + } + CASE_BIGNUM_BIGNUM { + v0 = _ecl_big_floor(x, y, &v1); + break; + } + CASE_BIGNUM_RATIO { + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), y->ratio.den); + break; + } + CASE_BIGNUM_SINGLE_FLOAT { + float n = ecl_single_float(y); + float p = _ecl_big_to_double(x) / n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float((p - q)*n); + break; + } + CASE_BIGNUM_DOUBLE_FLOAT { + double n = ecl_double_float(y); + double p = _ecl_big_to_double(x) / n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float((p - q)*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_BIGNUM_LONG_FLOAT { - long double n = ecl_long_float(y); - long double p = _ecl_big_to_double(x) / n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float((p - q)*n); - break; - } + CASE_BIGNUM_LONG_FLOAT { + long double n = ecl_long_float(y); + long double p = _ecl_big_to_double(x) / n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float((p - q)*n); + break; + } #endif - CASE_RATIO_RATIO { - v0 = ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); - break; - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM; - CASE_RATIO_SINGLE_FLOAT; + CASE_RATIO_RATIO { + v0 = ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), ecl_times(x->ratio.den, y->ratio.den)); + break; + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM; + CASE_RATIO_SINGLE_FLOAT; #ifdef ECL_LONG_FLOAT - CASE_RATIO_LONG_FLOAT; + CASE_RATIO_LONG_FLOAT; #endif - CASE_RATIO_DOUBLE_FLOAT { - v0 = ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); - v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); - break; - } + CASE_RATIO_DOUBLE_FLOAT { + v0 = ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(ecl_nth_value(the_env, 1), x->ratio.den); + break; + } - CASE_SINGLE_FLOAT_FIXNUM; - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO; - CASE_SINGLE_FLOAT_DOUBLE_FLOAT; + CASE_SINGLE_FLOAT_FIXNUM; + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO; + CASE_SINGLE_FLOAT_DOUBLE_FLOAT; #ifdef ECL_LONG_FLOAT - CASE_SINGLE_FLOAT_LONG_FLOAT; + CASE_SINGLE_FLOAT_LONG_FLOAT; #endif - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - float n = ecl_to_double(y); - float p = ecl_single_float(x)/n; - float q = floorf(p); - v0 = _ecl_float_to_integer(q); - /* We cannot factor these two multiplications because - * if we have signed zeros (1 - 1) * (-1) = -0 while - * 1*(-1) - 1*(-1) = +0 */ - v1 = ecl_make_single_float(p*n - q*n); - break; - } - CASE_DOUBLE_FLOAT_FIXNUM; - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO; - CASE_DOUBLE_FLOAT_SINGLE_FLOAT; + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + float n = ecl_to_double(y); + float p = ecl_single_float(x)/n; + float q = floorf(p); + v0 = _ecl_float_to_integer(q); + /* We cannot factor these two multiplications because + * if we have signed zeros (1 - 1) * (-1) = -0 while + * 1*(-1) - 1*(-1) = +0 */ + v1 = ecl_make_single_float(p*n - q*n); + break; + } + CASE_DOUBLE_FLOAT_FIXNUM; + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO; + CASE_DOUBLE_FLOAT_SINGLE_FLOAT; #ifdef ECL_LONG_FLOAT - CASE_DOUBLE_FLOAT_LONG_FLOAT; + CASE_DOUBLE_FLOAT_LONG_FLOAT; #endif - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - double n = ecl_to_double(y); - double p = ecl_double_float(x)/n; - double q = floor(p); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(p*n - q*n); - break; - } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + double n = ecl_to_double(y); + double p = ecl_double_float(x)/n; + double q = floor(p); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(p*n - q*n); + break; + } #ifdef ECL_LONG_FLOAT - CASE_LONG_FLOAT_FIXNUM; - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO; - CASE_LONG_FLOAT_SINGLE_FLOAT; - CASE_LONG_FLOAT_DOUBLE_FLOAT; - CASE_LONG_FLOAT_LONG_FLOAT { - long double n = ecl_to_long_double(y); - long double p = ecl_long_float(x)/n; - long double q = floorl(p); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(p*n - q*n); - break; - } + CASE_LONG_FLOAT_FIXNUM; + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO; + CASE_LONG_FLOAT_SINGLE_FLOAT; + CASE_LONG_FLOAT_DOUBLE_FLOAT; + CASE_LONG_FLOAT_LONG_FLOAT { + long double n = ecl_to_long_double(y); + long double p = ecl_long_float(x)/n; + long double q = floorl(p); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(p*n - q*n); + break; + } #endif - default: DISPATCH2_ERROR: { - if (!ecl_realp(x)) - FEwrong_type_nth_arg(@[floor], 1, x, @[real]); - else - FEwrong_type_nth_arg(@[floor], 2, y, @[real]); - } -} -MATH_DISPATCH2_END; - ecl_return2(the_env, v0, v1); + default: DISPATCH2_ERROR: { + if (!ecl_realp(x)) + FEwrong_type_nth_arg(@[floor], 1, x, @[real]); + else + FEwrong_type_nth_arg(@[floor], 2, y, @[real]); + } + } + MATH_DISPATCH2_END; + ecl_return2(the_env, v0, v1); } diff --git a/src/c/numbers/log.d b/src/c/numbers/log.d index 214977ab4..4e3924d8d 100644 --- a/src/c/numbers/log.d +++ b/src/c/numbers/log.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - log1.d -- Trascendental functions: log(x) -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * eclog1.d - trascendental functions: log(x) + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,85 +23,85 @@ static cl_object ecl_log1_complex_inner(cl_object r, cl_object i) { - cl_object a = ecl_abs(r); - cl_object p = ecl_abs(i); - int rel = ecl_number_compare(a, p); - if (rel > 0) { - cl_object aux = p; - p = a; a = aux; - } else if (rel == 0) { - /* if a == p, - * log(sqrt(a^2+p^2)) = log(2a^2)/2 - */ - a = ecl_times(a, a); - a = ecl_divide(ecl_log1(ecl_plus(a, a)), ecl_make_fixnum(2)); - goto OUTPUT; - } - /* For the real part of the output we use the formula - * log(sqrt(p^2 + a^2)) = log(sqrt(p^2*(1 + (a/p)^2))) - * = log(p) + log(1 + (a/p)^2)/2; */ - a = ecl_divide(a, p); - a = ecl_plus(ecl_divide(ecl_log1p(ecl_times(a,a)), ecl_make_fixnum(2)), - ecl_log1(p)); + cl_object a = ecl_abs(r); + cl_object p = ecl_abs(i); + int rel = ecl_number_compare(a, p); + if (rel > 0) { + cl_object aux = p; + p = a; a = aux; + } else if (rel == 0) { + /* if a == p, + * log(sqrt(a^2+p^2)) = log(2a^2)/2 + */ + a = ecl_times(a, a); + a = ecl_divide(ecl_log1(ecl_plus(a, a)), ecl_make_fixnum(2)); + goto OUTPUT; + } + /* For the real part of the output we use the formula + * log(sqrt(p^2 + a^2)) = log(sqrt(p^2*(1 + (a/p)^2))) + * = log(p) + log(1 + (a/p)^2)/2; */ + a = ecl_divide(a, p); + a = ecl_plus(ecl_divide(ecl_log1p(ecl_times(a,a)), ecl_make_fixnum(2)), + ecl_log1(p)); OUTPUT: - p = ecl_atan2(i, r); - return ecl_make_complex(a, p); + p = ecl_atan2(i, r); + return ecl_make_complex(a, p); } static cl_object ecl_log1_bignum(cl_object x) { - if (ecl_minusp(x)) { - return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - } else { - cl_fixnum l = ecl_integer_length(x) - 1; - cl_object r = ecl_make_ratio(x, ecl_ash(ecl_make_fixnum(1), l)); - float d = logf(ecl_to_float(r)) + l * logf(2.0); - return ecl_make_single_float(d); - } + if (ecl_minusp(x)) { + return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + } else { + cl_fixnum l = ecl_integer_length(x) - 1; + cl_object r = ecl_make_ratio(x, ecl_ash(ecl_make_fixnum(1), l)); + float d = logf(ecl_to_float(r)) + l * logf(2.0); + return ecl_make_single_float(d); + } } static cl_object ecl_log1_rational(cl_object x) { - float f = ecl_to_float(x); - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_single_float(logf(ecl_to_float(x))); + float f = ecl_to_float(x); + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_single_float(logf(ecl_to_float(x))); } static cl_object ecl_log1_single_float(cl_object x) { - float f = ecl_single_float(x); - if (isnan(f)) return x; - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_single_float(logf(f)); + float f = ecl_single_float(x); + if (isnan(f)) return x; + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_single_float(logf(f)); } static cl_object ecl_log1_double_float(cl_object x) { - double f = ecl_double_float(x); - if (isnan(f)) return x; - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_double_float(log(f)); + double f = ecl_double_float(x); + if (isnan(f)) return x; + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_double_float(log(f)); } #ifdef ECL_LONG_FLOAT static cl_object ecl_log1_long_float(cl_object x) { - long double f = ecl_long_float(x); - if (isnan(f)) return x; - if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); - return ecl_make_long_float(logl(f)); + long double f = ecl_long_float(x); + if (isnan(f)) return x; + if (f < 0) return ecl_log1_complex_inner(x, ecl_make_fixnum(0)); + return ecl_make_long_float(logl(f)); } #endif static cl_object ecl_log1_complex(cl_object x) { - return ecl_log1_complex_inner(x->complex.real, x->complex.imag); + return ecl_log1_complex_inner(x->complex.real, x->complex.imag); } MATH_DEF_DISPATCH1(log1, @[log], @[number], @@ -116,27 +112,28 @@ MATH_DEF_DISPATCH1(log1, @[log], @[number], cl_object ecl_log2(cl_object x, cl_object y) { - return ecl_divide(ecl_log1(y), ecl_log1(x)); + return ecl_divide(ecl_log1(y), ecl_log1(x)); } @(defun log (x &optional (y OBJNULL)) -@ /* INV: type check in ecl_log1() and ecl_log2() */ - if (y == OBJNULL) - @(return ecl_log1(x)) - @(return ecl_log2(y, x)) -@) + @ /* INV: type check in ecl_log1() and ecl_log2() */ + if (y == OBJNULL) { + @(return ecl_log1(x)); + } + @(return ecl_log2(y, x)) + @) #ifndef HAVE_LOG1P double log1p(double x) { - double u = 1.0 + x; - if (u == 1) { - return 0.0; - } else { - return (log(u) * x)/(u - 1.0); - } + double u = 1.0 + x; + if (u == 1) { + return 0.0; + } else { + return (log(u) * x)/(u - 1.0); + } } #endif @@ -144,12 +141,12 @@ log1p(double x) float log1pf(float x) { - float u = (float)1 + x; - if (u == 1) { - return (float)0; - } else { - return (logf(u) * x)/(u - (float)1); - } + float u = (float)1 + x; + if (u == 1) { + return (float)0; + } else { + return (logf(u) * x)/(u - (float)1); + } } #endif @@ -157,68 +154,68 @@ log1pf(float x) long double log1pl(long double x) { - long double u = (long double)1 + x; - if (u == 1) { - return (long double)1; - } else { - return (logl(u) * x)/(u - (long double)1); - } + long double u = (long double)1 + x; + if (u == 1) { + return (long double)1; + } else { + return (logl(u) * x)/(u - (long double)1); + } } #endif cl_object si_log1p(cl_object x) { - @(return ecl_log1p(x)); + @(return ecl_log1p(x)); } static cl_object ecl_log1p_simple(cl_object x) { - return ecl_log1_complex_inner(ecl_one_plus(x), ecl_make_fixnum(0)); + return ecl_log1_complex_inner(ecl_one_plus(x), ecl_make_fixnum(0)); } static cl_object ecl_log1p_rational(cl_object x) { - float f = ecl_to_float(x); - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_single_float(log1pf(ecl_to_float(x))); + float f = ecl_to_float(x); + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_single_float(log1pf(ecl_to_float(x))); } static cl_object ecl_log1p_single_float(cl_object x) { - float f = ecl_single_float(x); - if (isnan(f)) return x; - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_single_float(log1pf(f)); + float f = ecl_single_float(x); + if (isnan(f)) return x; + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_single_float(log1pf(f)); } static cl_object ecl_log1p_double_float(cl_object x) { - double f = ecl_double_float(x); - if (isnan(f)) return x; - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_double_float(log1p(f)); + double f = ecl_double_float(x); + if (isnan(f)) return x; + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_double_float(log1p(f)); } #ifdef ECL_LONG_FLOAT static cl_object ecl_log1p_long_float(cl_object x) { - long double f = ecl_long_float(x); - if (isnan(f)) return x; - if (f < -1) return ecl_log1p_simple(x); - return ecl_make_long_float(log1pl(f)); + long double f = ecl_long_float(x); + if (isnan(f)) return x; + if (f < -1) return ecl_log1p_simple(x); + return ecl_make_long_float(log1pl(f)); } #endif static cl_object ecl_log1p_complex(cl_object x) { - return ecl_log1_complex_inner(ecl_one_plus(x->complex.real), x->complex.imag); + return ecl_log1_complex_inner(ecl_one_plus(x->complex.real), x->complex.imag); } MATH_DEF_DISPATCH1(log1p, @[si::log1p], @[number], diff --git a/src/c/numbers/minmax.d b/src/c/numbers/minmax.d index e627e08c9..56d90efc6 100644 --- a/src/c/numbers/minmax.d +++ b/src/c/numbers/minmax.d @@ -1,48 +1,43 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - minmax.c -- number sorting. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * minmax.c - number sorting + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include @(defun max (max &rest nums) -@ - /* INV: type check occurs in ecl_number_compare() for the rest of - numbers, but for the first argument it happens in ecl_zerop(). */ - if (narg-- == 1) { - ecl_zerop(max); - } else do { - cl_object numi = ecl_va_arg(nums); - if (ecl_number_compare(max, numi) < 0) - max = numi; - } while (--narg); - @(return max) -@) + @ + /* INV: type check occurs in ecl_number_compare() for the rest of + numbers, but for the first argument it happens in ecl_zerop(). */ + if (narg-- == 1) { + ecl_zerop(max); + } else do { + cl_object numi = ecl_va_arg(nums); + if (ecl_number_compare(max, numi) < 0) + max = numi; + } while (--narg); + @(return max); + @) @(defun min (min &rest nums) -@ - /* INV: type check occurs in ecl_number_compare() for the rest of - numbers, but for the first argument it happens in ecl_zerop(). */ - if (narg-- == 1) { - ecl_zerop(min); - } else do { - cl_object numi = ecl_va_arg(nums); - if (ecl_number_compare(min, numi) > 0) - min = numi; - } while (--narg); - @(return min) -@) + @ + /* INV: type check occurs in ecl_number_compare() for the rest of + numbers, but for the first argument it happens in ecl_zerop(). */ + if (narg-- == 1) { + ecl_zerop(min); + } else do { + cl_object numi = ecl_va_arg(nums); + if (ecl_number_compare(min, numi) > 0) + min = numi; + } while (--narg); + @(return min); + @) diff --git a/src/c/numbers/minus.d b/src/c/numbers/minus.d index 5650df53d..045e5c919 100644 --- a/src/c/numbers/minus.d +++ b/src/c/numbers/minus.d @@ -1,177 +1,176 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - minus.d -- Implementation of CL:- -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. + * ecminus.d - implementation of CL:- + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../../Copyright' for full details. -*/ #include #include @(defun - (num &rest nums) - cl_object diff; -@ - /* INV: argument type check in number_{negate,minus}() */ - if (narg == 1) - @(return ecl_negate(num)) - for (diff = num; --narg; ) - diff = ecl_minus(diff, ecl_va_arg(nums)); - @(return diff) -@) + cl_object diff; + @ + /* INV: argument type check in number_{negate,minus}() */ + if (narg == 1) { + @(return ecl_negate(num)); + } + for (diff = num; --narg; ) + diff = ecl_minus(diff, ecl_va_arg(nums)); + @(return diff); + @) #ifdef MATH_DISPATCH2_BEGIN cl_object ecl_minus(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); - } - CASE_FIXNUM_BIGNUM { - return _ecl_fix_minus_big(ecl_fixnum(x), y); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - cl_object z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); - } - CASE_BIGNUM_FIXNUM { - return _ecl_big_plus_fix(x, -ecl_fixnum(y)); - } - CASE_BIGNUM_BIGNUM { - return _ecl_big_minus_big(x, y); - } - CASE_BIGNUM_SINGLE_FLOAT; - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) - ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT; - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.den, y); - z = ecl_minus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - } - CASE_RATIO_RATIO { - cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); - cl_object z = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_minus(z1, z); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) - ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); - } + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); + } + CASE_FIXNUM_BIGNUM { + return _ecl_fix_minus_big(ecl_fixnum(x), y); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + cl_object z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); + } + CASE_BIGNUM_FIXNUM { + return _ecl_big_plus_fix(x, -ecl_fixnum(y)); + } + CASE_BIGNUM_BIGNUM { + return _ecl_big_minus_big(x, y); + } + CASE_BIGNUM_SINGLE_FLOAT; + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) - ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT; + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.den, y); + z = ecl_minus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + } + CASE_RATIO_RATIO { + cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); + cl_object z = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_minus(z1, z); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) - ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); - } - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) - ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) - ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); + } + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) - ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) - ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) - ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT { - COMPLEX_X: - return ecl_make_complex(ecl_minus(x->complex.real, y), - x->complex.imag); - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return ecl_make_complex(ecl_minus(x, y->complex.real), - ecl_negate(y->complex.imag)); - } - CASE_COMPLEX_COMPLEX { - cl_object z = ecl_minus(x->complex.real, y->complex.real); - cl_object z1 = ecl_minus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); - } - CASE_UNKNOWN(@[-],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT { + COMPLEX_X: + return ecl_make_complex(ecl_minus(x->complex.real, y), + x->complex.imag); + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return ecl_make_complex(ecl_minus(x, y->complex.real), + ecl_negate(y->complex.imag)); + } + CASE_COMPLEX_COMPLEX { + cl_object z = ecl_minus(x->complex.real, y->complex.real); + cl_object z1 = ecl_minus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); + } + CASE_UNKNOWN(@[-],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -179,157 +178,157 @@ MATH_DISPATCH2_END; cl_object ecl_minus(cl_object x, cl_object y) { - cl_fixnum i, j, k; - cl_object z, z1; + cl_fixnum i, j, k; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch(ecl_t_of(y)) { - case t_fixnum: - return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); - case t_bignum: - return _ecl_fix_minus_big(ecl_fixnum(x), y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + switch(ecl_t_of(y)) { + case t_fixnum: + return ecl_make_integer(ecl_fixnum(x) - ecl_fixnum(y)); + case t_bignum: + return _ecl_fix_minus_big(ecl_fixnum(x), y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_big_plus_fix(x, -ecl_fixnum(y)); - case t_bignum: - return _ecl_big_minus_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_minus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_big_plus_fix(x, -ecl_fixnum(y)); + case t_bignum: + return _ecl_big_minus_big(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_minus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.den, y); - z = ecl_minus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.den); - z1 = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_minus(z, z1); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.den, y); + z = ecl_minus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.den); + z1 = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_minus(z, z1); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) - ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) - ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) - ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) - ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) - fix(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) - ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[-], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) - fix(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) - ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) - ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[-], 2, y, @[number]); + } #endif - COMPLEX: - return ecl_make_complex(ecl_minus(x, y->complex.real), - ecl_negate(y->complex.imag)); - case t_complex: - if (ecl_t_of(y) != t_complex) { - z = ecl_minus(x->complex.real, y); - z1 = x->complex.imag; - } else { - z = ecl_minus(x->complex.real, y->complex.real); - z1 = ecl_minus(x->complex.imag, y->complex.imag); - } - return ecl_make_complex(z, z1); - default: - FEwrong_type_nth_arg(@[-], 1, x, @[number]); - } + COMPLEX: + return ecl_make_complex(ecl_minus(x, y->complex.real), + ecl_negate(y->complex.imag)); + case t_complex: + if (ecl_t_of(y) != t_complex) { + z = ecl_minus(x->complex.real, y); + z1 = x->complex.imag; + } else { + z = ecl_minus(x->complex.real, y->complex.real); + z1 = ecl_minus(x->complex.imag, y->complex.imag); + } + return ecl_make_complex(z, z1); + default: + FEwrong_type_nth_arg(@[-], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/minusp.d b/src/c/numbers/minusp.d index 07f26a550..728cdfafd 100644 --- a/src/c/numbers/minusp.d +++ b/src/c/numbers/minusp.d @@ -1,65 +1,60 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - minusp.d -- Implementation of CL:MINUSP -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * minusp.d - implementation of CL:MINUSP + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include cl_object cl_minusp(cl_object x) -{ /* INV: ecl_minusp() checks type */ - @(return (ecl_minusp(x) ? ECL_T : ECL_NIL)) +{ /* INV: ecl_minusp() checks type */ + @(return (ecl_minusp(x) ? ECL_T : ECL_NIL)); } static int ecl_minusp_fixnum(cl_object x) { - return ecl_fixnum_minusp(x); + return ecl_fixnum_minusp(x); } static int ecl_minusp_big(cl_object x) { - return _ecl_big_sign(x) < 0; + return _ecl_big_sign(x) < 0; } static int ecl_minusp_ratio(cl_object x) { - return ecl_minusp(x->ratio.num); + return ecl_minusp(x->ratio.num); } static int ecl_minusp_single_float(cl_object x) { - return ecl_single_float(x) < 0; + return ecl_single_float(x) < 0; } static int ecl_minusp_double_float(cl_object x) { - return ecl_double_float(x) < 0; + return ecl_double_float(x) < 0; } #ifdef ECL_LONG_FLOAT static int ecl_minusp_long_float(cl_object x) { - return ecl_long_float(x) < 0; + return ecl_long_float(x) < 0; } #endif diff --git a/src/c/numbers/negate.d b/src/c/numbers/negate.d index 0c69930e2..6a9136e70 100644 --- a/src/c/numbers/negate.d +++ b/src/c/numbers/negate.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - negate.d -- Trascendental functions: negateine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * negate.d - trascendental functions: negateine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,46 +18,46 @@ static cl_object ecl_negate_fix(cl_object x) { - return ecl_make_integer(-ecl_fixnum(x)); + return ecl_make_integer(-ecl_fixnum(x)); } static cl_object ecl_negate_big(cl_object x) { - return _ecl_big_negate(x); + return _ecl_big_negate(x); } static cl_object ecl_negate_ratio(cl_object x) { - return ecl_make_ratio(ecl_negate(x->ratio.num), x->ratio.den); + return ecl_make_ratio(ecl_negate(x->ratio.num), x->ratio.den); } static cl_object ecl_negate_single_float(cl_object x) { - return ecl_make_single_float(-ecl_single_float(x)); + return ecl_make_single_float(-ecl_single_float(x)); } static cl_object ecl_negate_double_float(cl_object x) { - return ecl_make_double_float(-ecl_double_float(x)); + return ecl_make_double_float(-ecl_double_float(x)); } #ifdef ECL_LONG_FLOAT static cl_object ecl_negate_long_float(cl_object x) { - return ecl_make_long_float(-ecl_long_float(x)); + return ecl_make_long_float(-ecl_long_float(x)); } #endif static cl_object ecl_negate_complex(cl_object x) { - return ecl_make_complex(ecl_negate(x->complex.real), - ecl_negate(x->complex.imag)); + return ecl_make_complex(ecl_negate(x->complex.real), + ecl_negate(x->complex.imag)); } MATH_DEF_DISPATCH1_NE(negate, @[-], @[number], diff --git a/src/c/numbers/number_compare.d b/src/c/numbers/number_compare.d index f4d4d6e37..a1e17b810 100644 --- a/src/c/numbers/number_compare.d +++ b/src/c/numbers/number_compare.d @@ -1,208 +1,205 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - number_compare.c -- number comparison. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * number_compare.d - number comparison + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ #include #include #include "numbers/float_fix_compare.d" /* - The value of ecl_number_compare(x, y) is - - -1 if x < y - 0 if x = y - 1 if x > y. - - If x or y is not real, it fails. + * + * The value of ecl_number_compare(x, y) is + * + * -1 if x < y + * 0 if x = y + * 1 if x > y. + * + * If x or y is not real, it fails. */ int ecl_number_compare(cl_object x, cl_object y) { - cl_fixnum ix, iy; - double dx, dy; + cl_fixnum ix, iy; + double dx, dy; #ifdef ECL_LONG_FLOAT - long double ldx, ldy; + long double ldx, ldy; #endif - cl_type ty; + cl_type ty; BEGIN: - ty = ecl_t_of(y); - switch (ecl_t_of(x)) { - case t_fixnum: - ix = ecl_fixnum(x); - switch (ty) { - case t_fixnum: - iy = ecl_fixnum(y); - if (ix < iy) - return(-1); - else return(ix != iy); - case t_bignum: - /* INV: (= x y) can't be zero since fixnum != bignum */ - return _ecl_big_sign(y) < 0? 1 : -1; - case t_ratio: - x = ecl_times(x, y->ratio.den); - y = y->ratio.num; - return(ecl_number_compare(x, y)); - case t_singlefloat: - return double_fix_compare(ix, ecl_single_float(y)); - case t_doublefloat: - return double_fix_compare(ix, ecl_double_float(y)); + ty = ecl_t_of(y); + switch (ecl_t_of(x)) { + case t_fixnum: + ix = ecl_fixnum(x); + switch (ty) { + case t_fixnum: + iy = ecl_fixnum(y); + if (ix < iy) + return(-1); + else return(ix != iy); + case t_bignum: + /* INV: (= x y) can't be zero since fixnum != bignum */ + return _ecl_big_sign(y) < 0? 1 : -1; + case t_ratio: + x = ecl_times(x, y->ratio.den); + y = y->ratio.num; + return(ecl_number_compare(x, y)); + case t_singlefloat: + return double_fix_compare(ix, ecl_single_float(y)); + case t_doublefloat: + return double_fix_compare(ix, ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return long_double_fix_compare(ix, ecl_long_float(y)); + case t_longfloat: + return long_double_fix_compare(ix, ecl_long_float(y)); #endif - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_bignum: - switch (ty) { - case t_fixnum: - return _ecl_big_sign(x) < 0 ? -1 : 1; - case t_bignum: - return(_ecl_big_compare(x, y)); - case t_ratio: - x = ecl_times(x, y->ratio.den); - y = y->ratio.num; - return(ecl_number_compare(x, y)); - case t_singlefloat: - case t_doublefloat: + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_bignum: + switch (ty) { + case t_fixnum: + return _ecl_big_sign(x) < 0 ? -1 : 1; + case t_bignum: + return(_ecl_big_compare(x, y)); + case t_ratio: + x = ecl_times(x, y->ratio.den); + y = y->ratio.num; + return(ecl_number_compare(x, y)); + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_ratio: - switch (ty) { - case t_fixnum: - case t_bignum: - y = ecl_times(y, x->ratio.den); - x = x->ratio.num; - return(ecl_number_compare(x, y)); - case t_ratio: - return(ecl_number_compare(ecl_times(x->ratio.num, - y->ratio.den), - ecl_times(y->ratio.num, - x->ratio.den))); - case t_singlefloat: - case t_doublefloat: + y = cl_rational(y); + goto BEGIN; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_ratio: + switch (ty) { + case t_fixnum: + case t_bignum: + y = ecl_times(y, x->ratio.den); + x = x->ratio.num; + return(ecl_number_compare(x, y)); + case t_ratio: + return(ecl_number_compare(ecl_times(x->ratio.num, + y->ratio.den), + ecl_times(y->ratio.num, + x->ratio.den))); + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - case t_singlefloat: - dx = (double)(ecl_single_float(x)); - goto DOUBLEFLOAT0; - case t_doublefloat: - dx = ecl_double_float(x); - DOUBLEFLOAT0: - switch (ty) { - case t_fixnum: - return -double_fix_compare(ecl_fixnum(y), dx); - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - dy = (double)(ecl_single_float(y)); - break; - case t_doublefloat: - dy = ecl_double_float(y); - break; + y = cl_rational(y); + goto BEGIN; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + case t_singlefloat: + dx = (double)(ecl_single_float(x)); + goto DOUBLEFLOAT0; + case t_doublefloat: + dx = ecl_double_float(x); + DOUBLEFLOAT0: + switch (ty) { + case t_fixnum: + return -double_fix_compare(ecl_fixnum(y), dx); + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + dy = (double)(ecl_single_float(y)); + break; + case t_doublefloat: + dy = ecl_double_float(y); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - ldx = dx; - ldy = ecl_long_float(y); - goto LONGFLOAT; + case t_longfloat: + ldx = dx; + ldy = ecl_long_float(y); + goto LONGFLOAT; #endif - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - DOUBLEFLOAT: - if (dx == dy) - return(0); - else if (dx < dy) - return(-1); - else - return(1); + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + DOUBLEFLOAT: + if (dx == dy) + return(0); + else if (dx < dy) + return(-1); + else + return(1); #ifdef ECL_LONG_FLOAT - case t_longfloat: - ldx = ecl_long_float(x); - switch (ty) { - case t_fixnum: - return -long_double_fix_compare(ecl_fixnum(y), ldx); - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - ldy = ecl_single_float(y); - break; - case t_doublefloat: - ldy = ecl_double_float(y); - break; - case t_longfloat: - ldy = ecl_long_float(y); - break; - default: - FEwrong_type_nth_arg(@[<], 2, y, @[real]); - } - LONGFLOAT: - if (ldx == ldy) - return 0; - else if (ldx < ldy) - return -1; - else - return 1; - break; + case t_longfloat: + ldx = ecl_long_float(x); + switch (ty) { + case t_fixnum: + return -long_double_fix_compare(ecl_fixnum(y), ldx); + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + ldy = ecl_single_float(y); + break; + case t_doublefloat: + ldy = ecl_double_float(y); + break; + case t_longfloat: + ldy = ecl_long_float(y); + break; + default: + FEwrong_type_nth_arg(@[<], 2, y, @[real]); + } + LONGFLOAT: + if (ldx == ldy) + return 0; + else if (ldx < ldy) + return -1; + else + return 1; + break; #endif - default: - FEwrong_type_nth_arg(@[<], 1, x, @[real]); - } + default: + FEwrong_type_nth_arg(@[<], 1, x, @[real]); + } } static cl_object monotonic(int s, int t, int narg, ecl_va_list nums) { - cl_object c, d; + cl_object c, d; - if (narg == 0) - FEwrong_num_arguments_anonym(); - /* INV: type check occurs in ecl_number_compare() */ - for (c = ecl_va_arg(nums); --narg; c = d) { - d = ecl_va_arg(nums); - if (s*ecl_number_compare(d, c) < t) - return1(ECL_NIL); - } - return1(ECL_T); + if (narg == 0) + FEwrong_num_arguments_anonym(); + /* INV: type check occurs in ecl_number_compare() */ + for (c = ecl_va_arg(nums); --narg; c = d) { + d = ecl_va_arg(nums); + if (s*ecl_number_compare(d, c) < t) + return1(ECL_NIL); + } + return1(ECL_T); } -#define MONOTONIC(i, j) (cl_narg narg, ...) \ -{ ecl_va_list nums; ecl_va_start(nums, narg, narg, 0); \ - return monotonic(i, j, narg, nums); } +#define MONOTONIC(i, j) (cl_narg narg, ...) \ + { ecl_va_list nums; ecl_va_start(nums, narg, narg, 0); \ + return monotonic(i, j, narg, nums); } cl_object @<= MONOTONIC( 1, 0) -cl_object @>= MONOTONIC(-1, 0) -cl_object @< MONOTONIC( 1, 1) -cl_object @> MONOTONIC(-1, 1) + cl_object @>= MONOTONIC(-1, 0) + cl_object @< MONOTONIC( 1, 1) + cl_object @> MONOTONIC(-1, 1) diff --git a/src/c/numbers/number_equalp.d b/src/c/numbers/number_equalp.d index 2a201cdfb..3fad40a16 100644 --- a/src/c/numbers/number_equalp.d +++ b/src/c/numbers/number_equalp.d @@ -1,195 +1,193 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - number_compare.c -- number comparison and sorting. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * number_compare.c - number comparison and sorting + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ #include #include #include "numbers/float_fix_compare.d" @(defun = (num &rest nums) - int i; -@ - /* ANSI: Need not signal error for 1 argument */ - /* INV: For >= 2 arguments, ecl_number_equalp() performs checks */ - for (i = 1; i < narg; i++) - if (!ecl_number_equalp(num, ecl_va_arg(nums))) - @(return ECL_NIL) - @(return ECL_T) -@) + int i; + @ + /* ANSI: Need not signal error for 1 argument */ + /* INV: For >= 2 arguments, ecl_number_equalp() performs checks */ + for (i = 1; i < narg; i++) + if (!ecl_number_equalp(num, ecl_va_arg(nums))) { + @(return ECL_NIL); + } + @(return ECL_T); + @) /* Returns 1 if both numbers compare to equal */ int ecl_number_equalp(cl_object x, cl_object y) { - double dx; - /* INV: (= fixnum bignum) => 0 */ - /* INV: (= fixnum ratio) => 0 */ - /* INV: (= bignum ratio) => 0 */ + double dx; + /* INV: (= fixnum bignum) => 0 */ + /* INV: (= fixnum ratio) => 0 */ + /* INV: (= bignum ratio) => 0 */ BEGIN: - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return x == y; - case t_bignum: - case t_ratio: - return 0; - case t_singlefloat: - return double_fix_compare(ecl_fixnum(x), ecl_single_float(y)) == 0; - case t_doublefloat: - return double_fix_compare(ecl_fixnum(x), ecl_double_float(y)) == 0; + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return x == y; + case t_bignum: + case t_ratio: + return 0; + case t_singlefloat: + return double_fix_compare(ecl_fixnum(x), ecl_single_float(y)) == 0; + case t_doublefloat: + return double_fix_compare(ecl_fixnum(x), ecl_double_float(y)) == 0; #ifdef ECL_LONG_FLOAT - case t_longfloat: - return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)) == 0; + case t_longfloat: + return long_double_fix_compare(ecl_fixnum(x), ecl_long_float(y)) == 0; #endif - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return 0; - case t_bignum: - return _ecl_big_compare(x, y)==0; - case t_ratio: - return 0; - case t_singlefloat: - case t_doublefloat: + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return 0; + case t_bignum: + return _ecl_big_compare(x, y)==0; + case t_ratio: + return 0; + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - return 0; - case t_ratio: - return (ecl_number_equalp(x->ratio.num, y->ratio.num) && - ecl_number_equalp(x->ratio.den, y->ratio.den)); - case t_singlefloat: - case t_doublefloat: + y = cl_rational(y); + goto BEGIN; + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + return 0; + case t_ratio: + return (ecl_number_equalp(x->ratio.num, y->ratio.num) && + ecl_number_equalp(x->ratio.den, y->ratio.den)); + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - y = cl_rational(y); - goto BEGIN; - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - case t_singlefloat: - dx = ecl_single_float(x); - goto FLOAT_ECL; - case t_doublefloat: - dx = ecl_double_float(x); - FLOAT_ECL: - switch (ecl_t_of(y)) { - case t_fixnum: - return double_fix_compare(ecl_fixnum(y), dx) == 0; - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - return dx == ecl_single_float(y); - case t_doublefloat: - return dx == ecl_double_float(y); + y = cl_rational(y); + goto BEGIN; + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + case t_singlefloat: + dx = ecl_single_float(x); + goto FLOAT_ECL; + case t_doublefloat: + dx = ecl_double_float(x); + FLOAT_ECL: + switch (ecl_t_of(y)) { + case t_fixnum: + return double_fix_compare(ecl_fixnum(y), dx) == 0; + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + return dx == ecl_single_float(y); + case t_doublefloat: + return dx == ecl_double_float(y); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return dx == ecl_long_float(y); + case t_longfloat: + return dx == ecl_long_float(y); #endif - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double dx = ecl_long_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return long_double_fix_compare(ecl_fixnum(y), dx) == 0; - case t_bignum: - case t_ratio: - x = cl_rational(x); - goto BEGIN; - case t_singlefloat: - return dx == ecl_single_float(y); - case t_doublefloat: - return dx == ecl_double_float(y); - case t_longfloat: - return dx == ecl_long_float(y); - case t_complex: - goto Y_COMPLEX; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - } + case t_longfloat: { + long double dx = ecl_long_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return long_double_fix_compare(ecl_fixnum(y), dx) == 0; + case t_bignum: + case t_ratio: + x = cl_rational(x); + goto BEGIN; + case t_singlefloat: + return dx == ecl_single_float(y); + case t_doublefloat: + return dx == ecl_double_float(y); + case t_longfloat: + return dx == ecl_long_float(y); + case t_complex: + goto Y_COMPLEX; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + } #endif - Y_COMPLEX: - if (!ecl_zerop(y->complex.imag)) - return 0; - return ecl_number_equalp(x, y->complex.real); - case t_complex: - switch (ecl_t_of(y)) { - case t_complex: - return (ecl_number_equalp(x->complex.real, y->complex.real) && - ecl_number_equalp(x->complex.imag, y->complex.imag)); - case t_fixnum: case t_bignum: case t_ratio: - case t_singlefloat: case t_doublefloat: + Y_COMPLEX: + if (!ecl_zerop(y->complex.imag)) + return 0; + return ecl_number_equalp(x, y->complex.real); + case t_complex: + switch (ecl_t_of(y)) { + case t_complex: + return (ecl_number_equalp(x->complex.real, y->complex.real) && + ecl_number_equalp(x->complex.imag, y->complex.imag)); + case t_fixnum: case t_bignum: case t_ratio: + case t_singlefloat: case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - if (ecl_zerop(x->complex.imag)) - return ecl_number_equalp(x->complex.real, y) != 0; - else - return 0; - default: - FEwrong_type_nth_arg(@[=], 2, y, @[number]); - } - default: - FEwrong_type_nth_arg(@[=], 1, x, @[number]); - } + if (ecl_zerop(x->complex.imag)) + return ecl_number_equalp(x->complex.real, y) != 0; + else + return 0; + default: + FEwrong_type_nth_arg(@[=], 2, y, @[number]); + } + default: + FEwrong_type_nth_arg(@[=], 1, x, @[number]); + } } @(defun /= (&rest nums &aux numi) - int i, j; -@ - if (narg == 0) - FEwrong_num_arguments_anonym(); - numi = ecl_va_arg(nums); - for (i = 2; i<=narg; i++) { - ecl_va_list numb; - ecl_va_start(numb, narg, narg, 0); - numi = ecl_va_arg(nums); - for (j = 1; j #include @@ -23,48 +19,48 @@ static cl_object ecl_one_minus_fix(cl_object x) { - if (x == ecl_make_fixnum(MOST_NEGATIVE_FIXNUM)) - return ecl_make_integer(MOST_NEGATIVE_FIXNUM-1); - return (cl_object)((cl_fixnum)x - ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); + if (x == ecl_make_fixnum(MOST_NEGATIVE_FIXNUM)) + return ecl_make_integer(MOST_NEGATIVE_FIXNUM-1); + return (cl_object)((cl_fixnum)x - ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); } static cl_object ecl_one_minus_big(cl_object x) { - return ecl_minus(x, ecl_make_fixnum(1)); + return ecl_minus(x, ecl_make_fixnum(1)); } static cl_object ecl_one_minus_ratio(cl_object x) { - return ecl_make_ratio(ecl_minus(x->ratio.num,x->ratio.den), x->ratio.den); + return ecl_make_ratio(ecl_minus(x->ratio.num,x->ratio.den), x->ratio.den); } static cl_object ecl_one_minus_single_float(cl_object x) { - return ecl_make_single_float(ecl_single_float(x) - 1); + return ecl_make_single_float(ecl_single_float(x) - 1); } static cl_object ecl_one_minus_double_float(cl_object x) { - return ecl_make_double_float(ecl_double_float(x) - 1); + return ecl_make_double_float(ecl_double_float(x) - 1); } #ifdef ECL_LONG_FLOAT static cl_object ecl_one_minus_long_float(cl_object x) { - return ecl_make_long_float(ecl_long_float(x) - 1); + return ecl_make_long_float(ecl_long_float(x) - 1); } #endif static cl_object ecl_one_minus_complex(cl_object x) { - return ecl_make_complex(ecl_one_minus(x->complex.real), - x->complex.imag); + return ecl_make_complex(ecl_one_minus(x->complex.real), + x->complex.imag); } MATH_DEF_DISPATCH1_NE(one_minus, @[1-], @[number], @@ -77,6 +73,5 @@ MATH_DEF_DISPATCH1_NE(one_minus, @[1-], @[number], cl_object @1-(cl_object x) { /* INV: type check is in ecl_one_minus() */ - @(return ecl_one_minus(x)) + @(return ecl_one_minus(x)); } - diff --git a/src/c/numbers/one_plus.d b/src/c/numbers/one_plus.d index 57c220238..96f7e9c47 100644 --- a/src/c/numbers/one_plus.d +++ b/src/c/numbers/one_plus.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - one_plus.d -- Implementation of CL:1+ -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * one_plus.d - implementation of CL:1+ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ #include #include @@ -23,48 +19,48 @@ static cl_object ecl_one_plus_fix(cl_object x) { - if (x == ecl_make_fixnum(MOST_POSITIVE_FIXNUM)) - return ecl_make_integer(MOST_POSITIVE_FIXNUM+1); - return (cl_object)((cl_fixnum)x + ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); + if (x == ecl_make_fixnum(MOST_POSITIVE_FIXNUM)) + return ecl_make_integer(MOST_POSITIVE_FIXNUM+1); + return (cl_object)((cl_fixnum)x + ((cl_fixnum)ecl_make_fixnum(1) - ECL_FIXNUM_TAG)); } static cl_object ecl_one_plus_big(cl_object x) { - return ecl_plus(x, ecl_make_fixnum(1)); + return ecl_plus(x, ecl_make_fixnum(1)); } static cl_object ecl_one_plus_ratio(cl_object x) { - return ecl_make_ratio(ecl_plus(x->ratio.num,x->ratio.den), x->ratio.den); + return ecl_make_ratio(ecl_plus(x->ratio.num,x->ratio.den), x->ratio.den); } static cl_object ecl_one_plus_single_float(cl_object x) { - return ecl_make_single_float(ecl_single_float(x) + 1); + return ecl_make_single_float(ecl_single_float(x) + 1); } static cl_object ecl_one_plus_double_float(cl_object x) { - return ecl_make_double_float(ecl_double_float(x) + 1); + return ecl_make_double_float(ecl_double_float(x) + 1); } #ifdef ECL_LONG_FLOAT static cl_object ecl_one_plus_long_float(cl_object x) { - return ecl_make_long_float(ecl_long_float(x) + 1); + return ecl_make_long_float(ecl_long_float(x) + 1); } #endif static cl_object ecl_one_plus_complex(cl_object x) { - return ecl_make_complex(ecl_one_plus(x->complex.real), - x->complex.imag); + return ecl_make_complex(ecl_one_plus(x->complex.real), + x->complex.imag); } MATH_DEF_DISPATCH1_NE(one_plus, @[1+], @[number], @@ -77,6 +73,6 @@ MATH_DEF_DISPATCH1_NE(one_plus, @[1+], @[number], cl_object @1+(cl_object x) { - /* INV: type check is in ecl_one_plus() */ - @(return ecl_one_plus(x)) + /* INV: type check is in ecl_one_plus() */ + @(return ecl_one_plus(x)); } diff --git a/src/c/numbers/plus.d b/src/c/numbers/plus.d index fb3f38155..d79f2d055 100644 --- a/src/c/numbers/plus.d +++ b/src/c/numbers/plus.d @@ -1,175 +1,173 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - plus.d -- Implementation of CL:+ -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. + * plus.d - implementation of CL:+ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../../Copyright' for full details. -*/ #include #include @(defun + (&rest nums) - cl_object sum = ecl_make_fixnum(0); -@ - /* INV: type check is in ecl_plus() */ - while (narg--) - sum = ecl_plus(sum, ecl_va_arg(nums)); - @(return sum) -@) + cl_object sum = ecl_make_fixnum(0); + @ + /* INV: type check is in ecl_plus() */ + while (narg--) + sum = ecl_plus(sum, ecl_va_arg(nums)); + @(return sum) + @) #ifdef MATH_DISPATCH2_BEGIN cl_object ecl_plus(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); - } - CASE_FIXNUM_BIGNUM { - return _ecl_big_plus_fix(y, ecl_fixnum(x)); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - cl_object z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); - } - CASE_BIGNUM_FIXNUM { - return _ecl_big_plus_fix(x, ecl_fixnum(y)); - } - CASE_BIGNUM_BIGNUM { - return _ecl_big_plus_big(x, y); - } - CASE_BIGNUM_SINGLE_FLOAT; - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) + ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT; - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.den, y); - z = ecl_plus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - } - CASE_RATIO_RATIO { - cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); - cl_object z = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_plus(z1, z); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) + ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); - } + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); + } + CASE_FIXNUM_BIGNUM { + return _ecl_big_plus_fix(y, ecl_fixnum(x)); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + cl_object z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); + } + CASE_BIGNUM_FIXNUM { + return _ecl_big_plus_fix(x, ecl_fixnum(y)); + } + CASE_BIGNUM_BIGNUM { + return _ecl_big_plus_big(x, y); + } + CASE_BIGNUM_SINGLE_FLOAT; + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) + ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT; + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.den, y); + z = ecl_plus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + } + CASE_RATIO_RATIO { + cl_object z1 = ecl_times(x->ratio.num,y->ratio.den); + cl_object z = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_plus(z1, z); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) + ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); - } - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) + ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); + } + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) + ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) + ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX_Y; - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return ecl_make_complex(ecl_plus(x, y->complex.real), - y->complex.imag); - } - CASE_COMPLEX_COMPLEX { - cl_object z = ecl_plus(x->complex.real, y->complex.real); - cl_object z1 = ecl_plus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); - } - CASE_UNKNOWN(@[+],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX_Y; + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return ecl_make_complex(ecl_plus(x, y->complex.real), + y->complex.imag); + } + CASE_COMPLEX_COMPLEX { + cl_object z = ecl_plus(x->complex.real, y->complex.real); + cl_object z1 = ecl_plus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); + } + CASE_UNKNOWN(@[+],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -177,155 +175,155 @@ MATH_DISPATCH2_END; cl_object ecl_plus(cl_object x, cl_object y) { - cl_fixnum i, j; - cl_object z, z1; + cl_fixnum i, j; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); - case t_bignum: - return _ecl_big_plus_fix(y, ecl_fixnum(x)); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_integer(ecl_fixnum(x) + ecl_fixnum(y)); + case t_bignum: + return _ecl_big_plus_fix(y, ecl_fixnum(x)); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) + ecl_long_float(y)); #endif - case t_complex: - COMPLEX: /* INV: x is real, y is complex */ - return ecl_make_complex(ecl_plus(x, y->complex.real), - y->complex.imag); - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_big_plus_fix(x, ecl_fixnum(y)); - case t_bignum: - return _ecl_big_plus_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.den); - z = ecl_plus(z, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + case t_complex: + COMPLEX: /* INV: x is real, y is complex */ + return ecl_make_complex(ecl_plus(x, y->complex.real), + y->complex.imag); + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_big_plus_fix(x, ecl_fixnum(y)); + case t_bignum: + return _ecl_big_plus_big(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.den); + z = ecl_plus(z, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.den, y); - z = ecl_plus(x->ratio.num, z); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z1 = ecl_times(x->ratio.num,y->ratio.den); - z = ecl_times(x->ratio.den,y->ratio.num); - z = ecl_plus(z1, z); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.den, y); + z = ecl_plus(x->ratio.num, z); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z1 = ecl_times(x->ratio.num,y->ratio.den); + z = ecl_times(x->ratio.den,y->ratio.num); + z = ecl_plus(z1, z); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_singlefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(ecl_single_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_singlefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(ecl_single_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(ecl_single_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(ecl_single_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_single_float(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_single_float(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } - case t_doublefloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } + case t_doublefloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) + ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) + ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(ecl_long_float(x) + ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[+], 2, y, @[number]); - } + case t_longfloat: + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(ecl_long_float(x) + ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(ecl_long_float(x) + ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_long_float(x) + ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[+], 2, y, @[number]); + } #endif - case t_complex: - if (ecl_t_of(y) != t_complex) { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX; - } - z = ecl_plus(x->complex.real, y->complex.real); - z1 = ecl_plus(x->complex.imag, y->complex.imag); - return ecl_make_complex(z, z1); - default: - FEwrong_type_nth_arg(@[+], 1, x, @[number]); - } + case t_complex: + if (ecl_t_of(y) != t_complex) { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX; + } + z = ecl_plus(x->complex.real, y->complex.real); + z1 = ecl_plus(x->complex.imag, y->complex.imag); + return ecl_make_complex(z, z1); + default: + FEwrong_type_nth_arg(@[+], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/plusp.d b/src/c/numbers/plusp.d index c19188141..1d238f421 100644 --- a/src/c/numbers/plusp.d +++ b/src/c/numbers/plusp.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - plusp.d -- Implementation of CL:PLUSP -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * plusp.d - implementation of CL:PLUSP + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ #include #include @@ -23,43 +19,43 @@ cl_object cl_plusp(cl_object x) { /* INV: ecl_plusp() checks type */ - @(return (ecl_plusp(x) ? ECL_T : ECL_NIL)) + @(return (ecl_plusp(x) ? ECL_T : ECL_NIL)); } static int ecl_plusp_fixnum(cl_object x) { - return ecl_fixnum_plusp(x); + return ecl_fixnum_plusp(x); } static int ecl_plusp_big(cl_object x) { - return _ecl_big_sign(x) > 0; + return _ecl_big_sign(x) > 0; } static int ecl_plusp_ratio(cl_object x) { - return ecl_plusp(x->ratio.num); + return ecl_plusp(x->ratio.num); } static int ecl_plusp_single_float(cl_object x) { - return ecl_single_float(x) > 0; + return ecl_single_float(x) > 0; } static int ecl_plusp_double_float(cl_object x) { - return ecl_double_float(x) > 0; + return ecl_double_float(x) > 0; } #ifdef ECL_LONG_FLOAT static int ecl_plusp_long_float(cl_object x) { - return ecl_long_float(x) > 0; + return ecl_long_float(x) > 0; } #endif diff --git a/src/c/numbers/round.d b/src/c/numbers/round.d index 70687fdce..051aae0c7 100644 --- a/src/c/numbers/round.d +++ b/src/c/numbers/round.d @@ -1,19 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - round.d -- Implementation of CL:ROUND -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. + * round.d - implementation of CL:ROUND + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -26,142 +24,142 @@ #include @(defun round (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_round1(x); - else - return ecl_round2(x, y); -@) + @ + if (narg == 1) + return ecl_round1(x); + else + return ecl_round2(x, y); + @) static cl_object number_remainder(cl_object x, cl_object y, cl_object q) { - cl_object z; + cl_object z; - z = ecl_times(q, y); - z = ecl_minus(x, z); - return(z); + z = ecl_times(q, y); + z = ecl_minus(x, z); + return(z); } static double round_double(double d) { - if (d >= 0) { - double q = floor(d += 0.5); - if (q == d) { - int i = (int)fmod(q, 10); - if (i & 1) { - return q-1; - } - } - return q; - } else { - return -round_double(-d); - } + if (d >= 0) { + double q = floor(d += 0.5); + if (q == d) { + int i = (int)fmod(q, 10); + if (i & 1) { + return q-1; + } + } + return q; + } else { + return -round_double(-d); + } } #ifdef ECL_LONG_FLOAT static long double round_long_double(long double d) { - if (d >= 0) { - long double q = floorl(d += 0.5); - if (q == d) { - int i = (int)fmodl(q, 10); - if (i & 1) { - return q-1; - } - } - return q; - } else { - return -round_long_double(-d); - } + if (d >= 0) { + long double q = floorl(d += 0.5); + if (q == d) { + int i = (int)fmodl(q, 10); + if (i & 1) { + return q-1; + } + } + return q; + } else { + return -round_long_double(-d); + } } #endif static cl_object ecl_round2_integer(const cl_env_ptr the_env, cl_object x, cl_object y, cl_object q) { - cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); - cl_object r = ecl_minus(q, q1); - if (ecl_minusp(r)) { - int c = ecl_number_compare(cl_core.minus_half, r); - if (c > 0 || (c == 0 && ecl_oddp(q1))) { - q1 = ecl_one_minus(q1); - } - } else { - int c = ecl_number_compare(r, cl_core.plus_half); - if (c > 0 || (c == 0 && ecl_oddp(q1))) { - q1 = ecl_one_plus(q1); - } - } - r = number_remainder(x, y, q1); - ecl_return2(the_env, q1, r); + cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); + cl_object r = ecl_minus(q, q1); + if (ecl_minusp(r)) { + int c = ecl_number_compare(cl_core.minus_half, r); + if (c > 0 || (c == 0 && ecl_oddp(q1))) { + q1 = ecl_one_minus(q1); + } + } else { + int c = ecl_number_compare(r, cl_core.plus_half); + if (c > 0 || (c == 0 && ecl_oddp(q1))) { + q1 = ecl_one_plus(q1); + } + } + r = number_remainder(x, y, q1); + ecl_return2(the_env, q1, r); } cl_object ecl_round1(cl_object x) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - v0 = ecl_round2_integer(the_env, x->ratio.num, x->ratio.den, x); - v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); - break; - case t_singlefloat: { - float d = ecl_single_float(x); - float q = round_double(d); - v0 = _ecl_float_to_integer(q); - v1 = ecl_make_single_float(d - q); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double q = round_double(d); - v0 = _ecl_double_to_integer(q); - v1 = ecl_make_double_float(d - q); - break; - } + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + v0 = ecl_round2_integer(the_env, x->ratio.num, x->ratio.den, x); + v1 = ecl_make_ratio(ecl_nth_value(the_env, 1), x->ratio.den); + break; + case t_singlefloat: { + float d = ecl_single_float(x); + float q = round_double(d); + v0 = _ecl_float_to_integer(q); + v1 = ecl_make_single_float(d - q); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double q = round_double(d); + v0 = _ecl_double_to_integer(q); + v1 = ecl_make_double_float(d - q); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double q = round_long_double(d); - v0 = _ecl_long_double_to_integer(q); - v1 = ecl_make_long_float(d - q); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double q = round_long_double(d); + v0 = _ecl_long_double_to_integer(q); + v1 = ecl_make_long_float(d - q); + break; + } #endif - default: - FEwrong_type_nth_arg(@[round],1,x,@[real]); - } - ecl_return2(the_env, v0, v1); + default: + FEwrong_type_nth_arg(@[round],1,x,@[real]); + } + ecl_return2(the_env, v0, v1); } cl_object ecl_round2(cl_object x, cl_object y) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v0, v1; - cl_object q; + const cl_env_ptr the_env = ecl_process_env(); + cl_object v0, v1; + cl_object q; - q = ecl_divide(x, y); - switch (ecl_t_of(q)) { - case t_fixnum: - case t_bignum: - v0 = q; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - return ecl_round2_integer(the_env, x, y, q); - default: - v0 = q = ecl_round1(q); - v1 = number_remainder(x, y, q); - } - ecl_return2(the_env, v0, v1); + q = ecl_divide(x, y); + switch (ecl_t_of(q)) { + case t_fixnum: + case t_bignum: + v0 = q; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + return ecl_round2_integer(the_env, x, y, q); + default: + v0 = q = ecl_round1(q); + v1 = number_remainder(x, y, q); + } + ecl_return2(the_env, v0, v1); } diff --git a/src/c/numbers/sin.d b/src/c/numbers/sin.d index a92e8a9a3..03dea336d 100644 --- a/src/c/numbers/sin.d +++ b/src/c/numbers/sin.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sin.d -- Trascendental functions: sine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * sin.d - trascendental functions: sine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,48 +23,48 @@ cl_object cl_sin(cl_object x) { - @(return ecl_sin(x)); + @(return ecl_sin(x)); } static cl_object ecl_sin_rational(cl_object x) { - return ecl_make_single_float(sinf(ecl_to_float(x))); + return ecl_make_single_float(sinf(ecl_to_float(x))); } static cl_object ecl_sin_single_float(cl_object x) { - return ecl_make_single_float(sinf(ecl_single_float(x))); + return ecl_make_single_float(sinf(ecl_single_float(x))); } static cl_object ecl_sin_double_float(cl_object x) { - return ecl_make_double_float(sin(ecl_double_float(x))); + return ecl_make_double_float(sin(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_sin_long_float(cl_object x) { - return ecl_make_long_float(sinl(ecl_long_float(x))); + return ecl_make_long_float(sinl(ecl_long_float(x))); } #endif static cl_object ecl_sin_complex(cl_object x) { - /* - z = x + I y - z = x + I y - sin(z) = sinh(I z) = sinh(-y + I x) - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_sin(dx), ecl_cosh(dy)); - cl_object b = ecl_times(ecl_cos(dx), ecl_sinh(dy)); - return ecl_make_complex(a, b); + /* + z = x + I y + z = x + I y + sin(z) = sinh(I z) = sinh(-y + I x) + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_sin(dx), ecl_cosh(dy)); + cl_object b = ecl_times(ecl_cos(dx), ecl_sinh(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(sin, @[sin], @[number], diff --git a/src/c/numbers/sinh.d b/src/c/numbers/sinh.d index bd52eb88d..54835b76c 100644 --- a/src/c/numbers/sinh.d +++ b/src/c/numbers/sinh.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sinh.d -- Trascendental functions: hyperbolic sine -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * sinh.d - trascendental functions: hyperbolic sine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,49 +23,49 @@ cl_object cl_sinh(cl_object x) { - @(return ecl_sinh(x)); + @(return ecl_sinh(x)); } static cl_object ecl_sinh_rational(cl_object x) { - return ecl_make_single_float(sinhf(ecl_to_float(x))); + return ecl_make_single_float(sinhf(ecl_to_float(x))); } static cl_object ecl_sinh_single_float(cl_object x) { - return ecl_make_single_float(sinhf(ecl_single_float(x))); + return ecl_make_single_float(sinhf(ecl_single_float(x))); } static cl_object ecl_sinh_double_float(cl_object x) { - return ecl_make_double_float(sinh(ecl_double_float(x))); + return ecl_make_double_float(sinh(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_sinh_long_float(cl_object x) { - return ecl_make_long_float(sinhl(ecl_long_float(x))); + return ecl_make_long_float(sinhl(ecl_long_float(x))); } #endif static cl_object ecl_sinh_complex(cl_object x) { - /* - z = x + I y - sinh(z) = (exp(z)-exp(-z))/2 - = (exp(x)*(cos(y)+Isin(y))-exp(-x)*(cos(y)-Isin(y)))/2 - = sinh(x)*cos(y) + Icosh(x)*sin(y); - */ - cl_object dx = x->complex.real; - cl_object dy = x->complex.imag; - cl_object a = ecl_times(ecl_sinh(dx), ecl_cos(dy)); - cl_object b = ecl_times(ecl_cosh(dx), ecl_sin(dy)); - return ecl_make_complex(a, b); + /* + z = x + I y + sinh(z) = (exp(z)-exp(-z))/2 + = (exp(x)*(cos(y)+Isin(y))-exp(-x)*(cos(y)-Isin(y)))/2 + = sinh(x)*cos(y) + Icosh(x)*sin(y); + */ + cl_object dx = x->complex.real; + cl_object dy = x->complex.imag; + cl_object a = ecl_times(ecl_sinh(dx), ecl_cos(dy)); + cl_object b = ecl_times(ecl_cosh(dx), ecl_sin(dy)); + return ecl_make_complex(a, b); } MATH_DEF_DISPATCH1(sinh, @[sinh], @[number], diff --git a/src/c/numbers/sqrt.d b/src/c/numbers/sqrt.d index 595fee838..2b833c203 100644 --- a/src/c/numbers/sqrt.d +++ b/src/c/numbers/sqrt.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sqrt.d -- Square root. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * sqrt.d - square root + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,62 +23,62 @@ cl_object cl_sqrt(cl_object x) { - @(return ecl_sqrt(x)); + @(return ecl_sqrt(x)); } static cl_object ecl_sqrt_rational(cl_object x) { - if (ecl_minusp(x)) { - x = ecl_sqrt_rational(ecl_negate(x)); - return ecl_make_complex(ecl_make_fixnum(0), x); - } else { - return ecl_make_single_float(sqrtf(ecl_to_float(x))); - } + if (ecl_minusp(x)) { + x = ecl_sqrt_rational(ecl_negate(x)); + return ecl_make_complex(ecl_make_fixnum(0), x); + } else { + return ecl_make_single_float(sqrtf(ecl_to_float(x))); + } } static cl_object ecl_sqrt_single_float(cl_object x) { - float f = ecl_single_float(x); - if (f < 0) { - return ecl_make_complex(ecl_make_fixnum(0), - ecl_make_single_float(sqrtf(-f))); - } else { - return ecl_make_single_float(sqrtf(f)); - } + float f = ecl_single_float(x); + if (f < 0) { + return ecl_make_complex(ecl_make_fixnum(0), + ecl_make_single_float(sqrtf(-f))); + } else { + return ecl_make_single_float(sqrtf(f)); + } } static cl_object ecl_sqrt_double_float(cl_object x) { - double f = ecl_double_float(x); - if (f < 0) { - return ecl_make_complex(ecl_make_fixnum(0), - ecl_make_double_float(sqrt(-f))); - } else { - return ecl_make_double_float(sqrt(f)); - } + double f = ecl_double_float(x); + if (f < 0) { + return ecl_make_complex(ecl_make_fixnum(0), + ecl_make_double_float(sqrt(-f))); + } else { + return ecl_make_double_float(sqrt(f)); + } } #ifdef ECL_LONG_FLOAT static cl_object ecl_sqrt_long_float(cl_object x) { - long double f = ecl_long_float(x); - if (f < 0) { - return ecl_make_complex(ecl_make_fixnum(0), - ecl_make_long_float(sqrtl(-f))); - } else { - return ecl_make_long_float(sqrtl(f)); - } + long double f = ecl_long_float(x); + if (f < 0) { + return ecl_make_complex(ecl_make_fixnum(0), + ecl_make_long_float(sqrtl(-f))); + } else { + return ecl_make_long_float(sqrtl(f)); + } } #endif static cl_object ecl_sqrt_complex(cl_object x) { - return ecl_expt(x, cl_core.plus_half); + return ecl_expt(x, cl_core.plus_half); } MATH_DEF_DISPATCH1(sqrt, @[sqrt], @[number], diff --git a/src/c/numbers/tan.d b/src/c/numbers/tan.d index 639ef6d5f..8df59710e 100644 --- a/src/c/numbers/tan.d +++ b/src/c/numbers/tan.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - tan.d -- Trascendental functions: tangent -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * tan.d - trascendental functions: tangent + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -41,41 +37,41 @@ static double safe_tanf(double x) { return tan(x); } cl_object cl_tan(cl_object x) { - @(return ecl_tan(x)); + @(return ecl_tan(x)); } static cl_object ecl_tan_rational(cl_object x) { - return ecl_make_single_float(safe_tanf(ecl_to_float(x))); + return ecl_make_single_float(safe_tanf(ecl_to_float(x))); } static cl_object ecl_tan_single_float(cl_object x) { - return ecl_make_single_float(safe_tanf(ecl_single_float(x))); + return ecl_make_single_float(safe_tanf(ecl_single_float(x))); } static cl_object ecl_tan_double_float(cl_object x) { - return ecl_make_double_float(tan(ecl_double_float(x))); + return ecl_make_double_float(tan(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_tan_long_float(cl_object x) { - return ecl_make_long_float(tanl(ecl_long_float(x))); + return ecl_make_long_float(tanl(ecl_long_float(x))); } #endif static cl_object ecl_tan_complex(cl_object x) { - cl_object a = ecl_sin(x); - cl_object b = ecl_cos(x); - return ecl_divide(a, b); + cl_object a = ecl_sin(x); + cl_object b = ecl_cos(x); + return ecl_divide(a, b); } MATH_DEF_DISPATCH1(tan, @[tan], @[number], diff --git a/src/c/numbers/tanh.d b/src/c/numbers/tanh.d index ef95c3337..b44e25a8e 100644 --- a/src/c/numbers/tanh.d +++ b/src/c/numbers/tanh.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - tanh.d -- Trascendental functions: hyperbolic tangent -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * tanh.d - trascendental functions: hyperbolic tangent + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,41 +23,41 @@ cl_object cl_tanh(cl_object x) { - @(return ecl_tanh(x)); + @(return ecl_tanh(x)); } static cl_object ecl_tanh_rational(cl_object x) { - return ecl_make_single_float(tanhf(ecl_to_float(x))); + return ecl_make_single_float(tanhf(ecl_to_float(x))); } static cl_object ecl_tanh_single_float(cl_object x) { - return ecl_make_single_float(tanhf(ecl_single_float(x))); + return ecl_make_single_float(tanhf(ecl_single_float(x))); } static cl_object ecl_tanh_double_float(cl_object x) { - return ecl_make_double_float(tanh(ecl_double_float(x))); + return ecl_make_double_float(tanh(ecl_double_float(x))); } #ifdef ECL_LONG_FLOAT static cl_object ecl_tanh_long_float(cl_object x) { - return ecl_make_long_float(tanhl(ecl_long_float(x))); + return ecl_make_long_float(tanhl(ecl_long_float(x))); } #endif static cl_object ecl_tanh_complex(cl_object x) { - cl_object a = ecl_sinh(x); - cl_object b = ecl_cosh(x); - return ecl_divide(a, b); + cl_object a = ecl_sinh(x); + cl_object b = ecl_cosh(x); + return ecl_divide(a, b); } MATH_DEF_DISPATCH1(tanh, @[tanh], @[number], diff --git a/src/c/numbers/times.d b/src/c/numbers/times.d index c362f3842..110e6e8a2 100644 --- a/src/c/numbers/times.d +++ b/src/c/numbers/times.d @@ -1,175 +1,173 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - times.d -- Implementation of CL:* -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. + * times.d - implementation of CL:* + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../../Copyright' for full details. -*/ #include #include @(defun * (&rest nums) - cl_object prod = ecl_make_fixnum(1); -@ - /* INV: type check in ecl_times() */ - while (narg--) - prod = ecl_times(prod, ecl_va_arg(nums)); - @(return prod) -@) + cl_object prod = ecl_make_fixnum(1); + @ + /* INV: type check in ecl_times() */ + while (narg--) + prod = ecl_times(prod, ecl_va_arg(nums)); + @(return prod); + @) #ifdef MATH_DISPATCH2_BEGIN cl_object ecl_times(cl_object x, cl_object y) { -MATH_DISPATCH2_BEGIN(x,y) -{ - CASE_FIXNUM_FIXNUM { - return _ecl_fix_times_fix(ecl_fixnum(x), ecl_fixnum(y)); - } - CASE_FIXNUM_BIGNUM { - return _ecl_big_times_fix(y, ecl_fixnum(x)); - } - CASE_FIXNUM_RATIO; - CASE_BIGNUM_RATIO { - return ecl_make_ratio(ecl_times(x, y->ratio.num), - y->ratio.den); - } - CASE_FIXNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); - } - CASE_FIXNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); - } - CASE_BIGNUM_FIXNUM { - return _ecl_big_times_fix(x, ecl_fixnum(y)); - } - CASE_BIGNUM_BIGNUM { - return _ecl_big_times_big(x, y); - } - CASE_BIGNUM_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); - } - CASE_BIGNUM_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); - } - CASE_RATIO_FIXNUM; - CASE_RATIO_BIGNUM { - cl_object z = ecl_times(x->ratio.num, y); - return ecl_make_ratio(z, x->ratio.den); - } - CASE_RATIO_RATIO { - cl_object num = ecl_times(x->ratio.num,y->ratio.num); - cl_object den = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(num, den); - } - CASE_RATIO_SINGLE_FLOAT { - return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); - } - CASE_RATIO_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); - } - CASE_SINGLE_FLOAT_FIXNUM { - return ecl_make_single_float(ecl_single_float(x) * ecl_fixnum(y)); - } - CASE_SINGLE_FLOAT_BIGNUM; - CASE_SINGLE_FLOAT_RATIO { - return ecl_make_single_float(ecl_single_float(x) * ecl_to_float(y)); - } - CASE_SINGLE_FLOAT_SINGLE_FLOAT { - return ecl_make_single_float(ecl_single_float(x) * ecl_single_float(y)); - } - CASE_SINGLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_single_float(x) * ecl_double_float(y)); - } - CASE_DOUBLE_FLOAT_FIXNUM { - return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); - } - CASE_DOUBLE_FLOAT_BIGNUM; - CASE_DOUBLE_FLOAT_RATIO { - return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); - } - CASE_DOUBLE_FLOAT_SINGLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); - } - CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { - return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); - } + MATH_DISPATCH2_BEGIN(x,y) + { + CASE_FIXNUM_FIXNUM { + return _ecl_fix_times_fix(ecl_fixnum(x), ecl_fixnum(y)); + } + CASE_FIXNUM_BIGNUM { + return _ecl_big_times_fix(y, ecl_fixnum(x)); + } + CASE_FIXNUM_RATIO; + CASE_BIGNUM_RATIO { + return ecl_make_ratio(ecl_times(x, y->ratio.num), + y->ratio.den); + } + CASE_FIXNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); + } + CASE_FIXNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); + } + CASE_BIGNUM_FIXNUM { + return _ecl_big_times_fix(x, ecl_fixnum(y)); + } + CASE_BIGNUM_BIGNUM { + return _ecl_big_times_big(x, y); + } + CASE_BIGNUM_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); + } + CASE_BIGNUM_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + } + CASE_RATIO_FIXNUM; + CASE_RATIO_BIGNUM { + cl_object z = ecl_times(x->ratio.num, y); + return ecl_make_ratio(z, x->ratio.den); + } + CASE_RATIO_RATIO { + cl_object num = ecl_times(x->ratio.num,y->ratio.num); + cl_object den = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(num, den); + } + CASE_RATIO_SINGLE_FLOAT { + return ecl_make_single_float(ecl_to_float(x) * ecl_single_float(y)); + } + CASE_RATIO_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + } + CASE_SINGLE_FLOAT_FIXNUM { + return ecl_make_single_float(ecl_single_float(x) * ecl_fixnum(y)); + } + CASE_SINGLE_FLOAT_BIGNUM; + CASE_SINGLE_FLOAT_RATIO { + return ecl_make_single_float(ecl_single_float(x) * ecl_to_float(y)); + } + CASE_SINGLE_FLOAT_SINGLE_FLOAT { + return ecl_make_single_float(ecl_single_float(x) * ecl_single_float(y)); + } + CASE_SINGLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_single_float(x) * ecl_double_float(y)); + } + CASE_DOUBLE_FLOAT_FIXNUM { + return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); + } + CASE_DOUBLE_FLOAT_BIGNUM; + CASE_DOUBLE_FLOAT_RATIO { + return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); + } + CASE_DOUBLE_FLOAT_SINGLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); + } + CASE_DOUBLE_FLOAT_DOUBLE_FLOAT { + return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); + } #ifdef ECL_LONG_FLOAT - CASE_FIXNUM_LONG_FLOAT { - return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); - } - CASE_BIGNUM_LONG_FLOAT; - CASE_RATIO_LONG_FLOAT { - return ecl_make_long_float(ecl_to_long_double(x) * ecl_long_float(y)); - } - CASE_SINGLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_single_float(x) * ecl_long_float(y)); - } - CASE_DOUBLE_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); - } - CASE_LONG_FLOAT_FIXNUM { - return ecl_make_long_float(ecl_long_float(x) * ecl_fixnum(y)); - } - CASE_LONG_FLOAT_BIGNUM; - CASE_LONG_FLOAT_RATIO { - return ecl_make_long_float(ecl_long_float(x) * ecl_to_long_double(y)); - } - CASE_LONG_FLOAT_SINGLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) * ecl_single_float(y)); - } - CASE_LONG_FLOAT_DOUBLE_FLOAT { - return ecl_make_long_float(ecl_long_float(x) * ecl_double_float(y)); - } - CASE_LONG_FLOAT_LONG_FLOAT { - return ecl_make_long_float(ecl_long_float(x) * ecl_long_float(y)); - } - CASE_LONG_FLOAT_COMPLEX { - goto COMPLEX_Y; - } - CASE_COMPLEX_LONG_FLOAT; { - goto COMPLEX_X; - } + CASE_FIXNUM_LONG_FLOAT { + return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); + } + CASE_BIGNUM_LONG_FLOAT; + CASE_RATIO_LONG_FLOAT { + return ecl_make_long_float(ecl_to_long_double(x) * ecl_long_float(y)); + } + CASE_SINGLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_single_float(x) * ecl_long_float(y)); + } + CASE_DOUBLE_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); + } + CASE_LONG_FLOAT_FIXNUM { + return ecl_make_long_float(ecl_long_float(x) * ecl_fixnum(y)); + } + CASE_LONG_FLOAT_BIGNUM; + CASE_LONG_FLOAT_RATIO { + return ecl_make_long_float(ecl_long_float(x) * ecl_to_long_double(y)); + } + CASE_LONG_FLOAT_SINGLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) * ecl_single_float(y)); + } + CASE_LONG_FLOAT_DOUBLE_FLOAT { + return ecl_make_long_float(ecl_long_float(x) * ecl_double_float(y)); + } + CASE_LONG_FLOAT_LONG_FLOAT { + return ecl_make_long_float(ecl_long_float(x) * ecl_long_float(y)); + } + CASE_LONG_FLOAT_COMPLEX { + goto COMPLEX_Y; + } + CASE_COMPLEX_LONG_FLOAT; { + goto COMPLEX_X; + } #endif - CASE_COMPLEX_FIXNUM; - CASE_COMPLEX_BIGNUM; - CASE_COMPLEX_RATIO; - CASE_COMPLEX_SINGLE_FLOAT; - CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX_Y; - } - CASE_BIGNUM_COMPLEX; - CASE_RATIO_COMPLEX; - CASE_SINGLE_FLOAT_COMPLEX; - CASE_DOUBLE_FLOAT_COMPLEX; - CASE_FIXNUM_COMPLEX { - COMPLEX_Y: - return ecl_make_complex(ecl_times(x, y->complex.real), - ecl_times(x, y->complex.imag)); - } - CASE_COMPLEX_COMPLEX { - cl_object z11 = ecl_times(x->complex.real, y->complex.real); - cl_object z12 = ecl_times(x->complex.imag, y->complex.imag); - cl_object z21 = ecl_times(x->complex.imag, y->complex.real); - cl_object z22 = ecl_times(x->complex.real, y->complex.imag); - return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); - } - CASE_UNKNOWN(@[*],x,y,@[number]); -} -MATH_DISPATCH2_END; + CASE_COMPLEX_FIXNUM; + CASE_COMPLEX_BIGNUM; + CASE_COMPLEX_RATIO; + CASE_COMPLEX_SINGLE_FLOAT; + CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX_Y; + } + CASE_BIGNUM_COMPLEX; + CASE_RATIO_COMPLEX; + CASE_SINGLE_FLOAT_COMPLEX; + CASE_DOUBLE_FLOAT_COMPLEX; + CASE_FIXNUM_COMPLEX { + COMPLEX_Y: + return ecl_make_complex(ecl_times(x, y->complex.real), + ecl_times(x, y->complex.imag)); + } + CASE_COMPLEX_COMPLEX { + cl_object z11 = ecl_times(x->complex.real, y->complex.real); + cl_object z12 = ecl_times(x->complex.imag, y->complex.imag); + cl_object z21 = ecl_times(x->complex.imag, y->complex.real); + cl_object z22 = ecl_times(x->complex.real, y->complex.imag); + return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); + } + CASE_UNKNOWN(@[*],x,y,@[number]); + } + MATH_DISPATCH2_END; } #else @@ -177,162 +175,162 @@ MATH_DISPATCH2_END; cl_object ecl_times(cl_object x, cl_object y) { - cl_object z, z1; + cl_object z, z1; - switch (ecl_t_of(x)) { - case t_fixnum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_fix_times_fix(ecl_fixnum(x),ecl_fixnum(y)); - case t_bignum: - return _ecl_big_times_fix(y, ecl_fixnum(x)); - case t_ratio: - z = ecl_times(x, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); + switch (ecl_t_of(x)) { + case t_fixnum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_fix_times_fix(ecl_fixnum(x),ecl_fixnum(y)); + case t_bignum: + return _ecl_big_times_fix(y, ecl_fixnum(x)); + case t_ratio: + z = ecl_times(x, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_fixnum(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_fixnum(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_fixnum(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_bignum: - switch (ecl_t_of(y)) { - case t_fixnum: - return _ecl_big_times_fix(x, ecl_fixnum(y)); - case t_bignum: - return _ecl_big_times_big(x, y); - case t_ratio: - z = ecl_times(x, y->ratio.num); - return ecl_make_ratio(z, y->ratio.den); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_bignum: + switch (ecl_t_of(y)) { + case t_fixnum: + return _ecl_big_times_fix(x, ecl_fixnum(y)); + case t_bignum: + return _ecl_big_times_big(x, y); + case t_ratio: + z = ecl_times(x, y->ratio.num); + return ecl_make_ratio(z, y->ratio.den); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_ratio: - switch (ecl_t_of(y)) { - case t_fixnum: - case t_bignum: - z = ecl_times(x->ratio.num, y); - return ecl_make_ratio(z, x->ratio.den); - case t_ratio: - z = ecl_times(x->ratio.num,y->ratio.num); - z1 = ecl_times(x->ratio.den,y->ratio.den); - return ecl_make_ratio(z, z1); - case t_singlefloat: - return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_ratio: + switch (ecl_t_of(y)) { + case t_fixnum: + case t_bignum: + z = ecl_times(x->ratio.num, y); + return ecl_make_ratio(z, x->ratio.den); + case t_ratio: + z = ecl_times(x->ratio.num,y->ratio.num); + z1 = ecl_times(x->ratio.den,y->ratio.den); + return ecl_make_ratio(z, z1); + case t_singlefloat: + return ecl_make_single_float(ecl_to_double(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_to_double(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_to_double(x) * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - case t_singlefloat: { - float fx = ecl_single_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_single_float(fx * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_single_float(fx * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_single_float(fx * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(fx * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + case t_singlefloat: { + float fx = ecl_single_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_single_float(fx * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_single_float(fx * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_single_float(fx * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(fx * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(fx * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(fx * ecl_long_float(y)); #endif - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } - case t_doublefloat: { - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } + case t_doublefloat: { + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_double_float(ecl_double_float(x) * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_double_float(ecl_double_float(x) * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_double_float(ecl_double_float(x) * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_double_float(ecl_double_float(x) * ecl_double_float(y)); #ifdef ECL_LONG_FLOAT - case t_longfloat: - return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); + case t_longfloat: + return ecl_make_long_float(ecl_double_float(x) * ecl_long_float(y)); #endif - case t_complex: { - COMPLEX: /* INV: x is real, y is complex */ - return ecl_make_complex(ecl_times(x, y->complex.real), - ecl_times(x, y->complex.imag)); - } - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } + case t_complex: { + COMPLEX: /* INV: x is real, y is complex */ + return ecl_make_complex(ecl_times(x, y->complex.real), + ecl_times(x, y->complex.imag)); + } + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double lx = ecl_long_float(x); - switch (ecl_t_of(y)) { - case t_fixnum: - return ecl_make_long_float(lx * ecl_fixnum(y)); - case t_bignum: - case t_ratio: - return ecl_make_long_float(lx * ecl_to_double(y)); - case t_singlefloat: - return ecl_make_long_float(lx * ecl_single_float(y)); - case t_doublefloat: - return ecl_make_long_float(lx * ecl_double_float(y)); - case t_longfloat: - return ecl_make_long_float(lx * ecl_long_float(y)); - case t_complex: - goto COMPLEX; - default: - FEwrong_type_nth_arg(@[*], 2, y, @[number]); - } - } + case t_longfloat: { + long double lx = ecl_long_float(x); + switch (ecl_t_of(y)) { + case t_fixnum: + return ecl_make_long_float(lx * ecl_fixnum(y)); + case t_bignum: + case t_ratio: + return ecl_make_long_float(lx * ecl_to_double(y)); + case t_singlefloat: + return ecl_make_long_float(lx * ecl_single_float(y)); + case t_doublefloat: + return ecl_make_long_float(lx * ecl_double_float(y)); + case t_longfloat: + return ecl_make_long_float(lx * ecl_long_float(y)); + case t_complex: + goto COMPLEX; + default: + FEwrong_type_nth_arg(@[*], 2, y, @[number]); + } + } #endif - case t_complex: - { - cl_object z11, z12, z21, z22; + case t_complex: + { + cl_object z11, z12, z21, z22; - if (ecl_t_of(y) != t_complex) { - cl_object aux = x; - x = y; y = aux; - goto COMPLEX; - } - z11 = ecl_times(x->complex.real, y->complex.real); - z12 = ecl_times(x->complex.imag, y->complex.imag); - z21 = ecl_times(x->complex.imag, y->complex.real); - z22 = ecl_times(x->complex.real, y->complex.imag); - return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); - } - default: - FEwrong_type_nth_arg(@[*], 1, x, @[number]); - } + if (ecl_t_of(y) != t_complex) { + cl_object aux = x; + x = y; y = aux; + goto COMPLEX; + } + z11 = ecl_times(x->complex.real, y->complex.real); + z12 = ecl_times(x->complex.imag, y->complex.imag); + z21 = ecl_times(x->complex.imag, y->complex.real); + z22 = ecl_times(x->complex.real, y->complex.imag); + return ecl_make_complex(ecl_minus(z11, z12), ecl_plus(z21, z22)); + } + default: + FEwrong_type_nth_arg(@[*], 1, x, @[number]); + } } #endif diff --git a/src/c/numbers/truncate.d b/src/c/numbers/truncate.d index c6f4a9bcc..ef64e42a0 100644 --- a/src/c/numbers/truncate.d +++ b/src/c/numbers/truncate.d @@ -1,19 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - truncate.d -- Implementation of CL:TRUNCATE -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. + * truncate.d - implementation of CL:TRUNCATE + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #define ECL_INCLUDE_MATH_H #include @@ -27,63 +25,63 @@ cl_object ecl_truncate1(cl_object x) { - cl_object v0, v1; - switch (ecl_t_of(x)) { - case t_fixnum: - case t_bignum: - v0 = x; - v1 = ecl_make_fixnum(0); - break; - case t_ratio: - if (ecl_plusp(x->ratio.num)) - return ecl_floor1(x); - else - return ecl_ceiling1(x); - case t_singlefloat: { - float d = ecl_single_float(x); - float y = d > 0? floorf(d) : ceilf(d); - v0 = _ecl_float_to_integer(y); - v1 = ecl_make_single_float(d - y); - break; - } - case t_doublefloat: { - double d = ecl_double_float(x); - double y = d > 0? floor(d) : ceil(d); - v0 = _ecl_double_to_integer(y); - v1 = ecl_make_double_float(d - y); - break; - } + cl_object v0, v1; + switch (ecl_t_of(x)) { + case t_fixnum: + case t_bignum: + v0 = x; + v1 = ecl_make_fixnum(0); + break; + case t_ratio: + if (ecl_plusp(x->ratio.num)) + return ecl_floor1(x); + else + return ecl_ceiling1(x); + case t_singlefloat: { + float d = ecl_single_float(x); + float y = d > 0? floorf(d) : ceilf(d); + v0 = _ecl_float_to_integer(y); + v1 = ecl_make_single_float(d - y); + break; + } + case t_doublefloat: { + double d = ecl_double_float(x); + double y = d > 0? floor(d) : ceil(d); + v0 = _ecl_double_to_integer(y); + v1 = ecl_make_double_float(d - y); + break; + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - long double d = ecl_long_float(x); - long double y = d > 0? floorl(d) : ceill(d); - v0 = _ecl_long_double_to_integer(y); - v1 = ecl_make_long_float(d - y); - break; - } + case t_longfloat: { + long double d = ecl_long_float(x); + long double y = d > 0? floorl(d) : ceill(d); + v0 = _ecl_long_double_to_integer(y); + v1 = ecl_make_long_float(d - y); + break; + } #endif - default: - FEwrong_type_nth_arg(@[truncate],1,x,@[real]); - } - { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return2(the_env, v0, v1); - } + default: + FEwrong_type_nth_arg(@[truncate],1,x,@[real]); + } + { + const cl_env_ptr the_env = ecl_process_env(); + ecl_return2(the_env, v0, v1); + } } cl_object ecl_truncate2(cl_object x, cl_object y) { - if (ecl_plusp(x) != ecl_plusp(y)) - return ecl_ceiling2(x, y); - else - return ecl_floor2(x, y); + if (ecl_plusp(x) != ecl_plusp(y)) + return ecl_ceiling2(x, y); + else + return ecl_floor2(x, y); } @(defun truncate (x &optional (y OBJNULL)) -@ - if (narg == 1) - return ecl_truncate1(x); - else - return ecl_truncate2(x, y); -@) + @ + if (narg == 1) + return ecl_truncate1(x); + else + return ecl_truncate2(x, y); + @) diff --git a/src/c/numbers/zerop.d b/src/c/numbers/zerop.d index 3ae4a3e06..bbdcce391 100644 --- a/src/c/numbers/zerop.d +++ b/src/c/numbers/zerop.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - zerop.d -- Implementation of CL:ZEROP -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * zerop.d - implementation of CL:ZEROP + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ #include #include @@ -23,44 +19,44 @@ cl_object cl_zerop(cl_object x) { /* INV: ecl_zerop() checks type */ - @(return (ecl_zerop(x) ? ECL_T : ECL_NIL)) + @(return (ecl_zerop(x) ? ECL_T : ECL_NIL)); } static int ecl_zerop_fixnum(cl_object x) { - return x == ecl_make_fixnum(0); + return x == ecl_make_fixnum(0); } static int ecl_zerop_ratio(cl_object x) { - return 0; + return 0; } static int ecl_zerop_single_float(cl_object x) { - return ecl_single_float(x) == 0; + return ecl_single_float(x) == 0; } static int ecl_zerop_double_float(cl_object x) { - return ecl_double_float(x) == 0; + return ecl_double_float(x) == 0; } #ifdef ECL_LONG_FLOAT static int ecl_zerop_long_float(cl_object x) { - return ecl_long_float(x) == 0; + return ecl_long_float(x) == 0; } #endif static int ecl_zerop_complex(cl_object x) { - return ecl_zerop(x->complex.real) && ecl_zerop(x->complex.imag); + return ecl_zerop(x->complex.real) && ecl_zerop(x->complex.imag); } MATH_DEF_DISPATCH1_BOOL(zerop, @[zerop], @[number], diff --git a/src/c/package.d b/src/c/package.d index 116922acd..51efa524c 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - package.d -- Packages. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * package.d - packages + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -41,38 +36,38 @@ static cl_object find_symbol_inner(cl_object name, cl_object p, int *intern_flag static void FEpackage_error(const char *message, cl_object package, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(6, - @'package-error', - ECL_NIL, /* not correctable */ - make_constant_base_string(message), /* format control */ - narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */ - @':package', package); /* extra arguments */ + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(6, + @'package-error', + ECL_NIL, /* not correctable */ + make_constant_base_string(message), /* format control */ + narg? cl_grab_rest_args(args) : cl_list(1,package), /* format args */ + @':package', package); /* extra arguments */ } void CEpackage_error(const char *message, const char *continue_message, cl_object package, int narg, ...) { - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - si_signal_simple_error(6, - @'package-error', - make_constant_base_string(continue_message), - make_constant_base_string(message), /* format control */ - narg? cl_grab_rest_args(args) : cl_list(1,package), - @':package', package); + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + si_signal_simple_error(6, + @'package-error', + make_constant_base_string(continue_message), + make_constant_base_string(message), /* format control */ + narg? cl_grab_rest_args(args) : cl_list(1,package), + @':package', package); } static bool member_string_eq(cl_object x, cl_object l) { - /* INV: l is a proper list */ - loop_for_on_unsafe(l) { - if (ecl_string_eq(x, ECL_CONS_CAR(l))) - return TRUE; - } end_loop_for_on_unsafe(l); - return FALSE; + /* INV: l is a proper list */ + loop_for_on_unsafe(l) { + if (ecl_string_eq(x, ECL_CONS_CAR(l))) + return TRUE; + } end_loop_for_on_unsafe(l); + return FALSE; } #if defined(__cplusplus) || (defined(__GNUC__) && !defined(__STRICT_ANSI__)) @@ -84,1025 +79,1031 @@ member_string_eq(cl_object x, cl_object l) static INLINE void symbol_remove_package(cl_object s, cl_object p) { - if (Null(s)) - s = ECL_NIL_SYMBOL; - if (s->symbol.hpack == p) - s->symbol.hpack = ECL_NIL; + if (Null(s)) + s = ECL_NIL_SYMBOL; + if (s->symbol.hpack == p) + s->symbol.hpack = ECL_NIL; } static INLINE void symbol_add_package(cl_object s, cl_object p) { - if (Null(s)) - s = ECL_NIL_SYMBOL; - if (s->symbol.hpack == ECL_NIL) - s->symbol.hpack = p; + if (Null(s)) + s = ECL_NIL_SYMBOL; + if (s->symbol.hpack == ECL_NIL) + s->symbol.hpack = p; } /* - ecl_make_package(n, ns, ul) makes a package with name n, - which must be a string or a symbol, - and nicknames ns, which must be a list of strings or symbols, - and uses packages in list ul, which must be a list of packages - or package names i.e. strings or symbols. + ecl_make_package(n, ns, ul) makes a package with name n, + which must be a string or a symbol, + and nicknames ns, which must be a list of strings or symbols, + and uses packages in list ul, which must be a list of packages + or package names i.e. strings or symbols. */ static cl_object make_package_hashtable() { - return cl__make_hash_table(@'package', /* package hash table */ - ecl_make_fixnum(128), /* initial size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + return cl__make_hash_table(@'package', /* package hash table */ + ecl_make_fixnum(128), /* initial size */ + cl_core.rehash_size, + cl_core.rehash_threshold); } static cl_object alloc_package(cl_object name) { - cl_object p = ecl_alloc_object(t_package); - p->pack.internal = make_package_hashtable(); - p->pack.external = make_package_hashtable(); - p->pack.name = name; - p->pack.nicknames = ECL_NIL; - p->pack.shadowings = ECL_NIL; - p->pack.uses = ECL_NIL; - p->pack.usedby = ECL_NIL; - p->pack.locked = FALSE; - return p; + cl_object p = ecl_alloc_object(t_package); + p->pack.internal = make_package_hashtable(); + p->pack.external = make_package_hashtable(); + p->pack.name = name; + p->pack.nicknames = ECL_NIL; + p->pack.shadowings = ECL_NIL; + p->pack.uses = ECL_NIL; + p->pack.usedby = ECL_NIL; + p->pack.locked = FALSE; + return p; } cl_object _ecl_package_to_be_created(const cl_env_ptr env, cl_object name) { - cl_object package = ecl_assoc(name, env->packages_to_be_created); - if (Null(package)) { - const cl_env_ptr env = ecl_process_env(); - package = alloc_package(name); - env->packages_to_be_created = - cl_acons(name, package, env->packages_to_be_created); - } else { - package = ECL_CONS_CDR(package); - } - return package; + cl_object package = ecl_assoc(name, env->packages_to_be_created); + if (Null(package)) { + const cl_env_ptr env = ecl_process_env(); + package = alloc_package(name); + env->packages_to_be_created = + cl_acons(name, package, env->packages_to_be_created); + } else { + package = ECL_CONS_CDR(package); + } + return package; } static cl_object find_pending_package(cl_env_ptr env, cl_object name, cl_object nicknames) { - if (ecl_option_values[ECL_OPT_BOOTED]) { - cl_object l = env->packages_to_be_created; - while (!Null(l)) { - cl_object pair = ECL_CONS_CAR(l); - cl_object other_name = ECL_CONS_CAR(pair); - if (ecl_equal(other_name, name) || - _ecl_funcall5(@'member', other_name, nicknames, - @':test', @'string=') != ECL_NIL) - { - cl_object x = ECL_CONS_CDR(pair); - env->packages_to_be_created = - ecl_remove_eq(pair, - env->packages_to_be_created); - return x; - } - l = ECL_CONS_CDR(l); - } + if (ecl_option_values[ECL_OPT_BOOTED]) { + cl_object l = env->packages_to_be_created; + while (!Null(l)) { + cl_object pair = ECL_CONS_CAR(l); + cl_object other_name = ECL_CONS_CAR(pair); + if (ecl_equal(other_name, name) || + _ecl_funcall5(@'member', other_name, nicknames, + @':test', @'string=') != ECL_NIL) + { + cl_object x = ECL_CONS_CDR(pair); + env->packages_to_be_created = + ecl_remove_eq(pair, + env->packages_to_be_created); + return x; } - return ECL_NIL; + l = ECL_CONS_CDR(l); + } + } + return ECL_NIL; } static cl_object process_nicknames(cl_object nicknames) { - cl_object l; - nicknames = cl_copy_list(nicknames); - for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) - ECL_RPLACA(l, cl_string(ECL_CONS_CAR(l))); - return nicknames; + cl_object l; + nicknames = cl_copy_list(nicknames); + for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) + ECL_RPLACA(l, cl_string(ECL_CONS_CAR(l))); + return nicknames; } static cl_object process_package_list(cl_object packages) { - cl_object l; - packages = cl_copy_list(packages); - for (l = packages; l != ECL_NIL; l = ECL_CONS_CDR(l)) - ECL_RPLACA(l, si_coerce_to_package(ECL_CONS_CAR(l))); - return packages; + cl_object l; + packages = cl_copy_list(packages); + for (l = packages; l != ECL_NIL; l = ECL_CONS_CDR(l)) + ECL_RPLACA(l, si_coerce_to_package(ECL_CONS_CAR(l))); + return packages; } cl_object ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) { - const cl_env_ptr env = ecl_process_env(); - cl_object x, other = ECL_NIL; + const cl_env_ptr env = ecl_process_env(); + cl_object x, other = ECL_NIL; - /* Type checking, coercions, and the like, happen before we - * acquire the lock */ - name = cl_string(name); - nicknames = process_nicknames(nicknames); - use_list = process_package_list(use_list); + /* Type checking, coercions, and the like, happen before we + * acquire the lock */ + name = cl_string(name); + nicknames = process_nicknames(nicknames); + use_list = process_package_list(use_list); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) { - /* Find a similarly named package in the list of - * packages to be created and use it or try to build a - * new package */ - x = find_pending_package(env, name, nicknames); - if (Null(x)) { - other = ecl_find_package_nolock(name); - if (other != ECL_NIL) { - goto OUTPUT; - } else { - x = alloc_package(name); - } - } - loop_for_in(nicknames) { - cl_object nick = ECL_CONS_CAR(nicknames); - other = ecl_find_package_nolock(nick); - if (other != ECL_NIL) { - name = nick; - goto OUTPUT; - } - x->pack.nicknames = CONS(nick, x->pack.nicknames); - } end_loop_for_in; - loop_for_in(use_list) { - cl_object y = ECL_CONS_CAR(use_list); - x->pack.uses = CONS(y, x->pack.uses); - y->pack.usedby = CONS(x, y->pack.usedby); - } end_loop_for_in; - /* Finally, add it to the list of packages */ - cl_core.packages = CONS(x, cl_core.packages); - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (!Null(other)) { - CEpackage_error("A package with the name ~A already exists.", - "Return existing package", - other, 1, name); - return other; - } - return x; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) { + /* Find a similarly named package in the list of + * packages to be created and use it or try to build a + * new package */ + x = find_pending_package(env, name, nicknames); + if (Null(x)) { + other = ecl_find_package_nolock(name); + if (other != ECL_NIL) { + goto OUTPUT; + } else { + x = alloc_package(name); + } + } + loop_for_in(nicknames) { + cl_object nick = ECL_CONS_CAR(nicknames); + other = ecl_find_package_nolock(nick); + if (other != ECL_NIL) { + name = nick; + goto OUTPUT; + } + x->pack.nicknames = CONS(nick, x->pack.nicknames); + } end_loop_for_in; + loop_for_in(use_list) { + cl_object y = ECL_CONS_CAR(use_list); + x->pack.uses = CONS(y, x->pack.uses); + y->pack.usedby = CONS(x, y->pack.usedby); + } end_loop_for_in; + /* Finally, add it to the list of packages */ + cl_core.packages = CONS(x, cl_core.packages); + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (!Null(other)) { + CEpackage_error("A package with the name ~A already exists.", + "Return existing package", + other, 1, name); + return other; + } + return x; } cl_object ecl_rename_package(cl_object x, cl_object name, cl_object nicknames) { - bool error; + bool error; - name = cl_string(name); - nicknames = process_nicknames(nicknames); - x = si_coerce_to_package(x); - if (x->pack.locked) { - CEpackage_error("Cannot rename locked package ~S.", - "Ignore lock and proceed", x, 0); - } - nicknames = ecl_cons(name, nicknames); - error = 0; - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object l; - for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object nick = ECL_CONS_CAR(l); - cl_object p = ecl_find_package_nolock(nick); - if ((p != ECL_NIL) && (p != x)) { - name = nick; - error = 1; - break; - } - } - if (!error) { - x->pack.name = name; - x->pack.nicknames = ECL_CONS_CDR(nicknames); - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - FEpackage_error("A package with name ~S already exists.", x, - 1, name); - } - return x; + name = cl_string(name); + nicknames = process_nicknames(nicknames); + x = si_coerce_to_package(x); + if (x->pack.locked) { + CEpackage_error("Cannot rename locked package ~S.", + "Ignore lock and proceed", x, 0); + } + nicknames = ecl_cons(name, nicknames); + error = 0; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object l; + for (l = nicknames; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object nick = ECL_CONS_CAR(l); + cl_object p = ecl_find_package_nolock(nick); + if ((p != ECL_NIL) && (p != x)) { + name = nick; + error = 1; + break; + } + } + if (!error) { + x->pack.name = name; + x->pack.nicknames = ECL_CONS_CDR(nicknames); + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + FEpackage_error("A package with name ~S already exists.", x, + 1, name); + } + return x; } /* - ecl_find_package_nolock(n) seaches for a package with name n, where n is - a valid string designator, or simply outputs n if it is a - package. + ecl_find_package_nolock(n) seaches for a package with name n, where n is + a valid string designator, or simply outputs n if it is a + package. - This is not a locking routine and someone may replace the list of - packages while we are scanning it. Nevertheless, the list IS NOT - be destructively modified, which means that we are on the safe side. - Routines which need to ensure that the package list remains constant - should enforce a global lock with PACKAGE_OP_LOCK(). + This is not a locking routine and someone may replace the list of + packages while we are scanning it. Nevertheless, the list IS NOT + be destructively modified, which means that we are on the safe side. + Routines which need to ensure that the package list remains constant + should enforce a global lock with PACKAGE_OP_LOCK(). */ cl_object ecl_find_package_nolock(cl_object name) { - cl_object l, p; + cl_object l, p; - if (ECL_PACKAGEP(name)) - return name; - name = cl_string(name); - l = cl_core.packages; - loop_for_on_unsafe(l) { - p = ECL_CONS_CAR(l); - if (ecl_string_eq(name, p->pack.name)) - return p; - if (member_string_eq(name, p->pack.nicknames)) - return p; - } end_loop_for_on_unsafe(l); + if (ECL_PACKAGEP(name)) + return name; + name = cl_string(name); + l = cl_core.packages; + loop_for_on_unsafe(l) { + p = ECL_CONS_CAR(l); + if (ecl_string_eq(name, p->pack.name)) + return p; + if (member_string_eq(name, p->pack.nicknames)) + return p; + } end_loop_for_on_unsafe(l); #ifdef ECL_RELATIVE_PACKAGE_NAMES - /* Note that this function may actually be called _before_ symbols are set up - * are bound! */ - if (ecl_option_values[ECL_OPT_BOOTED] && - ECL_SYM_VAL(ecl_process_env(), @'si::*relative-package-names*') != ECL_NIL) { - return si_find_relative_package(1, name); - } + /* Note that this function may actually be called _before_ symbols are set up + * are bound! */ + if (ecl_option_values[ECL_OPT_BOOTED] && + ECL_SYM_VAL(ecl_process_env(), @'si::*relative-package-names*') != ECL_NIL) { + return si_find_relative_package(1, name); + } #endif - return ECL_NIL; + return ECL_NIL; } cl_object ecl_find_package(const char *p) { - ecl_def_ct_base_string(pack_name,p,strlen(p),,); - return cl_find_package(pack_name); + ecl_def_ct_base_string(pack_name,p,strlen(p),,); + return cl_find_package(pack_name); } cl_object si_coerce_to_package(cl_object p) { - /* INV: ecl_find_package_nolock() signals an error if "p" is neither a package - nor a string */ - cl_object pp = ecl_find_package_nolock(p); - if (Null(pp)) { - FEpackage_error("There exists no package with name ~S", p, 0); - } - @(return pp); + /* INV: ecl_find_package_nolock() signals an error if "p" is neither a package + nor a string */ + cl_object pp = ecl_find_package_nolock(p); + if (Null(pp)) { + FEpackage_error("There exists no package with name ~S", p, 0); + } + @(return pp); } cl_object ecl_current_package(void) { - cl_object x = ecl_symbol_value(@'*package*'); - unlikely_if (!ECL_PACKAGEP(x)) { - const cl_env_ptr env = ecl_process_env(); - ECL_SETQ(env, @'*package*', cl_core.user_package); - FEerror("The value of *PACKAGE*, ~S, was not a package", - 1, x); - } - return x; + cl_object x = ecl_symbol_value(@'*package*'); + unlikely_if (!ECL_PACKAGEP(x)) { + const cl_env_ptr env = ecl_process_env(); + ECL_SETQ(env, @'*package*', cl_core.user_package); + FEerror("The value of *PACKAGE*, ~S, was not a package", + 1, x); + } + return x; } /* - Ecl_Intern(st, p) interns string st in package p. + Ecl_Intern(st, p) interns string st in package p. */ cl_object _ecl_intern(const char *s, cl_object p) { - int intern_flag; - cl_object str = make_constant_base_string(s); - return ecl_intern(str, p, &intern_flag); + int intern_flag; + cl_object str = make_constant_base_string(s); + return ecl_intern(str, p, &intern_flag); } cl_object ecl_intern(cl_object name, cl_object p, int *intern_flag) { - cl_object s; - bool error, ignore_error = 0; + cl_object s; + bool error, ignore_error = 0; - if (ecl_unlikely(!ECL_STRINGP(name))) - FEwrong_type_nth_arg(@[intern], 1, name, @[string]); - p = si_coerce_to_package(p); + if (ecl_unlikely(!ECL_STRINGP(name))) + FEwrong_type_nth_arg(@[intern], 1, name, @[string]); + p = si_coerce_to_package(p); AGAIN: - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - s = find_symbol_inner(name, p, intern_flag); - if (*intern_flag) { - error = 0; - } else if (p->pack.locked && !ignore_error) { - error = 1; - } else { - s = cl_make_symbol(name); - s->symbol.hpack = p; - *intern_flag = 0; - if (p == cl_core.keyword_package) { - ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant); - ECL_SET(s, s); - p->pack.external = - _ecl_sethash(name, p->pack.external, s); - } else { - p->pack.internal = - _ecl_sethash(name, p->pack.internal, s); - } - error = 0; - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - CEpackage_error("Cannot intern symbol ~S in locked package ~S.", - "Ignore lock and proceed", p, 2, name, p); - ignore_error = 1; - goto AGAIN; - } - return s; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + s = find_symbol_inner(name, p, intern_flag); + if (*intern_flag) { + error = 0; + } else if (p->pack.locked && !ignore_error) { + error = 1; + } else { + s = cl_make_symbol(name); + s->symbol.hpack = p; + *intern_flag = 0; + if (p == cl_core.keyword_package) { + ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant); + ECL_SET(s, s); + p->pack.external = + _ecl_sethash(name, p->pack.external, s); + } else { + p->pack.internal = + _ecl_sethash(name, p->pack.internal, s); + } + error = 0; + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + CEpackage_error("Cannot intern symbol ~S in locked package ~S.", + "Ignore lock and proceed", p, 2, name, p); + ignore_error = 1; + goto AGAIN; + } + return s; } /* - find_symbol_inner(st, len, p) searches for string st of length - len in package p. + find_symbol_inner(st, len, p) searches for string st of length + len in package p. */ static cl_object find_symbol_inner(cl_object name, cl_object p, int *intern_flag) { - cl_object s, ul; + cl_object s, ul; - s = ecl_gethash_safe(name, p->pack.external, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_EXTERNAL; - goto OUTPUT; - } - if (p == cl_core.keyword_package) - goto NOTHING; - s = ecl_gethash_safe(name, p->pack.internal, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_INTERNAL; - goto OUTPUT; - } - ul = p->pack.uses; - loop_for_on_unsafe(ul) { - s = ecl_gethash_safe(name, ECL_CONS_CAR(ul)->pack.external, OBJNULL); - if (s != OBJNULL) { - *intern_flag = ECL_INHERITED; - goto OUTPUT; - } - } end_loop_for_on_unsafe(ul); + s = ecl_gethash_safe(name, p->pack.external, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_EXTERNAL; + goto OUTPUT; + } + if (p == cl_core.keyword_package) + goto NOTHING; + s = ecl_gethash_safe(name, p->pack.internal, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_INTERNAL; + goto OUTPUT; + } + ul = p->pack.uses; + loop_for_on_unsafe(ul) { + s = ecl_gethash_safe(name, ECL_CONS_CAR(ul)->pack.external, OBJNULL); + if (s != OBJNULL) { + *intern_flag = ECL_INHERITED; + goto OUTPUT; + } + } end_loop_for_on_unsafe(ul); NOTHING: - *intern_flag = 0; - s = ECL_NIL; + *intern_flag = 0; + s = ECL_NIL; OUTPUT: - return s; + return s; } cl_object ecl_find_symbol(cl_object n, cl_object p, int *intern_flag) { - cl_object s; - if (ecl_unlikely(!ECL_STRINGP(n))) - FEwrong_type_nth_arg(@[find-symbol], 1, n, @[string]); - p = si_coerce_to_package(p); - ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(ecl_process_env()) { - s = find_symbol_inner(n, p, intern_flag); - } ECL_WITH_GLOBAL_ENV_RDLOCK_END; - return s; + cl_object s; + if (ecl_unlikely(!ECL_STRINGP(n))) + FEwrong_type_nth_arg(@[find-symbol], 1, n, @[string]); + p = si_coerce_to_package(p); + ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(ecl_process_env()) { + s = find_symbol_inner(n, p, intern_flag); + } ECL_WITH_GLOBAL_ENV_RDLOCK_END; + return s; } static cl_object potential_unintern_conflict(cl_object name, cl_object s, cl_object p) { - cl_object x = OBJNULL; - cl_object l = p->pack.uses; - loop_for_on_unsafe(l) { - cl_object other_p = ECL_CONS_CAR(l); - cl_object y = ecl_gethash_safe(name, other_p->pack.external, OBJNULL); - if (y != OBJNULL) { - if (x == OBJNULL) { - x = y; - } else if (x != y) { - return ecl_cons(x, y); - } - } - } end_loop_for_on_unsafe(l); - return ECL_NIL; + cl_object x = OBJNULL; + cl_object l = p->pack.uses; + loop_for_on_unsafe(l) { + cl_object other_p = ECL_CONS_CAR(l); + cl_object y = ecl_gethash_safe(name, other_p->pack.external, OBJNULL); + if (y != OBJNULL) { + if (x == OBJNULL) { + x = y; + } else if (x != y) { + return ecl_cons(x, y); + } + } + } end_loop_for_on_unsafe(l); + return ECL_NIL; } bool ecl_unintern(cl_object s, cl_object p) { - cl_object conflict; - bool output = FALSE; - cl_object name = ecl_symbol_name(s); + cl_object conflict; + bool output = FALSE; + cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) { - CEpackage_error("Cannot unintern symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - } - conflict = ECL_NIL; - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object hash = p->pack.internal; - cl_object x = ecl_gethash_safe(name, hash, OBJNULL); - if (x != s) { - hash = p->pack.external; - x = ecl_gethash_safe(name, hash, OBJNULL); - if (x != s) - goto OUTPUT; - } - if (ecl_member_eq(s, p->pack.shadowings)) { - conflict = potential_unintern_conflict(name, s, p); - if (conflict != ECL_NIL) { - goto OUTPUT; - } - p->pack.shadowings = ecl_remove_eq(s, p->pack.shadowings); - } - ecl_remhash(name, hash); - symbol_remove_package(s, p); - output = TRUE; - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (conflict != ECL_NIL) { - FEpackage_error("Cannot unintern the shadowing symbol ~S~%" - "from ~S,~%" - "because ~S and ~S will cause~%" - "a name conflict.", p, 4, s, p, - ECL_CONS_CAR(conflict), ECL_CONS_CDR(conflict)); - } - return output; + p = si_coerce_to_package(p); + if (p->pack.locked) { + CEpackage_error("Cannot unintern symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + } + conflict = ECL_NIL; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object hash = p->pack.internal; + cl_object x = ecl_gethash_safe(name, hash, OBJNULL); + if (x != s) { + hash = p->pack.external; + x = ecl_gethash_safe(name, hash, OBJNULL); + if (x != s) + goto OUTPUT; + } + if (ecl_member_eq(s, p->pack.shadowings)) { + conflict = potential_unintern_conflict(name, s, p); + if (conflict != ECL_NIL) { + goto OUTPUT; + } + p->pack.shadowings = ecl_remove_eq(s, p->pack.shadowings); + } + ecl_remhash(name, hash); + symbol_remove_package(s, p); + output = TRUE; + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (conflict != ECL_NIL) { + FEpackage_error("Cannot unintern the shadowing symbol ~S~%" + "from ~S,~%" + "because ~S and ~S will cause~%" + "a name conflict.", p, 4, s, p, + ECL_CONS_CAR(conflict), ECL_CONS_CDR(conflict)); + } + return output; } static cl_object potential_export_conflict(cl_object name, cl_object s, cl_object p) { - cl_object l = p->pack.usedby; - loop_for_on_unsafe(l) { - int intern_flag; - cl_object other_p = ECL_CONS_CAR(l); - cl_object x = find_symbol_inner(name, other_p, &intern_flag); - if (intern_flag && s != x && - !ecl_member_eq(x, other_p->pack.shadowings)) { - return other_p; - } - } end_loop_for_on_unsafe(l); - return ECL_NIL; + cl_object l = p->pack.usedby; + loop_for_on_unsafe(l) { + int intern_flag; + cl_object other_p = ECL_CONS_CAR(l); + cl_object x = find_symbol_inner(name, other_p, &intern_flag); + if (intern_flag && s != x && + !ecl_member_eq(x, other_p->pack.shadowings)) { + return other_p; + } + } end_loop_for_on_unsafe(l); + return ECL_NIL; } void cl_export2(cl_object s, cl_object p) { - int intern_flag, error; - cl_object other_p, name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot export symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); + int intern_flag, error; + cl_object other_p, name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot export symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); AGAIN: - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object x = find_symbol_inner(name, p, &intern_flag); - if (!intern_flag) { - error = 1; - } else if (x != s) { - error = 2; - } else if (intern_flag == ECL_EXTERNAL) { - error = 0; - } else if ((other_p = potential_export_conflict(name, s, p)) != ECL_NIL) { - error = 3; - } else { - if (intern_flag == ECL_INTERNAL) - ecl_remhash(name, p->pack.internal); - p->pack.external = _ecl_sethash(name, p->pack.external, s); - error = 0; - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error == 1) { - CEpackage_error("The symbol ~S is not accessible from ~S " - "and cannot be exported.", - "Import the symbol in the package and proceed.", - p, 2, s, p); - cl_import2(s, p); - goto AGAIN; - } else if (error == 2) { - FEpackage_error("Cannot export the symbol ~S from ~S,~%" - "because there is already a symbol with the same name~%" - "in the package.", p, 2, s, p); - } else if (error == 3) { - FEpackage_error("Cannot export the symbol ~S~%" - "from ~S,~%" - "because it will cause a name conflict~%" - "in ~S.", p, 3, s, p, other_p); - } + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object x = find_symbol_inner(name, p, &intern_flag); + if (!intern_flag) { + error = 1; + } else if (x != s) { + error = 2; + } else if (intern_flag == ECL_EXTERNAL) { + error = 0; + } else if ((other_p = potential_export_conflict(name, s, p)) != ECL_NIL) { + error = 3; + } else { + if (intern_flag == ECL_INTERNAL) + ecl_remhash(name, p->pack.internal); + p->pack.external = _ecl_sethash(name, p->pack.external, s); + error = 0; + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error == 1) { + CEpackage_error("The symbol ~S is not accessible from ~S " + "and cannot be exported.", + "Import the symbol in the package and proceed.", + p, 2, s, p); + cl_import2(s, p); + goto AGAIN; + } else if (error == 2) { + FEpackage_error("Cannot export the symbol ~S from ~S,~%" + "because there is already a symbol with the same name~%" + "in the package.", p, 2, s, p); + } else if (error == 3) { + FEpackage_error("Cannot export the symbol ~S~%" + "from ~S,~%" + "because it will cause a name conflict~%" + "in ~S.", p, 3, s, p, other_p); + } } cl_object cl_delete_package(cl_object p) { - cl_object hash, l; - cl_index i; + cl_object hash, l; + cl_index i; - /* 1) Try to remove the package from the global list */ - p = ecl_find_package_nolock(p); - if (Null(p)) { - CEpackage_error("Package ~S not found. Cannot delete it.", - "Ignore error and continue", p, 0); - @(return ECL_NIL); - } - if (p->pack.locked) - CEpackage_error("Cannot delete locked package ~S.", - "Ignore lock and proceed", p, 0); - if (p == cl_core.lisp_package || p == cl_core.keyword_package) { - FEpackage_error("Cannot remove package ~S", p, 0); - } + /* 1) Try to remove the package from the global list */ + p = ecl_find_package_nolock(p); + if (Null(p)) { + CEpackage_error("Package ~S not found. Cannot delete it.", + "Ignore error and continue", p, 0); + @(return ECL_NIL); + } + if (p->pack.locked) + CEpackage_error("Cannot delete locked package ~S.", + "Ignore lock and proceed", p, 0); + if (p == cl_core.lisp_package || p == cl_core.keyword_package) { + FEpackage_error("Cannot remove package ~S", p, 0); + } - /* 2) Now remove the package from the other packages that use it - * and empty the package. - */ - if (Null(p->pack.name)) { - @(return ECL_NIL) - } - while (!Null(l = p->pack.uses)) { - ecl_unuse_package(ECL_CONS_CAR(l), p); - } - while (!Null(l = p->pack.usedby)) { - ecl_unuse_package(p, ECL_CONS_CAR(l)); - } + /* 2) Now remove the package from the other packages that use it + * and empty the package. + */ + if (Null(p->pack.name)) { + @(return ECL_NIL); + } + while (!Null(l = p->pack.uses)) { + ecl_unuse_package(ECL_CONS_CAR(l), p); + } + while (!Null(l = p->pack.usedby)) { + ecl_unuse_package(p, ECL_CONS_CAR(l)); + } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++) - if (hash->hash.data[i].key != OBJNULL) { - cl_object s = hash->hash.data[i].value; - symbol_remove_package(s, p); - } - cl_clrhash(p->pack.internal); - for (hash = p->pack.external, i = 0; i < hash->hash.size; i++) - if (hash->hash.data[i].key != OBJNULL) { - cl_object s = hash->hash.data[i].value; - symbol_remove_package(s, p); - } - cl_clrhash(p->pack.external); - p->pack.shadowings = ECL_NIL; - p->pack.name = ECL_NIL; - /* 2) Only at the end, remove the package from the list of packages. */ - cl_core.packages = ecl_remove_eq(p, cl_core.packages); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return ECL_T) + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++) + if (hash->hash.data[i].key != OBJNULL) { + cl_object s = hash->hash.data[i].value; + symbol_remove_package(s, p); + } + cl_clrhash(p->pack.internal); + for (hash = p->pack.external, i = 0; i < hash->hash.size; i++) + if (hash->hash.data[i].key != OBJNULL) { + cl_object s = hash->hash.data[i].value; + symbol_remove_package(s, p); + } + cl_clrhash(p->pack.external); + p->pack.shadowings = ECL_NIL; + p->pack.name = ECL_NIL; + /* 2) Only at the end, remove the package from the list of packages. */ + cl_core.packages = ecl_remove_eq(p, cl_core.packages); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + @(return ECL_T); } void cl_unexport2(cl_object s, cl_object p) { - cl_object name = ecl_symbol_name(s); - bool error; - p = si_coerce_to_package(p); - if (p == cl_core.keyword_package) { - FEpackage_error("Cannot unexport a symbol from the keyword package.", - cl_core.keyword_package, 0); - } - if (p->pack.locked) { - CEpackage_error("Cannot unexport symbol ~S from locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - int intern_flag; - cl_object x = find_symbol_inner(name, p, &intern_flag); - if (intern_flag == 0 || x != s) { - error = 1; - } else if (intern_flag != ECL_EXTERNAL) { - /* According to ANSI & Cltl, internal symbols are - ignored in unexport */ - error = 0; - } else { - ecl_remhash(name, p->pack.external); - p->pack.internal = _ecl_sethash(name, p->pack.internal, s); - error = 0; - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - FEpackage_error("Cannot unexport ~S because it does not " - "belong to package ~S.", - p, 2, s, p); - } + cl_object name = ecl_symbol_name(s); + bool error; + p = si_coerce_to_package(p); + if (p == cl_core.keyword_package) { + FEpackage_error("Cannot unexport a symbol from the keyword package.", + cl_core.keyword_package, 0); + } + if (p->pack.locked) { + CEpackage_error("Cannot unexport symbol ~S from locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + } + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + int intern_flag; + cl_object x = find_symbol_inner(name, p, &intern_flag); + if (intern_flag == 0 || x != s) { + error = 1; + } else if (intern_flag != ECL_EXTERNAL) { + /* According to ANSI & Cltl, internal symbols are + ignored in unexport */ + error = 0; + } else { + ecl_remhash(name, p->pack.external); + p->pack.internal = _ecl_sethash(name, p->pack.internal, s); + error = 0; + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + FEpackage_error("Cannot unexport ~S because it does not " + "belong to package ~S.", + p, 2, s, p); + } } void cl_import2(cl_object s, cl_object p) { - int intern_flag, error, ignore_error = 0; - cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) { - CEpackage_error("Cannot import symbol ~S into locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - } - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - cl_object x = find_symbol_inner(name, p, &intern_flag); - if (intern_flag) { - if (x != s && !ignore_error) { - error = 1; - goto OUTPUT; - } - if (intern_flag == ECL_INTERNAL || intern_flag == ECL_EXTERNAL) { - error = 0; - goto OUTPUT; - } - } - p->pack.internal = _ecl_sethash(name, p->pack.internal, s); - symbol_add_package(s, p); - error = 0; - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - CEpackage_error("Cannot import the symbol ~S " - "from package ~A,~%" - "because there is already a symbol with the same name~%" - "in the package.", - "Ignore conflict and proceed", p, 2, s, p); - ignore_error = 1; - } + int intern_flag, error, ignore_error = 0; + cl_object name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked) { + CEpackage_error("Cannot import symbol ~S into locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + } + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + cl_object x = find_symbol_inner(name, p, &intern_flag); + if (intern_flag) { + if (x != s && !ignore_error) { + error = 1; + goto OUTPUT; + } + if (intern_flag == ECL_INTERNAL || intern_flag == ECL_EXTERNAL) { + error = 0; + goto OUTPUT; + } + } + p->pack.internal = _ecl_sethash(name, p->pack.internal, s); + symbol_add_package(s, p); + error = 0; + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + CEpackage_error("Cannot import the symbol ~S " + "from package ~A,~%" + "because there is already a symbol with the same name~%" + "in the package.", + "Ignore conflict and proceed", p, 2, s, p); + ignore_error = 1; + } } void ecl_shadowing_import(cl_object s, cl_object p) { - int intern_flag; - cl_object x; - cl_object name = ecl_symbol_name(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot shadowing-import symbol ~S into " - "locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); + int intern_flag; + cl_object x; + cl_object name = ecl_symbol_name(s); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot shadowing-import symbol ~S into " + "locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - x = find_symbol_inner(name, p, &intern_flag); - if (intern_flag && intern_flag != ECL_INHERITED) { - if (x == s) { - if (!ecl_member_eq(x, p->pack.shadowings)) - p->pack.shadowings - = CONS(x, p->pack.shadowings); - goto OUTPUT; - } - if(ecl_member_eq(x, p->pack.shadowings)) - p->pack.shadowings = - ecl_remove_eq(x, p->pack.shadowings); - if (intern_flag == ECL_INTERNAL) - ecl_remhash(name, p->pack.internal); - else - ecl_remhash(name, p->pack.external); - symbol_remove_package(x, p); - } - p->pack.shadowings = CONS(s, p->pack.shadowings); - p->pack.internal = _ecl_sethash(name, p->pack.internal, s); - OUTPUT: - (void)0; - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + x = find_symbol_inner(name, p, &intern_flag); + if (intern_flag && intern_flag != ECL_INHERITED) { + if (x == s) { + if (!ecl_member_eq(x, p->pack.shadowings)) + p->pack.shadowings + = CONS(x, p->pack.shadowings); + goto OUTPUT; + } + if(ecl_member_eq(x, p->pack.shadowings)) + p->pack.shadowings = + ecl_remove_eq(x, p->pack.shadowings); + if (intern_flag == ECL_INTERNAL) + ecl_remhash(name, p->pack.internal); + else + ecl_remhash(name, p->pack.external); + symbol_remove_package(x, p); + } + p->pack.shadowings = CONS(s, p->pack.shadowings); + p->pack.internal = _ecl_sethash(name, p->pack.internal, s); + OUTPUT: + (void)0; + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } void ecl_shadow(cl_object s, cl_object p) { - int intern_flag; - cl_object x; + int intern_flag; + cl_object x; - /* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */ - s = cl_string(s); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot shadow symbol ~S in locked package ~S.", - "Ignore lock and proceed", p, 2, s, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - x = find_symbol_inner(s, p, &intern_flag); - if (intern_flag != ECL_INTERNAL && intern_flag != ECL_EXTERNAL) { - x = cl_make_symbol(s); - p->pack.internal = _ecl_sethash(s, p->pack.internal, x); - x->symbol.hpack = p; - } - p->pack.shadowings = CONS(x, p->pack.shadowings); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + /* Contrary to CLTL, in ANSI CL, SHADOW operates on strings. */ + s = cl_string(s); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot shadow symbol ~S in locked package ~S.", + "Ignore lock and proceed", p, 2, s, p); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + x = find_symbol_inner(s, p, &intern_flag); + if (intern_flag != ECL_INTERNAL && intern_flag != ECL_EXTERNAL) { + x = cl_make_symbol(s); + p->pack.internal = _ecl_sethash(s, p->pack.internal, x); + x->symbol.hpack = p; + } + p->pack.shadowings = CONS(x, p->pack.shadowings); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } void ecl_use_package(cl_object x, cl_object p) { - struct ecl_hashtable_entry *hash_entries; - cl_index i, hash_length; - cl_object here, there, name; - int intern_flag, error = 0; + struct ecl_hashtable_entry *hash_entries; + cl_index i, hash_length; + cl_object here, there, name; + int intern_flag, error = 0; - x = si_coerce_to_package(x); - if (x == cl_core.keyword_package) - FEpackage_error("Cannot use keyword package.", - cl_core.keyword_package, 0); - p = si_coerce_to_package(p); - if (p == x) - return; - if (ecl_member_eq(x, p->pack.uses)) - return; - if (p == cl_core.keyword_package) - FEpackage_error("Cannot apply USE-PACKAGE on keyword package.", - cl_core.keyword_package, 0); - if (p->pack.locked) - CEpackage_error("Cannot use package ~S in locked package ~S.", - "Ignore lock and proceed", - p, 2, x, p); + x = si_coerce_to_package(x); + if (x == cl_core.keyword_package) + FEpackage_error("Cannot use keyword package.", + cl_core.keyword_package, 0); + p = si_coerce_to_package(p); + if (p == x) + return; + if (ecl_member_eq(x, p->pack.uses)) + return; + if (p == cl_core.keyword_package) + FEpackage_error("Cannot apply USE-PACKAGE on keyword package.", + cl_core.keyword_package, 0); + if (p->pack.locked) + CEpackage_error("Cannot use package ~S in locked package ~S.", + "Ignore lock and proceed", + p, 2, x, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - hash_entries = x->pack.external->hash.data; - hash_length = x->pack.external->hash.size; - for (i = 0, error = 0; i < hash_length; i++) { - if (hash_entries[i].key != OBJNULL) { - here = hash_entries[i].value; - name = ecl_symbol_name(here); - there = find_symbol_inner(name, p, &intern_flag); - if (intern_flag && here != there - && ! ecl_member_eq(there, p->pack.shadowings)) { - error = 1; - break; - } - } - } - if (!error) { - p->pack.uses = CONS(x, p->pack.uses); - x->pack.usedby = CONS(p, x->pack.usedby); - } - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - if (error) { - FEpackage_error("Cannot use ~S~%" - "from ~S,~%" - "because ~S and ~S will cause~%" - "a name conflict.", p, 4, x, p, here, there); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + hash_entries = x->pack.external->hash.data; + hash_length = x->pack.external->hash.size; + for (i = 0, error = 0; i < hash_length; i++) { + if (hash_entries[i].key != OBJNULL) { + here = hash_entries[i].value; + name = ecl_symbol_name(here); + there = find_symbol_inner(name, p, &intern_flag); + if (intern_flag && here != there + && ! ecl_member_eq(there, p->pack.shadowings)) { + error = 1; + break; } + } + } + if (!error) { + p->pack.uses = CONS(x, p->pack.uses); + x->pack.usedby = CONS(p, x->pack.usedby); + } + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + if (error) { + FEpackage_error("Cannot use ~S~%" + "from ~S,~%" + "because ~S and ~S will cause~%" + "a name conflict.", p, 4, x, p, here, there); + } } void ecl_unuse_package(cl_object x, cl_object p) { - x = si_coerce_to_package(x); - p = si_coerce_to_package(p); - if (p->pack.locked) - CEpackage_error("Cannot unuse package ~S from locked package ~S.", - "Ignore lock and proceed", - p, 2, x, p); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { - p->pack.uses = ecl_remove_eq(x, p->pack.uses); - x->pack.usedby = ecl_remove_eq(p, x->pack.usedby); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + x = si_coerce_to_package(x); + p = si_coerce_to_package(p); + if (p->pack.locked) + CEpackage_error("Cannot unuse package ~S from locked package ~S.", + "Ignore lock and proceed", + p, 2, x, p); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(ecl_process_env()) { + p->pack.uses = ecl_remove_eq(x, p->pack.uses); + x->pack.usedby = ecl_remove_eq(p, x->pack.usedby); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; } @(defun make_package (pack_name &key nicknames (use CONS(cl_core.lisp_package, ECL_NIL))) @ - /* INV: ecl_make_package() performs type checking */ - @(return ecl_make_package(pack_name, nicknames, use)) + /* INV: ecl_make_package() performs type checking */ + @(return ecl_make_package(pack_name, nicknames, use)); @) cl_object si_select_package(cl_object pack_name) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object p = si_coerce_to_package(pack_name); - ecl_return1(the_env, ECL_SETQ(the_env, @'*package*', p)); + const cl_env_ptr the_env = ecl_process_env(); + cl_object p = si_coerce_to_package(pack_name); + ecl_return1(the_env, ECL_SETQ(the_env, @'*package*', p)); } cl_object cl_find_package(cl_object p) { - @(return ecl_find_package_nolock(p)) + @(return ecl_find_package_nolock(p)); } cl_object cl_package_name(cl_object p) { - /* FIXME: name should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.name) + /* FIXME: name should be a fresh one */ + p = si_coerce_to_package(p); + @(return p->pack.name); } cl_object cl_package_nicknames(cl_object p) { - /* FIXME: list should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.nicknames) + /* FIXME: list should be a fresh one */ + p = si_coerce_to_package(p); + @(return p->pack.nicknames); } @(defun rename_package (pack new_name &o new_nicknames) @ - /* INV: ecl_rename_package() type checks and coerces pack to package */ - @(return ecl_rename_package(pack, new_name, new_nicknames)) + /* INV: ecl_rename_package() type checks and coerces pack to package */ + @(return ecl_rename_package(pack, new_name, new_nicknames)); @) cl_object cl_package_use_list(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.uses); + return cl_copy_list(si_coerce_to_package(p)->pack.uses); } cl_object cl_package_used_by_list(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.usedby); + return cl_copy_list(si_coerce_to_package(p)->pack.usedby); } cl_object cl_package_shadowing_symbols(cl_object p) { - return cl_copy_list(si_coerce_to_package(p)->pack.shadowings); + return cl_copy_list(si_coerce_to_package(p)->pack.shadowings); } cl_object si_package_lock(cl_object p, cl_object t) { - bool previous; - p = si_coerce_to_package(p); - previous = p->pack.locked; - p->pack.locked = (t != ECL_NIL); - @(return (previous? ECL_T : ECL_NIL)) + bool previous; + p = si_coerce_to_package(p); + previous = p->pack.locked; + p->pack.locked = (t != ECL_NIL); + @(return (previous? ECL_T : ECL_NIL)); } cl_object cl_list_all_packages() { - return cl_copy_list(cl_core.packages); + return cl_copy_list(cl_core.packages); } @(defun intern (strng &optional (p ecl_current_package()) &aux sym) - int intern_flag; + int intern_flag; @ - sym = ecl_intern(strng, p, &intern_flag); - if (intern_flag == ECL_INTERNAL) - @(return sym @':internal') - if (intern_flag == ECL_EXTERNAL) - @(return sym @':external') - if (intern_flag == ECL_INHERITED) - @(return sym @':inherited') - @(return sym ECL_NIL) + sym = ecl_intern(strng, p, &intern_flag); + if (intern_flag == ECL_INTERNAL) { + @(return sym @':internal'); + } + if (intern_flag == ECL_EXTERNAL) { + @(return sym @':external'); + } + if (intern_flag == ECL_INHERITED) { + @(return sym @':inherited'); + } + @(return sym ECL_NIL); @) @(defun find_symbol (strng &optional (p ecl_current_package())) - cl_object x; - int intern_flag; + cl_object x; + int intern_flag; @ - x = ecl_find_symbol(strng, p, &intern_flag); - if (intern_flag == ECL_INTERNAL) - @(return x @':internal') - if (intern_flag == ECL_EXTERNAL) - @(return x @':external') - if (intern_flag == ECL_INHERITED) - @(return x @':inherited') - @(return ECL_NIL ECL_NIL) + x = ecl_find_symbol(strng, p, &intern_flag); + if (intern_flag == ECL_INTERNAL) { + @(return x @':internal'); + } + if (intern_flag == ECL_EXTERNAL) { + @(return x @':external'); + } + if (intern_flag == ECL_INHERITED) { + @(return x @':inherited'); + } + @(return ECL_NIL ECL_NIL); @) @(defun unintern (symbl &optional (p ecl_current_package())) @ - @(return (ecl_unintern(symbl, p) ? ECL_T : ECL_NIL)) + @(return (ecl_unintern(symbl, p) ? ECL_T : ECL_NIL)); @) @(defun export (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_export2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_export2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[export],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_export2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_export2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[export],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun unexport (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_unexport2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_unexport2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[unexport],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_unexport2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_unexport2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[unexport],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun import (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - cl_import2(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - cl_import2(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[import],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + cl_import2(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + cl_import2(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[import],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun shadowing_import (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { - case t_symbol: - ecl_shadowing_import(symbols, pack); - break; - case t_list: - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - ecl_shadowing_import(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[shadowing-import],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + switch (ecl_t_of(symbols)) { + case t_symbol: + ecl_shadowing_import(symbols, pack); + break; + case t_list: + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + ecl_shadowing_import(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[shadowing-import],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun shadow (symbols &o (pack ecl_current_package())) @ - switch (ecl_t_of(symbols)) { + switch (ecl_t_of(symbols)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_symbol: - case t_character: - /* Arguments to SHADOW may be: string designators ... */ - ecl_shadow(symbols, pack); - break; - case t_list: - /* ... or lists of string designators */ - pack = si_coerce_to_package(pack); - loop_for_in(symbols) { - ecl_shadow(ECL_CONS_CAR(symbols), pack); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[shadow],1,symbols, - cl_list(3,@'or',@'symbol',@'list')); - } - @(return ECL_T) + case t_base_string: + case t_symbol: + case t_character: + /* Arguments to SHADOW may be: string designators ... */ + ecl_shadow(symbols, pack); + break; + case t_list: + /* ... or lists of string designators */ + pack = si_coerce_to_package(pack); + loop_for_in(symbols) { + ecl_shadow(ECL_CONS_CAR(symbols), pack); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[shadow],1,symbols, + cl_list(3,@'or',@'symbol',@'list')); + } + @(return ECL_T); @) @(defun use_package (pack &o (pa ecl_current_package())) @ - switch (ecl_t_of(pack)) { - case t_symbol: - case t_character: - case t_base_string: + switch (ecl_t_of(pack)) { + case t_symbol: + case t_character: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_package: - ecl_use_package(pack, pa); - break; - case t_list: - pa = si_coerce_to_package(pa); - loop_for_in(pack) { - ecl_use_package(ECL_CONS_CAR(pack), pa); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[use-package], 1, pack, - ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); - } - @(return ECL_T) + case t_package: + ecl_use_package(pack, pa); + break; + case t_list: + pa = si_coerce_to_package(pa); + loop_for_in(pack) { + ecl_use_package(ECL_CONS_CAR(pack), pa); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[use-package], 1, pack, + ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); + } + @(return ECL_T); @) @(defun unuse_package (pack &o (pa ecl_current_package())) @ - switch (ecl_t_of(pack)) { - case t_symbol: - case t_character: - case t_base_string: + switch (ecl_t_of(pack)) { + case t_symbol: + case t_character: + case t_base_string: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_package: - ecl_unuse_package(pack, pa); - break; - case t_list: - pa = si_coerce_to_package(pa); - loop_for_in(pack) { - ecl_unuse_package(ECL_CONS_CAR(pack), pa); - } end_loop_for_in; - break; - default: - FEwrong_type_nth_arg(@[unuse-package], 1, pack, - ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); - } - @(return ECL_T) + case t_package: + ecl_unuse_package(pack, pa); + break; + case t_list: + pa = si_coerce_to_package(pa); + loop_for_in(pack) { + ecl_unuse_package(ECL_CONS_CAR(pack), pa); + } end_loop_for_in; + break; + default: + FEwrong_type_nth_arg(@[unuse-package], 1, pack, + ecl_read_from_cstring("(OR SYMBOL CHARACTER STRING LIST PACKAGE)")); + } + @(return ECL_T); @) cl_object si_package_hash_tables(cl_object p) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object he, hi, u; - unlikely_if (!ECL_PACKAGEP(p)) - FEwrong_type_only_arg(@[si::package-hash-tables], p, @[package]); - ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { - he = si_copy_hash_table(p->pack.external); - hi = si_copy_hash_table(p->pack.internal); - u = cl_copy_list(p->pack.uses); - } ECL_WITH_GLOBAL_ENV_WRLOCK_END; - @(return he hi u) + const cl_env_ptr the_env = ecl_process_env(); + cl_object he, hi, u; + unlikely_if (!ECL_PACKAGEP(p)) + FEwrong_type_only_arg(@[si::package-hash-tables], p, @[package]); + ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { + he = si_copy_hash_table(p->pack.external); + hi = si_copy_hash_table(p->pack.internal); + u = cl_copy_list(p->pack.uses); + } ECL_WITH_GLOBAL_ENV_WRLOCK_END; + @(return he hi u); } diff --git a/src/c/pathname.d b/src/c/pathname.d index 84d3d7f54..a8011a5e9 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -1,27 +1,22 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - pathname.d -- Pathnames. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - Copyright (c) 2015, Daniel KochmaÅ„ski. - - ECL 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. -*/ + * pathname.d - pathnames + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * Copyright (c) 2015 Daniel KochmaÅ„ski + * + * See file 'LICENSE' for the copyright details. + * + */ /* - O.S. DEPENDENT + O.S. DEPENDENT - This file contains those functions that interpret namestrings. + This file contains those functions that interpret namestrings. */ #include @@ -45,214 +40,214 @@ typedef int (*delim_fn)(int); static cl_object normalize_case(cl_object path, cl_object cas) { - if (cas == @':local') { - if (path->pathname.logical) - return @':upcase'; - return @':downcase'; - } else if (cas == @':common' || cas == @':downcase' || cas == @':upcase') { - return cas; - } else { - FEerror("Not a valid pathname case :~%~A", 1, cas); - } + if (cas == @':local') { + if (path->pathname.logical) + return @':upcase'; + return @':downcase'; + } else if (cas == @':common' || cas == @':downcase' || cas == @':upcase') { + return cas; + } else { + FEerror("Not a valid pathname case :~%~A", 1, cas); + } } static bool in_local_case_p(cl_object str, cl_object cas) { - if (cas == @':downcase') - return ecl_string_case(str) < 0; - return 1; + if (cas == @':downcase') + return ecl_string_case(str) < 0; + return 1; } static bool in_antilocal_case_p(cl_object str, cl_object cas) { - if (cas == @':downcase') - return ecl_string_case(str) > 0; - return 0; + if (cas == @':downcase') + return ecl_string_case(str) > 0; + return 0; } static cl_object to_local_case(cl_object str, cl_object cas) { - if (cas == @':downcase') - return cl_string_downcase(1, str); - return cl_string_upcase(1, str); + if (cas == @':downcase') + return cl_string_downcase(1, str); + return cl_string_upcase(1, str); } static cl_object host_case(cl_object host) { - if (Null(host)) - return @':local'; - if (ecl_logical_hostname_p(host)) - return @':upcase'; - return @':downcase'; + if (Null(host)) + return @':local'; + if (ecl_logical_hostname_p(host)) + return @':upcase'; + return @':downcase'; } static cl_object to_antilocal_case(cl_object str, cl_object cas) { - if (cas == @':downcase') - return cl_string_upcase(1, str); - return cl_string_upcase(1, str); + if (cas == @':downcase') + return cl_string_upcase(1, str); + return cl_string_upcase(1, str); } static cl_object translate_from_common(cl_object str, cl_object tocase) { - int string_case = ecl_string_case(str); - if (string_case > 0) { /* ALL_UPPER */ - return to_local_case(str, tocase); - } else if (string_case < 0) { /* ALL_LOWER */ - return to_antilocal_case(str, tocase); - } else { /* Mixed case goes unchanged */ - return str; - } + int string_case = ecl_string_case(str); + if (string_case > 0) { /* ALL_UPPER */ + return to_local_case(str, tocase); + } else if (string_case < 0) { /* ALL_LOWER */ + return to_antilocal_case(str, tocase); + } else { /* Mixed case goes unchanged */ + return str; + } } static cl_object translate_to_common(cl_object str, cl_object fromcase) { - if (in_local_case_p(str, fromcase)) { - return cl_string_upcase(1, str); - } else if (in_antilocal_case_p(str, fromcase)) { - return cl_string_downcase(1, str); - } else { - return str; - } + if (in_local_case_p(str, fromcase)) { + return cl_string_upcase(1, str); + } else if (in_antilocal_case_p(str, fromcase)) { + return cl_string_downcase(1, str); + } else { + return str; + } } static cl_object translate_component_case(cl_object str, cl_object fromcase, cl_object tocase) { - /* Pathnames may contain some other objects, such as symbols, - * numbers, etc, which need not be translated */ - if (str == OBJNULL) { - return str; - } else if (!ECL_STRINGP(str)) { - return str; - } else if (tocase == fromcase) { - return str; - } else if (tocase == @':common') { - return translate_to_common(str, fromcase); - } else if (fromcase == @':common') { - return translate_from_common(str, tocase); - } else { - str = translate_to_common(str, fromcase); - return translate_from_common(str, tocase); - } + /* Pathnames may contain some other objects, such as symbols, + * numbers, etc, which need not be translated */ + if (str == OBJNULL) { + return str; + } else if (!ECL_STRINGP(str)) { + return str; + } else if (tocase == fromcase) { + return str; + } else if (tocase == @':common') { + return translate_to_common(str, fromcase); + } else if (fromcase == @':common') { + return translate_from_common(str, tocase); + } else { + str = translate_to_common(str, fromcase); + return translate_from_common(str, tocase); + } } static cl_object translate_list_case(cl_object list, cl_object fromcase, cl_object tocase) { - /* If the argument is really a list, translate all strings in it and - * return this new list, else assume it is a string and translate it. - */ - if (!CONSP(list)) { - return translate_component_case(list, fromcase, tocase); - } else { - cl_object l; - list = cl_copy_list(list); - for (l = list; !ecl_endp(l); l = CDR(l)) { - /* It is safe to pass anything to translate_component_case, - * because it will only transform strings, leaving other - * object (such as symbols) unchanged.*/ - cl_object name = ECL_CONS_CAR(l); - name = ECL_LISTP(name)? - translate_list_case(name, fromcase, tocase) : - translate_component_case(name, fromcase, tocase); - ECL_RPLACA(l, name); - } - return list; - } + /* If the argument is really a list, translate all strings in it and + * return this new list, else assume it is a string and translate it. + */ + if (!CONSP(list)) { + return translate_component_case(list, fromcase, tocase); + } else { + cl_object l; + list = cl_copy_list(list); + for (l = list; !ecl_endp(l); l = CDR(l)) { + /* It is safe to pass anything to translate_component_case, + * because it will only transform strings, leaving other + * object (such as symbols) unchanged.*/ + cl_object name = ECL_CONS_CAR(l); + name = ECL_LISTP(name)? + translate_list_case(name, fromcase, tocase) : + translate_component_case(name, fromcase, tocase); + ECL_RPLACA(l, name); + } + return list; + } } static void push_substring(cl_object buffer, cl_object string, cl_index start, cl_index end) { - string = cl_string(string); - while (start < end) { - ecl_string_push_extend(buffer, ecl_char(string, start)); - start++; - } + string = cl_string(string); + while (start < end) { + ecl_string_push_extend(buffer, ecl_char(string, start)); + start++; + } } static void push_string(cl_object buffer, cl_object string) { - push_substring(buffer, string, 0, ecl_length(string)); + push_substring(buffer, string, 0, ecl_length(string)); } static cl_object destructively_check_directory(cl_object directory, bool logical, bool delete_back) { - /* This function performs two tasks - * 1) It ensures that the list is a valid directory list - * 2) It ensures that all strings in the list are valid C strings without fill pointer - * All strings are copied, thus avoiding problems with the user modifying the - * list that was passed to MAKE-PATHNAME. - * 3) Redundant :back are removed. - */ - /* INV: directory is always a list */ - cl_object ptr; - int i; + /* This function performs two tasks + * 1) It ensures that the list is a valid directory list + * 2) It ensures that all strings in the list are valid C strings without fill pointer + * All strings are copied, thus avoiding problems with the user modifying the + * list that was passed to MAKE-PATHNAME. + * 3) Redundant :back are removed. + */ + /* INV: directory is always a list */ + cl_object ptr; + int i; - if (!LISTP(directory)) - return @':error'; - if (Null(directory)) - return directory; - if (ECL_CONS_CAR(directory) != @':absolute' && - ECL_CONS_CAR(directory) != @':relative') - return @':error'; + if (!LISTP(directory)) + return @':error'; + if (Null(directory)) + return directory; + if (ECL_CONS_CAR(directory) != @':absolute' && + ECL_CONS_CAR(directory) != @':relative') + return @':error'; BEGIN: - for (i=0, ptr=directory; CONSP(ptr); ptr = ECL_CONS_CDR(ptr), i++) { - cl_object item = ECL_CONS_CAR(ptr); - if (item == @':back') { - if (i == 0) - return @':error'; - item = ecl_nth(i-1, directory); - if (item == @':absolute' || item == @':wild-inferiors') - return @':error'; - if (delete_back && i >= 2) { - cl_object next = ECL_CONS_CDR(ptr); - ptr = ecl_nthcdr(i-2, directory); - ECL_RPLACD(ptr, next); - i = i-2; - } - } else if (item == @':up') { - if (i == 0) - return @':error'; - item = ecl_nth(i-1, directory); - if (item == @':absolute' || item == @':wild-inferiors') - return @':error'; - } else if (item == @':relative' || item == @':absolute') { - if (i > 0) - return @':error'; - } else if (ecl_stringp(item)) { - cl_index l = ecl_length(item); - item = cl_copy_seq(item); - ECL_RPLACA(ptr, item); - if (logical) - continue; - if (l && ecl_char(item,0) == '.') { - if (l == 1) { - /* Single dot */ - if (i == 0) - return @':error'; - ECL_RPLACD(ecl_nthcdr(--i, directory), - ECL_CONS_CDR(ptr)); - } else if (l == 2 && ecl_char(item,1) == '.') { - ECL_RPLACA(ptr, @':up'); - goto BEGIN; - } - } - } else if (item != @':wild' && item != @':wild-inferiors') { - return @':error'; - } + for (i=0, ptr=directory; CONSP(ptr); ptr = ECL_CONS_CDR(ptr), i++) { + cl_object item = ECL_CONS_CAR(ptr); + if (item == @':back') { + if (i == 0) + return @':error'; + item = ecl_nth(i-1, directory); + if (item == @':absolute' || item == @':wild-inferiors') + return @':error'; + if (delete_back && i >= 2) { + cl_object next = ECL_CONS_CDR(ptr); + ptr = ecl_nthcdr(i-2, directory); + ECL_RPLACD(ptr, next); + i = i-2; + } + } else if (item == @':up') { + if (i == 0) + return @':error'; + item = ecl_nth(i-1, directory); + if (item == @':absolute' || item == @':wild-inferiors') + return @':error'; + } else if (item == @':relative' || item == @':absolute') { + if (i > 0) + return @':error'; + } else if (ecl_stringp(item)) { + cl_index l = ecl_length(item); + item = cl_copy_seq(item); + ECL_RPLACA(ptr, item); + if (logical) + continue; + if (l && ecl_char(item,0) == '.') { + if (l == 1) { + /* Single dot */ + if (i == 0) + return @':error'; + ECL_RPLACD(ecl_nthcdr(--i, directory), + ECL_CONS_CDR(ptr)); + } else if (l == 2 && ecl_char(item,1) == '.') { + ECL_RPLACA(ptr, @':up'); + goto BEGIN; } - return directory; + } + } else if (item != @':wild' && item != @':wild-inferiors') { + return @':error'; + } + } + return directory; } cl_object @@ -260,119 +255,119 @@ ecl_make_pathname(cl_object host, cl_object device, cl_object directory, cl_object name, cl_object type, cl_object version, cl_object fromcase) { - cl_object x, p, component; + cl_object x, p, component; - p = ecl_alloc_object(t_pathname); - if (ecl_stringp(host)) - p->pathname.logical = ecl_logical_hostname_p(host); - else if (host == ECL_NIL) - p->pathname.logical = FALSE; - else { - x = directory; - component = @':host'; - goto ERROR; - } - if (device != ECL_NIL && device != @':unspecific' && - !(!p->pathname.logical && ecl_stringp(device))) { - x = device; - component = @':device'; - goto ERROR; - } - if (name != ECL_NIL && name != @':wild' && !ecl_stringp(name)) { - x = name; - component = @':name'; - goto ERROR; - } - if (type != ECL_NIL && type != @':unspecific' && type != @':wild' && !ecl_stringp(type)) { - x = type; - component = @':type'; - goto ERROR; - } - if (version != @':unspecific' && version != @':newest' && - version != @':wild' && version != ECL_NIL && !ECL_FIXNUMP(version)) - { - x = version; - component = @':version'; - ERROR: FEerror("~s is not a valid pathname-~a component", 2, x, component); - } - switch (ecl_t_of(directory)) { + p = ecl_alloc_object(t_pathname); + if (ecl_stringp(host)) + p->pathname.logical = ecl_logical_hostname_p(host); + else if (host == ECL_NIL) + p->pathname.logical = FALSE; + else { + x = directory; + component = @':host'; + goto ERROR; + } + if (device != ECL_NIL && device != @':unspecific' && + !(!p->pathname.logical && ecl_stringp(device))) { + x = device; + component = @':device'; + goto ERROR; + } + if (name != ECL_NIL && name != @':wild' && !ecl_stringp(name)) { + x = name; + component = @':name'; + goto ERROR; + } + if (type != ECL_NIL && type != @':unspecific' && type != @':wild' && !ecl_stringp(type)) { + x = type; + component = @':type'; + goto ERROR; + } + if (version != @':unspecific' && version != @':newest' && + version != @':wild' && version != ECL_NIL && !ECL_FIXNUMP(version)) + { + x = version; + component = @':version'; + ERROR: FEerror("~s is not a valid pathname-~a component", 2, x, component); + } + switch (ecl_t_of(directory)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - directory = cl_list(2, @':absolute', directory); - break; - case t_symbol: - if (directory == @':wild') { - directory = cl_list(2, @':absolute', @':wild-inferiors'); - break; - } - x = directory; - component = @':directory'; - goto ERROR; - case t_list: - directory = cl_copy_list(directory); - break; - default: - x = directory; - component = @':directory'; - goto ERROR; - } - p->pathname.host = host; - { - cl_object tocase = normalize_case(p, @':local'); - if (p->pathname.logical) - fromcase = @':common'; - else - fromcase = normalize_case(p, fromcase); - p->pathname.host = - translate_component_case(host, fromcase, tocase); - p->pathname.device = - translate_component_case(device, fromcase, tocase); - p->pathname.directory = - directory = - translate_list_case(directory, fromcase, tocase); - p->pathname.name = - translate_component_case(name, fromcase, tocase); - p->pathname.type = - translate_component_case(type, fromcase, tocase); - p->pathname.version = version; - } - directory = destructively_check_directory(directory, p->pathname.logical, 0); - unlikely_if (directory == @':error') { - cl_error(3, @'file-error', @':pathname', p); - } - p->pathname.directory = directory; - return(p); + case t_base_string: + directory = cl_list(2, @':absolute', directory); + break; + case t_symbol: + if (directory == @':wild') { + directory = cl_list(2, @':absolute', @':wild-inferiors'); + break; + } + x = directory; + component = @':directory'; + goto ERROR; + case t_list: + directory = cl_copy_list(directory); + break; + default: + x = directory; + component = @':directory'; + goto ERROR; + } + p->pathname.host = host; + { + cl_object tocase = normalize_case(p, @':local'); + if (p->pathname.logical) + fromcase = @':common'; + else + fromcase = normalize_case(p, fromcase); + p->pathname.host = + translate_component_case(host, fromcase, tocase); + p->pathname.device = + translate_component_case(device, fromcase, tocase); + p->pathname.directory = + directory = + translate_list_case(directory, fromcase, tocase); + p->pathname.name = + translate_component_case(name, fromcase, tocase); + p->pathname.type = + translate_component_case(type, fromcase, tocase); + p->pathname.version = version; + } + directory = destructively_check_directory(directory, p->pathname.logical, 0); + unlikely_if (directory == @':error') { + cl_error(3, @'file-error', @':pathname', p); + } + p->pathname.directory = directory; + return(p); } static cl_object tilde_expand(cl_object pathname) { - /* - * If the pathname is a physical one, without hostname, without device - * and the first element is either a tilde '~' or '~' followed by - * a user name, we merge the user homedir pathname with this one. - */ - cl_object directory, head; - if (pathname->pathname.logical || pathname->pathname.host != ECL_NIL - || pathname->pathname.device != ECL_NIL) { - return pathname; - } - directory = pathname->pathname.directory; - if (!CONSP(directory) || ECL_CONS_CAR(directory) != @':relative' - || ECL_CONS_CDR(directory) == ECL_NIL) { - return pathname; - } - head = CADR(directory); - if (ecl_stringp(head) && ecl_length(head) > 0 && - ecl_char(head,0) == '~') { - /* Remove the tilde component */ - ECL_RPLACD(directory, CDDR(directory)); - pathname = cl_merge_pathnames(2, pathname, - ecl_homedir_pathname(head)); - } - return pathname; + /* + * If the pathname is a physical one, without hostname, without device + * and the first element is either a tilde '~' or '~' followed by + * a user name, we merge the user homedir pathname with this one. + */ + cl_object directory, head; + if (pathname->pathname.logical || pathname->pathname.host != ECL_NIL + || pathname->pathname.device != ECL_NIL) { + return pathname; + } + directory = pathname->pathname.directory; + if (!CONSP(directory) || ECL_CONS_CAR(directory) != @':relative' + || ECL_CONS_CDR(directory) == ECL_NIL) { + return pathname; + } + head = CADR(directory); + if (ecl_stringp(head) && ecl_length(head) > 0 && + ecl_char(head,0) == '~') { + /* Remove the tilde component */ + ECL_RPLACD(directory, CDDR(directory)); + pathname = cl_merge_pathnames(2, pathname, + ecl_homedir_pathname(head)); + } + return pathname; } #define WORD_INCLUDE_DELIM 1 @@ -387,7 +382,7 @@ tilde_expand(cl_object pathname) static cl_object make_one(cl_object s, cl_index start, cl_index end) { - return cl_subseq(3, s, ecl_make_fixnum(start), ecl_make_fixnum(end)); + return cl_subseq(3, s, ecl_make_fixnum(start), ecl_make_fixnum(end)); } static int is_colon(int c) { return c == ':'; } @@ -411,80 +406,80 @@ static cl_object parse_word(cl_object s, delim_fn delim, int flags, cl_index start, cl_index end, cl_index *end_of_word) { - cl_index i, j, last_delim = end; - bool wild_inferiors = FALSE; + cl_index i, j, last_delim = end; + bool wild_inferiors = FALSE; - i = j = start; - for (; i < end; i++) { - bool valid_char; - cl_index c = ecl_char(s, i); - if (delim(c)) { - if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) { - /* Leading dot is included */ - continue; - } - last_delim = i; - if (!(flags & WORD_SEARCH_LAST_DOT)) { - break; - } - } - if (c == '*') { - if (!(flags & WORD_ALLOW_ASTERISK)) - valid_char = FALSE; /* Asterisks not allowed in this word */ - else { - wild_inferiors = (i > start && ecl_char(s, i-1) == '*'); - valid_char = TRUE; /* single "*" */ - } - } else if (c == ';' && (flags & WORD_DISALLOW_SEMICOLON)) { - valid_char = 0; - } else if (c == '/' && (flags & WORD_DISALLOW_SLASH)) { - valid_char = 0; - } else { - valid_char = c != 0; - } - if (!valid_char) { - *end_of_word = start; - return @':error'; - } - } - if (i > last_delim) { - /* Go back to the position of the last delimiter */ - i = last_delim; - } - if (i < end) { - *end_of_word = i+1; - } else { - *end_of_word = end; - /* We have reached the end of the string without finding - the proper delimiter */ - if (flags & WORD_INCLUDE_DELIM) { - *end_of_word = start; - return ECL_NIL; - } - } - switch(i-j) { - case 0: - if (flags & WORD_EMPTY_IS_NIL) - return ECL_NIL; - return cl_core.null_string; - case 1: - if (ecl_char(s,j) == '*') - return @':wild'; - break; - case 2: { - cl_index c0 = ecl_char(s,j); - cl_index c1 = ecl_char(s,j+1); - if (c0 == '*' && c1 == '*') - return @':wild-inferiors'; - if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.') - return @':up'; - break; - } - default: - if (wild_inferiors) /* '**' surrounded by other characters */ - return @':error'; - } - return make_one(s, j, i); + i = j = start; + for (; i < end; i++) { + bool valid_char; + cl_index c = ecl_char(s, i); + if (delim(c)) { + if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) { + /* Leading dot is included */ + continue; + } + last_delim = i; + if (!(flags & WORD_SEARCH_LAST_DOT)) { + break; + } + } + if (c == '*') { + if (!(flags & WORD_ALLOW_ASTERISK)) + valid_char = FALSE; /* Asterisks not allowed in this word */ + else { + wild_inferiors = (i > start && ecl_char(s, i-1) == '*'); + valid_char = TRUE; /* single "*" */ + } + } else if (c == ';' && (flags & WORD_DISALLOW_SEMICOLON)) { + valid_char = 0; + } else if (c == '/' && (flags & WORD_DISALLOW_SLASH)) { + valid_char = 0; + } else { + valid_char = c != 0; + } + if (!valid_char) { + *end_of_word = start; + return @':error'; + } + } + if (i > last_delim) { + /* Go back to the position of the last delimiter */ + i = last_delim; + } + if (i < end) { + *end_of_word = i+1; + } else { + *end_of_word = end; + /* We have reached the end of the string without finding + the proper delimiter */ + if (flags & WORD_INCLUDE_DELIM) { + *end_of_word = start; + return ECL_NIL; + } + } + switch(i-j) { + case 0: + if (flags & WORD_EMPTY_IS_NIL) + return ECL_NIL; + return cl_core.null_string; + case 1: + if (ecl_char(s,j) == '*') + return @':wild'; + break; + case 2: { + cl_index c0 = ecl_char(s,j); + cl_index c1 = ecl_char(s,j+1); + if (c0 == '*' && c1 == '*') + return @':wild-inferiors'; + if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.') + return @':up'; + break; + } + default: + if (wild_inferiors) /* '**' surrounded by other characters */ + return @':error'; + } + return make_one(s, j, i); } /* @@ -500,37 +495,37 @@ static cl_object parse_directories(cl_object s, int flags, cl_index start, cl_index end, cl_index *end_of_dir) { - cl_index i, j; - cl_object path = ECL_NIL; - delim_fn delim = (flags & WORD_LOGICAL) ? is_semicolon : is_slash; + cl_index i, j; + cl_object path = ECL_NIL; + delim_fn delim = (flags & WORD_LOGICAL) ? is_semicolon : is_slash; - flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK; - *end_of_dir = start; - for (i = j = start; i < end; j = i) { - cl_object part = parse_word(s, delim, flags, j, end, &i); - if (part == @':error' || part == ECL_NIL) - break; - if (part == cl_core.null_string) { /* "/", ";" */ - if (j != start) { - if (flags & WORD_LOGICAL) - return @':error'; - *end_of_dir = i; - continue; - } - part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute'; - } - *end_of_dir = i; - path = ecl_cons(part, path); - } - return cl_nreverse(path); + flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK; + *end_of_dir = start; + for (i = j = start; i < end; j = i) { + cl_object part = parse_word(s, delim, flags, j, end, &i); + if (part == @':error' || part == ECL_NIL) + break; + if (part == cl_core.null_string) { /* "/", ";" */ + if (j != start) { + if (flags & WORD_LOGICAL) + return @':error'; + *end_of_dir = i; + continue; + } + part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute'; + } + *end_of_dir = i; + path = ecl_cons(part, path); + } + return cl_nreverse(path); } bool ecl_logical_hostname_p(cl_object host) { - if (!ecl_stringp(host)) - return FALSE; - return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal')); + if (!ecl_stringp(host)) + return FALSE; + return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal')); } /* @@ -563,281 +558,285 @@ cl_object ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep, cl_object default_host) { - cl_object host, device, path, name, type, aux, version; - bool logical; + cl_object host, device, path, name, type, aux, version; + bool logical; - if (start == end) { - host = device = path = name = type = aux = version = @'nil'; - logical = 0; - goto make_it; - } - /* We first try parsing as logical-pathname. In case of - * failure, physical-pathname parsing is performed only when - * there is no supplied *logical* host name. All other failures - * result in ECL_NIL as output. - */ - host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM | - WORD_DISALLOW_SEMICOLON, start, end, ep); - if (default_host != ECL_NIL) { - if (host == ECL_NIL || host == @':error') - host = default_host; - } - if (!ecl_logical_hostname_p(host)) - goto physical; - /* - * Logical pathname format: - * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] - */ - logical = TRUE; - device = @':unspecific'; - path = parse_directories(s, WORD_LOGICAL, *ep, end, ep); - if (CONSP(path)) { - if (ECL_CONS_CAR(path) != @':relative' && - ECL_CONS_CAR(path) != @':absolute') - path = CONS(@':absolute', path); - path = destructively_check_directory(path, TRUE, FALSE); - } else { - path = CONS(@':absolute', path); - } - if (path == @':error') - return ECL_NIL; - name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (name == @':error') - return ECL_NIL; - type = ECL_NIL; - version = ECL_NIL; - if (*ep == start || ecl_char(s, *ep-1) != '.') - goto make_it; - type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (type == @':error') - return ECL_NIL; - if (*ep == start || ecl_char(s, *ep-1) != '.') - goto make_it; - aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK | - WORD_EMPTY_IS_NIL, *ep, end, ep); - if (aux == @':error') { - return ECL_NIL; - } else if (ECL_SYMBOLP(aux)) { - version = aux; - } else { - const cl_env_ptr the_env = ecl_process_env(); - cl_object parsed_length; - version = cl_parse_integer(3, aux, @':junk-allowed', ECL_T); - parsed_length = ecl_nth_value(the_env, 1); - if (ecl_fixnum(parsed_length) == ecl_length(aux) && - cl_integerp(version) != ECL_NIL && ecl_plusp(version)) - ; - else if (cl_string_equal(2, aux, @':newest') != ECL_NIL) - version = @':newest'; - else - return ECL_NIL; - } - goto make_it; + if (start == end) { + host = device = path = name = type = aux = version = @'nil'; + logical = 0; + goto make_it; + } + /* We first try parsing as logical-pathname. In case of + * failure, physical-pathname parsing is performed only when + * there is no supplied *logical* host name. All other failures + * result in ECL_NIL as output. + */ + host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM | + WORD_DISALLOW_SEMICOLON, start, end, ep); + if (default_host != ECL_NIL) { + if (host == ECL_NIL || host == @':error') + host = default_host; + } + if (!ecl_logical_hostname_p(host)) + goto physical; + /* + * Logical pathname format: + * [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type] + */ + logical = TRUE; + device = @':unspecific'; + path = parse_directories(s, WORD_LOGICAL, *ep, end, ep); + if (CONSP(path)) { + if (ECL_CONS_CAR(path) != @':relative' && + ECL_CONS_CAR(path) != @':absolute') + path = CONS(@':absolute', path); + path = destructively_check_directory(path, TRUE, FALSE); + } else { + path = CONS(@':absolute', path); + } + if (path == @':error') + return ECL_NIL; + name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (name == @':error') + return ECL_NIL; + type = ECL_NIL; + version = ECL_NIL; + if (*ep == start || ecl_char(s, *ep-1) != '.') + goto make_it; + type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (type == @':error') + return ECL_NIL; + if (*ep == start || ecl_char(s, *ep-1) != '.') + goto make_it; + aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK | + WORD_EMPTY_IS_NIL, *ep, end, ep); + if (aux == @':error') { + return ECL_NIL; + } else if (ECL_SYMBOLP(aux)) { + version = aux; + } else { + const cl_env_ptr the_env = ecl_process_env(); + cl_object parsed_length; + version = cl_parse_integer(3, aux, @':junk-allowed', ECL_T); + parsed_length = ecl_nth_value(the_env, 1); + if (ecl_fixnum(parsed_length) == ecl_length(aux) && + cl_integerp(version) != ECL_NIL && ecl_plusp(version)) + ; + else if (cl_string_equal(2, aux, @':newest') != ECL_NIL) + version = @':newest'; + else + return ECL_NIL; + } + goto make_it; physical: - /* - * Physical pathname format: - * [[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type] - */ - logical = FALSE; - /* We only parse a hostname when the device was present. This - * requisite is a bit stupid and only applies to the Unix port, - * where "//home/" is equivalent to "/home" However, in Windows - * we need "//FOO/" to be separately handled, for it is a shared - * resource. - */ + /* + * Physical pathname format: + * [[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type] + */ + logical = FALSE; + /* We only parse a hostname when the device was present. This + * requisite is a bit stupid and only applies to the Unix port, + * where "//home/" is equivalent to "/home" However, in Windows + * we need "//FOO/" to be separately handled, for it is a shared + * resource. + */ #if defined(ECL_MS_WINDOWS_HOST) - if ((start+1 <= end) && is_slash(ecl_char(s, start))) { - device = ECL_NIL; - goto maybe_parse_host; - } + if ((start+1 <= end) && is_slash(ecl_char(s, start))) { + device = ECL_NIL; + goto maybe_parse_host; + } #endif - device = parse_word(s, is_colon, WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | - WORD_DISALLOW_SLASH, start, end, ep); - if (device == @':error' || device == ECL_NIL) { - device = ECL_NIL; - host = ECL_NIL; - goto done_device_and_host; - } - if (!ecl_stringp(device)) { - return ECL_NIL; - } + device = parse_word(s, is_colon, WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | + WORD_DISALLOW_SLASH, start, end, ep); + if (device == @':error' || device == ECL_NIL) { + device = ECL_NIL; + host = ECL_NIL; + goto done_device_and_host; + } + if (!ecl_stringp(device)) { + return ECL_NIL; + } maybe_parse_host: - /* Files have no effective device. */ - if (@string-equal(2, device, @':file') == ECL_T) - device = ECL_NIL; - start = *ep; + /* Files have no effective device. */ + if (@string-equal(2, device, @':file') == ECL_T) + device = ECL_NIL; + start = *ep; + host = ECL_NIL; + if ((start+2) <= end && is_slash(ecl_char(s, start)) && + is_slash(ecl_char(s, start+1))) + { + host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL, + start+2, end, ep); + if (host == @':error') { host = ECL_NIL; - if ((start+2) <= end && is_slash(ecl_char(s, start)) && - is_slash(ecl_char(s, start+1))) - { - host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL, - start+2, end, ep); - if (host == @':error') { - host = ECL_NIL; - } else if (host != ECL_NIL) { - if (!ecl_stringp(host)) - return ECL_NIL; - start = *ep; - if (is_slash(ecl_char(s,--start))) - *ep = start; - } - } - if (ecl_length(device) == 0) - device = ECL_NIL; - done_device_and_host: - path = parse_directories(s, 0, *ep, end, ep); - if (CONSP(path)) { - if (ECL_CONS_CAR(path) != @':relative' && - ECL_CONS_CAR(path) != @':absolute') - path = CONS(@':relative', path); - path = destructively_check_directory(path, FALSE, FALSE); - } - if (path == @':error') - return ECL_NIL; + } else if (host != ECL_NIL) { + if (!ecl_stringp(host)) + return ECL_NIL; start = *ep; - name = parse_word(s, is_dot, - WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT | - WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, - start, end, ep); - if (name == @':error') - return ECL_NIL; - if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') { - type = ECL_NIL; - } else { - type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep); - if (type == @':error') - return ECL_NIL; - } - version = (name != ECL_NIL || type != ECL_NIL) ? @':newest' : ECL_NIL; + if (is_slash(ecl_char(s,--start))) + *ep = start; + } + } + if (ecl_length(device) == 0) + device = ECL_NIL; + done_device_and_host: + path = parse_directories(s, 0, *ep, end, ep); + if (CONSP(path)) { + if (ECL_CONS_CAR(path) != @':relative' && + ECL_CONS_CAR(path) != @':absolute') + path = CONS(@':relative', path); + path = destructively_check_directory(path, FALSE, FALSE); + } + if (path == @':error') + return ECL_NIL; + start = *ep; + name = parse_word(s, is_dot, + WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT | + WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, + start, end, ep); + if (name == @':error') + return ECL_NIL; + if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') { + type = ECL_NIL; + } else { + type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep); + if (type == @':error') + return ECL_NIL; + } + version = (name != ECL_NIL || type != ECL_NIL) ? @':newest' : ECL_NIL; make_it: - if (*ep >= end) *ep = end; - path = ecl_make_pathname(host, device, path, name, type, version, - @':local'); - path->pathname.logical = logical; - return tilde_expand(path); + if (*ep >= end) *ep = end; + path = ecl_make_pathname(host, device, path, name, type, version, + @':local'); + path->pathname.logical = logical; + return tilde_expand(path); } cl_object si_default_pathname_defaults(void) { - /* This routine outputs the value of *default-pathname-defaults* - * coerced to type PATHNAME. Special care is taken so that we do - * not enter an infinite loop when using PARSE-NAMESTRING, because - * this routine might itself try to use the value of this variable. */ - cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); - unlikely_if (!ECL_PATHNAMEP(path)) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); - FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*], - path, @'pathname'); - } - @(return path) + /* This routine outputs the value of *default-pathname-defaults* + * coerced to type PATHNAME. Special care is taken so that we do + * not enter an infinite loop when using PARSE-NAMESTRING, because + * this routine might itself try to use the value of this variable. */ + cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); + unlikely_if (!ECL_PATHNAMEP(path)) { + const cl_env_ptr the_env = ecl_process_env(); + ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); + FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*], + path, @'pathname'); + } + @(return path); } cl_object cl_pathname(cl_object x) { -L: - switch (ecl_t_of(x)) { + L: + switch (ecl_t_of(x)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - x = cl_parse_namestring(1, x); - case t_pathname: - break; - case t_stream: - switch ((enum ecl_smmode)x->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_probe: - case ecl_smm_io: - case ecl_smm_input_file: - case ecl_smm_output_file: - case ecl_smm_io_file: - x = IO_STREAM_FILENAME(x); - goto L; - case ecl_smm_synonym: - x = SYNONYM_STREAM_STREAM(x); - goto L; - default: - ;/* Fall through to error message */ - } - default: { - const char *type = "(OR FILE-STREAM STRING PATHNAME)"; - FEwrong_type_only_arg(@[pathname], x, ecl_read_from_cstring(type)); - } - } - @(return x) + case t_base_string: + x = cl_parse_namestring(1, x); + case t_pathname: + break; + case t_stream: + switch ((enum ecl_smmode)x->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_probe: + case ecl_smm_io: + case ecl_smm_input_file: + case ecl_smm_output_file: + case ecl_smm_io_file: + x = IO_STREAM_FILENAME(x); + goto L; + case ecl_smm_synonym: + x = SYNONYM_STREAM_STREAM(x); + goto L; + default: + ;/* Fall through to error message */ + } + default: { + const char *type = "(OR FILE-STREAM STRING PATHNAME)"; + FEwrong_type_only_arg(@[pathname], x, ecl_read_from_cstring(type)); + } + } + @(return x); } cl_object cl_logical_pathname(cl_object x) { - x = cl_pathname(x); - if (!x->pathname.logical) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~S cannot be coerced to a logical pathname."), - @':format-arguments', cl_list(1, x), - @':expected-type', @'logical-pathname', - @':datum', x); - } - @(return x); + x = cl_pathname(x); + if (!x->pathname.logical) { + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~S cannot be coerced to a logical pathname."), + @':format-arguments', cl_list(1, x), + @':expected-type', @'logical-pathname', + @':datum', x); + } + @(return x); } /* FIXME! WILD-PATHNAME-P is missing! */ @(defun wild-pathname-p (pathname &optional component) - bool checked = 0; + bool checked = 0; @ - pathname = cl_pathname(pathname); - if (component == ECL_NIL || component == @':host') { - if (pathname->pathname.host == @':wild') - @(return ECL_T); - checked = 1; + pathname = cl_pathname(pathname); + if (component == ECL_NIL || component == @':host') { + if (pathname->pathname.host == @':wild') { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':device') { + if (pathname->pathname.device == @':wild') { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':version') { + if (pathname->pathname.version == @':wild') { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':name') { + cl_object name = pathname->pathname.name; + if (name != ECL_NIL && + (name == @':wild' || ecl_wild_string_p(name))) { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':type') { + cl_object name = pathname->pathname.type; + if (name != ECL_NIL && + (name == @':wild' || ecl_wild_string_p(name))) { + @(return ECL_T); + } + checked = 1; + } + if (component == ECL_NIL || component == @':directory') { + cl_object list = pathname->pathname.directory; + checked = 1; + loop_for_on_unsafe(list) { + cl_object name = ECL_CONS_CAR(list); + if (name != ECL_NIL && + (name == @':wild' || name == @':wild-inferiors' || + ecl_wild_string_p(name))) { + @(return ECL_T); } - if (component == ECL_NIL || component == @':device') { - if (pathname->pathname.device == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':version') { - if (pathname->pathname.version == @':wild') - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':name') { - cl_object name = pathname->pathname.name; - if (name != ECL_NIL && - (name == @':wild' || ecl_wild_string_p(name))) - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':type') { - cl_object name = pathname->pathname.type; - if (name != ECL_NIL && - (name == @':wild' || ecl_wild_string_p(name))) - @(return ECL_T); - checked = 1; - } - if (component == ECL_NIL || component == @':directory') { - cl_object list = pathname->pathname.directory; - checked = 1; - loop_for_on_unsafe(list) { - cl_object name = ECL_CONS_CAR(list); - if (name != ECL_NIL && - (name == @':wild' || name == @':wild-inferiors' || - ecl_wild_string_p(name))) - { - @(return ECL_T) - } - } end_loop_for_on_unsafe(list); - } - if (checked == 0) { - FEerror("~A is not a valid pathname component", 1, component); - } - @(return ECL_NIL) + } end_loop_for_on_unsafe(list); + } + if (checked == 0) { + FEerror("~A is not a valid pathname component", 1, component); + } + @(return ECL_NIL); @) /* @@ -850,22 +849,22 @@ cl_logical_pathname(cl_object x) cl_object coerce_to_file_pathname(cl_object pathname) { - pathname = coerce_to_physical_pathname(pathname); - pathname = cl_merge_pathnames(1, pathname); + pathname = coerce_to_physical_pathname(pathname); + pathname = cl_merge_pathnames(1, pathname); #if 0 #if !defined(cygwin) && !defined(ECL_MS_WINDOWS_HOST) - if (pathname->pathname.device != ECL_NIL) - FEerror("Device ~S not yet supported.", 1, - pathname->pathname.device); - if (pathname->pathname.host != ECL_NIL) - FEerror("Access to remote files not yet supported.", 0); + if (pathname->pathname.device != ECL_NIL) + FEerror("Device ~S not yet supported.", 1, + pathname->pathname.device); + if (pathname->pathname.host != ECL_NIL) + FEerror("Access to remote files not yet supported.", 0); #endif #endif - if (pathname->pathname.directory == ECL_NIL || - ECL_CONS_CAR(pathname->pathname.directory) == @':relative') { - pathname = cl_merge_pathnames(2, pathname, si_getcwd(0)); - } - return pathname; + if (pathname->pathname.directory == ECL_NIL || + ECL_CONS_CAR(pathname->pathname.directory) == @':relative') { + pathname = cl_merge_pathnames(2, pathname, si_getcwd(0)); + } + return pathname; } /* @@ -875,10 +874,10 @@ coerce_to_file_pathname(cl_object pathname) cl_object coerce_to_physical_pathname(cl_object x) { - x = cl_pathname(x); - if (x->pathname.logical) - return cl_translate_logical_pathname(1, x); - return x; + x = cl_pathname(x); + if (x->pathname.logical) + return cl_translate_logical_pathname(1, x); + return x; } /* @@ -890,35 +889,35 @@ coerce_to_physical_pathname(cl_object x) cl_object si_coerce_to_filename(cl_object pathname_orig) { - cl_object namestring, pathname; + cl_object namestring, pathname; - /* We always go through the pathname representation and thus - * cl_namestring() always outputs a fresh new string */ - pathname = coerce_to_file_pathname(pathname_orig); - if (cl_wild_pathname_p(1,pathname) != ECL_NIL) - cl_error(3, @'file-error', @':pathname', pathname_orig); - namestring = ecl_namestring(pathname, - ECL_NAMESTRING_TRUNCATE_IF_ERROR | - ECL_NAMESTRING_FORCE_BASE_STRING); - if (namestring == ECL_NIL) { - FEerror("Pathname without a physical namestring:" - "~% :HOST ~A" - "~% :DEVICE ~A" - "~% :DIRECTORY ~A" - "~% :NAME ~A" - "~% :TYPE ~A" - "~% :VERSION ~A", - 6, pathname_orig->pathname.host, - pathname_orig->pathname.device, - pathname_orig->pathname.directory, - pathname_orig->pathname.name, - pathname_orig->pathname.type, - pathname_orig->pathname.version); - } - if (cl_core.path_max != -1 && - ecl_length(namestring) >= cl_core.path_max - 16) - FEerror("Too long filename: ~S.", 1, namestring); - return namestring; + /* We always go through the pathname representation and thus + * cl_namestring() always outputs a fresh new string */ + pathname = coerce_to_file_pathname(pathname_orig); + if (cl_wild_pathname_p(1,pathname) != ECL_NIL) + cl_error(3, @'file-error', @':pathname', pathname_orig); + namestring = ecl_namestring(pathname, + ECL_NAMESTRING_TRUNCATE_IF_ERROR | + ECL_NAMESTRING_FORCE_BASE_STRING); + if (namestring == ECL_NIL) { + FEerror("Pathname without a physical namestring:" + "~% :HOST ~A" + "~% :DEVICE ~A" + "~% :DIRECTORY ~A" + "~% :NAME ~A" + "~% :TYPE ~A" + "~% :VERSION ~A", + 6, pathname_orig->pathname.host, + pathname_orig->pathname.device, + pathname_orig->pathname.directory, + pathname_orig->pathname.name, + pathname_orig->pathname.type, + pathname_orig->pathname.version); + } + if (cl_core.path_max != -1 && + ecl_length(namestring) >= cl_core.path_max - 16) + FEerror("Too long filename: ~S.", 1, namestring); + return namestring; } #define default_device(host) ECL_NIL @@ -926,437 +925,436 @@ si_coerce_to_filename(cl_object pathname_orig) cl_object ecl_merge_pathnames(cl_object path, cl_object defaults, cl_object default_version) { - cl_object host, device, directory, name, type, version; - cl_object tocase; + cl_object host, device, directory, name, type, version; + cl_object tocase; - defaults = cl_pathname(defaults); - path = cl_parse_namestring(1, path, ECL_NIL, defaults); - if (Null(host = path->pathname.host)) - host = defaults->pathname.host; - tocase = host_case(host); - if (Null(path->pathname.device)) { - if (Null(path->pathname.host)) - device = cl_pathname_device(3, defaults, @':case', tocase); - else if (path->pathname.host == defaults->pathname.host) - device = defaults->pathname.device; - else - device = default_device(path->pathname.host); - } else { - device = path->pathname.device; - } - if (Null(path->pathname.directory)) { - directory = cl_pathname_directory(3, defaults, @':case', tocase); - } else if (ECL_CONS_CAR(path->pathname.directory) == @':absolute') { - directory = path->pathname.directory; - } else if (!Null(defaults->pathname.directory)) { - directory = ecl_append(cl_pathname_directory(3, defaults, - @':case', tocase), - CDR(path->pathname.directory)); - /* Eliminate redundant :back */ - directory = destructively_check_directory(directory, TRUE, TRUE); - } else { - directory = path->pathname.directory; - } - if (Null(name = path->pathname.name)) { - name = cl_pathname_name(3, defaults, @':case', tocase); - } - if (Null(type = path->pathname.type)) { - type = cl_pathname_type(3, defaults, @':case', tocase); - } - version = path->pathname.version; - if (Null(path->pathname.name)) { - if (Null(version)) - version = defaults->pathname.version; - } - if (Null(version)) { - version = default_version; - } - if (default_version == @':default') { - if (Null(name) && Null(type)) { - version = ECL_NIL; - } else { - version = @':newest'; - } - } - /* - In this implementation, version is not considered - */ - defaults = ecl_make_pathname(host, device, directory, name, - type, version, tocase); - return defaults; + defaults = cl_pathname(defaults); + path = cl_parse_namestring(1, path, ECL_NIL, defaults); + if (Null(host = path->pathname.host)) + host = defaults->pathname.host; + tocase = host_case(host); + if (Null(path->pathname.device)) { + if (Null(path->pathname.host)) + device = cl_pathname_device(3, defaults, @':case', tocase); + else if (path->pathname.host == defaults->pathname.host) + device = defaults->pathname.device; + else + device = default_device(path->pathname.host); + } else { + device = path->pathname.device; + } + if (Null(path->pathname.directory)) { + directory = cl_pathname_directory(3, defaults, @':case', tocase); + } else if (ECL_CONS_CAR(path->pathname.directory) == @':absolute') { + directory = path->pathname.directory; + } else if (!Null(defaults->pathname.directory)) { + directory = ecl_append(cl_pathname_directory(3, defaults, + @':case', tocase), + CDR(path->pathname.directory)); + /* Eliminate redundant :back */ + directory = destructively_check_directory(directory, TRUE, TRUE); + } else { + directory = path->pathname.directory; + } + if (Null(name = path->pathname.name)) { + name = cl_pathname_name(3, defaults, @':case', tocase); + } + if (Null(type = path->pathname.type)) { + type = cl_pathname_type(3, defaults, @':case', tocase); + } + version = path->pathname.version; + if (Null(path->pathname.name)) { + if (Null(version)) + version = defaults->pathname.version; + } + if (Null(version)) { + version = default_version; + } + if (default_version == @':default') { + if (Null(name) && Null(type)) { + version = ECL_NIL; + } else { + version = @':newest'; + } + } + /* + In this implementation, version is not considered + */ + defaults = ecl_make_pathname(host, device, directory, name, + type, version, tocase); + return defaults; } /* - ecl_namestring(x, flag) converts a pathname to a namestring. - if flag is true, then the pathname may be coerced to the requirements - of the filesystem, removing fields that have no meaning (such as - version, or type, etc); otherwise, when it is not possible to - produce a readable representation of the pathname, NIL is returned. + ecl_namestring(x, flag) converts a pathname to a namestring. + if flag is true, then the pathname may be coerced to the requirements + of the filesystem, removing fields that have no meaning (such as + version, or type, etc); otherwise, when it is not possible to + produce a readable representation of the pathname, NIL is returned. */ cl_object ecl_namestring(cl_object x, int flags) { - bool logical; - cl_object l, y; - cl_object buffer, host; - bool truncate_if_unreadable = flags & ECL_NAMESTRING_TRUNCATE_IF_ERROR; + bool logical; + cl_object l, y; + cl_object buffer, host; + bool truncate_if_unreadable = flags & ECL_NAMESTRING_TRUNCATE_IF_ERROR; - x = cl_pathname(x); + x = cl_pathname(x); - /* INV: Pathnames can only be created by mergin, parsing namestrings - * or using ecl_make_pathname(). In all of these cases ECL will complain - * at creation time if the pathname has wrong components. - */ - buffer = ecl_make_string_output_stream(128, 1); - logical = x->pathname.logical; - host = x->pathname.host; - if (logical) { - if ((y = x->pathname.device) != @':unspecific' && - truncate_if_unreadable) - return ECL_NIL; - if (host != ECL_NIL) { - si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); - writestr_stream(":", buffer); - } - } else { - if ((y = x->pathname.device) != ECL_NIL) { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - writestr_stream(":", buffer); - } - if (host != ECL_NIL) { + /* INV: Pathnames can only be created by mergin, parsing namestrings + * or using ecl_make_pathname(). In all of these cases ECL will complain + * at creation time if the pathname has wrong components. + */ + buffer = ecl_make_string_output_stream(128, 1); + logical = x->pathname.logical; + host = x->pathname.host; + if (logical) { + if ((y = x->pathname.device) != @':unspecific' && + truncate_if_unreadable) + return ECL_NIL; + if (host != ECL_NIL) { + si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); + writestr_stream(":", buffer); + } + } else { + if ((y = x->pathname.device) != ECL_NIL) { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + writestr_stream(":", buffer); + } + if (host != ECL_NIL) { #if !defined(ECL_MS_WINDOWS_HOST) - if (y == ECL_NIL) { - writestr_stream("file:", buffer); - } + if (y == ECL_NIL) { + writestr_stream("file:", buffer); + } #endif - writestr_stream("//", buffer); - si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); - } + writestr_stream("//", buffer); + si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } + l = x->pathname.directory; + if (ecl_endp(l)) + goto NO_DIRECTORY; + y = ECL_CONS_CAR(l); + if (y == @':relative') { + if (logical) + ecl_write_char(';', buffer); + } else { + if (!logical) + ecl_write_char(DIR_SEPARATOR, buffer); + } + l = ECL_CONS_CDR(l); + loop_for_in(l) { + y = ECL_CONS_CAR(l); + if (y == @':up') { + writestr_stream("..", buffer); + } else if (y == @':wild') { + writestr_stream("*", buffer); + } else if (y == @':wild-inferiors') { + writestr_stream("**", buffer); + } else if (y != @':back') { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } else { + /* Directory :back has no namestring representation */ + return ECL_NIL; + } + ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer); + } end_loop_for_in; + NO_DIRECTORY: + if (ecl_file_position(buffer) == ecl_make_fixnum(0)) { + if ((ecl_stringp(x->pathname.name) && + ecl_member_char(':', x->pathname.name)) || + (ecl_stringp(x->pathname.type) && + ecl_member_char(':', x->pathname.type))) + writestr_stream(":", buffer); + } + y = x->pathname.name; + if (y != ECL_NIL) { + if (y == @':wild') { + writestr_stream("*", buffer); + } else { + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } else if (!logical && !Null(x->pathname.type)) { + /* #P".txt" is :NAME = ".txt" :TYPE = NIL and + hence :NAME = NIL and :TYPE != NIL does not have + a printed representation */ + return ECL_NIL; + } + y = x->pathname.type; + if (y == @':unspecific') { + return ECL_NIL; + } else if (y != ECL_NIL) { + if (y == @':wild') { + writestr_stream(".*", buffer); + } else { + writestr_stream(".", buffer); + si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); + } + } + y = x->pathname.version; + if (logical) { + if (y != ECL_NIL) { + writestr_stream(".", buffer); + if (y == @':wild') { + writestr_stream("*", buffer); + } else if (y == @':newest') { + si_do_write_sequence(ecl_symbol_name(y), buffer, + ecl_make_fixnum(0), ECL_NIL); + } else { + /* Since the printer is not reentrant, + * we cannot use cl_write and friends. + */ + int n = ecl_fixnum(y), i; + char b[ECL_FIXNUM_BITS / 2]; + for (i = 0; n; i++) { + b[i] = n%10 + '0'; + n = n/10; } - l = x->pathname.directory; - if (ecl_endp(l)) - goto NO_DIRECTORY; - y = ECL_CONS_CAR(l); - if (y == @':relative') { - if (logical) - ecl_write_char(';', buffer); - } else { - if (!logical) - ecl_write_char(DIR_SEPARATOR, buffer); + if (i == 0) + b[i++] = '0'; + while (i--) { + ecl_write_char(b[i], buffer); } - l = ECL_CONS_CDR(l); - loop_for_in(l) { - y = ECL_CONS_CAR(l); - if (y == @':up') { - writestr_stream("..", buffer); - } else if (y == @':wild') { - writestr_stream("*", buffer); - } else if (y == @':wild-inferiors') { - writestr_stream("**", buffer); - } else if (y != @':back') { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } else { - /* Directory :back has no namestring representation */ - return ECL_NIL; - } - ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer); - } end_loop_for_in; -NO_DIRECTORY: - if (ecl_file_position(buffer) == ecl_make_fixnum(0)) { - if ((ecl_stringp(x->pathname.name) && - ecl_member_char(':', x->pathname.name)) || - (ecl_stringp(x->pathname.type) && - ecl_member_char(':', x->pathname.type))) - writestr_stream(":", buffer); - } - y = x->pathname.name; - if (y != ECL_NIL) { - if (y == @':wild') { - writestr_stream("*", buffer); - } else { - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } else if (!logical && !Null(x->pathname.type)) { - /* #P".txt" is :NAME = ".txt" :TYPE = NIL and - hence :NAME = NIL and :TYPE != NIL does not have - a printed representation */ - return ECL_NIL; - } - y = x->pathname.type; - if (y == @':unspecific') { - return ECL_NIL; - } else if (y != ECL_NIL) { - if (y == @':wild') { - writestr_stream(".*", buffer); - } else { - writestr_stream(".", buffer); - si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL); - } - } - y = x->pathname.version; - if (logical) { - if (y != ECL_NIL) { - writestr_stream(".", buffer); - if (y == @':wild') { - writestr_stream("*", buffer); - } else if (y == @':newest') { - si_do_write_sequence(ecl_symbol_name(y), buffer, - ecl_make_fixnum(0), ECL_NIL); - } else { - /* Since the printer is not reentrant, - * we cannot use cl_write and friends. - */ - int n = ecl_fixnum(y), i; - char b[ECL_FIXNUM_BITS / 2]; - for (i = 0; n; i++) { - b[i] = n%10 + '0'; - n = n/10; - } - if (i == 0) - b[i++] = '0'; - while (i--) { - ecl_write_char(b[i], buffer); - } - } - } - } 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 != ECL_NIL) - return ECL_NIL; - } else if (y != @':newest') { - /* Filenames have an implicit version :newest */ - return ECL_NIL; - } - } - buffer = cl_get_output_stream_string(buffer); + } + } + } 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 != ECL_NIL) + return ECL_NIL; + } else if (y != @':newest') { + /* Filenames have an implicit version :newest */ + return ECL_NIL; + } + } + buffer = cl_get_output_stream_string(buffer); #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(buffer) && - (flags & ECL_NAMESTRING_FORCE_BASE_STRING)) { - unlikely_if (!ecl_fits_in_base_string(buffer)) - FEerror("The filesystem does not accept filenames " - "with extended characters: ~S", - 1, buffer); - buffer = si_copy_to_simple_base_string(buffer); - } + if (ECL_EXTENDED_STRING_P(buffer) && + (flags & ECL_NAMESTRING_FORCE_BASE_STRING)) { + unlikely_if (!ecl_fits_in_base_string(buffer)) + FEerror("The filesystem does not accept filenames " + "with extended characters: ~S", + 1, buffer); + buffer = si_copy_to_simple_base_string(buffer); + } #endif - return buffer; + return buffer; } cl_object cl_namestring(cl_object x) { - @(return ecl_namestring(x, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + @(return ecl_namestring(x, ECL_NAMESTRING_TRUNCATE_IF_ERROR)); } @(defun parse_namestring (thing - &o host (defaults si_default_pathname_defaults()) - &k (start ecl_make_fixnum(0)) end junk_allowed - &a output) + &o host (defaults si_default_pathname_defaults()) + &k (start ecl_make_fixnum(0)) end junk_allowed + &a output) @ - if (host != ECL_NIL) { - host = cl_string(host); - } - if (!ecl_stringp(thing)) { - output = cl_pathname(thing); - } else { - cl_object default_host = host; - cl_index_pair p; - cl_index ee; - if (default_host == ECL_NIL && defaults != ECL_NIL) { - defaults = cl_pathname(defaults); - default_host = defaults->pathname.host; - } - p = ecl_vector_start_end(@[parse-namestring], thing, start, end); - output = ecl_parse_namestring(thing, p.start, p.end, &ee, default_host); - start = ecl_make_fixnum(ee); - if (output == ECL_NIL || ee != p.end) { - if (Null(junk_allowed)) { - FEparse_error("Cannot parse the namestring ~S~%" - "from ~S to ~S.", ECL_NIL, - 3, thing, start, end); - } - goto OUTPUT; - } - } - if (host != ECL_NIL && !ecl_equal(output->pathname.host, host)) { - FEerror("The pathname ~S does not contain the required host ~S.", - 2, thing, host); - } - OUTPUT: - @(return output start) + if (host != ECL_NIL) { + host = cl_string(host); + } + if (!ecl_stringp(thing)) { + output = cl_pathname(thing); + } else { + cl_object default_host = host; + cl_index_pair p; + cl_index ee; + if (default_host == ECL_NIL && defaults != ECL_NIL) { + defaults = cl_pathname(defaults); + default_host = defaults->pathname.host; + } + p = ecl_vector_start_end(@[parse-namestring], thing, start, end); + output = ecl_parse_namestring(thing, p.start, p.end, &ee, default_host); + start = ecl_make_fixnum(ee); + if (output == ECL_NIL || ee != p.end) { + if (Null(junk_allowed)) { + FEparse_error("Cannot parse the namestring ~S~%" + "from ~S to ~S.", ECL_NIL, + 3, thing, start, end); + } + goto OUTPUT; + } + } + if (host != ECL_NIL && !ecl_equal(output->pathname.host, host)) { + FEerror("The pathname ~S does not contain the required host ~S.", + 2, thing, host); + } + OUTPUT: + @(return output start); @) @(defun merge_pathnames (path - &o (defaults si_default_pathname_defaults()) - (default_version @':newest')) + &o (defaults si_default_pathname_defaults()) + (default_version @':newest')) @ - path = cl_pathname(path); - defaults = cl_pathname(defaults); - @(return ecl_merge_pathnames(path, defaults, default_version)) + path = cl_pathname(path); + defaults = cl_pathname(defaults); + @(return ecl_merge_pathnames(path, defaults, default_version)); @) @(defun make_pathname (&key (host ECL_NIL hostp) (device ECL_NIL devicep) - (directory ECL_NIL directoryp) - (name ECL_NIL namep) (type ECL_NIL typep) (version ECL_NIL versionp) - ((:case scase) @':local') - defaults + (directory ECL_NIL directoryp) + (name ECL_NIL namep) (type ECL_NIL typep) (version ECL_NIL versionp) + ((:case scase) @':local') + defaults &aux x) @ - if (Null(defaults)) { - defaults = si_default_pathname_defaults(); - defaults = ecl_make_pathname(defaults->pathname.host, - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, - @':local'); - } else { - defaults = cl_pathname(defaults); - } - if (!hostp) host = defaults->pathname.host; - x = ecl_make_pathname(host, device, directory, name, type, version, scase); - if (!devicep) x->pathname.device = defaults->pathname.device; - if (!directoryp) x->pathname.directory = defaults->pathname.directory; - if (!namep) x->pathname.name = defaults->pathname.name; - if (!typep) x->pathname.type = defaults->pathname.type; - if (!versionp) x->pathname.version = defaults->pathname.version; + if (Null(defaults)) { + defaults = si_default_pathname_defaults(); + defaults = ecl_make_pathname(defaults->pathname.host, + ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, + @':local'); + } else { + defaults = cl_pathname(defaults); + } + if (!hostp) host = defaults->pathname.host; + x = ecl_make_pathname(host, device, directory, name, type, version, scase); + if (!devicep) x->pathname.device = defaults->pathname.device; + if (!directoryp) x->pathname.directory = defaults->pathname.directory; + if (!namep) x->pathname.name = defaults->pathname.name; + if (!typep) x->pathname.type = defaults->pathname.type; + if (!versionp) x->pathname.version = defaults->pathname.version; - @(return x) + @(return x); @) cl_object cl_pathnamep(cl_object pname) { - @(return (ECL_PATHNAMEP(pname) ? ECL_T : ECL_NIL)) + @(return (ECL_PATHNAMEP(pname) ? ECL_T : ECL_NIL)); } cl_object si_logical_pathname_p(cl_object pname) { - @(return ((ECL_PATHNAMEP(pname) && pname->pathname.logical)? - ECL_T : ECL_NIL)) + @(return ((ECL_PATHNAMEP(pname) && pname->pathname.logical)? + ECL_T : ECL_NIL)); } @(defun pathname_host (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.host, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.host, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_device (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.device, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.device, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_directory (pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_list_case(pname->pathname.directory, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_list_case(pname->pathname.directory, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_name(pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.name, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.name, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) @(defun pathname_type(pname &key ((:case scase) @':local')) @ - pname = cl_pathname(pname); - @(return translate_component_case(pname->pathname.type, - normalize_case(pname, @':local'), - normalize_case(pname, scase))) + pname = cl_pathname(pname); + @(return translate_component_case(pname->pathname.type, + normalize_case(pname, @':local'), + normalize_case(pname, scase))); @) cl_object cl_pathname_version(cl_object pname) { - pname = cl_pathname(pname); - @(return pname->pathname.version) + pname = cl_pathname(pname); + @(return pname->pathname.version); } cl_object cl_file_namestring(cl_object pname) { - pname = cl_pathname(pname); - @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, - pname->pathname.name, - pname->pathname.type, - pname->pathname.version, - @':local'), - ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + pname = cl_pathname(pname); + @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, + pname->pathname.name, + pname->pathname.type, + pname->pathname.version, + @':local'), + ECL_NAMESTRING_TRUNCATE_IF_ERROR)); } cl_object cl_directory_namestring(cl_object pname) { - pname = cl_pathname(pname); - @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, - pname->pathname.directory, - ECL_NIL, ECL_NIL, ECL_NIL, - @':local'), - ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + pname = cl_pathname(pname); + @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, + pname->pathname.directory, + ECL_NIL, ECL_NIL, ECL_NIL, + @':local'), + ECL_NAMESTRING_TRUNCATE_IF_ERROR)); } cl_object cl_host_namestring(cl_object pname) { - pname = cl_pathname(pname); - pname = pname->pathname.host; - if (Null(pname) || pname == @':wild') - pname = cl_core.null_string; - @(return pname) + pname = cl_pathname(pname); + pname = pname->pathname.host; + if (Null(pname) || pname == @':wild') + pname = cl_core.null_string; + @(return pname); } #define EN_MATCH(p1,p2,el) (ecl_equalp(p1->pathname.el, p2->pathname.el)? ECL_NIL : p1->pathname.el) @(defun enough_namestring (path - &o (defaults si_default_pathname_defaults())) - cl_object newpath, pathdir, defaultdir, fname; + &o (defaults si_default_pathname_defaults())) + cl_object newpath, pathdir, defaultdir, fname; @ - defaults = cl_pathname(defaults); - path = cl_pathname(path); - pathdir = path->pathname.directory; - defaultdir = defaults->pathname.directory; - if (Null(pathdir)) { - pathdir = ecl_list1(@':relative'); - } else if (Null(defaultdir)) { - /* The defaults pathname does not have a directory. */ - } else if (ECL_CONS_CAR(pathdir) == @':relative') { - /* The pathname is relative to the default one one, so we just output the - original one */ - } else { - /* The new pathname is an absolute one. We compare it with the defaults - and if they have some common elements, we just output the remaining ones. */ - cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir, - @':test', @'equal'); - if (dir_begin == ECL_NIL) { - pathdir = ECL_NIL; - } else if (dir_begin == cl_length(defaultdir)) { - pathdir = funcall(3, @'subseq', pathdir, dir_begin); - pathdir = CONS(@':relative', pathdir); - } - } - fname = EN_MATCH(path, defaults, name); - if (fname == ECL_NIL) fname = path->pathname.name; - /* Create a path with all elements that do not match the default */ - newpath - = ecl_make_pathname(EN_MATCH(path, defaults, host), - EN_MATCH(path, defaults, device), - pathdir, fname, - EN_MATCH(path, defaults, type), - EN_MATCH(path, defaults, version), - @':local'); - newpath->pathname.logical = path->pathname.logical; - @(return ecl_namestring(newpath, ECL_NAMESTRING_TRUNCATE_IF_ERROR)) + defaults = cl_pathname(defaults); + path = cl_pathname(path); + pathdir = path->pathname.directory; + defaultdir = defaults->pathname.directory; + if (Null(pathdir)) { + pathdir = ecl_list1(@':relative'); + } else if (Null(defaultdir)) { + /* The defaults pathname does not have a directory. */ + } else if (ECL_CONS_CAR(pathdir) == @':relative') { + /* The pathname is relative to the default one one, so we just output the + original one */ + } else { + /* The new pathname is an absolute one. We compare it with the defaults + and if they have some common elements, we just output the remaining ones. */ + cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir, + @':test', @'equal'); + if (dir_begin == ECL_NIL) { + pathdir = ECL_NIL; + } else if (dir_begin == cl_length(defaultdir)) { + pathdir = funcall(3, @'subseq', pathdir, dir_begin); + pathdir = CONS(@':relative', pathdir); + } + } + fname = EN_MATCH(path, defaults, name); + if (fname == ECL_NIL) fname = path->pathname.name; + /* Create a path with all elements that do not match the default */ + newpath = ecl_make_pathname(EN_MATCH(path, defaults, host), + EN_MATCH(path, defaults, device), + pathdir, fname, + EN_MATCH(path, defaults, type), + EN_MATCH(path, defaults, version), + @':local'); + newpath->pathname.logical = path->pathname.logical; + @(return ecl_namestring(newpath, ECL_NAMESTRING_TRUNCATE_IF_ERROR)); @) #undef EN_MATCH @@ -1365,15 +1363,15 @@ cl_host_namestring(cl_object pname) bool ecl_wild_string_p(cl_object item) { - if (ECL_STRINGP(item)) { - cl_index i, l = ecl_length(item); - for (i = 0; i < l; i++) { - ecl_character c = ecl_char(item, i); - if (c == '\\' || c == '*' || c == '?') - return 1; - } - } - return 0; + if (ECL_STRINGP(item)) { + cl_index i, l = ecl_length(item); + for (i = 0; i < l; i++) { + ecl_character c = ecl_char(item, i); + if (c == '\\' || c == '*' || c == '?') + return 1; + } + } + return 0; } /* @@ -1385,123 +1383,123 @@ bool ecl_string_match(cl_object s, cl_index j, cl_index ls, cl_object p, cl_index i, cl_index lp) { - while (i < lp) { - cl_index cp = ecl_char(p, i); - switch (cp) { - case '*': { - /* An asterisk in the pattern matches any - * number of characters. We try the shortest - * sequence that matches. */ - cl_index cn = 0, next; - for (next = i+1; - next < lp && ((cn = ecl_char(p, next)) == '*'); - next++) - ; - if (next == lp) { - return TRUE; - } - while (j < ls) { - if (ecl_string_match(s, j, ls, p, next, lp)) { - return TRUE; - } - j++; - } - return FALSE; - break; - } - case '?': - /* Match any character */ - if (j > ls) return FALSE; - i++; j++; - break; - case '\\': - /* Interpret a pattern character literally. - Trailing slash is interpreted as a slash. */ - if (++i >= lp) i--; - default: - if ((j >= ls) || (cp != ecl_char(s, j))) { - /* Either there are no characters left in "s" - * or the next character does not match. */ - return FALSE; - } - i++; j++; - } + while (i < lp) { + cl_index cp = ecl_char(p, i); + switch (cp) { + case '*': { + /* An asterisk in the pattern matches any + * number of characters. We try the shortest + * sequence that matches. */ + cl_index cn = 0, next; + for (next = i+1; + next < lp && ((cn = ecl_char(p, next)) == '*'); + next++) + ; + if (next == lp) { + return TRUE; + } + while (j < ls) { + if (ecl_string_match(s, j, ls, p, next, lp)) { + return TRUE; } - /* At the end all characters should have been matched */ - return (j >= ls); + j++; + } + return FALSE; + break; + } + case '?': + /* Match any character */ + if (j > ls) return FALSE; + i++; j++; + break; + case '\\': + /* Interpret a pattern character literally. + Trailing slash is interpreted as a slash. */ + if (++i >= lp) i--; + default: + if ((j >= ls) || (cp != ecl_char(s, j))) { + /* Either there are no characters left in "s" + * or the next character does not match. */ + return FALSE; + } + i++; j++; + } + } + /* At the end all characters should have been matched */ + return (j >= ls); } 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 (!ecl_stringp(a) || mask == ECL_NIL) - return (a == mask); - if (!ecl_stringp(mask)) - FEerror("~S is not supported as mask for pathname-match-p", 1, mask); - return ecl_string_match(a, 0, ecl_length(a), - mask, 0, ecl_length(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 (!ecl_stringp(a) || mask == ECL_NIL) + return (a == mask); + if (!ecl_stringp(mask)) + FEerror("~S is not supported as mask for pathname-match-p", 1, mask); + return ecl_string_match(a, 0, ecl_length(a), + mask, 0, ecl_length(mask)); } static bool path_list_match(cl_object a, cl_object mask) { - cl_object item_mask; - while (!ecl_endp(mask)) { - item_mask = CAR(mask); - mask = CDR(mask); - if (item_mask == @':wild-inferiors') { - if (ecl_endp(mask)) - return TRUE; - while (!ecl_endp(a)) { - if (path_list_match(a, mask)) - return TRUE; - a = CDR(a); - } - return FALSE; - } else if (ecl_endp(a)) { - /* A NIL directory should match against :absolute - or :relative, in order to perform suitable translations. */ - if (item_mask != @':absolute' && item_mask != @':relative') - return FALSE; - } else if (!path_item_match(CAR(a), item_mask)) { - return FALSE; - } else { - a = CDR(a); - } - } - if (!ecl_endp(a)) - return FALSE; + cl_object item_mask; + while (!ecl_endp(mask)) { + item_mask = CAR(mask); + mask = CDR(mask); + if (item_mask == @':wild-inferiors') { + if (ecl_endp(mask)) return TRUE; + while (!ecl_endp(a)) { + if (path_list_match(a, mask)) + return TRUE; + a = CDR(a); + } + return FALSE; + } else if (ecl_endp(a)) { + /* A NIL directory should match against :absolute + or :relative, in order to perform suitable translations. */ + if (item_mask != @':absolute' && item_mask != @':relative') + return FALSE; + } else if (!path_item_match(CAR(a), item_mask)) { + return FALSE; + } else { + a = CDR(a); + } + } + if (!ecl_endp(a)) + return FALSE; + return TRUE; } cl_object cl_pathname_match_p(cl_object path, cl_object mask) { - cl_object output = ECL_NIL; - path = cl_pathname(path); - mask = cl_pathname(mask); - if (path->pathname.logical != mask->pathname.logical) - goto OUTPUT; + cl_object output = ECL_NIL; + path = cl_pathname(path); + mask = cl_pathname(mask); + if (path->pathname.logical != mask->pathname.logical) + goto OUTPUT; #if 0 - /* INV: This was checked in the calling routine */ - if (!path_item_match(path->pathname.host, mask->pathname.host)) - goto OUTPUT; + /* INV: This was checked in the calling routine */ + if (!path_item_match(path->pathname.host, mask->pathname.host)) + goto OUTPUT; #endif - /* Missing components default to :WILD */ - if (!Null(mask->pathname.directory) && - !path_list_match(path->pathname.directory, mask->pathname.directory)) - goto OUTPUT; - if (!path_item_match(path->pathname.name, mask->pathname.name)) - goto OUTPUT; - if (!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 = ECL_T; + /* Missing components default to :WILD */ + if (!Null(mask->pathname.directory) && + !path_list_match(path->pathname.directory, mask->pathname.directory)) + goto OUTPUT; + if (!path_item_match(path->pathname.name, mask->pathname.name)) + goto OUTPUT; + if (!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 = ECL_T; OUTPUT: - @(return output) + @(return output); } /* --------------- PATHNAME TRANSLATIONS ------------------ */ @@ -1509,304 +1507,302 @@ cl_pathname_match_p(cl_object path, cl_object mask) static cl_object coerce_to_from_pathname(cl_object x, cl_object host) { - switch (ecl_t_of(x)) { + switch (ecl_t_of(x)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - x = cl_parse_namestring(2, x, host); - case t_pathname: - if (x->pathname.logical) - return x; - default: - FEerror("~S is not a valid from-pathname translation", 1, x); - } + case t_base_string: + x = cl_parse_namestring(2, x, host); + case t_pathname: + if (x->pathname.logical) + return x; + default: + FEerror("~S is not a valid from-pathname translation", 1, x); + } } @(defun si::pathname-translations (host &optional (set OBJNULL)) - cl_index parsed_len, len; - cl_object pair, l; + cl_index parsed_len, len; + cl_object pair, l; @ - /* Check that host is a valid host name */ - if (ecl_unlikely(!ECL_STRINGP(host))) - FEwrong_type_nth_arg(@[si::pathname-translations], 1, host, @[string]); - host = cl_string_upcase(1, host); - len = ecl_length(host); - parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len); - if (parsed_len < len) { - FEerror("Wrong host syntax ~S", 1, host); - } - /* Find its translation list */ - pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'); - if (set == OBJNULL) { - @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); - } - /* Set the new translation list */ - if (ecl_unlikely(!LISTP(set))) { - FEwrong_type_nth_arg(@[si::pathname-translations], 2, set, @[list]); - } - if (pair == ECL_NIL) { - pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); - cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); - } - for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { - cl_object item = CAR(l); - cl_object from = coerce_to_from_pathname(cl_car(item), host); - cl_object to = cl_pathname(cl_cadr(item)); - set = CONS(CONS(from, CONS(to, ECL_NIL)), set); - } - set = cl_nreverse(set); - ECL_RPLACA(ECL_CONS_CDR(pair), set); - @(return set) + /* Check that host is a valid host name */ + if (ecl_unlikely(!ECL_STRINGP(host))) + FEwrong_type_nth_arg(@[si::pathname-translations], 1, host, @[string]); + host = cl_string_upcase(1, host); + len = ecl_length(host); + parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len); + if (parsed_len < len) { + FEerror("Wrong host syntax ~S", 1, host); + } + /* Find its translation list */ + pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'); + if (set == OBJNULL) { + @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); + } + /* Set the new translation list */ + if (ecl_unlikely(!LISTP(set))) { + FEwrong_type_nth_arg(@[si::pathname-translations], 2, set, @[list]); + } + if (pair == ECL_NIL) { + pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); + cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); + } + for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { + cl_object item = CAR(l); + cl_object from = coerce_to_from_pathname(cl_car(item), host); + cl_object to = cl_pathname(cl_cadr(item)); + set = CONS(CONS(from, CONS(to, ECL_NIL)), set); + } + set = cl_nreverse(set); + ECL_RPLACA(ECL_CONS_CDR(pair), set); + @(return set); @) static cl_object find_wilds(cl_object l, cl_object source, cl_object match) { - cl_index i, j, k, ls, lm; + cl_index i, j, k, ls, lm; - if (match == @':wild') - return ecl_list1(source); - if (!ecl_stringp(match) || !ecl_stringp(source)) { - if (match != source) - return @':error'; - return l; - } - ls = ecl_length(source); - lm = ecl_length(match); - for(i = j = 0; i < ls && j < lm; ) { - cl_index pattern_char = ecl_char(match,j); - if (pattern_char == '*') { - for (j++, k = i; - k < ls && ecl_char(source,k) != pattern_char; - k++) - ; - l = CONS(make_one(source, i, k), l); - i = k; - continue; - } - if (ecl_char(source,i) != pattern_char) - return @':error'; - i++, j++; - } - if (i < ls || j < lm) - return @':error'; - return l; + if (match == @':wild') + return ecl_list1(source); + if (!ecl_stringp(match) || !ecl_stringp(source)) { + if (match != source) + return @':error'; + return l; + } + ls = ecl_length(source); + lm = ecl_length(match); + for(i = j = 0; i < ls && j < lm; ) { + cl_index pattern_char = ecl_char(match,j); + if (pattern_char == '*') { + for (j++, k = i; + k < ls && ecl_char(source,k) != pattern_char; + k++) + ; + l = CONS(make_one(source, i, k), l); + i = k; + continue; + } + if (ecl_char(source,i) != pattern_char) + return @':error'; + i++, j++; + } + if (i < ls || j < lm) + return @':error'; + return l; } static cl_object find_list_wilds(cl_object a, cl_object mask) { - cl_object l = ECL_NIL, l2; + cl_object l = ECL_NIL, l2; - while (!ecl_endp(mask)) { - cl_object item_mask = CAR(mask); - mask = CDR(mask); - if (item_mask == @':wild-inferiors') { - l2 = ECL_NIL; - while (!path_list_match(a, mask)) { - if (ecl_endp(a)) - return @':error'; - l2 = CONS(CAR(a),l2); - a = CDR(a); - } - l = CONS(l2, l); - } else if (ecl_endp(a)) { - /* A NIL directory should match against :absolute - or :relative, in order to perform suitable translations. */ - if (item_mask != @':absolute' && item_mask != @':relative') - return @':error'; - } else { - l2 = find_wilds(l, CAR(a), item_mask); - if (l == @':error') - return @':error'; - if (!Null(l2)) - l = CONS(l2, l); - a = CDR(a); - } - } - return @nreverse(l); + while (!ecl_endp(mask)) { + cl_object item_mask = CAR(mask); + mask = CDR(mask); + if (item_mask == @':wild-inferiors') { + l2 = ECL_NIL; + while (!path_list_match(a, mask)) { + if (ecl_endp(a)) + return @':error'; + l2 = CONS(CAR(a),l2); + a = CDR(a); + } + l = CONS(l2, l); + } else if (ecl_endp(a)) { + /* A NIL directory should match against :absolute + or :relative, in order to perform suitable translations. */ + if (item_mask != @':absolute' && item_mask != @':relative') + return @':error'; + } else { + l2 = find_wilds(l, CAR(a), item_mask); + if (l == @':error') + return @':error'; + if (!Null(l2)) + l = CONS(l2, l); + a = CDR(a); + } + } + return @nreverse(l); } static cl_object copy_wildcards(cl_object *wilds_list, cl_object pattern) { - cl_index i, l, j; - bool new_string; - cl_object wilds = *wilds_list, token; + cl_index i, l, j; + bool new_string; + cl_object wilds = *wilds_list, token; - if (pattern == @':wild') { - if (ecl_endp(wilds)) - return @':error'; - pattern = CAR(wilds); - *wilds_list = CDR(wilds); - return pattern; - } - if (pattern == @':wild-inferiors') - return @':error'; - if (!ecl_stringp(pattern)) - return pattern; + if (pattern == @':wild') { + if (ecl_endp(wilds)) + return @':error'; + pattern = CAR(wilds); + *wilds_list = CDR(wilds); + return pattern; + } + if (pattern == @':wild-inferiors') + return @':error'; + if (!ecl_stringp(pattern)) + return pattern; - new_string = FALSE; - l = ecl_length(pattern); - token = si_get_buffer_string(); - for (j = i = 0; i < l; ) { - cl_index c = ecl_char(pattern, i); - if (c != '*') { - i++; - continue; - } - if (i != j) { - push_substring(token, pattern, j, i); - } - new_string = TRUE; - if (ecl_endp(wilds)) { - return @':error'; - } - push_string(token, CAR(wilds)); - wilds = CDR(wilds); - j = i++; - } - /* Only create a new string when needed */ - if (new_string) { - pattern = cl_copy_seq(token); - } - si_put_buffer_string(token); - *wilds_list = wilds; - return pattern; + new_string = FALSE; + l = ecl_length(pattern); + token = si_get_buffer_string(); + for (j = i = 0; i < l; ) { + cl_index c = ecl_char(pattern, i); + if (c != '*') { + i++; + continue; + } + if (i != j) { + push_substring(token, pattern, j, i); + } + new_string = TRUE; + if (ecl_endp(wilds)) { + return @':error'; + } + push_string(token, CAR(wilds)); + wilds = CDR(wilds); + j = i++; + } + /* Only create a new string when needed */ + if (new_string) { + pattern = cl_copy_seq(token); + } + si_put_buffer_string(token); + *wilds_list = wilds; + return pattern; } static cl_object copy_list_wildcards(cl_object *wilds, cl_object to) { - cl_object l = ECL_NIL; + cl_object l = ECL_NIL; - while (!ecl_endp(to)) { - cl_object d, mask = CAR(to); - if (mask == @':wild-inferiors') { - cl_object list = *wilds; - if (ecl_endp(list)) - return @':error'; - else { - cl_object dirlist = CAR(list); - if (CONSP(dirlist)) - l = ecl_append(CAR(list), l); - else if (!Null(CAR(list))) - return @':error'; - } - *wilds = CDR(list); - } else { - d = copy_wildcards(wilds, CAR(to)); - if (d == @':error') - return d; - l = CONS(d, l); - } - to = CDR(to); - } - if (CONSP(l)) - l = @nreverse(l); - return l; + while (!ecl_endp(to)) { + cl_object d, mask = CAR(to); + if (mask == @':wild-inferiors') { + cl_object list = *wilds; + if (ecl_endp(list)) + return @':error'; + else { + cl_object dirlist = CAR(list); + if (CONSP(dirlist)) + l = ecl_append(CAR(list), l); + else if (!Null(CAR(list))) + return @':error'; + } + *wilds = CDR(list); + } else { + d = copy_wildcards(wilds, CAR(to)); + if (d == @':error') + return d; + l = CONS(d, l); + } + to = CDR(to); + } + if (CONSP(l)) + l = @nreverse(l); + return l; } @(defun translate-pathname (source from to &key ((:case scase) @':local')) - cl_object wilds, d; - cl_object host, device, directory, name, type, version; - cl_object fromcase, tocase; + cl_object wilds, d; + cl_object host, device, directory, name, type, version; + cl_object fromcase, tocase; @ - /* The pathname from which we get the data */ - source = cl_pathname(source); - /* The mask applied to the source pathname */ - from = cl_pathname(from); - fromcase = normalize_case(from, @':local'); - /* The pattern which says what the output should look like */ - to = cl_pathname(to); - tocase = normalize_case(to, @':local'); + /* The pathname from which we get the data */ + source = cl_pathname(source); + /* The mask applied to the source pathname */ + from = cl_pathname(from); + fromcase = normalize_case(from, @':local'); + /* The pattern which says what the output should look like */ + to = cl_pathname(to); + tocase = normalize_case(to, @':local'); - if (source->pathname.logical != from->pathname.logical) - goto error; + if (source->pathname.logical != from->pathname.logical) + goto error; - /* Match host names */ - if (cl_string_equal(2, source->pathname.host, from->pathname.host) == ECL_NIL) - goto error; - host = to->pathname.host; + /* Match host names */ + if (cl_string_equal(2, source->pathname.host, from->pathname.host) == ECL_NIL) + goto error; + host = to->pathname.host; - /* Logical pathnames do not have devices. We just overwrite it. */ - device = to->pathname.device; + /* Logical pathnames do not have devices. We just overwrite it. */ + device = to->pathname.device; - /* Match directories */ - wilds = find_list_wilds(source->pathname.directory, - from->pathname.directory); - if (wilds == @':error') goto error; - if (Null(to->pathname.directory)) { - /* Missing components are replaced */ - d = translate_list_case(source->pathname.directory, fromcase, tocase); - } else { - wilds = translate_list_case(wilds, fromcase, tocase); - d = copy_list_wildcards(&wilds, to->pathname.directory); - if (d == @':error') goto error; - if (wilds != ECL_NIL) goto error2; - } - directory = d; + /* Match directories */ + wilds = find_list_wilds(source->pathname.directory, + from->pathname.directory); + if (wilds == @':error') goto error; + if (Null(to->pathname.directory)) { + /* Missing components are replaced */ + d = translate_list_case(source->pathname.directory, fromcase, tocase); + } else { + wilds = translate_list_case(wilds, fromcase, tocase); + d = copy_list_wildcards(&wilds, to->pathname.directory); + if (d == @':error') goto error; + if (wilds != ECL_NIL) goto error2; + } + directory = d; - /* Match name */ - wilds = find_wilds(ECL_NIL, source->pathname.name, from->pathname.name); - if (wilds == @':error') goto error2; - if (Null(to->pathname.name)) { - d = translate_component_case(source->pathname.name, fromcase, tocase); - } else { - wilds = translate_list_case(wilds, fromcase, tocase); - d = copy_wildcards(&wilds, to->pathname.name); - if (d == @':error') goto error; - if (wilds != ECL_NIL) goto error2; - } - name = d; + /* Match name */ + wilds = find_wilds(ECL_NIL, source->pathname.name, from->pathname.name); + if (wilds == @':error') goto error2; + if (Null(to->pathname.name)) { + d = translate_component_case(source->pathname.name, fromcase, tocase); + } else { + wilds = translate_list_case(wilds, fromcase, tocase); + d = copy_wildcards(&wilds, to->pathname.name); + if (d == @':error') goto error; + if (wilds != ECL_NIL) goto error2; + } + name = d; - /* Match type */ - wilds = find_wilds(ECL_NIL, source->pathname.type, from->pathname.type); - if (wilds == @':error') goto error2; - if (Null(to->pathname.type)) { - d = translate_component_case(source->pathname.type, fromcase, tocase); - } else { - wilds = translate_list_case(wilds, fromcase, tocase); - d = copy_wildcards(&wilds, to->pathname.type); - if (d == @':error') goto error; - if (wilds != ECL_NIL) goto error2; - } - type = d; + /* Match type */ + wilds = find_wilds(ECL_NIL, source->pathname.type, from->pathname.type); + if (wilds == @':error') goto error2; + if (Null(to->pathname.type)) { + d = translate_component_case(source->pathname.type, fromcase, tocase); + } else { + wilds = translate_list_case(wilds, fromcase, tocase); + d = copy_wildcards(&wilds, to->pathname.type); + if (d == @':error') goto error; + if (wilds != ECL_NIL) goto error2; + } + type = d; - /* Match version */ - version = to->pathname.version; - if (from->pathname.version == @':wild') { - if (to->pathname.version == @':wild') { - version = source->pathname.version; - } - } - @(return ecl_make_pathname(host, device, directory, name, type, - version, tocase)); + /* Match version */ + version = to->pathname.version; + if (from->pathname.version == @':wild') { + if (to->pathname.version == @':wild') { + version = source->pathname.version; + } + } + @(return ecl_make_pathname(host, device, directory, name, type, + version, tocase)); error: - FEerror("~S is not a specialization of path ~S", 2, source, from); + FEerror("~S is not a specialization of path ~S", 2, source, from); error2: - FEerror("Number of wildcards in ~S do not match ~S", 2, from, to); + FEerror("Number of wildcards in ~S do not match ~S", 2, from, to); @) @(defun translate-logical-pathname (source &key) - cl_object l, pair; - cl_object pathname; + cl_object l, pair; + cl_object pathname; @ - pathname = cl_pathname(source); + pathname = cl_pathname(source); begin: - if (!pathname->pathname.logical) { - @(return pathname) - } - l = @si::pathname-translations(1, pathname->pathname.host); - for(; !ecl_endp(l); l = CDR(l)) { - pair = CAR(l); - if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) { - pathname = cl_translate_pathname(3, pathname, - CAR(pair), - CADR(pair)); - goto begin; - } - } - FEerror("~S admits no logical pathname translations", 1, pathname); + if (!pathname->pathname.logical) { + @(return pathname); + } + l = @si::pathname-translations(1, pathname->pathname.host); + for(; !ecl_endp(l); l = CDR(l)) { + pair = CAR(l); + if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) { + pathname = cl_translate_pathname(3, pathname, CAR(pair), CADR(pair)); + goto begin; + } + } + FEerror("~S admits no logical pathname translations", 1, pathname); @) diff --git a/src/c/predicate.d b/src/c/predicate.d index e554b7820..8b5550a67 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - predicate.c -- Predicates. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * predicate.d - predicates + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #define ECL_INCLUDE_MATH_H @@ -25,224 +20,224 @@ cl_object cl_identity(cl_object x) { - @(return x) + @(return x); } cl_object cl_null(cl_object x) { - @(return (Null(x) ? ECL_T : ECL_NIL)) + @(return (Null(x) ? ECL_T : ECL_NIL)); } cl_object cl_symbolp(cl_object x) { - @(return (ECL_SYMBOLP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_SYMBOLP(x) ? ECL_T : ECL_NIL)); } cl_object cl_atom(cl_object x) { - @(return (ECL_ATOM(x) ? ECL_T : ECL_NIL)) + @(return (ECL_ATOM(x) ? ECL_T : ECL_NIL)); } cl_object cl_consp(cl_object x) { - @(return (CONSP(x) ? ECL_T : ECL_NIL)) + @(return (CONSP(x) ? ECL_T : ECL_NIL)); } cl_object cl_listp(cl_object x) { - @(return ((Null(x) || CONSP(x)) ? ECL_T : ECL_NIL)) + @(return ((Null(x) || CONSP(x)) ? ECL_T : ECL_NIL)); } cl_object cl_numberp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return (ECL_NUMBER_TYPE_P(t) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return (ECL_NUMBER_TYPE_P(t) ? ECL_T : ECL_NIL)); } /* Used in compiled code */ bool ecl_numberp(cl_object x) { - cl_type t = ecl_t_of(x); - return ECL_NUMBER_TYPE_P(t); + cl_type t = ecl_t_of(x); + return ECL_NUMBER_TYPE_P(t); } cl_object cl_integerp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_fixnum || t == t_bignum) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_fixnum || t == t_bignum) ? ECL_T : ECL_NIL)); } cl_object cl_rationalp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_fixnum || t == t_bignum || t == t_ratio) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_fixnum || t == t_bignum || t == t_ratio) ? ECL_T : ECL_NIL)); } cl_object cl_floatp(cl_object x) { - @(return (floatp(x)? ECL_T : ECL_NIL)) + @(return (floatp(x)? ECL_T : ECL_NIL)); } bool floatp(cl_object x) { - cl_type t = ecl_t_of(x); - return (t == t_singlefloat) || (t == t_doublefloat) + cl_type t = ecl_t_of(x); + return (t == t_singlefloat) || (t == t_doublefloat) #ifdef ECL_LONG_FLOAT - || (t == t_longfloat) + || (t == t_longfloat) #endif - ; + ; } cl_object cl_realp(cl_object x) { - cl_type t = ecl_t_of(x); - @(return (ECL_REAL_TYPE_P(t) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return (ECL_REAL_TYPE_P(t) ? ECL_T : ECL_NIL)); } bool ecl_realp(cl_object x) { - cl_type t = ecl_t_of(x); - return ECL_REAL_TYPE_P(t); + cl_type t = ecl_t_of(x); + return ECL_REAL_TYPE_P(t); } cl_object cl_complexp(cl_object x) { - @(return (ECL_COMPLEXP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_COMPLEXP(x) ? ECL_T : ECL_NIL)); } cl_object cl_characterp(cl_object x) { - @(return (ECL_CHARACTERP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_CHARACTERP(x) ? ECL_T : ECL_NIL)); } #ifdef ECL_UNICODE cl_object si_base_char_p(cl_object c) { - @(return ((ECL_CHARACTERP(c) && ECL_BASE_CHAR_P(c))? ECL_T : ECL_NIL)) + @(return ((ECL_CHARACTERP(c) && ECL_BASE_CHAR_P(c))? ECL_T : ECL_NIL)); } #endif bool ecl_stringp(cl_object x) { - cl_type t = ecl_t_of(x); + cl_type t = ecl_t_of(x); #ifdef ECL_UNICODE - return t == t_base_string || t == t_string; + return t == t_base_string || t == t_string; #else - return t == t_base_string; + return t == t_base_string; #endif } cl_object cl_stringp(cl_object x) { - @(return (ECL_STRINGP(x)? ECL_T : ECL_NIL)) + @(return (ECL_STRINGP(x)? ECL_T : ECL_NIL)); } cl_object cl_bit_vector_p(cl_object x) { - @(return (ECL_BIT_VECTOR_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_BIT_VECTOR_P(x) ? ECL_T : ECL_NIL)); } cl_object cl_vectorp(cl_object x) { - @(return (ECL_VECTORP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_VECTORP(x) ? ECL_T : ECL_NIL)); } cl_object cl_simple_string_p(cl_object x) { - @(return ((ECL_STRINGP(x) && - !ECL_ADJUSTABLE_ARRAY_P(x) && - !ECL_ARRAY_HAS_FILL_POINTER_P(x) && - Null(CAR(x->base_string.displaced))) ? ECL_T : ECL_NIL)) + @(return ((ECL_STRINGP(x) && + !ECL_ADJUSTABLE_ARRAY_P(x) && + !ECL_ARRAY_HAS_FILL_POINTER_P(x) && + Null(CAR(x->base_string.displaced))) ? ECL_T : ECL_NIL)); } #ifdef ECL_UNICODE cl_object si_base_string_p(cl_object x) { - @(return (ECL_BASE_STRING_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_BASE_STRING_P(x) ? ECL_T : ECL_NIL)); } #endif cl_object cl_simple_bit_vector_p(cl_object x) { - @(return ((ECL_BIT_VECTOR_P(x) && - !ECL_ADJUSTABLE_ARRAY_P(x) && - !ECL_ARRAY_HAS_FILL_POINTER_P(x) && - Null(CAR(x->vector.displaced))) ? ECL_T : ECL_NIL)) + @(return ((ECL_BIT_VECTOR_P(x) && + !ECL_ADJUSTABLE_ARRAY_P(x) && + !ECL_ARRAY_HAS_FILL_POINTER_P(x) && + Null(CAR(x->vector.displaced))) ? ECL_T : ECL_NIL)); } cl_object cl_simple_vector_p(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_vector && - !ECL_ADJUSTABLE_ARRAY_P(x) && - !ECL_ARRAY_HAS_FILL_POINTER_P(x) && - Null(CAR(x->vector.displaced)) && - (cl_elttype)x->vector.elttype == ecl_aet_object) ? ECL_T : ECL_NIL)) + cl_type t = ecl_t_of(x); + @(return ((t == t_vector && + !ECL_ADJUSTABLE_ARRAY_P(x) && + !ECL_ARRAY_HAS_FILL_POINTER_P(x) && + Null(CAR(x->vector.displaced)) && + (cl_elttype)x->vector.elttype == ecl_aet_object) ? ECL_T : ECL_NIL)); } cl_object cl_arrayp(cl_object x) { - @(return (ECL_ARRAYP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_ARRAYP(x) ? ECL_T : ECL_NIL)); } cl_object cl_packagep(cl_object x) { - @(return (ECL_PACKAGEP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_PACKAGEP(x) ? ECL_T : ECL_NIL)); } cl_object cl_functionp(cl_object x) { - cl_type t; - cl_object output; + cl_type t; + cl_object output; - t = ecl_t_of(x); - if (t == t_bytecodes || t == t_bclosure || t == t_cfun - || t == t_cfunfixed || t == t_cclosure - || (t == t_instance && x->instance.isgf)) - output = ECL_T; - else - output = ECL_NIL; - @(return output) + t = ecl_t_of(x); + if (t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure + || (t == t_instance && x->instance.isgf)) + output = ECL_T; + else + output = ECL_NIL; + @(return output); } cl_object cl_compiled_function_p(cl_object x) { - cl_type t = ecl_t_of(x); - @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun - || t == t_cfunfixed || t == t_cclosure) ? ECL_T : ECL_NIL)) -} + cl_type t = ecl_t_of(x); + @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure) ? ECL_T : ECL_NIL)) + } cl_object cl_eq(cl_object x, cl_object y) { - @(return ((x == y) ? ECL_T : ECL_NIL)) + @(return ((x == y) ? ECL_T : ECL_NIL)); } /* @@ -262,267 +257,267 @@ cl_eq(cl_object x, cl_object y) #if !defined(ECL_SIGNED_ZERO) && !defined(ECL_IEEE_FP) # define FLOAT_EQL(a,b,type) return (a) == (b) #else -# define FLOAT_EQL(a,b,type) { \ - type xa = (a), xb = (b); \ - if (xa == xb) { \ - return signbit(xa) == signbit(xb); \ - } else if (isnan(xa) || isnan(xb)) { \ - return !memcmp(&xa, &xb, sizeof(type)); \ - } else { \ - return 0; \ - } } +# define FLOAT_EQL(a,b,type) { \ + type xa = (a), xb = (b); \ + if (xa == xb) { \ + return signbit(xa) == signbit(xb); \ + } else if (isnan(xa) || isnan(xb)) { \ + return !memcmp(&xa, &xb, sizeof(type)); \ + } else { \ + return 0; \ + } } #endif bool ecl_eql(cl_object x, cl_object y) { - if (x == y) - return TRUE; - if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y)) - return FALSE; - if (x->d.t != y->d.t) - return FALSE; - switch (x->d.t) { - case t_bignum: - return (_ecl_big_compare(x, y) == 0); - case t_ratio: - return (ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den)); - case t_singlefloat: - FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); - case t_doublefloat: - FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); + if (x == y) + return TRUE; + if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y)) + return FALSE; + if (x->d.t != y->d.t) + return FALSE; + switch (x->d.t) { + case t_bignum: + return (_ecl_big_compare(x, y) == 0); + case t_ratio: + return (ecl_eql(x->ratio.num, y->ratio.num) && + ecl_eql(x->ratio.den, y->ratio.den)); + case t_singlefloat: + FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); + case t_doublefloat: + FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); #ifdef ECL_LONG_FLOAT - case t_longfloat: - FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); + case t_longfloat: + FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); #endif - case t_complex: - return (ecl_eql(x->complex.real, y->complex.real) && - ecl_eql(x->complex.imag, y->complex.imag)); + case t_complex: + return (ecl_eql(x->complex.real, y->complex.real) && + ecl_eql(x->complex.imag, y->complex.imag)); #ifdef ECL_SSE2 - case t_sse_pack: - return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); + case t_sse_pack: + return !memcmp(x->sse.data.b8, y->sse.data.b8, 16); #endif - default: - return FALSE; - } + default: + return FALSE; + } } cl_object cl_eql(cl_object x, cl_object y) { - @(return (ecl_eql(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_eql(x, y) ? ECL_T : ECL_NIL)); } bool ecl_equal(register cl_object x, cl_object y) { - cl_type tx, ty; -BEGIN: - if (x==y) - return(TRUE); - tx = ecl_t_of(x); - ty = ecl_t_of(y); - switch (tx) { - case t_list: - if (Null(x) || Null(y)) { - /* If X is NIL, then X and Y must be EQ */ - return FALSE; - } - if (tx != ty || !ecl_equal(CAR(x), CAR(y))) - return FALSE; - x = CDR(x); - y = CDR(y); - goto BEGIN; - case t_symbol: - case t_vector: - case t_array: - case t_fixnum: - return FALSE; - case t_bignum: - return (tx == ty) && (_ecl_big_compare(x,y) == 0); - case t_ratio: - return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) && - ecl_eql(x->ratio.den, y->ratio.den); - case t_singlefloat: { - if (tx != ty) return 0; - FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); - } - case t_doublefloat: { - if (tx != ty) return 0; - FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); - } + cl_type tx, ty; + BEGIN: + if (x==y) + return(TRUE); + tx = ecl_t_of(x); + ty = ecl_t_of(y); + switch (tx) { + case t_list: + if (Null(x) || Null(y)) { + /* If X is NIL, then X and Y must be EQ */ + return FALSE; + } + if (tx != ty || !ecl_equal(CAR(x), CAR(y))) + return FALSE; + x = CDR(x); + y = CDR(y); + goto BEGIN; + case t_symbol: + case t_vector: + case t_array: + case t_fixnum: + return FALSE; + case t_bignum: + return (tx == ty) && (_ecl_big_compare(x,y) == 0); + case t_ratio: + return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) && + ecl_eql(x->ratio.den, y->ratio.den); + case t_singlefloat: { + if (tx != ty) return 0; + FLOAT_EQL(ecl_single_float(x), ecl_single_float(y), float); + } + case t_doublefloat: { + if (tx != ty) return 0; + FLOAT_EQL(ecl_double_float(x), ecl_double_float(y), double); + } #ifdef ECL_LONG_FLOAT - case t_longfloat: { - if (tx != ty) return 0; - FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); - } + case t_longfloat: { + if (tx != ty) return 0; + FLOAT_EQL(ecl_long_float(x), ecl_long_float(y), long double); + } #endif - case t_complex: - return (tx == ty) && ecl_eql(x->complex.real, y->complex.real) && - ecl_eql(x->complex.imag, y->complex.imag); - case t_character: - return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y)); - case t_base_string: + case t_complex: + return (tx == ty) && ecl_eql(x->complex.real, y->complex.real) && + ecl_eql(x->complex.imag, y->complex.imag); + case t_character: + return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y)); + case t_base_string: #ifdef ECL_UNICODE - case t_string: - if (ty != t_base_string && ty != t_string) - return FALSE; + case t_string: + if (ty != t_base_string && ty != t_string) + return FALSE; #else - if (ty != t_base_string) - return FALSE; + if (ty != t_base_string) + return FALSE; #endif - return ecl_string_eq(x, y); - case t_bitvector: { - cl_index i, ox, oy; - if (ty != tx) - return FALSE; - if (x->vector.fillp != y->vector.fillp) - return(FALSE); - ox = x->vector.offset; - oy = y->vector.offset; - for (i = 0; i < x->vector.fillp; i++) - if((x->vector.self.bit[(i+ox)/8] & (0200>>(i+ox)%8)) - !=(y->vector.self.bit[(i+oy)/8] & (0200>>(i+oy)%8))) - return(FALSE); - return(TRUE); - } - case t_pathname: - return ty == tx && - ecl_equal(x->pathname.host, y->pathname.host) && - ecl_equal(x->pathname.device, y->pathname.device) && - ecl_equal(x->pathname.directory, y->pathname.directory) && - ecl_equal(x->pathname.name, y->pathname.name) && - ecl_equal(x->pathname.type, y->pathname.type) && - ecl_equal(x->pathname.version, y->pathname.version); - case t_foreign: - return (tx == ty) && (x->foreign.data == y->foreign.data); - default: - return FALSE; - } + return ecl_string_eq(x, y); + case t_bitvector: { + cl_index i, ox, oy; + if (ty != tx) + return FALSE; + if (x->vector.fillp != y->vector.fillp) + return(FALSE); + ox = x->vector.offset; + oy = y->vector.offset; + for (i = 0; i < x->vector.fillp; i++) + if((x->vector.self.bit[(i+ox)/8] & (0200>>(i+ox)%8)) + !=(y->vector.self.bit[(i+oy)/8] & (0200>>(i+oy)%8))) + return(FALSE); + return(TRUE); + } + case t_pathname: + return ty == tx && + ecl_equal(x->pathname.host, y->pathname.host) && + ecl_equal(x->pathname.device, y->pathname.device) && + ecl_equal(x->pathname.directory, y->pathname.directory) && + ecl_equal(x->pathname.name, y->pathname.name) && + ecl_equal(x->pathname.type, y->pathname.type) && + ecl_equal(x->pathname.version, y->pathname.version); + case t_foreign: + return (tx == ty) && (x->foreign.data == y->foreign.data); + default: + return FALSE; + } } cl_object cl_equal(cl_object x, cl_object y) { - @(return (ecl_equal(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_equal(x, y) ? ECL_T : ECL_NIL)); } bool ecl_equalp(cl_object x, cl_object y) { - cl_type tx, ty; - cl_index j; -BEGIN: - if (x == y) - return TRUE; - tx = ecl_t_of(x); - ty = ecl_t_of(y); + cl_type tx, ty; + cl_index j; + BEGIN: + if (x == y) + return TRUE; + tx = ecl_t_of(x); + ty = ecl_t_of(y); - switch (tx) { - case t_fixnum: - case t_bignum: - case t_ratio: - case t_singlefloat: - case t_doublefloat: + switch (tx) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - case t_complex: - return ECL_NUMBER_TYPE_P(ty) && ecl_number_equalp(x, y); - case t_vector: - case t_base_string: - case t_bitvector: + case t_complex: + return ECL_NUMBER_TYPE_P(ty) && ecl_number_equalp(x, y); + case t_vector: + case t_base_string: + case t_bitvector: #ifdef ECL_UNICODE - case t_string: - if (ty != t_vector && ty != t_base_string && ty != t_bitvector - && ty != t_string) - return FALSE; + case t_string: + if (ty != t_vector && ty != t_base_string && ty != t_bitvector + && ty != t_string) + return FALSE; #else - if (ty != t_vector && ty != t_base_string && ty != t_bitvector) - return FALSE; + if (ty != t_vector && ty != t_base_string && ty != t_bitvector) + return FALSE; #endif - j = x->vector.fillp; - if (j != y->vector.fillp) - return FALSE; - goto ARRAY; - case t_array: - if (ty != t_array || x->array.rank != y->array.rank) - return FALSE; - if (x->array.rank > 1) { - cl_index i = 0; - for (i = 0; i < x->array.rank; i++) - if (x->array.dims[i] != y->array.dims[i]) - return(FALSE); - } - if (x->array.dim != y->array.dim) - return(FALSE); - j=x->array.dim; - ARRAY: { - cl_index i; - for (i = 0; i < j; i++) - if (!ecl_equalp(ecl_aref_unsafe(x, i), ecl_aref_unsafe(y, i))) - return(FALSE); - return(TRUE); - } - case t_character: - return (ty == tx) && ecl_char_equal(x, y); - case t_list: - if ((tx != ty) || Null(x) || Null(y)) { - /* X is NIL but it is not EQ to Y */ - return FALSE; - } - if (!ecl_equalp(CAR(x), CAR(y))) - return(FALSE); - x = CDR(x); - y = CDR(y); - goto BEGIN; - case t_instance: { - cl_index i; - if ((ty != tx) || (ECL_CLASS_OF(x) != ECL_CLASS_OF(y))) - return(FALSE); - for (i = 0; i < x->instance.length; i++) - if (!ecl_equalp(x->instance.slots[i], y->instance.slots[i])) - return(FALSE); - return(TRUE); - } - case t_pathname: - return (tx == ty) && ecl_equal(x, y); - case t_hashtable: { - if (tx != ty || - x->hash.entries != y->hash.entries || - x->hash.test != y->hash.test) - return(FALSE); - { - cl_env_ptr env = ecl_process_env(); - cl_object iterator = si_hash_table_iterator(x); - do { - cl_object ndx = _ecl_funcall1(iterator); - if (Null(ndx)) { - return TRUE; - } else { - cl_object key = env->values[1]; - if (ecl_gethash_safe(key, y, OBJNULL) == OBJNULL) - return FALSE; - } - } while (1); - } - } - case t_random: - return (tx == ty) && ecl_equalp(x->random.value, y->random.value); - default: - return ecl_eql(x,y); + j = x->vector.fillp; + if (j != y->vector.fillp) + return FALSE; + goto ARRAY; + case t_array: + if (ty != t_array || x->array.rank != y->array.rank) + return FALSE; + if (x->array.rank > 1) { + cl_index i = 0; + for (i = 0; i < x->array.rank; i++) + if (x->array.dims[i] != y->array.dims[i]) + return(FALSE); + } + if (x->array.dim != y->array.dim) + return(FALSE); + j=x->array.dim; + ARRAY: { + cl_index i; + for (i = 0; i < j; i++) + if (!ecl_equalp(ecl_aref_unsafe(x, i), ecl_aref_unsafe(y, i))) + return(FALSE); + return(TRUE); + } + case t_character: + return (ty == tx) && ecl_char_equal(x, y); + case t_list: + if ((tx != ty) || Null(x) || Null(y)) { + /* X is NIL but it is not EQ to Y */ + return FALSE; + } + if (!ecl_equalp(CAR(x), CAR(y))) + return(FALSE); + x = CDR(x); + y = CDR(y); + goto BEGIN; + case t_instance: { + cl_index i; + if ((ty != tx) || (ECL_CLASS_OF(x) != ECL_CLASS_OF(y))) + return(FALSE); + for (i = 0; i < x->instance.length; i++) + if (!ecl_equalp(x->instance.slots[i], y->instance.slots[i])) + return(FALSE); + return(TRUE); + } + case t_pathname: + return (tx == ty) && ecl_equal(x, y); + case t_hashtable: { + if (tx != ty || + x->hash.entries != y->hash.entries || + x->hash.test != y->hash.test) + return(FALSE); + { + cl_env_ptr env = ecl_process_env(); + cl_object iterator = si_hash_table_iterator(x); + do { + cl_object ndx = _ecl_funcall1(iterator); + if (Null(ndx)) { + return TRUE; + } else { + cl_object key = env->values[1]; + if (ecl_gethash_safe(key, y, OBJNULL) == OBJNULL) + return FALSE; } + } while (1); + } + } + case t_random: + return (tx == ty) && ecl_equalp(x->random.value, y->random.value); + default: + return ecl_eql(x,y); + } } cl_object cl_equalp(cl_object x, cl_object y) { - @(return (ecl_equalp(x, y) ? ECL_T : ECL_NIL)) + @(return (ecl_equalp(x, y) ? ECL_T : ECL_NIL)); } cl_object si_fixnump(cl_object x) { - @(return (ECL_FIXNUMP(x) ? ECL_T : ECL_NIL)) + @(return (ECL_FIXNUMP(x) ? ECL_T : ECL_NIL)); } diff --git a/src/c/print.d b/src/c/print.d index 26980a774..7390e35c7 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - print.d -- Print. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * print.d - print + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - See file '../Copyright' for full details. -*/ #include #include #include @@ -23,388 +19,389 @@ cl_object _ecl_stream_or_default_output(cl_object stream) { - if (Null(stream)) - return ecl_symbol_value(@'*standard-output*'); - else if (stream == ECL_T) - return ecl_symbol_value(@'*terminal-io*'); - return stream; + if (Null(stream)) + return ecl_symbol_value(@'*standard-output*'); + else if (stream == ECL_T) + return ecl_symbol_value(@'*terminal-io*'); + return stream; } int ecl_print_base(void) { - cl_object object = ecl_symbol_value(@'*print-base*'); - cl_fixnum base; - unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { - ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); - FEerror("The value of *PRINT-BASE*~% ~S~%" - "is not of the expected type (INTEGER 2 36)", 1, object); - } - return base; + cl_object object = ecl_symbol_value(@'*print-base*'); + cl_fixnum base; + unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) { + ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10)); + FEerror("The value of *PRINT-BASE*~% ~S~%" + "is not of the expected type (INTEGER 2 36)", 1, object); + } + return base; } cl_fixnum ecl_print_level(void) { - cl_object object = ecl_symbol_value(@'*print-level*'); - cl_fixnum level; - if (object == ECL_NIL) { - level = MOST_POSITIVE_FIXNUM; - } else if (ECL_FIXNUMP(object)) { - level = ecl_fixnum(object); - if (level < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); - FEerror("The value of *PRINT-LEVEL*~% ~S~%" - "is not of the expected type (OR NULL (INTEGER 0 *))", - 1, object); - } - } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { - goto ERROR; - } else { - level = MOST_POSITIVE_FIXNUM; - } - return level; + cl_object object = ecl_symbol_value(@'*print-level*'); + cl_fixnum level; + if (object == ECL_NIL) { + level = MOST_POSITIVE_FIXNUM; + } else if (ECL_FIXNUMP(object)) { + level = ecl_fixnum(object); + if (level < 0) { + ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL); + FEerror("The value of *PRINT-LEVEL*~% ~S~%" + "is not of the expected type (OR NULL (INTEGER 0 *))", + 1, object); + } + } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { + goto ERROR; + } else { + level = MOST_POSITIVE_FIXNUM; + } + return level; } cl_fixnum ecl_print_length(void) { - cl_object object = ecl_symbol_value(@'*print-length*'); - cl_fixnum length; - if (object == ECL_NIL) { - length = MOST_POSITIVE_FIXNUM; - } else if (ECL_FIXNUMP(object)) { - length = ecl_fixnum(object); - unlikely_if (length < 0) { - ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); - FEerror("The value of *PRINT-LENGTH*~% ~S~%" - "is not of the expected type (OR NULL (INTEGER 0 *))", - 1, object); - } - } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { - goto ERROR; - } else { - length = MOST_POSITIVE_FIXNUM; - } - return length; + cl_object object = ecl_symbol_value(@'*print-length*'); + cl_fixnum length; + if (object == ECL_NIL) { + length = MOST_POSITIVE_FIXNUM; + } else if (ECL_FIXNUMP(object)) { + length = ecl_fixnum(object); + unlikely_if (length < 0) { + ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL); + FEerror("The value of *PRINT-LENGTH*~% ~S~%" + "is not of the expected type (OR NULL (INTEGER 0 *))", + 1, object); + } + } else if (ecl_unlikely(!ECL_BIGNUMP(object))) { + goto ERROR; + } else { + length = MOST_POSITIVE_FIXNUM; + } + return length; } bool ecl_print_radix(void) { - return ecl_symbol_value(@'*print-radix*') != ECL_NIL; + return ecl_symbol_value(@'*print-radix*') != ECL_NIL; } cl_object ecl_print_case(void) { - cl_object output = ecl_symbol_value(@'*print-case*'); - unlikely_if (output != @':upcase' && - output != @':downcase' && - output != @':capitalize') - { - ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); - FEerror("The value of *PRINT-CASE*~% ~S~%" - "is not of the expected type " - "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output); - } - return output; + cl_object output = ecl_symbol_value(@'*print-case*'); + unlikely_if (output != @':upcase' && + output != @':downcase' && + output != @':capitalize') + { + ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); + FEerror("The value of *PRINT-CASE*~% ~S~%" + "is not of the expected type " + "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output); + } + return output; } bool ecl_print_gensym(void) { - return ecl_symbol_value(@'*print-gensym*') != ECL_NIL; + return ecl_symbol_value(@'*print-gensym*') != ECL_NIL; } bool ecl_print_array(void) { - return ecl_symbol_value(@'*print-array*') != ECL_NIL; + return ecl_symbol_value(@'*print-array*') != ECL_NIL; } bool ecl_print_readably(void) { - return ecl_symbol_value(@'*print-readably*') != ECL_NIL; + return ecl_symbol_value(@'*print-readably*') != ECL_NIL; } bool ecl_print_escape(void) { - return ecl_symbol_value(@'*print-escape*') != ECL_NIL; + return ecl_symbol_value(@'*print-escape*') != ECL_NIL; } bool ecl_print_circle(void) { - return ecl_symbol_value(@'*print-circle*') != ECL_NIL; + return ecl_symbol_value(@'*print-circle*') != ECL_NIL; } @(defun write (x &key ((:stream strm) ECL_NIL) - (array ecl_symbol_value(@'*print-array*')) - (base ecl_symbol_value(@'*print-base*')) - ((:case cas) ecl_symbol_value(@'*print-case*')) - (circle ecl_symbol_value(@'*print-circle*')) - (escape ecl_symbol_value(@'*print-escape*')) - (gensym ecl_symbol_value(@'*print-gensym*')) - (length ecl_symbol_value(@'*print-length*')) - (level ecl_symbol_value(@'*print-level*')) - (lines ecl_symbol_value(@'*print-lines*')) - (miser_width ecl_symbol_value(@'*print-miser-width*')) - (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) - (pretty ecl_symbol_value(@'*print-pretty*')) - (radix ecl_symbol_value(@'*print-radix*')) - (readably ecl_symbol_value(@'*print-readably*')) - (right_margin ecl_symbol_value(@'*print-right-margin*'))) -@{ - ecl_bds_bind(the_env, @'*print-array*', array); - ecl_bds_bind(the_env, @'*print-base*', base); - ecl_bds_bind(the_env, @'*print-case*', cas); - ecl_bds_bind(the_env, @'*print-circle*', circle); - ecl_bds_bind(the_env, @'*print-escape*', escape); - ecl_bds_bind(the_env, @'*print-gensym*', gensym); - ecl_bds_bind(the_env, @'*print-level*', level); - ecl_bds_bind(the_env, @'*print-length*', length); - ecl_bds_bind(the_env, @'*print-lines*', lines); - ecl_bds_bind(the_env, @'*print-miser-width*', miser_width); - ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch); - ecl_bds_bind(the_env, @'*print-pretty*', pretty); - ecl_bds_bind(the_env, @'*print-radix*', radix); - ecl_bds_bind(the_env, @'*print-readably*', readably); - ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); + (array ecl_symbol_value(@'*print-array*')) + (base ecl_symbol_value(@'*print-base*')) + ((:case cas) ecl_symbol_value(@'*print-case*')) + (circle ecl_symbol_value(@'*print-circle*')) + (escape ecl_symbol_value(@'*print-escape*')) + (gensym ecl_symbol_value(@'*print-gensym*')) + (length ecl_symbol_value(@'*print-length*')) + (level ecl_symbol_value(@'*print-level*')) + (lines ecl_symbol_value(@'*print-lines*')) + (miser_width ecl_symbol_value(@'*print-miser-width*')) + (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*')) + (pretty ecl_symbol_value(@'*print-pretty*')) + (radix ecl_symbol_value(@'*print-radix*')) + (readably ecl_symbol_value(@'*print-readably*')) + (right_margin ecl_symbol_value(@'*print-right-margin*'))) + @ + ecl_bds_bind(the_env, @'*print-array*', array); + ecl_bds_bind(the_env, @'*print-base*', base); + ecl_bds_bind(the_env, @'*print-case*', cas); + ecl_bds_bind(the_env, @'*print-circle*', circle); + ecl_bds_bind(the_env, @'*print-escape*', escape); + ecl_bds_bind(the_env, @'*print-gensym*', gensym); + ecl_bds_bind(the_env, @'*print-level*', level); + ecl_bds_bind(the_env, @'*print-length*', length); + ecl_bds_bind(the_env, @'*print-lines*', lines); + ecl_bds_bind(the_env, @'*print-miser-width*', miser_width); + ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch); + ecl_bds_bind(the_env, @'*print-pretty*', pretty); + ecl_bds_bind(the_env, @'*print-radix*', radix); + ecl_bds_bind(the_env, @'*print-readably*', readably); + ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); - strm = _ecl_stream_or_default_output(strm); - si_write_object(x, strm); - ecl_force_output(strm); + strm = _ecl_stream_or_default_output(strm); + si_write_object(x, strm); + ecl_force_output(strm); - ecl_bds_unwind_n(the_env, 15); - @(return x) -@) + ecl_bds_unwind_n(the_env, 15); + @(return x); + @) @(defun prin1 (obj &optional strm) -@ - ecl_prin1(obj, strm); - @(return obj) -@) + @ + ecl_prin1(obj, strm); + @(return obj); + @) @(defun print (obj &optional strm) -@ - ecl_print(obj, strm); - @(return obj) -@) + @ + ecl_print(obj, strm); + @(return obj); + @) @(defun pprint (obj &optional strm) -@ - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_T); - ecl_bds_bind(the_env, @'*print-pretty*', ECL_T); - ecl_write_char('\n', strm); - si_write_object(obj, strm); - ecl_force_output(strm); - ecl_bds_unwind_n(the_env, 2); - @(return) -@) + @ + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_T); + ecl_bds_bind(the_env, @'*print-pretty*', ECL_T); + ecl_write_char('\n', strm); + si_write_object(obj, strm); + ecl_force_output(strm); + ecl_bds_unwind_n(the_env, 2); + @(return); + @) @(defun princ (obj &optional strm) -@ - ecl_princ(obj, strm); - @(return obj) -@) + @ + ecl_princ(obj, strm); + @(return obj); + @) @(defun write-char (c &optional strm) -@ - /* INV: ecl_char_code() checks the type of `c' */ - strm = _ecl_stream_or_default_output(strm); - c = ECL_CODE_CHAR(ecl_write_char(ecl_char_code(c), strm)); - @(return c) -@) + @ + /* INV: ecl_char_code() checks the type of `c' */ + strm = _ecl_stream_or_default_output(strm); + c = ECL_CODE_CHAR(ecl_write_char(ecl_char_code(c), strm)); + @(return c); + @) @(defun write-string (strng &o strm &k (start ecl_make_fixnum(0)) end) -@ - unlikely_if (!ECL_STRINGP(strng)) - FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); - strm = _ecl_stream_or_default_output(strm); + @ + unlikely_if (!ECL_STRINGP(strng)) + FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) - _ecl_funcall5(@'gray::stream-write-string', strm, strng, start, end); - else + if (!ECL_ANSI_STREAM_P(strm)) + _ecl_funcall5(@'gray::stream-write-string', strm, strng, start, end); + else #endif - si_do_write_sequence(strng, strm, start, end); - @(return strng) -@) + si_do_write_sequence(strng, strm, start, end); + @(return strng); + @) @(defun write-line (strng &o strm &k (start ecl_make_fixnum(0)) end) -@ - unlikely_if (!ECL_STRINGP(strng)) - FEwrong_type_nth_arg(@[write-line], 1, strng, @[string]); - strm = _ecl_stream_or_default_output(strm); + @ + unlikely_if (!ECL_STRINGP(strng)) + FEwrong_type_nth_arg(@[write-line], 1, strng, @[string]); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) - _ecl_funcall5(@'gray::stream-write-string', strm, strng, - start, end); - else + if (!ECL_ANSI_STREAM_P(strm)) + _ecl_funcall5(@'gray::stream-write-string', strm, strng, + start, end); + else #endif - si_do_write_sequence(strng, strm, start, end); - ecl_terpri(strm); - @(return strng) -@) + si_do_write_sequence(strng, strm, start, end); + ecl_terpri(strm); + @(return strng); + @) @(defun terpri (&optional strm) -@ - ecl_terpri(strm); - @(return ECL_NIL) -@) + @ + ecl_terpri(strm); + @(return ECL_NIL); + @) @(defun fresh-line (&optional strm) -@ - strm = _ecl_stream_or_default_output(strm); + @ + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-fresh-line', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-fresh-line', strm); + } #endif - if (ecl_file_column(strm) == 0) - @(return ECL_NIL) - ecl_write_char('\n', strm); - ecl_force_output(strm); - @(return ECL_T) -@) + if (ecl_file_column(strm) == 0) { + @(return ECL_NIL); + } + ecl_write_char('\n', strm); + ecl_force_output(strm); + @(return ECL_T); + @) @(defun finish-output (&o strm) -@ - strm = _ecl_stream_or_default_output(strm); + @ + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-finish-output', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-finish-output', strm); + } #endif - ecl_force_output(strm); - @(return ECL_NIL) -@) + ecl_force_output(strm); + @(return ECL_NIL); + @) @(defun force-output (&o strm) -@ - strm = _ecl_stream_or_default_output(strm); - ecl_force_output(strm); - @(return ECL_NIL) -@) + @ + strm = _ecl_stream_or_default_output(strm); + ecl_force_output(strm); + @(return ECL_NIL); + @) @(defun clear-output (&o strm) -@ - strm = _ecl_stream_or_default_output(strm); - ecl_clear_output(strm); - @(return ECL_NIL) -@) + @ + strm = _ecl_stream_or_default_output(strm); + ecl_clear_output(strm); + @(return ECL_NIL); + @) cl_object cl_write_byte(cl_object integer, cl_object binary_output_stream) { - ecl_write_byte(integer, binary_output_stream); - @(return integer) + ecl_write_byte(integer, binary_output_stream); + @(return integer); } @(defun write-sequence (sequence stream &key (start ecl_make_fixnum(0)) end) -@ + @ #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(stream)) { - return _ecl_funcall5(@'gray::stream-write-sequence', - stream, sequence, start, end); - } else + if (!ECL_ANSI_STREAM_P(stream)) { + return _ecl_funcall5(@'gray::stream-write-sequence', + stream, sequence, start, end); + } else #endif - return si_do_write_sequence(sequence, stream, start, end); -@) + return si_do_write_sequence(sequence, stream, start, end); + @) cl_object ecl_princ(cl_object obj, cl_object strm) { - const cl_env_ptr the_env = ecl_process_env(); - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - si_write_object(obj, strm); - ecl_bds_unwind_n(the_env, 2); - return obj; + const cl_env_ptr the_env = ecl_process_env(); + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + si_write_object(obj, strm); + ecl_bds_unwind_n(the_env, 2); + return obj; } cl_object ecl_prin1(cl_object obj, cl_object strm) { - const cl_env_ptr the_env = ecl_process_env(); - strm = _ecl_stream_or_default_output(strm); - ecl_bds_bind(the_env, @'*print-escape*', ECL_T); - si_write_object(obj, strm); - ecl_force_output(strm); - ecl_bds_unwind1(the_env); - return obj; + const cl_env_ptr the_env = ecl_process_env(); + strm = _ecl_stream_or_default_output(strm); + ecl_bds_bind(the_env, @'*print-escape*', ECL_T); + si_write_object(obj, strm); + ecl_force_output(strm); + ecl_bds_unwind1(the_env); + return obj; } cl_object ecl_print(cl_object obj, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - ecl_terpri(strm); - ecl_prin1(obj, strm); - ecl_princ_char(' ', strm); - return obj; + strm = _ecl_stream_or_default_output(strm); + ecl_terpri(strm); + ecl_prin1(obj, strm); + ecl_princ_char(' ', strm); + return obj; } cl_object ecl_terpri(cl_object strm) { - strm = _ecl_stream_or_default_output(strm); + strm = _ecl_stream_or_default_output(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - return _ecl_funcall2(@'gray::stream-terpri', strm); - } + if (!ECL_ANSI_STREAM_P(strm)) { + return _ecl_funcall2(@'gray::stream-terpri', strm); + } #endif - ecl_write_char('\n', strm); - ecl_force_output(strm); - return(ECL_NIL); + ecl_write_char('\n', strm); + ecl_force_output(strm); + return(ECL_NIL); } void ecl_write_string(cl_object strng, cl_object strm) { - cl_index i; + cl_index i; - strm = _ecl_stream_or_default_output(strm); - switch(ecl_t_of(strng)) { + strm = _ecl_stream_or_default_output(strm); + switch(ecl_t_of(strng)) { #ifdef ECL_UNICODE - case t_string: - for (i = 0; i < strng->string.fillp; i++) - ecl_write_char(strng->string.self[i], strm); - break; + case t_string: + for (i = 0; i < strng->string.fillp; i++) + ecl_write_char(strng->string.self[i], strm); + break; #endif - case t_base_string: - for (i = 0; i < strng->base_string.fillp; i++) - ecl_write_char(strng->base_string.self[i], strm); - break; - default: - FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); - } + case t_base_string: + for (i = 0; i < strng->base_string.fillp; i++) + ecl_write_char(strng->base_string.self[i], strm); + break; + default: + FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]); + } - ecl_force_output(strm); + ecl_force_output(strm); } /* - THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION + THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION */ void ecl_princ_str(const char *s, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - writestr_stream(s, strm); + strm = _ecl_stream_or_default_output(strm); + writestr_stream(s, strm); } int ecl_princ_char(int c, cl_object strm) { - strm = _ecl_stream_or_default_output(strm); - ecl_write_char(c, strm); - if (c == '\n') { - ecl_force_output(strm); - } - return c; + strm = _ecl_stream_or_default_output(strm); + ecl_write_char(c, strm); + if (c == '\n') { + ecl_force_output(strm); + } + return c; } diff --git a/src/c/printer/float_string_old.d b/src/c/printer/float_string_old.d index 5a80ff5fb..b297b7496 100644 --- a/src/c/printer/float_string_old.d +++ b/src/c/printer/float_string_old.d @@ -1,16 +1,13 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -92,19 +89,19 @@ static bool large_mantissa(cl_object r, cl_object mp, cl_object s) { - return ecl_greatereq(ecl_plus(ecl_ash(r,1), mp), - ecl_ash(s, 1)); + return ecl_greatereq(ecl_plus(ecl_ash(r,1), mp), + ecl_ash(s, 1)); } static cl_fixnum assert_floating_point_width(cl_object width) { - if (!ECL_FIXNUMP(width) || ecl_lower(width,ecl_make_fixnum(1))) { - FEerror("Invalid number of floating point digits." - "~%~A~%is not an integer within bounds", - 1, width); - } - return ecl_fixnum(width); + if (!ECL_FIXNUMP(width) || ecl_lower(width,ecl_make_fixnum(1))) { + FEerror("Invalid number of floating point digits." + "~%~A~%is not an integer within bounds", + 1, width); + } + return ecl_fixnum(width); } static cl_object @@ -112,207 +109,207 @@ float_string(cl_object digits_string, cl_object fraction, cl_object exponent, cl_object precision, cl_object width, cl_object fdigits, cl_object scale, cl_object fmin) { - cl_object r = fraction; - cl_object s = ecl_make_fixnum(1); - cl_object mm = s; - cl_object mp = s; - cl_fixnum i, k = 0, digits = 0, decpnt = 0, cutoff = 0; - cl_object u; - char *buffer; - bool roundup = 0, cutoffp = 0, low = 0, high = 0; + cl_object r = fraction; + cl_object s = ecl_make_fixnum(1); + cl_object mm = s; + cl_object mp = s; + cl_fixnum i, k = 0, digits = 0, decpnt = 0, cutoff = 0; + cl_object u; + char *buffer; + bool roundup = 0, cutoffp = 0, low = 0, high = 0; - if (Null(digits_string)) { - digits_string = si_make_vector(@'base-char', ecl_make_fixnum(10), - ECL_T /* adjustable */, - ecl_make_fixnum(0) /* fill pointer */, - ECL_NIL /* displacement */, - ECL_NIL /* displ. offset */); - } - /* Represent fraction as r/s, error bounds as m+/s and m-/s. - * Rational arithmetic avoids loss of precision in subsequent - * calculations. - */ - { - int sign = ecl_number_compare(exponent, ecl_make_fixnum(0)); - if (sign > 0) { - r = cl_ash(fraction, exponent); - mm = cl_ash(ecl_make_fixnum(1), exponent); - mp = mm; - } else if (sign < 0) { - s = cl_ash(ecl_make_fixnum(1), ecl_negate(exponent)); - } - } - /* Adjust error bounds m+ and m- for unequal gaps */ - if (ecl_number_equalp(fraction, cl_ash(ecl_make_fixnum(1), precision))) { - mp = ecl_ash(mm, 1); - r = ecl_ash(r, 1); - s = ecl_ash(s, 1); - } - /* Scale value by requested amount and update error bounds */ - if (!Null(scale)) { - if (ecl_minusp(scale)) { - cl_object factor = cl_expt(ecl_make_fixnum(10), - ecl_negate(scale)); - s = ecl_times(s, factor); - } else { - cl_object factor = cl_expt(ecl_make_fixnum(10), scale); - r = ecl_times(r, factor); - mm = ecl_times(mm, factor); - mp = ecl_times(mp, factor); - } - } - while (ecl_lower(r, ecl_ceiling2(s, ecl_make_fixnum(10)))) { - k--; - r = ecl_times(r, ecl_make_fixnum(10)); - mm = ecl_times(r, ecl_make_fixnum(10)); - mp = ecl_times(r, ecl_make_fixnum(10)); - } - do { - /* Ensure mantissa (r + m+)/s is smaller than one */ - while (large_mantissa(r, mp, s)) { - s = ecl_times(s, ecl_make_fixnum(10)); - k++; - } - /* Determine the number of digits to generate */ - if (!Null(fdigits)) { - cutoffp = 1; - cutoff = assert_floating_point_width(width); - } else if (!Null(width)) { - cutoffp = 1; - cutoff = assert_floating_point_width(width); - if (k < 0) { - cutoff = cutoff - 1; - } else { - cutoff = cutoff - k + 1; - } - } - /* ... and ensure it is never less than fmin */ - if (cutoffp) { - cl_fixnum a, i; - cl_object y; - if (!Null(fmin)) { - cl_fixnum f = assert_floating_point_width(fmin); - if (cutoff < f) - cutoff = f; - } - /* If we decided to cut off digit generation before precision - * has been exhausted, rounding the last digit may cause a - * carry propagation. We can prevent this, preserving - * left-to-right digit generation, with a few magical - * adjustments to m- and m+. Of course, correct rounding is - * also preserved. */ - a = k - cutoff; - y = s; - if (a < 0) { - for (i = 0, a = -a; i < a; i++) { - y = ecl_ceiling2(y, ecl_make_fixnum(10)); - } - } else { - for (i = 0, a = -a; i < a; i++) { - y = ecl_times(y, ecl_make_fixnum(10)); - } - } - mm = cl_max(2, y, mm); - mp = cl_max(2, y, mp); - roundup = ecl_number_equalp(mp, y); - } - } while (large_mantissa(r, mp, s)); - /* Zero-fill before fraction if no integer part */ - if (k < 0) { - decpnt = digits; - ecl_string_push_extend(digits_string, '.'); - for (i = k; i; i++) { - digits++; - ecl_string_push_extend(digits_string, '0'); - } - } - /* Generate least significant digits */ - do { - int sign; - if (--k == -1) { - ecl_string_push_extend(digits_string, '.'); - decpnt = digits; - } - u = ecl_truncate2(ecl_times(r, ecl_make_fixnum(10)), s); - r = VALUES(1); - mm = ecl_times(mm, ecl_make_fixnum(10)); - mp = ecl_times(mp, ecl_make_fixnum(10)); - low = ecl_lower(ecl_ash(r,1), mm); - sign = ecl_number_compare(ecl_ash(r,1), ecl_minus(ecl_ash(s,1),mp)); - high = roundup? (sign >= 0) : (sign > 0); - /* stop when either precision is exhausted or we have printed as many - * fraction digits as permitted */ - if (low || high || (cutoffp && (k + cutoff <= 0))) - break; - ecl_string_push_extend(digits_string, ecl_digit_char(ecl_fixnum(u), 10)); - digits++; - } while(1); - /* If cutof occured before first digit, then no digits generated at all */ - if (!cutoffp || (k + cutoff) >= 0) { - /* Last digit may need rounding */ - int digit = ecl_fixnum(u); - if (low && !high) - digit = ecl_fixnum(u); - else if (high && !low) - digit = ecl_fixnum(u)+1; - else if (ecl_lower(ecl_ash(r,1), s)) - digit = ecl_fixnum(u); - else - digit = ecl_fixnum(u) + 1; - ecl_string_push_extend(digits_string, ecl_digit_char(digit, 10)); - digits++; - } - /* Zero-fill after integer part if no fraction */ - if (k >= 0) { - for (i = 0; i < k; i++) { - ecl_string_push_extend(digits_string, '0'); - digits++; - } - ecl_string_push_extend(digits_string, '.'); - decpnt = digits; - } - /* Add trailing zeroes to pad fraction if fdigits needed */ - if (!Null(fdigits)) { - cl_fixnum f = assert_floating_point_width(fdigits) - (digits - decpnt); - for (i = 0; i < f; i++) { - ecl_string_push_extend(digits_string, '0'); - digits++; - } - } - /* All done */ - @(return - digits_string - ecl_make_fixnum(1+digits) - ((decpnt == 0)? ECL_T : ECL_NIL) - ((decpnt == digits)? ECL_T : ECL_NIL) - ecl_make_fixnum(decpnt)) + if (Null(digits_string)) { + digits_string = si_make_vector(@'base-char', ecl_make_fixnum(10), + ECL_T /* adjustable */, + ecl_make_fixnum(0) /* fill pointer */, + ECL_NIL /* displacement */, + ECL_NIL /* displ. offset */); + } + /* Represent fraction as r/s, error bounds as m+/s and m-/s. + * Rational arithmetic avoids loss of precision in subsequent + * calculations. + */ + { + int sign = ecl_number_compare(exponent, ecl_make_fixnum(0)); + if (sign > 0) { + r = cl_ash(fraction, exponent); + mm = cl_ash(ecl_make_fixnum(1), exponent); + mp = mm; + } else if (sign < 0) { + s = cl_ash(ecl_make_fixnum(1), ecl_negate(exponent)); + } + } + /* Adjust error bounds m+ and m- for unequal gaps */ + if (ecl_number_equalp(fraction, cl_ash(ecl_make_fixnum(1), precision))) { + mp = ecl_ash(mm, 1); + r = ecl_ash(r, 1); + s = ecl_ash(s, 1); + } + /* Scale value by requested amount and update error bounds */ + if (!Null(scale)) { + if (ecl_minusp(scale)) { + cl_object factor = cl_expt(ecl_make_fixnum(10), + ecl_negate(scale)); + s = ecl_times(s, factor); + } else { + cl_object factor = cl_expt(ecl_make_fixnum(10), scale); + r = ecl_times(r, factor); + mm = ecl_times(mm, factor); + mp = ecl_times(mp, factor); + } + } + while (ecl_lower(r, ecl_ceiling2(s, ecl_make_fixnum(10)))) { + k--; + r = ecl_times(r, ecl_make_fixnum(10)); + mm = ecl_times(r, ecl_make_fixnum(10)); + mp = ecl_times(r, ecl_make_fixnum(10)); + } + do { + /* Ensure mantissa (r + m+)/s is smaller than one */ + while (large_mantissa(r, mp, s)) { + s = ecl_times(s, ecl_make_fixnum(10)); + k++; + } + /* Determine the number of digits to generate */ + if (!Null(fdigits)) { + cutoffp = 1; + cutoff = assert_floating_point_width(width); + } else if (!Null(width)) { + cutoffp = 1; + cutoff = assert_floating_point_width(width); + if (k < 0) { + cutoff = cutoff - 1; + } else { + cutoff = cutoff - k + 1; + } + } + /* ... and ensure it is never less than fmin */ + if (cutoffp) { + cl_fixnum a, i; + cl_object y; + if (!Null(fmin)) { + cl_fixnum f = assert_floating_point_width(fmin); + if (cutoff < f) + cutoff = f; + } + /* If we decided to cut off digit generation before precision + * has been exhausted, rounding the last digit may cause a + * carry propagation. We can prevent this, preserving + * left-to-right digit generation, with a few magical + * adjustments to m- and m+. Of course, correct rounding is + * also preserved. */ + a = k - cutoff; + y = s; + if (a < 0) { + for (i = 0, a = -a; i < a; i++) { + y = ecl_ceiling2(y, ecl_make_fixnum(10)); + } + } else { + for (i = 0, a = -a; i < a; i++) { + y = ecl_times(y, ecl_make_fixnum(10)); + } + } + mm = cl_max(2, y, mm); + mp = cl_max(2, y, mp); + roundup = ecl_number_equalp(mp, y); + } + } while (large_mantissa(r, mp, s)); + /* Zero-fill before fraction if no integer part */ + if (k < 0) { + decpnt = digits; + ecl_string_push_extend(digits_string, '.'); + for (i = k; i; i++) { + digits++; + ecl_string_push_extend(digits_string, '0'); + } + } + /* Generate least significant digits */ + do { + int sign; + if (--k == -1) { + ecl_string_push_extend(digits_string, '.'); + decpnt = digits; + } + u = ecl_truncate2(ecl_times(r, ecl_make_fixnum(10)), s); + r = VALUES(1); + mm = ecl_times(mm, ecl_make_fixnum(10)); + mp = ecl_times(mp, ecl_make_fixnum(10)); + low = ecl_lower(ecl_ash(r,1), mm); + sign = ecl_number_compare(ecl_ash(r,1), ecl_minus(ecl_ash(s,1),mp)); + high = roundup? (sign >= 0) : (sign > 0); + /* stop when either precision is exhausted or we have printed as many + * fraction digits as permitted */ + if (low || high || (cutoffp && (k + cutoff <= 0))) + break; + ecl_string_push_extend(digits_string, ecl_digit_char(ecl_fixnum(u), 10)); + digits++; + } while(1); + /* If cutof occured before first digit, then no digits generated at all */ + if (!cutoffp || (k + cutoff) >= 0) { + /* Last digit may need rounding */ + int digit = ecl_fixnum(u); + if (low && !high) + digit = ecl_fixnum(u); + else if (high && !low) + digit = ecl_fixnum(u)+1; + else if (ecl_lower(ecl_ash(r,1), s)) + digit = ecl_fixnum(u); + else + digit = ecl_fixnum(u) + 1; + ecl_string_push_extend(digits_string, ecl_digit_char(digit, 10)); + digits++; + } + /* Zero-fill after integer part if no fraction */ + if (k >= 0) { + for (i = 0; i < k; i++) { + ecl_string_push_extend(digits_string, '0'); + digits++; + } + ecl_string_push_extend(digits_string, '.'); + decpnt = digits; + } + /* Add trailing zeroes to pad fraction if fdigits needed */ + if (!Null(fdigits)) { + cl_fixnum f = assert_floating_point_width(fdigits) - (digits - decpnt); + for (i = 0; i < f; i++) { + ecl_string_push_extend(digits_string, '0'); + digits++; + } + } + /* All done */ + @(return + digits_string + ecl_make_fixnum(1+digits) + ((decpnt == 0)? ECL_T : ECL_NIL) + ((decpnt == digits)? ECL_T : ECL_NIL) + ecl_make_fixnum(decpnt)); } ecl_def_ct_base_string(str_dot,".",1,static,const); @(defun ext::float-string (string x &optional width fdigits scale fmin) -@ -{ - if (ecl_zerop(x)) { - if (Null(fdigits)) { - cl_object s = cl_make_string(3, ecl_one_plus(fdigits), - @':initial-element', - ECL_CODE_CHAR('0')); - ecl_char_set(s, 0, '.'); - @(return s cl_length(s) ECL_T cl_zerop(fdigits) ecl_make_fixnum(0)); - } else { - @(return str_dot ecl_make_fixnum(1) ECL_T ECL_T ecl_make_fixnum(0)); - } - } else { - cl_object sig = cl_integer_decode_float(x); - cl_object exp = VALUES(1); - cl_object precision = cl_float_precision(x); - cl_object digits = cl_float_digits(x); - cl_object fudge = ecl_minus(digits, precision); - cl_object w = Null(width)? ECL_NIL : cl_max(2, width, ecl_make_fixnum(1)); - return float_string(string, cl_ash(sig, ecl_negate(fudge)), - ecl_plus(exp, fudge), precision, w, - fdigits, scale, fmin); - } -} -@) + @ + { + if (ecl_zerop(x)) { + if (Null(fdigits)) { + cl_object s = cl_make_string(3, ecl_one_plus(fdigits), + @':initial-element', + ECL_CODE_CHAR('0')); + ecl_char_set(s, 0, '.'); + @(return s cl_length(s) ECL_T cl_zerop(fdigits) ecl_make_fixnum(0)); + } else { + @(return str_dot ecl_make_fixnum(1) ECL_T ECL_T ecl_make_fixnum(0)); + } + } else { + cl_object sig = cl_integer_decode_float(x); + cl_object exp = VALUES(1); + cl_object precision = cl_float_precision(x); + cl_object digits = cl_float_digits(x); + cl_object fudge = ecl_minus(digits, precision); + cl_object w = Null(width)? ECL_NIL : cl_max(2, width, ecl_make_fixnum(1)); + return float_string(string, cl_ash(sig, ecl_negate(fudge)), + ecl_plus(exp, fudge), precision, w, + fdigits, scale, fmin); + } + } + @) diff --git a/src/c/printer/float_to_digits.d b/src/c/printer/float_to_digits.d index d9dc8f21b..6b795f522 100644 --- a/src/c/printer/float_to_digits.d +++ b/src/c/printer/float_to_digits.d @@ -1,16 +1,13 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -21,201 +18,201 @@ #define EXPT_RADIX(x) ecl_ash(ecl_make_fixnum(1),x) typedef struct { - cl_object r; - cl_object s; - cl_object mm; - cl_object mp; - bool high_ok; - bool low_ok; + cl_object r; + cl_object s; + cl_object mm; + cl_object mp; + bool high_ok; + bool low_ok; } float_approx; static cl_object times2(cl_object x) { - return ecl_plus(x, x); + return ecl_plus(x, x); } static float_approx * setup(cl_object number, float_approx *approx) { - cl_object f = cl_integer_decode_float(number); - cl_fixnum e = ecl_fixnum(VALUES(1)), min_e; - bool limit_f = 0; - switch (ecl_t_of(number)) { - case t_singlefloat: - min_e = FLT_MIN_EXP; - limit_f = (number->SF.SFVAL == - ldexpf(FLT_RADIX, FLT_MANT_DIG-1)); - break; - case t_doublefloat: - min_e = DBL_MIN_EXP; - limit_f = (number->DF.DFVAL == - ldexp(FLT_RADIX, DBL_MANT_DIG-1)); - break; + cl_object f = cl_integer_decode_float(number); + cl_fixnum e = ecl_fixnum(VALUES(1)), min_e; + bool limit_f = 0; + switch (ecl_t_of(number)) { + case t_singlefloat: + min_e = FLT_MIN_EXP; + limit_f = (number->SF.SFVAL == + ldexpf(FLT_RADIX, FLT_MANT_DIG-1)); + break; + case t_doublefloat: + min_e = DBL_MIN_EXP; + limit_f = (number->DF.DFVAL == + ldexp(FLT_RADIX, DBL_MANT_DIG-1)); + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - min_e = LDBL_MIN_EXP; - limit_f = (number->longfloat.value == - ldexpl(FLT_RADIX, LDBL_MANT_DIG-1)); + case t_longfloat: + min_e = LDBL_MIN_EXP; + limit_f = (number->longfloat.value == + ldexpl(FLT_RADIX, LDBL_MANT_DIG-1)); #endif - } - approx->low_ok = approx->high_ok = ecl_evenp(f); - if (e > 0) { - cl_object be = EXPT_RADIX(e); - if (limit_f) { - cl_object be1 = ecl_times(be, ecl_make_fixnum(FLT_RADIX)); - approx->r = times2(ecl_times(f, be1)); - approx->s = ecl_make_fixnum(FLT_RADIX*2); - approx->mm = be; - approx->mp = be1; - } else { - approx->r = times2(ecl_times(f, be)); - approx->s = ecl_make_fixnum(2); - approx->mm = be; - approx->mp = be; - } - } else if (!limit_f || (e == min_e)) { - approx->r = times2(f); - approx->s = times2(EXPT_RADIX(-e)); - approx->mp = ecl_make_fixnum(1); - approx->mm = ecl_make_fixnum(1); - } else { - approx->r = times2(ecl_make_fixnum(FLT_RADIX)); - approx->s = times2(EXPT_RADIX(1-e)); - approx->mp = ecl_make_fixnum(FLT_RADIX); - approx->mm = ecl_make_fixnum(1); - } - return approx; + } + approx->low_ok = approx->high_ok = ecl_evenp(f); + if (e > 0) { + cl_object be = EXPT_RADIX(e); + if (limit_f) { + cl_object be1 = ecl_times(be, ecl_make_fixnum(FLT_RADIX)); + approx->r = times2(ecl_times(f, be1)); + approx->s = ecl_make_fixnum(FLT_RADIX*2); + approx->mm = be; + approx->mp = be1; + } else { + approx->r = times2(ecl_times(f, be)); + approx->s = ecl_make_fixnum(2); + approx->mm = be; + approx->mp = be; + } + } else if (!limit_f || (e == min_e)) { + approx->r = times2(f); + approx->s = times2(EXPT_RADIX(-e)); + approx->mp = ecl_make_fixnum(1); + approx->mm = ecl_make_fixnum(1); + } else { + approx->r = times2(ecl_make_fixnum(FLT_RADIX)); + approx->s = times2(EXPT_RADIX(1-e)); + approx->mp = ecl_make_fixnum(FLT_RADIX); + approx->mm = ecl_make_fixnum(1); + } + return approx; } static cl_fixnum scale(float_approx *approx) { - cl_fixnum k = 0; - cl_object x = ecl_plus(approx->r, approx->mp); - int sign; - do { - sign = ecl_number_compare(x, approx->s); - if (approx->high_ok) { - if (sign < 0) - break; - } else { - if (sign <= 0) - break; - } - approx->s = ecl_times(approx->s, PRINT_BASE); - k++; - } while(1); - do { - x = ecl_times(x, PRINT_BASE); - sign = ecl_number_compare(x, approx->s); - if (approx->high_ok) { - if (sign >= 0) - break; - } else { - if (sign > 0) - break; - } - k--; - approx->r = ecl_times(approx->r, PRINT_BASE); - approx->mm = ecl_times(approx->mm, PRINT_BASE); - approx->mp = ecl_times(approx->mp, PRINT_BASE); - } while(1); - return k; + cl_fixnum k = 0; + cl_object x = ecl_plus(approx->r, approx->mp); + int sign; + do { + sign = ecl_number_compare(x, approx->s); + if (approx->high_ok) { + if (sign < 0) + break; + } else { + if (sign <= 0) + break; + } + approx->s = ecl_times(approx->s, PRINT_BASE); + k++; + } while(1); + do { + x = ecl_times(x, PRINT_BASE); + sign = ecl_number_compare(x, approx->s); + if (approx->high_ok) { + if (sign >= 0) + break; + } else { + if (sign > 0) + break; + } + k--; + approx->r = ecl_times(approx->r, PRINT_BASE); + approx->mm = ecl_times(approx->mm, PRINT_BASE); + approx->mp = ecl_times(approx->mp, PRINT_BASE); + } while(1); + return k; } static cl_object generate(cl_object digits, float_approx *approx) { - cl_object d, x; - cl_fixnum digit; - bool tc1, tc2; - do { - d = ecl_truncate2(ecl_times(approx->r, PRINT_BASE), approx->s); - approx->r = VALUES(1); - approx->mp = ecl_times(approx->mp, PRINT_BASE); - approx->mm = ecl_times(approx->mm, PRINT_BASE); - tc1 = approx->low_ok? - ecl_lowereq(approx->r, approx->mm) : - ecl_lower(approx->r, approx->mm); - x = ecl_plus(approx->r, approx->mp); - tc2 = approx->high_ok? - ecl_greatereq(x, approx->s) : - ecl_greater(x, approx->s); - if (tc1 || tc2) { - break; - } - ecl_string_push_extend(digits, ecl_digit_char(ecl_fixnum(d), 10)); - } while (1); - if (tc2 && !tc1) { - digit = ecl_fixnum(d) + 1; - } else if (tc1 && !tc2) { - digit = ecl_fixnum(d); - } else if (ecl_lower(times2(approx->r), approx->s)) { - digit = ecl_fixnum(d); - } else { - digit = ecl_fixnum(d) + 1; - } - ecl_string_push_extend(digits, ecl_digit_char(digit, 10)); - return digits; + cl_object d, x; + cl_fixnum digit; + bool tc1, tc2; + do { + d = ecl_truncate2(ecl_times(approx->r, PRINT_BASE), approx->s); + approx->r = VALUES(1); + approx->mp = ecl_times(approx->mp, PRINT_BASE); + approx->mm = ecl_times(approx->mm, PRINT_BASE); + tc1 = approx->low_ok? + ecl_lowereq(approx->r, approx->mm) : + ecl_lower(approx->r, approx->mm); + x = ecl_plus(approx->r, approx->mp); + tc2 = approx->high_ok? + ecl_greatereq(x, approx->s) : + ecl_greater(x, approx->s); + if (tc1 || tc2) { + break; + } + ecl_string_push_extend(digits, ecl_digit_char(ecl_fixnum(d), 10)); + } while (1); + if (tc2 && !tc1) { + digit = ecl_fixnum(d) + 1; + } else if (tc1 && !tc2) { + digit = ecl_fixnum(d); + } else if (ecl_lower(times2(approx->r), approx->s)) { + digit = ecl_fixnum(d); + } else { + digit = ecl_fixnum(d) + 1; + } + ecl_string_push_extend(digits, ecl_digit_char(digit, 10)); + return digits; } static void change_precision(float_approx *approx, cl_object position, cl_object relativep) { - cl_fixnum pos; - if (Null(position)) - return; - pos = ecl_fixnum(position); - if (!Null(relativep)) { - cl_object k = ecl_make_fixnum(0); - cl_object l = ecl_make_fixnum(1); - while (ecl_lower(ecl_times(approx->s, l), - ecl_plus(approx->r, approx->mp))) { - k = ecl_one_plus(k); - l = ecl_times(l, PRINT_BASE); - } - position = ecl_minus(k, position); - { - cl_object e1 = cl_expt(PRINT_BASE, position); - cl_object e2 = ecl_divide(e1, ecl_make_fixnum(2)); - cl_object e3 = cl_expt(PRINT_BASE, k); - if (ecl_greatereq(ecl_plus(approx->r, ecl_times(approx->s, e1)), - ecl_times(approx->s, e2))) - position = ecl_one_minus(position); - } - } - { - cl_object x = ecl_times(approx->s, cl_expt(PRINT_BASE, position)); - cl_object e = ecl_divide(x, ecl_make_fixnum(2)); - cl_object low = cl_max(2, approx->mm, e); - cl_object high = cl_max(2, approx->mp, e); - if (ecl_lowereq(approx->mm, low)) { - approx->mm = low; - approx->low_ok = 1; - } - if (ecl_lowereq(approx->mp, high)) { - approx->mp = high; - approx->high_ok = 1; - } - } + cl_fixnum pos; + if (Null(position)) + return; + pos = ecl_fixnum(position); + if (!Null(relativep)) { + cl_object k = ecl_make_fixnum(0); + cl_object l = ecl_make_fixnum(1); + while (ecl_lower(ecl_times(approx->s, l), + ecl_plus(approx->r, approx->mp))) { + k = ecl_one_plus(k); + l = ecl_times(l, PRINT_BASE); + } + position = ecl_minus(k, position); + { + cl_object e1 = cl_expt(PRINT_BASE, position); + cl_object e2 = ecl_divide(e1, ecl_make_fixnum(2)); + cl_object e3 = cl_expt(PRINT_BASE, k); + if (ecl_greatereq(ecl_plus(approx->r, ecl_times(approx->s, e1)), + ecl_times(approx->s, e2))) + position = ecl_one_minus(position); + } + } + { + cl_object x = ecl_times(approx->s, cl_expt(PRINT_BASE, position)); + cl_object e = ecl_divide(x, ecl_make_fixnum(2)); + cl_object low = cl_max(2, approx->mm, e); + cl_object high = cl_max(2, approx->mp, e); + if (ecl_lowereq(approx->mm, low)) { + approx->mm = low; + approx->low_ok = 1; + } + if (ecl_lowereq(approx->mp, high)) { + approx->mp = high; + approx->high_ok = 1; + } + } } cl_object si_float_to_digits(cl_object digits, cl_object number, cl_object position, cl_object relativep) { - cl_fixnum k; - float_approx approx[1]; - setup(number, approx); - change_precision(approx, position, relativep); - k = scale(approx); - if (Null(digits)) - digits = si_make_vector(@'base-char', ecl_make_fixnum(10), - ECL_T /* adjustable */, - ecl_make_fixnum(0) /* fill pointer */, - ECL_NIL /* displacement */, - ECL_NIL /* displ. offset */); - generate(digits, approx); - @(return ecl_make_fixnum(k) digits) + cl_fixnum k; + float_approx approx[1]; + setup(number, approx); + change_precision(approx, position, relativep); + k = scale(approx); + if (Null(digits)) + digits = si_make_vector(@'base-char', ecl_make_fixnum(10), + ECL_T /* adjustable */, + ecl_make_fixnum(0) /* fill pointer */, + ECL_NIL /* displacement */, + ECL_NIL /* displ. offset */); + generate(digits, approx); + @(return ecl_make_fixnum(k) digits); } diff --git a/src/c/printer/float_to_string.d b/src/c/printer/float_to_string.d index 316818986..e051a57ef 100644 --- a/src/c/printer/float_to_string.d +++ b/src/c/printer/float_to_string.d @@ -1,16 +1,13 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -20,39 +17,39 @@ cl_object _ecl_ensure_buffer(cl_object buffer, cl_fixnum length) { - if (Null(buffer)) { - buffer = si_make_vector(@'base-char', ecl_make_fixnum(length), - ECL_T /* adjustable */, - ecl_make_fixnum(0) /* fill pointer */, - ECL_NIL /* displacement */, - ECL_NIL /* displ. offset */); - } - return buffer; + if (Null(buffer)) { + buffer = si_make_vector(@'base-char', ecl_make_fixnum(length), + ECL_T /* adjustable */, + ecl_make_fixnum(0) /* fill pointer */, + ECL_NIL /* displacement */, + ECL_NIL /* displ. offset */); + } + return buffer; } void _ecl_string_push_c_string(cl_object s, const char *c) { - for (; *c; c++) { - ecl_string_push_extend(s, *c); - } + for (; *c; c++) { + ecl_string_push_extend(s, *c); + } } static void insert_char(cl_object buffer, cl_index where, cl_fixnum c) { - cl_fixnum end = buffer->base_string.fillp; - ecl_string_push_extend(buffer, '.'); - ecl_copy_subarray(buffer, where+1, buffer, where, end - where); - ecl_char_set(buffer, where, c); + cl_fixnum end = buffer->base_string.fillp; + ecl_string_push_extend(buffer, '.'); + ecl_copy_subarray(buffer, where+1, buffer, where, end - where); + ecl_char_set(buffer, where, c); } static cl_object push_base_string(cl_object buffer, cl_object s) { - buffer = _ecl_ensure_buffer(buffer, s->base_string.fillp); - _ecl_string_push_c_string(buffer, (char *)s->base_string.self); - return buffer; + buffer = _ecl_ensure_buffer(buffer, s->base_string.fillp); + _ecl_string_push_c_string(buffer, (char *)s->base_string.self); + return buffer; } /********************************************************************** @@ -62,72 +59,72 @@ push_base_string(cl_object buffer, cl_object s) static void print_float_exponent(cl_object buffer, cl_object number, cl_fixnum exp) { - cl_object r = ecl_symbol_value(@'*read-default-float-format*'); - cl_fixnum e; - switch (ecl_t_of(number)) { - case t_singlefloat: - e = (r == @'single-float' || r == @'short-float')? 'e' : 'f'; - break; + cl_object r = ecl_symbol_value(@'*read-default-float-format*'); + cl_fixnum e; + switch (ecl_t_of(number)) { + case t_singlefloat: + e = (r == @'single-float' || r == @'short-float')? 'e' : 'f'; + break; #ifdef ECL_LONG_FLOAT - case t_longfloat: - e = (r == @'long-float') ? 'e' : 'l'; - break; - case t_doublefloat: - e = (r == @'double-float')? 'e' : 'd'; - break; + case t_longfloat: + e = (r == @'long-float') ? 'e' : 'l'; + break; + case t_doublefloat: + e = (r == @'double-float')? 'e' : 'd'; + break; #else - case t_doublefloat: - e = (r == @'double-float' || r == @'long-float')? 'e' : 'd'; - break; + case t_doublefloat: + e = (r == @'double-float' || r == @'long-float')? 'e' : 'd'; + break; #endif - } - if (e != 'e' || exp != 0) { - ecl_string_push_extend(buffer, e); - si_integer_to_string(buffer, ecl_make_fixnum(exp), ecl_make_fixnum(10), - ECL_NIL, ECL_NIL); - } + } + if (e != 'e' || exp != 0) { + ecl_string_push_extend(buffer, e); + si_integer_to_string(buffer, ecl_make_fixnum(exp), ecl_make_fixnum(10), + ECL_NIL, ECL_NIL); + } } cl_object si_float_to_string_free(cl_object buffer_or_nil, cl_object number, cl_object e_min, cl_object e_max) { - cl_fixnum base, e; - cl_object exp, buffer; + cl_fixnum base, e; + cl_object exp, buffer; - if (ecl_float_nan_p(number)) { - cl_object s = funcall(2, @'ext::float-nan-string', number); - @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); - } else if (ecl_float_infinity_p(number)) { - cl_object s = funcall(2, @'ext::float-infinity-string', number); - @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); - } - base = ecl_length(buffer_or_nil); - exp = si_float_to_digits(buffer_or_nil, number, ECL_NIL, ECL_NIL); - buffer = VALUES(1); - e = ecl_fixnum(exp); + if (ecl_float_nan_p(number)) { + cl_object s = funcall(2, @'ext::float-nan-string', number); + @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); + } else if (ecl_float_infinity_p(number)) { + cl_object s = funcall(2, @'ext::float-infinity-string', number); + @(return push_base_string(buffer_or_nil, si_coerce_to_base_string(s))); + } + base = ecl_length(buffer_or_nil); + exp = si_float_to_digits(buffer_or_nil, number, ECL_NIL, ECL_NIL); + buffer = VALUES(1); + e = ecl_fixnum(exp); - if (ecl_signbit(number)) { - insert_char(buffer, base++, '-'); - } - /* Do we have to print in exponent notation? */ - if (ecl_lowereq(exp, e_min) || ecl_lowereq(e_max, exp)) { - insert_char(buffer, base+1, '.'); - print_float_exponent(buffer, number, e-1); - } else if (e > 0) { - cl_fixnum l = buffer->base_string.fillp - base; - while (l++ <= e) { - ecl_string_push_extend(buffer, '0'); - } - insert_char(buffer, base+e, '.'); - print_float_exponent(buffer, number, 0); - } else { - insert_char(buffer, base++, '0'); - insert_char(buffer, base++, '.'); - for (e = -e; e; e--) { - insert_char(buffer, base++, '0'); - } - print_float_exponent(buffer, number, 0); - } - @(return buffer); + if (ecl_signbit(number)) { + insert_char(buffer, base++, '-'); + } + /* Do we have to print in exponent notation? */ + if (ecl_lowereq(exp, e_min) || ecl_lowereq(e_max, exp)) { + insert_char(buffer, base+1, '.'); + print_float_exponent(buffer, number, e-1); + } else if (e > 0) { + cl_fixnum l = buffer->base_string.fillp - base; + while (l++ <= e) { + ecl_string_push_extend(buffer, '0'); + } + insert_char(buffer, base+e, '.'); + print_float_exponent(buffer, number, 0); + } else { + insert_char(buffer, base++, '0'); + insert_char(buffer, base++, '.'); + for (e = -e; e; e--) { + insert_char(buffer, base++, '0'); + } + print_float_exponent(buffer, number, 0); + } + @(return buffer); } diff --git a/src/c/printer/print_unreadable.d b/src/c/printer/print_unreadable.d index 0e1a008fb..7ea5305c4 100644 --- a/src/c/printer/print_unreadable.d +++ b/src/c/printer/print_unreadable.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - print_unreadable.d -- helper for print-unreadable-object macro -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * print_unreadable.d - helper for print-unreadable-object macro + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -21,64 +16,64 @@ void _ecl_write_addr(cl_object x, cl_object stream) { - cl_fixnum i, j; + cl_fixnum i, j; - i = (cl_index)x; - for (j = sizeof(i)*8-4; j >= 0; j -= 4) { - int k = (i>>j) & 0xf; - if (k < 10) - ecl_write_char('0' + k, stream); - else - ecl_write_char('a' + k - 10, stream); - } + i = (cl_index)x; + for (j = sizeof(i)*8-4; j >= 0; j -= 4) { + int k = (i>>j) & 0xf; + if (k < 10) + ecl_write_char('0' + k, stream); + else + ecl_write_char('a' + k - 10, stream); + } } void _ecl_write_unreadable(cl_object x, const char *prefix, cl_object name, cl_object stream) { - if (ecl_print_readably()) - FEprint_not_readable(x); - ecl_write_char('#', stream); - ecl_write_char('<', stream); - writestr_stream(prefix, stream); - ecl_write_char(' ', stream); - if (!Null(name)) { - si_write_ugly_object(name, stream); - } else { - _ecl_write_addr(x, stream); - } - ecl_write_char('>', stream); + if (ecl_print_readably()) + FEprint_not_readable(x); + ecl_write_char('#', stream); + ecl_write_char('<', stream); + writestr_stream(prefix, stream); + ecl_write_char(' ', stream); + if (!Null(name)) { + si_write_ugly_object(name, stream); + } else { + _ecl_write_addr(x, stream); + } + ecl_write_char('>', stream); } cl_object si_print_unreadable_object_function(cl_object o, cl_object stream, cl_object type, cl_object id, cl_object function) { - if (ecl_print_readably()) - FEprint_not_readable(o); - stream = _ecl_stream_or_default_output(stream); - if (ecl_print_level() == 0) { - ecl_write_char('#', stream); - } else { - writestr_stream("#<", stream); - if (!Null(type)) { - cl_index i, l; - type = cl_type_of(o); - if (!ECL_SYMBOLP(type)) { - type = @'standard-object'; - } - type = type->symbol.name; - for (i = 0, l = ecl_length(type); i < l; i++) - ecl_write_char(ecl_char_downcase(ecl_char(type, i)), stream); - ecl_write_char(' ', stream); - } - if (!Null(function)) { - _ecl_funcall1(function); - } - if (!Null(id)) { - ecl_write_char(' ', stream); - _ecl_write_addr(o, stream); - } - ecl_write_char('>', stream); - } - @(return ECL_NIL) + if (ecl_print_readably()) + FEprint_not_readable(o); + stream = _ecl_stream_or_default_output(stream); + if (ecl_print_level() == 0) { + ecl_write_char('#', stream); + } else { + writestr_stream("#<", stream); + if (!Null(type)) { + cl_index i, l; + type = cl_type_of(o); + if (!ECL_SYMBOLP(type)) { + type = @'standard-object'; + } + type = type->symbol.name; + for (i = 0, l = ecl_length(type); i < l; i++) + ecl_write_char(ecl_char_downcase(ecl_char(type, i)), stream); + ecl_write_char(' ', stream); + } + if (!Null(function)) { + _ecl_funcall1(function); + } + if (!Null(id)) { + ecl_write_char(' ', stream); + _ecl_write_addr(o, stream); + } + ecl_write_char('>', stream); + } + @(return ECL_NIL); } diff --git a/src/c/printer/write_array.d b/src/c/printer/write_array.d index 811635d26..98260a8d5 100644 --- a/src/c/printer/write_array.d +++ b/src/c/printer/write_array.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_array.d -- File interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * write_array.d - file interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,186 +18,186 @@ static void write_array_inner(bool vector, cl_object x, cl_object stream) { - cl_env_ptr env = ecl_process_env(); - const cl_index *adims; - cl_index subscripts[ECL_ARRAY_RANK_LIMIT]; - cl_fixnum n, j, m, k, i; - cl_fixnum print_length; - cl_fixnum print_level; - bool readably = ecl_print_readably(); + cl_env_ptr env = ecl_process_env(); + const cl_index *adims; + cl_index subscripts[ECL_ARRAY_RANK_LIMIT]; + cl_fixnum n, j, m, k, i; + cl_fixnum print_length; + cl_fixnum print_level; + bool readably = ecl_print_readably(); - if (vector) { - adims = &x->vector.fillp; - n = 1; - } else { - adims = x->array.dims; - n = x->array.rank; + if (vector) { + adims = &x->vector.fillp; + n = 1; + } else { + adims = x->array.dims; + n = x->array.rank; + } + if (readably) { + print_length = MOST_POSITIVE_FIXNUM; + print_level = MOST_POSITIVE_FIXNUM; + } else { + if (!ecl_print_array()) { + writestr_stream(vector? "#', stream); + return; + } + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + ecl_write_char('#', stream); + if (print_level == 0) + return; + if (readably) { + ecl_write_char('A', stream); + ecl_write_char('(', stream); + si_write_object(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); + ecl_write_char(' ', stream); + if (n > 0) { + ecl_write_char('(', stream); + for (j=0; j= n) { + /* We can write the elements of the array */ + print_level -= n; + ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level)); + } else { + /* The elements of the array are not printed */ + n = print_level; + print_level = -1; + } + for (j = 0; j < n; j++) + subscripts[j] = 0; + for (m = 0, j = 0;;) { + for (i = j; i < n; i++) { + if (subscripts[i] == 0) { + ecl_write_char('(', stream); + if (adims[i] == 0) { + ecl_write_char(')', stream); + j = i-1; + k = 0; + goto INC; } - if (readably) { - print_length = MOST_POSITIVE_FIXNUM; - print_level = MOST_POSITIVE_FIXNUM; - } else { - if (!ecl_print_array()) { - writestr_stream(vector? "#', stream); - return; - } - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - ecl_write_char('#', stream); - if (print_level == 0) - return; - if (readably) { - ecl_write_char('A', stream); - ecl_write_char('(', stream); - si_write_object(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); - ecl_write_char(' ', stream); - if (n > 0) { - ecl_write_char('(', stream); - for (j=0; j= n) { - /* We can write the elements of the array */ - print_level -= n; - ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level)); - } else { - /* The elements of the array are not printed */ - n = print_level; - print_level = -1; - } - for (j = 0; j < n; j++) - subscripts[j] = 0; - for (m = 0, j = 0;;) { - for (i = j; i < n; i++) { - if (subscripts[i] == 0) { - ecl_write_char('(', stream); - if (adims[i] == 0) { - ecl_write_char(')', stream); - j = i-1; - k = 0; - goto INC; - } - } - if (subscripts[i] > 0) - ecl_write_char(' ', stream); - if (subscripts[i] >= print_length) { - writestr_stream("...)", stream); - k=adims[i]-subscripts[i]; - subscripts[i] = 0; - for (j = i+1; j < n; j++) - k *= adims[j]; - j = i-1; - goto INC; - } - } - /* FIXME: This conses! */ - if (print_level >= 0) - si_write_object(ecl_aref_unsafe(x, m), stream); - else - ecl_write_char('#', stream); - j = n-1; - k = 1; + } + if (subscripts[i] > 0) + ecl_write_char(' ', stream); + if (subscripts[i] >= print_length) { + writestr_stream("...)", stream); + k=adims[i]-subscripts[i]; + subscripts[i] = 0; + for (j = i+1; j < n; j++) + k *= adims[j]; + j = i-1; + goto INC; + } + } + /* FIXME: This conses! */ + if (print_level >= 0) + si_write_object(ecl_aref_unsafe(x, m), stream); + else + ecl_write_char('#', stream); + j = n-1; + k = 1; - INC: - while (j >= 0) { - if (++subscripts[j] < adims[j]) - break; - subscripts[j] = 0; - ecl_write_char(')', stream); - --j; - } - if (j < 0) - break; - m += k; - } - if (print_level >= 0) { - ecl_bds_unwind1(env); - } - if (readably) { - ecl_write_char(')', stream); - } + INC: + while (j >= 0) { + if (++subscripts[j] < adims[j]) + break; + subscripts[j] = 0; + ecl_write_char(')', stream); + --j; + } + if (j < 0) + break; + m += k; + } + if (print_level >= 0) { + ecl_bds_unwind1(env); + } + if (readably) { + ecl_write_char(')', stream); + } } void _ecl_write_array(cl_object x, cl_object stream) { - write_array_inner(0, x, stream); + write_array_inner(0, x, stream); } void _ecl_write_vector(cl_object x, cl_object stream) { - write_array_inner(1, x, stream); + write_array_inner(1, x, stream); } #ifdef ECL_UNICODE void _ecl_write_string(cl_object x, cl_object stream) { - cl_index ndx; - if (!ecl_print_escape() && !ecl_print_readably()) { - for (ndx = 0; ndx < x->string.fillp; ndx++) - ecl_write_char(x->string.self[ndx], stream); - } else { - ecl_write_char('"', stream); - for (ndx = 0; ndx < x->string.fillp; ndx++) { - ecl_character c = x->string.self[ndx]; - if (c == '"' || c == '\\') - ecl_write_char('\\', stream); - ecl_write_char(c, stream); - } - ecl_write_char('"', stream); - } + cl_index ndx; + if (!ecl_print_escape() && !ecl_print_readably()) { + for (ndx = 0; ndx < x->string.fillp; ndx++) + ecl_write_char(x->string.self[ndx], stream); + } else { + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->string.fillp; ndx++) { + ecl_character c = x->string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); + } } #endif void _ecl_write_base_string(cl_object x, cl_object stream) { - cl_index ndx; - if (!ecl_print_escape() && !ecl_print_readably()) { - for (ndx = 0; ndx < x->base_string.fillp; ndx++) - ecl_write_char(x->base_string.self[ndx], stream); - } else { - ecl_write_char('"', stream); - for (ndx = 0; ndx < x->base_string.fillp; ndx++) { - int c = x->base_string.self[ndx]; - if (c == '"' || c == '\\') - ecl_write_char('\\', stream); - ecl_write_char(c, stream); - } - ecl_write_char('"', stream); - } + cl_index ndx; + if (!ecl_print_escape() && !ecl_print_readably()) { + for (ndx = 0; ndx < x->base_string.fillp; ndx++) + ecl_write_char(x->base_string.self[ndx], stream); + } else { + ecl_write_char('"', stream); + for (ndx = 0; ndx < x->base_string.fillp; ndx++) { + int c = x->base_string.self[ndx]; + if (c == '"' || c == '\\') + ecl_write_char('\\', stream); + ecl_write_char(c, stream); + } + ecl_write_char('"', stream); + } } void _ecl_write_bitvector(cl_object x, cl_object stream) { - if (!ecl_print_array() && !ecl_print_readably()) { - writestr_stream("#', stream); - } else { - cl_index ndx; - writestr_stream("#*", stream); - for (ndx = 0; ndx < x->vector.fillp; ndx++) - if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) - ecl_write_char('1', stream); - else - ecl_write_char('0', stream); - } + if (!ecl_print_array() && !ecl_print_readably()) { + writestr_stream("#', stream); + } else { + cl_index ndx; + writestr_stream("#*", stream); + for (ndx = 0; ndx < x->vector.fillp; ndx++) + if (x->vector.self.bit[(ndx+x->vector.offset)/8] & (0200 >> (ndx+x->vector.offset)%8)) + ecl_write_char('1', stream); + else + ecl_write_char('0', stream); + } } diff --git a/src/c/printer/write_code.d b/src/c/printer/write_code.d index e4cf12127..5ebdd9c13 100644 --- a/src/c/printer/write_code.d +++ b/src/c/printer/write_code.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_list.d -- ugly printer for bytecodes and functions -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * write_list.d - ugly printer for bytecodes and functions + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,49 +19,49 @@ void _ecl_write_bytecodes(cl_object x, cl_object stream) { - if (ecl_print_readably()) { - cl_index i; - cl_object lex = ECL_NIL; - cl_object code_l=ECL_NIL; - for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) - code_l = ecl_cons(ecl_make_fixnum(((cl_opcode*)(x->bytecodes.code))[i]), code_l); - writestr_stream("#Y", stream); - si_write_ugly_object(cl_list(7, x->bytecodes.name, lex, - ECL_NIL /* x->bytecodes.definition */, - code_l, x->bytecodes.data, - x->bytecodes.file, - x->bytecodes.file_position), - stream); - } else { - cl_object name = x->bytecodes.name; - writestr_stream("#', stream); - } + if (ecl_print_readably()) { + cl_index i; + cl_object lex = ECL_NIL; + cl_object code_l=ECL_NIL; + for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) + code_l = ecl_cons(ecl_make_fixnum(((cl_opcode*)(x->bytecodes.code))[i]), code_l); + writestr_stream("#Y", stream); + si_write_ugly_object(cl_list(7, x->bytecodes.name, lex, + ECL_NIL /* x->bytecodes.definition */, + code_l, x->bytecodes.data, + x->bytecodes.file, + x->bytecodes.file_position), + stream); + } else { + cl_object name = x->bytecodes.name; + writestr_stream("#', stream); + } } void _ecl_write_bclosure(cl_object x, cl_object stream) { - if (ecl_print_readably()) { - cl_object lex = x->bclosure.lex; - if (Null(lex)) { - _ecl_write_bytecodes(x->bclosure.code, stream); - } else { - writestr_stream("#Y", stream); - si_write_ugly_object(cl_list(2, x->bclosure.code, lex), - stream); - } - } else { - cl_object name = x->bytecodes.name; - writestr_stream("#', stream); - } + if (ecl_print_readably()) { + cl_object lex = x->bclosure.lex; + if (Null(lex)) { + _ecl_write_bytecodes(x->bclosure.code, stream); + } else { + writestr_stream("#Y", stream); + si_write_ugly_object(cl_list(2, x->bclosure.code, lex), + stream); + } + } else { + cl_object name = x->bytecodes.name; + writestr_stream("#', stream); + } } diff --git a/src/c/printer/write_list.d b/src/c/printer/write_list.d index 0babc8bc5..6958f980d 100644 --- a/src/c/printer/write_list.d +++ b/src/c/printer/write_list.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_list.d -- ugly printer for lists -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * write_list.d - ugly printer for lists + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,98 +18,98 @@ void _ecl_write_list(cl_object x, cl_object stream) { - const cl_env_ptr env = ecl_process_env(); - bool circle; - cl_fixnum print_level, print_length; - cl_index i; - cl_object y; - if (Null(x)) { - _ecl_write_symbol(x, stream); - return; + const cl_env_ptr env = ecl_process_env(); + bool circle; + cl_fixnum print_level, print_length; + cl_index i; + cl_object y; + if (Null(x)) { + _ecl_write_symbol(x, stream); + return; + } + if (CAR(x) == @'si::#!') { + writestr_stream("#!", stream); + x = CDR(x); + si_write_object(x, stream); + return; + } + if (CONSP(CDR(x)) && Null(CDDR(x))) { + if (CAR(x) == @'quote') { + ecl_write_char('\'', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'function') { + ecl_write_char('#', stream); + ecl_write_char('\'', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::quasiquote') { + ecl_write_char('`', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote') { + ecl_write_char(',', stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote-splice') { + writestr_stream(",@@", stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + if (CAR(x) == @'si::unquote-nsplice') { + writestr_stream(",.", stream); + x = CADR(x); + si_write_object(x, stream); + return; + } + } + circle = ecl_print_circle(); + if (ecl_print_readably()) { + print_level = MOST_POSITIVE_FIXNUM; + print_length = MOST_POSITIVE_FIXNUM; + } else { + print_level = ecl_print_level(); + print_length = ecl_print_length(); + } + if (print_level == 0) { + ecl_write_char('#', stream); + return; + } + ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level-1)); + ecl_write_char('(', stream); + for (i = 0; ; i++) { + if (i >= print_length) { + writestr_stream("...", stream); + break; + } + y = CAR(x); + x = CDR(x); + si_write_object(y, stream); + /* FIXME! */ + if (x == OBJNULL || ECL_ATOM(x) || + (circle && _ecl_will_print_as_hash(x))) + { + if (x != ECL_NIL) { + ecl_write_char(' ', stream); + writestr_stream(". ", stream); + si_write_object(x, stream); } - if (CAR(x) == @'si::#!') { - writestr_stream("#!", stream); - x = CDR(x); - si_write_object(x, stream); - return; - } - if (CONSP(CDR(x)) && Null(CDDR(x))) { - if (CAR(x) == @'quote') { - ecl_write_char('\'', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'function') { - ecl_write_char('#', stream); - ecl_write_char('\'', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::quasiquote') { - ecl_write_char('`', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::unquote') { - ecl_write_char(',', stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::unquote-splice') { - writestr_stream(",@@", stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - if (CAR(x) == @'si::unquote-nsplice') { - writestr_stream(",.", stream); - x = CADR(x); - si_write_object(x, stream); - return; - } - } - circle = ecl_print_circle(); - if (ecl_print_readably()) { - print_level = MOST_POSITIVE_FIXNUM; - print_length = MOST_POSITIVE_FIXNUM; - } else { - print_level = ecl_print_level(); - print_length = ecl_print_length(); - } - if (print_level == 0) { - ecl_write_char('#', stream); - return; - } - ecl_bds_bind(env, @'*print-level*', ecl_make_fixnum(print_level-1)); - ecl_write_char('(', stream); - for (i = 0; ; i++) { - if (i >= print_length) { - writestr_stream("...", stream); - break; - } - y = CAR(x); - x = CDR(x); - si_write_object(y, stream); - /* FIXME! */ - if (x == OBJNULL || ECL_ATOM(x) || - (circle && _ecl_will_print_as_hash(x))) - { - if (x != ECL_NIL) { - ecl_write_char(' ', stream); - writestr_stream(". ", stream); - si_write_object(x, stream); - } - break; - } - if (i == 0 && y != OBJNULL && ecl_t_of(y) == t_symbol) - ecl_write_char(' ', stream); - else - ecl_write_char(' ', stream); - } - ecl_write_char(')', stream); - ecl_bds_unwind1(env); + break; + } + if (i == 0 && y != OBJNULL && ecl_t_of(y) == t_symbol) + ecl_write_char(' ', stream); + else + ecl_write_char(' ', stream); + } + ecl_write_char(')', stream); + ecl_bds_unwind1(env); } diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d index 976cc3b26..f8ef11980 100644 --- a/src/c/printer/write_object.d +++ b/src/c/printer/write_object.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_object.d -- basic printer routine. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * write_object.d - basic printer routine + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,18 +19,18 @@ bool _ecl_will_print_as_hash(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); - cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (ECL_FIXNUMP(circle_counter)) { - return !(code == OBJNULL || code == ECL_NIL); - } else if (code == OBJNULL) { - /* Was not found before */ - _ecl_sethash(x, circle_stack, ECL_NIL); - return 0; - } else { - return 1; - } + cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + cl_object code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (ECL_FIXNUMP(circle_counter)) { + return !(code == OBJNULL || code == ECL_NIL); + } else if (code == OBJNULL) { + /* Was not found before */ + _ecl_sethash(x, circle_stack, ECL_NIL); + return 0; + } else { + return 1; + } } /* To print circular structures, we traverse the structure by adding @@ -44,106 +39,106 @@ _ecl_will_print_as_hash(cl_object x) After the visit we squeeze out all the non circular elements. The flags is used during printing to distinguish between the first visit to the element. - */ +*/ static cl_fixnum search_print_circle(cl_object x) { - cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); - cl_object code; + cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); + cl_object code; - if (!ECL_FIXNUMP(circle_counter)) { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (code == OBJNULL) { - /* Was not found before */ - _ecl_sethash(x, circle_stack, ECL_NIL); - return 0; - } else if (code == ECL_NIL) { - /* This object is referenced twice */ - _ecl_sethash(x, circle_stack, ECL_T); - return 1; - } else { - return 2; - } - } else { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); - if (code == OBJNULL || code == ECL_NIL) { - /* Is not referenced or was not found before */ - /* _ecl_sethash(x, circle_stack, ECL_NIL); */ - return 0; - } else if (code == ECL_T) { - /* This object is referenced twice, but has no code yet */ - cl_fixnum new_code = ecl_fixnum(circle_counter) + 1; - circle_counter = ecl_make_fixnum(new_code); - _ecl_sethash(x, circle_stack, circle_counter); - ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', - circle_counter); - return -new_code; - } else { - return ecl_fixnum(code); - } - } + if (!ECL_FIXNUMP(circle_counter)) { + code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (code == OBJNULL) { + /* Was not found before */ + _ecl_sethash(x, circle_stack, ECL_NIL); + return 0; + } else if (code == ECL_NIL) { + /* This object is referenced twice */ + _ecl_sethash(x, circle_stack, ECL_T); + return 1; + } else { + return 2; + } + } else { + code = ecl_gethash_safe(x, circle_stack, OBJNULL); + if (code == OBJNULL || code == ECL_NIL) { + /* Is not referenced or was not found before */ + /* _ecl_sethash(x, circle_stack, ECL_NIL); */ + return 0; + } else if (code == ECL_T) { + /* This object is referenced twice, but has no code yet */ + cl_fixnum new_code = ecl_fixnum(circle_counter) + 1; + circle_counter = ecl_make_fixnum(new_code); + _ecl_sethash(x, circle_stack, circle_counter); + ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', + circle_counter); + return -new_code; + } else { + return ecl_fixnum(code); + } + } } cl_object si_write_object(cl_object x, cl_object stream) { - bool circle; + bool circle; #ifdef ECL_CMU_FORMAT - if (ecl_symbol_value(@'*print-pretty*') != ECL_NIL) { - cl_object f = _ecl_funcall2(@'pprint-dispatch', x); - if (VALUES(1) != ECL_NIL) { - _ecl_funcall3(f, stream, x); - goto OUTPUT; - } - } + if (ecl_symbol_value(@'*print-pretty*') != ECL_NIL) { + cl_object f = _ecl_funcall2(@'pprint-dispatch', x); + if (VALUES(1) != ECL_NIL) { + _ecl_funcall3(f, stream, x); + goto OUTPUT; + } + } #endif /* ECL_CMU_FORMAT */ - circle = ecl_print_circle(); - if (circle && !Null(x) && !ECL_FIXNUMP(x) && !ECL_CHARACTERP(x) && - (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) - { - cl_object circle_counter; - cl_fixnum code; - circle_counter = ecl_symbol_value(@'si::*circle-counter*'); - if (circle_counter == ECL_NIL) { - cl_env_ptr env = ecl_process_env(); - cl_object hash = - cl__make_hash_table(@'eq', - ecl_make_fixnum(1024), - cl_core.rehash_size, - cl_core.rehash_threshold); - ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); - ecl_bds_bind(env, @'si::*circle-stack*', hash); - si_write_object(x, cl_core.null_stream); - ECL_SETQ(env, @'si::*circle-counter*', ecl_make_fixnum(0)); - si_write_object(x, stream); - cl_clrhash(hash); - ecl_bds_unwind_n(env, 2); - goto OUTPUT; - } - code = search_print_circle(x); - if (!ECL_FIXNUMP(circle_counter)) { - /* We are only inspecting the object to be printed. */ - /* Only run X if it was not referenced before */ - if (code != 0) - goto OUTPUT; - } else if (code == 0) { - /* Object is not referenced twice */ - } else if (code < 0) { - /* Object is referenced twice. We print its definition */ - ecl_write_char('#', stream); - _ecl_write_fixnum(-code, stream); - ecl_write_char('=', stream); - } else { - /* Second reference to the object */ - ecl_write_char('#', stream); - _ecl_write_fixnum(code, stream); - ecl_write_char('#', stream); - goto OUTPUT; - } - } - return si_write_ugly_object(x, stream); + circle = ecl_print_circle(); + if (circle && !Null(x) && !ECL_FIXNUMP(x) && !ECL_CHARACTERP(x) && + (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) + { + cl_object circle_counter; + cl_fixnum code; + circle_counter = ecl_symbol_value(@'si::*circle-counter*'); + if (circle_counter == ECL_NIL) { + cl_env_ptr env = ecl_process_env(); + cl_object hash = + cl__make_hash_table(@'eq', + ecl_make_fixnum(1024), + cl_core.rehash_size, + cl_core.rehash_threshold); + ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); + ecl_bds_bind(env, @'si::*circle-stack*', hash); + si_write_object(x, cl_core.null_stream); + ECL_SETQ(env, @'si::*circle-counter*', ecl_make_fixnum(0)); + si_write_object(x, stream); + cl_clrhash(hash); + ecl_bds_unwind_n(env, 2); + goto OUTPUT; + } + code = search_print_circle(x); + if (!ECL_FIXNUMP(circle_counter)) { + /* We are only inspecting the object to be printed. */ + /* Only run X if it was not referenced before */ + if (code != 0) + goto OUTPUT; + } else if (code == 0) { + /* Object is not referenced twice */ + } else if (code < 0) { + /* Object is referenced twice. We print its definition */ + ecl_write_char('#', stream); + _ecl_write_fixnum(-code, stream); + ecl_write_char('=', stream); + } else { + /* Second reference to the object */ + ecl_write_char('#', stream); + _ecl_write_fixnum(code, stream); + ecl_write_char('#', stream); + goto OUTPUT; + } + } + return si_write_ugly_object(x, stream); OUTPUT: - @(return x) + @(return x); } diff --git a/src/c/printer/write_sse.d b/src/c/printer/write_sse.d index d3447af7d..0c8cc291d 100644 --- a/src/c/printer/write_sse.d +++ b/src/c/printer/write_sse.d @@ -1,21 +1,17 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_list.d -- ugly printer for SSE types -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. + * write_sse.d - ugly printer for SSE types + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ - ECL 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. -*/ #ifdef ECL_SSE2 #include #include @@ -23,78 +19,78 @@ static int is_all_FF(void *ptr, int size) { - int i; - for (i = 0; i < size; i++) - if (((unsigned char*)ptr)[i] != 0xFF) - return 0; - return 1; + int i; + for (i = 0; i < size; i++) + if (((unsigned char*)ptr)[i] != 0xFF) + return 0; + return 1; } static void write_sse_float(float v, cl_object stream) { - if (is_all_FF(&v, sizeof(float))) { - writestr_stream(" TRUE", stream); - } else { - ecl_write_char(' ', stream); - si_write_ugly_object(ecl_make_single_float(v), stream); - } + if (is_all_FF(&v, sizeof(float))) { + writestr_stream(" TRUE", stream); + } else { + ecl_write_char(' ', stream); + si_write_ugly_object(ecl_make_single_float(v), stream); + } } static void write_sse_double(double v, cl_object stream) { - if (is_all_FF(&v, sizeof(double))) - writestr_stream(" TRUE", stream); - else { - ecl_write_char(' ', stream); - si_write_ugly_object(ecl_make_double_float(v), stream); - } + if (is_all_FF(&v, sizeof(double))) + writestr_stream(" TRUE", stream); + else { + ecl_write_char(' ', stream); + si_write_ugly_object(ecl_make_double_float(v), stream); + } } static void write_sse_pack(cl_object x, cl_object stream) { - int i; - cl_elttype etype = x->sse.elttype; - cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); + int i; + cl_elttype etype = x->sse.elttype; + cl_object mode = ecl_symbol_value(@'ext::*sse-pack-print-mode*'); - if (mode != ECL_NIL) { - if (mode == @':float') etype = ecl_aet_sf; - else if (mode == @':double') etype = ecl_aet_df; - else etype = ecl_aet_b8; - } + if (mode != ECL_NIL) { + if (mode == @':float') etype = ecl_aet_sf; + else if (mode == @':double') etype = ecl_aet_df; + else etype = ecl_aet_b8; + } - switch (etype) { - case ecl_aet_sf: - for (i = 0; i < 4; i++) - write_sse_float(x->sse.data.sf[i], stream); - break; - case ecl_aet_df: - write_sse_double(x->sse.data.df[0], stream); - write_sse_double(x->sse.data.df[1], stream); - break; - default: { - cl_object buffer = si_get_buffer_string(); - for (i = 0; i < 16; i++) { - ecl_string_push_extend(buffer, ' '); - if (i%4 == 0) ecl_string_push_extend(buffer, ' '); - si_integer_to_string(buffer, ecl_make_fixnum(x->sse.data.b8[i]), - ecl_make_fixnum(16), ECL_NIL, ECL_NIL); - } - si_do_write_sequence(buffer, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(buffer); - break; - } - } + switch (etype) { + case ecl_aet_sf: + for (i = 0; i < 4; i++) + write_sse_float(x->sse.data.sf[i], stream); + break; + case ecl_aet_df: + write_sse_double(x->sse.data.df[0], stream); + write_sse_double(x->sse.data.df[1], stream); + break; + default: { + cl_object buffer = si_get_buffer_string(); + for (i = 0; i < 16; i++) { + ecl_string_push_extend(buffer, ' '); + if (i%4 == 0) ecl_string_push_extend(buffer, ' '); + si_integer_to_string(buffer, ecl_make_fixnum(x->sse.data.b8[i]), + ecl_make_fixnum(16), ECL_NIL, ECL_NIL); + } + si_do_write_sequence(buffer, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(buffer); + break; + } + } } void _ecl_write_sse(cl_object x, cl_object stream) { - if (ecl_print_readably()) FEprint_not_readable(x); - writestr_stream("#', stream); + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#', stream); } #endif diff --git a/src/c/printer/write_symbol.d b/src/c/printer/write_symbol.d index 432fa28da..681aead06 100644 --- a/src/c/printer/write_symbol.d +++ b/src/c/printer/write_symbol.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - write_symbol.d -- print a symbol. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * write_symbol.d - print a symbol + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -23,48 +18,48 @@ static bool potential_number_p(cl_object s, int base) { - /* See ANSI 2.3.1.1 */ - static cl_index i, l; - ecl_character c; - /* A potential number must contain at least one digit */ - bool some_digit = FALSE; + /* See ANSI 2.3.1.1 */ + static cl_index i, l; + ecl_character c; + /* A potential number must contain at least one digit */ + bool some_digit = FALSE; - l = s->base_string.fillp; - if (l == 0) - return FALSE; - c = ecl_char(s, 0); + l = s->base_string.fillp; + if (l == 0) + return FALSE; + c = ecl_char(s, 0); - /* A potential number must begin with a digit, sign or - extension character (^ _) */ - if (ecl_digitp(c,base) >= 0) - some_digit = TRUE; - else if (c != '+' && c != '-' && c != '^' && c != '_') - return FALSE; + /* A potential number must begin with a digit, sign or + extension character (^ _) */ + if (ecl_digitp(c,base) >= 0) + some_digit = TRUE; + else if (c != '+' && c != '-' && c != '^' && c != '_') + return FALSE; - /* A potential number cannot end with a sign */ - c = ecl_char(s, l-1); - if (c == '+' || c == '-') - return FALSE; + /* A potential number cannot end with a sign */ + c = ecl_char(s, l-1); + if (c == '+' || c == '-') + return FALSE; - for (i = 1; i < l; i++) { - c = ecl_char(s, i); - /* It can only contain digits, signs, ratio markers, - * extension characters and number markers. Number - * markers are letters, but two adjacent letters fail - * to be a number marker. */ - if (ecl_digitp(c, base) >= 0) { - some_digit = TRUE; - } else if (c == '+' || c == '-' || - c == '/' || c == '.' || c == '^' || c == '_') { - continue; - } else if (ecl_alpha_char_p(c) && - (((i+1) >= l) || !ecl_alpha_char_p(ecl_char(s, i+1)))) { - continue; - } else { - return FALSE; - } - } - return some_digit; + for (i = 1; i < l; i++) { + c = ecl_char(s, i); + /* It can only contain digits, signs, ratio markers, + * extension characters and number markers. Number + * markers are letters, but two adjacent letters fail + * to be a number marker. */ + if (ecl_digitp(c, base) >= 0) { + some_digit = TRUE; + } else if (c == '+' || c == '-' || + c == '/' || c == '.' || c == '^' || c == '_') { + continue; + } else if (ecl_alpha_char_p(c) && + (((i+1) >= l) || !ecl_alpha_char_p(ecl_char(s, i+1)))) { + continue; + } else { + return FALSE; + } + } + return some_digit; } #define needs_to_be_inverted(s) (ecl_string_case(s) != 0) @@ -72,149 +67,148 @@ potential_number_p(cl_object s, int base) static bool all_dots(cl_object s) { - cl_index i; - for (i = 0; i < s->base_string.fillp; i++) - if (ecl_char(s, i) != '.') - return 0; - return 1; + cl_index i; + for (i = 0; i < s->base_string.fillp; i++) + if (ecl_char(s, i) != '.') + return 0; + return 1; } static bool needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case) { - int action = readtable->readtable.read_case; - cl_index i; - if (potential_number_p(s, ecl_print_base())) - return 1; - /* The value of *PRINT-ESCAPE* is T. We need to check whether the - * symbol name S needs to be escaped. This will happen if it has some - * strange character, or if it has a lowercase character (because such - * a character cannot be read with the standard readtable) or if the - * string has to be escaped according to readtable case and the rules - * of 22.1.3.3.2. */ - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - int syntax = ecl_readtable_get(readtable, c, 0); - if (syntax != cat_constituent || - ecl_invalid_character_p(c) || - (c) == ':') - return 1; - if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) - return 1; - if (ecl_lower_case_p(c)) - return 1; - } - return 0; + int action = readtable->readtable.read_case; + cl_index i; + if (potential_number_p(s, ecl_print_base())) + return 1; + /* The value of *PRINT-ESCAPE* is T. We need to check whether the + * symbol name S needs to be escaped. This will happen if it has some + * strange character, or if it has a lowercase character (because such + * a character cannot be read with the standard readtable) or if the + * string has to be escaped according to readtable case and the rules + * of 22.1.3.3.2. */ + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + int syntax = ecl_readtable_get(readtable, c, 0); + if (syntax != cat_constituent || + ecl_invalid_character_p(c) || + (c) == ':') + return 1; + if ((action == ecl_case_downcase) && ecl_upper_case_p(c)) + return 1; + if (ecl_lower_case_p(c)) + return 1; + } + return 0; } static void write_symbol_string(cl_object s, int action, cl_object print_case, cl_object stream, bool escape) { - cl_index i; - bool capitalize; - if (action == ecl_case_invert) { - if (!needs_to_be_inverted(s)) - action = ecl_case_preserve; - } - if (escape) - ecl_write_char('|', stream); - capitalize = 1; - for (i = 0; i < s->base_string.fillp; i++) { - int c = ecl_char(s, i); - if (escape) { - if (c == '|' || c == '\\') { - ecl_write_char('\\', stream); - } - } else if (action != ecl_case_preserve) { - if (ecl_upper_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_upcase) && - ((print_case == @':downcase') || - ((print_case == @':capitalize') && !capitalize)))) - { - c = ecl_char_downcase(c); - } - capitalize = 0; - } else if (ecl_lower_case_p(c)) { - if ((action == ecl_case_invert) || - ((action == ecl_case_downcase) && - ((print_case == @':upcase') || - ((print_case == @':capitalize') && capitalize)))) - { - c = ecl_char_upcase(c); - } - capitalize = 0; - } else { - capitalize = !ecl_alphanumericp(c); - } - } - ecl_write_char(c, stream); - } - if (escape) - ecl_write_char('|', stream); + cl_index i; + bool capitalize; + if (action == ecl_case_invert) { + if (!needs_to_be_inverted(s)) + action = ecl_case_preserve; + } + if (escape) + ecl_write_char('|', stream); + capitalize = 1; + for (i = 0; i < s->base_string.fillp; i++) { + int c = ecl_char(s, i); + if (escape) { + if (c == '|' || c == '\\') { + ecl_write_char('\\', stream); + } + } else if (action != ecl_case_preserve) { + if (ecl_upper_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_upcase) && + ((print_case == @':downcase') || + ((print_case == @':capitalize') && !capitalize)))) + { + c = ecl_char_downcase(c); + } + capitalize = 0; + } else if (ecl_lower_case_p(c)) { + if ((action == ecl_case_invert) || + ((action == ecl_case_downcase) && + ((print_case == @':upcase') || + ((print_case == @':capitalize') && capitalize)))) + { + c = ecl_char_upcase(c); + } + capitalize = 0; + } else { + capitalize = !ecl_alphanumericp(c); + } + } + ecl_write_char(c, stream); + } + if (escape) + ecl_write_char('|', stream); } static bool forced_print_package(cl_object package) { - cl_object print_package = ecl_symbol_value(@'si::*print-package*'); - return !Null(print_package) && (print_package != package); + cl_object print_package = ecl_symbol_value(@'si::*print-package*'); + return !Null(print_package) && (print_package != package); } void _ecl_write_symbol(cl_object x, cl_object stream) { - cl_object readtable = ecl_current_readtable(); - cl_object print_case = ecl_print_case(); - cl_object package; - cl_object name; - int intern_flag; - bool print_readably = ecl_print_readably(); - bool forced_package = 0; + cl_object readtable = ecl_current_readtable(); + cl_object print_case = ecl_print_case(); + cl_object package; + cl_object name; + int intern_flag; + bool print_readably = ecl_print_readably(); + bool forced_package = 0; - if (Null(x)) { - package = ECL_NIL_SYMBOL->symbol.hpack; - name = ECL_NIL_SYMBOL->symbol.name; - } else { - package = x->symbol.hpack; - name = x->symbol.name; - } + if (Null(x)) { + package = ECL_NIL_SYMBOL->symbol.hpack; + name = ECL_NIL_SYMBOL->symbol.name; + } else { + package = x->symbol.hpack; + name = x->symbol.name; + } - if (!print_readably && !ecl_print_escape()) { - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, 0); - return; - } - /* From here on, print-escape is true which means that it should - * be possible to recover the same symbol by reading it with - * the standard readtable (which has readtable-case = :UPCASE) - */ - if (Null(package)) { - if (print_readably || ecl_print_gensym()) - writestr_stream("#:", stream); - } else if (package == cl_core.keyword_package) { - ecl_write_char(':', stream); - } else if ((forced_package = forced_print_package(package)) - || ecl_find_symbol(name, ecl_current_package(), &intern_flag) != x - || (intern_flag == 0)) - { - cl_object name = package->pack.name; - write_symbol_string(name, readtable->readtable.read_case, - print_case, stream, - needs_to_be_escaped(name, readtable, print_case)); - if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) - ecl_internal_error("can't print symbol"); - if (intern_flag == ECL_INTERNAL || forced_package) { - writestr_stream("::", stream); - } else if (intern_flag == ECL_EXTERNAL) { - ecl_write_char(':', stream); - } else { - FEerror("Pathological symbol --- cannot print.", 0); - } - } - write_symbol_string(name, readtable->readtable.read_case, print_case, stream, - needs_to_be_escaped(name, readtable, print_case) || - all_dots(name)); + if (!print_readably && !ecl_print_escape()) { + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, 0); + return; + } + /* From here on, print-escape is true which means that it should + * be possible to recover the same symbol by reading it with + * the standard readtable (which has readtable-case = :UPCASE) + */ + if (Null(package)) { + if (print_readably || ecl_print_gensym()) + writestr_stream("#:", stream); + } else if (package == cl_core.keyword_package) { + ecl_write_char(':', stream); + } else if ((forced_package = forced_print_package(package)) + || ecl_find_symbol(name, ecl_current_package(), &intern_flag) != x + || (intern_flag == 0)) + { + cl_object name = package->pack.name; + write_symbol_string(name, readtable->readtable.read_case, + print_case, stream, + needs_to_be_escaped(name, readtable, print_case)); + if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x) + ecl_internal_error("can't print symbol"); + if (intern_flag == ECL_INTERNAL || forced_package) { + writestr_stream("::", stream); + } else if (intern_flag == ECL_EXTERNAL) { + ecl_write_char(':', stream); + } else { + FEerror("Pathological symbol --- cannot print.", 0); + } + } + write_symbol_string(name, readtable->readtable.read_case, print_case, stream, + needs_to_be_escaped(name, readtable, print_case) || + all_dots(name)); } - diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index 30824b85c..2b7e071d9 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - print.d -- Print. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * write_ugly.d - ugly printer + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -29,363 +24,363 @@ static void write_readable_pathname(cl_object path, cl_object stream) { - cl_object l = - cl_list(15, @'make-pathname', - @':host', path->pathname.host, - @':device', path->pathname.device, - @':directory', - _ecl_funcall2(@'ext::maybe-quote', path->pathname.directory), - @':name', path->pathname.name, - @':type', path->pathname.type, - @':version', path->pathname.version, - @':defaults', ECL_NIL); - writestr_stream("#.", stream); - si_write_object(l, stream); + cl_object l = + cl_list(15, @'make-pathname', + @':host', path->pathname.host, + @':device', path->pathname.device, + @':directory', + _ecl_funcall2(@'ext::maybe-quote', path->pathname.directory), + @':name', path->pathname.name, + @':type', path->pathname.type, + @':version', path->pathname.version, + @':defaults', ECL_NIL); + writestr_stream("#.", stream); + si_write_object(l, stream); } static void write_pathname(cl_object path, cl_object stream) { - cl_object namestring = ecl_namestring(path, 0); - bool readably = ecl_print_readably(); - if (namestring == ECL_NIL) { - if (readably) { - write_readable_pathname(path, stream); - return; - } - namestring = ecl_namestring(path, 1); - if (namestring == ECL_NIL) { - writestr_stream("#", stream); - return; - } - } - if (readably || ecl_print_escape()) - writestr_stream("#P", stream); - si_write_ugly_object(namestring, stream); + cl_object namestring = ecl_namestring(path, 0); + bool readably = ecl_print_readably(); + if (namestring == ECL_NIL) { + if (readably) { + write_readable_pathname(path, stream); + return; + } + namestring = ecl_namestring(path, 1); + if (namestring == ECL_NIL) { + writestr_stream("#", stream); + return; + } + } + if (readably || ecl_print_escape()) + writestr_stream("#P", stream); + si_write_ugly_object(namestring, stream); } static void write_integer(cl_object number, cl_object stream) { - cl_object s = si_get_buffer_string(); - int print_base = ecl_print_base(); - si_integer_to_string(s, number, - ecl_make_fixnum(print_base), - ecl_symbol_value(@'*print-radix*'), - ECL_T /* decimal syntax */); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, number, + ecl_make_fixnum(print_base), + ecl_symbol_value(@'*print-radix*'), + ECL_T /* decimal syntax */); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } void _ecl_write_fixnum(cl_fixnum i, cl_object stream) { - cl_object s = si_get_buffer_string(); - si_integer_to_string(s, ecl_make_fixnum(i), ecl_make_fixnum(10), ECL_NIL, ECL_NIL); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + si_integer_to_string(s, ecl_make_fixnum(i), ecl_make_fixnum(10), ECL_NIL, ECL_NIL); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } static void write_ratio(cl_object r, cl_object stream) { - cl_object s = si_get_buffer_string(); - int print_base = ecl_print_base(); - si_integer_to_string(s, r->ratio.num, ecl_make_fixnum(print_base), - ecl_symbol_value(@'*print-radix*'), - ECL_NIL /* decimal syntax */); - ecl_string_push_extend(s, '/'); - si_integer_to_string(s, r->ratio.den, - ecl_make_fixnum(print_base), - ECL_NIL, ECL_NIL); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + int print_base = ecl_print_base(); + si_integer_to_string(s, r->ratio.num, ecl_make_fixnum(print_base), + ecl_symbol_value(@'*print-radix*'), + ECL_NIL /* decimal syntax */); + ecl_string_push_extend(s, '/'); + si_integer_to_string(s, r->ratio.den, + ecl_make_fixnum(print_base), + ECL_NIL, ECL_NIL); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } static void write_complex(cl_object x, cl_object stream) { - writestr_stream("#C(", stream); - si_write_ugly_object(x->complex.real, stream); - ecl_write_char(' ', stream); - si_write_ugly_object(x->complex.imag, stream); - ecl_write_char(')', stream); + writestr_stream("#C(", stream); + si_write_ugly_object(x->complex.real, stream); + ecl_write_char(' ', stream); + si_write_ugly_object(x->complex.imag, stream); + ecl_write_char(')', stream); } static void write_float(cl_object f, cl_object stream) { - cl_object s = si_get_buffer_string(); - s = si_float_to_string_free(s, f, ecl_make_fixnum(-3), ecl_make_fixnum(8)); - si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); - si_put_buffer_string(s); + cl_object s = si_get_buffer_string(); + s = si_float_to_string_free(s, f, ecl_make_fixnum(-3), ecl_make_fixnum(8)); + si_do_write_sequence(s, stream, ecl_make_fixnum(0), ECL_NIL); + si_put_buffer_string(s); } static void write_character(cl_object x, cl_object stream) { - int i = ECL_CHAR_CODE(x); - if (!ecl_print_escape() && !ecl_print_readably()) { - ecl_write_char(i, stream); - } else { - writestr_stream("#\\", stream); - if (i < 32 || i >= 127) { - cl_object name = cl_char_name(ECL_CODE_CHAR(i)); - writestr_stream((char*)name->base_string.self, stream); - } else { - ecl_write_char(i, stream); - } - } + int i = ECL_CHAR_CODE(x); + if (!ecl_print_escape() && !ecl_print_readably()) { + ecl_write_char(i, stream); + } else { + writestr_stream("#\\", stream); + if (i < 32 || i >= 127) { + cl_object name = cl_char_name(ECL_CODE_CHAR(i)); + writestr_stream((char*)name->base_string.self, stream); + } else { + ecl_write_char(i, stream); + } + } } static void write_package(cl_object x, cl_object stream) { - if (ecl_print_readably()) FEprint_not_readable(x); - writestr_stream("#<", stream); - si_write_ugly_object(x->pack.name, stream); - writestr_stream(" package>", stream); + if (ecl_print_readably()) FEprint_not_readable(x); + writestr_stream("#<", stream); + si_write_ugly_object(x->pack.name, stream); + writestr_stream(" package>", stream); } static void write_hashtable(cl_object x, cl_object stream) { - if (ecl_print_readably() && !Null(ecl_symbol_value(@'*read-eval*'))) { - cl_object make = - cl_list(9, @'make-hash-table', - @':size', cl_hash_table_size(x), - @':rehash-size', cl_hash_table_rehash_size(x), - @':rehash-threshold', cl_hash_table_rehash_threshold(x), - @':test', cl_list(2, @'quote', cl_hash_table_test(x))); - cl_object init = - cl_list(3, @'ext::hash-table-fill', make, - cl_list(2, @'quote', si_hash_table_content(x))); - writestr_stream("#.", stream); - si_write_ugly_object(init, stream); - } else { - _ecl_write_unreadable(x, "hash-table", ECL_NIL, stream); - } + if (ecl_print_readably() && !Null(ecl_symbol_value(@'*read-eval*'))) { + cl_object make = + cl_list(9, @'make-hash-table', + @':size', cl_hash_table_size(x), + @':rehash-size', cl_hash_table_rehash_size(x), + @':rehash-threshold', cl_hash_table_rehash_threshold(x), + @':test', cl_list(2, @'quote', cl_hash_table_test(x))); + cl_object init = + cl_list(3, @'ext::hash-table-fill', make, + cl_list(2, @'quote', si_hash_table_content(x))); + writestr_stream("#.", stream); + si_write_ugly_object(init, stream); + } else { + _ecl_write_unreadable(x, "hash-table", ECL_NIL, stream); + } } static void write_random(cl_object x, cl_object stream) { - if (ecl_print_readably()) { - writestr_stream("#$", stream); - _ecl_write_vector(x->random.value, stream); - } else { - _ecl_write_unreadable(x->random.value, "random-state", ECL_NIL, stream); - } + if (ecl_print_readably()) { + writestr_stream("#$", stream); + _ecl_write_vector(x->random.value, stream); + } else { + _ecl_write_unreadable(x->random.value, "random-state", ECL_NIL, stream); + } } static void write_stream(cl_object x, cl_object stream) { - const char *prefix; - cl_object tag; - union cl_lispunion str; + const char *prefix; + cl_object tag; + union cl_lispunion str; #ifdef ECL_UNICODE - ecl_character buffer[10]; + ecl_character buffer[10]; #else - ecl_base_char buffer[10]; + ecl_base_char buffer[10]; #endif - switch ((enum ecl_smmode)x->stream.mode) { - case ecl_smm_input_file: - prefix = "closed input file"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_input: - prefix = "closed input stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_output_file: - prefix = "closed output file"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_output: - prefix = "closed output stream"; - tag = IO_STREAM_FILENAME(x); - break; + switch ((enum ecl_smmode)x->stream.mode) { + case ecl_smm_input_file: + prefix = "closed input file"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_input: + prefix = "closed input stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_output_file: + prefix = "closed output file"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_output: + prefix = "closed output stream"; + tag = IO_STREAM_FILENAME(x); + break; #ifdef ECL_MS_WINDOWS_HOST - case ecl_smm_input_wsock: - prefix = "closed input win32 socket stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_output_wsock: - prefix = "closed output win32 socket stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_io_wsock: - prefix = "closed i/o win32 socket stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_io_wcon: - prefix = "closed i/o win32 console stream"; - tag = IO_STREAM_FILENAME(x); - break; + case ecl_smm_input_wsock: + prefix = "closed input win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_output_wsock: + prefix = "closed output win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_io_wsock: + prefix = "closed i/o win32 socket stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_io_wcon: + prefix = "closed i/o win32 console stream"; + tag = IO_STREAM_FILENAME(x); + break; #endif - case ecl_smm_io_file: - prefix = "closed io file"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_io: - prefix = "closed io stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_probe: - prefix = "closed probe stream"; - tag = IO_STREAM_FILENAME(x); - break; - case ecl_smm_synonym: - prefix = "closed synonym stream to"; - tag = SYNONYM_STREAM_SYMBOL(x); - break; - case ecl_smm_broadcast: - prefix = "closed broadcast stream"; - tag = ECL_NIL; - break; - case ecl_smm_concatenated: - prefix = "closed concatenated stream"; - tag = ECL_NIL; - break; - case ecl_smm_two_way: - prefix = "closed two-way stream"; - tag = ECL_NIL; - break; - case ecl_smm_echo: - prefix = "closed echo stream"; - tag = ECL_NIL; - break; - case ecl_smm_string_input: { - cl_object text = x->stream.object0; - cl_index ndx, l = ecl_length(text); - for (ndx = 0; (ndx < 8) && (ndx < l); ndx++) { - buffer[ndx] = ecl_char(text, ndx); - } - if (l > ndx) { - buffer[ndx-1] = '.'; - buffer[ndx-2] = '.'; - buffer[ndx-3] = '.'; - } - buffer[ndx++] = 0; - prefix = "closed string-input stream from"; - tag = &str; + case ecl_smm_io_file: + prefix = "closed io file"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_io: + prefix = "closed io stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_probe: + prefix = "closed probe stream"; + tag = IO_STREAM_FILENAME(x); + break; + case ecl_smm_synonym: + prefix = "closed synonym stream to"; + tag = SYNONYM_STREAM_SYMBOL(x); + break; + case ecl_smm_broadcast: + prefix = "closed broadcast stream"; + tag = ECL_NIL; + break; + case ecl_smm_concatenated: + prefix = "closed concatenated stream"; + tag = ECL_NIL; + break; + case ecl_smm_two_way: + prefix = "closed two-way stream"; + tag = ECL_NIL; + break; + case ecl_smm_echo: + prefix = "closed echo stream"; + tag = ECL_NIL; + break; + case ecl_smm_string_input: { + cl_object text = x->stream.object0; + cl_index ndx, l = ecl_length(text); + for (ndx = 0; (ndx < 8) && (ndx < l); ndx++) { + buffer[ndx] = ecl_char(text, ndx); + } + if (l > ndx) { + buffer[ndx-1] = '.'; + buffer[ndx-2] = '.'; + buffer[ndx-3] = '.'; + } + buffer[ndx++] = 0; + prefix = "closed string-input stream from"; + tag = &str; #ifdef ECL_UNICODE - tag->string.t = t_string; - tag->string.self = buffer; + tag->string.t = t_string; + tag->string.self = buffer; #else - tag->base_string.t = t_base_string; - tag->base_string.self = buffer; + tag->base_string.t = t_base_string; + tag->base_string.self = buffer; #endif - tag->base_string.dim = ndx; - tag->base_string.fillp = ndx-1; - break; - } - case ecl_smm_string_output: - prefix = "closed string-output stream"; - tag = ECL_NIL; - break; - case ecl_smm_sequence_input: - prefix = "closed sequence-input stream"; - tag = ECL_NIL; - break; - case ecl_smm_sequence_output: - prefix = "closed sequence-output stream"; - tag = ECL_NIL; - break; - default: - ecl_internal_error("illegal stream mode"); - } - if (!x->stream.closed) - prefix = prefix + 7; - _ecl_write_unreadable(x, prefix, tag, stream); + tag->base_string.dim = ndx; + tag->base_string.fillp = ndx-1; + break; + } + case ecl_smm_string_output: + prefix = "closed string-output stream"; + tag = ECL_NIL; + break; + case ecl_smm_sequence_input: + prefix = "closed sequence-input stream"; + tag = ECL_NIL; + break; + case ecl_smm_sequence_output: + prefix = "closed sequence-output stream"; + tag = ECL_NIL; + break; + default: + ecl_internal_error("illegal stream mode"); + } + if (!x->stream.closed) + prefix = prefix + 7; + _ecl_write_unreadable(x, prefix, tag, stream); } static void write_instance(cl_object x, cl_object stream) { - _ecl_funcall3(@'print-object', x, stream); + _ecl_funcall3(@'print-object', x, stream); } static void write_readtable(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "readtable", ECL_NIL, stream); + _ecl_write_unreadable(x, "readtable", ECL_NIL, stream); } static void write_cfun(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "compiled-function", x->cfun.name, stream); + _ecl_write_unreadable(x, "compiled-function", x->cfun.name, stream); } static void write_codeblock(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "codeblock", x->cblock.name, stream); + _ecl_write_unreadable(x, "codeblock", x->cblock.name, stream); } static void write_cclosure(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "compiled-closure", ECL_NIL, stream); + _ecl_write_unreadable(x, "compiled-closure", ECL_NIL, stream); } static void write_foreign(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "foreign", x->foreign.tag, stream); + _ecl_write_unreadable(x, "foreign", x->foreign.tag, stream); } static void write_frame(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), stream); + _ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), stream); } static void write_weak_pointer(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "weak-pointer", ECL_NIL, stream); + _ecl_write_unreadable(x, "weak-pointer", ECL_NIL, stream); } #ifdef ECL_THREADS static void write_process(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "process", x->process.name, stream); + _ecl_write_unreadable(x, "process", x->process.name, stream); } static void write_lock(cl_object x, cl_object stream) { - const char *prefix = x->lock.recursive? - "lock" : "lock (nonrecursive)"; - _ecl_write_unreadable(x, prefix, x->lock.name, stream); + const char *prefix = x->lock.recursive? + "lock" : "lock (nonrecursive)"; + _ecl_write_unreadable(x, prefix, x->lock.name, stream); } static void write_condition_variable(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); + _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); } static void write_semaphore(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); + _ecl_write_unreadable(x, "semaphore", ECL_NIL, stream); } static void write_barrier(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "barrier", ECL_NIL, stream); + _ecl_write_unreadable(x, "barrier", ECL_NIL, stream); } static void write_mailbox(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "mailbox", ECL_NIL, stream); + _ecl_write_unreadable(x, "mailbox", ECL_NIL, stream); } #endif /* ECL_THREADS */ @@ -393,75 +388,75 @@ write_mailbox(cl_object x, cl_object stream) static void write_illegal(cl_object x, cl_object stream) { - _ecl_write_unreadable(x, "illegal pointer", ECL_NIL, stream); + _ecl_write_unreadable(x, "illegal pointer", ECL_NIL, stream); } typedef void (*printer)(cl_object x, cl_object stream); static printer dispatch[FREE+1] = { - 0 /* t_start = 0 */, - _ecl_write_list, /* t_list = 1 */ - write_character, /* t_character = 2 */ - write_integer, /* t_fixnum = 3 */ - write_integer, /* t_bignum = 4 */ - write_ratio, /* t_ratio */ - /* write_float, */ /* t_shortfloat */ - write_float, /* t_singlefloat */ - write_float, /* t_doublefloat */ + 0 /* t_start = 0 */, + _ecl_write_list, /* t_list = 1 */ + write_character, /* t_character = 2 */ + write_integer, /* t_fixnum = 3 */ + write_integer, /* t_bignum = 4 */ + write_ratio, /* t_ratio */ + /* write_float, */ /* t_shortfloat */ + write_float, /* t_singlefloat */ + write_float, /* t_doublefloat */ #ifdef ECL_LONG_FLOAT - write_float, /* t_longfloat */ + write_float, /* t_longfloat */ #endif - write_complex, /* t_complex */ - _ecl_write_symbol, /* t_symbol */ - write_package, /* t_package */ - write_hashtable, /* t_hashtable */ - _ecl_write_array, /* t_array */ - _ecl_write_vector, /* t_vector */ + write_complex, /* t_complex */ + _ecl_write_symbol, /* t_symbol */ + write_package, /* t_package */ + write_hashtable, /* t_hashtable */ + _ecl_write_array, /* t_array */ + _ecl_write_vector, /* t_vector */ #ifdef ECL_UNICODE - _ecl_write_string, /* t_string */ + _ecl_write_string, /* t_string */ #endif - _ecl_write_base_string, /* t_base_string */ - _ecl_write_bitvector, /* t_bitvector */ - write_stream, /* t_stream */ - write_random, /* t_random */ - write_readtable, /* t_readtable */ - write_pathname, /* t_pathname */ - _ecl_write_bytecodes, /* t_bytecodes */ - _ecl_write_bclosure, /* t_bclosure */ - write_cfun, /* t_cfun */ - write_cfun, /* t_cfunfixed */ - write_cclosure, /* t_cclosure */ - write_instance, /* t_instance */ + _ecl_write_base_string, /* t_base_string */ + _ecl_write_bitvector, /* t_bitvector */ + write_stream, /* t_stream */ + write_random, /* t_random */ + write_readtable, /* t_readtable */ + write_pathname, /* t_pathname */ + _ecl_write_bytecodes, /* t_bytecodes */ + _ecl_write_bclosure, /* t_bclosure */ + write_cfun, /* t_cfun */ + write_cfun, /* t_cfunfixed */ + write_cclosure, /* t_cclosure */ + write_instance, /* t_instance */ #ifdef ECL_THREADS - write_process, /* t_process */ - write_lock, /* t_lock */ - write_lock, /* t_rwlock */ - write_condition_variable, /* t_condition_variable */ - write_semaphore, /* t_semaphore */ - write_barrier, /* t_barrier */ - write_mailbox, /* t_mailbox */ + write_process, /* t_process */ + write_lock, /* t_lock */ + write_lock, /* t_rwlock */ + write_condition_variable, /* t_condition_variable */ + write_semaphore, /* t_semaphore */ + write_barrier, /* t_barrier */ + write_mailbox, /* t_mailbox */ #endif - write_codeblock, /* t_codeblock */ - write_foreign, /* t_foreign */ - write_frame, /* t_frame */ - write_weak_pointer, /* t_weak_pointer */ + write_codeblock, /* t_codeblock */ + write_foreign, /* t_foreign */ + write_frame, /* t_frame */ + write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 - _ecl_write_sse, /* t_sse_pack */ + _ecl_write_sse, /* t_sse_pack */ #endif - /* t_end */ + /* t_end */ }; cl_object si_write_ugly_object(cl_object x, cl_object stream) { - if (x == OBJNULL) { - if (ecl_print_readably()) - FEprint_not_readable(x); - writestr_stream("#", stream); - } else { - int t = ecl_t_of(x); - printer f = (t >= t_end)? write_illegal : dispatch[t]; - f(x, stream); - } - @(return x) + if (x == OBJNULL) { + if (ecl_print_readably()) + FEprint_not_readable(x); + writestr_stream("#", stream); + } else { + int t = ecl_t_of(x); + printer f = (t >= t_end)? write_illegal : dispatch[t]; + f(x, stream); + } + @(return x); } diff --git a/src/c/read.d b/src/c/read.d index 77c70c9f3..de3c5bd52 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - read.d -- Read. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * read.d - reader + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define ECL_INCLUDE_MATH_H #include @@ -57,54 +52,54 @@ static cl_object dispatch_macro_character(cl_object table, cl_object strm, int c cl_object si_get_buffer_string() { - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_object output; - if (pool == ECL_NIL) { + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_object output; + if (pool == ECL_NIL) { #ifdef ECL_UNICODE - output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); + output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); #else - output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); + output = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); #endif - } else { - output = CAR(pool); - env->string_pool = CDR(pool); - } - TOKEN_STRING_FILLP(output) = 0; - @(return output) + } else { + output = CAR(pool); + env->string_pool = CDR(pool); + } + TOKEN_STRING_FILLP(output) = 0; + @(return output); } cl_object si_put_buffer_string(cl_object string) { - if (string != ECL_NIL) { - const cl_env_ptr env = ecl_process_env(); - cl_object pool = env->string_pool; - cl_index l = 0; - if (pool != ECL_NIL) { - /* We store the size of the pool in the string index */ - l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); - } - if (l < ECL_MAX_STRING_POOL_SIZE) { - /* Ok, by ignoring the following code, here we - * are doing like SBCL: we simply grow the - * input buffer and do not care about its - * size. */ + if (string != ECL_NIL) { + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; + cl_index l = 0; + if (pool != ECL_NIL) { + /* We store the size of the pool in the string index */ + l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); + } + if (l < ECL_MAX_STRING_POOL_SIZE) { + /* Ok, by ignoring the following code, here we + * are doing like SBCL: we simply grow the + * input buffer and do not care about its + * size. */ #if 0 - if (TOKEN_STRING_DIM(string) > 32*ECL_BUFFER_STRING_SIZE) { - /* String has been enlarged. Cut it. */ + if (TOKEN_STRING_DIM(string) > 32*ECL_BUFFER_STRING_SIZE) { + /* String has been enlarged. Cut it. */ #ifdef ECL_UNICODE - string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); + string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); #else - string = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); + string = ecl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); #endif - } + } #endif - TOKEN_STRING_FILLP(string) = l+1; - env->string_pool = CONS(string, pool); - } - } - @(return) + TOKEN_STRING_FILLP(string) = l+1; + env->string_pool = CONS(string, pool); + } + } + @(return); } static void extra_argument (int c, cl_object stream, cl_object d); @@ -114,15 +109,15 @@ static cl_object do_read_delimited_list(int d, cl_object strm, bool proper_list) cl_object ecl_read_object_non_recursive(cl_object in) { - cl_object x; - const cl_env_ptr env = ecl_process_env(); + cl_object x; + const cl_env_ptr env = ecl_process_env(); - ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); - x = ecl_read_object(in); - x = patch_sharp(env, x); - ecl_bds_unwind_n(env, 2); - return x; + ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); + x = ecl_read_object(in); + x = patch_sharp(env, x); + ecl_bds_unwind_n(env, 2); + return x; } /* @@ -135,316 +130,316 @@ ecl_read_object_non_recursive(cl_object in) static void invert_buffer_case(cl_object x, cl_object escape_list, int sign) { - cl_fixnum high_limit, low_limit; - cl_fixnum i = TOKEN_STRING_FILLP(x)-1; - do { - if (escape_list != ECL_NIL) { - cl_object escape_interval = CAR(escape_list); - high_limit = ecl_fixnum(CAR(escape_interval)); - low_limit = ecl_fixnum(CDR(escape_interval)); - escape_list = CDR(escape_list); - } else { - high_limit = low_limit = -1; - } - for (; i > high_limit; i--) { - /* The character is not escaped */ - int c = TOKEN_STRING_CHAR(x,i); - if (ecl_upper_case_p(c) && (sign < 0)) { - c = ecl_char_downcase(c); - } else if (ecl_lower_case_p(c) && (sign > 0)) { - c = ecl_char_upcase(c); - } - TOKEN_STRING_CHAR_SET(x,i,c); - } - for (; i > low_limit; i--) { - /* The character is within an escaped interval */ - ; - } - } while (i >= 0); + cl_fixnum high_limit, low_limit; + cl_fixnum i = TOKEN_STRING_FILLP(x)-1; + do { + if (escape_list != ECL_NIL) { + cl_object escape_interval = CAR(escape_list); + high_limit = ecl_fixnum(CAR(escape_interval)); + low_limit = ecl_fixnum(CDR(escape_interval)); + escape_list = CDR(escape_list); + } else { + high_limit = low_limit = -1; + } + for (; i > high_limit; i--) { + /* The character is not escaped */ + int c = TOKEN_STRING_CHAR(x,i); + if (ecl_upper_case_p(c) && (sign < 0)) { + c = ecl_char_downcase(c); + } else if (ecl_lower_case_p(c) && (sign > 0)) { + c = ecl_char_upcase(c); + } + TOKEN_STRING_CHAR_SET(x,i,c); + } + for (; i > low_limit; i--) { + /* The character is within an escaped interval */ + ; + } + } while (i >= 0); } static cl_object ecl_read_object_with_delimiter(cl_object in, int delimiter, int flags, enum ecl_chattrib a) { - cl_object x, token; - int c, base; - cl_object p; - cl_index length, i; - int colon, intern_flag; - bool external_symbol; - cl_env_ptr the_env = ecl_process_env(); - cl_object rtbl = ecl_current_readtable(); - enum ecl_readtable_case read_case = rtbl->readtable.read_case; - cl_object escape_list; /* intervals of escaped characters */ - cl_fixnum upcase; /* # uppercase characters - # downcase characters */ - cl_fixnum count; /* number of unescaped characters */ - bool suppress = read_suppress; - if (a != cat_constituent) { - c = 0; - goto LOOP; + cl_object x, token; + int c, base; + cl_object p; + cl_index length, i; + int colon, intern_flag; + bool external_symbol; + cl_env_ptr the_env = ecl_process_env(); + cl_object rtbl = ecl_current_readtable(); + enum ecl_readtable_case read_case = rtbl->readtable.read_case; + cl_object escape_list; /* intervals of escaped characters */ + cl_fixnum upcase; /* # uppercase characters - # downcase characters */ + cl_fixnum count; /* number of unescaped characters */ + bool suppress = read_suppress; + if (a != cat_constituent) { + c = 0; + goto LOOP; + } + BEGIN: + do { + c = ecl_read_char(in); + if (c == delimiter) { + the_env->nvalues = 0; + return OBJNULL; + } + if (c == EOF) + FEend_of_file(in); + a = ecl_readtable_get(rtbl, c, &x); + } while (a == cat_whitespace); + if ((a == cat_terminating || a == cat_non_terminating) && + (flags != ECL_READ_ONLY_TOKEN)) { + cl_object o; + if (ECL_HASH_TABLE_P(x)) { + o = dispatch_macro_character(x, in, c); + } else { + o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c)); + } + if (the_env->nvalues == 0) { + if (flags == ECL_READ_RETURN_IGNORABLE) + return ECL_NIL; + goto BEGIN; + } + unlikely_if (the_env->nvalues > 1) { + FEerror("The readmacro ~S returned ~D values.", + 2, x, ecl_make_fixnum(the_env->nvalues)); + } + return o; + } + LOOP: + p = escape_list = ECL_NIL; + upcase = count = length = 0; + external_symbol = colon = 0; + token = si_get_buffer_string(); + for (;;) { + if (c == ':' && (flags != ECL_READ_ONLY_TOKEN) && + a == cat_constituent) { + colon++; + goto NEXT; + } + if (colon > 2) { + while (colon--) { + ecl_string_push_extend(token, ':'); + length++; + } + } else if (colon) { + external_symbol = (colon == 1); + TOKEN_STRING_CHAR_SET(token,length,'\0'); + /* If the readtable case was :INVERT and all non-escaped characters + * had the same case, we revert their case. */ + if (read_case == ecl_case_invert && count != 0) { + if (upcase == count) { + invert_buffer_case(token, escape_list, -1); + } else if (upcase == -count) { + invert_buffer_case(token, escape_list, +1); } -BEGIN: - do { - c = ecl_read_char(in); - if (c == delimiter) { - the_env->nvalues = 0; - return OBJNULL; - } - if (c == EOF) - FEend_of_file(in); - a = ecl_readtable_get(rtbl, c, &x); - } while (a == cat_whitespace); - if ((a == cat_terminating || a == cat_non_terminating) && - (flags != ECL_READ_ONLY_TOKEN)) { - cl_object o; - if (ECL_HASH_TABLE_P(x)) { - o = dispatch_macro_character(x, in, c); - } else { - o = _ecl_funcall3(x, in, ECL_CODE_CHAR(c)); - } - if (the_env->nvalues == 0) { - if (flags == ECL_READ_RETURN_IGNORABLE) - return ECL_NIL; - goto BEGIN; - } - unlikely_if (the_env->nvalues > 1) { - FEerror("The readmacro ~S returned ~D values.", - 2, x, ecl_make_fixnum(the_env->nvalues)); - } - return o; - } -LOOP: - p = escape_list = ECL_NIL; - upcase = count = length = 0; - external_symbol = colon = 0; - token = si_get_buffer_string(); - for (;;) { - if (c == ':' && (flags != ECL_READ_ONLY_TOKEN) && - a == cat_constituent) { - colon++; - goto NEXT; - } - if (colon > 2) { - while (colon--) { - ecl_string_push_extend(token, ':'); - length++; - } - } else if (colon) { - external_symbol = (colon == 1); - TOKEN_STRING_CHAR_SET(token,length,'\0'); - /* If the readtable case was :INVERT and all non-escaped characters - * had the same case, we revert their case. */ - if (read_case == ecl_case_invert && count != 0) { - if (upcase == count) { - invert_buffer_case(token, escape_list, -1); - } else if (upcase == -count) { - invert_buffer_case(token, escape_list, +1); - } - } - if (length == 0) { - p = cl_core.keyword_package; - external_symbol = 0; - } else { - p = ecl_find_package_nolock(token); - } - if (Null(p) && !suppress) { - /* When loading binary files, we sometimes must create - symbols whose package has not yet been maked. We - allow it, but later on in ecl_init_module we make sure that - all referenced packages have been properly built. - */ - cl_object name = cl_copy_seq(token); - unlikely_if (Null(the_env->packages_to_be_created_p)) { - FEerror("There is no package with the name ~A.", - 1, name); - } - p = _ecl_package_to_be_created(the_env, name); - } - TOKEN_STRING_FILLP(token) = length = 0; - upcase = count = colon = 0; - escape_list = ECL_NIL; - } - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - if (read_case == ecl_case_invert) { - escape_list = CONS(CONS(ecl_make_fixnum(length), - ecl_make_fixnum(length-1)), - escape_list); - } else { - escape_list = ECL_T; - } - ecl_string_push_extend(token, c); - length++; - goto NEXT; - } - if (a == cat_multiple_escape) { - cl_index begin = length; - for (;;) { - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) - break; - ecl_string_push_extend(token, c); - length++; - } - if (read_case == ecl_case_invert) { - escape_list = CONS(CONS(ecl_make_fixnum(begin), - ecl_make_fixnum(length-1)), - escape_list); - } else { - escape_list = ECL_T; - } - goto NEXT; - } - if (a == cat_whitespace || a == cat_terminating) { - ecl_unread_char(c, in); - break; - } - unlikely_if (ecl_invalid_character_p(c)) { - FEreader_error("Found invalid character ~:C", in, - 1, ECL_CODE_CHAR(c)); - } - if (read_case != ecl_case_preserve) { - if (ecl_upper_case_p(c)) { - upcase++; - count++; - if (read_case == ecl_case_downcase) - c = ecl_char_downcase(c); - } else if (ecl_lower_case_p(c)) { - upcase--; - count++; - if (read_case == ecl_case_upcase) - c = ecl_char_upcase(c); - } - } - ecl_string_push_extend(token, c); - length++; - NEXT: - c = ecl_read_char(in); - if (c == EOF) - break; - a = ecl_readtable_get(rtbl, c, NULL); + } + if (length == 0) { + p = cl_core.keyword_package; + external_symbol = 0; + } else { + p = ecl_find_package_nolock(token); + } + if (Null(p) && !suppress) { + /* When loading binary files, we sometimes must create + symbols whose package has not yet been maked. We + allow it, but later on in ecl_init_module we make sure that + all referenced packages have been properly built. + */ + cl_object name = cl_copy_seq(token); + unlikely_if (Null(the_env->packages_to_be_created_p)) { + FEerror("There is no package with the name ~A.", + 1, name); } + p = _ecl_package_to_be_created(the_env, name); + } + TOKEN_STRING_FILLP(token) = length = 0; + upcase = count = colon = 0; + escape_list = ECL_NIL; + } + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(ecl_make_fixnum(length), + ecl_make_fixnum(length-1)), + escape_list); + } else { + escape_list = ECL_T; + } + ecl_string_push_extend(token, c); + length++; + goto NEXT; + } + if (a == cat_multiple_escape) { + cl_index begin = length; + for (;;) { + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + ecl_string_push_extend(token, c); + length++; + } + if (read_case == ecl_case_invert) { + escape_list = CONS(CONS(ecl_make_fixnum(begin), + ecl_make_fixnum(length-1)), + escape_list); + } else { + escape_list = ECL_T; + } + goto NEXT; + } + if (a == cat_whitespace || a == cat_terminating) { + ecl_unread_char(c, in); + break; + } + unlikely_if (ecl_invalid_character_p(c)) { + FEreader_error("Found invalid character ~:C", in, + 1, ECL_CODE_CHAR(c)); + } + if (read_case != ecl_case_preserve) { + if (ecl_upper_case_p(c)) { + upcase++; + count++; + if (read_case == ecl_case_downcase) + c = ecl_char_downcase(c); + } else if (ecl_lower_case_p(c)) { + upcase--; + count++; + if (read_case == ecl_case_upcase) + c = ecl_char_upcase(c); + } + } + ecl_string_push_extend(token, c); + length++; + NEXT: + c = ecl_read_char(in); + if (c == EOF) + break; + a = ecl_readtable_get(rtbl, c, NULL); + } - if (suppress) { - x = ECL_NIL; - goto OUTPUT; - } + if (suppress) { + x = ECL_NIL; + goto OUTPUT; + } - /* If there are some escaped characters, it must be a symbol */ - if ((flags == ECL_READ_ONLY_TOKEN) || p != ECL_NIL || - escape_list != ECL_NIL || length == 0) - goto SYMBOL; + /* If there are some escaped characters, it must be a symbol */ + if ((flags == ECL_READ_ONLY_TOKEN) || p != ECL_NIL || + escape_list != ECL_NIL || length == 0) + goto SYMBOL; - /* The case in which the buffer is full of dots has to be especial cased */ - if (length == 1 && TOKEN_STRING_CHAR_CMP(token,0,'.')) { - if (flags == ECL_READ_LIST_DOT) { - x = @'si::.'; - goto OUTPUT; - } else { - FEreader_error("Dots appeared illegally.", in, 0); - } - } else { - int i; - for (i = 0; i < length; i++) { - if (!TOKEN_STRING_CHAR_CMP(token,i,'.')) - goto MAYBE_NUMBER; - } - FEreader_error("Dots appeared illegally.", in, 0); - } + /* The case in which the buffer is full of dots has to be especial cased */ + if (length == 1 && TOKEN_STRING_CHAR_CMP(token,0,'.')) { + if (flags == ECL_READ_LIST_DOT) { + x = @'si::.'; + goto OUTPUT; + } else { + FEreader_error("Dots appeared illegally.", in, 0); + } + } else { + int i; + for (i = 0; i < length; i++) { + if (!TOKEN_STRING_CHAR_CMP(token,i,'.')) + goto MAYBE_NUMBER; + } + FEreader_error("Dots appeared illegally.", in, 0); + } MAYBE_NUMBER: - /* Here we try to parse a number from the content of the buffer */ - base = ecl_current_read_base(); - if ((base <= 10) && ecl_alpha_char_p(TOKEN_STRING_CHAR(token,0))) - goto SYMBOL; - x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, base); - unlikely_if (x == ECL_NIL) - FEreader_error("Syntax error when reading number.~%Offending string: ~S.", - in, 1, token); - if (x != OBJNULL && length == i) - goto OUTPUT; + /* Here we try to parse a number from the content of the buffer */ + base = ecl_current_read_base(); + if ((base <= 10) && ecl_alpha_char_p(TOKEN_STRING_CHAR(token,0))) + goto SYMBOL; + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, base); + unlikely_if (x == ECL_NIL) + FEreader_error("Syntax error when reading number.~%Offending string: ~S.", + in, 1, token); + if (x != OBJNULL && length == i) + goto OUTPUT; SYMBOL: - if (flags == ECL_READ_ONLY_TOKEN) { - the_env->nvalues = 1; - return token; - } + if (flags == ECL_READ_ONLY_TOKEN) { + the_env->nvalues = 1; + return token; + } - /*TOKEN_STRING_CHAR_SET(token,length,'\0');*/ - /* If the readtable case was :INVERT and all non-escaped characters - * had the same case, we revert their case. */ - if (read_case == ecl_case_invert && count != 0) { - if (upcase == count) { - invert_buffer_case(token, escape_list, -1); - } else if (upcase == -count) { - invert_buffer_case(token, escape_list, +1); - } - } - if (external_symbol) { - x = ecl_find_symbol(token, p, &intern_flag); - unlikely_if (intern_flag != ECL_EXTERNAL) { - FEerror("Cannot find the external symbol ~A in ~S.", - 2, cl_copy_seq(token), p); - } - } else { - if (p == ECL_NIL) { - p = ecl_current_package(); - } - /* INV: cl_make_symbol() copies the string */ - x = ecl_intern(token, p, &intern_flag); - } + /*TOKEN_STRING_CHAR_SET(token,length,'\0');*/ + /* If the readtable case was :INVERT and all non-escaped characters + * had the same case, we revert their case. */ + if (read_case == ecl_case_invert && count != 0) { + if (upcase == count) { + invert_buffer_case(token, escape_list, -1); + } else if (upcase == -count) { + invert_buffer_case(token, escape_list, +1); + } + } + if (external_symbol) { + x = ecl_find_symbol(token, p, &intern_flag); + unlikely_if (intern_flag != ECL_EXTERNAL) { + FEerror("Cannot find the external symbol ~A in ~S.", + 2, cl_copy_seq(token), p); + } + } else { + if (p == ECL_NIL) { + p = ecl_current_package(); + } + /* INV: cl_make_symbol() copies the string */ + x = ecl_intern(token, p, &intern_flag); + } OUTPUT: - si_put_buffer_string(token); - the_env->nvalues = 1; - return x; + si_put_buffer_string(token); + the_env->nvalues = 1; + return x; } /* - ecl_read_object(in) reads an object from stream in. - This routine corresponds to COMMON Lisp function READ. + ecl_read_object(in) reads an object from stream in. + This routine corresponds to COMMON Lisp function READ. */ cl_object ecl_read_object(cl_object in) { - return ecl_read_object_with_delimiter(in, EOF, 0, cat_constituent); + return ecl_read_object_with_delimiter(in, EOF, 0, cat_constituent); } cl_object si_read_object_or_ignore(cl_object in, cl_object eof) { - cl_object x; - const cl_env_ptr env = ecl_process_env(); + cl_object x; + const cl_env_ptr env = ecl_process_env(); - ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); - x = ecl_read_object_with_delimiter(in, EOF, ECL_READ_RETURN_IGNORABLE, - cat_constituent); - if (x == OBJNULL) { - env->nvalues = 1; - x = eof; - } else if (env->nvalues) { - x = patch_sharp(env, x); - } - ecl_bds_unwind_n(env, 2); - return x; + ecl_bds_bind(env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(env, @'si::*backq-level*', ecl_make_fixnum(0)); + x = ecl_read_object_with_delimiter(in, EOF, ECL_READ_RETURN_IGNORABLE, + cat_constituent); + if (x == OBJNULL) { + env->nvalues = 1; + x = eof; + } else if (env->nvalues) { + x = patch_sharp(env, x); + } + ecl_bds_unwind_n(env, 2); + return x; } static cl_object right_parenthesis_reader(cl_object in, cl_object character) { - FEreader_error("Unmatched right parenthesis, #\\)", in, 0); + FEreader_error("Unmatched right parenthesis, #\\)", in, 0); } static cl_object left_parenthesis_reader(cl_object in, cl_object character) { - const char c = ')'; - @(return do_read_delimited_list(c, in, 0)) + const char c = ')'; + @(return do_read_delimited_list(c, in, 0)); } /* @@ -454,326 +449,326 @@ left_parenthesis_reader(cl_object in, cl_object character) static cl_object comma_reader(cl_object in, cl_object c) { - cl_object x, y; - const cl_env_ptr env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); + cl_object x, y; + const cl_env_ptr env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(env, @'si::*backq-level*')); - unlikely_if (backq_level <= 0) - FEreader_error("A comma has appeared out of a backquote.", in, 0); - /* Read character & complain at EOF */ - c = cl_peek_char(2,ECL_NIL,in); - if (c == ECL_CODE_CHAR('@@')) { - x = @'si::unquote-splice'; - ecl_read_char(in); - } else if (c == ECL_CODE_CHAR('.')) { - x = @'si::unquote-nsplice'; - ecl_read_char(in); - } else { - x = @'si::unquote'; - } - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); - y = ecl_read_object(in); - ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); - return cl_list(2, x, y); + unlikely_if (backq_level <= 0) + FEreader_error("A comma has appeared out of a backquote.", in, 0); + /* Read character & complain at EOF */ + c = cl_peek_char(2,ECL_NIL,in); + if (c == ECL_CODE_CHAR('@@')) { + x = @'si::unquote-splice'; + ecl_read_char(in); + } else if (c == ECL_CODE_CHAR('.')) { + x = @'si::unquote-nsplice'; + ecl_read_char(in); + } else { + x = @'si::unquote'; + } + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level-1)); + y = ecl_read_object(in); + ECL_SETQ(env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + return cl_list(2, x, y); } static cl_object backquote_reader(cl_object in, cl_object c) { - const cl_env_ptr the_env = ecl_process_env(); - cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); - c = ecl_read_object(in); - ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); - unlikely_if (c == OBJNULL) - FEend_of_file(in); + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum backq_level = ecl_fixnum(ECL_SYM_VAL(the_env, @'si::*backq-level*')); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level+1)); + c = ecl_read_object(in); + ECL_SETQ(the_env, @'si::*backq-level*', ecl_make_fixnum(backq_level)); + unlikely_if (c == OBJNULL) + FEend_of_file(in); #if 0 - @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL)); + @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL));; #else - @(return cl_list(2,@'si::quasiquote',c)) + @(return cl_list(2,@'si::quasiquote',c)); #endif } /* - read_constituent(in) reads a sequence of constituent characters from - stream in and places it in token. As a help, it returns TRUE - or FALSE depending on the value of *READ-SUPPRESS*. + read_constituent(in) reads a sequence of constituent characters from + stream in and places it in token. As a help, it returns TRUE + or FALSE depending on the value of *READ-SUPPRESS*. */ static cl_object read_constituent(cl_object in) { - int store = !read_suppress; - cl_object rtbl = ecl_current_readtable(); - bool not_first = 0; - cl_object token = si_get_buffer_string(); - do { - int c = ecl_read_char(in); - enum ecl_chattrib c_cat; - if (c == EOF) { - break; - } - c_cat = ecl_readtable_get(rtbl, c, NULL); - if (c_cat == cat_constituent || - ((c_cat == cat_non_terminating) && not_first)) - { - if (store) { - ecl_string_push_extend(token, c); - } - } else { - ecl_unread_char(c, in); - break; - } - not_first = 1; - } while(1); - return (read_suppress)? ECL_NIL : token; + int store = !read_suppress; + cl_object rtbl = ecl_current_readtable(); + bool not_first = 0; + cl_object token = si_get_buffer_string(); + do { + int c = ecl_read_char(in); + enum ecl_chattrib c_cat; + if (c == EOF) { + break; + } + c_cat = ecl_readtable_get(rtbl, c, NULL); + if (c_cat == cat_constituent || + ((c_cat == cat_non_terminating) && not_first)) + { + if (store) { + ecl_string_push_extend(token, c); + } + } else { + ecl_unread_char(c, in); + break; + } + not_first = 1; + } while(1); + return (read_suppress)? ECL_NIL : token; } static cl_object double_quote_reader(cl_object in, cl_object c) { - int delim = ECL_CHAR_CODE(c); - cl_object rtbl = ecl_current_readtable(); - cl_object token = si_get_buffer_string(); - cl_object output; - for (;;) { - int c = ecl_read_char_noeof(in); - if (c == delim) - break; - else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) - c = ecl_read_char_noeof(in); - ecl_string_push_extend(token, c); - } + int delim = ECL_CHAR_CODE(c); + cl_object rtbl = ecl_current_readtable(); + cl_object token = si_get_buffer_string(); + cl_object output; + for (;;) { + int c = ecl_read_char_noeof(in); + if (c == delim) + break; + else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) + c = ecl_read_char_noeof(in); + ecl_string_push_extend(token, c); + } - /* Must be kept a (SIMPLE-ARRAY CHARACTERS (*)), see - * http://sourceforge.net/p/ecls/mailman/message/32272388/ */ - output = cl_copy_seq(token); - si_put_buffer_string(token); - @(return output) + /* Must be kept a (SIMPLE-ARRAY CHARACTERS (*)), see + * http://sourceforge.net/p/ecls/mailman/message/32272388/ */ + output = cl_copy_seq(token); + si_put_buffer_string(token); + @(return output); } static cl_object dispatch_reader_fun(cl_object in, cl_object dc) { - cl_object readtable = ecl_current_readtable(); - cl_object dispatch_table; - int c = ecl_char_code(dc); - ecl_readtable_get(readtable, c, &dispatch_table); - unlikely_if (!ECL_HASH_TABLE_P(dispatch_table)) - FEreader_error("~C is not a dispatching macro character", - in, 1, dc); - return dispatch_macro_character(dispatch_table, in, c); + cl_object readtable = ecl_current_readtable(); + cl_object dispatch_table; + int c = ecl_char_code(dc); + ecl_readtable_get(readtable, c, &dispatch_table); + unlikely_if (!ECL_HASH_TABLE_P(dispatch_table)) + FEreader_error("~C is not a dispatching macro character", + in, 1, dc); + return dispatch_macro_character(dispatch_table, in, c); } static cl_object dispatch_macro_character(cl_object table, cl_object in, int c) { - cl_object arg; - int d; - c = ecl_read_char_noeof(in); - d = ecl_digitp(c, 10); - if (d >= 0) { - cl_fixnum i = 0; - do { - i = 10*i + d; - c = ecl_read_char_noeof(in); - d = ecl_digitp(c, 10); - } while (d >= 0); - arg = ecl_make_fixnum(i); - } else { - arg = ECL_NIL; - } - { - cl_object dc = ECL_CODE_CHAR(c); - cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL); - unlikely_if (Null(fun)) { - FEreader_error("No dispatch function defined " - "for character ~S", - in, 1, dc); - } - return _ecl_funcall4(fun, in, dc, arg); - } + cl_object arg; + int d; + c = ecl_read_char_noeof(in); + d = ecl_digitp(c, 10); + if (d >= 0) { + cl_fixnum i = 0; + do { + i = 10*i + d; + c = ecl_read_char_noeof(in); + d = ecl_digitp(c, 10); + } while (d >= 0); + arg = ecl_make_fixnum(i); + } else { + arg = ECL_NIL; + } + { + cl_object dc = ECL_CODE_CHAR(c); + cl_object fun = ecl_gethash_safe(dc, table, ECL_NIL); + unlikely_if (Null(fun)) { + FEreader_error("No dispatch function defined " + "for character ~S", + in, 1, dc); + } + return _ecl_funcall4(fun, in, dc, arg); + } } static cl_object single_quote_reader(cl_object in, cl_object c) { - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - @(return cl_list(2, @'quote', c)) + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + @(return cl_list(2, @'quote', c)); } static cl_object void_reader(cl_object in, cl_object c) { - /* no result */ - @(return) + /* no result */ + @(return); } static cl_object semicolon_reader(cl_object in, cl_object c) { - int auxc; + int auxc; - do - auxc = ecl_read_char(in); - while (auxc != '\n' && auxc != EOF); - /* no result */ - @(return) + do + auxc = ecl_read_char(in); + while (auxc != '\n' && auxc != EOF); + /* no result */ + @(return); } /* - sharpmacro routines + sharpmacro routines */ static cl_object sharp_C_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object x, real, imag; + const cl_env_ptr the_env = ecl_process_env(); + cl_object x, real, imag; - if (d != ECL_NIL && !read_suppress) - extra_argument('C', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) - FEend_of_file(in); - if (read_suppress) - @(return ECL_NIL); - unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) - FEreader_error("Reader macro #C should be followed by a list", - in, 0); - real = CAR(x); - imag = CADR(x); - /* INV: ecl_make_complex() checks its types. When reading circular - structures, we cannot check the types of the elements, and we - must build the complex number by hand. */ - if ((CONSP(real) || CONSP(imag)) && - !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) - { - x = ecl_alloc_object(t_complex); - x->complex.real = real; - x->complex.imag = imag; - } else { - x = ecl_make_complex(real, imag); - } - @(return x) + if (d != ECL_NIL && !read_suppress) + extra_argument('C', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) + FEend_of_file(in); + if (read_suppress) + @(return ECL_NIL); + unlikely_if (!ECL_CONSP(x) || ecl_length(x) != 2) + FEreader_error("Reader macro #C should be followed by a list", + in, 0); + real = CAR(x); + imag = CADR(x); + /* INV: ecl_make_complex() checks its types. When reading circular + structures, we cannot check the types of the elements, and we + must build the complex number by hand. */ + if ((CONSP(real) || CONSP(imag)) && + !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) + { + x = ecl_alloc_object(t_complex); + x->complex.real = real; + x->complex.imag = imag; + } else { + x = ecl_make_complex(real, imag); + } + @(return x); } static cl_object sharp_backslash_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object token; - if (d != ECL_NIL && !read_suppress) { - unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { - FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); - } - } - token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, - cat_single_escape); - if (token == ECL_NIL) { - c = ECL_NIL; - } else if (TOKEN_STRING_FILLP(token) == 1) { - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); - } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { - /* #\^x */ - c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); - } else { - cl_object nc = cl_name_char(token); - unlikely_if (Null(nc)) { - FEreader_error("~S is an illegal character name.", in, 1, token); - } - c = nc; - } - si_put_buffer_string(token); - ecl_return1(the_env, c); + const cl_env_ptr the_env = ecl_process_env(); + cl_object token; + if (d != ECL_NIL && !read_suppress) { + unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) { + FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); + } + } + token = ecl_read_object_with_delimiter(in, EOF, ECL_READ_ONLY_TOKEN, + cat_single_escape); + if (token == ECL_NIL) { + c = ECL_NIL; + } else if (TOKEN_STRING_FILLP(token) == 1) { + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,0)); + } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { + /* #\^x */ + c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); + } else { + cl_object nc = cl_name_char(token); + unlikely_if (Null(nc)) { + FEreader_error("~S is an illegal character name.", in, 1, token); + } + c = nc; + } + si_put_buffer_string(token); + ecl_return1(the_env, c); } static cl_object sharp_single_quote_reader(cl_object in, cl_object c, cl_object d) { - bool suppress = read_suppress; - if(d != ECL_NIL && !suppress) - extra_argument('\'', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) { - FEend_of_file(in); - } else if (suppress) { - c = ECL_NIL; - } else { - c = cl_list(2, @'function', c); - } - @(return c) + bool suppress = read_suppress; + if(d != ECL_NIL && !suppress) + extra_argument('\'', in, d); + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) { + FEend_of_file(in); + } else if (suppress) { + c = ECL_NIL; + } else { + c = cl_list(2, @'function', c); + } + @(return c); } static cl_object sharp_Y_reader(cl_object in, cl_object c, cl_object d) { - cl_index i; - cl_object x, rv, nth, lex; + cl_index i; + cl_object x, rv, nth, lex; - if (d != ECL_NIL && !read_suppress) - extra_argument('C', in, d); - x = ecl_read_object(in); - unlikely_if (x == OBJNULL) { - FEend_of_file(in); - } - if (read_suppress) { - @(return ECL_NIL); - } - unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { - FEreader_error("Reader macro #Y should be followed by a list", - in, 0); - } + if (d != ECL_NIL && !read_suppress) + extra_argument('C', in, d); + x = ecl_read_object(in); + unlikely_if (x == OBJNULL) { + FEend_of_file(in); + } + if (read_suppress) { + @(return ECL_NIL); + } + unlikely_if (!ECL_CONSP(x) || ecl_length(x) < 5) { + FEreader_error("Reader macro #Y should be followed by a list", + in, 0); + } - if (ecl_length(x) == 2) { - rv = ecl_alloc_object(t_bclosure); - rv->bclosure.code = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bclosure.lex = ECL_CONS_CAR(x); - rv->bclosure.entry = _ecl_bclosure_dispatch_vararg; - @(return rv); - } + if (ecl_length(x) == 2) { + rv = ecl_alloc_object(t_bclosure); + rv->bclosure.code = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bclosure.lex = ECL_CONS_CAR(x); + rv->bclosure.entry = _ecl_bclosure_dispatch_vararg; + @(return rv); + } - rv = ecl_alloc_object(t_bytecodes); + rv = ecl_alloc_object(t_bytecodes); - rv->bytecodes.name = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); + rv->bytecodes.name = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); - lex = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); + lex = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); - rv->bytecodes.definition = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); + rv->bytecodes.definition = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.code_size = ecl_to_fix(cl_list_length(nth)); - rv->bytecodes.code = ecl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); - for ( i=0; !ecl_endp(nth) ; i++, nth=ECL_CONS_CDR(nth) ) - ((cl_opcode*)(rv->bytecodes.code))[i] = ecl_to_fix(ECL_CONS_CAR(nth)); + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.code_size = ecl_to_fix(cl_list_length(nth)); + rv->bytecodes.code = ecl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); + for ( i=0; !ecl_endp(nth) ; i++, nth=ECL_CONS_CDR(nth) ) + ((cl_opcode*)(rv->bytecodes.code))[i] = ecl_to_fix(ECL_CONS_CAR(nth)); - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - rv->bytecodes.data = nth; + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + rv->bytecodes.data = nth; - if (ECL_ATOM(x)) { - nth = ECL_NIL; - } else { - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - } - rv->bytecodes.file = nth; - if (ECL_ATOM(x)) { - nth = ecl_make_fixnum(0); - } else { - nth = ECL_CONS_CAR(x); - x = ECL_CONS_CDR(x); - } - rv->bytecodes.file_position = nth; + if (ECL_ATOM(x)) { + nth = ECL_NIL; + } else { + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + } + rv->bytecodes.file = nth; + if (ECL_ATOM(x)) { + nth = ecl_make_fixnum(0); + } else { + nth = ECL_CONS_CAR(x); + x = ECL_CONS_CDR(x); + } + rv->bytecodes.file_position = nth; - rv->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - @(return rv); + rv->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + @(return rv); } #define QUOTE 1 @@ -793,295 +788,296 @@ sharp_Y_reader(cl_object in, cl_object c, cl_object d) cl_object si_make_backq_vector(cl_object d, cl_object data, cl_object in) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object v, last; - cl_index dim, i; - if (Null(d)) { - dim = ecl_length(data); - } else { - dim = ecl_fixnum(d); - } - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL; i < dim; i++) { - if (data == ECL_NIL) { - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - break; - } - ecl_aset_unsafe(v, i, last = ecl_car(data)); - data = ECL_CONS_CDR(data); - } - unlikely_if (data != ECL_NIL) { - if (in != ECL_NIL) { - FEreader_error("Vector larger than specified length," - "~D.", in, 1, d); - } else { - FEerror("Vector larger than specified length, ~D", 1, d); - } - } - ecl_return1(the_env, v); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v, last; + cl_index dim, i; + if (Null(d)) { + dim = ecl_length(data); + } else { + dim = ecl_fixnum(d); + } + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL; i < dim; i++) { + if (data == ECL_NIL) { + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + break; + } + ecl_aset_unsafe(v, i, last = ecl_car(data)); + data = ECL_CONS_CDR(data); + } + unlikely_if (data != ECL_NIL) { + if (in != ECL_NIL) { + FEreader_error("Vector larger than specified length," + "~D.", in, 1, d); + } else { + FEerror("Vector larger than specified length, ~D", 1, d); + } + } + ecl_return1(the_env, v); } static cl_object sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) { - extern int _cl_backq_car(cl_object *); - const cl_env_ptr the_env = ecl_process_env(); - cl_object v; - unlikely_if (!Null(d) && - (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || - ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) - { - FEreader_error("Invalid dimension size ~D in #()", in, 1, d); - } - if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { - /* First case: ther might be unquoted elements in the vector. - * Then we just create a form that generates the vector. - */ - cl_object x = do_read_delimited_list(')', in, 1); - cl_index a = _cl_backq_car(&x); - if (a != QUOTE) { - v = cl_list(2, @'si::unquote', - cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); - } else { - return si_make_backq_vector(d, x, in); - } - } else if (read_suppress) { - /* Second case: *read-suppress* = t, we ignore the data */ - do_read_delimited_list(')', in, 1); - v = ECL_NIL; - } else if (Null(d)) { - /* Third case: no dimension provided. Read a list and - coerce it to vector. */ - return si_make_backq_vector(d, do_read_delimited_list(')', in, 1), in); - } else { - /* Finally: Both dimension and data are provided. The - amount of data cannot exceed the length, but it may - be smaller, and in that case...*/ - cl_object last; - cl_index dim = ecl_fixnum(d), i; - v = ecl_alloc_simple_vector(dim, ecl_aet_object); - for (i = 0, last = ECL_NIL;; i++) { - cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, - cat_constituent); - if (aux == OBJNULL) - break; - unlikely_if (i >= dim) { - FEreader_error("Vector larger than specified length," - "~D.", in, 1, d); - } - ecl_aset_unsafe(v, i, last = aux); - } - /* ... we fill the vector with the last element read (or NIL). */ - for (; i < dim; i++) { - ecl_aset_unsafe(v, i, last); - } - } - @(return v) + extern int _cl_backq_car(cl_object *); + const cl_env_ptr the_env = ecl_process_env(); + cl_object v; + unlikely_if (!Null(d) && + (!ECL_FIXNUMP(d) || ecl_fixnum_minusp(d) || + ecl_fixnum_greater(d, ecl_make_fixnum(ECL_ARRAY_DIMENSION_LIMIT)))) + { + FEreader_error("Invalid dimension size ~D in #()", in, 1, d); + } + if (ecl_fixnum_plusp(ECL_SYM_VAL(the_env, @'si::*backq-level*'))) { + /* First case: ther might be unquoted elements in the vector. + * Then we just create a form that generates the vector. + */ + cl_object x = do_read_delimited_list(')', in, 1); + cl_index a = _cl_backq_car(&x); + if (a != QUOTE) { + v = cl_list(2, @'si::unquote', + cl_list(4, @'si::make-backq-vector', d, x, ECL_NIL)); + } else { + return si_make_backq_vector(d, x, in); + } + } else if (read_suppress) { + /* Second case: *read-suppress* = t, we ignore the data */ + do_read_delimited_list(')', in, 1); + v = ECL_NIL; + } else if (Null(d)) { + /* Third case: no dimension provided. Read a list and + coerce it to vector. */ + return si_make_backq_vector(d, do_read_delimited_list(')', in, 1), in); + } else { + /* Finally: Both dimension and data are provided. The + amount of data cannot exceed the length, but it may + be smaller, and in that case...*/ + cl_object last; + cl_index dim = ecl_fixnum(d), i; + v = ecl_alloc_simple_vector(dim, ecl_aet_object); + for (i = 0, last = ECL_NIL;; i++) { + cl_object aux = ecl_read_object_with_delimiter(in, ')', 0, + cat_constituent); + if (aux == OBJNULL) + break; + unlikely_if (i >= dim) { + FEreader_error("Vector larger than specified length," + "~D.", in, 1, d); + } + ecl_aset_unsafe(v, i, last = aux); + } + /* ... we fill the vector with the last element read (or NIL). */ + for (; i < dim; i++) { + ecl_aset_unsafe(v, i, last); + } + } + @(return v); } static cl_object sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) { - cl_env_ptr env = ecl_process_env(); - cl_index sp = ECL_STACK_INDEX(env); - cl_object last, elt, x; - cl_index dim, dimcount, i; - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; + cl_env_ptr env = ecl_process_env(); + cl_index sp = ECL_STACK_INDEX(env); + cl_object last, elt, x; + cl_index dim, dimcount, i; + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; - if (read_suppress) { - read_constituent(in); - @(return ECL_NIL) - } - for (dimcount = 0 ;; dimcount++) { - int x = ecl_read_char(in); - if (x == EOF) - break; - a = ecl_readtable_get(rtbl, x, NULL); - if (a == cat_terminating || a == cat_whitespace) { - ecl_unread_char(x, in); - break; - } - unlikely_if (a == cat_single_escape || a == cat_multiple_escape || - (x != '0' && x != '1')) - { - FEreader_error("Character ~:C is not allowed after #*", - in, 1, ECL_CODE_CHAR(x)); - } - ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); - } - if (Null(d)) { - dim = dimcount; - } else { - unlikely_if (!ECL_FIXNUMP(d) || ((dim = ecl_fixnum(d)) < 0) || - (dim > ECL_ARRAY_DIMENSION_LIMIT)) - { - FEreader_error("Wrong vector dimension size ~D in #*.", - in, 1, d); - } - unlikely_if (dimcount > dim) - FEreader_error("Too many elements in #*.", in, 0); - unlikely_if (dim && (dimcount == 0)) - FEreader_error("Cannot fill the bit-vector #*.", in, 0); - } - last = ECL_STACK_REF(env,-1); - x = ecl_alloc_simple_vector(dim, ecl_aet_bit); - for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? env->stack[sp+i] : last; - if (elt == ecl_make_fixnum(0)) - x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); - else - x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; - } - ECL_STACK_POP_N_UNSAFE(env, dimcount); - @(return x) + if (read_suppress) { + read_constituent(in); + @(return ECL_NIL); + } + for (dimcount = 0 ;; dimcount++) { + int x = ecl_read_char(in); + if (x == EOF) + break; + a = ecl_readtable_get(rtbl, x, NULL); + if (a == cat_terminating || a == cat_whitespace) { + ecl_unread_char(x, in); + break; + } + unlikely_if (a == cat_single_escape || a == cat_multiple_escape || + (x != '0' && x != '1')) + { + FEreader_error("Character ~:C is not allowed after #*", + in, 1, ECL_CODE_CHAR(x)); + } + ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); + } + if (Null(d)) { + dim = dimcount; + } else { + unlikely_if (!ECL_FIXNUMP(d) || ((dim = ecl_fixnum(d)) < 0) || + (dim > ECL_ARRAY_DIMENSION_LIMIT)) + { + FEreader_error("Wrong vector dimension size ~D in #*.", + in, 1, d); + } + unlikely_if (dimcount > dim) + FEreader_error("Too many elements in #*.", in, 0); + unlikely_if (dim && (dimcount == 0)) + FEreader_error("Cannot fill the bit-vector #*.", in, 0); + } + last = ECL_STACK_REF(env,-1); + x = ecl_alloc_simple_vector(dim, ecl_aet_bit); + for (i = 0; i < dim; i++) { + elt = (i < dimcount) ? env->stack[sp+i] : last; + if (elt == ecl_make_fixnum(0)) + x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); + else + x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; + } + ECL_STACK_POP_N_UNSAFE(env, dimcount); + @(return x); } static cl_object sharp_colon_reader(cl_object in, cl_object ch, cl_object d) { - cl_object rtbl = ecl_current_readtable(); - enum ecl_chattrib a; - bool escape_flag; - int c; - cl_object output, token; + cl_object rtbl = ecl_current_readtable(); + enum ecl_chattrib a; + bool escape_flag; + int c; + cl_object output, token; - if (d != ECL_NIL && !read_suppress) - extra_argument(':', in, d); + if (d != ECL_NIL && !read_suppress) + extra_argument(':', in, d); + c = ecl_read_char_noeof(in); + a = ecl_readtable_get(rtbl, c, NULL); + escape_flag = FALSE; + token = si_get_buffer_string(); + goto L; + for (;;) { + ecl_string_push_extend(token, c); + K: + c = ecl_read_char(in); + if (c == EOF) + goto M; + a = ecl_readtable_get(rtbl, c, NULL); + L: + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + escape_flag = TRUE; + } else if (a == cat_multiple_escape) { + escape_flag = TRUE; + for (;;) { c = ecl_read_char_noeof(in); a = ecl_readtable_get(rtbl, c, NULL); - escape_flag = FALSE; - token = si_get_buffer_string(); - goto L; - for (;;) { - ecl_string_push_extend(token, c); - K: - c = ecl_read_char(in); - if (c == EOF) - goto M; - a = ecl_readtable_get(rtbl, c, NULL); - L: - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - escape_flag = TRUE; - } else if (a == cat_multiple_escape) { - escape_flag = TRUE; - for (;;) { - c = ecl_read_char_noeof(in); - a = ecl_readtable_get(rtbl, c, NULL); - if (a == cat_single_escape) { - c = ecl_read_char_noeof(in); - a = cat_constituent; - } else if (a == cat_multiple_escape) - break; - ecl_string_push_extend(token, c); - } - goto K; - } else if (ecl_lower_case_p(c)) - c = ecl_char_upcase(c); - if (a == cat_whitespace || a == cat_terminating) - break; - } - ecl_unread_char(c, in); + if (a == cat_single_escape) { + c = ecl_read_char_noeof(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + ecl_string_push_extend(token, c); + } + goto K; + } else if (ecl_lower_case_p(c)) + c = ecl_char_upcase(c); + if (a == cat_whitespace || a == cat_terminating) + break; + } + ecl_unread_char(c, in); -M: - if (read_suppress) { - output = ECL_NIL; - } else { - output = cl_make_symbol(token); - } - si_put_buffer_string(token); - @(return output) + M: + if (read_suppress) { + output = ECL_NIL; + } else { + output = cl_make_symbol(token); + } + si_put_buffer_string(token); + @(return output); } static cl_object sharp_dot_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr env = ecl_process_env(); - if (d != ECL_NIL && !read_suppress) - extra_argument('.', in, d); - c = ecl_read_object(in); - unlikely_if (c == OBJNULL) - FEend_of_file(in); - if (read_suppress) - @(return ECL_NIL); - unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) - FEreader_error("Cannot evaluate the form #.~A", in, 1, c); - /* FIXME! We should do something here to ensure that the #. - * only uses the #n# that have been defined */ - c = patch_sharp(env, c); - c = si_eval_with_env(1, c); - @(return c) + const cl_env_ptr env = ecl_process_env(); + if (d != ECL_NIL && !read_suppress) + extra_argument('.', in, d); + c = ecl_read_object(in); + unlikely_if (c == OBJNULL) + FEend_of_file(in); + if (read_suppress) { + @(return ECL_NIL); + } + unlikely_if (ecl_symbol_value(@'*read-eval*') == ECL_NIL) + FEreader_error("Cannot evaluate the form #.~A", in, 1, c); + /* FIXME! We should do something here to ensure that the #. + * only uses the #n# that have been defined */ + c = patch_sharp(env, c); + c = si_eval_with_env(1, c); + @(return c); } static cl_object read_number(cl_object in, int radix, cl_object macro_char) { - cl_index i; - cl_object x; - cl_object token = read_constituent(in); - if (token == ECL_NIL) { - x = ECL_NIL; - } else { - x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); - unlikely_if (x == OBJNULL || x == ECL_NIL || - i != TOKEN_STRING_FILLP(token)) - { - FEreader_error("Cannot parse the #~A readmacro.", in, 1, - macro_char); - } - unlikely_if (cl_rationalp(x) == ECL_NIL) { - FEreader_error("The float ~S appeared after the #~A readmacro.", - in, 2, x, macro_char); - } - si_put_buffer_string(token); - } - return x; + cl_index i; + cl_object x; + cl_object token = read_constituent(in); + if (token == ECL_NIL) { + x = ECL_NIL; + } else { + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); + unlikely_if (x == OBJNULL || x == ECL_NIL || + i != TOKEN_STRING_FILLP(token)) + { + FEreader_error("Cannot parse the #~A readmacro.", in, 1, + macro_char); + } + unlikely_if (cl_rationalp(x) == ECL_NIL) { + FEreader_error("The float ~S appeared after the #~A readmacro.", + in, 2, x, macro_char); + } + si_put_buffer_string(token); + } + return x; } static cl_object sharp_B_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('B', in, d); - @(return (read_number(in, 2, ECL_CODE_CHAR('B')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('B', in, d); + @(return (read_number(in, 2, ECL_CODE_CHAR('B')))); } static cl_object sharp_O_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('O', in, d); - @(return (read_number(in, 8, ECL_CODE_CHAR('O')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('O', in, d); + @(return (read_number(in, 8, ECL_CODE_CHAR('O')))); } static cl_object sharp_X_reader(cl_object in, cl_object c, cl_object d) { - if(d != ECL_NIL && !read_suppress) - extra_argument('X', in, d); - @(return (read_number(in, 16, ECL_CODE_CHAR('X')))) + if(d != ECL_NIL && !read_suppress) + extra_argument('X', in, d); + @(return (read_number(in, 16, ECL_CODE_CHAR('X')))); } static cl_object sharp_R_reader(cl_object in, cl_object c, cl_object d) { - int radix; - if (read_suppress) { - radix = 10; - } else unlikely_if (!ECL_FIXNUMP(d)) { - FEreader_error("No radix was supplied in the #R readmacro.", in, 0); - } else { - radix = ecl_fixnum(d); - unlikely_if (radix > 36 || radix < 2) { - FEreader_error("~S is an illegal radix.", in, 1, d); - } - } - @(return (read_number(in, radix, ECL_CODE_CHAR('R')))) + int radix; + if (read_suppress) { + radix = 10; + } else unlikely_if (!ECL_FIXNUMP(d)) { + FEreader_error("No radix was supplied in the #R readmacro.", in, 0); + } else { + radix = ecl_fixnum(d); + unlikely_if (radix > 36 || radix < 2) { + FEreader_error("~S is an illegal radix.", in, 1, d); + } + } + @(return (read_number(in, radix, ECL_CODE_CHAR('R')))); } #define sharp_A_reader void_reader @@ -1090,228 +1086,230 @@ sharp_R_reader(cl_object in, cl_object c, cl_object d) static cl_object sharp_eq_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair, value; - cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair, value; + cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); - if (read_suppress) @(return); - unlikely_if (Null(d)) { - FEreader_error("The #= readmacro requires an argument.", in, 0); - } - unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { - FEreader_error("Duplicate definitions for #~D=.", in, 1, d); - } - pair = CONS(d, OBJNULL); - ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); - value = ecl_read_object(in); - unlikely_if (value == pair) { - FEreader_error("#~D# is defined by itself.", in, 1, d); - } - ECL_RPLACD(pair, value); - ecl_return1(the_env, value); + if (read_suppress) { + @(return); + } + unlikely_if (Null(d)) { + FEreader_error("The #= readmacro requires an argument.", in, 0); + } + unlikely_if (ecl_assq(d, sharp_eq_context) != ECL_NIL) { + FEreader_error("Duplicate definitions for #~D=.", in, 1, d); + } + pair = CONS(d, OBJNULL); + ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); + value = ecl_read_object(in); + unlikely_if (value == pair) { + FEreader_error("#~D# is defined by itself.", in, 1, d); + } + ECL_RPLACD(pair, value); + ecl_return1(the_env, value); } static cl_object sharp_sharp_reader(cl_object in, cl_object c, cl_object d) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object pair; + const cl_env_ptr the_env = ecl_process_env(); + cl_object pair; - if (read_suppress) - ecl_return1(the_env, ECL_NIL); - unlikely_if (Null(d)) { - FEreader_error("The ## readmacro requires an argument.", in, 0); - } - pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); - unlikely_if (pair == ECL_NIL) { - FEreader_error("#~D# is undefined.", in, 1, d); - } else { - cl_object value = ECL_CONS_CDR(pair); - ecl_return1(the_env, (value == OBJNULL)? pair : value); - } + if (read_suppress) + ecl_return1(the_env, ECL_NIL); + unlikely_if (Null(d)) { + FEreader_error("The ## readmacro requires an argument.", in, 0); + } + pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); + unlikely_if (pair == ECL_NIL) { + FEreader_error("#~D# is undefined.", in, 1, d); + } else { + cl_object value = ECL_CONS_CDR(pair); + ecl_return1(the_env, (value == OBJNULL)? pair : value); + } } static cl_object do_patch_sharp(cl_object x, cl_object table) #if 1 { - /* The hash table maintains an association as follows: - * - * [1] object -> itself - * The object has been processed by patch_sharp, us as it is. - * [2] object -> nothing - * The object has to be processed by do_patch_sharp. - * [3] (# . object) -> object - * This is the value of a #n# statement. The object migt - * or might not yet be processed by do_patch_sharp(). - */ + /* The hash table maintains an association as follows: + * + * [1] object -> itself + * The object has been processed by patch_sharp, us as it is. + * [2] object -> nothing + * The object has to be processed by do_patch_sharp. + * [3] (# . object) -> object + * This is the value of a #n# statement. The object migt + * or might not yet be processed by do_patch_sharp(). + */ AGAIN: - switch (ecl_t_of(x)) { - case t_list: { - cl_object y; - if (Null(x)) - return x; - y = ecl_gethash_safe(x, table, table); - if (y == table) { - /* case [2] */ - break; - } else if (y == x) { - /* case [1] */ - return x; - } else { - /* case [3] */ - x = y; - goto AGAIN; - } - } - case t_vector: - case t_array: - case t_complex: - case t_bclosure: - case t_bytecodes: { - cl_object y = ecl_gethash_safe(x, table, table); - if (y == table) { - /* case [2] */ - break; - } - /* it can only be case [1] */ - } - default: - return x; - } - /* We eagerly mark the object as processed, to avoid infinite - * recursion. */ - _ecl_sethash(x, table, x); - switch (ecl_t_of(x)) { - case t_list: - ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); - ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); - break; - case t_vector: - if (x->vector.elttype == ecl_aet_object) { - cl_index i; - for (i = 0; i < x->vector.fillp; i++) - x->vector.self.t[i] = - do_patch_sharp(x->vector.self.t[i], table); - } - break; - case t_array: - if (x->vector.elttype == ecl_aet_object) { - cl_index i, j = x->array.dim; - for (i = 0; i < j; i++) - x->array.self.t[i] = - do_patch_sharp(x->array.self.t[i], table); - } - break; - case t_complex: { - cl_object r = do_patch_sharp(x->complex.real, table); - cl_object i = do_patch_sharp(x->complex.imag, table); - if (r != x->complex.real || i != x->complex.imag) { - cl_object c = ecl_make_complex(r, i); - x->complex = c->complex; - } - break; - } - case t_bclosure: { - x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); - x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); - break; - } - case t_bytecodes: { - x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); - x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); - x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); - break; - } - default:; - } - return x; + switch (ecl_t_of(x)) { + case t_list: { + cl_object y; + if (Null(x)) + return x; + y = ecl_gethash_safe(x, table, table); + if (y == table) { + /* case [2] */ + break; + } else if (y == x) { + /* case [1] */ + return x; + } else { + /* case [3] */ + x = y; + goto AGAIN; + } + } + case t_vector: + case t_array: + case t_complex: + case t_bclosure: + case t_bytecodes: { + cl_object y = ecl_gethash_safe(x, table, table); + if (y == table) { + /* case [2] */ + break; + } + /* it can only be case [1] */ + } + default: + return x; + } + /* We eagerly mark the object as processed, to avoid infinite + * recursion. */ + _ecl_sethash(x, table, x); + switch (ecl_t_of(x)) { + case t_list: + ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); + ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); + break; + case t_vector: + if (x->vector.elttype == ecl_aet_object) { + cl_index i; + for (i = 0; i < x->vector.fillp; i++) + x->vector.self.t[i] = + do_patch_sharp(x->vector.self.t[i], table); + } + break; + case t_array: + if (x->vector.elttype == ecl_aet_object) { + cl_index i, j = x->array.dim; + for (i = 0; i < j; i++) + x->array.self.t[i] = + do_patch_sharp(x->array.self.t[i], table); + } + break; + case t_complex: { + cl_object r = do_patch_sharp(x->complex.real, table); + cl_object i = do_patch_sharp(x->complex.imag, table); + if (r != x->complex.real || i != x->complex.imag) { + cl_object c = ecl_make_complex(r, i); + x->complex = c->complex; + } + break; + } + case t_bclosure: { + x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); + x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); + break; + } + case t_bytecodes: { + x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); + x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); + x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); + break; + } + default:; + } + return x; } #else { - switch (ecl_t_of(x)) { - case t_list: - if (Null(x)) - return x; - case t_vector: - case t_array: - case t_complex: - case t_bclosure: - case t_bytecodes: { - cl_object y = ecl_gethash_safe(x, table, table); - if (y == table) - break; - x = y; - } - default: - return x; - } - switch (ecl_t_of(x)) { - case t_list: - ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); - ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); - break; - case t_vector: - if (x->vector.elttype == ecl_aet_object) { - cl_index i; - for (i = 0; i < x->vector.fillp; i++) - x->vector.self.t[i] = - do_patch_sharp(x->vector.self.t[i], table); - } - break; - case t_array: - if (x->vector.elttype == ecl_aet_object) { - cl_index i, j = x->array.dim; - for (i = 0; i < j; i++) - x->array.self.t[i] = - do_patch_sharp(x->array.self.t[i], table); - } - break; - case t_complex: { - cl_object r = do_patch_sharp(x->complex.real, table); - cl_object i = do_patch_sharp(x->complex.imag, table); - if (r != x->complex.real || i != x->complex.imag) { - cl_object c = ecl_make_complex(r, i); - x->complex = c->complex; - } - break; - } - case t_bclosure: { - x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); - x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); - break; - } - case t_bytecodes: { - x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); - x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); - x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); - break; - } - default:; - } - _ecl_sethash(x, table, x); - return x; + switch (ecl_t_of(x)) { + case t_list: + if (Null(x)) + return x; + case t_vector: + case t_array: + case t_complex: + case t_bclosure: + case t_bytecodes: { + cl_object y = ecl_gethash_safe(x, table, table); + if (y == table) + break; + x = y; + } + default: + return x; + } + switch (ecl_t_of(x)) { + case t_list: + ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table)); + ECL_RPLACD(x, do_patch_sharp(ECL_CONS_CDR(x), table)); + break; + case t_vector: + if (x->vector.elttype == ecl_aet_object) { + cl_index i; + for (i = 0; i < x->vector.fillp; i++) + x->vector.self.t[i] = + do_patch_sharp(x->vector.self.t[i], table); + } + break; + case t_array: + if (x->vector.elttype == ecl_aet_object) { + cl_index i, j = x->array.dim; + for (i = 0; i < j; i++) + x->array.self.t[i] = + do_patch_sharp(x->array.self.t[i], table); + } + break; + case t_complex: { + cl_object r = do_patch_sharp(x->complex.real, table); + cl_object i = do_patch_sharp(x->complex.imag, table); + if (r != x->complex.real || i != x->complex.imag) { + cl_object c = ecl_make_complex(r, i); + x->complex = c->complex; + } + break; + } + case t_bclosure: { + x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table); + x = x->bclosure.code = do_patch_sharp(x->bclosure.code, table); + break; + } + case t_bytecodes: { + x->bytecodes.name = do_patch_sharp(x->bytecodes.name, table); + x->bytecodes.definition = do_patch_sharp(x->bytecodes.definition, table); + x->bytecodes.data = do_patch_sharp(x->bytecodes.data, table); + break; + } + default:; + } + _ecl_sethash(x, table, x); + return x; } #endif static cl_object patch_sharp(const cl_env_ptr the_env, cl_object x) { - cl_object pairs = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); - if (pairs == ECL_NIL) { - return x; - } else { - cl_object table = - cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); - do { - cl_object pair = ECL_CONS_CAR(pairs); - _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); - pairs = ECL_CONS_CDR(pairs); - } while (pairs != ECL_NIL); - return do_patch_sharp(x, table); - } + cl_object pairs = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + if (pairs == ECL_NIL) { + return x; + } else { + cl_object table = + cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ + cl_core.rehash_size, + cl_core.rehash_threshold); + do { + cl_object pair = ECL_CONS_CAR(pairs); + _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); + pairs = ECL_CONS_CDR(pairs); + } while (pairs != ECL_NIL); + return do_patch_sharp(x, table); + } } #define sharp_plus_reader void_reader @@ -1323,739 +1321,743 @@ patch_sharp(const cl_env_ptr the_env, cl_object x) static cl_object sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d) { - int c; - int level = 0; + int c; + int level = 0; - if (d != ECL_NIL && !read_suppress) - extra_argument('|', in, d); - for (;;) { - c = ecl_read_char_noeof(in); - L: - if (c == '#') { - c = ecl_read_char_noeof(in); - if (c == '|') - level++; - } else if (c == '|') { - c = ecl_read_char_noeof(in); - if (c == '#') { - if (level == 0) - break; - else - --level; - } else - goto L; - } - } - @(return) - /* no result */ + if (d != ECL_NIL && !read_suppress) + extra_argument('|', in, d); + for (;;) { + c = ecl_read_char_noeof(in); + L: + if (c == '#') { + c = ecl_read_char_noeof(in); + if (c == '|') + level++; + } else if (c == '|') { + c = ecl_read_char_noeof(in); + if (c == '#') { + if (level == 0) + break; + else + --level; + } else + goto L; + } + } + /* no result */ + @(return); } static cl_object default_dispatch_macro_fun(cl_object in, cl_object c, cl_object d) { - FEreader_error("No dispatch function defined for character ~s.", in, 1, c); + FEreader_error("No dispatch function defined for character ~s.", in, 1, c); } /* - #P" ... " returns the pathname with namestring ... . + #P" ... " returns the pathname with namestring ... . */ static cl_object sharp_P_reader(cl_object in, cl_object c, cl_object d) { - bool suppress = read_suppress; - if (d != ECL_NIL && !suppress) - extra_argument('P', in, d); - d = ecl_read_object(in); - if (suppress) { - d = ECL_NIL; - } else { - d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); - } - @(return d) + bool suppress = read_suppress; + if (d != ECL_NIL && !suppress) + extra_argument('P', in, d); + d = ecl_read_object(in); + if (suppress) { + d = ECL_NIL; + } else { + d = cl_parse_namestring(3, d, ECL_NIL, ECL_NIL); + } + @(return d); } /* - #$ fixnum returns a random-state with the fixnum - as its content. + #$ fixnum returns a random-state with the fixnum + as its content. */ static cl_object sharp_dollar_reader(cl_object in, cl_object c, cl_object d) { - cl_object rs; - if (d != ECL_NIL && !read_suppress) - extra_argument('$', in, d); - c = ecl_read_object(in); - rs = ecl_make_random_state(c); - @(return rs) + cl_object rs; + if (d != ECL_NIL && !read_suppress) + extra_argument('$', in, d); + c = ecl_read_object(in); + rs = ecl_make_random_state(c); + @(return rs); } /* - readtable routines + readtable routines */ static void ECL_INLINE assert_type_readtable(cl_object function, cl_narg narg, cl_object p) { - unlikely_if (!ECL_READTABLEP(p)) { - FEwrong_type_nth_arg(function, narg, p, @[readtable]); - } + unlikely_if (!ECL_READTABLEP(p)) { + FEwrong_type_nth_arg(function, narg, p, @[readtable]); + } } cl_object ecl_copy_readtable(cl_object from, cl_object to) { - struct ecl_readtable_entry *from_rtab, *to_rtab; - cl_index i; - size_t entry_bytes = sizeof(struct ecl_readtable_entry); - size_t total_bytes = entry_bytes * RTABSIZE; - cl_object output; + struct ecl_readtable_entry *from_rtab, *to_rtab; + cl_index i; + size_t entry_bytes = sizeof(struct ecl_readtable_entry); + size_t total_bytes = entry_bytes * RTABSIZE; + cl_object output; - assert_type_readtable(@[copy-readtable], 1, from); - /* For the sake of garbage collector and thread safety we - * create an incomplete object and only copy to the destination - * at the end in a more or less "atomic" (meaning "fast") way. - */ - output = ecl_alloc_object(t_readtable); - output->readtable.locked = 0; - output->readtable.table = to_rtab = (struct ecl_readtable_entry *) - ecl_alloc_align(total_bytes, entry_bytes); - from_rtab = from->readtable.table; - memcpy(to_rtab, from_rtab, total_bytes); - for (i = 0; i < RTABSIZE; i++) { - cl_object d = from_rtab[i].dispatch; - if (ECL_HASH_TABLE_P(d)) { - d = si_copy_hash_table(d); - } - to_rtab[i].dispatch = d; - } - output->readtable.read_case = from->readtable.read_case; + assert_type_readtable(@[copy-readtable], 1, from); + /* For the sake of garbage collector and thread safety we + * create an incomplete object and only copy to the destination + * at the end in a more or less "atomic" (meaning "fast") way. + */ + output = ecl_alloc_object(t_readtable); + output->readtable.locked = 0; + output->readtable.table = to_rtab = (struct ecl_readtable_entry *) + ecl_alloc_align(total_bytes, entry_bytes); + from_rtab = from->readtable.table; + memcpy(to_rtab, from_rtab, total_bytes); + for (i = 0; i < RTABSIZE; i++) { + cl_object d = from_rtab[i].dispatch; + if (ECL_HASH_TABLE_P(d)) { + d = si_copy_hash_table(d); + } + to_rtab[i].dispatch = d; + } + output->readtable.read_case = from->readtable.read_case; #ifdef ECL_UNICODE - if (!Null(from->readtable.hash)) { - output->readtable.hash = si_copy_hash_table(from->readtable.hash); - } else { - output->readtable.hash = ECL_NIL; - } + if (!Null(from->readtable.hash)) { + output->readtable.hash = si_copy_hash_table(from->readtable.hash); + } else { + output->readtable.hash = ECL_NIL; + } #endif - if (!Null(to)) { - assert_type_readtable(@[copy-readtable], 2, to); - to->readtable = output->readtable; - output = to; - } - return output; + if (!Null(to)) { + assert_type_readtable(@[copy-readtable], 2, to); + to->readtable = output->readtable; + output = to; + } + return output; } cl_object ecl_current_readtable(void) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object r; + const cl_env_ptr the_env = ecl_process_env(); + cl_object r; - /* INV: *readtable* always has a value */ - r = ECL_SYM_VAL(the_env, @'*readtable*'); - unlikely_if (!ECL_READTABLEP(r)) { - ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); - FEerror("The value of *READTABLE*, ~S, was not a readtable.", - 1, r); - } - return r; + /* INV: *readtable* always has a value */ + r = ECL_SYM_VAL(the_env, @'*readtable*'); + unlikely_if (!ECL_READTABLEP(r)) { + ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable); + FEerror("The value of *READTABLE*, ~S, was not a readtable.", + 1, r); + } + return r; } int ecl_current_read_base(void) { - const cl_env_ptr the_env = ecl_process_env(); - /* INV: *READ-BASE* always has a value */ - cl_object x = ECL_SYM_VAL(the_env, @'*read-base*'); - cl_fixnum b; + const cl_env_ptr the_env = ecl_process_env(); + /* INV: *READ-BASE* always has a value */ + cl_object x = ECL_SYM_VAL(the_env, @'*read-base*'); + cl_fixnum b; - unlikely_if (!ECL_FIXNUMP(x) || ((b = ecl_fixnum(x)) < 2) || (b > 36)) - { - ECL_SETQ(the_env, @'*read-base*', ecl_make_fixnum(10)); - FEerror("The value of *READ-BASE*~& ~S~%" - "is not in the range (INTEGER 2 36)", 1, x); - } - return b; + unlikely_if (!ECL_FIXNUMP(x) || ((b = ecl_fixnum(x)) < 2) || (b > 36)) + { + ECL_SETQ(the_env, @'*read-base*', ecl_make_fixnum(10)); + FEerror("The value of *READ-BASE*~& ~S~%" + "is not in the range (INTEGER 2 36)", 1, x); + } + return b; } char ecl_current_read_default_float_format(void) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object x; + const cl_env_ptr the_env = ecl_process_env(); + cl_object x; - /* INV: *READ-DEFAULT-FLOAT-FORMAT* is always bound to something */ - x = ECL_SYM_VAL(the_env, @'*read-default-float-format*'); - if (x == @'single-float' || x == @'short-float') - return 'F'; - if (x == @'double-float') - return 'D'; - if (x == @'long-float') { + /* INV: *READ-DEFAULT-FLOAT-FORMAT* is always bound to something */ + x = ECL_SYM_VAL(the_env, @'*read-default-float-format*'); + if (x == @'single-float' || x == @'short-float') + return 'F'; + if (x == @'double-float') + return 'D'; + if (x == @'long-float') { #ifdef ECL_LONG_FLOAT - return 'L'; + return 'L'; #else - return 'D'; + return 'D'; #endif - } - ECL_SETQ(the_env, @'*read-default-float-format*', @'single-float'); - FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*~& ~S~%" - "is not one of (SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT)", - 1, x); + } + ECL_SETQ(the_env, @'*read-default-float-format*', @'single-float'); + FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*~& ~S~%" + "is not one of (SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT)", + 1, x); } static cl_object stream_or_default_input(cl_object stream) { - const cl_env_ptr the_env = ecl_process_env(); - if (Null(stream)) - return ECL_SYM_VAL(the_env, @'*standard-input*'); - if (stream == ECL_T) - return ECL_SYM_VAL(the_env, @'*terminal-io*'); - return stream; + const cl_env_ptr the_env = ecl_process_env(); + if (Null(stream)) + return ECL_SYM_VAL(the_env, @'*standard-input*'); + if (stream == ECL_T) + return ECL_SYM_VAL(the_env, @'*terminal-io*'); + return stream; } @(defun read (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - cl_object x; -@ - strm = stream_or_default_input(strm); - if (Null(recursivep)) { - x = ecl_read_object_non_recursive(strm); - } else { - x = ecl_read_object(strm); - } - if (x == OBJNULL) { - if (Null(eof_errorp)) - @(return eof_value) - FEend_of_file(strm); - } - /* Skip whitespace characters, but stop at beginning of new line or token */ - if (Null(recursivep)) { - cl_object rtbl = ecl_current_readtable(); - int c = ecl_read_char(strm); - if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) { - ecl_unread_char(c, strm); - } - } - @(return x) -@) + cl_object x; + @ + strm = stream_or_default_input(strm); + if (Null(recursivep)) { + x = ecl_read_object_non_recursive(strm); + } else { + x = ecl_read_object(strm); + } + if (x == OBJNULL) { + if (Null(eof_errorp)) { + @(return eof_value); + } + FEend_of_file(strm); + } + /* Skip whitespace characters, but stop at beginning of new line or token */ + if (Null(recursivep)) { + cl_object rtbl = ecl_current_readtable(); + int c = ecl_read_char(strm); + if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) { + ecl_unread_char(c, strm); + } + } + @(return x); + @) @(defun read_preserving_whitespace - (&optional (strm ECL_NIL) - (eof_errorp ECL_T) - eof_value - recursivep) - cl_object x; -@ - strm = stream_or_default_input(strm); - if (Null(recursivep)) { - x = ecl_read_object_non_recursive(strm); - } else { - x = ecl_read_object(strm); - } - if (x == OBJNULL) { - if (Null(eof_errorp)) - @(return eof_value) - FEend_of_file(strm); - } - @(return x) -@) + (&optional (strm ECL_NIL) + (eof_errorp ECL_T) + eof_value + recursivep) + cl_object x; + @ + strm = stream_or_default_input(strm); + if (Null(recursivep)) { + x = ecl_read_object_non_recursive(strm); + } else { + x = ecl_read_object(strm); + } + if (x == OBJNULL) { + if (Null(eof_errorp)) + @(return eof_value); + FEend_of_file(strm); + } + @(return x); + @) static cl_object do_read_delimited_list(int d, cl_object in, bool proper_list) { - int after_dot = 0; - bool suppress = read_suppress; - cl_object x, y = ECL_NIL; - cl_object *p = &y; - do { - x = ecl_read_object_with_delimiter(in, d, ECL_READ_LIST_DOT, - cat_constituent); - if (x == OBJNULL) { - /* End of the list. */ - unlikely_if (after_dot == 1) { - /* Something like (1 . ) */ - FEreader_error("Object missing after a list dot", in, 0); - } - return y; - } else if (x == @'si::.') { - unlikely_if (proper_list) { - FEreader_error("A dotted list was found where a proper list was expected.", in, 0); - } - unlikely_if (p == &y) { - /* Something like (. 2) */ - FEreader_error("A dot appeared after a left parenthesis.", in, 0); - } - unlikely_if (after_dot) { - /* Something like (1 . . 2) */ - FEreader_error("Two dots appeared consecutively.", in, 0); - } - after_dot = 1; - } else if (after_dot) { - unlikely_if (after_dot++ > 1) { - /* Something like (1 . 2 3) */ - FEreader_error("Too many objects after a list dot", in, 0); - } - *p = x; - } else if (!suppress) { - *p = ecl_list1(x); - p = &ECL_CONS_CDR(*p); - } - } while (1); + int after_dot = 0; + bool suppress = read_suppress; + cl_object x, y = ECL_NIL; + cl_object *p = &y; + do { + x = ecl_read_object_with_delimiter(in, d, ECL_READ_LIST_DOT, + cat_constituent); + if (x == OBJNULL) { + /* End of the list. */ + unlikely_if (after_dot == 1) { + /* Something like (1 . ) */ + FEreader_error("Object missing after a list dot", in, 0); + } + return y; + } else if (x == @'si::.') { + unlikely_if (proper_list) { + FEreader_error("A dotted list was found where a proper list was expected.", in, 0); + } + unlikely_if (p == &y) { + /* Something like (. 2) */ + FEreader_error("A dot appeared after a left parenthesis.", in, 0); + } + unlikely_if (after_dot) { + /* Something like (1 . . 2) */ + FEreader_error("Two dots appeared consecutively.", in, 0); + } + after_dot = 1; + } else if (after_dot) { + unlikely_if (after_dot++ > 1) { + /* Something like (1 . 2 3) */ + FEreader_error("Too many objects after a list dot", in, 0); + } + *p = x; + } else if (!suppress) { + *p = ecl_list1(x); + p = &ECL_CONS_CDR(*p); + } + } while (1); } @(defun read_delimited_list (d &optional (strm ECL_NIL) recursivep) - cl_object l; - int delimiter; -@ - delimiter = ecl_char_code(d); - strm = stream_or_default_input(strm); - if (!Null(recursivep)) { - l = do_read_delimited_list(delimiter, strm, 1); - } else { - ecl_bds_bind(the_env, @'si::*sharp-eq-context*', ECL_NIL); - ecl_bds_bind(the_env, @'si::*backq-level*', ecl_make_fixnum(0)); - l = do_read_delimited_list(delimiter, strm, 1); - l = patch_sharp(the_env, l); - ecl_bds_unwind_n(the_env, 2); - } - @(return l) -@) + cl_object l; + int delimiter; + @ + delimiter = ecl_char_code(d); + strm = stream_or_default_input(strm); + if (!Null(recursivep)) { + l = do_read_delimited_list(delimiter, strm, 1); + } else { + ecl_bds_bind(the_env, @'si::*sharp-eq-context*', ECL_NIL); + ecl_bds_bind(the_env, @'si::*backq-level*', ecl_make_fixnum(0)); + l = do_read_delimited_list(delimiter, strm, 1); + l = patch_sharp(the_env, l); + ecl_bds_unwind_n(the_env, 2); + } + @(return l); + @) @(defun read_line (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object token, value0, value1; -@ - strm = stream_or_default_input(strm); + int c; + cl_object token, value0, value1; + @ + strm = stream_or_default_input(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - value0 = _ecl_funcall2(@'gray::stream-read-line', strm); - value1 = ecl_nth_value(the_env, 1); - if (!Null(value1)) { - if (!Null(eof_errorp)) - FEend_of_file(strm); - value0 = eof_value; - value1 = ECL_T; - } - goto OUTPUT; - } + if (!ECL_ANSI_STREAM_P(strm)) { + value0 = _ecl_funcall2(@'gray::stream-read-line', strm); + value1 = ecl_nth_value(the_env, 1); + if (!Null(value1)) { + if (!Null(eof_errorp)) + FEend_of_file(strm); + value0 = eof_value; + value1 = ECL_T; + } + goto OUTPUT; + } #endif - token = si_get_buffer_string(); - do { - c = ecl_read_char(strm); - if (c == EOF || c == '\n') - break; - ecl_string_push_extend(token, c); - } while(1); - if (c == EOF && TOKEN_STRING_FILLP(token) == 0) { - if (!Null(eof_errorp)) - FEend_of_file(strm); - value0 = eof_value; - value1 = ECL_T; - } else { + token = si_get_buffer_string(); + do { + c = ecl_read_char(strm); + if (c == EOF || c == '\n') + break; + ecl_string_push_extend(token, c); + } while(1); + if (c == EOF && TOKEN_STRING_FILLP(token) == 0) { + if (!Null(eof_errorp)) + FEend_of_file(strm); + value0 = eof_value; + value1 = ECL_T; + } else { #ifdef ECL_NEWLINE_IS_CRLF /* From \r\n, ignore \r */ - if (TOKEN_STRING_FILLP(token) > 0 && - TOKEN_STRING_CHAR_CMP(token,TOKEN_STRING_FILLP(token)-1,'\r')) - TOKEN_STRING_FILLP(token)--; + if (TOKEN_STRING_FILLP(token) > 0 && + TOKEN_STRING_CHAR_CMP(token,TOKEN_STRING_FILLP(token)-1,'\r')) + TOKEN_STRING_FILLP(token)--; #endif #ifdef ECL_NEWLINE_IS_LFCR /* From \n\r, ignore \r */ - ecl_read_char(strm); + ecl_read_char(strm); #endif - value0 = cl_copy_seq(token); - value1 = (c == EOF? ECL_T : ECL_NIL); - } - si_put_buffer_string(token); + value0 = cl_copy_seq(token); + value1 = (c == EOF? ECL_T : ECL_NIL); + } + si_put_buffer_string(token); OUTPUT: - @(return value0 value1) -@) + @(return value0 value1); + @) @(defun read-char (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object output; -@ - strm = stream_or_default_input(strm); - c = ecl_read_char(strm); - if (c != EOF) - output = ECL_CODE_CHAR(c); - else if (Null(eof_errorp)) - output = eof_value; - else - FEend_of_file(strm); - @(return output) -@) + int c; + cl_object output; + @ + strm = stream_or_default_input(strm); + c = ecl_read_char(strm); + if (c != EOF) + output = ECL_CODE_CHAR(c); + else if (Null(eof_errorp)) + output = eof_value; + else + FEend_of_file(strm); + @(return output); + @) @(defun unread_char (c &optional (strm ECL_NIL)) -@ - /* INV: unread_char() checks the type `c' */ - strm = stream_or_default_input(strm); - ecl_unread_char(ecl_char_code(c), strm); - @(return ECL_NIL) -@) + @ + /* INV: unread_char() checks the type `c' */ + strm = stream_or_default_input(strm); + ecl_unread_char(ecl_char_code(c), strm); + @(return ECL_NIL); + @) @(defun peek-char (&optional peek_type (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int c; - cl_object rtbl = ecl_current_readtable(); -@ - strm = stream_or_default_input(strm); + int c; + cl_object rtbl = ecl_current_readtable(); + @ + strm = stream_or_default_input(strm); + c = ecl_peek_char(strm); + if (c != EOF && !Null(peek_type)) { + if (peek_type == ECL_T) { + do { + /* If the character is not a whitespace, output */ + if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace) + break; + /* Otherwise, read the whitespace and peek the + * next character */ + ecl_read_char(strm); c = ecl_peek_char(strm); - if (c != EOF && !Null(peek_type)) { - if (peek_type == ECL_T) { - do { - /* If the character is not a whitespace, output */ - if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace) - break; - /* Otherwise, read the whitespace and peek the - * next character */ - ecl_read_char(strm); - c = ecl_peek_char(strm); - } while (c != EOF); - } else { - do { - /* If the character belongs to the given class, - * we're done. */ - if (ecl_char_eq(ECL_CODE_CHAR(c), peek_type)) - break; - /* Otherwise, consume the character and - * peek the next one. */ - ecl_read_char(strm); - c = ecl_peek_char(strm); - } while (c != EOF); - } - } - if (c != EOF) { - eof_value = ECL_CODE_CHAR(c); - } else if (!Null(eof_errorp)) { - FEend_of_file(strm); - } - @(return eof_value) -@) + } while (c != EOF); + } else { + do { + /* If the character belongs to the given class, + * we're done. */ + if (ecl_char_eq(ECL_CODE_CHAR(c), peek_type)) + break; + /* Otherwise, consume the character and + * peek the next one. */ + ecl_read_char(strm); + c = ecl_peek_char(strm); + } while (c != EOF); + } + } + if (c != EOF) { + eof_value = ECL_CODE_CHAR(c); + } else if (!Null(eof_errorp)) { + FEend_of_file(strm); + } + @(return eof_value); + @) @(defun listen (&optional (strm ECL_NIL)) -@ - strm = stream_or_default_input(strm); - @(return ((ecl_listen_stream(strm) == ECL_LISTEN_AVAILABLE)? ECL_T : ECL_NIL)) -@) + @ + strm = stream_or_default_input(strm); + @(return ((ecl_listen_stream(strm) == ECL_LISTEN_AVAILABLE)? ECL_T : ECL_NIL)); + @) @(defun read_char_no_hang (&optional (strm ECL_NIL) (eof_errorp ECL_T) eof_value recursivep) - int f; -@ - strm = stream_or_default_input(strm); + int f; + @ + strm = stream_or_default_input(strm); #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(strm)) { - cl_object output = - _ecl_funcall2(@'gray::stream-read-char-no-hang', strm); - if (output == @':eof') - goto END_OF_FILE; - @(return output); - } + if (!ECL_ANSI_STREAM_P(strm)) { + cl_object output = + _ecl_funcall2(@'gray::stream-read-char-no-hang', strm); + if (output == @':eof') + goto END_OF_FILE; + @(return output); + } #endif - f = ecl_listen_stream(strm); - if (f == ECL_LISTEN_AVAILABLE) { - int c = ecl_read_char(strm); - if (c != EOF) { - @(return ECL_CODE_CHAR(c)); - } - } else if (f == ECL_LISTEN_NO_CHAR) { - @(return @'nil'); - } - /* We reach here if there was an EOF */ - END_OF_FILE: - if (Null(eof_errorp)) - @(return eof_value) - else - FEend_of_file(strm); -@) + f = ecl_listen_stream(strm); + if (f == ECL_LISTEN_AVAILABLE) { + int c = ecl_read_char(strm); + if (c != EOF) { + @(return ECL_CODE_CHAR(c)); + } + } else if (f == ECL_LISTEN_NO_CHAR) { + @(return @'nil'); + } + /* We reach here if there was an EOF */ + END_OF_FILE: + if (Null(eof_errorp)) { + @(return eof_value); + } + else { + FEend_of_file(strm); + } + @) @(defun clear_input (&optional (strm ECL_NIL)) -@ - strm = stream_or_default_input(strm); - ecl_clear_input(strm); - @(return ECL_NIL) -@) + @ + strm = stream_or_default_input(strm); + ecl_clear_input(strm); + @(return ECL_NIL); + @) @(defun read_byte (binary_input_stream &optional (eof_errorp ECL_T) eof_value) - cl_object c; -@ - c = ecl_read_byte(binary_input_stream); - if (c == ECL_NIL) { - if (Null(eof_errorp)) - @(return eof_value) - else - FEend_of_file(binary_input_stream); - } - @(return c) -@) + cl_object c; + @ + c = ecl_read_byte(binary_input_stream); + if (c == ECL_NIL) { + if (Null(eof_errorp)) { + @(return eof_value); + } + else + FEend_of_file(binary_input_stream); + } + @(return c); + @) @(defun read_sequence (sequence stream &key (start ecl_make_fixnum(0)) end) -@ + @ #ifdef ECL_CLOS_STREAMS - if (!ECL_ANSI_STREAM_P(stream)) - return funcall(5, @'gray::stream-read-sequence', stream, sequence, start, end); - else + if (!ECL_ANSI_STREAM_P(stream)) + return funcall(5, @'gray::stream-read-sequence', stream, sequence, start, end); + else #endif - return si_do_read_sequence(sequence, stream, start, end); -@) + return si_do_read_sequence(sequence, stream, start, end); + @) @(defun copy_readtable (&o (from ecl_current_readtable()) to) -@ - if (Null(from)) { - to = ecl_copy_readtable(cl_core.standard_readtable, to); - } else { - to = ecl_copy_readtable(from, to); - } - @(return to) -@) + @ + if (Null(from)) { + to = ecl_copy_readtable(cl_core.standard_readtable, to); + } else { + to = ecl_copy_readtable(from, to); + } + @(return to); + @) cl_object cl_readtable_case(cl_object r) { - assert_type_readtable(@[readtable-case], 1, r); - switch (r->readtable.read_case) { - case ecl_case_upcase: r = @':upcase'; break; - case ecl_case_downcase: r = @':downcase'; break; - case ecl_case_invert: r = @':invert'; break; - case ecl_case_preserve: r = @':preserve'; - } - @(return r) + assert_type_readtable(@[readtable-case], 1, r); + switch (r->readtable.read_case) { + case ecl_case_upcase: r = @':upcase'; break; + case ecl_case_downcase: r = @':downcase'; break; + case ecl_case_invert: r = @':invert'; break; + case ecl_case_preserve: r = @':preserve'; + } + @(return r); } static void error_locked_readtable(cl_object r) { - cl_error(2, - make_constant_base_string("Cannot modify locked readtable ~A."), - r); + cl_error(2, + make_constant_base_string("Cannot modify locked readtable ~A."), + r); } cl_object si_readtable_case_set(cl_object r, cl_object mode) { - assert_type_readtable(@[readtable-case], 1, r); - if (r->readtable.locked) { - error_locked_readtable(r); - } - if (mode == @':upcase') { - r->readtable.read_case = ecl_case_upcase; - } else if (mode == @':downcase') { - r->readtable.read_case = ecl_case_downcase; - } else if (mode == @':preserve') { - r->readtable.read_case = ecl_case_preserve; - } else if (mode == @':invert') { - r->readtable.read_case = ecl_case_invert; - } else { - const char *type = "(member :upcase :downcase :preserve :invert)"; - FEwrong_type_nth_arg(@[si::readtable-case-set], 2, - mode, ecl_read_from_cstring(type)); - } - @(return mode) + assert_type_readtable(@[readtable-case], 1, r); + if (r->readtable.locked) { + error_locked_readtable(r); + } + if (mode == @':upcase') { + r->readtable.read_case = ecl_case_upcase; + } else if (mode == @':downcase') { + r->readtable.read_case = ecl_case_downcase; + } else if (mode == @':preserve') { + r->readtable.read_case = ecl_case_preserve; + } else if (mode == @':invert') { + r->readtable.read_case = ecl_case_invert; + } else { + const char *type = "(member :upcase :downcase :preserve :invert)"; + FEwrong_type_nth_arg(@[si::readtable-case-set], 2, + mode, ecl_read_from_cstring(type)); + } + @(return mode); } cl_object cl_readtablep(cl_object readtable) { - @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)) + @(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL)); } int ecl_readtable_get(cl_object readtable, int c, cl_object *macro_or_table) { - cl_object m; - enum ecl_chattrib cat; + cl_object m; + enum ecl_chattrib cat; #ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - cat = cat_constituent; - m = ECL_NIL; - if (!Null(hash)) { - cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); - if (!Null(pair)) { - cat = ecl_fixnum(ECL_CONS_CAR(pair)); - m = ECL_CONS_CDR(pair); - } - } - } else + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + cat = cat_constituent; + m = ECL_NIL; + if (!Null(hash)) { + cl_object pair = ecl_gethash_safe(ECL_CODE_CHAR(c), hash, ECL_NIL); + if (!Null(pair)) { + cat = ecl_fixnum(ECL_CONS_CAR(pair)); + m = ECL_CONS_CDR(pair); + } + } + } else #endif - { - m = readtable->readtable.table[c].dispatch; - cat = readtable->readtable.table[c].syntax_type; - } - if (macro_or_table) *macro_or_table = m; - return cat; + { + m = readtable->readtable.table[c].dispatch; + cat = readtable->readtable.table[c].syntax_type; + } + if (macro_or_table) *macro_or_table = m; + return cat; } void ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, - cl_object macro_or_table) + cl_object macro_or_table) { - if (readtable->readtable.locked) { - error_locked_readtable(readtable); - } + if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } #ifdef ECL_UNICODE - if (c >= RTABSIZE) { - cl_object hash = readtable->readtable.hash; - if (Null(hash)) { - hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); - readtable->readtable.hash = hash; - } - _ecl_sethash(ECL_CODE_CHAR(c), hash, - CONS(ecl_make_fixnum(cat), macro_or_table)); - } else + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + if (Null(hash)) { + hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), + cl_core.rehash_size, + cl_core.rehash_threshold); + readtable->readtable.hash = hash; + } + _ecl_sethash(ECL_CODE_CHAR(c), hash, + CONS(ecl_make_fixnum(cat), macro_or_table)); + } else #endif - { - readtable->readtable.table[c].dispatch = macro_or_table; - readtable->readtable.table[c].syntax_type = cat; - } + { + readtable->readtable.table[c].dispatch = macro_or_table; + readtable->readtable.table[c].syntax_type = cat; + } } bool ecl_invalid_character_p(int c) { - return (c <= 32) || (c == 127); + return (c <= 32) || (c == 127); } @(defun set_syntax_from_char (tochr fromchr &o (tordtbl ecl_current_readtable()) - fromrdtbl) - enum ecl_chattrib cat; - cl_object dispatch; - cl_fixnum fc, tc; -@ - if (tordtbl->readtable.locked) { - error_locked_readtable(tordtbl); - } - if (Null(fromrdtbl)) - fromrdtbl = cl_core.standard_readtable; - assert_type_readtable(@[readtable-case], 1, tordtbl); - assert_type_readtable(@[readtable-case], 2, fromrdtbl); - fc = ecl_char_code(fromchr); - tc = ecl_char_code(tochr); + fromrdtbl) + enum ecl_chattrib cat; + cl_object dispatch; + cl_fixnum fc, tc; + @ + if (tordtbl->readtable.locked) { + error_locked_readtable(tordtbl); + } + if (Null(fromrdtbl)) + fromrdtbl = cl_core.standard_readtable; + assert_type_readtable(@[readtable-case], 1, tordtbl); + assert_type_readtable(@[readtable-case], 2, fromrdtbl); + fc = ecl_char_code(fromchr); + tc = ecl_char_code(tochr); - cat = ecl_readtable_get(fromrdtbl, fc, &dispatch); - if (ECL_READTABLEP(dispatch)) { - dispatch = si_copy_hash_table(dispatch); - } - ecl_readtable_set(tordtbl, tc, cat, dispatch); - @(return ECL_T) -@) + cat = ecl_readtable_get(fromrdtbl, fc, &dispatch); + if (ECL_READTABLEP(dispatch)) { + dispatch = si_copy_hash_table(dispatch); + } + ecl_readtable_set(tordtbl, tc, cat, dispatch); + @(return ECL_T); + @) @(defun set_macro_character (c function &optional non_terminating_p (readtable ecl_current_readtable())) -@ - ecl_readtable_set(readtable, ecl_char_code(c), - Null(non_terminating_p)? - cat_terminating : - cat_non_terminating, - function); - @(return ECL_T) -@) + @ + ecl_readtable_set(readtable, ecl_char_code(c), + Null(non_terminating_p)? + cat_terminating : + cat_non_terminating, + function); + @(return ECL_T); + @) @(defun get_macro_character (c &optional (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object dispatch; -@ - if (Null(readtable)) - readtable = cl_core.standard_readtable; - cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch); - if (ECL_HASH_TABLE_P(dispatch)) - dispatch = cl_core.dispatch_reader; - @(return dispatch ((cat == cat_non_terminating)? ECL_T : ECL_NIL)) -@) + enum ecl_chattrib cat; + cl_object dispatch; + @ + if (Null(readtable)) + readtable = cl_core.standard_readtable; + cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch); + if (ECL_HASH_TABLE_P(dispatch)) + dispatch = cl_core.dispatch_reader; + @(return dispatch ((cat == cat_non_terminating)? ECL_T : ECL_NIL)); + @) @(defun make_dispatch_macro_character (chr - &optional non_terminating_p (readtable ecl_current_readtable())) - enum ecl_chattrib cat; - cl_object table; - int c; -@ - assert_type_readtable(@[make-dispatch-macro-character], 3, readtable); - c = ecl_char_code(chr); - cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; - table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); - ecl_readtable_set(readtable, c, cat, table); - @(return ECL_T) -@) + &optional non_terminating_p (readtable ecl_current_readtable())) + enum ecl_chattrib cat; + cl_object table; + int c; + @ + assert_type_readtable(@[make-dispatch-macro-character], 3, readtable); + c = ecl_char_code(chr); + cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; + table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), + cl_core.rehash_size, + cl_core.rehash_threshold); + ecl_readtable_set(readtable, c, cat, table); + @(return ECL_T); + @) @(defun set_dispatch_macro_character (dspchr subchr fnc - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum subcode; -@ - assert_type_readtable(@[set-dispatch-macro-character], 4, readtable); - ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); - unlikely_if (readtable->readtable.locked) { - error_locked_readtable(readtable); - } - unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - subcode = ecl_char_code(subchr); - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - if (ecl_lower_case_p(subcode)) { - subcode = ecl_char_upcase(subcode); - } else if (ecl_upper_case_p(subcode)) { - subcode = ecl_char_downcase(subcode); - } - if (Null(fnc)) { - ecl_remhash(ECL_CODE_CHAR(subcode), table); - } else { - _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); - } - @(return ECL_T) -@) + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum subcode; + @ + assert_type_readtable(@[set-dispatch-macro-character], 4, readtable); + ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); + unlikely_if (readtable->readtable.locked) { + error_locked_readtable(readtable); + } + unlikely_if (!ECL_HASH_TABLE_P(table)) { + FEerror("~S is not a dispatch character.", 1, dspchr); + } + subcode = ecl_char_code(subchr); + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + if (ecl_lower_case_p(subcode)) { + subcode = ecl_char_upcase(subcode); + } else if (ecl_upper_case_p(subcode)) { + subcode = ecl_char_downcase(subcode); + } + if (Null(fnc)) { + ecl_remhash(ECL_CODE_CHAR(subcode), table); + } else { + _ecl_sethash(ECL_CODE_CHAR(subcode), table, fnc); + } + @(return ECL_T); + @) @(defun get_dispatch_macro_character (dspchr subchr - &optional (readtable ecl_current_readtable())) - cl_object table; - cl_fixnum c; -@ - if (Null(readtable)) { - readtable = cl_core.standard_readtable; - } - assert_type_readtable(@[get-dispatch-macro-character], 3, readtable); - c = ecl_char_code(dspchr); - ecl_readtable_get(readtable, c, &table); - unlikely_if (!ECL_HASH_TABLE_P(table)) { - FEerror("~S is not a dispatch character.", 1, dspchr); - } - c = ecl_char_code(subchr); + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum c; + @ + if (Null(readtable)) { + readtable = cl_core.standard_readtable; + } + assert_type_readtable(@[get-dispatch-macro-character], 3, readtable); + c = ecl_char_code(dspchr); + ecl_readtable_get(readtable, c, &table); + unlikely_if (!ECL_HASH_TABLE_P(table)) { + FEerror("~S is not a dispatch character.", 1, dspchr); + } + c = ecl_char_code(subchr); - /* Since macro characters may take a number as argument, it is - not allowed to turn digits into dispatch macro characters */ - if (ecl_digitp(c, 10) >= 0) - @(return ECL_NIL) - @(return ecl_gethash_safe(subchr, table, ECL_NIL)) -@) + /* Since macro characters may take a number as argument, it is + not allowed to turn digits into dispatch macro characters */ + if (ecl_digitp(c, 10) >= 0) + @(return ECL_NIL); + @(return ecl_gethash_safe(subchr, table, ECL_NIL)); + @) cl_object si_standard_readtable() { - @(return cl_core.standard_readtable) + @(return cl_core.standard_readtable); } @(defun ext::readtable-lock (r &optional yesno) - cl_object output; -@ - assert_type_readtable(@[ext::readtable-lock], 1, r); - output = (r->readtable.locked)? ECL_T : ECL_NIL; - if (narg > 1) { - r->readtable.locked = !Null(yesno); - } - @(return output) -@) + cl_object output; + @ + assert_type_readtable(@[ext::readtable-lock], 1, r); + output = (r->readtable.locked)? ECL_T : ECL_NIL; + if (narg > 1) { + r->readtable.locked = !Null(yesno); + } + @(return output); + @) static void extra_argument(int c, cl_object stream, cl_object d) { - FEreader_error("~S is an extra argument for the #~C readmacro.", - stream, 2, d, ECL_CODE_CHAR(c)); + FEreader_error("~S is an extra argument for the #~C readmacro.", + stream, 2, d, ECL_CODE_CHAR(c)); } @@ -2065,221 +2067,221 @@ extra_argument(int c, cl_object stream, cl_object d) void init_read(void) { - struct ecl_readtable_entry *rtab; - cl_object r; - int i; + struct ecl_readtable_entry *rtab; + cl_object r; + int i; - cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); - r->readtable.locked = 0; - r->readtable.read_case = ecl_case_upcase; - r->readtable.table = rtab - = (struct ecl_readtable_entry *) - ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); - for (i = 0; i < RTABSIZE; i++) { - rtab[i].syntax_type = cat_constituent; - rtab[i].dispatch = ECL_NIL; - } + cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); + r->readtable.locked = 0; + r->readtable.read_case = ecl_case_upcase; + r->readtable.table = rtab + = (struct ecl_readtable_entry *) + ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); + for (i = 0; i < RTABSIZE; i++) { + rtab[i].syntax_type = cat_constituent; + rtab[i].dispatch = ECL_NIL; + } #ifdef ECL_UNICODE - r->readtable.hash = ECL_NIL; + r->readtable.hash = ECL_NIL; #endif - cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); + cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); - ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\t', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\n', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\f', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, '\r', cat_whitespace, ECL_NIL); + ecl_readtable_set(r, ' ', cat_whitespace, ECL_NIL); - ecl_readtable_set(r, '"', cat_terminating, - make_cf2(double_quote_reader)); + ecl_readtable_set(r, '"', cat_terminating, + make_cf2(double_quote_reader)); - ecl_readtable_set(r, '\'', cat_terminating, - make_cf2(single_quote_reader)); - ecl_readtable_set(r, '(', cat_terminating, - make_cf2(left_parenthesis_reader)); - ecl_readtable_set(r, ')', cat_terminating, - make_cf2(right_parenthesis_reader)); - ecl_readtable_set(r, ',', cat_terminating, - make_cf2(comma_reader)); - ecl_readtable_set(r, ';', cat_terminating, - make_cf2(semicolon_reader)); - ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); - ecl_readtable_set(r, '`', cat_terminating, - make_cf2(backquote_reader)); - ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); + ecl_readtable_set(r, '\'', cat_terminating, + make_cf2(single_quote_reader)); + ecl_readtable_set(r, '(', cat_terminating, + make_cf2(left_parenthesis_reader)); + ecl_readtable_set(r, ')', cat_terminating, + make_cf2(right_parenthesis_reader)); + ecl_readtable_set(r, ',', cat_terminating, + make_cf2(comma_reader)); + ecl_readtable_set(r, ';', cat_terminating, + make_cf2(semicolon_reader)); + ecl_readtable_set(r, '\\', cat_single_escape, ECL_NIL); + ecl_readtable_set(r, '`', cat_terminating, + make_cf2(backquote_reader)); + ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL); - cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun); + cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun); - cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), - ECL_T /* non terminating */, r); + cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'), + ECL_T /* non terminating */, r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), - make_cf3(sharp_C_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), - make_cf3(sharp_backslash_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), - make_cf3(sharp_single_quote_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), - make_cf3(sharp_left_parenthesis_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), - make_cf3(sharp_asterisk_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), - make_cf3(sharp_colon_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), - make_cf3(sharp_dot_reader), r); - /* Used for fasload only. */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), - make_cf3(sharp_B_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), - make_cf3(sharp_O_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), - make_cf3(sharp_X_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), - make_cf3(sharp_R_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), - @'si::sharp-a-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), - @'si::sharp-s-reader', r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), - make_cf3(sharp_P_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('C'), + make_cf3(sharp_C_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\\'), + make_cf3(sharp_backslash_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\''), + make_cf3(sharp_single_quote_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('('), + make_cf3(sharp_left_parenthesis_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('*'), + make_cf3(sharp_asterisk_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(':'), + make_cf3(sharp_colon_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('.'), + make_cf3(sharp_dot_reader), r); + /* Used for fasload only. */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('B'), + make_cf3(sharp_B_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('O'), + make_cf3(sharp_O_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('X'), + make_cf3(sharp_X_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('R'), + make_cf3(sharp_R_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('A'), + @'si::sharp-a-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('S'), + @'si::sharp-s-reader', r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('P'), + make_cf3(sharp_P_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), - make_cf3(sharp_eq_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), - make_cf3(sharp_sharp_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), - make_cf3(sharp_plus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), - make_cf3(sharp_minus_reader), r); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), - make_cf3(sharp_vertical_bar_reader), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), - make_cf3(sharp_dollar_reader), r); - /* This is specific to this implementation */ - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), - make_cf3(sharp_Y_reader), r); - /* This is specific to this implementation: ignore BOM */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('='), + make_cf3(sharp_eq_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('#'), + make_cf3(sharp_sharp_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('+'), + make_cf3(sharp_plus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('-'), + make_cf3(sharp_minus_reader), r); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('|'), + make_cf3(sharp_vertical_bar_reader), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('$'), + make_cf3(sharp_dollar_reader), r); + /* This is specific to this implementation */ + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('Y'), + make_cf3(sharp_Y_reader), r); + /* This is specific to this implementation: ignore BOM */ #ifdef ECL_UNICODE - ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); + ecl_readtable_set(r, 0xfeff, cat_whitespace, ECL_NIL); #endif - /* Lock the standard read table so that we do not have to make copies - * to keep it unchanged */ - r->readtable.locked = 1; + /* Lock the standard read table so that we do not have to make copies + * to keep it unchanged */ + r->readtable.locked = 1; - init_backq(); + init_backq(); - ECL_SET(@'*readtable*', - r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); - cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), - ECL_NIL, r); - ECL_SET(@'*read-default-float-format*', @'single-float'); + ECL_SET(@'*readtable*', + r=ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL)); + cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('!'), + ECL_NIL, r); + ECL_SET(@'*read-default-float-format*', @'single-float'); - { - cl_object var, val; - var = cl_list(24, - @'*print-pprint-dispatch*', /* See end of pprint.lsp */ - @'*print-array*', - @'*print-base*', - @'*print-case*', - @'*print-circle*', - @'*print-escape*', - @'*print-gensym*', - @'*print-length*', - @'*print-level*', - @'*print-lines*', - @'*print-miser-width*', - @'*print-pretty*', - @'*print-radix*', - @'*print-readably*', - @'*print-right-margin*', - @'*read-base*', - @'*read-default-float-format*', - @'*read-eval*', - @'*read-suppress*', - @'*readtable*', - @'si::*print-package*', - @'si::*print-structure*', - @'si::*sharp-eq-context*', - @'si::*circle-counter*'); - val = cl_list(24, - /**pprint-dispatch-table**/ ECL_NIL, - /**print-array**/ ECL_T, - /**print-base**/ ecl_make_fixnum(10), - /**print-case**/ @':downcase', - /**print-circle**/ ECL_T, - /**print-escape**/ ECL_T, - /**print-gensym**/ ECL_T, - /**print-length**/ ECL_NIL, - /**print-level**/ ECL_NIL, - /**print-lines**/ ECL_NIL, - /**print-miser-width**/ ECL_NIL, - /**print-pretty**/ ECL_NIL, - /**print-radix**/ ECL_NIL, - /**print-readably**/ ECL_T, - /**print-right-margin**/ ECL_NIL, - /**read-base**/ ecl_make_fixnum(10), - /**read-default-float-format**/ @'single-float', - /**read-eval**/ ECL_T, - /**read-suppress**/ ECL_NIL, - /**readtable**/ cl_core.standard_readtable, - /*si::*print-package**/ cl_core.lisp_package, - /*si::*print-structure**/ ECL_T, - /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); - ECL_SET(@'si::+ecl-syntax-progv-list+', CONS(var,val)); - var = cl_list(23, - @'*print-pprint-dispatch*', /* See end of pprint.lsp */ - @'*print-array*', - @'*print-base*', - @'*print-case*', - @'*print-circle*', - @'*print-escape*', - @'*print-gensym*', - @'*print-length*', - @'*print-level*', - @'*print-lines*', - @'*print-miser-width*', - @'*print-pretty*', - @'*print-radix*', - @'*print-readably*', - @'*print-right-margin*', - @'*read-base*', - @'*read-default-float-format*', - @'*read-eval*', - @'*read-suppress*', - @'*readtable*', - @'*package*', - @'si::*sharp-eq-context*', - @'si::*circle-counter*'); - val = cl_list(23, - /**pprint-dispatch-table**/ ECL_NIL, - /**print-array**/ ECL_T, - /**print-base**/ ecl_make_fixnum(10), - /**print-case**/ @':upcase', - /**print-circle**/ ECL_NIL, - /**print-escape**/ ECL_T, - /**print-gensym**/ ECL_T, - /**print-length**/ ECL_NIL, - /**print-level**/ ECL_NIL, - /**print-lines**/ ECL_NIL, - /**print-miser-width**/ ECL_NIL, - /**print-pretty**/ ECL_NIL, - /**print-radix**/ ECL_NIL, - /**print-readably**/ ECL_T, - /**print-right-margin**/ ECL_NIL, - /**read-base**/ ecl_make_fixnum(10), - /**read-default-float-format**/ @'single-float', - /**read-eval**/ ECL_T, - /**read-suppress**/ ECL_NIL, - /**readtable**/ cl_core.standard_readtable, - /**package**/ cl_core.user_package, - /*si::*sharp-eq-context**/ ECL_NIL, - /*si::*cicle-counter**/ ECL_NIL); - ECL_SET(@'si::+io-syntax-progv-list+', CONS(var,val)); - } + { + cl_object var, val; + var = cl_list(24, + @'*print-pprint-dispatch*', /* See end of pprint.lsp */ + @'*print-array*', + @'*print-base*', + @'*print-case*', + @'*print-circle*', + @'*print-escape*', + @'*print-gensym*', + @'*print-length*', + @'*print-level*', + @'*print-lines*', + @'*print-miser-width*', + @'*print-pretty*', + @'*print-radix*', + @'*print-readably*', + @'*print-right-margin*', + @'*read-base*', + @'*read-default-float-format*', + @'*read-eval*', + @'*read-suppress*', + @'*readtable*', + @'si::*print-package*', + @'si::*print-structure*', + @'si::*sharp-eq-context*', + @'si::*circle-counter*'); + val = cl_list(24, + /**pprint-dispatch-table**/ ECL_NIL, + /**print-array**/ ECL_T, + /**print-base**/ ecl_make_fixnum(10), + /**print-case**/ @':downcase', + /**print-circle**/ ECL_T, + /**print-escape**/ ECL_T, + /**print-gensym**/ ECL_T, + /**print-length**/ ECL_NIL, + /**print-level**/ ECL_NIL, + /**print-lines**/ ECL_NIL, + /**print-miser-width**/ ECL_NIL, + /**print-pretty**/ ECL_NIL, + /**print-radix**/ ECL_NIL, + /**print-readably**/ ECL_T, + /**print-right-margin**/ ECL_NIL, + /**read-base**/ ecl_make_fixnum(10), + /**read-default-float-format**/ @'single-float', + /**read-eval**/ ECL_T, + /**read-suppress**/ ECL_NIL, + /**readtable**/ cl_core.standard_readtable, + /*si::*print-package**/ cl_core.lisp_package, + /*si::*print-structure**/ ECL_T, + /*si::*sharp-eq-context**/ ECL_NIL, + /*si::*cicle-counter**/ ECL_NIL); + ECL_SET(@'si::+ecl-syntax-progv-list+', CONS(var,val)); + var = cl_list(23, + @'*print-pprint-dispatch*', /* See end of pprint.lsp */ + @'*print-array*', + @'*print-base*', + @'*print-case*', + @'*print-circle*', + @'*print-escape*', + @'*print-gensym*', + @'*print-length*', + @'*print-level*', + @'*print-lines*', + @'*print-miser-width*', + @'*print-pretty*', + @'*print-radix*', + @'*print-readably*', + @'*print-right-margin*', + @'*read-base*', + @'*read-default-float-format*', + @'*read-eval*', + @'*read-suppress*', + @'*readtable*', + @'*package*', + @'si::*sharp-eq-context*', + @'si::*circle-counter*'); + val = cl_list(23, + /**pprint-dispatch-table**/ ECL_NIL, + /**print-array**/ ECL_T, + /**print-base**/ ecl_make_fixnum(10), + /**print-case**/ @':upcase', + /**print-circle**/ ECL_NIL, + /**print-escape**/ ECL_T, + /**print-gensym**/ ECL_T, + /**print-length**/ ECL_NIL, + /**print-level**/ ECL_NIL, + /**print-lines**/ ECL_NIL, + /**print-miser-width**/ ECL_NIL, + /**print-pretty**/ ECL_NIL, + /**print-radix**/ ECL_NIL, + /**print-readably**/ ECL_T, + /**print-right-margin**/ ECL_NIL, + /**read-base**/ ecl_make_fixnum(10), + /**read-default-float-format**/ @'single-float', + /**read-eval**/ ECL_T, + /**read-suppress**/ ECL_NIL, + /**readtable**/ cl_core.standard_readtable, + /**package**/ cl_core.user_package, + /*si::*sharp-eq-context**/ ECL_NIL, + /*si::*cicle-counter**/ ECL_NIL); + ECL_SET(@'si::+io-syntax-progv-list+', CONS(var,val)); + } } /* @@ -2297,178 +2299,178 @@ static cl_object make_one_data_stream(const cl_object string) { #ifdef ECL_UNICODE - return si_make_sequence_input_stream(3, string, @':external-format', - @':utf-8'); + return si_make_sequence_input_stream(3, string, @':external-format', + @':utf-8'); #else - return ecl_make_string_input_stream(string, 0, ecl_length(string)); + return ecl_make_string_input_stream(string, 0, ecl_length(string)); #endif } static cl_object make_data_stream(const cl_object *data) { - if (data == 0 || data[0] == NULL) { - return cl_core.null_stream; - } - if (data[1] == NULL) { - return make_one_data_stream(data[0]); - } else { - cl_object stream_list = ECL_NIL; - cl_index i; - for (i = 0; data[i]; i++) { - cl_object s = make_one_data_stream(data[i]); - stream_list = ecl_cons(s, stream_list); - } - return cl_apply(2, @'make-concatenated-stream', - cl_nreverse(stream_list)); - } + if (data == 0 || data[0] == NULL) { + return cl_core.null_stream; + } + if (data[1] == NULL) { + return make_one_data_stream(data[0]); + } else { + cl_object stream_list = ECL_NIL; + cl_index i; + for (i = 0; data[i]; i++) { + cl_object s = make_one_data_stream(data[i]); + stream_list = ecl_cons(s, stream_list); + } + return cl_apply(2, @'make-concatenated-stream', + cl_nreverse(stream_list)); + } } cl_object ecl_init_module(cl_object block, void (*entry_point)(cl_object)) { - const cl_env_ptr env = ecl_process_env(); - volatile cl_object old_eptbc = env->packages_to_be_created; - volatile cl_object x; - cl_index i, len, perm_len, temp_len; - cl_object in; - cl_object *VV = NULL, *VVtemp = NULL; + const cl_env_ptr env = ecl_process_env(); + volatile cl_object old_eptbc = env->packages_to_be_created; + volatile cl_object x; + cl_index i, len, perm_len, temp_len; + cl_object in; + cl_object *VV = NULL, *VVtemp = NULL; - if (block == NULL) - block = ecl_make_codeblock(); - block->cblock.entry = entry_point; + if (block == NULL) + block = ecl_make_codeblock(); + block->cblock.entry = entry_point; - in = OBJNULL; - ECL_UNWIND_PROTECT_BEGIN(env) { - cl_index bds_ndx; - cl_object progv_list; + in = OBJNULL; + ECL_UNWIND_PROTECT_BEGIN(env) { + cl_index bds_ndx; + cl_object progv_list; - ecl_bds_bind(env, @'si::*cblock*', block); - env->packages_to_be_created_p = ECL_T; + ecl_bds_bind(env, @'si::*cblock*', block); + env->packages_to_be_created_p = ECL_T; - /* Communicate the library which Cblock we are using, and get - * back the amount of data to be processed. - */ - (*entry_point)(block); - perm_len = block->cblock.data_size; - temp_len = block->cblock.temp_data_size; - len = perm_len + temp_len; + /* Communicate the library which Cblock we are using, and get + * back the amount of data to be processed. + */ + (*entry_point)(block); + perm_len = block->cblock.data_size; + temp_len = block->cblock.temp_data_size; + len = perm_len + temp_len; - if (block->cblock.data_text == 0) { - if (len) { - /* Code from COMPILE uses data in *compiler-constants* */ - cl_object v = ECL_SYM_VAL(env,@'si::*compiler-constants*'); - unlikely_if (ecl_t_of(v) != t_vector || - v->vector.dim != len || - v->vector.elttype != ecl_aet_object) - FEerror("Internal error: corrupted data in " - "si::*compiler-constants*", 0); - VV = block->cblock.data = v->vector.self.t; - VVtemp = block->cblock.temp_data = NULL; - } - goto NO_DATA_LABEL; - } - if (len == 0) { - VV = VVtemp = NULL; - goto NO_DATA_LABEL; - } + if (block->cblock.data_text == 0) { + if (len) { + /* Code from COMPILE uses data in *compiler-constants* */ + cl_object v = ECL_SYM_VAL(env,@'si::*compiler-constants*'); + unlikely_if (ecl_t_of(v) != t_vector || + v->vector.dim != len || + v->vector.elttype != ecl_aet_object) + FEerror("Internal error: corrupted data in " + "si::*compiler-constants*", 0); + VV = block->cblock.data = v->vector.self.t; + VVtemp = block->cblock.temp_data = NULL; + } + goto NO_DATA_LABEL; + } + if (len == 0) { + VV = VVtemp = NULL; + goto NO_DATA_LABEL; + } #ifdef ECL_DYNAMIC_VV - VV = block->cblock.data = perm_len? (cl_object *)ecl_alloc(perm_len * sizeof(cl_object)) : NULL; + VV = block->cblock.data = perm_len? (cl_object *)ecl_alloc(perm_len * sizeof(cl_object)) : NULL; #else - VV = block->cblock.data; + VV = block->cblock.data; #endif - memset(VV, 0, perm_len * sizeof(*VV)); + memset(VV, 0, perm_len * sizeof(*VV)); - VVtemp = block->cblock.temp_data = temp_len? (cl_object *)ecl_alloc(temp_len * sizeof(cl_object)) : NULL; - memset(VVtemp, 0, temp_len * sizeof(*VVtemp)); + VVtemp = block->cblock.temp_data = temp_len? (cl_object *)ecl_alloc(temp_len * sizeof(cl_object)) : NULL; + memset(VVtemp, 0, temp_len * sizeof(*VVtemp)); - /* Read all data for the library */ + /* Read all data for the library */ #ifdef ECL_EXTERNALIZABLE - { - cl_object v = ecl_deserialize(block->cblock.data_text); - unlikely_if (v->vector.dim < len) - FEreader_error("Not enough data while loading" - "binary file", in, 0); - memcpy(VV, v->vector.self.t, len * sizeof(cl_object)); - } + { + cl_object v = ecl_deserialize(block->cblock.data_text); + unlikely_if (v->vector.dim < len) + FEreader_error("Not enough data while loading" + "binary file", in, 0); + memcpy(VV, v->vector.self.t, len * sizeof(cl_object)); + } #else - in = make_data_stream(block->cblock.data_text); - progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); - bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), - ECL_CONS_CDR(progv_list)); - for (i = 0 ; i < len; i++) { - x = ecl_read_object(in); - if (x == OBJNULL) - break; - if (i < perm_len) - VV[i] = x; - else - VVtemp[i-perm_len] = x; - } - if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) { - while (i--) { - if (i < perm_len) { - VV[i] = patch_sharp(env, VV[i]); - } else { - VVtemp[i-perm_len] = patch_sharp(env, VVtemp[i-perm_len]); - } - } - } - ecl_bds_unwind(env, bds_ndx); - unlikely_if (i < len) - FEreader_error("Not enough data while loading" - "binary file", in, 0); - cl_close(1,in); - in = OBJNULL; + in = make_data_stream(block->cblock.data_text); + progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+'); + bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list), + ECL_CONS_CDR(progv_list)); + for (i = 0 ; i < len; i++) { + x = ecl_read_object(in); + if (x == OBJNULL) + break; + if (i < perm_len) + VV[i] = x; + else + VVtemp[i-perm_len] = x; + } + if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) { + while (i--) { + if (i < perm_len) { + VV[i] = patch_sharp(env, VV[i]); + } else { + VVtemp[i-perm_len] = patch_sharp(env, VVtemp[i-perm_len]); + } + } + } + ecl_bds_unwind(env, bds_ndx); + unlikely_if (i < len) + FEreader_error("Not enough data while loading" + "binary file", in, 0); + cl_close(1,in); + in = OBJNULL; #endif - NO_DATA_LABEL: - env->packages_to_be_created_p = ECL_NIL; + NO_DATA_LABEL: + env->packages_to_be_created_p = ECL_NIL; - assert(block->cblock.cfuns_size == 0 || VV != NULL); - for (i = 0; i < block->cblock.cfuns_size; i++) { - const struct ecl_cfun *prototype = block->cblock.cfuns+i; - cl_index fname_location = ecl_fixnum(prototype->block); - cl_object fname = VV[fname_location]; - cl_index location = ecl_fixnum(prototype->name); - cl_object position = prototype->file_position; - int narg = prototype->narg; - VV[location] = narg<0? - ecl_make_cfun_va((cl_objectfn)prototype->entry, - fname, block) : - ecl_make_cfun((cl_objectfn_fixed)prototype->entry, - fname, block, narg); - /* Add source file info */ - if (position != ecl_make_fixnum(-1)) { - ecl_set_function_source_file_info(VV[location], - block->cblock.source, - position); - } - } - /* Execute top-level code */ - (*entry_point)(OBJNULL); - x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); - old_eptbc = env->packages_to_be_created; - unlikely_if (!Null(x)) { - CEerror(ECL_T, - Null(ECL_CONS_CDR(x))? - "Package ~A referenced in " - "compiled file~& ~A~&but has not been created": - "The packages~& ~A~&were referenced in " - "compiled file~& ~A~&but have not been created", - 2, x, block->cblock.name); - } - if (VVtemp) { - block->cblock.temp_data = NULL; - block->cblock.temp_data_size = 0; - ecl_dealloc(VVtemp); - } - ecl_bds_unwind1(env); - } ECL_UNWIND_PROTECT_EXIT { - if (in != OBJNULL) - cl_close(1,in); - env->packages_to_be_created = old_eptbc; - env->packages_to_be_created_p = ECL_NIL; - } ECL_UNWIND_PROTECT_END; + assert(block->cblock.cfuns_size == 0 || VV != NULL); + for (i = 0; i < block->cblock.cfuns_size; i++) { + const struct ecl_cfun *prototype = block->cblock.cfuns+i; + cl_index fname_location = ecl_fixnum(prototype->block); + cl_object fname = VV[fname_location]; + cl_index location = ecl_fixnum(prototype->name); + cl_object position = prototype->file_position; + int narg = prototype->narg; + VV[location] = narg<0? + ecl_make_cfun_va((cl_objectfn)prototype->entry, + fname, block) : + ecl_make_cfun((cl_objectfn_fixed)prototype->entry, + fname, block, narg); + /* Add source file info */ + if (position != ecl_make_fixnum(-1)) { + ecl_set_function_source_file_info(VV[location], + block->cblock.source, + position); + } + } + /* Execute top-level code */ + (*entry_point)(OBJNULL); + x = cl_set_difference(2, env->packages_to_be_created, old_eptbc); + old_eptbc = env->packages_to_be_created; + unlikely_if (!Null(x)) { + CEerror(ECL_T, + Null(ECL_CONS_CDR(x))? + "Package ~A referenced in " + "compiled file~& ~A~&but has not been created": + "The packages~& ~A~&were referenced in " + "compiled file~& ~A~&but have not been created", + 2, x, block->cblock.name); + } + if (VVtemp) { + block->cblock.temp_data = NULL; + block->cblock.temp_data_size = 0; + ecl_dealloc(VVtemp); + } + ecl_bds_unwind1(env); + } ECL_UNWIND_PROTECT_EXIT { + if (in != OBJNULL) + cl_close(1,in); + env->packages_to_be_created = old_eptbc; + env->packages_to_be_created_p = ECL_NIL; + } ECL_UNWIND_PROTECT_END; - return block; + return block; } diff --git a/src/c/reader/parse_integer.d b/src/c/reader/parse_integer.d index 8a950958d..f346668cc 100644 --- a/src/c/reader/parse_integer.d +++ b/src/c/reader/parse_integer.d @@ -1,18 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -24,93 +21,95 @@ cl_object ecl_parse_integer(cl_object str, cl_index start, cl_index end, cl_index *ep, unsigned int radix) { - int sign, d; - cl_object integer_part, output; - cl_index i, c; + int sign, d; + cl_object integer_part, output; + cl_index i, c; - if (start >= end || !basep(radix)) { - *ep = start; - return OBJNULL; - } - sign = 1; - c = ecl_char(str, start); - if (c == '+') { - start++; - } else if (c == '-') { - sign = -1; - start++; - } - integer_part = _ecl_big_register0(); - _ecl_big_set_ui(integer_part, 0); - for (i = start; i < end; i++) { - c = ecl_char(str, i); - d = ecl_digitp(c, radix); - if (d < 0) { - break; - } - _ecl_big_mul_ui(integer_part, integer_part, radix); - _ecl_big_add_ui(integer_part, integer_part, d); - } - if (sign < 0) { - _ecl_big_complement(integer_part, integer_part); - } - output = _ecl_big_register_normalize(integer_part); - *ep = i; - return (i == start)? OBJNULL : output; + if (start >= end || !basep(radix)) { + *ep = start; + return OBJNULL; + } + sign = 1; + c = ecl_char(str, start); + if (c == '+') { + start++; + } else if (c == '-') { + sign = -1; + start++; + } + integer_part = _ecl_big_register0(); + _ecl_big_set_ui(integer_part, 0); + for (i = start; i < end; i++) { + c = ecl_char(str, i); + d = ecl_digitp(c, radix); + if (d < 0) { + break; + } + _ecl_big_mul_ui(integer_part, integer_part, radix); + _ecl_big_add_ui(integer_part, integer_part, d); + } + if (sign < 0) { + _ecl_big_complement(integer_part, integer_part); + } + output = _ecl_big_register_normalize(integer_part); + *ep = i; + return (i == start)? OBJNULL : output; } @(defun parse_integer (strng &key (start ecl_make_fixnum(0)) - end - (radix ecl_make_fixnum(10)) - junk_allowed + end + (radix ecl_make_fixnum(10)) + junk_allowed &aux x) - cl_index s, e, ep; - cl_object rtbl = ecl_current_readtable(); -@ { - unlikely_if (!ECL_STRINGP(strng)) { - FEwrong_type_nth_arg(@[parse-integer], 1, strng, @[string]); - } - unlikely_if (!ECL_FIXNUMP(radix) || - ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || - ecl_fixnum_greater(radix, ecl_make_fixnum(36))) + cl_index s, e, ep; + cl_object rtbl = ecl_current_readtable(); + @ { + unlikely_if (!ECL_STRINGP(strng)) { + FEwrong_type_nth_arg(@[parse-integer], 1, strng, @[string]); + } + unlikely_if (!ECL_FIXNUMP(radix) || + ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || + ecl_fixnum_greater(radix, ecl_make_fixnum(36))) + { + FEerror("~S is an illegal radix.", 1, radix); + } + { + cl_index_pair p = + ecl_vector_start_end(@[parse-integer], strng, start, end); + s = p.start; + e = p.end; + } + while (s < e && + ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) { + s++; + } + if (s >= e) { + if (junk_allowed != ECL_NIL) { + @(return ECL_NIL ecl_make_fixnum(s)); + } + else { + goto CANNOT_PARSE; + } + } + x = ecl_parse_integer(strng, s, e, &ep, ecl_fixnum(radix)); + if (x == OBJNULL) { + if (junk_allowed != ECL_NIL) { + @(return ECL_NIL ecl_make_fixnum(ep)); + } else { + goto CANNOT_PARSE; + } + } + if (junk_allowed != ECL_NIL) { + @(return x ecl_make_fixnum(ep)); + } + for (s = ep; s < e; s++) { + unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) + != cat_whitespace) { - FEerror("~S is an illegal radix.", 1, radix); + CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", + ECL_NIL, 1, strng); } - { - cl_index_pair p = - ecl_vector_start_end(@[parse-integer], strng, start, end); - s = p.start; - e = p.end; - } - while (s < e && - ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) { - s++; - } - if (s >= e) { - if (junk_allowed != ECL_NIL) - @(return ECL_NIL ecl_make_fixnum(s)) - else - goto CANNOT_PARSE; - } - x = ecl_parse_integer(strng, s, e, &ep, ecl_fixnum(radix)); - if (x == OBJNULL) { - if (junk_allowed != ECL_NIL) { - @(return ECL_NIL ecl_make_fixnum(ep)); - } else { - goto CANNOT_PARSE; - } - } - if (junk_allowed != ECL_NIL) { - @(return x ecl_make_fixnum(ep)); - } - for (s = ep; s < e; s++) { - unlikely_if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) - != cat_whitespace) - { -CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", - ECL_NIL, 1, strng); - } - } - @(return x ecl_make_fixnum(e)); -} @) + } + @(return x ecl_make_fixnum(e)); + } @) diff --git a/src/c/reader/parse_number.d b/src/c/reader/parse_number.d index a0a8b79d5..5eee3e7a3 100644 --- a/src/c/reader/parse_number.d +++ b/src/c/reader/parse_number.d @@ -1,227 +1,224 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include static bool exponent_charp(cl_fixnum c) { - return (c == 'e') || (c == 'E') || (c == 'f') || (c == 'F') || - (c == 's') || (c == 'S') || (c == 'd') || (c == 'D') || - (c == 'l') || (c == 'L'); + return (c == 'e') || (c == 'E') || (c == 'f') || (c == 'F') || + (c == 's') || (c == 'S') || (c == 'd') || (c == 'D') || + (c == 'l') || (c == 'L'); } static cl_object expt10(cl_index expt) { - cl_object accum = _ecl_big_register0(); - cl_object factor = _ecl_big_register1(); - _ecl_big_set_ui(accum, 1); - _ecl_big_set_ui(factor, 10); - for (; expt; expt >>= 1) { - if (expt & 1) { - _ecl_big_mul(accum, accum, factor); - } - _ecl_big_mul(factor, factor, factor); - } - _ecl_big_register_free(factor); - return _ecl_big_register_normalize(accum); + cl_object accum = _ecl_big_register0(); + cl_object factor = _ecl_big_register1(); + _ecl_big_set_ui(accum, 1); + _ecl_big_set_ui(factor, 10); + for (; expt; expt >>= 1) { + if (expt & 1) { + _ecl_big_mul(accum, accum, factor); + } + _ecl_big_mul(factor, factor, factor); + } + _ecl_big_register_free(factor); + return _ecl_big_register_normalize(accum); } static cl_object infinity(cl_index exp_char, int sign) { - cl_object var; - switch (exp_char) { - case 'e': case 'E': - return infinity(ecl_current_read_default_float_format(), sign); - case 's': case 'S': - case 'f': case 'F': - var = (sign<0)? - @'ext::single-float-negative-infinity' : - @'ext::single-float-positive-infinity'; - break; - case 'l': case 'L': + cl_object var; + switch (exp_char) { + case 'e': case 'E': + return infinity(ecl_current_read_default_float_format(), sign); + case 's': case 'S': + case 'f': case 'F': + var = (sign<0)? + @'ext::single-float-negative-infinity' : + @'ext::single-float-positive-infinity'; + break; + case 'l': case 'L': #ifdef ECL_LONG_FLOAT - var = (sign<0)? - @'ext::long-float-negative-infinity' : - @'ext::long-float-positive-infinity'; - break; + var = (sign<0)? + @'ext::long-float-negative-infinity' : + @'ext::long-float-positive-infinity'; + break; #endif - case 'd': case 'D': - var = (sign<0)? - @'ext::double-float-negative-infinity' : - @'ext::double-float-positive-infinity'; - break; - default: - return OBJNULL; - } - return ecl_symbol_value(var); + case 'd': case 'D': + var = (sign<0)? + @'ext::double-float-negative-infinity' : + @'ext::double-float-positive-infinity'; + break; + default: + return OBJNULL; + } + return ecl_symbol_value(var); } static cl_object make_float(cl_object num, cl_object exp, cl_index exp_char, int sign) { - if (!ECL_FIXNUMP(exp)) { - return infinity(exp_char, sign); - } else { - cl_fixnum fix_exp = ecl_fixnum(exp); - if (fix_exp > 0) { - num = ecl_times(num, expt10(fix_exp)); - } else if (fix_exp < 0) { - num = ecl_divide(num, expt10(-fix_exp)); - } - } + if (!ECL_FIXNUMP(exp)) { + return infinity(exp_char, sign); + } else { + cl_fixnum fix_exp = ecl_fixnum(exp); + if (fix_exp > 0) { + num = ecl_times(num, expt10(fix_exp)); + } else if (fix_exp < 0) { + num = ecl_divide(num, expt10(-fix_exp)); + } + } AGAIN: - switch (exp_char) { - case 'e': case 'E': - exp_char = ecl_current_read_default_float_format(); - goto AGAIN; - case 's': case 'S': - case 'f': case 'F': - return ecl_make_single_float(sign * ecl_to_double(num)); - case 'l': case 'L': + switch (exp_char) { + case 'e': case 'E': + exp_char = ecl_current_read_default_float_format(); + goto AGAIN; + case 's': case 'S': + case 'f': case 'F': + return ecl_make_single_float(sign * ecl_to_double(num)); + case 'l': case 'L': #ifdef ECL_LONG_FLOAT - return ecl_make_long_float(sign * ecl_to_long_double(num)); + return ecl_make_long_float(sign * ecl_to_long_double(num)); #endif - case 'd': case 'D': { - return ecl_make_double_float(sign * ecl_to_double(num)); - } - default: - return OBJNULL; - } + case 'd': case 'D': { + return ecl_make_double_float(sign * ecl_to_double(num)); + } + default: + return OBJNULL; + } } /* - ecl_parse_number(str, start, end, ep, radix) parses C string str - up to (but not including) str[end] - using radix as the radix for the rational number. - (For floating numbers, the radix is ignored and replaced with 10) - When parsing succeeds, - the index of the next character is assigned to *ep, - and the number is returned as a lisp data object. - If not, OBJNULL is returned. + ecl_parse_number(str, start, end, ep, radix) parses C string str + up to (but not including) str[end] + using radix as the radix for the rational number. + (For floating numbers, the radix is ignored and replaced with 10) + When parsing succeeds, + the index of the next character is assigned to *ep, + and the number is returned as a lisp data object. + If not, OBJNULL is returned. */ cl_object ecl_parse_number(cl_object str, cl_index start, cl_index end, cl_index *ep, unsigned int radix) { - int sign = -1, d; - cl_index c, i, decimal = end; - cl_object num = _ecl_big_register0(); - bool some_digit = 0; - if (end <= start || radix > 36) { - *ep = start; - return OBJNULL; - } + int sign = -1, d; + cl_index c, i, decimal = end; + cl_object num = _ecl_big_register0(); + bool some_digit = 0; + if (end <= start || radix > 36) { + *ep = start; + return OBJNULL; + } AGAIN: - _ecl_big_set_ui(num, 0); - c = ecl_char(str, i = start); - sign = 1; - if (c == '+') { - if (++i == end) goto NOT_A_NUMBER; - c = ecl_char(str, i); - } else if (c == '-') { - sign = -1; - if (++i == end) goto NOT_A_NUMBER; - c = ecl_char(str, i); - } - if (c == '/') { - goto NOT_A_NUMBER; - } - for (; i < end; i++) { - c = ecl_char(str, i); - if (c == '/') { - cl_object den; - if (sign < 0) _ecl_big_complement(num, num); - num = _ecl_big_register_normalize(num); - c = ecl_char(str, ++i); - if (ecl_digitp(c, radix) < 0) - goto NOT_A_NUMBER; - den = ecl_parse_integer(str, i, end, ep, radix); - if (den == OBJNULL || (*ep < end)) { - return OBJNULL; - } else if (den == ecl_make_fixnum(0)) { - return ECL_NIL; - } else { - return ecl_make_ratio(num, den); - } - } else if (c == '.') { - if (decimal <= i) { - goto NOT_A_NUMBER; - } - if (radix != 10) { - radix = 10; - goto AGAIN; - } - /* For a number xxxx.1234...nEyyy - * we have stored in num the number xxxx1234...n and - * will get in the exponent yyy. What we do is to simply - * shift the exponent by -n. */ - decimal = i+1; - } else if ((d = ecl_digitp(c, radix)) >= 0) { - _ecl_big_mul_ui(num, num, radix); - _ecl_big_add_ui(num, num, d); - some_digit = 1; - } else if (exponent_charp(c)) { - cl_object exp, decimals; - if (!some_digit) - goto NOT_A_NUMBER; - if (radix != 10) { - radix = 10; - goto AGAIN; - } - num = _ecl_big_register_normalize(num); - decimals = (decimal < i) ? - ecl_make_fixnum(decimal - i): - ecl_make_fixnum(0); - exp = ecl_parse_integer(str, ++i, end, ep, 10); - if (exp == OBJNULL || (*ep < end)) - return OBJNULL; - return make_float(num, ecl_plus(decimals, exp), - c, sign); - } else if (radix != 10) { - _ecl_big_register_free(num); - num = ecl_parse_number(str, start, end, ep, 10); - if (num != OBJNULL) { - if (floatp(num)) - return num; - if (ECL_FIXNUMP(num) || ECL_BIGNUMP(num)) { - i = *ep; - if (i > start && ecl_char(str, i-1) == '.') - return num; - } - } - return OBJNULL; - } else { - NOT_A_NUMBER: - *ep = i; - _ecl_big_register_free(num); - return OBJNULL; - } - } - /* If we have reached the end without decimals (for instance - * 1., 2, 13., etc) we return an integer */ - *ep = i; - if (decimal < i) { - if (!some_digit) goto NOT_A_NUMBER; - return make_float(_ecl_big_register_normalize(num), - ecl_make_fixnum(decimal - i), 'e', sign); - } else { - if (sign < 0) _ecl_big_complement(num, num); - return _ecl_big_register_normalize(num); + _ecl_big_set_ui(num, 0); + c = ecl_char(str, i = start); + sign = 1; + if (c == '+') { + if (++i == end) goto NOT_A_NUMBER; + c = ecl_char(str, i); + } else if (c == '-') { + sign = -1; + if (++i == end) goto NOT_A_NUMBER; + c = ecl_char(str, i); + } + if (c == '/') { + goto NOT_A_NUMBER; + } + for (; i < end; i++) { + c = ecl_char(str, i); + if (c == '/') { + cl_object den; + if (sign < 0) _ecl_big_complement(num, num); + num = _ecl_big_register_normalize(num); + c = ecl_char(str, ++i); + if (ecl_digitp(c, radix) < 0) + goto NOT_A_NUMBER; + den = ecl_parse_integer(str, i, end, ep, radix); + if (den == OBJNULL || (*ep < end)) { + return OBJNULL; + } else if (den == ecl_make_fixnum(0)) { + return ECL_NIL; + } else { + return ecl_make_ratio(num, den); + } + } else if (c == '.') { + if (decimal <= i) { + goto NOT_A_NUMBER; + } + if (radix != 10) { + radix = 10; + goto AGAIN; + } + /* For a number xxxx.1234...nEyyy + * we have stored in num the number xxxx1234...n and + * will get in the exponent yyy. What we do is to simply + * shift the exponent by -n. */ + decimal = i+1; + } else if ((d = ecl_digitp(c, radix)) >= 0) { + _ecl_big_mul_ui(num, num, radix); + _ecl_big_add_ui(num, num, d); + some_digit = 1; + } else if (exponent_charp(c)) { + cl_object exp, decimals; + if (!some_digit) + goto NOT_A_NUMBER; + if (radix != 10) { + radix = 10; + goto AGAIN; + } + num = _ecl_big_register_normalize(num); + decimals = (decimal < i) ? + ecl_make_fixnum(decimal - i): + ecl_make_fixnum(0); + exp = ecl_parse_integer(str, ++i, end, ep, 10); + if (exp == OBJNULL || (*ep < end)) + return OBJNULL; + return make_float(num, ecl_plus(decimals, exp), + c, sign); + } else if (radix != 10) { + _ecl_big_register_free(num); + num = ecl_parse_number(str, start, end, ep, 10); + if (num != OBJNULL) { + if (floatp(num)) + return num; + if (ECL_FIXNUMP(num) || ECL_BIGNUMP(num)) { + i = *ep; + if (i > start && ecl_char(str, i-1) == '.') + return num; } + } + return OBJNULL; + } else { + NOT_A_NUMBER: + *ep = i; + _ecl_big_register_free(num); + return OBJNULL; + } + } + /* If we have reached the end without decimals (for instance + * 1., 2, 13., etc) we return an integer */ + *ep = i; + if (decimal < i) { + if (!some_digit) goto NOT_A_NUMBER; + return make_float(_ecl_big_register_normalize(num), + ecl_make_fixnum(decimal - i), 'e', sign); + } else { + if (sign < 0) _ecl_big_complement(num, num); + return _ecl_big_register_normalize(num); + } } diff --git a/src/c/reference.d b/src/c/reference.d index d47adc40d..5b53c8da3 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -1,174 +1,167 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - reference.c -- Reference in Constants and Variables. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * reference.d - reference in Constants and Variables + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include #include -/* - Symbol-function returns - function-closure for function - (macro . function-closure) for macros - special for special forms. -*/ +/* Symbol-function returns */ +/* function-closure for function */ +/* (macro . function-closure) for macros */ +/* special for special forms. */ cl_object cl_symbol_function(cl_object sym) { - cl_object output; - int type = ecl_symbol_type(sym); - if (type & ecl_stp_special_form) { - output = @'special'; - } else if (Null(sym) || (ECL_SYM_FUN(sym) == ECL_NIL)) { - FEundefined_function(sym); - } else if (type & ecl_stp_macro) { - output = CONS(@'si::macro', ECL_SYM_FUN(sym)); - } else { - output = ECL_SYM_FUN(sym); - } - @(return output) + cl_object output; + int type = ecl_symbol_type(sym); + if (type & ecl_stp_special_form) { + output = @'special'; + } else if (Null(sym) || (ECL_SYM_FUN(sym) == ECL_NIL)) { + FEundefined_function(sym); + } else if (type & ecl_stp_macro) { + output = CONS(@'si::macro', ECL_SYM_FUN(sym)); + } else { + output = ECL_SYM_FUN(sym); + } + @(return output); } cl_object cl_fdefinition(cl_object fname) { - @(return ((ECL_SYMBOLP(fname))? cl_symbol_function(fname) : ecl_fdefinition(fname))) + @(return ((ECL_SYMBOLP(fname))? cl_symbol_function(fname) : ecl_fdefinition(fname))); } cl_object cl_fboundp(cl_object fname) { - if (Null(fname)) { - @(return ECL_NIL); - } else if (ECL_SYMBOLP(fname)) { - @(return (((fname->symbol.stype & ecl_stp_special_form) - || ECL_SYM_FUN(fname) != ECL_NIL)? ECL_T : ECL_NIL)) - } else if (LISTP(fname)) { - if (CAR(fname) == @'setf') { - cl_object sym = CDR(fname); - if (CONSP(sym) && CDR(sym) == ECL_NIL) { - cl_object pair; - sym = CAR(sym); - if (ECL_SYMBOLP(sym)) { - pair = ecl_setf_definition(sym, ECL_NIL); - @(return ecl_cdr(pair)); - } - } - } + if (Null(fname)) { + @(return ECL_NIL); + } else if (ECL_SYMBOLP(fname)) { + @(return (((fname->symbol.stype & ecl_stp_special_form) + || ECL_SYM_FUN(fname) != ECL_NIL)? ECL_T : ECL_NIL)); + } else if (LISTP(fname)) { + if (CAR(fname) == @'setf') { + cl_object sym = CDR(fname); + if (CONSP(sym) && CDR(sym) == ECL_NIL) { + cl_object pair; + sym = CAR(sym); + if (ECL_SYMBOLP(sym)) { + pair = ecl_setf_definition(sym, ECL_NIL); + @(return ecl_cdr(pair)); } - FEinvalid_function_name(fname); + } + } + } + FEinvalid_function_name(fname); } cl_object ecl_fdefinition(cl_object fun) { - cl_type t = ecl_t_of(fun); - cl_object output; + cl_type t = ecl_t_of(fun); + cl_object output; - if (t == t_symbol) { - output = ECL_SYM_FUN(fun); - unlikely_if (output == ECL_NIL) - FEundefined_function(fun); - unlikely_if (fun->symbol.stype & (ecl_stp_macro | ecl_stp_special_form)) - FEundefined_function(fun); - } else unlikely_if (Null(fun)) { - FEundefined_function(fun); - } else if (t == t_list) { - cl_object sym = CDR(fun); - unlikely_if (!CONSP(sym)) - FEinvalid_function_name(fun); - if (CAR(fun) == @'setf') { - unlikely_if (CDR(sym) != ECL_NIL) - FEinvalid_function_name(fun); - sym = CAR(sym); - unlikely_if (ecl_t_of(sym) != t_symbol) - FEinvalid_function_name(fun); - output = ecl_setf_definition(sym, ECL_NIL); - unlikely_if (Null(ecl_cdr(output))) - FEundefined_function(fun); - output = ECL_CONS_CAR(output); - } else if (CAR(fun) == @'lambda') { - return si_make_lambda(ECL_NIL, sym); - } else if (CAR(fun) == @'ext::lambda-block') { - return si_make_lambda(CAR(sym), CDR(sym)); - } else { - FEinvalid_function_name(fun); - } - } else { - FEinvalid_function_name(fun); - } - return output; + if (t == t_symbol) { + output = ECL_SYM_FUN(fun); + unlikely_if (output == ECL_NIL) + FEundefined_function(fun); + unlikely_if (fun->symbol.stype & (ecl_stp_macro | ecl_stp_special_form)) + FEundefined_function(fun); + } else unlikely_if (Null(fun)) { + FEundefined_function(fun); + } else if (t == t_list) { + cl_object sym = CDR(fun); + unlikely_if (!CONSP(sym)) + FEinvalid_function_name(fun); + if (CAR(fun) == @'setf') { + unlikely_if (CDR(sym) != ECL_NIL) + FEinvalid_function_name(fun); + sym = CAR(sym); + unlikely_if (ecl_t_of(sym) != t_symbol) + FEinvalid_function_name(fun); + output = ecl_setf_definition(sym, ECL_NIL); + unlikely_if (Null(ecl_cdr(output))) + FEundefined_function(fun); + output = ECL_CONS_CAR(output); + } else if (CAR(fun) == @'lambda') { + return si_make_lambda(ECL_NIL, sym); + } else if (CAR(fun) == @'ext::lambda-block') { + return si_make_lambda(CAR(sym), CDR(sym)); + } else { + FEinvalid_function_name(fun); + } + } else { + FEinvalid_function_name(fun); + } + return output; } cl_object si_coerce_to_function(cl_object fun) { - cl_type t = ecl_t_of(fun); - if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure - || t == t_bytecodes || t == t_bclosure - || (t == t_instance && fun->instance.isgf))) { - fun = ecl_fdefinition(fun); - } - @(return fun) + cl_type t = ecl_t_of(fun); + if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure + || t == t_bytecodes || t == t_bclosure + || (t == t_instance && fun->instance.isgf))) { + fun = ecl_fdefinition(fun); + } + @(return fun); } cl_object cl_symbol_value(cl_object sym) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object value; - if (Null(sym)) { - value = sym; - } else { - if (ecl_unlikely(!ECL_SYMBOLP(sym))) { - FEwrong_type_only_arg(@[symbol-value], sym, @[symbol]); - } - value = ECL_SYM_VAL(the_env, sym); - if (ecl_unlikely(value == OBJNULL)) { - FEunbound_variable(sym); - } - } - @(return value) + const cl_env_ptr the_env = ecl_process_env(); + cl_object value; + if (Null(sym)) { + value = sym; + } else { + if (ecl_unlikely(!ECL_SYMBOLP(sym))) { + FEwrong_type_only_arg(@[symbol-value], sym, @[symbol]); + } + value = ECL_SYM_VAL(the_env, sym); + if (ecl_unlikely(value == OBJNULL)) { + FEunbound_variable(sym); + } + } + @(return value); } bool ecl_boundp(cl_env_ptr env, cl_object sym) { - if (Null(sym)) { - return 1; - } else { - if (ecl_unlikely(!ECL_SYMBOLP(sym))) - FEwrong_type_only_arg(@[boundp], sym, @[symbol]); - return ECL_SYM_VAL(env, sym) != OBJNULL; - } + if (Null(sym)) { + return 1; + } else { + if (ecl_unlikely(!ECL_SYMBOLP(sym))) + FEwrong_type_only_arg(@[boundp], sym, @[symbol]); + return ECL_SYM_VAL(env, sym) != OBJNULL; + } } cl_object cl_boundp(cl_object sym) { - const cl_env_ptr the_env = ecl_process_env(); - ecl_return1(the_env, ecl_boundp(the_env,sym)? ECL_T : ECL_NIL); + const cl_env_ptr the_env = ecl_process_env(); + ecl_return1(the_env, ecl_boundp(the_env,sym)? ECL_T : ECL_NIL); } cl_object cl_special_operator_p(cl_object form) { - const cl_env_ptr the_env = ecl_process_env(); - int special = ecl_symbol_type(form) & ecl_stp_special_form; - ecl_return1(the_env, special? ECL_T : ECL_NIL); + const cl_env_ptr the_env = ecl_process_env(); + int special = ecl_symbol_type(form) & ecl_stp_special_form; + ecl_return1(the_env, special? ECL_T : ECL_NIL); } diff --git a/src/c/sequence.d b/src/c/sequence.d index b6e09bf54..a39d27608 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sequence.d -- Sequence routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * sequence.d - sequence routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,278 +21,278 @@ cl_index_pair ecl_sequence_start_end(cl_object fun, cl_object sequence, cl_object start, cl_object end) { - cl_index_pair p; - cl_index l; - p.length = l = ecl_length(sequence); - unlikely_if (!ECL_FIXNUMP(start) || ecl_fixnum_minusp(start)) { - FEwrong_type_key_arg(fun, @[:start], start, @[unsigned-byte]); - } - p.start = ecl_fixnum(start); - if (Null(end)) { - p.end = l; - } else { - unlikely_if (!ECL_FIXNUMP(end) || ecl_fixnum_minusp(end)) { - FEwrong_type_key_arg(fun, @[:end], end, - ecl_read_from_cstring("(OR NULL UNSIGNED-BYTE)")); - } - p.end = ecl_fixnum(end); - unlikely_if (p.end > l) { - cl_object fillp = ecl_make_fixnum(l); - FEwrong_type_key_arg(fun, @[:end], end, - ecl_make_integer_type(start, fillp)); - } - } - unlikely_if (p.end < p.start) { - FEwrong_type_key_arg(fun, @[:start], start, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(p.end))); - } - return p; + cl_index_pair p; + cl_index l; + p.length = l = ecl_length(sequence); + unlikely_if (!ECL_FIXNUMP(start) || ecl_fixnum_minusp(start)) { + FEwrong_type_key_arg(fun, @[:start], start, @[unsigned-byte]); + } + p.start = ecl_fixnum(start); + if (Null(end)) { + p.end = l; + } else { + unlikely_if (!ECL_FIXNUMP(end) || ecl_fixnum_minusp(end)) { + FEwrong_type_key_arg(fun, @[:end], end, + ecl_read_from_cstring("(OR NULL UNSIGNED-BYTE)")); + } + p.end = ecl_fixnum(end); + unlikely_if (p.end > l) { + cl_object fillp = ecl_make_fixnum(l); + FEwrong_type_key_arg(fun, @[:end], end, + ecl_make_integer_type(start, fillp)); + } + } + unlikely_if (p.end < p.start) { + FEwrong_type_key_arg(fun, @[:start], start, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(p.end))); + } + return p; } cl_object si_sequence_start_end(cl_object fun, cl_object sequence, cl_object start, cl_object end) { - cl_index_pair p = ecl_sequence_start_end(fun, sequence, start, end); - @(return ecl_make_fixnum(p.start) ecl_make_fixnum(p.end) - ecl_make_fixnum(p.length)); + cl_index_pair p = ecl_sequence_start_end(fun, sequence, start, end); + @(return ecl_make_fixnum(p.start) ecl_make_fixnum(p.end) + ecl_make_fixnum(p.length)); } cl_object cl_elt(cl_object x, cl_object i) { - @(return ecl_elt(x, ecl_to_size(i))) + @(return ecl_elt(x, ecl_to_size(i))); } cl_object ecl_elt(cl_object seq, cl_fixnum index) { - cl_fixnum i; - cl_object l; + cl_fixnum i; + cl_object l; - if (index < 0) - goto E; - switch (ecl_t_of(seq)) { - case t_list: - for (i = index, l = seq; i > 0; --i) { - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - l = ECL_CONS_CDR(l); - } - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - return ECL_CONS_CAR(l); + if (index < 0) + goto E; + switch (ecl_t_of(seq)) { + case t_list: + for (i = index, l = seq; i > 0; --i) { + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + l = ECL_CONS_CDR(l); + } + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + return ECL_CONS_CAR(l); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: - if (index >= seq->vector.fillp) goto E; - return ecl_aref_unsafe(seq, index); - default: - E0: - FEtype_error_sequence(seq); - } -E: - FEtype_error_index(seq, index); + case t_vector: + case t_bitvector: + case t_base_string: + if (index >= seq->vector.fillp) goto E; + return ecl_aref_unsafe(seq, index); + default: + E0: + FEtype_error_sequence(seq); + } + E: + FEtype_error_index(seq, index); } cl_object si_elt_set(cl_object seq, cl_object index, cl_object val) { - @(return ecl_elt_set(seq, ecl_to_size(index), val)) + @(return ecl_elt_set(seq, ecl_to_size(index), val)); } cl_object ecl_elt_set(cl_object seq, cl_fixnum index, cl_object val) { - cl_fixnum i; - cl_object l; + cl_fixnum i; + cl_object l; - if (index < 0) - goto E; - switch (ecl_t_of(seq)) { - case t_list: - for (i = index, l = seq; i > 0; --i) { - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - l = ECL_CONS_CDR(l); - } - if (!LISTP(l)) goto E0; - if (Null(l)) goto E; - ECL_RPLACA(l, val); - return val; + if (index < 0) + goto E; + switch (ecl_t_of(seq)) { + case t_list: + for (i = index, l = seq; i > 0; --i) { + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + l = ECL_CONS_CDR(l); + } + if (!LISTP(l)) goto E0; + if (Null(l)) goto E; + ECL_RPLACA(l, val); + return val; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: - if (index >= seq->vector.fillp) goto E; - return ecl_aset_unsafe(seq, index, val); - default: - E0: - FEtype_error_sequence(seq); - } -E: - FEtype_error_index(seq, index); + case t_vector: + case t_bitvector: + case t_base_string: + if (index >= seq->vector.fillp) goto E; + return ecl_aset_unsafe(seq, index, val); + default: + E0: + FEtype_error_sequence(seq); + } + E: + FEtype_error_index(seq, index); } cl_object ecl_subseq(cl_object sequence, cl_index start, cl_index limit) { - switch (ecl_t_of(sequence)) { - case t_list: - if (start) - sequence = ecl_nthcdr(start, sequence); - { - cl_object x = ECL_NIL; - cl_object *z = &x; - while (!Null(sequence) && (limit--)) { - if (ECL_ATOM(sequence)) - FEtype_error_cons(sequence); - z = &ECL_CONS_CDR(*z = ecl_list1(ECL_CONS_CAR(sequence))); - sequence = ECL_CONS_CDR(sequence); - } - return x; - } + switch (ecl_t_of(sequence)) { + case t_list: + if (start) + sequence = ecl_nthcdr(start, sequence); + { + cl_object x = ECL_NIL; + cl_object *z = &x; + while (!Null(sequence) && (limit--)) { + if (ECL_ATOM(sequence)) + FEtype_error_cons(sequence); + z = &ECL_CONS_CDR(*z = ecl_list1(ECL_CONS_CAR(sequence))); + sequence = ECL_CONS_CDR(sequence); + } + return x; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: { - cl_index size; - cl_object x; - if (start > sequence->vector.fillp) { - x = ecl_alloc_simple_vector(0, ecl_array_elttype(sequence)); - } else { - size = sequence->vector.fillp - start; - if (size > limit) - size = limit; - x = ecl_alloc_simple_vector(size, ecl_array_elttype(sequence)); - ecl_copy_subarray(x, 0, sequence, start, size); - } - return x; - } - default: - FEtype_error_sequence(sequence); - } + case t_vector: + case t_bitvector: + case t_base_string: { + cl_index size; + cl_object x; + if (start > sequence->vector.fillp) { + x = ecl_alloc_simple_vector(0, ecl_array_elttype(sequence)); + } else { + size = sequence->vector.fillp - start; + if (size > limit) + size = limit; + x = ecl_alloc_simple_vector(size, ecl_array_elttype(sequence)); + ecl_copy_subarray(x, 0, sequence, start, size); + } + return x; + } + default: + FEtype_error_sequence(sequence); + } } cl_object ecl_copy_seq(cl_object sequence) { - return ecl_subseq(sequence, 0, MOST_POSITIVE_FIXNUM); + return ecl_subseq(sequence, 0, MOST_POSITIVE_FIXNUM); } @(defun subseq (sequence start &optional end &aux x) - cl_index_pair p; -@ - p = ecl_sequence_start_end(@[subseq], sequence, start, end); - sequence = ecl_subseq(sequence, p.start, p.end - p.start); - @(return sequence); -@) + cl_index_pair p; + @ + p = ecl_sequence_start_end(@[subseq], sequence, start, end); + sequence = ecl_subseq(sequence, p.start, p.end - p.start); + @(return sequence); + @) cl_object cl_copy_seq(cl_object x) { - @(return ecl_subseq(x, 0, MOST_POSITIVE_FIXNUM)); + @(return ecl_subseq(x, 0, MOST_POSITIVE_FIXNUM)); } cl_object cl_length(cl_object x) { - @(return ecl_make_fixnum(ecl_length(x))) + @(return ecl_make_fixnum(ecl_length(x))); } cl_fixnum ecl_length(cl_object x) { - cl_fixnum i; + cl_fixnum i; - switch (ecl_t_of(x)) { - case t_list: - /* INV: A list's length always fits in a fixnum */ - i = 0; - loop_for_in(x) { - i++; - } end_loop_for_in; - return(i); + switch (ecl_t_of(x)) { + case t_list: + /* INV: A list's length always fits in a fixnum */ + i = 0; + loop_for_in(x) { + i++; + } end_loop_for_in; + return(i); #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_base_string: - case t_bitvector: - return(x->vector.fillp); + case t_vector: + case t_base_string: + case t_bitvector: + return(x->vector.fillp); - default: - FEtype_error_sequence(x); - } + default: + FEtype_error_sequence(x); + } } cl_object cl_reverse(cl_object seq) { - cl_object output, x; + cl_object output, x; - switch (ecl_t_of(seq)) { - case t_list: { - for (x = seq, output = ECL_NIL; !Null(x); x = ECL_CONS_CDR(x)) { - if (!LISTP(x)) goto E; - output = CONS(ECL_CONS_CAR(x), output); - } - break; - } + switch (ecl_t_of(seq)) { + case t_list: { + for (x = seq, output = ECL_NIL; !Null(x); x = ECL_CONS_CDR(x)) { + if (!LISTP(x)) goto E; + output = CONS(ECL_CONS_CAR(x), output); + } + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: - output = ecl_alloc_simple_vector(seq->vector.fillp, ecl_array_elttype(seq)); - ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp); - ecl_reverse_subarray(output, 0, seq->vector.fillp); - break; - default: - E: - FEtype_error_sequence(seq); - } - @(return output) + case t_vector: + case t_bitvector: + case t_base_string: + output = ecl_alloc_simple_vector(seq->vector.fillp, ecl_array_elttype(seq)); + ecl_copy_subarray(output, 0, seq, 0, seq->vector.fillp); + ecl_reverse_subarray(output, 0, seq->vector.fillp); + break; + default: + E: + FEtype_error_sequence(seq); + } + @(return output); } cl_object cl_nreverse(cl_object seq) { - switch (ecl_t_of(seq)) { - case t_list: { - cl_object x, y, z; - for (x = seq, y = ECL_NIL; !Null(x); ) { - if (!LISTP(x)) FEtype_error_list(x); - z = x; - x = ECL_CONS_CDR(x); - if (x == seq) FEcircular_list(seq); - ECL_RPLACD(z, y); - y = z; - } - seq = y; - break; - } + switch (ecl_t_of(seq)) { + case t_list: { + cl_object x, y, z; + for (x = seq, y = ECL_NIL; !Null(x); ) { + if (!LISTP(x)) FEtype_error_list(x); + z = x; + x = ECL_CONS_CDR(x); + if (x == seq) FEcircular_list(seq); + ECL_RPLACD(z, y); + y = z; + } + seq = y; + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_base_string: - case t_bitvector: - ecl_reverse_subarray(seq, 0, seq->vector.fillp); - break; - default: - FEtype_error_sequence(seq); - } - @(return seq) + case t_vector: + case t_base_string: + case t_bitvector: + ecl_reverse_subarray(seq, 0, seq->vector.fillp); + break; + default: + FEtype_error_sequence(seq); + } + @(return seq); } diff --git a/src/c/serialize.d b/src/c/serialize.d index 34c55bc8c..b0112bfd7 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - serialize.d -- Serialize a bunch of lisp data. -*/ -/* - Copyright (c) 2010, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * serialize.d - serialize a bunch of lisp data + * + * Copyright (c) 2010 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -21,128 +16,128 @@ #include struct fake_package { - _ECL_HDR; - cl_object name; + _ECL_HDR; + cl_object name; }; struct fake_symbol { - _ECL_HDR; - cl_object name; - cl_object pack; + _ECL_HDR; + cl_object name; + cl_object pack; }; -#define ROUND_TO_WORD(int) \ - ((int + sizeof(cl_fixnum) - 1) & ~(sizeof(cl_fixnum) - 1)) -#define ROUNDED_SIZE(name) \ - ROUND_TO_WORD(sizeof(struct name)) +#define ROUND_TO_WORD(int) \ + ((int + sizeof(cl_fixnum) - 1) & ~(sizeof(cl_fixnum) - 1)) +#define ROUNDED_SIZE(name) \ + ROUND_TO_WORD(sizeof(struct name)) static cl_index object_size[] = { - 0, /* t_start */ - ROUNDED_SIZE(ecl_cons), /* t_list */ - 0, /* t_character = 2 */ - 0, /* t_fixnum = 3 */ - ROUNDED_SIZE(ecl_bignum), /* t_bignum = 4 */ - ROUNDED_SIZE(ecl_ratio), /* t_ratio */ - ROUNDED_SIZE(ecl_singlefloat), /* t_singlefloat */ - ROUNDED_SIZE(ecl_doublefloat), /* t_doublefloat */ + 0, /* t_start */ + ROUNDED_SIZE(ecl_cons), /* t_list */ + 0, /* t_character = 2 */ + 0, /* t_fixnum = 3 */ + ROUNDED_SIZE(ecl_bignum), /* t_bignum = 4 */ + ROUNDED_SIZE(ecl_ratio), /* t_ratio */ + ROUNDED_SIZE(ecl_singlefloat), /* t_singlefloat */ + ROUNDED_SIZE(ecl_doublefloat), /* t_doublefloat */ #ifdef ECL_LONG_FLOAT - ROUNDED_SIZE(ecl_long_float), /* t_longfloat */ + ROUNDED_SIZE(ecl_long_float), /* t_longfloat */ #endif - ROUNDED_SIZE(ecl_complex), /* t_complex */ - ROUNDED_SIZE(fake_symbol), /* t_symbol */ - ROUNDED_SIZE(fake_package), /* t_package */ - ROUNDED_SIZE(ecl_hashtable), /* t_hashtable */ - ROUNDED_SIZE(ecl_array), /* t_array */ - ROUNDED_SIZE(ecl_vector), /* t_vector */ + ROUNDED_SIZE(ecl_complex), /* t_complex */ + ROUNDED_SIZE(fake_symbol), /* t_symbol */ + ROUNDED_SIZE(fake_package), /* t_package */ + ROUNDED_SIZE(ecl_hashtable), /* t_hashtable */ + ROUNDED_SIZE(ecl_array), /* t_array */ + ROUNDED_SIZE(ecl_vector), /* t_vector */ #ifdef ECL_UNICODE - ROUNDED_SIZE(ecl_string), /* t_string */ + ROUNDED_SIZE(ecl_string), /* t_string */ #endif - ROUNDED_SIZE(ecl_base_string), /* t_base_string */ - ROUNDED_SIZE(ecl_vector), /* t_bitvector */ - ROUNDED_SIZE(ecl_stream), /* t_stream */ - ROUNDED_SIZE(ecl_random), /* t_random */ - ROUNDED_SIZE(ecl_readtable), /* t_readtable */ - ROUNDED_SIZE(ecl_pathname), /* t_pathname */ - ROUNDED_SIZE(ecl_bytecodes), /* t_bytecodes */ - ROUNDED_SIZE(ecl_bclosure), /* t_bclosure */ - ROUNDED_SIZE(ecl_cfun), /* t_cfun */ - ROUNDED_SIZE(ecl_cfunfixed), /* t_cfunfixed */ - ROUNDED_SIZE(ecl_cclosure), /* t_cclosure */ - ROUNDED_SIZE(ecl_instance), /* t_instance */ + ROUNDED_SIZE(ecl_base_string), /* t_base_string */ + ROUNDED_SIZE(ecl_vector), /* t_bitvector */ + ROUNDED_SIZE(ecl_stream), /* t_stream */ + ROUNDED_SIZE(ecl_random), /* t_random */ + ROUNDED_SIZE(ecl_readtable), /* t_readtable */ + ROUNDED_SIZE(ecl_pathname), /* t_pathname */ + ROUNDED_SIZE(ecl_bytecodes), /* t_bytecodes */ + ROUNDED_SIZE(ecl_bclosure), /* t_bclosure */ + ROUNDED_SIZE(ecl_cfun), /* t_cfun */ + ROUNDED_SIZE(ecl_cfunfixed), /* t_cfunfixed */ + ROUNDED_SIZE(ecl_cclosure), /* t_cclosure */ + ROUNDED_SIZE(ecl_instance), /* t_instance */ #ifdef ECL_THREADS - ROUNDED_SIZE(ecl_process), /* t_process */ - ROUNDED_SIZE(ecl_lock), /* t_lock */ - ROUNDED_SIZE(ecl_rwlock), /* t_rwlock */ - ROUNDED_SIZE(ecl_condition_variable), /* t_condition_variable */ - ROUNDED_SIZE(ecl_semaphore), /* t_semaphore */ - ROUNDED_SIZE(ecl_barrier), /* t_barrier */ - ROUNDED_SIZE(ecl_mailbox), /* t_mailbox */ + ROUNDED_SIZE(ecl_process), /* t_process */ + ROUNDED_SIZE(ecl_lock), /* t_lock */ + ROUNDED_SIZE(ecl_rwlock), /* t_rwlock */ + ROUNDED_SIZE(ecl_condition_variable), /* t_condition_variable */ + ROUNDED_SIZE(ecl_semaphore), /* t_semaphore */ + ROUNDED_SIZE(ecl_barrier), /* t_barrier */ + ROUNDED_SIZE(ecl_mailbox), /* t_mailbox */ #endif - ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ - ROUNDED_SIZE(ecl_foreign), /* t_foreign */ - ROUNDED_SIZE(ecl_frame), /* t_frame */ - ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ + ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ + ROUNDED_SIZE(ecl_foreign), /* t_foreign */ + ROUNDED_SIZE(ecl_frame), /* t_frame */ + ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ #ifdef ECL_SSE2 - , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ + , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ #endif }; typedef struct pool { - cl_object data; - cl_object hash; - cl_object queue; - cl_object last; + cl_object data; + cl_object hash; + cl_object queue; + cl_object last; } *pool_t; static cl_index alloc(pool_t pool, cl_index size) { - cl_index bytes = ROUND_TO_WORD(size); - cl_index fillp = pool->data->vector.fillp; - cl_index next_fillp = fillp + bytes; - if (next_fillp >= pool->data->vector.dim) { - cl_index new_dim = next_fillp + next_fillp / 2; - pool->data = _ecl_funcall3(@'adjust-array', pool->data, - ecl_make_fixnum(new_dim)); - } - pool->data->vector.fillp = next_fillp; - return fillp; + cl_index bytes = ROUND_TO_WORD(size); + cl_index fillp = pool->data->vector.fillp; + cl_index next_fillp = fillp + bytes; + if (next_fillp >= pool->data->vector.dim) { + cl_index new_dim = next_fillp + next_fillp / 2; + pool->data = _ecl_funcall3(@'adjust-array', pool->data, + ecl_make_fixnum(new_dim)); + } + pool->data->vector.fillp = next_fillp; + return fillp; } static cl_object fix_to_ptr(cl_object ptr) { - cl_fixnum i = (cl_fixnum)ptr; - return (cl_object)(i & ~ECL_IMMEDIATE_TAG); + cl_fixnum i = (cl_fixnum)ptr; + return (cl_object)(i & ~ECL_IMMEDIATE_TAG); } static cl_object enqueue(pool_t pool, cl_object what) { - cl_object record, index; - if (ECL_FIXNUMP(what) || ECL_CHARACTERP(what) || what == OBJNULL) { - return what; - } + cl_object record, index; + if (ECL_FIXNUMP(what) || ECL_CHARACTERP(what) || what == OBJNULL) { + return what; + } #ifdef ECL_SMALL_CONS - if (Null(what)) - return what; + if (Null(what)) + return what; #endif - index = ecl_gethash_safe(what, pool->hash, OBJNULL); - if (index == OBJNULL) { - cl_object cons; - index = ecl_make_fixnum(pool->hash->hash.entries); - ecl_sethash(what, pool->hash, index); - cons = ecl_cons(what, ECL_NIL); - ECL_RPLACD(pool->last, cons); - pool->last = cons; - } - return fix_to_ptr(index); + index = ecl_gethash_safe(what, pool->hash, OBJNULL); + if (index == OBJNULL) { + cl_object cons; + index = ecl_make_fixnum(pool->hash->hash.entries); + ecl_sethash(what, pool->hash, index); + cons = ecl_cons(what, ECL_NIL); + ECL_RPLACD(pool->last, cons); + pool->last = cons; + } + return fix_to_ptr(index); } #ifdef ECL_SMALL_CONS typedef struct { - _ECL_HDR; - cl_object car, cdr; + _ECL_HDR; + cl_object car, cdr; } large_cons; typedef large_cons *large_cons_ptr; #endif @@ -150,20 +145,20 @@ typedef large_cons *large_cons_ptr; static cl_index serialize_bits(pool_t pool, void *data, cl_index size) { - cl_index index = alloc(pool, size); - memcpy(pool->data->vector.self.b8 + index, data, size); - return index; + cl_index index = alloc(pool, size); + memcpy(pool->data->vector.self.b8 + index, data, size); + return index; } static void serialize_object_ptr(pool_t pool, cl_object *ptr, cl_index dim) { - cl_index index = serialize_bits(pool, ptr, dim*sizeof(cl_object)); - for (; dim; dim--, index += sizeof(cl_object)) { - cl_object *p = (cl_object *)(pool->data->vector.self.b8 + index); - *p = enqueue(pool, *p); - p++; - } + cl_index index = serialize_bits(pool, ptr, dim*sizeof(cl_object)); + for (; dim; dim--, index += sizeof(cl_object)) { + cl_object *p = (cl_object *)(pool->data->vector.self.b8 + index); + *p = enqueue(pool, *p); + p++; + } } static void serialize_vector(pool_t pool, cl_object v); @@ -171,422 +166,422 @@ static void serialize_vector(pool_t pool, cl_object v); static void serialize_displaced_vector(pool_t pool, cl_object v) { - cl_object disp = v->vector.displaced; - cl_object to = ECL_CONS_CAR(disp); - if (Null(to)) { - v->vector.displaced = ECL_NIL; - serialize_vector(pool, v); - } else { - cl_index index = v->vector.self.b8 - to->vector.self.b8; - v->vector.displaced = enqueue(pool, to); - v->vector.self.b8 = (uint8_t*)index; - } + cl_object disp = v->vector.displaced; + cl_object to = ECL_CONS_CAR(disp); + if (Null(to)) { + v->vector.displaced = ECL_NIL; + serialize_vector(pool, v); + } else { + cl_index index = v->vector.self.b8 - to->vector.self.b8; + v->vector.displaced = enqueue(pool, to); + v->vector.self.b8 = (uint8_t*)index; + } } static void serialize_vector(pool_t pool, cl_object v) { - if (!Null(v->vector.displaced)) { - serialize_displaced_vector(pool, v); - } else if (v->vector.elttype == ecl_aet_object) { - serialize_object_ptr(pool, v->vector.self.t, v->vector.dim); - } else { - serialize_bits(pool, v->vector.self.b8, - v->vector.dim * ecl_aet_size[v->vector.elttype]); - } + if (!Null(v->vector.displaced)) { + serialize_displaced_vector(pool, v); + } else if (v->vector.elttype == ecl_aet_object) { + serialize_object_ptr(pool, v->vector.self.t, v->vector.dim); + } else { + serialize_bits(pool, v->vector.self.b8, + v->vector.dim * ecl_aet_size[v->vector.elttype]); + } } static void serialize_array(pool_t pool, cl_object a) { - serialize_bits(pool, a->array.dims, sizeof(cl_index) * a->array.rank); - serialize_vector(pool, a); + serialize_bits(pool, a->array.dims, sizeof(cl_index) * a->array.rank); + serialize_vector(pool, a); } static void serialize_one(pool_t pool, cl_object what) { - cl_index bytes, index; - cl_object buffer; + cl_index bytes, index; + cl_object buffer; #ifdef ECL_SMALL_CONS - if (ECL_LISTP(what)) { - cl_index bytes = ROUND_TO_WORD(sizeof(large_cons)); - cl_index index = alloc(pool, bytes); - large_cons_ptr cons = - (large_cons_ptr)(pool->data->vector.self.b8 + index); - memset(cons, 0, bytes); - cons->t = t_list; - cons->car = enqueue(pool, ECL_CONS_CAR(what)); - cons->cdr = enqueue(pool, ECL_CONS_CDR(what)); - return; - } + if (ECL_LISTP(what)) { + cl_index bytes = ROUND_TO_WORD(sizeof(large_cons)); + cl_index index = alloc(pool, bytes); + large_cons_ptr cons = + (large_cons_ptr)(pool->data->vector.self.b8 + index); + memset(cons, 0, bytes); + cons->t = t_list; + cons->car = enqueue(pool, ECL_CONS_CAR(what)); + cons->cdr = enqueue(pool, ECL_CONS_CDR(what)); + return; + } #endif - bytes = object_size[what->d.t]; - index = alloc(pool, bytes); - buffer = (cl_object)(pool->data->vector.self.b8 + index); - memcpy(buffer, what, bytes); - switch (buffer->d.t) { - case t_singlefloat: - case t_doublefloat: + bytes = object_size[what->d.t]; + index = alloc(pool, bytes); + buffer = (cl_object)(pool->data->vector.self.b8 + index); + memcpy(buffer, what, bytes); + switch (buffer->d.t) { + case t_singlefloat: + case t_doublefloat: #ifdef ECL_LONG_FLOAT - case t_longfloat: + case t_longfloat: #endif - break; + break; #ifndef ECL_SMALL_CONS - case t_list: - buffer->cons.car = enqueue(pool, buffer->cons.car); - buffer->cons.cdr = enqueue(pool, buffer->cons.car); - break; + case t_list: + buffer->cons.car = enqueue(pool, buffer->cons.car); + buffer->cons.cdr = enqueue(pool, buffer->cons.car); + break; #endif - case t_bignum: { - cl_fixnum size = ECL_BIGNUM_SIZE(buffer); - cl_index dim = ((size < 0) ? (-size) : size); - cl_index bytes = dim * sizeof(mp_limb_t); - serialize_bits(pool, ECL_BIGNUM_LIMBS(buffer), bytes); - break; - } - case t_ratio: { - buffer->ratio.den = enqueue(pool, buffer->ratio.den); - buffer->ratio.num = enqueue(pool, buffer->ratio.num); - break; - } - case t_complex: { - buffer->complex.real = enqueue(pool, buffer->complex.real); - buffer->complex.imag = enqueue(pool, buffer->complex.imag); - break; - } + case t_bignum: { + cl_fixnum size = ECL_BIGNUM_SIZE(buffer); + cl_index dim = ((size < 0) ? (-size) : size); + cl_index bytes = dim * sizeof(mp_limb_t); + serialize_bits(pool, ECL_BIGNUM_LIMBS(buffer), bytes); + break; + } + case t_ratio: { + buffer->ratio.den = enqueue(pool, buffer->ratio.den); + buffer->ratio.num = enqueue(pool, buffer->ratio.num); + break; + } + case t_complex: { + buffer->complex.real = enqueue(pool, buffer->complex.real); + buffer->complex.imag = enqueue(pool, buffer->complex.imag); + break; + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_vector: - case t_bitvector: - case t_base_string: { - serialize_vector(pool, buffer); - break; - } - case t_array: { - cl_index bytes = ROUND_TO_WORD(buffer->array.rank * - sizeof(cl_index)); - serialize_bits(pool, buffer->array.dims, bytes); - serialize_vector(pool, buffer); - break; - } - case t_package: { - struct fake_package *p = (struct fake_package *)buffer; - p->name = enqueue(pool, what->pack.name); - break; - } - case t_symbol: { - struct fake_symbol *p = (struct fake_symbol *)buffer; - p->name = enqueue(pool, what->symbol.name); - p->pack = enqueue(pool, what->symbol.hpack); - break; - } - case t_pathname: - buffer->pathname.host = - enqueue(pool, buffer->pathname.host); - buffer->pathname.device = - enqueue(pool, buffer->pathname.device); - buffer->pathname.directory = - enqueue(pool, buffer->pathname.directory); - buffer->pathname.name = enqueue(pool, buffer->pathname.name); - buffer->pathname.type = enqueue(pool, buffer->pathname.type); - buffer->pathname.version = - enqueue(pool, buffer->pathname.version); - break; - case t_random: { - buffer->random.value = enqueue(pool, buffer->random.value); - break; - } - case t_bclosure: { - buffer->bclosure.code = enqueue(pool, buffer->bclosure.code); - buffer->bclosure.lex = enqueue(pool, buffer->bclosure.lex); - } - case t_bytecodes: { - buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name); - buffer->bytecodes.definition = enqueue(pool, buffer->bytecodes.definition); - buffer->bytecodes.data = enqueue(pool, buffer->bytecodes.data); - buffer->bytecodes.file = enqueue(pool, buffer->bytecodes.file); - buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position); - buffer->bytecodes.code = serialize_bits(pool, buffer->bytecodes.code, - buffer->bytecodes.code_size); - } - default: - FEerror("Unable to serialize object ~A", 1, what); - } + case t_vector: + case t_bitvector: + case t_base_string: { + serialize_vector(pool, buffer); + break; + } + case t_array: { + cl_index bytes = ROUND_TO_WORD(buffer->array.rank * + sizeof(cl_index)); + serialize_bits(pool, buffer->array.dims, bytes); + serialize_vector(pool, buffer); + break; + } + case t_package: { + struct fake_package *p = (struct fake_package *)buffer; + p->name = enqueue(pool, what->pack.name); + break; + } + case t_symbol: { + struct fake_symbol *p = (struct fake_symbol *)buffer; + p->name = enqueue(pool, what->symbol.name); + p->pack = enqueue(pool, what->symbol.hpack); + break; + } + case t_pathname: + buffer->pathname.host = + enqueue(pool, buffer->pathname.host); + buffer->pathname.device = + enqueue(pool, buffer->pathname.device); + buffer->pathname.directory = + enqueue(pool, buffer->pathname.directory); + buffer->pathname.name = enqueue(pool, buffer->pathname.name); + buffer->pathname.type = enqueue(pool, buffer->pathname.type); + buffer->pathname.version = + enqueue(pool, buffer->pathname.version); + break; + case t_random: { + buffer->random.value = enqueue(pool, buffer->random.value); + break; + } + case t_bclosure: { + buffer->bclosure.code = enqueue(pool, buffer->bclosure.code); + buffer->bclosure.lex = enqueue(pool, buffer->bclosure.lex); + } + case t_bytecodes: { + buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name); + buffer->bytecodes.definition = enqueue(pool, buffer->bytecodes.definition); + buffer->bytecodes.data = enqueue(pool, buffer->bytecodes.data); + buffer->bytecodes.file = enqueue(pool, buffer->bytecodes.file); + buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position); + buffer->bytecodes.code = serialize_bits(pool, buffer->bytecodes.code, + buffer->bytecodes.code_size); + } + default: + FEerror("Unable to serialize object ~A", 1, what); + } } static void init_pool(pool_t pool, cl_object root) { - pool->data = si_make_vector(@'ext::byte8', - ecl_make_fixnum(1024), - ECL_T, - ecl_make_fixnum(2 * sizeof(cl_index)), - ECL_NIL, - ecl_make_fixnum(0)); - pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256), - cl_core.rehash_size, - cl_core.rehash_threshold); - ecl_sethash(root, pool->hash, ecl_make_fixnum(0)); - pool->queue = ecl_list1(root); - pool->last = pool->queue; + pool->data = si_make_vector(@'ext::byte8', + ecl_make_fixnum(1024), + ECL_T, + ecl_make_fixnum(2 * sizeof(cl_index)), + ECL_NIL, + ecl_make_fixnum(0)); + pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256), + cl_core.rehash_size, + cl_core.rehash_threshold); + ecl_sethash(root, pool->hash, ecl_make_fixnum(0)); + pool->queue = ecl_list1(root); + pool->last = pool->queue; } static cl_object close_pool(pool_t pool) { - pool->data->vector.self.index[0] = pool->data->vector.fillp; - pool->data->vector.self.index[1] = pool->hash->hash.entries; - return pool->data; + pool->data->vector.self.index[0] = pool->data->vector.fillp; + pool->data->vector.self.index[1] = pool->hash->hash.entries; + return pool->data; } cl_object si_serialize(cl_object root) { - struct pool pool[1]; - init_pool(pool, root); - while (!Null(pool->queue)) { - cl_object what = ECL_CONS_CAR(pool->queue); - serialize_one(pool, what); - pool->queue = ECL_CONS_CDR(pool->queue); - } - @(return close_pool(pool)); + struct pool pool[1]; + init_pool(pool, root); + while (!Null(pool->queue)) { + cl_object what = ECL_CONS_CAR(pool->queue); + serialize_one(pool, what); + pool->queue = ECL_CONS_CDR(pool->queue); + } + @(return close_pool(pool)); } static void * reconstruct_bits(uint8_t *data, cl_index bytes) { - void *output = ecl_alloc_atomic(bytes); - memcpy(output, data, bytes); - return output; + void *output = ecl_alloc_atomic(bytes); + memcpy(output, data, bytes); + return output; } static void * reconstruct_object_ptr(uint8_t *data, cl_index bytes) { - void *output = ecl_alloc(bytes); - memcpy(output, data, bytes); - return output; + void *output = ecl_alloc(bytes); + memcpy(output, data, bytes); + return output; } static uint8_t * reconstruct_bytecodes(cl_object o, uint8_t *data) { - o->bytecodes.code = reconstruct_bits(data, o->bytecodes.code_size); - data += o->bytecodes.code_size; - return data; + o->bytecodes.code = reconstruct_bits(data, o->bytecodes.code_size); + data += o->bytecodes.code_size; + return data; } static uint8_t * reconstruct_vector(cl_object v, uint8_t *data) { - if (v->vector.displaced == ECL_NIL) { - cl_type t = v->vector.elttype; - cl_index size = v->vector.dim * ecl_aet_size[t]; - cl_index bytes = ROUND_TO_WORD(size); - if (t == ecl_aet_object) { - v->vector.self.t = reconstruct_object_ptr(data, bytes); - } else { - v->vector.self.t = reconstruct_bits(data, size); - } - data += bytes; - } - return data; + if (v->vector.displaced == ECL_NIL) { + cl_type t = v->vector.elttype; + cl_index size = v->vector.dim * ecl_aet_size[t]; + cl_index bytes = ROUND_TO_WORD(size); + if (t == ecl_aet_object) { + v->vector.self.t = reconstruct_object_ptr(data, bytes); + } else { + v->vector.self.t = reconstruct_bits(data, size); + } + data += bytes; + } + return data; } static uint8_t * reconstruct_array(cl_object a, uint8_t *data) { - cl_index bytes = ROUND_TO_WORD(a->array.rank * sizeof(cl_index)); - a->array.dims = reconstruct_bits(data, bytes); - return reconstruct_vector(a, data + bytes); + cl_index bytes = ROUND_TO_WORD(a->array.rank * sizeof(cl_index)); + a->array.dims = reconstruct_bits(data, bytes); + return reconstruct_vector(a, data + bytes); } static uint8_t * duplicate_object(uint8_t *data, cl_object *output) { - cl_type t = ((cl_object)data)->d.t; - cl_object o = ecl_alloc_object(t); - cl_index bytes = object_size[t]; - memcpy(o, data, bytes); - *output = o; - return data + bytes; + cl_type t = ((cl_object)data)->d.t; + cl_object o = ecl_alloc_object(t); + cl_index bytes = object_size[t]; + memcpy(o, data, bytes); + *output = o; + return data + bytes; } static uint8_t * reconstruct_one(uint8_t *data, cl_object *output) { - cl_object o = (cl_object)data; - switch (o->d.t) { + cl_object o = (cl_object)data; + switch (o->d.t) { #ifdef ECL_SMALL_CONS - case t_list: { - large_cons_ptr c = (large_cons_ptr)data; - *output = ecl_cons(c->car, c->cdr); - data += ROUND_TO_WORD(sizeof(large_cons)); - break; - } + case t_list: { + large_cons_ptr c = (large_cons_ptr)data; + *output = ecl_cons(c->car, c->cdr); + data += ROUND_TO_WORD(sizeof(large_cons)); + break; + } #endif #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - data = duplicate_object(data, output); - data = reconstruct_vector(*output, data); - break; - case t_array: - data = duplicate_object(data, output); - data = reconstruct_array(*output, data); - break; - case t_package: - *output = (cl_object)data; - data += ROUND_TO_WORD(sizeof(struct fake_package)); - break; - case t_symbol: - *output = (cl_object)data; - data += ROUND_TO_WORD(sizeof(struct fake_symbol)); - break; - case t_bytecodes: - data = duplicate_object(data, output); - data = reconstruct_bytecodes(*output, data); - default: - data = duplicate_object(data, output); - } - return data; + case t_base_string: + case t_vector: + case t_bitvector: + data = duplicate_object(data, output); + data = reconstruct_vector(*output, data); + break; + case t_array: + data = duplicate_object(data, output); + data = reconstruct_array(*output, data); + break; + case t_package: + *output = (cl_object)data; + data += ROUND_TO_WORD(sizeof(struct fake_package)); + break; + case t_symbol: + *output = (cl_object)data; + data += ROUND_TO_WORD(sizeof(struct fake_symbol)); + break; + case t_bytecodes: + data = duplicate_object(data, output); + data = reconstruct_bytecodes(*output, data); + default: + data = duplicate_object(data, output); + } + return data; } static cl_object get_object(cl_object o_or_index, cl_object *o_list) { - if (ECL_IMMEDIATE(o_or_index)) { - return o_or_index; - } else { - cl_index i = (cl_index)o_or_index >> 2; - return o_list[i]; - } + if (ECL_IMMEDIATE(o_or_index)) { + return o_or_index; + } else { + cl_index i = (cl_index)o_or_index >> 2; + return o_list[i]; + } } static void fixup_vector(cl_object v, cl_object *o_list) { - if (!ECL_IMMEDIATE(v->vector.displaced)) { - cl_object disp = get_object(v->vector.displaced, o_list); - cl_object to = ECL_CONS_CAR(disp); - if (to != ECL_NIL) { - cl_index offset = (cl_index)v->vector.self.b8; - v->vector.displaced = ECL_NIL; - ecl_displace(v, to, ecl_make_fixnum(offset)); - return; - } - } - if (v->vector.elttype == ecl_aet_object) { - cl_index i; - cl_object *p = v->vector.self.t; - for (i = v->vector.dim; i; i--, p++) { - *p = get_object(*p, o_list); - } - } + if (!ECL_IMMEDIATE(v->vector.displaced)) { + cl_object disp = get_object(v->vector.displaced, o_list); + cl_object to = ECL_CONS_CAR(disp); + if (to != ECL_NIL) { + cl_index offset = (cl_index)v->vector.self.b8; + v->vector.displaced = ECL_NIL; + ecl_displace(v, to, ecl_make_fixnum(offset)); + return; + } + } + if (v->vector.elttype == ecl_aet_object) { + cl_index i; + cl_object *p = v->vector.self.t; + for (i = v->vector.dim; i; i--, p++) { + *p = get_object(*p, o_list); + } + } } static void fixup(cl_object o, cl_object *o_list) { #ifdef ECL_SMALL_CONS - if (ECL_LISTP(o)) { - ECL_RPLACA(o, get_object(ECL_CONS_CAR(o), o_list)); - ECL_RPLACD(o, get_object(ECL_CONS_CDR(o), o_list)); - return; - } + if (ECL_LISTP(o)) { + ECL_RPLACA(o, get_object(ECL_CONS_CAR(o), o_list)); + ECL_RPLACD(o, get_object(ECL_CONS_CDR(o), o_list)); + return; + } #endif - switch (o->d.t) { - case t_ratio: - o->ratio.den = get_object(o->ratio.den, o_list); - o->ratio.num = get_object(o->ratio.num, o_list); - break; - case t_complex: - o->complex.real = get_object(o->complex.real, o_list); - o->complex.imag = get_object(o->complex.imag, o_list); - break; + switch (o->d.t) { + case t_ratio: + o->ratio.den = get_object(o->ratio.den, o_list); + o->ratio.num = get_object(o->ratio.num, o_list); + break; + case t_complex: + o->complex.real = get_object(o->complex.real, o_list); + o->complex.imag = get_object(o->complex.imag, o_list); + break; #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_vector: - case t_bitvector: - case t_array: - fixup_vector(o, o_list); - break; - case t_pathname: - o->pathname.host = get_object(o->pathname.host, o_list); - o->pathname.device = - get_object(o->pathname.device, o_list); - o->pathname.directory = - get_object(o->pathname.directory, o_list); - o->pathname.name = get_object(o->pathname.name, o_list); - o->pathname.type = get_object(o->pathname.type, o_list); - o->pathname.version = - get_object(o->pathname.version, o_list); - break; - case t_random: - o->random.value = get_object(o->random.value, o_list); - break; - case t_bclosure: - o->bclosure.code = get_object(o->bclosure.code, o_list); - o->bclosure.lex = get_object(o->bclosure.lex, o_list); - o->bclosure.entry = _ecl_bclosure_dispatch_vararg; - break; - case t_bytecodes: - o->bytecodes.name = get_object(o->bytecodes.name, o_list); - o->bytecodes.definition = get_object(o->bytecodes.definition, o_list); - o->bytecodes.data = get_object(o->bytecodes.data, o_list); - o->bytecodes.file = get_object(o->bytecodes.file, o_list); - o->bytecodes.file_position = get_object(o->bytecodes.file_position, o_list); - o->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; - break; - default: - break; - } + case t_base_string: + case t_vector: + case t_bitvector: + case t_array: + fixup_vector(o, o_list); + break; + case t_pathname: + o->pathname.host = get_object(o->pathname.host, o_list); + o->pathname.device = + get_object(o->pathname.device, o_list); + o->pathname.directory = + get_object(o->pathname.directory, o_list); + o->pathname.name = get_object(o->pathname.name, o_list); + o->pathname.type = get_object(o->pathname.type, o_list); + o->pathname.version = + get_object(o->pathname.version, o_list); + break; + case t_random: + o->random.value = get_object(o->random.value, o_list); + break; + case t_bclosure: + o->bclosure.code = get_object(o->bclosure.code, o_list); + o->bclosure.lex = get_object(o->bclosure.lex, o_list); + o->bclosure.entry = _ecl_bclosure_dispatch_vararg; + break; + case t_bytecodes: + o->bytecodes.name = get_object(o->bytecodes.name, o_list); + o->bytecodes.definition = get_object(o->bytecodes.definition, o_list); + o->bytecodes.data = get_object(o->bytecodes.data, o_list); + o->bytecodes.file = get_object(o->bytecodes.file, o_list); + o->bytecodes.file_position = get_object(o->bytecodes.file_position, o_list); + o->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; + break; + default: + break; + } } cl_object ecl_deserialize(uint8_t *raw) { - cl_index *data = (cl_index*)raw; - cl_index i, num_el = data[1]; - cl_object *output = ecl_alloc(sizeof(cl_object) * num_el); - raw += 2*sizeof(cl_index); - for (i = 0; i < num_el; i++) { - raw = reconstruct_one(raw, output+i); - } - for (i = 0; i < num_el; i++) { - cl_object package = output[i]; - if (!ECL_IMMEDIATE(package) && package->d.t == t_package) { - cl_object name = get_object(package->pack.name, - output); - output[i] = ecl_find_package_nolock(name); - } - } - for (i = 0; i < num_el; i++) { - cl_object symbol = output[i]; - if (!ECL_IMMEDIATE(symbol) && symbol->d.t == t_symbol) { - struct fake_symbol *s = (struct fake_symbol *)symbol; - cl_object name = get_object(s->name, output); - cl_object pack = get_object(s->pack, output); - int flag; - output[i] = ecl_intern(name, pack, &flag); - } - } - for (i = 0; i < num_el; i++) { - fixup(output[i], output); - } - return output[0]; + cl_index *data = (cl_index*)raw; + cl_index i, num_el = data[1]; + cl_object *output = ecl_alloc(sizeof(cl_object) * num_el); + raw += 2*sizeof(cl_index); + for (i = 0; i < num_el; i++) { + raw = reconstruct_one(raw, output+i); + } + for (i = 0; i < num_el; i++) { + cl_object package = output[i]; + if (!ECL_IMMEDIATE(package) && package->d.t == t_package) { + cl_object name = get_object(package->pack.name, + output); + output[i] = ecl_find_package_nolock(name); + } + } + for (i = 0; i < num_el; i++) { + cl_object symbol = output[i]; + if (!ECL_IMMEDIATE(symbol) && symbol->d.t == t_symbol) { + struct fake_symbol *s = (struct fake_symbol *)symbol; + cl_object name = get_object(s->name, output); + cl_object pack = get_object(s->pack, output); + int flag; + output[i] = ecl_intern(name, pack, &flag); + } + } + for (i = 0; i < num_el; i++) { + fixup(output[i], output); + } + return output[0]; } cl_object si_deserialize(cl_object data) { - @(return ecl_deserialize(data->vector.self.b8)) + @(return ecl_deserialize(data->vector.self.b8)); } diff --git a/src/c/sse2.d b/src/c/sse2.d index 9b4339d1c..8c7c10626 100644 --- a/src/c/sse2.d +++ b/src/c/sse2.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - sse2.c -- SSE2 vector type support -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * sse2.d - SSE2 vector type support + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -30,71 +25,71 @@ cl_object si_sse_pack_p(cl_object x) { - @(return (ECL_SSE_PACK_P(x) ? ECL_T : ECL_NIL)) + @(return (ECL_SSE_PACK_P(x) ? ECL_T : ECL_NIL)); } /* Element type substitution */ static void verify_sse_elttype(cl_elttype eltt) { - switch (eltt) { - case ecl_aet_sf: - case ecl_aet_df: - case ecl_aet_b8: - case ecl_aet_i8: + switch (eltt) { + case ecl_aet_sf: + case ecl_aet_df: + case ecl_aet_b8: + case ecl_aet_i8: #ifdef ecl_uint16_t - case ecl_aet_b16: - case ecl_aet_i16: + case ecl_aet_b16: + case ecl_aet_i16: #endif #ifdef ecl_uint32_t - case ecl_aet_b32: - case ecl_aet_i32: + case ecl_aet_b32: + case ecl_aet_i32: #endif #ifdef ecl_uint64_t - case ecl_aet_b64: - case ecl_aet_i64: + case ecl_aet_b64: + case ecl_aet_i64: #endif - break; /* OK */ - default: - FEerror("Invalid element type for an SSE pack: ~S", 1, ecl_elttype_to_symbol(eltt)); - } + break; /* OK */ + default: + FEerror("Invalid element type for an SSE pack: ~S", 1, ecl_elttype_to_symbol(eltt)); + } } static cl_elttype symbol_to_sse_elttype(cl_object type) { - cl_elttype eltt = ecl_symbol_to_elttype(type); - verify_sse_elttype(eltt); - return eltt; + cl_elttype eltt = ecl_symbol_to_elttype(type); + verify_sse_elttype(eltt); + return eltt; } cl_object si_sse_pack_as_elt_type(cl_object x, cl_object type) { - cl_elttype rtype; + cl_elttype rtype; - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { - FEwrong_type_nth_arg(@[ext::sse-pack-as-elt-type], 1, x, @[ext::sse-pack]); - } + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + FEwrong_type_nth_arg(@[ext::sse-pack-as-elt-type], 1, x, @[ext::sse-pack]); + } - rtype = symbol_to_sse_elttype(type); + rtype = symbol_to_sse_elttype(type); - if (x->sse.elttype != rtype) { - cl_object new = ecl_alloc_object(t_sse_pack); - new->sse.elttype = rtype; - new->sse.data.vi = x->sse.data.vi; - x = new; - } + if (x->sse.elttype != rtype) { + cl_object new = ecl_alloc_object(t_sse_pack); + new->sse.elttype = rtype; + new->sse.data.vi = x->sse.data.vi; + x = new; + } - @(return x) + @(return x); } cl_object si_sse_pack_element_type(cl_object x) { - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { - FEwrong_type_nth_arg(@[ext::sse-pack-element-type], 1, x, @[ext::sse-pack]); - } + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + FEwrong_type_nth_arg(@[ext::sse-pack-element-type], 1, x, @[ext::sse-pack]); + } - @(return ecl_elttype_to_symbol(x->sse.elttype) ecl_make_fixnum(x->sse.elttype)); + @(return ecl_elttype_to_symbol(x->sse.elttype) ecl_make_fixnum(x->sse.elttype)); } /* Conversion to and from specialized vectors */ @@ -102,42 +97,42 @@ si_sse_pack_element_type(cl_object x) cl_object si_sse_pack_to_vector(cl_object x, cl_object elt_type) { - cl_elttype etype; - cl_object vec; + cl_elttype etype; + cl_object vec; - if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { - FEwrong_type_nth_arg(@[ext::sse-pack-to-vector], 1, x, @[ext::sse-pack]); - } + if (ecl_unlikely(!ECL_SSE_PACK_P(x))) { + FEwrong_type_nth_arg(@[ext::sse-pack-to-vector], 1, x, @[ext::sse-pack]); + } - etype = x->sse.elttype; - if (elt_type != ECL_NIL) - etype = symbol_to_sse_elttype(elt_type); + etype = x->sse.elttype; + if (elt_type != ECL_NIL) + etype = symbol_to_sse_elttype(elt_type); - vec = ecl_alloc_simple_vector(16/ecl_aet_size[etype], etype); - memcpy(vec->vector.self.b8, x->sse.data.b8, 16); + vec = ecl_alloc_simple_vector(16/ecl_aet_size[etype], etype); + memcpy(vec->vector.self.b8, x->sse.data.b8, 16); - @(return vec) + @(return vec); } cl_object si_vector_to_sse_pack(cl_object x) { - cl_object ssev; + cl_object ssev; - if (ecl_unlikely(!ECL_ARRAYP(x))) { - FEwrong_type_nth_arg(@[ext::vector-to-sse-pack], 1, x, @[array]); - } + if (ecl_unlikely(!ECL_ARRAYP(x))) { + FEwrong_type_nth_arg(@[ext::vector-to-sse-pack], 1, x, @[array]); + } - verify_sse_elttype(x->vector.elttype); + verify_sse_elttype(x->vector.elttype); - if (ecl_unlikely(x->vector.dim * ecl_aet_size[x->vector.elttype] != 16)) - FEerror("Wrong vector size in VECTOR-TO-SSE-PACK: ~S",1,ecl_make_fixnum(x->vector.dim)); + if (ecl_unlikely(x->vector.dim * ecl_aet_size[x->vector.elttype] != 16)) + FEerror("Wrong vector size in VECTOR-TO-SSE-PACK: ~S",1,ecl_make_fixnum(x->vector.dim)); - ssev = ecl_alloc_object(t_sse_pack); - ssev->sse.elttype = x->vector.elttype; - memcpy(ssev->sse.data.b8, x->vector.self.b8, 16); + ssev = ecl_alloc_object(t_sse_pack); + ssev->sse.elttype = x->vector.elttype; + memcpy(ssev->sse.data.b8, x->vector.self.b8, 16); - @(return ssev) + @(return ssev); } /* Boxing and unboxing. @@ -147,58 +142,58 @@ si_vector_to_sse_pack(cl_object x) cl_object ecl_make_int_sse_pack(__m128i value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_b8; - obj->sse.data.vi = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_b8; + obj->sse.data.vi = value; + @(return obj); } __m128i ecl_unbox_int_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vi; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vi; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } cl_object ecl_make_float_sse_pack(__m128 value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_sf; - obj->sse.data.vf = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_sf; + obj->sse.data.vf = value; + @(return obj); } __m128 ecl_unbox_float_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vf; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vf; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } cl_object ecl_make_double_sse_pack(__m128d value) { - cl_object obj = ecl_alloc_object(t_sse_pack); - obj->sse.elttype = ecl_aet_df; - obj->sse.data.vd = value; - @(return obj); + cl_object obj = ecl_alloc_object(t_sse_pack); + obj->sse.elttype = ecl_aet_df; + obj->sse.data.vd = value; + @(return obj); } __m128d ecl_unbox_double_sse_pack(cl_object x) { - do { - if (ECL_SSE_PACK_P(x)) - return x->sse.data.vd; - x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); - } while(1); + do { + if (ECL_SSE_PACK_P(x)) + return x->sse.data.vd; + x = ecl_type_error(@'coerce', "variable", x, @'ext::sse-pack'); + } while(1); } -#endif // ECL_SSE2 +#endif /* ECL_SSE2 */ diff --git a/src/c/stacks.d b/src/c/stacks.d index dd8f615db..c8f6a2c13 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - stacks.c -- Binding/History/Frame stacks. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * stacks.d - binding/history/frame stacks + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -31,91 +26,91 @@ static void cs_set_size(cl_env_ptr env, cl_index new_size) { - volatile char foo = 0; - cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - env->cs_limit_size = new_size - 2*margin; + volatile char foo = 0; + cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + env->cs_limit_size = new_size - 2*margin; #ifdef ECL_DOWN_STACK - if (&foo > env->cs_org - new_size + 16) { - env->cs_limit = env->cs_org - new_size + 2*margin; - if (env->cs_limit < env->cs_barrier) - env->cs_barrier = env->cs_limit; - } + if (&foo > env->cs_org - new_size + 16) { + env->cs_limit = env->cs_org - new_size + 2*margin; + if (env->cs_limit < env->cs_barrier) + env->cs_barrier = env->cs_limit; + } #else - if (&foo < env->cs_org + new_size - 16) { - env->cs_limit = env->cs_org + new_size - 2*margin; - if (env->cs_limit > env->cs_barrier) - env->cs_barrier = env->cs_limit; - } + if (&foo < env->cs_org + new_size - 16) { + env->cs_limit = env->cs_org + new_size - 2*margin; + if (env->cs_limit > env->cs_barrier) + env->cs_barrier = env->cs_limit; + } #endif - else - ecl_internal_error("can't reset env->cs_limit."); - env->cs_size = new_size; + else + ecl_internal_error("can't reset env->cs_limit."); + env->cs_size = new_size; } void ecl_cs_overflow(void) { - static const char *stack_overflow_msg = - "\n;;;\n;;; Stack overflow.\n" - ";;; Jumping to the outermost toplevel prompt\n" - ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cl_index size = env->cs_size; + static const char *stack_overflow_msg = + "\n;;;\n;;; Stack overflow.\n" + ";;; Jumping to the outermost toplevel prompt\n" + ";;;\n\n"; + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + cl_index size = env->cs_size; #ifdef ECL_DOWN_STACK - if (env->cs_limit > env->cs_org - size) - env->cs_limit -= margin; + if (env->cs_limit > env->cs_org - size) + env->cs_limit -= margin; #else - if (env->cs_limit < env->cs_org + size) - env->cs_limit += margin; + if (env->cs_limit < env->cs_org + size) + env->cs_limit += margin; #endif - else - ecl_unrecoverable_error(env, stack_overflow_msg); + else + ecl_unrecoverable_error(env, stack_overflow_msg); - if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size) - si_serror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', - @':size', ecl_make_fixnum(size), - @':type', @'ext::c-stack'); - else - si_serror(6, ECL_NIL, - @'ext::stack-overflow', - @':size', ECL_NIL, - @':type', @'ext::c-stack'); - size += size/2; - if (size > env->cs_max_size) - size = env->cs_max_size; - cs_set_size(env, size); + if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size) + si_serror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', + @':size', ecl_make_fixnum(size), + @':type', @'ext::c-stack'); + else + si_serror(6, ECL_NIL, + @'ext::stack-overflow', + @':size', ECL_NIL, + @':type', @'ext::c-stack'); + size += size/2; + if (size > env->cs_max_size) + size = env->cs_max_size; + cs_set_size(env, size); } void ecl_cs_set_org(cl_env_ptr env) { - /* Rough estimate. Not very safe. We assume that cl_boot() - * is invoked from the main() routine of the program. - */ - env->cs_org = (char*)(&env); - env->cs_barrier = env->cs_org; - env->cs_max_size = 0; + /* Rough estimate. Not very safe. We assume that cl_boot() + * is invoked from the main() routine of the program. + */ + env->cs_org = (char*)(&env); + env->cs_barrier = env->cs_org; + env->cs_max_size = 0; #if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK) && !defined(NACL) - { - struct rlimit rl; - cl_index size; - getrlimit(RLIMIT_STACK, &rl); - if (rl.rlim_cur != RLIM_INFINITY) { - env->cs_max_size = rl.rlim_cur; - size = rl.rlim_cur / 2; - if (size > (cl_index)ecl_option_values[ECL_OPT_C_STACK_SIZE]) - ecl_set_option(ECL_OPT_C_STACK_SIZE, size); + { + struct rlimit rl; + cl_index size; + getrlimit(RLIMIT_STACK, &rl); + if (rl.rlim_cur != RLIM_INFINITY) { + env->cs_max_size = rl.rlim_cur; + size = rl.rlim_cur / 2; + if (size > (cl_index)ecl_option_values[ECL_OPT_C_STACK_SIZE]) + ecl_set_option(ECL_OPT_C_STACK_SIZE, size); #ifdef ECL_DOWN_STACK - env->cs_barrier = env->cs_org - rl.rlim_cur - 1024; + env->cs_barrier = env->cs_org - rl.rlim_cur - 1024; #else - env->cs_barrier = env->cs_org + rl.rlim_cur + 1024; + env->cs_barrier = env->cs_org + rl.rlim_cur + 1024; #endif - } - } + } + } #endif - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); + cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); } @@ -124,125 +119,125 @@ ecl_cs_set_org(cl_env_ptr env) void ecl_bds_unwind_n(cl_env_ptr env, int n) { - while (n--) ecl_bds_unwind1(env); + while (n--) ecl_bds_unwind1(env); } static void ecl_bds_set_size(cl_env_ptr env, cl_index new_size) { - ecl_bds_ptr old_org = env->bds_org; - cl_index limit = env->bds_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink the binding stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_ptr org; - env->bds_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); + ecl_bds_ptr old_org = env->bds_org; + cl_index limit = env->bds_top - old_org; + if (new_size <= limit) { + FEerror("Cannot shrink the binding stack below ~D.", 1, + ecl_make_unsigned_integer(limit)); + } else { + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + ecl_bds_ptr org; + env->bds_limit_size = new_size - 2*margin; + org = ecl_alloc_atomic(new_size * sizeof(*org)); - ecl_disable_interrupts_env(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->bds_top = org + limit; - env->bds_org = org; - env->bds_limit = org + (new_size - 2*margin); - env->bds_size = new_size; - ecl_enable_interrupts_env(env); + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->bds_top = org + limit; + env->bds_org = org; + env->bds_limit = org + (new_size - 2*margin); + env->bds_size = new_size; + ecl_enable_interrupts_env(env); - ecl_dealloc(old_org); - } + ecl_dealloc(old_org); + } } ecl_bds_ptr ecl_bds_overflow(void) { - static const char *stack_overflow_msg = - "\n;;;\n;;; Binding stack overflow.\n" - ";;; Jumping to the outermost toplevel prompt\n" - ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - cl_index size = env->bds_size; - ecl_bds_ptr org = env->bds_org; - ecl_bds_ptr last = org + size; - if (env->bds_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); - } - env->bds_limit += margin; - si_serror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::binding-stack'); - ecl_bds_set_size(env, size + (size / 2)); - return env->bds_top; + static const char *stack_overflow_msg = + "\n;;;\n;;; Binding stack overflow.\n" + ";;; Jumping to the outermost toplevel prompt\n" + ";;;\n\n"; + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + cl_index size = env->bds_size; + ecl_bds_ptr org = env->bds_org; + ecl_bds_ptr last = org + size; + if (env->bds_limit >= last) { + ecl_unrecoverable_error(env, stack_overflow_msg); + } + env->bds_limit += margin; + si_serror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::binding-stack'); + ecl_bds_set_size(env, size + (size / 2)); + return env->bds_top; } void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index) { - ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; - ecl_bds_ptr bds = env->bds_top; - for (; bds > new_bds_top; bds--) + ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; + ecl_bds_ptr bds = env->bds_top; + for (; bds > new_bds_top; bds--) #ifdef ECL_THREADS - ecl_bds_unwind1(env); + ecl_bds_unwind1(env); #else - bds->symbol->symbol.value = bds->value; + bds->symbol->symbol.value = bds->value; #endif - env->bds_top = new_bds_top; + env->bds_top = new_bds_top; } cl_index ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) { - cl_object vars = vars0, values = values0; - cl_index n = env->bds_top - env->bds_org; - for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { - if (Null(vars)) { - return n; - } else { - cl_object var = ECL_CONS_CAR(vars); - if (Null(values)) { - ecl_bds_bind(env, var, OBJNULL); - } else { - ecl_bds_bind(env, var, ECL_CONS_CAR(values)); - values = ECL_CONS_CDR(values); - } - } - } - FEerror("Wrong arguments to special form PROGV. Either~%" - "~A~%or~%~A~%are not proper lists", - 2, vars0, values0); + cl_object vars = vars0, values = values0; + cl_index n = env->bds_top - env->bds_org; + for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { + if (Null(vars)) { + return n; + } else { + cl_object var = ECL_CONS_CAR(vars); + if (Null(values)) { + ecl_bds_bind(env, var, OBJNULL); + } else { + ecl_bds_bind(env, var, ECL_CONS_CAR(values)); + values = ECL_CONS_CDR(values); + } + } + } + FEerror("Wrong arguments to special form PROGV. Either~%" + "~A~%or~%~A~%are not proper lists", + 2, vars0, values0); } static ecl_bds_ptr get_bds_ptr(cl_object x) { - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_bds_ptr p = env->bds_org + ecl_fixnum(x); - if (env->bds_org <= p && p <= env->bds_top) - return(p); - } - FEerror("~S is an illegal bds index.", 1, x); + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_bds_ptr p = env->bds_org + ecl_fixnum(x); + if (env->bds_org <= p && p <= env->bds_top) + return(p); + } + FEerror("~S is an illegal bds index.", 1, x); } cl_object si_bds_top() { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->bds_top - env->bds_org)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->bds_top - env->bds_org)); } cl_object si_bds_var(cl_object arg) { - @(return get_bds_ptr(arg)->symbol) + @(return get_bds_ptr(arg)->symbol); } cl_object si_bds_val(cl_object arg) { - cl_object v = get_bds_ptr(arg)->value; - @(return ((v == OBJNULL)? ECL_UNBOUND : v)) + cl_object v = get_bds_ptr(arg)->value; + @(return ((v == OBJNULL)? ECL_UNBOUND : v)); } #ifdef ecl_bds_bind @@ -260,47 +255,47 @@ si_bds_val(cl_object arg) static cl_index ecl_new_binding_index(cl_env_ptr env, cl_object symbol) { - cl_object pool; - cl_index new_index = symbol->symbol.binding; - if (new_index == ECL_MISSING_SPECIAL_BINDING) { - pool = ecl_atomic_pop(&cl_core.reused_indices); - if (!Null(pool)) { - new_index = ecl_fixnum(ECL_CONS_CAR(pool)); - } else { - new_index = ecl_atomic_index_incf(&cl_core.last_var_index); - } - symbol->symbol.binding = new_index; - symbol->symbol.dynamic |= 1; - } - si_set_finalizer(symbol, ECL_T); - return new_index; + cl_object pool; + cl_index new_index = symbol->symbol.binding; + if (new_index == ECL_MISSING_SPECIAL_BINDING) { + pool = ecl_atomic_pop(&cl_core.reused_indices); + if (!Null(pool)) { + new_index = ecl_fixnum(ECL_CONS_CAR(pool)); + } else { + new_index = ecl_atomic_index_incf(&cl_core.last_var_index); + } + symbol->symbol.binding = new_index; + symbol->symbol.dynamic |= 1; + } + si_set_finalizer(symbol, ECL_T); + return new_index; } static cl_object ecl_extend_bindings_array(cl_object vector) { - cl_index new_size = cl_core.last_var_index * 1.25; - cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim); - return new_vector; + cl_index new_size = cl_core.last_var_index * 1.25; + cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL, + ECL_NIL, ECL_NIL, ECL_NIL); + si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); + ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim); + return new_vector; } static cl_index invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) { - cl_index index = s->symbol.binding; - if (index == ECL_MISSING_SPECIAL_BINDING) { - index = ecl_new_binding_index(env, s); - } - if (index >= env->thread_local_bindings_size) { - cl_object vector = env->bindings_array; - env->bindings_array = vector = ecl_extend_bindings_array(vector); - env->thread_local_bindings_size = vector->vector.dim; - env->thread_local_bindings = vector->vector.self.t; - } - return index; + cl_index index = s->symbol.binding; + if (index == ECL_MISSING_SPECIAL_BINDING) { + index = ecl_new_binding_index(env, s); + } + if (index >= env->thread_local_bindings_size) { + cl_object vector = env->bindings_array; + env->bindings_array = vector = ecl_extend_bindings_array(vector); + env->thread_local_bindings_size = vector->vector.dim; + env->thread_local_bindings = vector->vector.self.t; + } + return index; } #endif /* ECL_THREADS */ @@ -311,23 +306,23 @@ void ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v) { #ifdef ECL_THREADS - cl_object *location; - ecl_bds_ptr slot; - cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { - index = invalid_or_too_large_binding_index(env,s); - } - location = env->thread_local_bindings + index; - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - slot->symbol = s; - slot->value = *location; - *location = v; + cl_object *location; + ecl_bds_ptr slot; + cl_index index = s->symbol.binding; + if (index >= env->thread_local_bindings_size) { + index = invalid_or_too_large_binding_index(env,s); + } + location = env->thread_local_bindings + index; + slot = ++env->bds_top; + if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + slot->symbol = s; + slot->value = *location; + *location = v; #else - ecl_bds_check(env); - (++(env->bds_top))->symbol = s; - env->bds_top->value = s->symbol.value; \ - s->symbol.value = v; + ecl_bds_check(env); + (++(env->bds_top))->symbol = s; + env->bds_top->value = s->symbol.value; \ + s->symbol.value = v; #endif } @@ -335,35 +330,35 @@ void ecl_bds_push(cl_env_ptr env, cl_object s) { #ifdef ECL_THREADS - cl_object *location; - ecl_bds_ptr slot; - cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { - index = invalid_or_too_large_binding_index(env,s); - } - location = env->thread_local_bindings + index; - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - slot->symbol = s; - slot->value = *location; - if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; + cl_object *location; + ecl_bds_ptr slot; + cl_index index = s->symbol.binding; + if (index >= env->thread_local_bindings_size) { + index = invalid_or_too_large_binding_index(env,s); + } + location = env->thread_local_bindings + index; + slot = ++env->bds_top; + if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + slot->symbol = s; + slot->value = *location; + if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; #else - ecl_bds_check(env); - (++(env->bds_top))->symbol = s; - env->bds_top->value = s->symbol.value; + ecl_bds_check(env); + (++(env->bds_top))->symbol = s; + env->bds_top->value = s->symbol.value; #endif } void ecl_bds_unwind1(cl_env_ptr env) { - ecl_bds_ptr slot = env->bds_top--; - cl_object s = slot->symbol; + ecl_bds_ptr slot = env->bds_top--; + cl_object s = slot->symbol; #ifdef ECL_THREADS - cl_object *location = env->thread_local_bindings + s->symbol.binding; - *location = slot->value; + cl_object *location = env->thread_local_bindings + s->symbol.binding; + *location = slot->value; #else - s->symbol.value = slot->value; + s->symbol.value = slot->value; #endif } @@ -371,30 +366,30 @@ ecl_bds_unwind1(cl_env_ptr env) cl_object ecl_bds_read(cl_env_ptr env, cl_object s) { - cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object x = env->thread_local_bindings[index]; - if (x != ECL_NO_TL_BINDING) return x; - } - return s->symbol.value; + cl_index index = s->symbol.binding; + if (index < env->thread_local_bindings_size) { + cl_object x = env->thread_local_bindings[index]; + if (x != ECL_NO_TL_BINDING) return x; + } + return s->symbol.value; } cl_object * ecl_bds_ref(cl_env_ptr env, cl_object s) { - cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object *location = env->thread_local_bindings + index; - if (*location != ECL_NO_TL_BINDING) - return location; - } - return &(s->symbol.value); + cl_index index = s->symbol.binding; + if (index < env->thread_local_bindings_size) { + cl_object *location = env->thread_local_bindings + index; + if (*location != ECL_NO_TL_BINDING) + return location; + } + return &(s->symbol.value); } cl_object ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) { - return *ecl_bds_ref(env, s) = value; + return *ecl_bds_ref(env, s) = value; } #endif /* ECL_THREADS */ @@ -403,78 +398,78 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) static cl_object ihs_function_name(cl_object x) { - cl_object y; + cl_object y; - switch (ecl_t_of(x)) { - case t_symbol: - return(x); + switch (ecl_t_of(x)) { + case t_symbol: + return(x); - case t_bclosure: - x = x->bclosure.code; + case t_bclosure: + x = x->bclosure.code; - case t_bytecodes: - y = x->bytecodes.name; - if (Null(y)) - return(@'lambda'); - else - return y; + case t_bytecodes: + y = x->bytecodes.name; + if (Null(y)) + return(@'lambda'); + else + return y; - case t_cfun: - case t_cfunfixed: - return(x->cfun.name); + case t_cfun: + case t_cfunfixed: + return(x->cfun.name); - default: - return(ECL_NIL); - } + default: + return(ECL_NIL); + } } static ecl_ihs_ptr get_ihs_ptr(cl_index n) { - cl_env_ptr env = ecl_process_env(); - ecl_ihs_ptr p = env->ihs_top; - if (n > p->index) - FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); - while (n < p->index) - p = p->next; - return p; + cl_env_ptr env = ecl_process_env(); + ecl_ihs_ptr p = env->ihs_top; + if (n > p->index) + FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); + while (n < p->index) + p = p->next; + return p; } cl_object si_ihs_top(void) { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->ihs_top->index)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->ihs_top->index)); } cl_object si_ihs_prev(cl_object x) { - @(return cl_1M(x)) + @(return cl_1M(x)); } cl_object si_ihs_next(cl_object x) { - @(return cl_1P(x)) + @(return cl_1P(x)); } cl_object si_ihs_bds(cl_object arg) { - @(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)) + @(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)); } cl_object si_ihs_fun(cl_object arg) { - @(return get_ihs_ptr(ecl_to_size(arg))->function) + @(return get_ihs_ptr(ecl_to_size(arg))->function); } cl_object si_ihs_env(cl_object arg) { - @(return get_ihs_ptr(ecl_to_size(arg))->lex_env) + @(return get_ihs_ptr(ecl_to_size(arg))->lex_env); } /********************** FRAME STACK *************************/ @@ -482,137 +477,137 @@ si_ihs_env(cl_object arg) static void frs_set_size(cl_env_ptr env, cl_index new_size) { - ecl_frame_ptr old_org = env->frs_org; - cl_index limit = env->frs_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink frame stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - ecl_frame_ptr org; - env->frs_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); + ecl_frame_ptr old_org = env->frs_org; + cl_index limit = env->frs_top - old_org; + if (new_size <= limit) { + FEerror("Cannot shrink frame stack below ~D.", 1, + ecl_make_unsigned_integer(limit)); + } else { + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + ecl_frame_ptr org; + env->frs_limit_size = new_size - 2*margin; + org = ecl_alloc_atomic(new_size * sizeof(*org)); - ecl_disable_interrupts_env(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->frs_top = org + limit; - env->frs_org = org; - env->frs_limit = org + (new_size - 2*margin); - env->frs_size = new_size; - ecl_enable_interrupts_env(env); + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->frs_top = org + limit; + env->frs_org = org; + env->frs_limit = org + (new_size - 2*margin); + env->frs_size = new_size; + ecl_enable_interrupts_env(env); - ecl_dealloc(old_org); - } + ecl_dealloc(old_org); + } } static void frs_overflow(void) /* used as condition in list.d */ { - static const char *stack_overflow_msg = - "\n;;;\n;;; Frame stack overflow.\n" - ";;; Jumping to the outermost toplevel prompt\n" - ";;;\n\n"; - cl_env_ptr env = ecl_process_env(); - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - cl_index size = env->frs_size; - ecl_frame_ptr org = env->frs_org; - ecl_frame_ptr last = org + size; - if (env->frs_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); - } - env->frs_limit += margin; - si_serror(6, make_constant_base_string("Extend stack size"), - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::frame-stack'); - frs_set_size(env, size + size / 2); + static const char *stack_overflow_msg = + "\n;;;\n;;; Frame stack overflow.\n" + ";;; Jumping to the outermost toplevel prompt\n" + ";;;\n\n"; + cl_env_ptr env = ecl_process_env(); + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + cl_index size = env->frs_size; + ecl_frame_ptr org = env->frs_org; + ecl_frame_ptr last = org + size; + if (env->frs_limit >= last) { + ecl_unrecoverable_error(env, stack_overflow_msg); + } + env->frs_limit += margin; + si_serror(6, make_constant_base_string("Extend stack size"), + @'ext::stack-overflow', @':size', ecl_make_fixnum(size), + @':type', @'ext::frame-stack'); + frs_set_size(env, size + size / 2); } ecl_frame_ptr _ecl_frs_push(register cl_env_ptr env, register cl_object val) { - ecl_frame_ptr output = ++env->frs_top; - if (output >= env->frs_limit) { - frs_overflow(); - output = env->frs_top; - } - output->frs_bds_top_index = env->bds_top - env->bds_org; - output->frs_val = val; - output->frs_ihs = env->ihs_top; - output->frs_sp = ECL_STACK_INDEX(env); - return output; + ecl_frame_ptr output = ++env->frs_top; + if (output >= env->frs_limit) { + frs_overflow(); + output = env->frs_top; + } + output->frs_bds_top_index = env->bds_top - env->bds_org; + output->frs_val = val; + output->frs_ihs = env->ihs_top; + output->frs_sp = ECL_STACK_INDEX(env); + return output; } void ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) { - env->nlj_fr = fr; - while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG) - --env->frs_top; - env->ihs_top = env->frs_top->frs_ihs; - ecl_bds_unwind(env, env->frs_top->frs_bds_top_index); - ECL_STACK_SET_INDEX(env, env->frs_top->frs_sp); - ecl_longjmp(env->frs_top->frs_jmpbuf, 1); - /* never reached */ + env->nlj_fr = fr; + while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG) + --env->frs_top; + env->ihs_top = env->frs_top->frs_ihs; + ecl_bds_unwind(env, env->frs_top->frs_bds_top_index); + ECL_STACK_SET_INDEX(env, env->frs_top->frs_sp); + ecl_longjmp(env->frs_top->frs_jmpbuf, 1); + /* never reached */ } ecl_frame_ptr frs_sch (cl_object frame_id) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr top; - for (top = env->frs_top; top >= env->frs_org; top--) - if (top->frs_val == frame_id) - return(top); - return(NULL); + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr top; + for (top = env->frs_top; top >= env->frs_org; top--) + if (top->frs_val == frame_id) + return(top); + return(NULL); } static ecl_frame_ptr get_frame_ptr(cl_object x) { - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr p = env->frs_org + ecl_fixnum(x); - if (env->frs_org <= p && p <= env->frs_top) - return p; - } - FEerror("~S is an illegal frs index.", 1, x); + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr p = env->frs_org + ecl_fixnum(x); + if (env->frs_org <= p && p <= env->frs_top) + return p; + } + FEerror("~S is an illegal frs index.", 1, x); } cl_object si_frs_top() { - cl_env_ptr env = ecl_process_env(); - @(return ecl_make_fixnum(env->frs_top - env->frs_org)) + cl_env_ptr env = ecl_process_env(); + @(return ecl_make_fixnum(env->frs_top - env->frs_org)); } cl_object si_frs_bds(cl_object arg) { - @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index)) + @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index)); } cl_object si_frs_tag(cl_object arg) { - @(return get_frame_ptr(arg)->frs_val) + @(return get_frame_ptr(arg)->frs_val); } cl_object si_frs_ihs(cl_object arg) { - @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)) + @(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)); } cl_object si_sch_frs_base(cl_object fr, cl_object ihs) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr x; - cl_index y = ecl_to_size(ihs); - for (x = get_frame_ptr(fr); - x <= env->frs_top && x->frs_ihs->index < y; - x++); - @(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))) + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr x; + cl_index y = ecl_to_size(ihs); + for (x = get_frame_ptr(fr); + x <= env->frs_top && x->frs_ihs->index < y; + x++); + @(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))); } /********************* INITIALIZATION ***********************/ @@ -620,93 +615,94 @@ si_sch_frs_base(cl_object fr, cl_object ihs) cl_object si_set_limit(cl_object type, cl_object limit) { - cl_env_ptr env = ecl_process_env(); - cl_index margin; - if (type == @'ext::frame-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - frs_set_size(env, the_size + 2*margin); - } else if (type == @'ext::binding-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_set_size(env, the_size + 2*margin); - } else if (type == @'ext::c-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cs_set_size(env, the_size + 2*margin); - } else if (type == @'ext::lisp-stack') { - cl_index the_size = ecl_to_size(limit); - ecl_stack_set_size(env, the_size); - } else { - /* - * size_t can be larger than cl_index, and ecl_to_size() - * creates a fixnum which is too small for size_t on 32-bit. - */ - size_t the_size = (size_t)ecl_to_ulong(limit); - _ecl_set_max_heap_size(the_size); - } + cl_env_ptr env = ecl_process_env(); + cl_index margin; + if (type == @'ext::frame-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + frs_set_size(env, the_size + 2*margin); + } else if (type == @'ext::binding-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + ecl_bds_set_size(env, the_size + 2*margin); + } else if (type == @'ext::c-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + cs_set_size(env, the_size + 2*margin); + } else if (type == @'ext::lisp-stack') { + cl_index the_size = ecl_to_size(limit); + ecl_stack_set_size(env, the_size); + } else { + /* + * size_t can be larger than cl_index, and ecl_to_size() + * creates a fixnum which is too small for size_t on 32-bit. + */ + size_t the_size = (size_t)ecl_to_ulong(limit); + _ecl_set_max_heap_size(the_size); + } - return si_get_limit(type); + return si_get_limit(type); } cl_object si_get_limit(cl_object type) { - cl_env_ptr env = ecl_process_env(); - cl_index output; - if (type == @'ext::frame-stack') - output = env->frs_limit_size; - else if (type == @'ext::binding-stack') - output = env->bds_limit_size; - else if (type == @'ext::c-stack') - output = env->cs_limit_size; - else if (type == @'ext::lisp-stack') - output = env->stack_limit_size; - else - /* size_t can be larger than cl_index */ - @(return ecl_make_unsigned_integer(cl_core.max_heap_size)); + cl_env_ptr env = ecl_process_env(); + cl_index output; + if (type == @'ext::frame-stack') + output = env->frs_limit_size; + else if (type == @'ext::binding-stack') + output = env->bds_limit_size; + else if (type == @'ext::c-stack') + output = env->cs_limit_size; + else if (type == @'ext::lisp-stack') + output = env->stack_limit_size; + else { + /* size_t can be larger than cl_index */ + @(return ecl_make_unsigned_integer(cl_core.max_heap_size)); + } - @(return ecl_make_unsigned_integer(output)) + @(return ecl_make_unsigned_integer(output)); } cl_object si_reset_margin(cl_object type) { - cl_env_ptr env = ecl_process_env(); - if (type == @'ext::frame-stack') - frs_set_size(env, env->frs_size); - else if (type == @'ext::binding-stack') - ecl_bds_set_size(env, env->bds_size); - else if (type == @'ext::c-stack') - cs_set_size(env, env->cs_size); - else - return ECL_NIL; + cl_env_ptr env = ecl_process_env(); + if (type == @'ext::frame-stack') + frs_set_size(env, env->frs_size); + else if (type == @'ext::binding-stack') + ecl_bds_set_size(env, env->bds_size); + else if (type == @'ext::c-stack') + cs_set_size(env, env->cs_size); + else + return ECL_NIL; - return ECL_T; + return ECL_T; } void init_stacks(cl_env_ptr env) { - static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; - cl_index size, margin; + static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; + cl_index size, margin; - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; - env->frs_size = size; - env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); - env->frs_top = env->frs_org-1; - env->frs_limit = &env->frs_org[size - 2*margin]; + margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; + env->frs_size = size; + env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); + env->frs_top = env->frs_org-1; + env->frs_limit = &env->frs_org[size - 2*margin]; - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; - env->bds_size = size; - env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); - env->bds_top = env->bds_org-1; - env->bds_limit = &env->bds_org[size - 2*margin]; + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; + env->bds_size = size; + env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); + env->bds_top = env->bds_org-1; + env->bds_limit = &env->bds_org[size - 2*margin]; - env->ihs_top = &ihs_org; - ihs_org.function = ECL_NIL; - ihs_org.lex_env = ECL_NIL; - ihs_org.index = 0; + env->ihs_top = &ihs_org; + ihs_org.function = ECL_NIL; + ihs_org.lex_env = ECL_NIL; + ihs_org.index = 0; } diff --git a/src/c/string.d b/src/c/string.d index 1664d5081..b463d3de2 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -1,22 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - string.d -- String routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or - modify it under thep 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. -*/ - + * string.d - string routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -28,22 +22,22 @@ typedef ecl_character (*ecl_casefun)(ecl_character, bool *); static cl_object do_make_base_string(cl_index s, ecl_base_char code) { - cl_object x = ecl_alloc_simple_base_string(s); - cl_index i; - for (i = 0; i < s; i++) - x->base_string.self[i] = code; - return x; + cl_object x = ecl_alloc_simple_base_string(s); + cl_index i; + for (i = 0; i < s; i++) + x->base_string.self[i] = code; + return x; } #ifdef ECL_UNICODE static cl_object do_make_string(cl_index s, ecl_character code) { - cl_object x = ecl_alloc_simple_extended_string(s); - cl_index i; - for (i = 0; i < s; i++) - x->string.self[i] = code; - return x; + cl_object x = ecl_alloc_simple_extended_string(s); + cl_index i; + for (i = 0; i < s; i++) + x->string.self[i] = code; + return x; } #else #define do_make_string do_make_base_string @@ -51,307 +45,307 @@ do_make_string(cl_index s, ecl_character code) @(defun make_string (size &key (initial_element ECL_CODE_CHAR(' ')) (element_type @'character')) - cl_index s; - cl_object x; -@ - s = ecl_to_index(size); - /* INV: ecl_[base_]char_code() checks the type of initial_element() */ - if (element_type == @'base-char' || element_type == @'standard-char') { - int code = ecl_base_char_code(initial_element); - x = do_make_base_string(s, code); - } else if (element_type == @'character') { - cl_index code = ecl_char_code(initial_element); - x = do_make_string(s, code); - } else if (_ecl_funcall3(@'subtypep', element_type, @'base-char') == ECL_T) { - int code = ecl_base_char_code(initial_element); - x = do_make_base_string(s, code); - } else if (_ecl_funcall3(@'subtypep', element_type, @'character') == ECL_T) { - cl_index code = ecl_char_code(initial_element); - x = do_make_string(s, code); - } else { - FEerror("The type ~S is not a valid string char type.", - 1, element_type); - } - @(return x) -@) + cl_index s; + cl_object x; + @ + s = ecl_to_index(size); + /* INV: ecl_[base_]char_code() checks the type of initial_element() */ + if (element_type == @'base-char' || element_type == @'standard-char') { + int code = ecl_base_char_code(initial_element); + x = do_make_base_string(s, code); + } else if (element_type == @'character') { + cl_index code = ecl_char_code(initial_element); + x = do_make_string(s, code); + } else if (_ecl_funcall3(@'subtypep', element_type, @'base-char') == ECL_T) { + int code = ecl_base_char_code(initial_element); + x = do_make_base_string(s, code); + } else if (_ecl_funcall3(@'subtypep', element_type, @'character') == ECL_T) { + cl_index code = ecl_char_code(initial_element); + x = do_make_string(s, code); + } else { + FEerror("The type ~S is not a valid string char type.", + 1, element_type); + } + @(return x); + @) /* - Make a string of a certain size, with some eading zeros to - keep C happy. The string must be adjustable, to allow further - growth. (See unixfsys.c for its use). + Make a string of a certain size, with some eading zeros to + keep C happy. The string must be adjustable, to allow further + growth. (See unixfsys.c for its use). */ cl_object ecl_alloc_adjustable_base_string(cl_index l) { - cl_object output = ecl_alloc_object(t_base_string); - output->base_string.self = (ecl_base_char *)ecl_alloc_atomic(l+1); - output->base_string.self[l] = 0; - output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; - output->base_string.elttype = ecl_aet_bc; - output->base_string.displaced = ECL_NIL; - output->base_string.dim = l; - output->base_string.fillp = 0; - return output; + cl_object output = ecl_alloc_object(t_base_string); + output->base_string.self = (ecl_base_char *)ecl_alloc_atomic(l+1); + output->base_string.self[l] = 0; + output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + output->base_string.elttype = ecl_aet_bc; + output->base_string.displaced = ECL_NIL; + output->base_string.dim = l; + output->base_string.fillp = 0; + return output; } #ifdef ECL_UNICODE cl_object ecl_alloc_adjustable_extended_string(cl_index l) { - cl_index bytes = sizeof(ecl_character) * l; - cl_object output = ecl_alloc_object(t_string); - output->string.self = (ecl_character *)ecl_alloc_atomic(bytes); - output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; - output->string.elttype = ecl_aet_ch; - output->string.displaced = ECL_NIL; - output->string.dim = l; - output->string.fillp = 0; - return output; + cl_index bytes = sizeof(ecl_character) * l; + cl_object output = ecl_alloc_object(t_string); + output->string.self = (ecl_character *)ecl_alloc_atomic(bytes); + output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + output->string.elttype = ecl_aet_ch; + output->string.displaced = ECL_NIL; + output->string.dim = l; + output->string.fillp = 0; + return output; } #endif /* - Make_simple_base_string(s) makes a simple-base string from C string s. + Make_simple_base_string(s) makes a simple-base string from C string s. */ cl_object ecl_make_simple_base_string(char *s, cl_fixnum l) { - cl_object x = ecl_alloc_object(t_base_string); - x->base_string.elttype = ecl_aet_bc; - x->base_string.flags = 0; /* no fill pointer, no adjustable */ - x->base_string.displaced = ECL_NIL; - if (l < 0) l = strlen(s); - x->base_string.dim = (x->base_string.fillp = l); - x->base_string.self = (ecl_base_char *)s; - return x; + cl_object x = ecl_alloc_object(t_base_string); + x->base_string.elttype = ecl_aet_bc; + x->base_string.flags = 0; /* no fill pointer, no adjustable */ + x->base_string.displaced = ECL_NIL; + if (l < 0) l = strlen(s); + x->base_string.dim = (x->base_string.fillp = l); + x->base_string.self = (ecl_base_char *)s; + return x; } cl_object make_base_string_copy(const char *s) { - cl_object x; - cl_index l = strlen(s); + cl_object x; + cl_index l = strlen(s); - x = ecl_alloc_simple_base_string(l); - memcpy(x->base_string.self, s, l); - return x; + x = ecl_alloc_simple_base_string(l); + memcpy(x->base_string.self, s, l); + return x; } cl_object ecl_cstring_to_base_string_or_nil(const char *s) { - if (s == NULL) - return ECL_NIL; - else - return make_base_string_copy(s); + if (s == NULL) + return ECL_NIL; + else + return make_base_string_copy(s); } bool ecl_fits_in_base_string(cl_object s) { - switch (ecl_t_of(s)) { + switch (ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: { - cl_index i; - for (i = 0; i < s->string.fillp; i++) { - if (!ECL_BASE_CHAR_CODE_P(s->string.self[i])) - return 0; - } - return 1; - } + case t_string: { + cl_index i; + for (i = 0; i < s->string.fillp; i++) { + if (!ECL_BASE_CHAR_CODE_P(s->string.self[i])) + return 0; + } + return 1; + } #endif - case t_base_string: - return 1; - default: - FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,s,@[string]); - } + case t_base_string: + return 1; + default: + FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,s,@[string]); + } } cl_object si_copy_to_simple_base_string(cl_object x) { - cl_object y; + cl_object y; AGAIN: - switch(ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - goto AGAIN; - case t_character: - x = cl_string(x); - goto AGAIN; + switch(ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + goto AGAIN; + case t_character: + x = cl_string(x); + goto AGAIN; #ifdef ECL_UNICODE - case t_string: { - cl_index index, length = x->string.fillp; - y = ecl_alloc_simple_base_string(length); - for (index=0; index < length; index++) { - ecl_character c = x->string.self[index]; - if (!ECL_BASE_CHAR_CODE_P(c)) - FEerror("Cannot coerce string ~A to a base-string", 1, x); - y->base_string.self[index] = c; - } - break; - } + case t_string: { + cl_index index, length = x->string.fillp; + y = ecl_alloc_simple_base_string(length); + for (index=0; index < length; index++) { + ecl_character c = x->string.self[index]; + if (!ECL_BASE_CHAR_CODE_P(c)) + FEerror("Cannot coerce string ~A to a base-string", 1, x); + y->base_string.self[index] = c; + } + break; + } #endif - case t_base_string: { - cl_index length = x->base_string.fillp; - y = ecl_alloc_simple_base_string(length); - memcpy(y->base_string.self, x->base_string.self, length); - break; - } - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - goto AGAIN; - } - default: - FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,x,@[string]); - } - @(return y) + case t_base_string: { + cl_index length = x->base_string.fillp; + y = ecl_alloc_simple_base_string(length); + memcpy(y->base_string.self, x->base_string.self, length); + break; + } + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + goto AGAIN; + } + default: + FEwrong_type_nth_arg(@[si::copy-to-simple-base-string],1,x,@[string]); + } + @(return y); } cl_object cl_string(cl_object x) { - switch (ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - break; - case t_character: { - cl_object y; - ecl_character c = ECL_CHAR_CODE(x); + switch (ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + break; + case t_character: { + cl_object y; + ecl_character c = ECL_CHAR_CODE(x); #ifdef ECL_UNICODE - if (ECL_BASE_CHAR_CODE_P(c)) { - y = ecl_alloc_simple_base_string(1); - y->base_string.self[0] = c; - x = y; - } else { - y = ecl_alloc_simple_extended_string(1); - y->string.self[0] = c; - x = y; - } + if (ECL_BASE_CHAR_CODE_P(c)) { + y = ecl_alloc_simple_base_string(1); + y->base_string.self[0] = c; + x = y; + } else { + y = ecl_alloc_simple_extended_string(1); + y->string.self[0] = c; + x = y; + } #else - y = ecl_alloc_simple_base_string(1); - y->base_string.self[0] = c; - x = y; - break; + y = ecl_alloc_simple_base_string(1); + y->base_string.self[0] = c; + x = y; + break; #endif - } + } #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - break; - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - break; - } - default: - FEwrong_type_nth_arg(@[string],1,x,@[string]); - } - @(return x) + case t_base_string: + break; + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + break; + } + default: + FEwrong_type_nth_arg(@[string],1,x,@[string]); + } + @(return x); } #ifdef ECL_UNICODE cl_object si_coerce_to_base_string(cl_object x) { - if (!ECL_BASE_STRING_P(x)) { - x = si_copy_to_simple_base_string(x); - } - @(return x) + if (!ECL_BASE_STRING_P(x)) { + x = si_copy_to_simple_base_string(x); + } + @(return x); } cl_object si_coerce_to_extended_string(cl_object x) { - cl_object y; + cl_object y; AGAIN: - switch (ecl_t_of(x)) { - case t_symbol: - x = x->symbol.name; - goto AGAIN; - case t_character: - y = ecl_alloc_simple_extended_string(1); - y->string.self[0] = ECL_CHAR_CODE(x); - break; - case t_base_string: { - cl_index index, len = x->base_string.dim; - y = ecl_alloc_simple_extended_string(x->base_string.fillp); - for(index=0; index < len; index++) { - y->string.self[index] = x->base_string.self[index]; - } - y->string.fillp = x->base_string.fillp; - } - case t_string: - y = x; - break; - case t_list: - if (Null(x)) { - x = ECL_NIL_SYMBOL->symbol.name; - goto AGAIN; - } - default: - FEwrong_type_nth_arg(@[si::coerce-to-extended-string],1,x,@[string]); - } - @(return y) + switch (ecl_t_of(x)) { + case t_symbol: + x = x->symbol.name; + goto AGAIN; + case t_character: + y = ecl_alloc_simple_extended_string(1); + y->string.self[0] = ECL_CHAR_CODE(x); + break; + case t_base_string: { + cl_index index, len = x->base_string.dim; + y = ecl_alloc_simple_extended_string(x->base_string.fillp); + for(index=0; index < len; index++) { + y->string.self[index] = x->base_string.self[index]; + } + y->string.fillp = x->base_string.fillp; + } + case t_string: + y = x; + break; + case t_list: + if (Null(x)) { + x = ECL_NIL_SYMBOL->symbol.name; + goto AGAIN; + } + default: + FEwrong_type_nth_arg(@[si::coerce-to-extended-string],1,x,@[string]); + } + @(return y); } #endif cl_object cl_char(cl_object object, cl_object index) { - cl_index position = ecl_to_index(index); - @(return ECL_CODE_CHAR(ecl_char(object, position))) + cl_index position = ecl_to_index(index); + @(return ECL_CODE_CHAR(ecl_char(object, position))); } ecl_character ecl_char(cl_object object, cl_index index) { - /* CHAR bypasses fill pointers when accessing strings */ - switch(ecl_t_of(object)) { + /* CHAR bypasses fill pointers when accessing strings */ + switch(ecl_t_of(object)) { #ifdef ECL_UNICODE - case t_string: - if (index >= object->string.dim) - FEtype_error_index(object, index); - return object->string.self[index]; + case t_string: + if (index >= object->string.dim) + FEtype_error_index(object, index); + return object->string.self[index]; #endif - case t_base_string: - if (index >= object->base_string.dim) - FEtype_error_index(object, index); - return object->base_string.self[index]; - default: - FEwrong_type_nth_arg(@[char],1,object,@[string]); - } + case t_base_string: + if (index >= object->base_string.dim) + FEtype_error_index(object, index); + return object->base_string.self[index]; + default: + FEwrong_type_nth_arg(@[char],1,object,@[string]); + } } cl_object si_char_set(cl_object object, cl_object index, cl_object value) { - cl_index position = ecl_to_index(index); - cl_index c = ecl_char_code(value); - ecl_char_set(object, position, c); - @(return value) + cl_index position = ecl_to_index(index); + cl_index c = ecl_char_code(value); + ecl_char_set(object, position, c); + @(return value); } ecl_character ecl_char_set(cl_object object, cl_index index, ecl_character value) { - /* CHAR bypasses fill pointers when accessing strings */ - switch(ecl_t_of(object)) { + /* CHAR bypasses fill pointers when accessing strings */ + switch(ecl_t_of(object)) { #ifdef ECL_UNICODE - case t_string: - if (index >= object->string.dim) - FEtype_error_index(object, index); - return object->string.self[index] = value; + case t_string: + if (index >= object->string.dim) + FEtype_error_index(object, index); + return object->string.self[index] = value; #endif - case t_base_string: - if (index >= object->base_string.dim) - FEtype_error_index(object, index); - return object->base_string.self[index] = value; - default: - FEwrong_type_nth_arg(@[si::char-set],1,object,@[string]); - } + case t_base_string: + if (index >= object->base_string.dim) + FEtype_error_index(object, index); + return object->base_string.self[index] = value; + default: + FEwrong_type_nth_arg(@[si::char-set],1,object,@[string]); + } } #ifdef ECL_UNICODE @@ -360,32 +354,32 @@ compare_strings(cl_object string1, cl_index s1, cl_index e1, cl_object string2, cl_index s2, cl_index e2, int case_sensitive, cl_index *m) { - cl_index c1, c2; - for (; s1 < e1; s1++, s2++) { - if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */ - *m = s1; - return +1; - } - c1 = ecl_char(string1, s1); - c2 = ecl_char(string2, s2); - if (!case_sensitive) { - c1 = ecl_char_upcase(c1); - c2 = ecl_char_upcase(c2); - } - if (c1 < c2) { - *m = s1; - return -1; - } else if (c1 > c2) { - *m = s1; - return +1; - } - } - *m = s1; - if (s2 >= e2) { - return 0; - } else { /* s1 is shorter than s2, hence s1 < s2 */ - return -1; - } + cl_index c1, c2; + for (; s1 < e1; s1++, s2++) { + if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */ + *m = s1; + return +1; + } + c1 = ecl_char(string1, s1); + c2 = ecl_char(string2, s2); + if (!case_sensitive) { + c1 = ecl_char_upcase(c1); + c2 = ecl_char_upcase(c2); + } + if (c1 < c2) { + *m = s1; + return -1; + } else if (c1 > c2) { + *m = s1; + return +1; + } + } + *m = s1; + if (s2 >= e2) { + return 0; + } else { /* s1 is shorter than s2, hence s1 < s2 */ + return -1; + } } #endif @@ -393,380 +387,387 @@ static int compare_base(unsigned char *s1, cl_index l1, unsigned char *s2, cl_index l2, int case_sensitive, cl_index *m) { - cl_index l, c1, c2; - for (l = 0; l < l1; l++, s1++, s2++) { - if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */ - *m = l; - return +1; - } - c1 = *s1; - c2 = *s2; - if (!case_sensitive) { - c1 = ecl_char_upcase(c1); - c2 = ecl_char_upcase(c2); - } - if (c1 < c2) { - *m = l; - return -1; - } else if (c1 > c2) { - *m = l; - return +1; - } - } - *m = l; - if (l1 == l2) - return 0; - else { /* s1 is shorter than s2, hence s1 < s2 */ - return -1; - } + cl_index l, c1, c2; + for (l = 0; l < l1; l++, s1++, s2++) { + if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */ + *m = l; + return +1; + } + c1 = *s1; + c2 = *s2; + if (!case_sensitive) { + c1 = ecl_char_upcase(c1); + c2 = ecl_char_upcase(c2); + } + if (c1 < c2) { + *m = l; + return -1; + } else if (c1 > c2) { + *m = l; + return +1; + } + } + *m = l; + if (l1 == l2) + return 0; + else { /* s1 is shorter than s2, hence s1 < s2 */ + return -1; + } } @(defun string= (string1 string2 &key (start1 ecl_make_fixnum(0)) end1 - (start2 ecl_make_fixnum(0)) end2) - cl_index_pair p; - cl_index s1, e1, s2, e2; -@ -{ - string1 = cl_string(string1); - string2 = cl_string(string2); - p = ecl_vector_start_end(@[string=], string1, start1, end1); - s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); - s2 = p.start; e2 = p.end; - if (e1 - s1 != e2 - s2) - @(return ECL_NIL); + (start2 ecl_make_fixnum(0)) end2) + cl_index_pair p; + cl_index s1, e1, s2, e2; + @ + { + string1 = cl_string(string1); + string2 = cl_string(string2); + p = ecl_vector_start_end(@[string=], string1, start1, end1); + s1 = p.start; e1 = p.end; + p = ecl_vector_start_end(@[string=], string2, start2, end2); + s2 = p.start; e2 = p.end; + if (e1 - s1 != e2 - s2) { + @(return ECL_NIL); + } #ifdef ECL_UNICODE - if (string1->string.t == t_string) { - if (string2->string.t == t_string) { - while (s1 < e1) - if (string1->string.self[s1++] != string2->string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } else { - while (s1 < e1) - if (string1->string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } - } else { - if (string2->string.t == t_string) { - while (s1 < e1) - if (string1->base_string.self[s1++] != string2->string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } else { - while (s1 < e1) - if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); - @(return ECL_T); - } - } -#else + if (string1->string.t == t_string) { + if (string2->string.t == t_string) { while (s1 < e1) - if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) - @(return ECL_NIL); -#endif + if (string1->string.self[s1++] != string2->string.self[s2++]) { + @(return ECL_NIL); + } @(return ECL_T); -} -@) + } else { + while (s1 < e1) + if (string1->string.self[s1++] != string2->base_string.self[s2++]) { + @(return ECL_NIL); + } + @(return ECL_T); + } + } else { + if (string2->string.t == t_string) { + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->string.self[s2++]) { + @(return ECL_NIL); + } + @(return ECL_T); + } else { + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) { + @(return ECL_NIL); + } + @(return ECL_T); + } + } +#else + while (s1 < e1) + if (string1->base_string.self[s1++] != string2->base_string.self[s2++]) { + @(return ECL_NIL); + } +#endif + @(return ECL_T); + } + @) /* - This correponds to string= (just the string equality). + This correponds to string= (just the string equality). */ bool ecl_string_eq(cl_object x, cl_object y) { - cl_index i, j; - i = x->base_string.fillp; - j = y->base_string.fillp; - if (i != j) return 0; + cl_index i, j; + i = x->base_string.fillp; + j = y->base_string.fillp; + if (i != j) return 0; #ifdef ECL_UNICODE - switch(ecl_t_of(x)) { - case t_string: - switch(ecl_t_of(y)) { - case t_string: - return memcmp(x->string.self, y->string.self, i * sizeof *x->string.self) == 0; - case t_base_string: { - cl_index index; - for(index=0; indexstring.self[index] != y->base_string.self[index]) - return 0; - return 1; - } - default: - FEwrong_type_nth_arg(@[string=],2,y,@[string]); - } - break; - case t_base_string: - switch(ecl_t_of(y)) { - case t_string: - return ecl_string_eq(y, x); - case t_base_string: - return memcmp(x->base_string.self, y->base_string.self, i) == 0; - default: - FEwrong_type_nth_arg(@[string=],2,y,@[string]); - } - break; - default: - FEwrong_type_nth_arg(@[string=],2,x,@[string]); - } + switch(ecl_t_of(x)) { + case t_string: + switch(ecl_t_of(y)) { + case t_string: + return memcmp(x->string.self, y->string.self, i * sizeof *x->string.self) == 0; + case t_base_string: { + cl_index index; + for(index=0; indexstring.self[index] != y->base_string.self[index]) + return 0; + return 1; + } + default: + FEwrong_type_nth_arg(@[string=],2,y,@[string]); + } + break; + case t_base_string: + switch(ecl_t_of(y)) { + case t_string: + return ecl_string_eq(y, x); + case t_base_string: + return memcmp(x->base_string.self, y->base_string.self, i) == 0; + default: + FEwrong_type_nth_arg(@[string=],2,y,@[string]); + } + break; + default: + FEwrong_type_nth_arg(@[string=],2,x,@[string]); + } #else - return memcmp(x->base_string.self, y->base_string.self, i) == 0; + return memcmp(x->base_string.self, y->base_string.self, i) == 0; #endif } @(defun string_equal (string1 string2 &key (start1 ecl_make_fixnum(0)) end1 - (start2 ecl_make_fixnum(0)) end2) - cl_index s1, e1, s2, e2; - cl_index_pair p; - int output; -@ - string1 = cl_string(string1); - string2 = cl_string(string2); - p = ecl_vector_start_end(@[string=], string1, start1, end1); - s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); - s2 = p.start; e2 = p.end; - if (e1 - s1 != e2 - s2) - @(return ECL_NIL); + (start2 ecl_make_fixnum(0)) end2) + cl_index s1, e1, s2, e2; + cl_index_pair p; + int output; + @ + string1 = cl_string(string1); + string2 = cl_string(string2); + p = ecl_vector_start_end(@[string=], string1, start1, end1); + s1 = p.start; e1 = p.end; + p = ecl_vector_start_end(@[string=], string2, start2, end2); + s2 = p.start; e2 = p.end; + if (e1 - s1 != e2 - s2) { + @(return ECL_NIL); + } #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { - output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1); - } else + if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { + output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1); + } else #endif - output = compare_base(string1->base_string.self + s1, e1 - s1, - string2->base_string.self + s2, e2 - s2, - 0, &e1); - @(return ((output == 0)? ECL_T : ECL_NIL)) -@) + output = compare_base(string1->base_string.self + s1, e1 - s1, + string2->base_string.self + s2, e2 - s2, + 0, &e1); + @(return ((output == 0)? ECL_T : ECL_NIL)); + @) static cl_object string_compare(cl_narg narg, int sign1, int sign2, int case_sensitive, ecl_va_list ARGS) { - cl_object string1 = ecl_va_arg(ARGS); - cl_object string2 = ecl_va_arg(ARGS); - cl_index s1, e1, s2, e2; - cl_index_pair p; - int output; - cl_object result; - cl_object KEYS[4]; + cl_object string1 = ecl_va_arg(ARGS); + cl_object string2 = ecl_va_arg(ARGS); + cl_index s1, e1, s2, e2; + cl_index_pair p; + int output; + cl_object result; + cl_object KEYS[4]; #define start1 KEY_VARS[0] #define end1 KEY_VARS[1] #define start2 KEY_VARS[2] #define end2 KEY_VARS[3] #define start1p KEY_VARS[4] #define start2p KEY_VARS[6] - cl_object KEY_VARS[8]; + cl_object KEY_VARS[8]; - if (narg < 2) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start1'; - KEYS[1]=@':end1'; - KEYS[2]=@':start2'; - KEYS[3]=@':end2'; - cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); + if (narg < 2) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start1'; + KEYS[1]=@':end1'; + KEYS[2]=@':start2'; + KEYS[3]=@':end2'; + cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); - string1 = cl_string(string1); - string2 = cl_string(string2); - if (start1p == ECL_NIL) start1 = ecl_make_fixnum(0); - if (start2p == ECL_NIL) start2 = ecl_make_fixnum(0); - p = ecl_vector_start_end(@[string=], string1, start1, end1); - s1 = p.start; e1 = p.end; - p = ecl_vector_start_end(@[string=], string2, start2, end2); - s2 = p.start; e2 = p.end; + string1 = cl_string(string1); + string2 = cl_string(string2); + if (start1p == ECL_NIL) start1 = ecl_make_fixnum(0); + if (start2p == ECL_NIL) start2 = ecl_make_fixnum(0); + p = ecl_vector_start_end(@[string=], string1, start1, end1); + s1 = p.start; e1 = p.end; + p = ecl_vector_start_end(@[string=], string2, start2, end2); + s2 = p.start; e2 = p.end; #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { - output = compare_strings(string1, s1, e1, string2, s2, e2, - case_sensitive, &e1); - } else + if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) { + output = compare_strings(string1, s1, e1, string2, s2, e2, + case_sensitive, &e1); + } else #endif - { - output = compare_base(string1->base_string.self + s1, e1 - s1, - string2->base_string.self + s2, e2 - s2, - case_sensitive, &e1); - e1 += s1; - } - if (output == sign1 || output == sign2) { - result = ecl_make_fixnum(e1); - } else { - result = ECL_NIL; - } - @(return result) + { + output = compare_base(string1->base_string.self + s1, e1 - s1, + string2->base_string.self + s2, e2 - s2, + case_sensitive, &e1); + e1 += s1; + } + if (output == sign1 || output == sign2) { + result = ecl_make_fixnum(e1); + } else { + result = ECL_NIL; + } + @(return result); #undef start1p #undef start2p #undef start1 #undef end1 #undef start2 #undef end2 -} + } @(defun string< (&rest args) -@ - return string_compare(narg, -1, -1, 1, args); -@) + @ + return string_compare(narg, -1, -1, 1, args); + @) @(defun string> (&rest args) -@ - return string_compare(narg, +1, +1, 1, args); -@) + @ + return string_compare(narg, +1, +1, 1, args); + @) @(defun string<= (&rest args) -@ - return string_compare(narg, -1, 0, 1, args); -@) + @ + return string_compare(narg, -1, 0, 1, args); + @) @(defun string>= (&rest args) -@ - return string_compare(narg, 0, +1, 1, args); -@) + @ + return string_compare(narg, 0, +1, 1, args); + @) @(defun string/= (&rest args) -@ - return string_compare(narg, -1, +1, 1, args); -@) + @ + return string_compare(narg, -1, +1, 1, args); + @) @(defun string-lessp (&rest args) -@ - return string_compare(narg, -1, -1, 0, args); -@) + @ + return string_compare(narg, -1, -1, 0, args); + @) @(defun string-greaterp (&rest args) -@ - return string_compare(narg, +1, +1, 0, args); -@) + @ + return string_compare(narg, +1, +1, 0, args); + @) @(defun string-not-greaterp (&rest args) -@ - return string_compare(narg, -1, 0, 0, args); -@) + @ + return string_compare(narg, -1, 0, 0, args); + @) @(defun string-not-lessp (&rest args) -@ - return string_compare(narg, 0, +1, 0, args); -@) + @ + return string_compare(narg, 0, +1, 0, args); + @) @(defun string-not-equal (&rest args) -@ - return string_compare(narg, -1, +1, 0, args); -@) + @ + return string_compare(narg, -1, +1, 0, args); + @) bool ecl_member_char(ecl_character c, cl_object char_bag) { - cl_index i, f; - switch (ecl_t_of(char_bag)) { - case t_list: - loop_for_in(char_bag) { - cl_object other = CAR(char_bag); - if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) - return(TRUE); - } end_loop_for_in; - return(FALSE); - case t_vector: - for (i = 0, f = char_bag->vector.fillp; i < f; i++) { - cl_object other = char_bag->vector.self.t[i]; - if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) - return(TRUE); - } - return(FALSE); + cl_index i, f; + switch (ecl_t_of(char_bag)) { + case t_list: + loop_for_in(char_bag) { + cl_object other = CAR(char_bag); + if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) + return(TRUE); + } end_loop_for_in; + return(FALSE); + case t_vector: + for (i = 0, f = char_bag->vector.fillp; i < f; i++) { + cl_object other = char_bag->vector.self.t[i]; + if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other)) + return(TRUE); + } + return(FALSE); #ifdef ECL_UNICODE - case t_string: - for (i = 0, f = char_bag->string.fillp; i < f; i++) { - if (c == char_bag->string.self[i]) - return(TRUE); - } - return(FALSE); + case t_string: + for (i = 0, f = char_bag->string.fillp; i < f; i++) { + if (c == char_bag->string.self[i]) + return(TRUE); + } + return(FALSE); #endif - case t_base_string: - for (i = 0, f = char_bag->base_string.fillp; i < f; i++) { - if (c == char_bag->base_string.self[i]) - return(TRUE); - } - return(FALSE); - case t_bitvector: - return(FALSE); - default: - FEwrong_type_nth_arg(@[member],2,char_bag,@[sequence]); - } + case t_base_string: + for (i = 0, f = char_bag->base_string.fillp; i < f; i++) { + if (c == char_bag->base_string.self[i]) + return(TRUE); + } + return(FALSE); + case t_bitvector: + return(FALSE); + default: + FEwrong_type_nth_arg(@[member],2,char_bag,@[sequence]); + } } static cl_object string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strng) { - cl_index i, j; + cl_index i, j; - strng = cl_string(strng); - i = 0; - j = ecl_length(strng); - if (left_trim) { - for (; i < j; i++) { - cl_index c = ecl_char(strng, i); - if (!ecl_member_char(c, char_bag)) - break; - } - } - if (right_trim) { - for (; j > i; j--) { - cl_index c = ecl_char(strng, j-1); - if (!ecl_member_char(c, char_bag)) { - break; - } - } - } - return cl_subseq(3, strng, ecl_make_fixnum(i), ecl_make_fixnum(j)); + strng = cl_string(strng); + i = 0; + j = ecl_length(strng); + if (left_trim) { + for (; i < j; i++) { + cl_index c = ecl_char(strng, i); + if (!ecl_member_char(c, char_bag)) + break; + } + } + if (right_trim) { + for (; j > i; j--) { + cl_index c = ecl_char(strng, j-1); + if (!ecl_member_char(c, char_bag)) { + break; + } + } + } + return cl_subseq(3, strng, ecl_make_fixnum(i), ecl_make_fixnum(j)); } cl_object cl_string_trim(cl_object char_bag, cl_object strng) { - return string_trim0(TRUE, TRUE, char_bag, strng); + return string_trim0(TRUE, TRUE, char_bag, strng); } cl_object cl_string_left_trim(cl_object char_bag, cl_object strng) { - return string_trim0(TRUE, FALSE, char_bag, strng); + return string_trim0(TRUE, FALSE, char_bag, strng); } cl_object cl_string_right_trim(cl_object char_bag, cl_object strng) { - return string_trim0(FALSE, TRUE, char_bag, strng); + return string_trim0(FALSE, TRUE, char_bag, strng); } static cl_object string_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) { - cl_object strng = ecl_va_arg(ARGS); - cl_index_pair p; - cl_index i; - bool b; - cl_object KEYS[2]; + cl_object strng = ecl_va_arg(ARGS); + cl_index_pair p; + cl_index i; + bool b; + cl_object KEYS[2]; #define kstart KEY_VARS[0] #define kend KEY_VARS[1] #define kstartp KEY_VARS[2] - cl_object KEY_VARS[4]; + cl_object KEY_VARS[4]; - if (narg < 1) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start'; - KEYS[1]=@':end'; - cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + if (narg < 1) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start'; + KEYS[1]=@':end'; + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); - strng = cl_string(strng); - strng = cl_copy_seq(strng); - if (kstartp == ECL_NIL) - kstart = ecl_make_fixnum(0); - p = ecl_vector_start_end(fun, strng, kstart, kend); - b = TRUE; + strng = cl_string(strng); + strng = cl_copy_seq(strng); + if (kstartp == ECL_NIL) + kstart = ecl_make_fixnum(0); + p = ecl_vector_start_end(fun, strng, kstart, kend); + b = TRUE; #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(strng)) { - for (i = p.start; i < p.end; i++) - strng->string.self[i] = (*casefun)(strng->string.self[i], &b); - } else + if (ECL_EXTENDED_STRING_P(strng)) { + for (i = p.start; i < p.end; i++) + strng->string.self[i] = (*casefun)(strng->string.self[i], &b); + } else #endif - for (i = p.start; i < p.end; i++) - strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); - @(return strng) + for (i = p.start; i < p.end; i++) + strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); + @(return strng); #undef kstartp #undef kstart #undef kend @@ -775,121 +776,121 @@ string_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) static ecl_character char_upcase(ecl_character c, bool *bp) { - return ecl_char_upcase(c); + return ecl_char_upcase(c); } @(defun string-upcase (&rest args) -@ - return string_case(narg, @[string-upcase], char_upcase, args); -@) + @ + return string_case(narg, @[string-upcase], char_upcase, args); + @) static ecl_character char_downcase(ecl_character c, bool *bp) { - return ecl_char_downcase(c); + return ecl_char_downcase(c); } @(defun string-downcase (&rest args) -@ - return string_case(narg, @[string-downcase], char_downcase, args); -@) + @ + return string_case(narg, @[string-downcase], char_downcase, args); + @) static ecl_character char_capitalize(ecl_character c, bool *bp) { - if (ecl_lower_case_p(c)) { - if (*bp) - c = ecl_char_upcase(c); - *bp = FALSE; - } else if (ecl_upper_case_p(c)) { - if (!*bp) - c = ecl_char_downcase(c); - *bp = FALSE; - } else { - *bp = !ecl_alphanumericp(c); - } - return c; + if (ecl_lower_case_p(c)) { + if (*bp) + c = ecl_char_upcase(c); + *bp = FALSE; + } else if (ecl_upper_case_p(c)) { + if (!*bp) + c = ecl_char_downcase(c); + *bp = FALSE; + } else { + *bp = !ecl_alphanumericp(c); + } + return c; } @(defun string-capitalize (&rest args) -@ - return string_case(narg, @[string-capitalize], char_capitalize, args); -@) + @ + return string_case(narg, @[string-capitalize], char_capitalize, args); + @) static cl_object nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) { - cl_object strng = ecl_va_arg(ARGS); - cl_index_pair p; - cl_index i; - bool b; - cl_object KEYS[2]; + cl_object strng = ecl_va_arg(ARGS); + cl_index_pair p; + cl_index i; + bool b; + cl_object KEYS[2]; #define kstart KEY_VARS[0] #define kend KEY_VARS[1] #define kstartp KEY_VARS[2] - cl_object KEY_VARS[4]; + cl_object KEY_VARS[4]; - if (narg < 1) FEwrong_num_arguments_anonym(); - KEYS[0]=@':start'; - KEYS[1]=@':end'; - cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + if (narg < 1) FEwrong_num_arguments_anonym(); + KEYS[0]=@':start'; + KEYS[1]=@':end'; + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); - if (ecl_unlikely(!ECL_STRINGP(strng))) - FEwrong_type_nth_arg(fun, 1, strng, @[string]); - if (kstartp == ECL_NIL) - kstart = ecl_make_fixnum(0); - p = ecl_vector_start_end(fun, strng, kstart, kend); - b = TRUE; + if (ecl_unlikely(!ECL_STRINGP(strng))) + FEwrong_type_nth_arg(fun, 1, strng, @[string]); + if (kstartp == ECL_NIL) + kstart = ecl_make_fixnum(0); + p = ecl_vector_start_end(fun, strng, kstart, kend); + b = TRUE; #ifdef ECL_UNICODE - if (ECL_EXTENDED_STRING_P(strng)) { - for (i = p.start; i < p.end; i++) - strng->string.self[i] = (*casefun)(strng->string.self[i], &b); - } else + if (ECL_EXTENDED_STRING_P(strng)) { + for (i = p.start; i < p.end; i++) + strng->string.self[i] = (*casefun)(strng->string.self[i], &b); + } else #endif - for (i = p.start; i < p.end; i++) - strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); - @(return strng) + for (i = p.start; i < p.end; i++) + strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b); + @(return strng); #undef kstartp #undef kstart #undef kend } @(defun nstring-upcase (&rest args) -@ - return nstring_case(narg, @'nstring-upcase', char_upcase, args); -@) + @ + return nstring_case(narg, @'nstring-upcase', char_upcase, args); + @) @(defun nstring-downcase (&rest args) -@ - return nstring_case(narg, @'nstring-downcase', char_downcase, args); -@) + @ + return nstring_case(narg, @'nstring-downcase', char_downcase, args); + @) @(defun nstring-capitalize (&rest args) -@ - return nstring_case(narg, @'nstring-capitalize', char_capitalize, args); -@) + @ + return nstring_case(narg, @'nstring-capitalize', char_capitalize, args); + @) @(defun si::base-string-concatenate (&rest args) - cl_index l; - int i; - cl_object output; -@ - /* Compute final size and store NONEMPTY coerced strings. */ - for (i = 0, l = 0; i < narg; i++) { - cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); - if (s->base_string.fillp) { - ECL_STACK_PUSH(the_env, s); - l += s->base_string.fillp; - } - } - /* Do actual copying by recovering those strings */ - output = ecl_alloc_simple_base_string(l); - while (l) { - cl_object s = ECL_STACK_POP_UNSAFE(the_env); - size_t bytes = s->base_string.fillp; - l -= bytes; - memcpy(output->base_string.self + l, s->base_string.self, bytes); - } - @(return output); -@) + cl_index l; + int i; + cl_object output; + @ + /* Compute final size and store NONEMPTY coerced strings. */ + for (i = 0, l = 0; i < narg; i++) { + cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); + if (s->base_string.fillp) { + ECL_STACK_PUSH(the_env, s); + l += s->base_string.fillp; + } + } + /* Do actual copying by recovering those strings */ + output = ecl_alloc_simple_base_string(l); + while (l) { + cl_object s = ECL_STACK_POP_UNSAFE(the_env); + size_t bytes = s->base_string.fillp; + l -= bytes; + memcpy(output->base_string.self + l, s->base_string.self, bytes); + } + @(return output); + @) diff --git a/src/c/structure.d b/src/c/structure.d index 12516961b..f8638b1f6 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - structure.c -- Structure interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * structure.d - structure interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,65 +21,65 @@ static bool structure_subtypep(cl_object x, cl_object y) { - if (ECL_CLASS_NAME(x) == y) { - return TRUE; - } else { - cl_object superiors = ECL_CLASS_SUPERIORS(x); - loop_for_on_unsafe(superiors) { - if (structure_subtypep(ECL_CONS_CAR(superiors), y)) - return TRUE; - } end_loop_for_on_unsafe(superiors); - return FALSE; - } + if (ECL_CLASS_NAME(x) == y) { + return TRUE; + } else { + cl_object superiors = ECL_CLASS_SUPERIORS(x); + loop_for_on_unsafe(superiors) { + if (structure_subtypep(ECL_CONS_CAR(superiors), y)) + return TRUE; + } end_loop_for_on_unsafe(superiors); + return FALSE; + } } cl_object si_structure_subtype_p(cl_object x, cl_object y) { - @(return ((ecl_t_of(x) == T_STRUCTURE - && structure_subtypep(ECL_STRUCT_TYPE(x), y)) ? ECL_T : ECL_NIL)) + @(return ((ecl_t_of(x) == T_STRUCTURE + && structure_subtypep(ECL_STRUCT_TYPE(x), y)) ? ECL_T : ECL_NIL)); } @(defun si::make-structure (type &rest args) - cl_object x; - int i; -@ - x = ecl_alloc_object(T_STRUCTURE); - ECL_STRUCT_TYPE(x) = type; - ECL_STRUCT_SLOTS(x) = NULL; /* for GC sake */ - ECL_STRUCT_LENGTH(x) = --narg; - ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); - x->instance.sig = ECL_UNBOUND; - if (narg >= ECL_SLOTS_LIMIT) - FEerror("Limit on structure size exceeded: ~S slots requested.", - 1, ecl_make_fixnum(narg)); - for (i = 0; i < narg; i++) - ECL_STRUCT_SLOT(x, i) = ecl_va_arg(args); - @(return x) -@) + cl_object x; + int i; + @ + x = ecl_alloc_object(T_STRUCTURE); + ECL_STRUCT_TYPE(x) = type; + ECL_STRUCT_SLOTS(x) = NULL; /* for GC sake */ + ECL_STRUCT_LENGTH(x) = --narg; + ECL_STRUCT_SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); + x->instance.sig = ECL_UNBOUND; + if (narg >= ECL_SLOTS_LIMIT) + FEerror("Limit on structure size exceeded: ~S slots requested.", + 1, ecl_make_fixnum(narg)); + for (i = 0; i < narg; i++) + ECL_STRUCT_SLOT(x, i) = ecl_va_arg(args); + @(return x); + @) #define ecl_copy_structure si_copy_instance cl_object cl_copy_structure(cl_object s) { - switch (ecl_t_of(s)) { - case t_instance: - s = ecl_copy_structure(s); - break; - case t_list: + switch (ecl_t_of(s)) { + case t_instance: + s = ecl_copy_structure(s); + break; + case t_list: #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - case t_bitvector: - case t_vector: - s = cl_copy_seq(s); - break; - default: - FEwrong_type_only_arg(@[copy-structure], s, @[structure]); - } - @(return s) + case t_base_string: + case t_bitvector: + case t_vector: + s = cl_copy_seq(s); + break; + default: + FEwrong_type_only_arg(@[copy-structure], s, @[structure]); + } + @(return s); } @@ -92,57 +87,57 @@ cl_copy_structure(cl_object s) cl_object si_structure_name(cl_object s) { - if (ecl_unlikely(Null(si_structurep(s)))) - FEwrong_type_only_arg(@[si::structure-name], s, @[structure]); - @(return ECL_STRUCT_NAME(s)) + if (ecl_unlikely(Null(si_structurep(s)))) + FEwrong_type_only_arg(@[si::structure-name], s, @[structure]); + @(return ECL_STRUCT_NAME(s)); } cl_object si_structure_ref(cl_object x, cl_object type, cl_object index) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); - @(return ECL_STRUCT_SLOT(x, ecl_fixnum(index))) + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); + @(return ECL_STRUCT_SLOT(x, ecl_fixnum(index))); } cl_object ecl_structure_ref(cl_object x, cl_object type, int n) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); - return(ECL_STRUCT_SLOT(x, n)); + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-ref], 1, x, type); + return(ECL_STRUCT_SLOT(x, n)); } cl_object si_structure_set(cl_object x, cl_object type, cl_object index, cl_object val) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); - ECL_STRUCT_SLOT(x, ecl_fixnum(index)) = val; - @(return val) + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); + ECL_STRUCT_SLOT(x, ecl_fixnum(index)) = val; + @(return val); } cl_object ecl_structure_set(cl_object x, cl_object type, int n, cl_object v) { - if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || - !structure_subtypep(ECL_STRUCT_TYPE(x), type))) - FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); - ECL_STRUCT_SLOT(x, n) = v; - return(v); + if (ecl_unlikely(ecl_t_of(x) != T_STRUCTURE || + !structure_subtypep(ECL_STRUCT_TYPE(x), type))) + FEwrong_type_nth_arg(@[si::structure-set], 1, x, type); + ECL_STRUCT_SLOT(x, n) = v; + return(v); } cl_object si_structurep(cl_object s) { - if (ECL_INSTANCEP(s) && - structure_subtypep(ECL_CLASS_OF(s), @'structure-object')) - return ECL_T; - else - return ECL_NIL; + if (ECL_INSTANCEP(s) && + structure_subtypep(ECL_CLASS_OF(s), @'structure-object')) + return ECL_T; + else + return ECL_NIL; } diff --git a/src/c/symbol.d b/src/c/symbol.d index f934d59b6..4060ebee6 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -1,85 +1,77 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - symbol.d -- Symbols. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * symbol.d - symbols + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include #include -/******************************* ------- ******************************/ -/* FIXME! CURRENTLY SYMBOLS ARE RESTRICTED TO HAVE NON-UNICODE NAMES */ - cl_object ecl_symbol_package(cl_object s) { - if (Null(s)) - return ECL_NIL_SYMBOL->symbol.hpack; - if (ecl_t_of(s) == t_symbol) - return s->symbol.hpack; - FEwrong_type_nth_arg(@[symbol-package], 1, s, @[symbol]); + if (Null(s)) + return ECL_NIL_SYMBOL->symbol.hpack; + if (ecl_t_of(s) == t_symbol) + return s->symbol.hpack; + FEwrong_type_nth_arg(@[symbol-package], 1, s, @[symbol]); } int ecl_symbol_type(cl_object s) { - if (Null(s)) - return ECL_NIL_SYMBOL->symbol.stype; - if (ecl_t_of(s) == t_symbol) - return s->symbol.stype; - FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); + if (Null(s)) + return ECL_NIL_SYMBOL->symbol.stype; + if (ecl_t_of(s) == t_symbol) + return s->symbol.stype; + FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); } void ecl_symbol_type_set(cl_object s, int type) { - if (Null(s)) { - ECL_NIL_SYMBOL->symbol.stype = type; - return; - } - if (ecl_t_of(s) == t_symbol) { - s->symbol.stype = type; - return; - } - FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); + if (Null(s)) { + ECL_NIL_SYMBOL->symbol.stype = type; + return; + } + if (ecl_t_of(s) == t_symbol) { + s->symbol.stype = type; + return; + } + FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); } cl_object ecl_symbol_name(cl_object s) { - if (Null(s)) { - return ECL_NIL_SYMBOL->symbol.name; - } - if (ecl_t_of(s) == t_symbol) { - return s->symbol.name; - } - FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); + if (Null(s)) { + return ECL_NIL_SYMBOL->symbol.name; + } + if (ecl_t_of(s) == t_symbol) { + return s->symbol.name; + } + FEwrong_type_nth_arg(@[symbol-name], 1, s, @[symbol]); } static cl_object * ecl_symbol_plist(cl_object s) { - if (Null(s)) { - return &ECL_NIL_SYMBOL->symbol.plist; - } - if (ecl_t_of(s) == t_symbol) { - return &s->symbol.plist; - } - FEwrong_type_nth_arg(@[symbol-plist], 1, s, @[symbol]); + if (Null(s)) { + return &ECL_NIL_SYMBOL->symbol.plist; + } + if (ecl_t_of(s) == t_symbol) { + return &s->symbol.plist; + } + FEwrong_type_nth_arg(@[symbol-plist], 1, s, @[symbol]); } /**********************************************************************/ @@ -89,394 +81,394 @@ static void FEtype_error_plist(cl_object x) /*__attribute__((noreturn))*/; cl_object cl_make_symbol(cl_object str) { - cl_object x; - /* INV: In several places it is assumed that we copy the string! */ - switch (ecl_t_of(str)) { + cl_object x; + /* INV: In several places it is assumed that we copy the string! */ + switch (ecl_t_of(str)) { #ifdef ECL_UNICODE - case t_string: - if (!ecl_fits_in_base_string(str)) { - str = cl_copy_seq(str); - } else { - str = si_copy_to_simple_base_string(str); - } - break; + case t_string: + if (!ecl_fits_in_base_string(str)) { + str = cl_copy_seq(str); + } else { + str = si_copy_to_simple_base_string(str); + } + break; #endif - case t_base_string: - str = si_copy_to_simple_base_string(str); - break; - default: - FEwrong_type_nth_arg(@[make-symbol],1,str,@[string]); - } - x = ecl_alloc_object(t_symbol); - x->symbol.name = str; - x->symbol.dynamic = 0; + case t_base_string: + str = si_copy_to_simple_base_string(str); + break; + default: + FEwrong_type_nth_arg(@[make-symbol],1,str,@[string]); + } + x = ecl_alloc_object(t_symbol); + x->symbol.name = str; + x->symbol.dynamic = 0; #ifdef ECL_THREADS - x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif /* */ - ECL_SET(x,OBJNULL); - ECL_SYM_FUN(x) = ECL_NIL; - x->symbol.plist = ECL_NIL; - x->symbol.hpack = ECL_NIL; - x->symbol.stype = ecl_stp_ordinary; - @(return x) + ECL_SET(x,OBJNULL); + ECL_SYM_FUN(x) = ECL_NIL; + x->symbol.plist = ECL_NIL; + x->symbol.hpack = ECL_NIL; + x->symbol.stype = ecl_stp_ordinary; + @(return x); } /* - ecl_make_keyword(s) makes a keyword from C string s. + ecl_make_keyword(s) makes a keyword from C string s. */ cl_object ecl_make_keyword(const char *s) { - cl_object x = _ecl_intern(s, cl_core.keyword_package); - /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ - return x; + cl_object x = _ecl_intern(s, cl_core.keyword_package); + /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ + return x; } cl_object ecl_make_symbol(const char *s, const char *p) { - cl_object package = ecl_find_package(p); - cl_object x = _ecl_intern(s, package); - /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ - return x; + cl_object package = ecl_find_package(p); + cl_object x = _ecl_intern(s, package); + /* cl_export(x, keyword_package); this is implicit in ecl_intern() */ + return x; } cl_object ecl_symbol_value(cl_object s) { - if (Null(s)) { - return s; - } else { - /* FIXME: Should we check symbol type? */ - const cl_env_ptr the_env = ecl_process_env(); - cl_object value = ECL_SYM_VAL(the_env, s); - unlikely_if (value == OBJNULL) - FEunbound_variable(s); - return value; - } + if (Null(s)) { + return s; + } else { + /* FIXME: Should we check symbol type? */ + const cl_env_ptr the_env = ecl_process_env(); + cl_object value = ECL_SYM_VAL(the_env, s); + unlikely_if (value == OBJNULL) + FEunbound_variable(s); + return value; + } } static void FEtype_error_plist(cl_object x) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a valid property list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', @'si::property-list', - @':datum', x); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a valid property list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', @'si::property-list', + @':datum', x); } cl_object ecl_getf(cl_object place, cl_object indicator, cl_object deflt) { - cl_object l; + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ECL_CONS_CAR(l) == indicator) - return ECL_CONS_CAR(cdr_l); - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - return(deflt); + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ECL_CONS_CAR(l) == indicator) + return ECL_CONS_CAR(cdr_l); + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + return(deflt); } cl_object ecl_get(cl_object s, cl_object p, cl_object d) { - return ecl_getf(*ecl_symbol_plist(s), p, d); + return ecl_getf(*ecl_symbol_plist(s), p, d); } /* - (SI:PUT-F plist value indicator) - returns the new property list with value for property indicator. - It will be used in SETF for GETF. + (SI:PUT-F plist value indicator) + returns the new property list with value for property indicator. + It will be used in SETF for GETF. */ cl_object si_put_f(cl_object place, cl_object value, cl_object indicator) { - cl_object l; + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - /* This loop guarantees finishing for circular lists */ - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ECL_CONS_CAR(l) == indicator) { - ECL_RPLACA(cdr_l, value); - @(return place); - } - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - place = CONS(value, place); - @(return CONS(indicator, place)); + /* This loop guarantees finishing for circular lists */ + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ECL_CONS_CAR(l) == indicator) { + ECL_RPLACA(cdr_l, value); + @(return place); + } + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + place = CONS(value, place); + @(return CONS(indicator, place)); } /* - Remf(p, i) removes property i - from the property list pointed by p, - which is a pointer to an cl_object. - The returned value of remf(p, i) is: + Remf(p, i) removes property i + from the property list pointed by p, + which is a pointer to an cl_object. + The returned value of remf(p, i) is: - TRUE if the property existed - FALSE otherwise. + TRUE if the property existed + FALSE otherwise. */ static bool remf(cl_object *place, cl_object indicator) { - cl_object l = *place, tail = ECL_NIL; - while (!Null(l)) { - cl_object ind; - if (!LISTP(l)) - FEtype_error_plist(*place); - ind = ECL_CONS_CAR(l); - l = ECL_CONS_CDR(l); - if (!CONSP(l)) - FEtype_error_plist(*place); - if (ind == indicator) { - l = ECL_CONS_CDR(l); - if (Null(tail)) - *place = l; - else - ECL_RPLACD(tail, l); - return TRUE; - } - tail = l; - l = ECL_CONS_CDR(l); - } - return FALSE; + cl_object l = *place, tail = ECL_NIL; + while (!Null(l)) { + cl_object ind; + if (!LISTP(l)) + FEtype_error_plist(*place); + ind = ECL_CONS_CAR(l); + l = ECL_CONS_CDR(l); + if (!CONSP(l)) + FEtype_error_plist(*place); + if (ind == indicator) { + l = ECL_CONS_CDR(l); + if (Null(tail)) + *place = l; + else + ECL_RPLACD(tail, l); + return TRUE; + } + tail = l; + l = ECL_CONS_CDR(l); + } + return FALSE; } bool ecl_keywordp(cl_object s) { - return (ecl_t_of(s) == t_symbol) && (s->symbol.hpack == cl_core.keyword_package); + return (ecl_t_of(s) == t_symbol) && (s->symbol.hpack == cl_core.keyword_package); } @(defun get (sym indicator &optional deflt) - cl_object *plist; -@ - plist = ecl_symbol_plist(sym); - @(return ecl_getf(*plist, indicator, deflt)) -@) + cl_object *plist; + @ + plist = ecl_symbol_plist(sym); + @(return ecl_getf(*plist, indicator, deflt)); + @) cl_object cl_remprop(cl_object sym, cl_object prop) { - cl_object *plist = ecl_symbol_plist(sym); - @(return (remf(plist, prop)? ECL_T: ECL_NIL)) + cl_object *plist = ecl_symbol_plist(sym); + @(return (remf(plist, prop)? ECL_T: ECL_NIL)); } cl_object cl_symbol_plist(cl_object sym) { - @(return *ecl_symbol_plist(sym)) + @(return *ecl_symbol_plist(sym)); } @(defun getf (place indicator &optional deflt) -@ - @(return ecl_getf(place, indicator, deflt)) -@) + @ + @(return ecl_getf(place, indicator, deflt)); + @) cl_object cl_get_properties(cl_object place, cl_object indicator_list) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object l; + const cl_env_ptr the_env = ecl_process_env(); + cl_object l; #ifdef ECL_SAFE - assert_type_proper_list(place); + assert_type_proper_list(place); #endif - for (l = place; CONSP(l); ) { - cl_object cdr_l = ECL_CONS_CDR(l); - if (!CONSP(cdr_l)) - break; - if (ecl_member_eq(ECL_CONS_CAR(l), indicator_list)) - ecl_return3(the_env,ECL_CONS_CAR(l),ECL_CONS_CAR(cdr_l),l); - l = ECL_CONS_CDR(cdr_l); - } - if (l != ECL_NIL) - FEtype_error_plist(place); - ecl_return3(the_env, ECL_NIL, ECL_NIL, ECL_NIL); + for (l = place; CONSP(l); ) { + cl_object cdr_l = ECL_CONS_CDR(l); + if (!CONSP(cdr_l)) + break; + if (ecl_member_eq(ECL_CONS_CAR(l), indicator_list)) + ecl_return3(the_env,ECL_CONS_CAR(l),ECL_CONS_CAR(cdr_l),l); + l = ECL_CONS_CDR(cdr_l); + } + if (l != ECL_NIL) + FEtype_error_plist(place); + ecl_return3(the_env, ECL_NIL, ECL_NIL, ECL_NIL); } cl_object cl_symbol_name(cl_object x) { - ecl_return1(ecl_process_env(), ecl_symbol_name(x)); + ecl_return1(ecl_process_env(), ecl_symbol_name(x)); } @(defun copy_symbol (sym &optional cp &aux x) -@ - if (Null(sym)) - sym = ECL_NIL_SYMBOL; - x = cl_make_symbol(ecl_symbol_name(sym)); - if (!Null(cp)) { - x->symbol.dynamic = 0; - x->symbol.stype = sym->symbol.stype; - x->symbol.value = sym->symbol.value; - x->symbol.gfdef = sym->symbol.gfdef; - x->symbol.plist = cl_copy_list(sym->symbol.plist); + @ + if (Null(sym)) + sym = ECL_NIL_SYMBOL; + x = cl_make_symbol(ecl_symbol_name(sym)); + if (!Null(cp)) { + x->symbol.dynamic = 0; + x->symbol.stype = sym->symbol.stype; + x->symbol.value = sym->symbol.value; + x->symbol.gfdef = sym->symbol.gfdef; + x->symbol.plist = cl_copy_list(sym->symbol.plist); #ifdef ECL_THREADS - x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; + x->symbol.binding = ECL_MISSING_SPECIAL_BINDING; #endif - /* FIXME!!! We should also copy the system property list */ - } - @(return x) -@) + /* FIXME!!! We should also copy the system property list */ + } + @(return x); + @) @(defun gensym (&optional (prefix cl_core.gensym_prefix)) - cl_type t; - cl_object counter, output; - bool increment; -@ { - if (ecl_stringp(prefix)) { - counter = ECL_SYM_VAL(the_env, @'*gensym-counter*'); - increment = 1; - } else if ((t = ecl_t_of(prefix)) == t_fixnum || t == t_bignum) { - counter = prefix; - prefix = cl_core.gensym_prefix; - increment = 0; - } else { - FEwrong_type_nth_arg(@[gensym],2,prefix, - cl_list(3, @'or', @'string', @'integer')); - } - output = ecl_make_string_output_stream(64, 1); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); - si_write_ugly_object(prefix, output); - si_write_ugly_object(counter, output); - ecl_bds_unwind_n(the_env, 4); - output = cl_make_symbol(cl_get_output_stream_string(output)); - if (increment) - ECL_SETQ(the_env, @'*gensym-counter*',ecl_one_plus(counter)); - @(return output); -} @) + cl_type t; + cl_object counter, output; + bool increment; + @ { + if (ecl_stringp(prefix)) { + counter = ECL_SYM_VAL(the_env, @'*gensym-counter*'); + increment = 1; + } else if ((t = ecl_t_of(prefix)) == t_fixnum || t == t_bignum) { + counter = prefix; + prefix = cl_core.gensym_prefix; + increment = 0; + } else { + FEwrong_type_nth_arg(@[gensym],2,prefix, + cl_list(3, @'or', @'string', @'integer')); + } + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); + si_write_ugly_object(prefix, output); + si_write_ugly_object(counter, output); + ecl_bds_unwind_n(the_env, 4); + output = cl_make_symbol(cl_get_output_stream_string(output)); + if (increment) + ECL_SETQ(the_env, @'*gensym-counter*',ecl_one_plus(counter)); + @(return output); + } @) @(defun gentemp (&optional (prefix cl_core.gentemp_prefix) (pack ecl_current_package())) - cl_object output, s; - int intern_flag; -@ - unlikely_if (!ECL_STRINGP(prefix)) - FEwrong_type_nth_arg(@[gentemp], 1, prefix, @[string]); - pack = si_coerce_to_package(pack); -ONCE_MORE: - output = ecl_make_string_output_stream(64, 1); - ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); - ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); - si_write_ugly_object(prefix, output); - si_write_ugly_object(cl_core.gentemp_counter, output); - ecl_bds_unwind_n(the_env, 4); - cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter); - s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag); - if (intern_flag != 0) - goto ONCE_MORE; - @(return s) -@) + cl_object output, s; + int intern_flag; + @ + unlikely_if (!ECL_STRINGP(prefix)) + FEwrong_type_nth_arg(@[gentemp], 1, prefix, @[string]); + pack = si_coerce_to_package(pack); + ONCE_MORE: + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL); + ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); + ecl_bds_bind(the_env, @'*print-radix*', ECL_NIL); + si_write_ugly_object(prefix, output); + si_write_ugly_object(cl_core.gentemp_counter, output); + ecl_bds_unwind_n(the_env, 4); + cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter); + s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag); + if (intern_flag != 0) + goto ONCE_MORE; + @(return s); + @) cl_object cl_symbol_package(cl_object sym) { - @(return ecl_symbol_package(sym)) + @(return ecl_symbol_package(sym)); } cl_object cl_keywordp(cl_object sym) { - @(return (ecl_keywordp(sym)? ECL_T: ECL_NIL)) + @(return (ecl_keywordp(sym)? ECL_T: ECL_NIL)); } /* - (SI:REM-F plist indicator) returns two values: + (SI:REM-F plist indicator) returns two values: - * the new property list - in which property indcator is removed + * the new property list + in which property indcator is removed - * T if really removed - NIL otherwise. + * T if really removed + NIL otherwise. - It will be used for macro REMF. + It will be used for macro REMF. */ cl_object si_rem_f(cl_object plist, cl_object indicator) { - cl_env_ptr the_env = ecl_process_env(); - bool found = remf(&plist, indicator); - ecl_return2(the_env, plist, (found? ECL_T : ECL_NIL)); + cl_env_ptr the_env = ecl_process_env(); + bool found = remf(&plist, indicator); + ecl_return2(the_env, plist, (found? ECL_T : ECL_NIL)); } cl_object si_set_symbol_plist(cl_object sym, cl_object plist) { - *ecl_symbol_plist(sym) = plist; - @(return plist) + *ecl_symbol_plist(sym) = plist; + @(return plist); } cl_object si_putprop(cl_object sym, cl_object value, cl_object indicator) { - cl_object *plist = ecl_symbol_plist(sym); - *plist = si_put_f(*plist, value, indicator); - @(return value) + cl_object *plist = ecl_symbol_plist(sym); + *plist = si_put_f(*plist, value, indicator); + @(return value); } /* Added for defstruct. Beppe */ @(defun si::put-properties (sym &rest ind_values) -@ - while (--narg >= 2) { - cl_object prop = ecl_va_arg(ind_values); - si_putprop(sym, ecl_va_arg(ind_values), prop); - narg--; - } - @(return sym) -@) + @ + while (--narg >= 2) { + cl_object prop = ecl_va_arg(ind_values); + si_putprop(sym, ecl_va_arg(ind_values), prop); + narg--; + } + @(return sym); + @) cl_object @si::*make-special(cl_object sym) { - int type = ecl_symbol_type(sym); - if (type & ecl_stp_constant) - FEerror("~S is a constant.", 1, sym); - ecl_symbol_type_set(sym, type | ecl_stp_special); - cl_remprop(sym, @'si::symbol-macro'); - @(return sym) + int type = ecl_symbol_type(sym); + if (type & ecl_stp_constant) + FEerror("~S is a constant.", 1, sym); + ecl_symbol_type_set(sym, type | ecl_stp_special); + cl_remprop(sym, @'si::symbol-macro'); + @(return sym); } cl_object @si::*make-constant(cl_object sym, cl_object val) { - int type = ecl_symbol_type(sym); - if (type & ecl_stp_special) - FEerror("The argument ~S to DEFCONSTANT is a special variable.", - 1, sym); - ecl_symbol_type_set(sym, type | ecl_stp_constant); - ECL_SET(sym, val); - @(return sym) + int type = ecl_symbol_type(sym); + if (type & ecl_stp_special) + FEerror("The argument ~S to DEFCONSTANT is a special variable.", + 1, sym); + ecl_symbol_type_set(sym, type | ecl_stp_constant); + ECL_SET(sym, val); + @(return sym); } void ecl_defvar(cl_object sym, cl_object val) { - si_safe_eval(3, cl_list(3, @'defvar', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); + si_safe_eval(3, cl_list(3, @'defvar', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); } void ecl_defparameter(cl_object sym, cl_object val) { - si_safe_eval(3, cl_list(3, @'defparameter', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); + si_safe_eval(3, cl_list(3, @'defparameter', sym, cl_list(2, @'quote', val)), ECL_NIL, ECL_NIL); } diff --git a/src/c/tcp.d b/src/c/tcp.d index ff520b7c9..109486b95 100644 --- a/src/c/tcp.d +++ b/src/c/tcp.d @@ -1,19 +1,15 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ - -/* tcp.c -- stream interface to TCP */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL is free software; you can redistribute it and/or modify it - under the terms of the GNU General Library 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. -*/ + * tcp.d - stream interface to TCP + * + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -50,14 +46,14 @@ extern int errno; #if defined(ECL_MS_WINDOWS_HOST) WSADATA wsadata; int wsock_initialized = 0; -#define INIT_TCP \ - if ( !wsock_initialized ) \ - { \ - if ( WSAStartup( MAKEWORD( 2, 2 ), &wsadata ) != NO_ERROR ) \ - FEerror( "Unable to initialize Windows socket library.", 0 ); \ - else \ - wsock_initialized = 1; \ - } +#define INIT_TCP \ + if ( !wsock_initialized ) \ + { \ + if ( WSAStartup( MAKEWORD( 2, 2 ), &wsadata ) != NO_ERROR ) \ + FEerror( "Unable to initialize Windows socket library.", 0 ); \ + else \ + wsock_initialized = 1; \ + } #else #define INIT_TCP #endif @@ -66,11 +62,11 @@ void ecl_tcp_close_all(void) { #if defined(ECL_MS_WINDOWS_HOST) - if ( wsock_initialized ) - { - WSACleanup(); - wsock_initialized = 0; - } + if ( wsock_initialized ) + { + WSACleanup(); + wsock_initialized = 0; + } #endif } @@ -97,30 +93,30 @@ int connect_to_server(char *host, int port) INIT_TCP - /* Get the statistics on the specified host. */ - if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { - if ((host_ptr = gethostbyname(host)) == NULL) { - /* No such host! */ - errno = EINVAL; - return(0); - } - /* Check the address type for an internet host. */ - if (host_ptr->h_addrtype != AF_INET) { - /* Not an Internet host! */ + /* Get the statistics on the specified host. */ + if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { + if ((host_ptr = gethostbyname(host)) == NULL) { + /* No such host! */ + errno = EINVAL; + return(0); + } + /* Check the address type for an internet host. */ + if (host_ptr->h_addrtype != AF_INET) { + /* Not an Internet host! */ #if defined(ECL_MS_WINDOWS_HOST) - errno = WSAEPROTOTYPE; + errno = WSAEPROTOTYPE; #else - errno = EPROTOTYPE; + errno = EPROTOTYPE; #endif - return(0); - } - /* Set up the socket data. */ - inaddr.sin_family = host_ptr->h_addrtype; - memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, - sizeof(inaddr.sin_addr)); - } - else - inaddr.sin_family = AF_INET; + return(0); + } + /* Set up the socket data. */ + inaddr.sin_family = host_ptr->h_addrtype; + memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, + sizeof(inaddr.sin_addr)); + } + else + inaddr.sin_family = AF_INET; addr = (struct sockaddr *) &inaddr; addrlen = sizeof (struct sockaddr_in); @@ -176,25 +172,25 @@ create_server_port(int port) INIT_TCP - /* - * Open the network connection. - */ - if ((request = socket(AF_INET, SOCK_STREAM, 0)) < 0) { - return(0); /* errno set by system call. */ - } + /* + * Open the network connection. + */ + if ((request = socket(AF_INET, SOCK_STREAM, 0)) < 0) { + return(0); /* errno set by system call. */ + } #ifdef SO_REUSEADDR - /* Necesary to restart the server without a reboot */ + /* Necesary to restart the server without a reboot */ #if defined(ECL_MS_WINDOWS_HOST) - { - char one = 1; - setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(char)); - } + { + char one = 1; + setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(char)); + } #else - { - int one = 1; - setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(int)); - } + { + int one = 1; + setsockopt(request, SOL_SOCKET, SO_REUSEADDR, &one, sizeof(int)); + } #endif #endif /* SO_REUSEADDR */ #ifdef TCP_NODELAY @@ -240,14 +236,14 @@ create_server_port(int port) loop: errno = 0; if ((conn = accept(request, (struct sockaddr *)NULL, (int *)NULL)) < 0) - if (errno) { - lwpblockon(active, fp, PD_INPUT); - clearerr(fp); - goto loop; - } else { - fclose(fp); - FElibc_error("Accepting requests", 0); - } + if (errno) { + lwpblockon(active, fp, PD_INPUT); + clearerr(fp); + goto loop; + } else { + fclose(fp); + FElibc_error("Accepting requests", 0); + } fclose(fp); } #else @@ -273,57 +269,58 @@ create_server_port(int port) cl_object si_open_client_stream(cl_object host, cl_object port) { - int fd, p; /* file descriptor */ - cl_object stream; + int fd, p; /* file descriptor */ + cl_object stream; - /* Ensure "host" is a string that we can pass to a C function */ - host = si_copy_to_simple_base_string(host); + /* Ensure "host" is a string that we can pass to a C function */ + host = si_copy_to_simple_base_string(host); - if (ecl_unlikely(!ECL_FIXNUMP(port) || - ecl_fixnum_minusp(port) || - ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { - FEwrong_type_nth_arg(@[si::open-client-stream], 2, port, - ecl_read_from_cstring("(INTEGER 0 65535)")); - } - p = ecl_fixnum(port); + if (ecl_unlikely(!ECL_FIXNUMP(port) || + ecl_fixnum_minusp(port) || + ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { + FEwrong_type_nth_arg(@[si::open-client-stream], 2, port, + ecl_read_from_cstring("(INTEGER 0 65535)")); + } + p = ecl_fixnum(port); - if (host->base_string.fillp > BUFSIZ - 1) - FEerror("~S is a too long file name.", 1, host); + if (host->base_string.fillp > BUFSIZ - 1) + FEerror("~S is a too long file name.", 1, host); - ecl_disable_interrupts(); - fd = connect_to_server((char*)host->base_string.self, ecl_fixnum(port)); - ecl_enable_interrupts(); - - if (fd == 0) - @(return ECL_NIL) + ecl_disable_interrupts(); + fd = connect_to_server((char*)host->base_string.self, ecl_fixnum(port)); + ecl_enable_interrupts(); + if (fd == 0) { + @(return ECL_NIL); + } + #if defined(ECL_MS_WINDOWS_HOST) - stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io_wsock, 8, 0, ECL_NIL); + stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io_wsock, 8, 0, ECL_NIL); #else - stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io, 8, 0, ECL_NIL); + stream = ecl_make_stream_from_fd(host, fd, ecl_smm_io, 8, 0, ECL_NIL); #endif - @(return stream) + @(return stream); } cl_object si_open_server_stream(cl_object port) { - int fd; /* file descriptor */ - cl_index p; + int fd; /* file descriptor */ + cl_index p; - if (ecl_unlikely(!ECL_FIXNUMP(port) || - ecl_fixnum_minusp(port) || - ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { - FEwrong_type_only_arg(@[si::open-client-stream], port, - ecl_read_from_cstring("(INTEGER 0 65535)")); - } - p = ecl_fixnum(port); - ecl_disable_interrupts(); - fd = create_server_port(p); - ecl_enable_interrupts(); + if (ecl_unlikely(!ECL_FIXNUMP(port) || + ecl_fixnum_minusp(port) || + ecl_fixnum_greater(port,ecl_make_fixnum(65536)))) { + FEwrong_type_only_arg(@[si::open-client-stream], port, + ecl_read_from_cstring("(INTEGER 0 65535)")); + } + p = ecl_fixnum(port); + ecl_disable_interrupts(); + fd = create_server_port(p); + ecl_enable_interrupts(); - @(return ((fd == 0)? ECL_NIL : ecl_make_stream_from_fd(ECL_NIL, fd, ecl_smm_io, 8, 0, ECL_NIL))) + @(return ((fd == 0)? ECL_NIL : ecl_make_stream_from_fd(ECL_NIL, fd, ecl_smm_io, 8, 0, ECL_NIL))); } /************************************************************ @@ -334,36 +331,36 @@ cl_object si_open_unix_socket_stream(cl_object path) { #if defined(ECL_MS_WINDOWS_HOST) - FEerror("UNIX socket not supported under Win32 platform", 0); + FEerror("UNIX socket not supported under Win32 platform", 0); #else - int fd; /* file descriptor */ - struct sockaddr_un addr; + int fd; /* file descriptor */ + struct sockaddr_un addr; - if (ecl_unlikely(!ECL_STRINGP(path))) - FEwrong_type_nth_arg(@[si::open-unix-socket-stream], 1, path, - @[string]); + if (ecl_unlikely(!ECL_STRINGP(path))) + FEwrong_type_nth_arg(@[si::open-unix-socket-stream], 1, path, + @[string]); - path = si_coerce_to_base_string(path); - if (path->base_string.fillp > UNIX_MAX_PATH-1) - FEerror("~S is a too long file name.", 1, path); + path = si_coerce_to_base_string(path); + if (path->base_string.fillp > UNIX_MAX_PATH-1) + FEerror("~S is a too long file name.", 1, path); - fd = socket(PF_UNIX, SOCK_STREAM, 0); - if (fd < 0) { - FElibc_error("Unable to create unix socket", 0); - @(return ECL_NIL) - } + fd = socket(PF_UNIX, SOCK_STREAM, 0); + if (fd < 0) { + FElibc_error("Unable to create unix socket", 0); + @(return ECL_NIL); + } - memcpy(addr.sun_path, path->base_string.self, path->base_string.fillp); - addr.sun_path[path->base_string.fillp] = 0; - addr.sun_family = AF_UNIX; + memcpy(addr.sun_path, path->base_string.self, path->base_string.fillp); + addr.sun_path[path->base_string.fillp] = 0; + addr.sun_family = AF_UNIX; - if (connect(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { - close(fd); - FElibc_error("Unable to connect to unix socket ~A", 1, path); - @(return ECL_NIL) - } + if (connect(fd, (struct sockaddr *)&addr, sizeof(addr)) < 0) { + close(fd); + FElibc_error("Unable to connect to unix socket ~A", 1, path); + @(return ECL_NIL); + } - @(return ecl_make_stream_from_fd(path, fd, ecl_smm_io, 8, 0, ECL_NIL)) + @(return ecl_make_stream_from_fd(path, fd, ecl_smm_io, 8, 0, ECL_NIL)); #endif } @@ -373,48 +370,49 @@ si_open_unix_socket_stream(cl_object path) cl_object si_lookup_host_entry(cl_object host_or_address) { - struct hostent *he; - unsigned long l; - char address[4]; - cl_object name, aliases, addresses; - int i; + struct hostent *he; + unsigned long l; + char address[4]; + cl_object name, aliases, addresses; + int i; - INIT_TCP + INIT_TCP - switch (ecl_t_of(host_or_address)) { + switch (ecl_t_of(host_or_address)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - host_or_address = si_copy_to_simple_base_string(host_or_address); - he = gethostbyname((char*)host_or_address->base_string.self); - break; - case t_fixnum: - l = ecl_fixnum(host_or_address); - goto addr; - case t_bignum: - l = _ecl_big_to_ulong(host_or_address); - addr: address[0] = l & 0xFF; - address[1] = (l >> 8) & 0xFF; - address[2] = (l >> 16) & 0xFF; - address[3] = (l >> 24) & 0xFF; - he = gethostbyaddr(&address, 4, AF_INET); - break; - default: - FEerror("LOOKUP-HOST-ENTRY: Number or string expected, got ~S", - 1, host_or_address); - } - if (he == NULL) - @(return ECL_NIL ECL_NIL ECL_NIL) - name = make_base_string_copy(he->h_name); - aliases = ECL_NIL; - for (i = 0; he->h_aliases[i] != 0; i++) - aliases = CONS(make_base_string_copy(he->h_aliases[i]), aliases); - addresses = ECL_NIL; - for (i = 0; he->h_addr_list[i]; i++) { - unsigned long *s = (unsigned long*)(he->h_addr_list[i]); - l = *s; - addresses = CONS(ecl_make_integer(l), addresses); - } - @(return name aliases addresses) + case t_base_string: + host_or_address = si_copy_to_simple_base_string(host_or_address); + he = gethostbyname((char*)host_or_address->base_string.self); + break; + case t_fixnum: + l = ecl_fixnum(host_or_address); + goto addr; + case t_bignum: + l = _ecl_big_to_ulong(host_or_address); + addr: address[0] = l & 0xFF; + address[1] = (l >> 8) & 0xFF; + address[2] = (l >> 16) & 0xFF; + address[3] = (l >> 24) & 0xFF; + he = gethostbyaddr(&address, 4, AF_INET); + break; + default: + FEerror("LOOKUP-HOST-ENTRY: Number or string expected, got ~S", + 1, host_or_address); + } + if (he == NULL) { + @(return ECL_NIL ECL_NIL ECL_NIL); + } + name = make_base_string_copy(he->h_name); + aliases = ECL_NIL; + for (i = 0; he->h_aliases[i] != 0; i++) + aliases = CONS(make_base_string_copy(he->h_aliases[i]), aliases); + addresses = ECL_NIL; + for (i = 0; he->h_addr_list[i]; i++) { + unsigned long *s = (unsigned long*)(he->h_addr_list[i]); + l = *s; + addresses = CONS(ecl_make_integer(l), addresses); + } + @(return name aliases addresses); } diff --git a/src/c/threads/atomic.d b/src/c/threads/atomic.d index a104dc197..f0861ee98 100755 --- a/src/c/threads/atomic.d +++ b/src/c/threads/atomic.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - atomic.d -- atomic operations. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * atomic.d - atomic operations + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -26,44 +21,44 @@ cl_object ecl_atomic_get(cl_object *slot) { - cl_object old; - do { - old = (cl_object)AO_load((AO_t*)slot); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)ECL_NIL)); - return old; + cl_object old; + do { + old = (cl_object)AO_load((AO_t*)slot); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)ECL_NIL)); + return old; } void ecl_atomic_push(cl_object *slot, cl_object c) { - cl_object cons = ecl_list1(c), car; - do { - car = (cl_object)AO_load((AO_t*)slot); - ECL_RPLACD(cons, car); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)car, (AO_t)cons)); + cl_object cons = ecl_list1(c), car; + do { + car = (cl_object)AO_load((AO_t*)slot); + ECL_RPLACD(cons, car); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)car, (AO_t)cons)); } cl_object ecl_atomic_pop(cl_object *slot) { - cl_object cons, rest; - do { - cons = (cl_object)AO_load((AO_t*)slot); - rest = CDR(cons); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)cons, (AO_t)rest)); - return cons; + cl_object cons, rest; + do { + cons = (cl_object)AO_load((AO_t*)slot); + rest = CDR(cons); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)cons, (AO_t)rest)); + return cons; } cl_index ecl_atomic_index_incf(cl_index *slot) { - AO_t old; - AO_t next; - do { - old = AO_load((AO_t*)slot); - next = old+1; - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)next)); - return (cl_index)next; + AO_t old; + AO_t next; + do { + old = AO_load((AO_t*)slot); + next = old+1; + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)old, (AO_t)next)); + return (cl_index)next; } #endif /* ECL_THREADS */ diff --git a/src/c/threads/barrier.d b/src/c/threads/barrier.d index 78cacdd1d..eb4053c82 100755 --- a/src/c/threads/barrier.d +++ b/src/c/threads/barrier.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - barrier.d -- wait barriers -*/ -/* - Copyright (c) 2012, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * barrier.d - wait barriers + * + * Copyright (c) 2012 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -23,149 +18,147 @@ static ECL_INLINE void FEerror_not_a_barrier(cl_object barrier) { - FEwrong_type_argument(@'mp::barrier', barrier); + FEwrong_type_argument(@'mp::barrier', barrier); } cl_object ecl_make_barrier(cl_object name, cl_index count) { - cl_object output = ecl_alloc_object(t_barrier); - output->barrier.name = name; - output->barrier.arrivers_count = count; - output->barrier.count = count; - output->barrier.queue_list = ECL_NIL; - output->barrier.queue_spinlock = ECL_NIL; - return output; + cl_object output = ecl_alloc_object(t_barrier); + output->barrier.name = name; + output->barrier.arrivers_count = count; + output->barrier.count = count; + output->barrier.queue_list = ECL_NIL; + output->barrier.queue_spinlock = ECL_NIL; + return output; } @(defun mp::make-barrier (count &key name) -@ - if (count == ECL_T) - count = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); - @(return ecl_make_barrier(name, fixnnint(count))) -@) + @ + if (count == ECL_T) + count = ecl_make_fixnum(MOST_POSITIVE_FIXNUM); + @(return ecl_make_barrier(name, fixnnint(count))); + @) cl_object mp_barrier_name(cl_object barrier) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_return1(env, barrier->barrier.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_return1(env, barrier->barrier.name); } cl_object mp_barrier_count(cl_object barrier) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_return1(env, ecl_make_fixnum(barrier->barrier.count)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_return1(env, ecl_make_fixnum(barrier->barrier.count)); } cl_object mp_barrier_arrivers_count(cl_object barrier) { - cl_fixnum arrivers, count; - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - arrivers = barrier->barrier.arrivers_count; - count = barrier->barrier.count; - if (arrivers < 0) - arrivers = 0; /* Disabled barrier */ - else - arrivers = count - arrivers; - ecl_return1(env, ecl_make_fixnum(arrivers)); + cl_fixnum arrivers, count; + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + arrivers = barrier->barrier.arrivers_count; + count = barrier->barrier.count; + if (arrivers < 0) + arrivers = 0; /* Disabled barrier */ + else + arrivers = count - arrivers; + ecl_return1(env, ecl_make_fixnum(arrivers)); } @(defun mp::barrier-unblock (barrier &key reset_count disable kill_waiting) - int ping_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL; - int kill_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_KILL | ECL_WAKEUP_ALL; -@ - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - if (!Null(reset_count)) - barrier->barrier.count = fixnnint(reset_count); - if (!Null(disable)) - barrier->barrier.arrivers_count = -1; - else - barrier->barrier.arrivers_count = barrier->barrier.count; - ecl_wakeup_waiters(the_env, barrier, - Null(kill_waiting)? ping_flags : kill_flags); - @(return) -@) + int ping_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL; + int kill_flags = ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_KILL | ECL_WAKEUP_ALL; + @ + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + if (!Null(reset_count)) + barrier->barrier.count = fixnnint(reset_count); + if (!Null(disable)) + barrier->barrier.arrivers_count = -1; + else + barrier->barrier.arrivers_count = barrier->barrier.count; + ecl_wakeup_waiters(the_env, barrier, + Null(kill_waiting)? ping_flags : kill_flags); + @(return); + @) static cl_object barrier_wait_condition(cl_env_ptr env, cl_object barrier) { - /* We were signaled */ - if (env->own_process->process.woken_up != ECL_NIL) - return ECL_T; - /* Disabled barrier */ - else if (barrier->barrier.arrivers_count < 0) - return ECL_T; - else - return ECL_NIL; + /* We were signaled */ + if (env->own_process->process.woken_up != ECL_NIL) + return ECL_T; + /* Disabled barrier */ + else if (barrier->barrier.arrivers_count < 0) + return ECL_T; + else + return ECL_NIL; } static cl_fixnum decrement_counter(cl_fixnum *counter) { - /* The logic is as follows: - * - If the counter is negative, we abort. This is a way of - * disabling the counter. - * - Otherwise, we decrease the counter only if it is positive - * - If the counter is currently zero, then we block. This - * situation implies that some other thread is unblocking. - */ - cl_fixnum c; - do { - c = *counter; - if (c < 0) { - return c; - } else if (c > 0) { - if (AO_compare_and_swap_full((AO_t*)counter, - (AO_t)c, (AO_t)(c-1))) - return c; - } - } while (1); + /* The logic is as follows: + * - If the counter is negative, we abort. This is a way of + * disabling the counter. + * - Otherwise, we decrease the counter only if it is positive + * - If the counter is currently zero, then we block. This + * situation implies that some other thread is unblocking. + */ + cl_fixnum c; + do { + c = *counter; + if (c < 0) { + return c; + } else if (c > 0) { + if (AO_compare_and_swap_full((AO_t*)counter, + (AO_t)c, (AO_t)(c-1))) + return c; + } + } while (1); } @(defun mp::barrier-wait (barrier &key) - cl_object output; - cl_fixnum counter; -@ -{ - cl_object own_process = the_env->own_process; + cl_object output; + cl_fixnum counter; + @ { + cl_object own_process = the_env->own_process; - unlikely_if (ecl_t_of(barrier) != t_barrier) { - FEerror_not_a_barrier(barrier); - } - ecl_disable_interrupts_env(the_env); - counter = decrement_counter(&barrier->barrier.arrivers_count); - if (counter == 0) { - print_lock("barrier %p saturated", barrier, barrier); - /* There are (count-1) threads in the queue and we - * are the last one. We thus unblock all threads and - * proceed. */ - mp_barrier_unblock(1, barrier); - ecl_enable_interrupts_env(the_env); - output = @':unblocked'; - } else if (counter > 0) { - print_lock("barrier %p waiting", barrier, barrier); - ecl_enable_interrupts_env(the_env); - ecl_wait_on(the_env, barrier_wait_condition, barrier); - output = ECL_T; - } else { - print_lock("barrier %p pass-through", barrier, barrier); - /* Barrier disabled */ - output = ECL_NIL; - } - @(return output) -} -@) + unlikely_if (ecl_t_of(barrier) != t_barrier) { + FEerror_not_a_barrier(barrier); + } + ecl_disable_interrupts_env(the_env); + counter = decrement_counter(&barrier->barrier.arrivers_count); + if (counter == 0) { + print_lock("barrier %p saturated", barrier, barrier); + /* There are (count-1) threads in the queue and we + * are the last one. We thus unblock all threads and + * proceed. */ + mp_barrier_unblock(1, barrier); + ecl_enable_interrupts_env(the_env); + output = @':unblocked'; + } else if (counter > 0) { + print_lock("barrier %p waiting", barrier, barrier); + ecl_enable_interrupts_env(the_env); + ecl_wait_on(the_env, barrier_wait_condition, barrier); + output = ECL_T; + } else { + print_lock("barrier %p pass-through", barrier, barrier); + /* Barrier disabled */ + output = ECL_NIL; + } + @(return output); + } @) diff --git a/src/c/threads/condition_variable.d b/src/c/threads/condition_variable.d index c4d15a436..d515e2aaf 100644 --- a/src/c/threads/condition_variable.d +++ b/src/c/threads/condition_variable.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - condition_variable.d -- Native threads. -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * condition_variable.d - condition variables for native threads + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -25,82 +20,82 @@ cl_object mp_make_condition_variable(void) { - cl_object output = ecl_alloc_object(t_condition_variable); - output->condition_variable.queue_list = ECL_NIL; - output->condition_variable.queue_spinlock = ECL_NIL; - output->condition_variable.lock = ECL_NIL; - @(return output) + cl_object output = ecl_alloc_object(t_condition_variable); + output->condition_variable.queue_list = ECL_NIL; + output->condition_variable.queue_spinlock = ECL_NIL; + output->condition_variable.lock = ECL_NIL; + @(return output); } static cl_object condition_variable_wait(cl_env_ptr env, cl_object cv) { - cl_object lock = cv->condition_variable.lock; - cl_object own_process = env->own_process; - /* We have entered the queue and still own the mutex? */ - print_lock("cv lock %p is %p =? %p", cv, lock, lock->lock.owner, own_process); - if (lock->lock.owner == own_process) { - mp_giveup_lock(lock); - } - /* We always return when we have been explicitly awaken */ - return own_process->process.woken_up; + cl_object lock = cv->condition_variable.lock; + cl_object own_process = env->own_process; + /* We have entered the queue and still own the mutex? */ + print_lock("cv lock %p is %p =? %p", cv, lock, lock->lock.owner, own_process); + if (lock->lock.owner == own_process) { + mp_giveup_lock(lock); + } + /* We always return when we have been explicitly awaken */ + return own_process->process.woken_up; } cl_object mp_condition_variable_wait(cl_object cv, cl_object lock) { - cl_env_ptr env = ecl_process_env(); - cl_object own_process = env->own_process; - unlikely_if (ecl_t_of(cv) != t_condition_variable) { - FEwrong_type_nth_arg(@[mp::condition-variable-wait], 1, cv, - @[mp::condition-variable]); - } - unlikely_if (ecl_t_of(lock) != t_lock) { - FEwrong_type_nth_arg(@[mp::condition-variable-wait], 2, lock, - @[mp::lock]); - } - unlikely_if (cv->condition_variable.lock != ECL_NIL && - cv->condition_variable.lock != lock) - { - FEerror("Attempt to associate lock ~A~%with condition variable ~A," - "~%which is already associated to lock ~A", 2, lock, - cv, cv->condition_variable.lock); - } - unlikely_if (lock->lock.owner != own_process) { - FEerror("Attempt to wait on a condition variable using lock~%~S" - "~%which is not owned by process~%~S", 2, lock, own_process); - } - unlikely_if (lock->lock.counter > 1) { - FEerror("mp:condition-variable-wait can not be used with recursive" - " locks:~%~S", 1, lock); - } - print_lock("waiting cv %p", cv, cv); - cv->condition_variable.lock = lock; - ecl_wait_on(env, condition_variable_wait, cv); - mp_get_lock_wait(lock); - @(return ECL_T) + cl_env_ptr env = ecl_process_env(); + cl_object own_process = env->own_process; + unlikely_if (ecl_t_of(cv) != t_condition_variable) { + FEwrong_type_nth_arg(@[mp::condition-variable-wait], 1, cv, + @[mp::condition-variable]); + } + unlikely_if (ecl_t_of(lock) != t_lock) { + FEwrong_type_nth_arg(@[mp::condition-variable-wait], 2, lock, + @[mp::lock]); + } + unlikely_if (cv->condition_variable.lock != ECL_NIL && + cv->condition_variable.lock != lock) + { + FEerror("Attempt to associate lock ~A~%with condition variable ~A," + "~%which is already associated to lock ~A", 2, lock, + cv, cv->condition_variable.lock); + } + unlikely_if (lock->lock.owner != own_process) { + FEerror("Attempt to wait on a condition variable using lock~%~S" + "~%which is not owned by process~%~S", 2, lock, own_process); + } + unlikely_if (lock->lock.counter > 1) { + FEerror("mp:condition-variable-wait can not be used with recursive" + " locks:~%~S", 1, lock); + } + print_lock("waiting cv %p", cv, cv); + cv->condition_variable.lock = lock; + ecl_wait_on(env, condition_variable_wait, cv); + mp_get_lock_wait(lock); + @(return ECL_T); } cl_object mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds) { - FEerror("Timed condition variables are not supported.", 0); + FEerror("Timed condition variables are not supported.", 0); } cl_object mp_condition_variable_signal(cl_object cv) { - print_lock("signal cv %p", cv, cv); - ecl_wakeup_waiters(ecl_process_env(), cv, - ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ONE | ECL_WAKEUP_DELETE); - @(return ECL_T) + print_lock("signal cv %p", cv, cv); + ecl_wakeup_waiters(ecl_process_env(), cv, + ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ONE | ECL_WAKEUP_DELETE); + @(return ECL_T); } cl_object mp_condition_variable_broadcast(cl_object cv) { - print_lock("broadcast cv %p", cv); - ecl_wakeup_waiters(ecl_process_env(), cv, - ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL | ECL_WAKEUP_DELETE); - @(return ECL_T) + print_lock("broadcast cv %p", cv); + ecl_wakeup_waiters(ecl_process_env(), cv, + ECL_WAKEUP_RESET_FLAG | ECL_WAKEUP_ALL | ECL_WAKEUP_DELETE); + @(return ECL_T); } diff --git a/src/c/threads/ecl_atomics.h b/src/c/threads/ecl_atomics.h index 60009f617..2459ae930 100755 --- a/src/c/threads/ecl_atomics.h +++ b/src/c/threads/ecl_atomics.h @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - ecl_atomics.h -- alternative definitions for atomic operations -*/ -/* - Copyright (c) 2012, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * ecl_atomics.h - alternative definitions for atomic operations + * + * Copyright (c) 2012 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifndef ECL_ATOMICS_H #define AO_ASSUME_WINDOWS98 diff --git a/src/c/threads/mailbox.d b/src/c/threads/mailbox.d index 5bbae4bc5..8580e678b 100755 --- a/src/c/threads/mailbox.d +++ b/src/c/threads/mailbox.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - mailbox.d -- thread communication queue -*/ -/* - Copyright (c) 2012, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * mailbox.d -- thread communication queue + * + * Copyright (c) 2012 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -23,146 +18,144 @@ static ECL_INLINE void FEerror_not_a_mailbox(cl_object mailbox) { - FEwrong_type_argument(@'mp::mailbox', mailbox); + FEwrong_type_argument(@'mp::mailbox', mailbox); } cl_object ecl_make_mailbox(cl_object name, cl_fixnum count) { - cl_object output = ecl_alloc_object(t_mailbox); - cl_fixnum mask; - for (mask = 1; mask < count; mask <<= 1) {} - if (mask == 1) - mask = 63; - count = mask; - mask = count - 1; - output->mailbox.name = name; - output->mailbox.data = si_make_vector(ECL_T, /* element type */ - ecl_make_fixnum(count), /* size */ - ECL_NIL, /* adjustable */ - ECL_NIL, /* fill pointer */ - ECL_NIL, /* displaced to */ - ECL_NIL); /* displacement */ - output->mailbox.reader_semaphore = - ecl_make_semaphore(name, 0); - output->mailbox.writer_semaphore = - ecl_make_semaphore(name, count); - output->mailbox.read_pointer = 0; - output->mailbox.write_pointer = 0; - output->mailbox.mask = mask; - return output; + cl_object output = ecl_alloc_object(t_mailbox); + cl_fixnum mask; + for (mask = 1; mask < count; mask <<= 1) {} + if (mask == 1) + mask = 63; + count = mask; + mask = count - 1; + output->mailbox.name = name; + output->mailbox.data = si_make_vector(ECL_T, /* element type */ + ecl_make_fixnum(count), /* size */ + ECL_NIL, /* adjustable */ + ECL_NIL, /* fill pointer */ + ECL_NIL, /* displaced to */ + ECL_NIL); /* displacement */ + output->mailbox.reader_semaphore = + ecl_make_semaphore(name, 0); + output->mailbox.writer_semaphore = + ecl_make_semaphore(name, count); + output->mailbox.read_pointer = 0; + output->mailbox.write_pointer = 0; + output->mailbox.mask = mask; + return output; } @(defun mp::make-mailbox (&key name (count ecl_make_fixnum(128))) -@ -{ - @(return ecl_make_mailbox(name, fixnnint(count))) -} -@) + @ { + @(return ecl_make_mailbox(name, fixnnint(count))); + } @) cl_object mp_mailbox_name(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, mailbox->mailbox.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, mailbox->mailbox.name); } cl_object mp_mailbox_count(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, ecl_make_fixnum(mailbox->mailbox.data->vector.dim)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, ecl_make_fixnum(mailbox->mailbox.data->vector.dim)); } cl_object mp_mailbox_empty_p(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - ecl_return1(env, mailbox->mailbox.reader_semaphore->semaphore.counter? ECL_NIL : ECL_T); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + ecl_return1(env, mailbox->mailbox.reader_semaphore->semaphore.counter? ECL_NIL : ECL_T); } cl_object mp_mailbox_read(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - cl_object output; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - mp_wait_on_semaphore(mailbox->mailbox.reader_semaphore); - { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & - mailbox->mailbox.mask; - output = mailbox->mailbox.data->vector.self.t[ndx]; - } - mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + cl_object output; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + mp_wait_on_semaphore(mailbox->mailbox.reader_semaphore); + { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & + mailbox->mailbox.mask; + output = mailbox->mailbox.data->vector.self.t[ndx]; + } + mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); + ecl_return1(env, output); } cl_object mp_mailbox_try_read(cl_object mailbox) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - cl_object output; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - output = mp_try_get_semaphore(mailbox->mailbox.reader_semaphore); - if (output != ECL_NIL) { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & - mailbox->mailbox.mask; - output = mailbox->mailbox.data->vector.self.t[ndx]; - mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); - } - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + cl_object output; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + output = mp_try_get_semaphore(mailbox->mailbox.reader_semaphore); + if (output != ECL_NIL) { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) & + mailbox->mailbox.mask; + output = mailbox->mailbox.data->vector.self.t[ndx]; + mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore); + } + ecl_return1(env, output); } cl_object mp_mailbox_send(cl_object mailbox, cl_object msg) { - cl_env_ptr env = ecl_process_env(); - cl_fixnum ndx; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - mp_wait_on_semaphore(mailbox->mailbox.writer_semaphore); - { - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & - mailbox->mailbox.mask; - mailbox->mailbox.data->vector.self.t[ndx] = msg; - } - mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); - ecl_return0(env); + cl_env_ptr env = ecl_process_env(); + cl_fixnum ndx; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + mp_wait_on_semaphore(mailbox->mailbox.writer_semaphore); + { + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & + mailbox->mailbox.mask; + mailbox->mailbox.data->vector.self.t[ndx] = msg; + } + mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); + ecl_return0(env); } cl_object mp_mailbox_try_send(cl_object mailbox, cl_object msg) { - cl_env_ptr env = ecl_process_env(); - cl_object output; - cl_fixnum ndx; - unlikely_if (ecl_t_of(mailbox) != t_mailbox) { - FEerror_not_a_mailbox(mailbox); - } - output = mp_try_get_semaphore(mailbox->mailbox.writer_semaphore); - if (output != ECL_NIL) { - output = msg; - ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & - mailbox->mailbox.mask; - mailbox->mailbox.data->vector.self.t[ndx] = msg; - mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); - } - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_object output; + cl_fixnum ndx; + unlikely_if (ecl_t_of(mailbox) != t_mailbox) { + FEerror_not_a_mailbox(mailbox); + } + output = mp_try_get_semaphore(mailbox->mailbox.writer_semaphore); + if (output != ECL_NIL) { + output = msg; + ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) & + mailbox->mailbox.mask; + mailbox->mailbox.data->vector.self.t[ndx] = msg; + mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore); + } + ecl_return1(env, output); } diff --git a/src/c/threads/mutex.d b/src/c/threads/mutex.d index 99ed0edbf..30f3a3c84 100755 --- a/src/c/threads/mutex.d +++ b/src/c/threads/mutex.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - mutex.d -- mutually exclusive locks. -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * mutex.d - mutually exclusive locks + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -28,178 +23,180 @@ static void FEerror_not_a_lock(cl_object lock) { - FEwrong_type_argument(@'mp::lock', lock); + FEwrong_type_argument(@'mp::lock', lock); } static void FEerror_not_a_recursive_lock(cl_object lock) { - FEerror("Attempted to recursively lock ~S which is already owned by ~S", - 2, lock, lock->lock.owner); + FEerror("Attempted to recursively lock ~S which is already owned by ~S", + 2, lock, lock->lock.owner); } static void FEerror_not_owned(cl_object lock) { - FEerror("Attempted to give up lock ~S that is not owned by process ~S", - 2, lock, mp_current_process()); + FEerror("Attempted to give up lock ~S that is not owned by process ~S", + 2, lock, mp_current_process()); } cl_object ecl_make_lock(cl_object name, bool recursive) { - cl_object output = ecl_alloc_object(t_lock); - output->lock.name = name; - output->lock.owner = ECL_NIL; - output->lock.counter = 0; - output->lock.recursive = recursive; - output->lock.queue_list = ECL_NIL; - output->lock.queue_spinlock = ECL_NIL; - return output; + cl_object output = ecl_alloc_object(t_lock); + output->lock.name = name; + output->lock.owner = ECL_NIL; + output->lock.counter = 0; + output->lock.recursive = recursive; + output->lock.queue_list = ECL_NIL; + output->lock.queue_spinlock = ECL_NIL; + return output; } @(defun mp::make-lock (&key name ((:recursive recursive) ECL_NIL)) -@ - @(return ecl_make_lock(name, !Null(recursive))) -@) + @ + @(return ecl_make_lock(name, !Null(recursive))); + @) cl_object mp_recursive_lock_p(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) - FEerror_not_a_lock(lock); - ecl_return1(env, lock->lock.recursive? ECL_T : ECL_NIL); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) + FEerror_not_a_lock(lock); + ecl_return1(env, lock->lock.recursive? ECL_T : ECL_NIL); } cl_object mp_lock_name(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, lock->lock.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, lock->lock.name); } cl_object mp_lock_owner(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, lock->lock.owner); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, lock->lock.owner); } cl_object mp_lock_count(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, ecl_make_fixnum(lock->lock.counter)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, ecl_make_fixnum(lock->lock.counter)); } cl_object mp_giveup_lock(cl_object lock) { - /* Must be called with interrupts disabled. */ - cl_env_ptr env = ecl_process_env(); - cl_object own_process = env->own_process; - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - unlikely_if (lock->lock.owner != own_process) { - FEerror_not_owned(lock); - } - if (--lock->lock.counter == 0) { - cl_object first = ecl_waiter_pop(env, lock);; - if (first == ECL_NIL) { - lock->lock.owner = ECL_NIL; - } else { - lock->lock.counter = 1; - lock->lock.owner = first; - ecl_wakeup_process(first); - } - } - ecl_return1(env, ECL_T); + /* Must be called with interrupts disabled. */ + cl_env_ptr env = ecl_process_env(); + cl_object own_process = env->own_process; + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + unlikely_if (lock->lock.owner != own_process) { + FEerror_not_owned(lock); + } + if (--lock->lock.counter == 0) { + cl_object first = ecl_waiter_pop(env, lock);; + if (first == ECL_NIL) { + lock->lock.owner = ECL_NIL; + } else { + lock->lock.counter = 1; + lock->lock.owner = first; + ecl_wakeup_process(first); + } + } + ecl_return1(env, ECL_T); } static cl_object get_lock_inner(cl_env_ptr env, cl_object lock) { - cl_object output; - cl_object own_process = env->own_process; - ecl_disable_interrupts_env(env); - if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), - (AO_t)ECL_NIL, (AO_t)own_process)) { - lock->lock.counter = 1; - output = ECL_T; - print_lock("acquired %p\t", lock, lock); - } else if (lock->lock.owner == own_process) { - unlikely_if (!lock->lock.recursive) { - FEerror_not_a_recursive_lock(lock); - } - ++lock->lock.counter; - output = ECL_T; - } else { - print_lock("failed acquiring %p for %d\t", lock, lock, - lock->lock.owner); - output = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return output; + cl_object output; + cl_object own_process = env->own_process; + ecl_disable_interrupts_env(env); + if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), + (AO_t)ECL_NIL, (AO_t)own_process)) { + lock->lock.counter = 1; + output = ECL_T; + print_lock("acquired %p\t", lock, lock); + } else if (lock->lock.owner == own_process) { + unlikely_if (!lock->lock.recursive) { + FEerror_not_a_recursive_lock(lock); + } + ++lock->lock.counter; + output = ECL_T; + } else { + print_lock("failed acquiring %p for %d\t", lock, lock, + lock->lock.owner); + output = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return output; } cl_object mp_get_lock_nowait(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - ecl_return1(env, get_lock_inner(env, lock)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + ecl_return1(env, get_lock_inner(env, lock)); } static cl_object own_or_get_lock(cl_env_ptr env, cl_object lock) { - cl_object output; - cl_object own_process = env->own_process; - ecl_disable_interrupts_env(env); - if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), - (AO_t)ECL_NIL, (AO_t)own_process)) { - lock->lock.counter = 1; - output = ECL_T; - print_lock("acquired %p\t", lock, lock); - } else if (lock->lock.owner == own_process) { - output = ECL_T; - } else { - output = ECL_NIL; - } - ecl_enable_interrupts_env(env); - return output; + cl_object output; + cl_object own_process = env->own_process; + ecl_disable_interrupts_env(env); + if (AO_compare_and_swap_full((AO_t*)&(lock->lock.owner), + (AO_t)ECL_NIL, (AO_t)own_process)) { + lock->lock.counter = 1; + output = ECL_T; + print_lock("acquired %p\t", lock, lock); + } else if (lock->lock.owner == own_process) { + output = ECL_T; + } else { + output = ECL_NIL; + } + ecl_enable_interrupts_env(env); + return output; } cl_object mp_get_lock_wait(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(lock) != t_lock) { - FEerror_not_a_lock(lock); - } - if (get_lock_inner(env, lock) == ECL_NIL) { - ecl_wait_on(env, own_or_get_lock, lock); - } - @(return ECL_T) + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(lock) != t_lock) { + FEerror_not_a_lock(lock); + } + if (get_lock_inner(env, lock) == ECL_NIL) { + ecl_wait_on(env, own_or_get_lock, lock); + } + @(return ECL_T); } @(defun mp::get-lock (lock &optional (wait ECL_T)) -@ - if (Null(wait)) - return mp_get_lock_nowait(lock); - else - return mp_get_lock_wait(lock); -@) + @ + if (Null(wait)) { + return mp_get_lock_nowait(lock); + } + else { + return mp_get_lock_wait(lock); + } + @) diff --git a/src/c/threads/process.d b/src/c/threads/process.d index ba1c41784..0b818f397 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - threads.d -- Native threads. -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * process.d - native threads + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifndef __sun__ /* See unixinit.d for this */ #define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ @@ -43,9 +38,9 @@ */ # include extern HANDLE WINAPI GC_CreateThread( - LPSECURITY_ATTRIBUTES lpThreadAttributes, - DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress, - LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId ); + LPSECURITY_ATTRIBUTES lpThreadAttributes, + DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress, + LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId ); # ifndef WITH___THREAD DWORD cl_env_key; # endif @@ -62,13 +57,13 @@ cl_env_ptr ecl_process_env(void) { #ifdef ECL_WINDOWS_THREADS - return TlsGetValue(cl_env_key); + return TlsGetValue(cl_env_key); #else - struct cl_env_struct *rv = pthread_getspecific(cl_env_key); - if (rv) - return rv; - FElibc_error("pthread_getspecific() failed.", 0); - return NULL; + struct cl_env_struct *rv = pthread_getspecific(cl_env_key); + if (rv) + return rv; + FElibc_error("pthread_getspecific() failed.", 0); + return NULL; #endif } #endif @@ -77,13 +72,13 @@ static void ecl_set_process_env(cl_env_ptr env) { #ifdef WITH___THREAD - cl_env_p = env; + cl_env_p = env; #else # ifdef ECL_WINDOWS_THREADS - TlsSetValue(cl_env_key, env); + TlsSetValue(cl_env_key, env); # else - if (pthread_setspecific(cl_env_key, env)) - FElibc_error("pthread_setspecific() failed.", 0); + if (pthread_setspecific(cl_env_key, env)) + FElibc_error("pthread_setspecific() failed.", 0); # endif #endif } @@ -91,7 +86,7 @@ ecl_set_process_env(cl_env_ptr env) cl_object mp_current_process(void) { - return ecl_process_env()->own_process; + return ecl_process_env()->own_process; } /*---------------------------------------------------------------------- @@ -101,79 +96,79 @@ mp_current_process(void) static void extend_process_vector() { - cl_object v = cl_core.processes; - cl_index new_size = v->vector.dim + v->vector.dim/2; - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object other = cl_core.processes; - if (new_size > other->vector.dim) { - cl_object new = si_make_vector(ECL_T, - ecl_make_fixnum(new_size), - ecl_make_fixnum(other->vector.fillp), - ECL_NIL, ECL_NIL, ECL_NIL); - ecl_copy_subarray(new, 0, other, 0, other->vector.dim); - cl_core.processes = new; - } - } ECL_WITH_SPINLOCK_END; + cl_object v = cl_core.processes; + cl_index new_size = v->vector.dim + v->vector.dim/2; + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object other = cl_core.processes; + if (new_size > other->vector.dim) { + cl_object new = si_make_vector(ECL_T, + ecl_make_fixnum(new_size), + ecl_make_fixnum(other->vector.fillp), + ECL_NIL, ECL_NIL, ECL_NIL); + ecl_copy_subarray(new, 0, other, 0, other->vector.dim); + cl_core.processes = new; + } + } ECL_WITH_SPINLOCK_END; } static void ecl_list_process(cl_object process) { - cl_env_ptr the_env = ecl_process_env(); - bool ok = 0; - do { - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_index size = vector->vector.dim; - cl_index ndx = vector->vector.fillp; - if (ndx < size) { - vector->vector.self.t[ndx++] = process; - vector->vector.fillp = ndx; - ok = 1; - } - } ECL_WITH_SPINLOCK_END; - if (ok) break; - extend_process_vector(); - } while (1); + cl_env_ptr the_env = ecl_process_env(); + bool ok = 0; + do { + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_index size = vector->vector.dim; + cl_index ndx = vector->vector.fillp; + if (ndx < size) { + vector->vector.self.t[ndx++] = process; + vector->vector.fillp = ndx; + ok = 1; + } + } ECL_WITH_SPINLOCK_END; + if (ok) break; + extend_process_vector(); + } while (1); } static void ecl_unlist_process(cl_object process) { - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - if (vector->vector.self.t[i] == process) { - vector->vector.fillp--; - do { - vector->vector.self.t[i] = - vector->vector.self.t[i+1]; - } while (++i < vector->vector.fillp); - break; - } - } - } ECL_WITH_SPINLOCK_END; + cl_env_ptr the_env = ecl_process_env(); + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_index i; + for (i = 0; i < vector->vector.fillp; i++) { + if (vector->vector.self.t[i] == process) { + vector->vector.fillp--; + do { + vector->vector.self.t[i] = + vector->vector.self.t[i+1]; + } while (++i < vector->vector.fillp); + break; + } + } + } ECL_WITH_SPINLOCK_END; } static cl_object ecl_process_list() { - cl_env_ptr the_env = ecl_process_env(); - cl_object output = ECL_NIL; - ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { - cl_object vector = cl_core.processes; - cl_object *data = vector->vector.self.t; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - cl_object p = data[i]; - if (p != ECL_NIL) - output = ecl_cons(p, output); - } - } ECL_WITH_SPINLOCK_END; - return output; + cl_env_ptr the_env = ecl_process_env(); + cl_object output = ECL_NIL; + ECL_WITH_SPINLOCK_BEGIN(the_env, &cl_core.processes_spinlock) { + cl_object vector = cl_core.processes; + cl_object *data = vector->vector.self.t; + cl_index i; + for (i = 0; i < vector->vector.fillp; i++) { + cl_object p = data[i]; + if (p != ECL_NIL) + output = ecl_cons(p, output); + } + } ECL_WITH_SPINLOCK_END; + return output; } /*---------------------------------------------------------------------- @@ -183,495 +178,495 @@ ecl_process_list() static void assert_type_process(cl_object o) { - if (ecl_t_of(o) != t_process) - FEwrong_type_argument(@[mp::process], o); + if (ecl_t_of(o) != t_process) + FEwrong_type_argument(@[mp::process], o); } static void thread_cleanup(void *aux) { - /* This routine performs some cleanup before a thread is completely - * killed. For instance, it has to remove the associated process - * object from the list, an it has to dealloc some memory. - * - * NOTE: thread_cleanup() does not provide enough "protection". In - * order to ensure that all UNWIND-PROTECT forms are properly - * executed, never use pthread_cancel() to kill a process, but - * rather use the lisp functions mp_interrupt_process() and - * mp_process_kill(). - */ - cl_object process = (cl_object)aux; - cl_env_ptr env = process->process.env; - /* The following flags will disable all interrupts. */ - AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING); - ecl_disable_interrupts_env(env); + /* This routine performs some cleanup before a thread is completely + * killed. For instance, it has to remove the associated process + * object from the list, an it has to dealloc some memory. + * + * NOTE: thread_cleanup() does not provide enough "protection". In + * order to ensure that all UNWIND-PROTECT forms are properly + * executed, never use pthread_cancel() to kill a process, but + * rather use the lisp functions mp_interrupt_process() and + * mp_process_kill(). + */ + cl_object process = (cl_object)aux; + cl_env_ptr env = process->process.env; + /* The following flags will disable all interrupts. */ + AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING); + ecl_disable_interrupts_env(env); #ifdef HAVE_SIGPROCMASK - /* ...but we might get stray signals. */ - { - sigset_t new[1]; - sigemptyset(new); - sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); - pthread_sigmask(SIG_BLOCK, new, NULL); - } + /* ...but we might get stray signals. */ + { + sigset_t new[1]; + sigemptyset(new); + sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + pthread_sigmask(SIG_BLOCK, new, NULL); + } #endif - process->process.env = NULL; - ecl_unlist_process(process); - mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); - ecl_set_process_env(NULL); - if (env) _ecl_dealloc_env(env); - AO_store_release((AO_t*)&process->process.phase, ECL_PROCESS_INACTIVE); + process->process.env = NULL; + ecl_unlist_process(process); + mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); + ecl_set_process_env(NULL); + if (env) _ecl_dealloc_env(env); + AO_store_release((AO_t*)&process->process.phase, ECL_PROCESS_INACTIVE); } #ifdef ECL_WINDOWS_THREADS static DWORD WINAPI thread_entry_point(void *arg) #else -static void * -thread_entry_point(void *arg) + static void * + thread_entry_point(void *arg) #endif { - cl_object process = (cl_object)arg; - cl_env_ptr env = process->process.env; + cl_object process = (cl_object)arg; + cl_env_ptr env = process->process.env; - /* - * Upon entering this routine - * process.env = our environment for lisp - * process.phase = ECL_PROCESS_BOOTING - * signals are disabled in the environment - * the communication interrupt is disabled (sigmasked) - * - * This process will not receive signals that originate from - * other processes. Furthermore, we expect not to get any - * other interrupts (SIGSEGV, SIGFPE) if we do things right. - */ - /* 1) Setup the environment for the execution of the thread */ - ecl_set_process_env(env = process->process.env); + /* + * Upon entering this routine + * process.env = our environment for lisp + * process.phase = ECL_PROCESS_BOOTING + * signals are disabled in the environment + * the communication interrupt is disabled (sigmasked) + * + * This process will not receive signals that originate from + * other processes. Furthermore, we expect not to get any + * other interrupts (SIGSEGV, SIGFPE) if we do things right. + */ + /* 1) Setup the environment for the execution of the thread */ + ecl_set_process_env(env = process->process.env); #ifndef ECL_WINDOWS_THREADS - pthread_cleanup_push(thread_cleanup, (void *)process); + pthread_cleanup_push(thread_cleanup, (void *)process); #endif - ecl_cs_set_org(env); - ecl_get_spinlock(env, &process->process.start_spinlock); - print_lock("ENVIRON %p %p %p %p", ECL_NIL, process, - env->bds_org, env->bds_top, env->bds_limit); + ecl_cs_set_org(env); + ecl_get_spinlock(env, &process->process.start_spinlock); + print_lock("ENVIRON %p %p %p %p", ECL_NIL, process, + env->bds_org, env->bds_top, env->bds_limit); - /* 2) Execute the code. The CATCH_ALL point is the destination - * provides us with an elegant way to exit the thread: we just - * do an unwind up to frs_top. - */ - ECL_CATCH_ALL_BEGIN(env) { + /* 2) Execute the code. The CATCH_ALL point is the destination + * provides us with an elegant way to exit the thread: we just + * do an unwind up to frs_top. + */ + ECL_CATCH_ALL_BEGIN(env) { #ifdef HAVE_SIGPROCMASK - { - sigset_t *new = (sigset_t*)env->default_sigmask; - pthread_sigmask(SIG_SETMASK, new, NULL); - } + { + sigset_t *new = (sigset_t*)env->default_sigmask; + pthread_sigmask(SIG_SETMASK, new, NULL); + } #endif - process->process.phase = ECL_PROCESS_ACTIVE; - ecl_enable_interrupts_env(env); - si_trap_fpe(@'last', ECL_T); - ecl_bds_bind(env, @'mp::*current-process*', process); + process->process.phase = ECL_PROCESS_ACTIVE; + ecl_enable_interrupts_env(env); + si_trap_fpe(@'last', ECL_T); + ecl_bds_bind(env, @'mp::*current-process*', process); - ECL_RESTART_CASE_BEGIN(env, @'abort') { - env->values[0] = cl_apply(2, process->process.function, - process->process.args); - { - cl_object output = ECL_NIL; - int i = env->nvalues; - while (i--) { - output = CONS(env->values[i], output); - } - process->process.exit_values = output; - } - } ECL_RESTART_CASE(1,args) { - /* ABORT restart. */ - process->process.exit_values = args; - } ECL_RESTART_CASE_END; - /* This will disable interrupts during the exit - * so that the unwinding is not interrupted. */ - process->process.phase = ECL_PROCESS_EXITING; - ecl_bds_unwind1(env); - } ECL_CATCH_ALL_END; + ECL_RESTART_CASE_BEGIN(env, @'abort') { + env->values[0] = cl_apply(2, process->process.function, + process->process.args); + { + cl_object output = ECL_NIL; + int i = env->nvalues; + while (i--) { + output = CONS(env->values[i], output); + } + process->process.exit_values = output; + } + } ECL_RESTART_CASE(1,args) { + /* ABORT restart. */ + process->process.exit_values = args; + } ECL_RESTART_CASE_END; + /* This will disable interrupts during the exit + * so that the unwinding is not interrupted. */ + process->process.phase = ECL_PROCESS_EXITING; + ecl_bds_unwind1(env); + } ECL_CATCH_ALL_END; - /* 4) If everything went right, we should be exiting the thread - * through this point. thread_cleanup is automatically invoked - * marking the process as inactive. - */ + /* 4) If everything went right, we should be exiting the thread + * through this point. thread_cleanup is automatically invoked + * marking the process as inactive. + */ #ifdef ECL_WINDOWS_THREADS - thread_cleanup(process); - return 1; + thread_cleanup(process); + return 1; #else - pthread_cleanup_pop(1); - return NULL; + pthread_cleanup_pop(1); + return NULL; #endif } static cl_object alloc_process(cl_object name, cl_object initial_bindings) { - cl_object process = ecl_alloc_object(t_process), array; - process->process.phase = ECL_PROCESS_INACTIVE; - process->process.name = name; - process->process.function = ECL_NIL; - process->process.args = ECL_NIL; - process->process.interrupt = ECL_NIL; - process->process.exit_values = ECL_NIL; - process->process.env = NULL; - if (initial_bindings != OBJNULL) { - array = si_make_vector(ECL_T, ecl_make_fixnum(256), - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - } else { - array = cl_copy_seq(ecl_process_env()->bindings_array); - } - process->process.initial_bindings = array; - process->process.woken_up = ECL_NIL; - process->process.start_spinlock = ECL_NIL; - process->process.queue_record = ecl_list1(process); - /* Creates the exit barrier so that processes can wait for termination, - * but it is created in a disabled state. */ - process->process.exit_barrier = ecl_make_barrier(name, MOST_POSITIVE_FIXNUM); - mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); - return process; + cl_object process = ecl_alloc_object(t_process), array; + process->process.phase = ECL_PROCESS_INACTIVE; + process->process.name = name; + process->process.function = ECL_NIL; + process->process.args = ECL_NIL; + process->process.interrupt = ECL_NIL; + process->process.exit_values = ECL_NIL; + process->process.env = NULL; + if (initial_bindings != OBJNULL) { + array = si_make_vector(ECL_T, ecl_make_fixnum(256), + ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); + si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); + } else { + array = cl_copy_seq(ecl_process_env()->bindings_array); + } + process->process.initial_bindings = array; + process->process.woken_up = ECL_NIL; + process->process.start_spinlock = ECL_NIL; + process->process.queue_record = ecl_list1(process); + /* Creates the exit barrier so that processes can wait for termination, + * but it is created in a disabled state. */ + process->process.exit_barrier = ecl_make_barrier(name, MOST_POSITIVE_FIXNUM); + mp_barrier_unblock(3, process->process.exit_barrier, @':disable', ECL_T); + return process; } bool ecl_import_current_thread(cl_object name, cl_object bindings) { - struct cl_env_struct env_aux[1]; - cl_object process; - pthread_t current; - cl_env_ptr env; - int registered; - struct GC_stack_base stack; + struct cl_env_struct env_aux[1]; + cl_object process; + pthread_t current; + cl_env_ptr env; + int registered; + struct GC_stack_base stack; #ifdef ECL_WINDOWS_THREADS - { - HANDLE aux = GetCurrentThread(); - DuplicateHandle(GetCurrentProcess(), - aux, - GetCurrentProcess(), - ¤t, - 0, - FALSE, - DUPLICATE_SAME_ACCESS); - CloseHandle(current); - } + { + HANDLE aux = GetCurrentThread(); + DuplicateHandle(GetCurrentProcess(), + aux, + GetCurrentProcess(), + ¤t, + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + CloseHandle(current); + } #else - current = pthread_self(); + current = pthread_self(); #endif #ifdef GBC_BOEHM - GC_get_stack_base(&stack); - switch (GC_register_my_thread(&stack)) { - case GC_SUCCESS: - registered = 1; - break; - case GC_DUPLICATE: - /* Thread was probably created using the GC hooks - * for thread creation */ - registered = 0; - break; - default: - return 0; - } + GC_get_stack_base(&stack); + switch (GC_register_my_thread(&stack)) { + case GC_SUCCESS: + registered = 1; + break; + case GC_DUPLICATE: + /* Thread was probably created using the GC hooks + * for thread creation */ + registered = 0; + break; + default: + return 0; + } #endif - { - cl_object processes = cl_core.processes; - cl_index i, size; - for (i = 0, size = processes->vector.dim; i < size; i++) { - cl_object p = processes->vector.self.t[i]; - if (!Null(p) && p->process.thread == current) - return 0; - } - } - /* We need a fake env to allow for interrupts blocking. */ - env_aux->disable_interrupts = 1; - ecl_set_process_env(env_aux); - env = _ecl_alloc_env(0); - ecl_set_process_env(env); - env->cleanup = registered; + { + cl_object processes = cl_core.processes; + cl_index i, size; + for (i = 0, size = processes->vector.dim; i < size; i++) { + cl_object p = processes->vector.self.t[i]; + if (!Null(p) && p->process.thread == current) + return 0; + } + } + /* We need a fake env to allow for interrupts blocking. */ + env_aux->disable_interrupts = 1; + ecl_set_process_env(env_aux); + env = _ecl_alloc_env(0); + ecl_set_process_env(env); + env->cleanup = registered; - /* Link environment and process together */ - env->own_process = process = alloc_process(name, bindings); - process->process.env = env; - process->process.phase = ECL_PROCESS_BOOTING; - process->process.thread = current; - ecl_list_process(process); + /* Link environment and process together */ + env->own_process = process = alloc_process(name, bindings); + process->process.env = env; + process->process.phase = ECL_PROCESS_BOOTING; + process->process.thread = current; + ecl_list_process(process); - ecl_init_env(env); - env->bindings_array = process->process.initial_bindings; - env->thread_local_bindings_size = env->bindings_array->vector.dim; - env->thread_local_bindings = env->bindings_array->vector.self.t; - ecl_enable_interrupts_env(env); + ecl_init_env(env); + env->bindings_array = process->process.initial_bindings; + env->thread_local_bindings_size = env->bindings_array->vector.dim; + env->thread_local_bindings = env->bindings_array->vector.self.t; + ecl_enable_interrupts_env(env); - /* Activate the barrier so that processes can immediately start waiting. */ - mp_barrier_unblock(1, process->process.exit_barrier); - process->process.phase = ECL_PROCESS_ACTIVE; + /* Activate the barrier so that processes can immediately start waiting. */ + mp_barrier_unblock(1, process->process.exit_barrier); + process->process.phase = ECL_PROCESS_ACTIVE; - ecl_bds_bind(env, @'mp::*current-process*', process); - return 1; + ecl_bds_bind(env, @'mp::*current-process*', process); + return 1; } void ecl_release_current_thread(void) { - cl_env_ptr env = ecl_process_env(); - int cleanup = env->cleanup; - thread_cleanup(env->own_process); + cl_env_ptr env = ecl_process_env(); + int cleanup = env->cleanup; + thread_cleanup(env->own_process); #ifdef GBC_BOEHM - if (cleanup) { - GC_unregister_my_thread(); - } + if (cleanup) { + GC_unregister_my_thread(); + } #endif } @(defun mp::make-process (&key name ((:initial-bindings initial_bindings) ECL_T)) - cl_object process; -@ - process = alloc_process(name, initial_bindings); - @(return process) -@) + cl_object process; + @ + process = alloc_process(name, initial_bindings); + @(return process); + @) cl_object mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...) { - ecl_va_list args; - ecl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@[mp::process-preset]); - assert_type_process(process); - process->process.function = function; - process->process.args = cl_grab_rest_args(args); - @(return process) + ecl_va_list args; + ecl_va_start(args, function, narg, 2); + if (narg < 2) + FEwrong_num_arguments(@[mp::process-preset]); + assert_type_process(process); + process->process.function = function; + process->process.args = cl_grab_rest_args(args); + @(return process); } cl_object mp_interrupt_process(cl_object process, cl_object function) { - unlikely_if (mp_process_active_p(process) == ECL_NIL) - FEerror("Cannot interrupt the inactive process ~A", 1, process); - ecl_interrupt_process(process, function); - @(return ECL_T) + unlikely_if (mp_process_active_p(process) == ECL_NIL) + FEerror("Cannot interrupt the inactive process ~A", 1, process); + ecl_interrupt_process(process, function); + @(return ECL_T); } cl_object mp_suspend_loop() { - cl_env_ptr env = ecl_process_env(); - ECL_CATCH_BEGIN(env,@'mp::suspend-loop') { - for ( ; ; ) { - cl_sleep(ecl_make_fixnum(100)); - } - } ECL_CATCH_END; - ecl_return0(env); + cl_env_ptr env = ecl_process_env(); + ECL_CATCH_BEGIN(env,@'mp::suspend-loop') { + for ( ; ; ) { + cl_sleep(ecl_make_fixnum(100)); + } + } ECL_CATCH_END; + ecl_return0(env); } cl_object mp_break_suspend_loop() { - cl_env_ptr the_env = ecl_process_env(); - if (frs_sch(@'mp::suspend-loop')) { - cl_throw(@'mp::suspend-loop'); - } - ecl_return0(the_env); + cl_env_ptr the_env = ecl_process_env(); + if (frs_sch(@'mp::suspend-loop')) { + cl_throw(@'mp::suspend-loop'); + } + ecl_return0(the_env); } cl_object mp_process_suspend(cl_object process) { - return mp_interrupt_process(process, @'mp::suspend-loop'); + return mp_interrupt_process(process, @'mp::suspend-loop'); } cl_object mp_process_resume(cl_object process) { - return mp_interrupt_process(process, @'mp::break-suspend-loop'); + return mp_interrupt_process(process, @'mp::break-suspend-loop'); } cl_object mp_process_kill(cl_object process) { - return mp_interrupt_process(process, @'mp::exit-process'); + return mp_interrupt_process(process, @'mp::exit-process'); } cl_object mp_process_yield(void) { - ecl_process_yield(); - @(return) + ecl_process_yield(); + @(return); } cl_object mp_process_enable(cl_object process) { - cl_env_ptr process_env; - int ok; - /* Try to gain exclusive access to the process at the same - * time we ensure that it is inactive. This prevents two - * concurrent calls to process-enable from different threads - * on the same process */ - unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase, - ECL_PROCESS_INACTIVE, - ECL_PROCESS_BOOTING)) { - FEerror("Cannot enable the running process ~A.", 1, process); - } - process->process.parent = mp_current_process(); - process->process.trap_fpe_bits = - process->process.parent->process.env->trap_fpe_bits; - ecl_list_process(process); + cl_env_ptr process_env; + int ok; + /* Try to gain exclusive access to the process at the same + * time we ensure that it is inactive. This prevents two + * concurrent calls to process-enable from different threads + * on the same process */ + unlikely_if (!AO_compare_and_swap_full((AO_t*)&process->process.phase, + ECL_PROCESS_INACTIVE, + ECL_PROCESS_BOOTING)) { + FEerror("Cannot enable the running process ~A.", 1, process); + } + process->process.parent = mp_current_process(); + process->process.trap_fpe_bits = + process->process.parent->process.env->trap_fpe_bits; + ecl_list_process(process); - /* Link environment and process together */ - process_env = _ecl_alloc_env(ecl_process_env()); - process_env->own_process = process; - process->process.env = process_env; + /* Link environment and process together */ + process_env = _ecl_alloc_env(ecl_process_env()); + process_env->own_process = process; + process->process.env = process_env; - ecl_init_env(process_env); - process_env->trap_fpe_bits = process->process.trap_fpe_bits; - process_env->bindings_array = process->process.initial_bindings; - process_env->thread_local_bindings_size = - process_env->bindings_array->vector.dim; - process_env->thread_local_bindings = - process_env->bindings_array->vector.self.t; + ecl_init_env(process_env); + process_env->trap_fpe_bits = process->process.trap_fpe_bits; + process_env->bindings_array = process->process.initial_bindings; + process_env->thread_local_bindings_size = + process_env->bindings_array->vector.dim; + process_env->thread_local_bindings = + process_env->bindings_array->vector.self.t; - /* Activate the barrier so that processes can immediately start waiting. */ - mp_barrier_unblock(1, process->process.exit_barrier); + /* Activate the barrier so that processes can immediately start waiting. */ + mp_barrier_unblock(1, process->process.exit_barrier); - /* Block the thread with this spinlock until it is ready */ - process->process.start_spinlock = ECL_T; + /* Block the thread with this spinlock until it is ready */ + process->process.start_spinlock = ECL_T; #ifdef ECL_WINDOWS_THREADS - { - HANDLE code; - DWORD threadId; + { + HANDLE code; + DWORD threadId; - code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); - ok = (process->process.thread = code) != NULL; - } + code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); + ok = (process->process.thread = code) != NULL; + } #else - { - int code; - pthread_attr_t pthreadattr; + { + int code; + pthread_attr_t pthreadattr; - pthread_attr_init(&pthreadattr); - pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); - /* - * We launch the thread with the signal mask specified in cl_core. - * The reason is that we might need to block certain signals - * to be processed by the signal handling thread in unixint.d - */ + pthread_attr_init(&pthreadattr); + pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); + /* + * We launch the thread with the signal mask specified in cl_core. + * The reason is that we might need to block certain signals + * to be processed by the signal handling thread in unixint.d + */ #ifdef HAVE_SIGPROCMASK - { - sigset_t new, previous; - sigfillset(&new); - pthread_sigmask(SIG_BLOCK, &new, &previous); - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); - pthread_sigmask(SIG_SETMASK, &previous, NULL); - } + { + sigset_t new, previous; + sigfillset(&new); + pthread_sigmask(SIG_BLOCK, &new, &previous); + code = pthread_create(&process->process.thread, &pthreadattr, + thread_entry_point, process); + pthread_sigmask(SIG_SETMASK, &previous, NULL); + } #else - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); + code = pthread_create(&process->process.thread, &pthreadattr, + thread_entry_point, process); #endif - ok = (code == 0); - } + ok = (code == 0); + } #endif - if (!ok) { - ecl_unlist_process(process); - /* Disable the barrier and alert possible waiting processes. */ - mp_barrier_unblock(3, process->process.exit_barrier, - @':disable', ECL_T); - process->process.phase = ECL_PROCESS_INACTIVE; - process->process.env = NULL; - _ecl_dealloc_env(process_env); - } - /* Unleash the thread */ - process->process.start_spinlock = ECL_NIL; + if (!ok) { + ecl_unlist_process(process); + /* Disable the barrier and alert possible waiting processes. */ + mp_barrier_unblock(3, process->process.exit_barrier, + @':disable', ECL_T); + process->process.phase = ECL_PROCESS_INACTIVE; + process->process.env = NULL; + _ecl_dealloc_env(process_env); + } + /* Unleash the thread */ + process->process.start_spinlock = ECL_NIL; - @(return (ok? process : ECL_NIL)) + @(return (ok? process : ECL_NIL)); } cl_object mp_exit_process(void) { - /* We simply undo the whole of the frame stack. This brings up - back to the thread entry point, going through all possible - UNWIND-PROTECT. - */ - const cl_env_ptr the_env = ecl_process_env(); - ecl_unwind(the_env, the_env->frs_org); - /* Never reached */ + /* We simply undo the whole of the frame stack. This brings up + back to the thread entry point, going through all possible + UNWIND-PROTECT. + */ + const cl_env_ptr the_env = ecl_process_env(); + ecl_unwind(the_env, the_env->frs_org); + /* Never reached */ } cl_object mp_all_processes(void) { - /* No race condition here because this list is never destructively - * modified. When we add or remove processes, we create new lists. */ - @(return ecl_process_list()) + /* No race condition here because this list is never destructively + * modified. When we add or remove processes, we create new lists. */ + @(return ecl_process_list()); } cl_object mp_process_name(cl_object process) { - assert_type_process(process); - @(return process->process.name) + assert_type_process(process); + @(return process->process.name); } cl_object mp_process_active_p(cl_object process) { - assert_type_process(process); - @(return (process->process.phase? ECL_T : ECL_NIL)) + assert_type_process(process); + @(return (process->process.phase? ECL_T : ECL_NIL)); } cl_object mp_process_whostate(cl_object process) { - assert_type_process(process); - @(return (cl_core.null_string)) + assert_type_process(process); + @(return (cl_core.null_string)); } cl_object mp_process_join(cl_object process) { - assert_type_process(process); - if (process->process.phase) { - /* We try to acquire a lock that is only owned by the process - * while it is active. */ - mp_barrier_wait(1, process->process.exit_barrier); - } - return cl_values_list(process->process.exit_values); + assert_type_process(process); + if (process->process.phase) { + /* We try to acquire a lock that is only owned by the process + * while it is active. */ + mp_barrier_wait(1, process->process.exit_barrier); + } + return cl_values_list(process->process.exit_values); } cl_object mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) { - cl_object process; - ecl_va_list args; - ecl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@[mp::process-run-function]); - if (CONSP(name)) { - process = cl_apply(2, @'mp::make-process', name); - } else { - process = mp_make_process(2, @':name', name); - } - cl_apply(4, @'mp::process-preset', process, function, - cl_grab_rest_args(args)); - return mp_process_enable(process); + cl_object process; + ecl_va_list args; + ecl_va_start(args, function, narg, 2); + if (narg < 2) + FEwrong_num_arguments(@[mp::process-run-function]); + if (CONSP(name)) { + process = cl_apply(2, @'mp::make-process', name); + } else { + process = mp_make_process(2, @':name', name); + } + cl_apply(4, @'mp::process-preset', process, function, + cl_grab_rest_args(args)); + return mp_process_enable(process); } cl_object mp_process_run_function_wait(cl_narg narg, ...) { - cl_object process; - ecl_va_list args; - ecl_va_start(args, narg, narg, 0); - process = cl_apply(2, @'mp::process-run-function', - cl_grab_rest_args(args)); - if (!Null(process)) { - ecl_def_ct_single_float(wait, 0.001, static, const); - while (process->process.phase < ECL_PROCESS_ACTIVE) { - cl_sleep(wait); - } - } - @(return process) + cl_object process; + ecl_va_list args; + ecl_va_start(args, narg, narg, 0); + process = cl_apply(2, @'mp::process-run-function', + cl_grab_rest_args(args)); + if (!Null(process)) { + ecl_def_ct_single_float(wait, 0.001, static, const); + while (process->process.phase < ECL_PROCESS_ACTIVE) { + cl_sleep(wait); + } + } + @(return process); } /*---------------------------------------------------------------------- @@ -682,22 +677,22 @@ mp_process_run_function_wait(cl_narg narg, ...) static cl_object mp_get_sigmask(void) { - cl_object data = ecl_alloc_simple_vector(sizeof(sigset_t), ecl_aet_b8); - sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; - sigset_t no_signals; - sigemptyset(&no_signals); - if (pthread_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) - FElibc_error("MP:GET-SIGMASK failed in a call to pthread_sigmask", 0); - @(return data) + cl_object data = ecl_alloc_simple_vector(sizeof(sigset_t), ecl_aet_b8); + sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; + sigset_t no_signals; + sigemptyset(&no_signals); + if (pthread_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) + FElibc_error("MP:GET-SIGMASK failed in a call to pthread_sigmask", 0); + @(return data); } static cl_object mp_set_sigmask(cl_object data) { - sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; - if (pthread_sigmask(SIG_SETMASK, mask_ptr, NULL)) - FElibc_error("MP:SET-SIGMASK failed in a call to pthread_sigmask", 0); - @(return data) + sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; + if (pthread_sigmask(SIG_SETMASK, mask_ptr, NULL)) + FElibc_error("MP:SET-SIGMASK failed in a call to pthread_sigmask", 0); + @(return data); } #endif @@ -705,17 +700,17 @@ cl_object mp_block_signals(void) { #ifdef ECL_WINDOWS_THREADS - cl_env_ptr the_env = ecl_process_env(); - cl_object previous = ecl_symbol_value(@'ext::*interrupts-enabled*'); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); - @(return previous) + cl_env_ptr the_env = ecl_process_env(); + cl_object previous = ecl_symbol_value(@'ext::*interrupts-enabled*'); + ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + @(return previous); #else - cl_object previous = mp_get_sigmask(); - sigset_t all_signals; - sigfillset(&all_signals); - if (pthread_sigmask(SIG_SETMASK, &all_signals, NULL)) - FElibc_error("MP:BLOCK-SIGNALS failed in a call to pthread_sigmask",0); - @(return previous) + cl_object previous = mp_get_sigmask(); + sigset_t all_signals; + sigfillset(&all_signals); + if (pthread_sigmask(SIG_SETMASK, &all_signals, NULL)) + FElibc_error("MP:BLOCK-SIGNALS failed in a call to pthread_sigmask",0); + @(return previous); #endif } @@ -723,12 +718,12 @@ cl_object mp_restore_signals(cl_object sigmask) { #ifdef ECL_WINDOWS_THREADS - cl_env_ptr the_env = ecl_process_env(); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask); - ecl_check_pending_interrupts(the_env); - @(return sigmask) + cl_env_ptr the_env = ecl_process_env(); + ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask); + ecl_check_pending_interrupts(the_env); + @(return sigmask); #else - return mp_set_sigmask(sigmask); + return mp_set_sigmask(sigmask); #endif } @@ -739,60 +734,60 @@ mp_restore_signals(cl_object sigmask) void init_threads(cl_env_ptr env) { - cl_object process; - pthread_t main_thread; + cl_object process; + pthread_t main_thread; - cl_core.processes = OBJNULL; + cl_core.processes = OBJNULL; - /* We have to set the environment before any allocation takes place, - * so that the interrupt handling code works. */ + /* We have to set the environment before any allocation takes place, + * so that the interrupt handling code works. */ #if !defined(WITH___THREAD) # if defined(ECL_WINDOWS_THREADS) - cl_env_key = TlsAlloc(); + cl_env_key = TlsAlloc(); # else - pthread_key_create(&cl_env_key, NULL); + pthread_key_create(&cl_env_key, NULL); # endif #endif - ecl_set_process_env(env); + ecl_set_process_env(env); #ifdef ECL_WINDOWS_THREADS - { - HANDLE aux = GetCurrentThread(); - DuplicateHandle(GetCurrentProcess(), - aux, - GetCurrentProcess(), - &main_thread, - 0, - FALSE, - DUPLICATE_SAME_ACCESS); - } + { + HANDLE aux = GetCurrentThread(); + DuplicateHandle(GetCurrentProcess(), + aux, + GetCurrentProcess(), + &main_thread, + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + } #else - main_thread = pthread_self(); + main_thread = pthread_self(); #endif - process = ecl_alloc_object(t_process); - process->process.phase = ECL_PROCESS_ACTIVE; - process->process.name = @'si::top-level'; - process->process.function = ECL_NIL; - process->process.args = ECL_NIL; - process->process.thread = main_thread; - process->process.env = env; - process->process.woken_up = ECL_NIL; - process->process.queue_record = ecl_list1(process); - process->process.start_spinlock = ECL_NIL; - process->process.exit_barrier = ecl_make_barrier(process->process.name, MOST_POSITIVE_FIXNUM); + process = ecl_alloc_object(t_process); + process->process.phase = ECL_PROCESS_ACTIVE; + process->process.name = @'si::top-level'; + process->process.function = ECL_NIL; + process->process.args = ECL_NIL; + process->process.thread = main_thread; + process->process.env = env; + process->process.woken_up = ECL_NIL; + process->process.queue_record = ecl_list1(process); + process->process.start_spinlock = ECL_NIL; + process->process.exit_barrier = ecl_make_barrier(process->process.name, MOST_POSITIVE_FIXNUM); - env->own_process = process; + env->own_process = process; - { - cl_object v = si_make_vector(ECL_T, /* Element type */ - ecl_make_fixnum(256), /* Size */ - ecl_make_fixnum(0), /* fill pointer */ - ECL_NIL, ECL_NIL, ECL_NIL); - v->vector.self.t[0] = process; - v->vector.fillp = 1; - cl_core.processes = v; - cl_core.global_lock = ecl_make_lock(@'mp::global-lock', 1); - cl_core.error_lock = ecl_make_lock(@'mp::error-lock', 1); - cl_core.global_env_lock = ecl_make_rwlock(@'ext::package-lock'); - } + { + cl_object v = si_make_vector(ECL_T, /* Element type */ + ecl_make_fixnum(256), /* Size */ + ecl_make_fixnum(0), /* fill pointer */ + ECL_NIL, ECL_NIL, ECL_NIL); + v->vector.self.t[0] = process; + v->vector.fillp = 1; + cl_core.processes = v; + cl_core.global_lock = ecl_make_lock(@'mp::global-lock', 1); + cl_core.error_lock = ecl_make_lock(@'mp::error-lock', 1); + cl_core.global_env_lock = ecl_make_rwlock(@'ext::package-lock'); + } } diff --git a/src/c/threads/queue.d b/src/c/threads/queue.d index e972521ab..e262b80c1 100755 --- a/src/c/threads/queue.d +++ b/src/c/threads/queue.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - queue.d -- waiting queue for threads. -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * queue.d - waiting queue for threads + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifdef HAVE_SCHED_H #include @@ -27,59 +22,59 @@ void ECL_INLINE ecl_process_yield() { #if defined(ECL_WINDOWS_THREADS) - Sleep(0); + Sleep(0); #elif defined(HAVE_SCHED_H) - sched_yield(); + sched_yield(); #else - ecl_musleep(0.0, 1);*/ + ecl_musleep(0.0, 1);*/ #endif -} + } void ECL_INLINE ecl_get_spinlock(cl_env_ptr the_env, cl_object *lock) { - cl_object own_process = the_env->own_process; - while (!AO_compare_and_swap_full((AO_t*)lock, (AO_t)ECL_NIL, - (AO_t)own_process)) { - ecl_process_yield(); - } + cl_object own_process = the_env->own_process; + while (!AO_compare_and_swap_full((AO_t*)lock, (AO_t)ECL_NIL, + (AO_t)own_process)) { + ecl_process_yield(); + } } void ECL_INLINE ecl_giveup_spinlock(cl_object *lock) { - AO_store((AO_t*)lock, (AO_t)ECL_NIL); + AO_store((AO_t*)lock, (AO_t)ECL_NIL); } static ECL_INLINE void wait_queue_nconc(cl_env_ptr the_env, cl_object q, cl_object new_tail) { - ecl_get_spinlock(the_env, &q->queue.spinlock); - q->queue.list = ecl_nconc(q->queue.list, new_tail); - ecl_giveup_spinlock(&q->queue.spinlock); + ecl_get_spinlock(the_env, &q->queue.spinlock); + q->queue.list = ecl_nconc(q->queue.list, new_tail); + ecl_giveup_spinlock(&q->queue.spinlock); } static ECL_INLINE cl_object wait_queue_pop_all(cl_env_ptr the_env, cl_object q) { - cl_object output; - ecl_disable_interrupts_env(the_env); - { - ecl_get_spinlock(the_env, &q->queue.spinlock); - output = q->queue.list; - q->queue.list = ECL_NIL; - ecl_giveup_spinlock(&q->queue.spinlock); - } - ecl_enable_interrupts_env(the_env); - return output; + cl_object output; + ecl_disable_interrupts_env(the_env); + { + ecl_get_spinlock(the_env, &q->queue.spinlock); + output = q->queue.list; + q->queue.list = ECL_NIL; + ecl_giveup_spinlock(&q->queue.spinlock); + } + ecl_enable_interrupts_env(the_env); + return output; } static ECL_INLINE void wait_queue_delete(cl_env_ptr the_env, cl_object q, cl_object item) { - ecl_get_spinlock(the_env, &q->queue.spinlock); - q->queue.list = ecl_delete_eq(item, q->queue.list); - ecl_giveup_spinlock(&q->queue.spinlock); + ecl_get_spinlock(the_env, &q->queue.spinlock); + q->queue.list = ecl_delete_eq(item, q->queue.list); + ecl_giveup_spinlock(&q->queue.spinlock); } /*---------------------------------------------------------------------- @@ -89,112 +84,112 @@ wait_queue_delete(cl_env_ptr the_env, cl_object q, cl_object item) static cl_object bignum_set_time(cl_object bignum, struct ecl_timeval *time) { - _ecl_big_set_index(bignum, time->tv_sec); - _ecl_big_mul_ui(bignum, bignum, 1000); - _ecl_big_add_ui(bignum, bignum, (time->tv_usec + 999) / 1000); - return bignum; + _ecl_big_set_index(bignum, time->tv_sec); + _ecl_big_mul_ui(bignum, bignum, 1000); + _ecl_big_add_ui(bignum, bignum, (time->tv_usec + 999) / 1000); + return bignum; } static cl_object elapsed_time(struct ecl_timeval *start) { - cl_object delta_big = _ecl_big_register0(); - cl_object aux_big = _ecl_big_register1(); - struct ecl_timeval now; - ecl_get_internal_real_time(&now); - bignum_set_time(aux_big, start); - bignum_set_time(delta_big, &now); - _ecl_big_sub(delta_big, delta_big, aux_big); - _ecl_big_register_free(aux_big); - return delta_big; + cl_object delta_big = _ecl_big_register0(); + cl_object aux_big = _ecl_big_register1(); + struct ecl_timeval now; + ecl_get_internal_real_time(&now); + bignum_set_time(aux_big, start); + bignum_set_time(delta_big, &now); + _ecl_big_sub(delta_big, delta_big, aux_big); + _ecl_big_register_free(aux_big); + return delta_big; } static double waiting_time(cl_index iteration, struct ecl_timeval *start) { - /* Waiting time is smaller than 0.10 s */ - double time; - cl_object top = ecl_make_fixnum(10 * 1000); - cl_object delta_big = elapsed_time(start); - _ecl_big_div_ui(delta_big, delta_big, iteration); - if (ecl_number_compare(delta_big, top) < 0) { - time = ecl_to_double(delta_big) * 1.5; - } else { - time = 0.10; - } - _ecl_big_register_free(delta_big); - return time; + /* Waiting time is smaller than 0.10 s */ + double time; + cl_object top = ecl_make_fixnum(10 * 1000); + cl_object delta_big = elapsed_time(start); + _ecl_big_div_ui(delta_big, delta_big, iteration); + if (ecl_number_compare(delta_big, top) < 0) { + time = ecl_to_double(delta_big) * 1.5; + } else { + time = 0.10; + } + _ecl_big_register_free(delta_big); + return time; } static cl_object ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) { - volatile const cl_env_ptr the_env = env; - volatile cl_object own_process = the_env->own_process; - volatile cl_object record; - volatile cl_object output; - cl_fixnum iteration = 0; - struct ecl_timeval start; - ecl_get_internal_real_time(&start); + volatile const cl_env_ptr the_env = env; + volatile cl_object own_process = the_env->own_process; + volatile cl_object record; + volatile cl_object output; + cl_fixnum iteration = 0; + struct ecl_timeval start; + ecl_get_internal_real_time(&start); - /* This spinlock is here because the default path (fair) is - * too slow */ - for (iteration = 0; iteration < 10; iteration++) { - cl_object output = condition(the_env,o); - if (output != ECL_NIL) - return output; - } + /* This spinlock is here because the default path (fair) is + * too slow */ + for (iteration = 0; iteration < 10; iteration++) { + cl_object output = condition(the_env,o); + if (output != ECL_NIL) + return output; + } - /* 0) We reserve a record for the queue. In order to avoid - * using the garbage collector, we reuse records */ - record = own_process->process.queue_record; - unlikely_if (record == ECL_NIL) { - record = ecl_list1(own_process); - } else { - own_process->process.queue_record = ECL_NIL; - } + /* 0) We reserve a record for the queue. In order to avoid + * using the garbage collector, we reuse records */ + record = own_process->process.queue_record; + unlikely_if (record == ECL_NIL) { + record = ecl_list1(own_process); + } else { + own_process->process.queue_record = ECL_NIL; + } - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* 2) Now we add ourselves to the queue. In order to - * avoid a call to the GC, we try to reuse records. */ - print_lock("adding to queue", o); - own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_T); - ecl_check_pending_interrupts(the_env); + ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + ECL_UNWIND_PROTECT_BEGIN(the_env) { + /* 2) Now we add ourselves to the queue. In order to + * avoid a call to the GC, we try to reuse records. */ + print_lock("adding to queue", o); + own_process->process.woken_up = ECL_NIL; + wait_queue_nconc(the_env, o, record); + ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_T); + ecl_check_pending_interrupts(the_env); - /* 3) Unlike the sigsuspend() implementation, this - * implementation does not block signals and the - * wakeup event might be lost before the sleep - * function is invoked. We must thus spin over short - * intervals of time to ensure that we check the - * condition periodically. */ - while (Null(output = condition(the_env, o))) { - ecl_musleep(waiting_time(iteration++, &start), 1); - } - ecl_bds_unwind1(the_env); - } ECL_UNWIND_PROTECT_EXIT { - /* 4) At this point we wrap up. We remove ourselves - * from the queue and unblock the lisp interrupt - * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); - own_process->process.queue_record = record; - ECL_RPLACD(record, ECL_NIL); + /* 3) Unlike the sigsuspend() implementation, this + * implementation does not block signals and the + * wakeup event might be lost before the sleep + * function is invoked. We must thus spin over short + * intervals of time to ensure that we check the + * condition periodically. */ + while (Null(output = condition(the_env, o))) { + ecl_musleep(waiting_time(iteration++, &start), 1); + } + ecl_bds_unwind1(the_env); + } ECL_UNWIND_PROTECT_EXIT { + /* 4) At this point we wrap up. We remove ourselves + * from the queue and unblock the lisp interrupt + * signal. Note that we recover the cons for later use.*/ + wait_queue_delete(the_env, o, own_process); + own_process->process.queue_record = record; + ECL_RPLACD(record, ECL_NIL); - /* 5) When this process exits, it may be because it - * aborts (which we know because output == ECL_NIL), or - * because the condition is satisfied. In both cases - * we allow the first in the queue to test again its - * condition. This is needed for objects, such as - * semaphores, where the condition may be satisfied - * more than once. */ - if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); - } - } ECL_UNWIND_PROTECT_END; - ecl_bds_unwind1(the_env); - return output; + /* 5) When this process exits, it may be because it + * aborts (which we know because output == ECL_NIL), or + * because the condition is satisfied. In both cases + * we allow the first in the queue to test again its + * condition. This is needed for objects, such as + * semaphores, where the condition may be satisfied + * more than once. */ + if (Null(output)) { + ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + } + } ECL_UNWIND_PROTECT_END; + ecl_bds_unwind1(the_env); + return output; } /********************************************************************** @@ -230,140 +225,140 @@ cl_object ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) { #if defined(HAVE_SIGPROCMASK) - volatile const cl_env_ptr the_env = env; - volatile cl_object own_process = the_env->own_process; - volatile cl_object record; - volatile sigset_t original; - volatile cl_object output; + volatile const cl_env_ptr the_env = env; + volatile cl_object own_process = the_env->own_process; + volatile cl_object record; + volatile sigset_t original; + volatile cl_object output; - /* 0) We reserve a record for the queue. In order to avoid - * using the garbage collector, we reuse records */ - record = own_process->process.queue_record; - unlikely_if (record == ECL_NIL) { - record = ecl_list1(own_process); - } else { - own_process->process.queue_record = ECL_NIL; - } + /* 0) We reserve a record for the queue. In order to avoid + * using the garbage collector, we reuse records */ + record = own_process->process.queue_record; + unlikely_if (record == ECL_NIL) { + record = ecl_list1(own_process); + } else { + own_process->process.queue_record = ECL_NIL; + } - /* 1) First we block lisp interrupt signals. This ensures that - * any awake signal that is issued from here is not lost. */ - { - int code = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - sigset_t empty; - sigemptyset(&empty); - sigaddset(&empty, code); - pthread_sigmask(SIG_BLOCK, &empty, &original); - } + /* 1) First we block lisp interrupt signals. This ensures that + * any awake signal that is issued from here is not lost. */ + { + int code = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; + sigset_t empty; + sigemptyset(&empty); + sigaddset(&empty, code); + pthread_sigmask(SIG_BLOCK, &empty, &original); + } - /* 2) Now we add ourselves to the queue. */ - own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); + /* 2) Now we add ourselves to the queue. */ + own_process->process.woken_up = ECL_NIL; + wait_queue_nconc(the_env, o, record); - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* 3) At this point we may receive signals, but we - * might have missed a wakeup event if that happened - * between 0) and 2), which is why we start with the - * check*/ - while (Null(output = condition(the_env, o))) - { - /* This will wait until we get a signal that - * demands some code being executed. Note that - * this includes our communication signals and - * the signals used by the GC. Note also that - * as a consequence we might throw / return - * which is why need to protect it all with - * UNWIND-PROTECT. */ - sigsuspend(&original); - } - } ECL_UNWIND_PROTECT_EXIT { - /* 4) At this point we wrap up. We remove ourselves - * from the queue and unblock the lisp interrupt - * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); - own_process->process.queue_record = record; - ECL_RPLACD(record, ECL_NIL); + ECL_UNWIND_PROTECT_BEGIN(the_env) { + /* 3) At this point we may receive signals, but we + * might have missed a wakeup event if that happened + * between 0) and 2), which is why we start with the + * check*/ + while (Null(output = condition(the_env, o))) + { + /* This will wait until we get a signal that + * demands some code being executed. Note that + * this includes our communication signals and + * the signals used by the GC. Note also that + * as a consequence we might throw / return + * which is why need to protect it all with + * UNWIND-PROTECT. */ + sigsuspend(&original); + } + } ECL_UNWIND_PROTECT_EXIT { + /* 4) At this point we wrap up. We remove ourselves + * from the queue and unblock the lisp interrupt + * signal. Note that we recover the cons for later use.*/ + wait_queue_delete(the_env, o, own_process); + own_process->process.queue_record = record; + ECL_RPLACD(record, ECL_NIL); - /* 5) When this process exits, it may be because it - * aborts (which we know because output == ECL_NIL), or - * because the condition is satisfied. In both cases - * we allow the first in the queue to test again its - * condition. This is needed for objects, such as - * semaphores, where the condition may be satisfied - * more than once. */ - if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); - } + /* 5) When this process exits, it may be because it + * aborts (which we know because output == ECL_NIL), or + * because the condition is satisfied. In both cases + * we allow the first in the queue to test again its + * condition. This is needed for objects, such as + * semaphores, where the condition may be satisfied + * more than once. */ + if (Null(output)) { + ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + } - /* 6) Restoring signals is done last, to ensure that - * all cleanup steps are performed. */ - pthread_sigmask(SIG_SETMASK, &original, NULL); - } ECL_UNWIND_PROTECT_END; - return output; + /* 6) Restoring signals is done last, to ensure that + * all cleanup steps are performed. */ + pthread_sigmask(SIG_SETMASK, &original, NULL); + } ECL_UNWIND_PROTECT_END; + return output; #else - return ecl_wait_on_timed(env, condition, o); + return ecl_wait_on_timed(env, condition, o); #endif } cl_object ecl_waiter_pop(cl_env_ptr the_env, cl_object q) { - cl_object output; - ecl_disable_interrupts_env(the_env); - ecl_get_spinlock(the_env, &q->queue.spinlock); - { - cl_object l; - output = ECL_NIL; - for (l = q->queue.list; l != ECL_NIL; l = ECL_CONS_CDR(l)) { - cl_object p = ECL_CONS_CAR(l); - if (p->process.phase != ECL_PROCESS_INACTIVE && - p->process.phase != ECL_PROCESS_EXITING) { - output = p; - break; - } - } - } - ecl_giveup_spinlock(&q->queue.spinlock); - ecl_enable_interrupts_env(the_env); - return output; + cl_object output; + ecl_disable_interrupts_env(the_env); + ecl_get_spinlock(the_env, &q->queue.spinlock); + { + cl_object l; + output = ECL_NIL; + for (l = q->queue.list; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + cl_object p = ECL_CONS_CAR(l); + if (p->process.phase != ECL_PROCESS_INACTIVE && + p->process.phase != ECL_PROCESS_EXITING) { + output = p; + break; + } + } + } + ecl_giveup_spinlock(&q->queue.spinlock); + ecl_enable_interrupts_env(the_env); + return output; } void ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags) { - ecl_disable_interrupts_env(the_env); - ecl_get_spinlock(the_env, &q->queue.spinlock); - if (q->queue.list != ECL_NIL) { - /* We scan the list of waiting processes, awaking one - * or more, depending on flags. In running through the list - * we eliminate zombie processes --- they should not be here - * because of the UNWIND-PROTECT in ecl_wait_on(), but - * sometimes shit happens */ - cl_object *tail, l; - for (tail = &q->queue.list; (l = *tail) != ECL_NIL; ) { - cl_object p = ECL_CONS_CAR(l); - if (p->process.phase == ECL_PROCESS_INACTIVE || - p->process.phase == ECL_PROCESS_EXITING) { - print_lock("removing %p", q, p); - *tail = ECL_CONS_CDR(l); - } else { - print_lock("awaking %p", q, p); - /* If the process is active, we then - * simply awake it with a signal.*/ - p->process.woken_up = ECL_T; - if (flags & ECL_WAKEUP_DELETE) - *tail = ECL_CONS_CDR(l); - tail = &ECL_CONS_CDR(l); - if (flags & ECL_WAKEUP_KILL) - mp_process_kill(p); - else - ecl_wakeup_process(p); - if (!(flags & ECL_WAKEUP_ALL)) - break; - } - } - } - ecl_giveup_spinlock(&q->queue.spinlock); - ecl_process_yield(); + ecl_disable_interrupts_env(the_env); + ecl_get_spinlock(the_env, &q->queue.spinlock); + if (q->queue.list != ECL_NIL) { + /* We scan the list of waiting processes, awaking one + * or more, depending on flags. In running through the list + * we eliminate zombie processes --- they should not be here + * because of the UNWIND-PROTECT in ecl_wait_on(), but + * sometimes shit happens */ + cl_object *tail, l; + for (tail = &q->queue.list; (l = *tail) != ECL_NIL; ) { + cl_object p = ECL_CONS_CAR(l); + if (p->process.phase == ECL_PROCESS_INACTIVE || + p->process.phase == ECL_PROCESS_EXITING) { + print_lock("removing %p", q, p); + *tail = ECL_CONS_CDR(l); + } else { + print_lock("awaking %p", q, p); + /* If the process is active, we then + * simply awake it with a signal.*/ + p->process.woken_up = ECL_T; + if (flags & ECL_WAKEUP_DELETE) + *tail = ECL_CONS_CDR(l); + tail = &ECL_CONS_CDR(l); + if (flags & ECL_WAKEUP_KILL) + mp_process_kill(p); + else + ecl_wakeup_process(p); + if (!(flags & ECL_WAKEUP_ALL)) + break; + } + } + } + ecl_giveup_spinlock(&q->queue.spinlock); + ecl_process_yield(); } #undef print_lock @@ -371,25 +366,25 @@ ecl_wakeup_waiters(cl_env_ptr the_env, cl_object q, int flags) void print_lock(char *prefix, cl_object l, ...) { - static cl_object lock = ECL_NIL; - va_list args; - va_start(args, l); - if (l == ECL_NIL - || type_of(l) == t_condition_variable - || ECL_FIXNUMP(l->lock.name)) { - cl_env_ptr env = ecl_process_env(); - ecl_get_spinlock(env, &lock); - printf("\n%ld\t", ecl_fixnum(env->own_process->process.name)); - vprintf(prefix, args); - if (l != ECL_NIL) { - cl_object p = l->lock.queue_list; - while (p != ECL_NIL) { - printf(" %lx", ecl_fixnum(ECL_CONS_CAR(p)->process.name)); - p = ECL_CONS_CDR(p); - } - } - fflush(stdout); - ecl_giveup_spinlock(&lock); - } + static cl_object lock = ECL_NIL; + va_list args; + va_start(args, l); + if (l == ECL_NIL + || type_of(l) == t_condition_variable + || ECL_FIXNUMP(l->lock.name)) { + cl_env_ptr env = ecl_process_env(); + ecl_get_spinlock(env, &lock); + printf("\n%ld\t", ecl_fixnum(env->own_process->process.name)); + vprintf(prefix, args); + if (l != ECL_NIL) { + cl_object p = l->lock.queue_list; + while (p != ECL_NIL) { + printf(" %lx", ecl_fixnum(ECL_CONS_CAR(p)->process.name)); + p = ECL_CONS_CDR(p); + } + } + fflush(stdout); + ecl_giveup_spinlock(&lock); + } } /*#define print_lock(a,b,c) (void)0*/ diff --git a/src/c/threads/rwlock.d b/src/c/threads/rwlock.d index bfef63b29..19d794ea5 100644 --- a/src/c/threads/rwlock.d +++ b/src/c/threads/rwlock.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - rwlock.d -- POSIX read-write locks -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * rwlock.d - POSIX read-write locks + * + * Copyright (c) 2003 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #ifndef __sun__ /* See unixinit.d for this */ #define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ @@ -34,195 +29,197 @@ static void FEerror_not_a_rwlock(cl_object lock) { - FEwrong_type_argument(@'mp::rwlock', lock); + FEwrong_type_argument(@'mp::rwlock', lock); } static void FEunknown_rwlock_error(cl_object lock, int rc) { #ifdef ECL_WINDOWS_THREADS - FEwin32_error("When acting on rwlock ~A, got an unexpected error.", 1, lock); + FEwin32_error("When acting on rwlock ~A, got an unexpected error.", 1, lock); #else - const char *msg = NULL; - switch (rc) { - case EINVAL: - msg = "The value specified by rwlock is invalid"; - break; - case EPERM: - msg = "Read/write lock not owned by us"; - break; - case EDEADLK: - msg = "Thread already owns this lock"; - break; - case ENOMEM: - msg = "Out of memory"; - break; - default: - FElibc_error("When acting on rwlock ~A, got an unexpected error.", - 1, lock); - } - FEerror("When acting on rwlock ~A, got the following C library error:~%" - "~A", 2, lock, make_constant_base_string(msg)); + const char *msg = NULL; + switch (rc) { + case EINVAL: + msg = "The value specified by rwlock is invalid"; + break; + case EPERM: + msg = "Read/write lock not owned by us"; + break; + case EDEADLK: + msg = "Thread already owns this lock"; + break; + case ENOMEM: + msg = "Out of memory"; + break; + default: + FElibc_error("When acting on rwlock ~A, got an unexpected error.", + 1, lock); + } + FEerror("When acting on rwlock ~A, got the following C library error:~%" + "~A", 2, lock, make_constant_base_string(msg)); #endif } cl_object ecl_make_rwlock(cl_object name) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object output = ecl_alloc_object(t_rwlock); + const cl_env_ptr the_env = ecl_process_env(); + cl_object output = ecl_alloc_object(t_rwlock); #ifdef ECL_RWLOCK - int rc; - ecl_disable_interrupts_env(the_env); - rc = pthread_rwlock_init(&output->rwlock.mutex, NULL); - ecl_enable_interrupts_env(the_env); - if (rc) { - FEerror("Unable to create read/write lock", 0); - } - ecl_set_finalizer_unprotected(output, ECL_T); + int rc; + ecl_disable_interrupts_env(the_env); + rc = pthread_rwlock_init(&output->rwlock.mutex, NULL); + ecl_enable_interrupts_env(the_env); + if (rc) { + FEerror("Unable to create read/write lock", 0); + } + ecl_set_finalizer_unprotected(output, ECL_T); #else - output->rwlock.mutex = ecl_make_lock(name, 0); + output->rwlock.mutex = ecl_make_lock(name, 0); #endif - output->rwlock.name = name; - return output; + output->rwlock.name = name; + return output; } @(defun mp::make-rwlock (&key name) -@ - @(return ecl_make_rwlock(name)) -@) + @ + @(return ecl_make_rwlock(name)); + @) cl_object mp_rwlock_name(cl_object lock) { - const cl_env_ptr env = ecl_process_env(); - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); - ecl_return1(env, lock->rwlock.name); + const cl_env_ptr env = ecl_process_env(); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); + ecl_return1(env, lock->rwlock.name); } cl_object mp_giveup_rwlock_read(cl_object lock) { - /* Must be called with interrupts disabled. */ - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + /* Must be called with interrupts disabled. */ + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - int rc = pthread_rwlock_unlock(&lock->rwlock.mutex); - if (rc) - FEunknown_rwlock_error(lock, rc); - @(return ECL_T); - } + { + int rc = pthread_rwlock_unlock(&lock->rwlock.mutex); + if (rc) + FEunknown_rwlock_error(lock, rc); + @(return ECL_T); + } #else - return mp_giveup_lock(lock->rwlock.mutex); + return mp_giveup_lock(lock->rwlock.mutex); #endif } cl_object mp_giveup_rwlock_write(cl_object lock) { - return mp_giveup_rwlock_read(lock); + return mp_giveup_rwlock_read(lock); } cl_object mp_get_rwlock_read_nowait(cl_object lock) { - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - const cl_env_ptr env = ecl_process_env(); - cl_object output = ECL_T; - int rc = pthread_rwlock_tryrdlock(&lock->rwlock.mutex); - if (rc == 0) { - output = ECL_T; - } else if (rc == EBUSY) { - output = ECL_NIL; - } else { - FEunknown_rwlock_error(lock, rc); - } - ecl_return1(env, output); - } + { + const cl_env_ptr env = ecl_process_env(); + cl_object output = ECL_T; + int rc = pthread_rwlock_tryrdlock(&lock->rwlock.mutex); + if (rc == 0) { + output = ECL_T; + } else if (rc == EBUSY) { + output = ECL_NIL; + } else { + FEunknown_rwlock_error(lock, rc); + } + ecl_return1(env, output); + } #else - return mp_get_lock_nowait(lock->rwlock.mutex); + return mp_get_lock_nowait(lock->rwlock.mutex); #endif } cl_object mp_get_rwlock_read_wait(cl_object lock) { - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - const cl_env_ptr env = ecl_process_env(); - int rc = pthread_rwlock_rdlock(&lock->rwlock.mutex); - if (rc != 0) { - FEunknown_rwlock_error(lock, rc); - } - ecl_return1(env, ECL_T); - } + { + const cl_env_ptr env = ecl_process_env(); + int rc = pthread_rwlock_rdlock(&lock->rwlock.mutex); + if (rc != 0) { + FEunknown_rwlock_error(lock, rc); + } + ecl_return1(env, ECL_T); + } #else - return mp_get_lock_wait(lock->rwlock.mutex); + return mp_get_lock_wait(lock->rwlock.mutex); #endif } @(defun mp::get-rwlock-read (lock &optional (wait ECL_T)) -@ - if (Null(wait)) - return mp_get_rwlock_read_nowait(lock); - else - return mp_get_rwlock_read_wait(lock); -@) + @ + if (Null(wait)) + return mp_get_rwlock_read_nowait(lock); + else + return mp_get_rwlock_read_wait(lock); + @) cl_object mp_get_rwlock_write_nowait(cl_object lock) { - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - const cl_env_ptr env = ecl_process_env(); - cl_object output = ECL_T; - int rc = pthread_rwlock_trywrlock(&lock->rwlock.mutex); - if (rc == 0) { - output = ECL_T; - } else if (rc == EBUSY) { - output = ECL_NIL; - } else { - FEunknown_rwlock_error(lock, rc); - } - ecl_return1(env, output); - } + { + const cl_env_ptr env = ecl_process_env(); + cl_object output = ECL_T; + int rc = pthread_rwlock_trywrlock(&lock->rwlock.mutex); + if (rc == 0) { + output = ECL_T; + } else if (rc == EBUSY) { + output = ECL_NIL; + } else { + FEunknown_rwlock_error(lock, rc); + } + ecl_return1(env, output); + } #else - return mp_get_lock_nowait(lock->rwlock.mutex); + return mp_get_lock_nowait(lock->rwlock.mutex); #endif } cl_object mp_get_rwlock_write_wait(cl_object lock) { - cl_env_ptr env = ecl_process_env(); - if (ecl_t_of(lock) != t_rwlock) - FEerror_not_a_rwlock(lock); + cl_env_ptr env = ecl_process_env(); + if (ecl_t_of(lock) != t_rwlock) + FEerror_not_a_rwlock(lock); #ifdef ECL_RWLOCK - { - int rc = pthread_rwlock_wrlock(&lock->rwlock.mutex); - if (rc != 0) { - FEunknown_rwlock_error(lock, rc); - } - @(return ECL_T) - } + { + int rc = pthread_rwlock_wrlock(&lock->rwlock.mutex); + if (rc != 0) { + FEunknown_rwlock_error(lock, rc); + } + @(return ECL_T); + } #else - return mp_get_lock_wait(lock->rwlock.mutex); + return mp_get_lock_wait(lock->rwlock.mutex); #endif } @(defun mp::get-rwlock-write (lock &optional (wait ECL_T)) -@ - if (Null(wait)) - return mp_get_rwlock_write_nowait(lock); - else - return mp_get_rwlock_write_wait(lock); -@) + @ + if (Null(wait)) { + return mp_get_rwlock_write_nowait(lock); + } + else { + return mp_get_rwlock_write_wait(lock); + } + @) diff --git a/src/c/threads/semaphore.d b/src/c/threads/semaphore.d index 5f9d98f0a..a428f1167 100644 --- a/src/c/threads/semaphore.d +++ b/src/c/threads/semaphore.d @@ -1,19 +1,14 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - semaphore.d -- POSIX-like semaphores -*/ -/* - Copyright (c) 2011, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * semaphore.d - POSIX-like semaphores + * + * Copyright (c) 2011 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #define AO_ASSUME_WINDOWS98 /* We need this for CAS */ #include @@ -26,118 +21,114 @@ static ECL_INLINE void FEerror_not_a_semaphore(cl_object semaphore) { - FEwrong_type_argument(@'mp::semaphore', semaphore); + FEwrong_type_argument(@'mp::semaphore', semaphore); } cl_object ecl_make_semaphore(cl_object name, cl_fixnum count) { - cl_object output = ecl_alloc_object(t_semaphore); - output->semaphore.name = name; - output->semaphore.counter = count; - output->semaphore.queue_list = ECL_NIL; - output->semaphore.queue_spinlock = ECL_NIL; - return output; + cl_object output = ecl_alloc_object(t_semaphore); + output->semaphore.name = name; + output->semaphore.counter = count; + output->semaphore.queue_list = ECL_NIL; + output->semaphore.queue_spinlock = ECL_NIL; + return output; } @(defun mp::make-semaphore (&key name (count ecl_make_fixnum(0))) -@ -{ - @(return ecl_make_semaphore(name, fixnnint(count))) -} -@) + @ { + @(return ecl_make_semaphore(name, fixnnint(count))); + } @) cl_object mp_semaphore_name(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, semaphore->semaphore.name); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, semaphore->semaphore.name); } cl_object mp_semaphore_count(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, ecl_make_fixnum(semaphore->semaphore.counter)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, ecl_make_fixnum(semaphore->semaphore.counter)); } cl_object mp_semaphore_wait_count(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, cl_length(semaphore->semaphore.queue_list)); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, cl_length(semaphore->semaphore.queue_list)); } @(defun mp::signal-semaphore (semaphore &optional (count ecl_make_fixnum(1))) -@ -{ - cl_fixnum n = fixnnint(count); - cl_env_ptr env = ecl_process_env(); - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - AO_fetch_and_add((AO_t*)&semaphore->semaphore.counter, n); - if (semaphore->semaphore.queue_list != ECL_NIL) { - ecl_wakeup_waiters(env, semaphore, ECL_WAKEUP_ONE); - } - @(return) -} -@) + @ { + cl_fixnum n = fixnnint(count); + cl_env_ptr env = ecl_process_env(); + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + AO_fetch_and_add((AO_t*)&semaphore->semaphore.counter, n); + if (semaphore->semaphore.queue_list != ECL_NIL) { + ecl_wakeup_waiters(env, semaphore, ECL_WAKEUP_ONE); + } + @(return); + } @) static cl_object get_semaphore_inner(cl_env_ptr env, cl_object semaphore) { - cl_object output; - ecl_disable_interrupts_env(env); - do { - cl_fixnum counter = semaphore->semaphore.counter; - if (!counter) { - output = ECL_NIL; - break; - } - if (AO_compare_and_swap_full((AO_t*)&(semaphore->semaphore.counter), - (AO_t)counter, (AO_t)(counter-1))) { - output = ecl_make_fixnum(counter); - break; - } - ecl_process_yield(); - } while (1); - ecl_enable_interrupts_env(env); - return output; + cl_object output; + ecl_disable_interrupts_env(env); + do { + cl_fixnum counter = semaphore->semaphore.counter; + if (!counter) { + output = ECL_NIL; + break; + } + if (AO_compare_and_swap_full((AO_t*)&(semaphore->semaphore.counter), + (AO_t)counter, (AO_t)(counter-1))) { + output = ecl_make_fixnum(counter); + break; + } + ecl_process_yield(); + } while (1); + ecl_enable_interrupts_env(env); + return output; } cl_object mp_wait_on_semaphore(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - cl_object output; - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - output = get_semaphore_inner(env, semaphore); - if (Null(output)) { - output = ecl_wait_on(env, get_semaphore_inner, semaphore); - } - ecl_return1(env, output); + cl_env_ptr env = ecl_process_env(); + cl_object output; + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + output = get_semaphore_inner(env, semaphore); + if (Null(output)) { + output = ecl_wait_on(env, get_semaphore_inner, semaphore); + } + ecl_return1(env, output); } cl_object mp_try_get_semaphore(cl_object semaphore) { - cl_env_ptr env = ecl_process_env(); - cl_object output; - unlikely_if (ecl_t_of(semaphore) != t_semaphore) { - FEerror_not_a_semaphore(semaphore); - } - ecl_return1(env, get_semaphore_inner(env, semaphore)); + cl_env_ptr env = ecl_process_env(); + cl_object output; + unlikely_if (ecl_t_of(semaphore) != t_semaphore) { + FEerror_not_a_semaphore(semaphore); + } + ecl_return1(env, get_semaphore_inner(env, semaphore)); } diff --git a/src/c/time.d b/src/c/time.d index 0fd65a295..05dc9d782 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - time.c -- Time routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * time.d - time routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -50,25 +45,25 @@ void ecl_get_internal_real_time(struct ecl_timeval *tv) { #if defined(HAVE_GETTIMEOFDAY) && !defined(ECL_MS_WINDOWS_HOST) - struct timezone tz; - struct timeval aux; - gettimeofday(&aux, &tz); - tv->tv_usec = aux.tv_usec; - tv->tv_sec = aux.tv_sec; + struct timezone tz; + struct timeval aux; + gettimeofday(&aux, &tz); + tv->tv_usec = aux.tv_usec; + tv->tv_sec = aux.tv_sec; #else # if defined(ECL_MS_WINDOWS_HOST) - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } system_time; - GetSystemTimeAsFileTime(&system_time.filetime); - system_time.hundred_ns /= 10000; - tv->tv_sec = system_time.hundred_ns / 1000; - tv->tv_usec = (system_time.hundred_ns % 1000) * 1000; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } system_time; + GetSystemTimeAsFileTime(&system_time.filetime); + system_time.hundred_ns /= 10000; + tv->tv_sec = system_time.hundred_ns / 1000; + tv->tv_usec = (system_time.hundred_ns % 1000) * 1000; # else - time_t = time(0); - tv->tv_sec = time_t; - tv->tv_usec = 0; + time_t = time(0); + tv->tv_sec = time_t; + tv->tv_usec = 0; # endif #endif } @@ -77,34 +72,34 @@ void ecl_get_internal_run_time(struct ecl_timeval *tv) { #ifdef HAVE_GETRUSAGE - struct rusage r; - getrusage(RUSAGE_SELF, &r); - tv->tv_usec = r.ru_utime.tv_usec; - tv->tv_sec = r.ru_utime.tv_sec; + struct rusage r; + getrusage(RUSAGE_SELF, &r); + tv->tv_usec = r.ru_utime.tv_usec; + tv->tv_sec = r.ru_utime.tv_sec; #else # ifdef HAVE_TIMES - struct tms buf; - times(&buf); - tv->tv_sec = buf.tms_utime / CLK_TCK; - tv->tv_usec = (buf.tms_utime % CLK_TCK) * 1000000; + struct tms buf; + times(&buf); + tv->tv_sec = buf.tms_utime / CLK_TCK; + tv->tv_usec = (buf.tms_utime % CLK_TCK) * 1000000; # else # if defined(ECL_MS_WINDOWS_HOST) - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } kernel_time, user_time, creation_time, exit_time; - if (!GetProcessTimes(GetCurrentProcess(), - &creation_time.filetime, - &exit_time.filetime, - &kernel_time.filetime, - &user_time.filetime)) - FEwin32_error("GetProcessTimes() failed", 0); - kernel_time.hundred_ns += user_time.hundred_ns; - kernel_time.hundred_ns /= 10000; - tv->tv_sec = kernel_time.hundred_ns / 1000; - tv->tv_usec = (kernel_time.hundred_ns % 1000) * 1000; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } kernel_time, user_time, creation_time, exit_time; + if (!GetProcessTimes(GetCurrentProcess(), + &creation_time.filetime, + &exit_time.filetime, + &kernel_time.filetime, + &user_time.filetime)) + FEwin32_error("GetProcessTimes() failed", 0); + kernel_time.hundred_ns += user_time.hundred_ns; + kernel_time.hundred_ns /= 10000; + tv->tv_sec = kernel_time.hundred_ns / 1000; + tv->tv_usec = (kernel_time.hundred_ns % 1000) * 1000; # else - ecl_get_internal_real_time(tv); + ecl_get_internal_real_time(tv); # endif # endif #endif @@ -114,59 +109,59 @@ void ecl_musleep(double time, bool alertable) { #ifdef HAVE_NANOSLEEP - struct timespec tm; - int code; - tm.tv_sec = (time_t)floor(time); - tm.tv_nsec = (long)((time - floor(time)) * 1e9); + struct timespec tm; + int code; + tm.tv_sec = (time_t)floor(time); + tm.tv_nsec = (long)((time - floor(time)) * 1e9); AGAIN: - code = nanosleep(&tm, &tm); - { - int old_errno = errno; - if (code < 0 && old_errno == EINTR && !alertable) { - goto AGAIN; - } - } + code = nanosleep(&tm, &tm); + { + int old_errno = errno; + if (code < 0 && old_errno == EINTR && !alertable) { + goto AGAIN; + } + } #else #if defined (ECL_MS_WINDOWS_HOST) - /* Maximum waiting time that fits in SleepEx. This is the - * largest integer that fits safely in DWORD in milliseconds - * and has to be converted to 100ns (1e-3 / 100e-9 = 1e4) */ - const DWORDLONG maxtime = (DWORDLONG)0xfffffff * (DWORDLONG)10000; - DWORDLONG wait = time * 1e7; - union { - FILETIME filetime; - DWORDLONG hundred_ns; - } end, now; - if (alertable) { - GetSystemTimeAsFileTime(&end.filetime); - end.hundred_ns += wait; - } - do { - DWORDLONG interval; - if (wait > maxtime) { - interval = maxtime; - wait -= maxtime; - } else { - interval = wait; - wait = 0; - } - if (SleepEx(interval/10000, alertable) != 0) { - if (alertable) { - break; - } else { - GetSystemTimeAsFileTime(&now.filetime); - if (now.hundred_ns >= end.hundred_ns) - break; - else - wait = end.hundred_ns - now.hundred_ns; - } - } - } while (wait); + /* Maximum waiting time that fits in SleepEx. This is the + * largest integer that fits safely in DWORD in milliseconds + * and has to be converted to 100ns (1e-3 / 100e-9 = 1e4) */ + const DWORDLONG maxtime = (DWORDLONG)0xfffffff * (DWORDLONG)10000; + DWORDLONG wait = time * 1e7; + union { + FILETIME filetime; + DWORDLONG hundred_ns; + } end, now; + if (alertable) { + GetSystemTimeAsFileTime(&end.filetime); + end.hundred_ns += wait; + } + do { + DWORDLONG interval; + if (wait > maxtime) { + interval = maxtime; + wait -= maxtime; + } else { + interval = wait; + wait = 0; + } + if (SleepEx(interval/10000, alertable) != 0) { + if (alertable) { + break; + } else { + GetSystemTimeAsFileTime(&now.filetime); + if (now.hundred_ns >= end.hundred_ns) + break; + else + wait = end.hundred_ns - now.hundred_ns; + } + } + } while (wait); #else - int t = (int)time; - for (t = (time + 0.5); t > 1000; t -= 1000) - sleep(1000); - sleep(t); + int t = (int)time; + for (t = (time + 0.5); t > 1000; t -= 1000) + sleep(1000); + sleep(t); #endif #endif } @@ -174,75 +169,75 @@ ecl_musleep(double time, bool alertable) cl_fixnum ecl_runtime(void) { - struct ecl_timeval tv; - ecl_get_internal_run_time(&tv); - return tv.tv_sec * 1000 + tv.tv_usec / 1000; + struct ecl_timeval tv; + ecl_get_internal_run_time(&tv); + return tv.tv_sec * 1000 + tv.tv_usec / 1000; } cl_object cl_sleep(cl_object z) { - double time; - /* INV: ecl_minusp() makes sure `z' is real */ - if (ecl_minusp(z)) - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a non-negative number ~S"), - @':format-arguments', cl_list(1, z), - @':expected-type', @'real', @':datum', z); - /* Compute time without overflows */ - ECL_WITHOUT_FPE_BEGIN { - time = ecl_to_double(z); - if (isnan(time) || !isfinite(time) || (time > INT_MAX)) { - time = INT_MAX; - } else if (time < 1e-9) { - time = 1e-9; - } - } ECL_WITHOUT_FPE_END; - ecl_musleep(time, 0); - @(return ECL_NIL) + double time; + /* INV: ecl_minusp() makes sure `z' is real */ + if (ecl_minusp(z)) + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a non-negative number ~S"), + @':format-arguments', cl_list(1, z), + @':expected-type', @'real', @':datum', z); + /* Compute time without overflows */ + ECL_WITHOUT_FPE_BEGIN { + time = ecl_to_double(z); + if (isnan(time) || !isfinite(time) || (time > INT_MAX)) { + time = INT_MAX; + } else if (time < 1e-9) { + time = 1e-9; + } + } ECL_WITHOUT_FPE_END; + ecl_musleep(time, 0); + @(return ECL_NIL); } static cl_object timeval_to_time(long sec, long usec) { - cl_object milliseconds = ecl_plus(ecl_times(ecl_make_integer(sec), - ecl_make_fixnum(1000)), - ecl_make_integer(usec / 1000)); - @(return milliseconds); + cl_object milliseconds = ecl_plus(ecl_times(ecl_make_integer(sec), + ecl_make_fixnum(1000)), + ecl_make_integer(usec / 1000)); + @(return milliseconds); } cl_object cl_get_internal_run_time() { - struct ecl_timeval tv; - ecl_get_internal_run_time(&tv); - return timeval_to_time(tv.tv_sec, tv.tv_usec); + struct ecl_timeval tv; + ecl_get_internal_run_time(&tv); + return timeval_to_time(tv.tv_sec, tv.tv_usec); } cl_object cl_get_internal_real_time() { - struct ecl_timeval tv; - ecl_get_internal_real_time(&tv); - return timeval_to_time(tv.tv_sec - beginning.tv_sec, - tv.tv_usec - beginning.tv_usec); + struct ecl_timeval tv; + ecl_get_internal_real_time(&tv); + return timeval_to_time(tv.tv_sec - beginning.tv_sec, + tv.tv_usec - beginning.tv_usec); } cl_object cl_get_universal_time() { - cl_object utc = ecl_make_integer(time(0)); - @(return ecl_plus(utc, cl_core.Jan1st1970UT)) + cl_object utc = ecl_make_integer(time(0)); + @(return ecl_plus(utc, cl_core.Jan1st1970UT)); } void init_unixtime(void) { - ecl_get_internal_real_time(&beginning); + ecl_get_internal_real_time(&beginning); - ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000)); + ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000)); - cl_core.Jan1st1970UT = - ecl_times(ecl_make_fixnum(24 * 60 * 60), - ecl_make_fixnum(17 + 365 * 70)); + cl_core.Jan1st1970UT = + ecl_times(ecl_make_fixnum(24 * 60 * 60), + ecl_make_fixnum(17 + 365 * 70)); } diff --git a/src/c/typespec.d b/src/c/typespec.d index c2ca49d58..efb3e4135 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -1,103 +1,98 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - typespec.c -- Type specifier routines. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * typespec.d - type specifier routines + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include void FEtype_error_fixnum(cl_object x) { - FEwrong_type_argument(@[fixnum], x); + FEwrong_type_argument(@[fixnum], x); } void FEtype_error_size(cl_object x) { - FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), - ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), - x); + FEwrong_type_argument(cl_list(3, @'integer', ecl_make_fixnum(0), + ecl_make_fixnum(MOST_POSITIVE_FIXNUM)), + x); } void FEtype_error_cons(cl_object x) { - FEwrong_type_argument(@[cons], x); + FEwrong_type_argument(@[cons], x); } void FEtype_error_list(cl_object x) { - FEwrong_type_argument(@[list], x); + FEwrong_type_argument(@[list], x); } void FEtype_error_proper_list(cl_object x) { - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Not a proper list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', ecl_read_from_cstring("si::proper-list"), - @':datum', x); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Not a proper list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', ecl_read_from_cstring("si::proper-list"), + @':datum', x); } void FEcircular_list(cl_object x) { - /* FIXME: Is this the right way to rebind it? */ - ecl_bds_bind(ecl_process_env(), @'*print-circle*', ECL_T); - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("Circular list ~D"), - @':format-arguments', cl_list(1, x), - @':expected-type', @'list', - @':datum', x); + /* FIXME: Is this the right way to rebind it? */ + ecl_bds_bind(ecl_process_env(), @'*print-circle*', ECL_T); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("Circular list ~D"), + @':format-arguments', cl_list(1, x), + @':expected-type', @'list', + @':datum', x); } void FEtype_error_index(cl_object seq, cl_fixnum ndx) { - cl_object n = ecl_make_fixnum(ndx); - cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq); - cl_error(9, @'simple-type-error', @':format-control', - make_constant_base_string("~S is not a valid index into the object ~S"), - @':format-arguments', cl_list(2, n, seq), - @':expected-type', cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(l-1)), - @':datum', n); + cl_object n = ecl_make_fixnum(ndx); + cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq); + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~S is not a valid index into the object ~S"), + @':format-arguments', cl_list(2, n, seq), + @':expected-type', cl_list(3, @'integer', ecl_make_fixnum(0), ecl_make_fixnum(l-1)), + @':datum', n); } void FEtype_error_array(cl_object v) { - FEwrong_type_argument(@[array], v); + FEwrong_type_argument(@[array], v); } void FEtype_error_vector(cl_object v) { - FEwrong_type_argument(@[vector], v); + FEwrong_type_argument(@[vector], v); } void FEtype_error_sequence(cl_object x) { - FEwrong_type_argument(@[sequence], x); + FEwrong_type_argument(@[sequence], x); } cl_object ecl_type_error(cl_object function, const char *place, cl_object o, cl_object type) { - si_wrong_type_argument(4, o, type, - (*place? make_constant_base_string(place) : ECL_NIL), - function); + si_wrong_type_argument(4, o, type, + (*place? make_constant_base_string(place) : ECL_NIL), + function); } /**********************************************************************/ @@ -105,253 +100,253 @@ ecl_type_error(cl_object function, const char *place, cl_object o, static cl_object ecl_type_to_symbol(cl_type t) { - switch(t) { - case t_character: - return @'character'; - case t_fixnum: - return @'fixnum'; - case t_bignum: - return @'bignum'; - case t_ratio: - return @'ratio'; - case t_singlefloat: - return @'single-float'; - case t_doublefloat: - return @'double-float'; + switch(t) { + case t_character: + return @'character'; + case t_fixnum: + return @'fixnum'; + case t_bignum: + return @'bignum'; + case t_ratio: + return @'ratio'; + case t_singlefloat: + return @'single-float'; + case t_doublefloat: + return @'double-float'; #ifdef ECL_LONG_FLOAT - case t_longfloat: - return @'long-float'; + case t_longfloat: + return @'long-float'; #endif - case t_complex: - return @'complex'; - case t_symbol: - return @'symbol'; - case t_package: - return @'package'; - case t_list: - return @'list'; - case t_hashtable: - return @'hash-table'; - case t_array: - return @'array'; - case t_vector: - return @'vector'; - case t_bitvector: - return @'bit-vector'; + case t_complex: + return @'complex'; + case t_symbol: + return @'symbol'; + case t_package: + return @'package'; + case t_list: + return @'list'; + case t_hashtable: + return @'hash-table'; + case t_array: + return @'array'; + case t_vector: + return @'vector'; + case t_bitvector: + return @'bit-vector'; #ifdef ECL_UNICODE - case t_string: - return @'string'; + case t_string: + return @'string'; #endif - case t_base_string: - return @'base-string'; - case t_stream: - return @'stream'; - case t_readtable: - return @'readtable'; - case t_pathname: - return @'pathname'; - case t_random: - return @'random-state'; - case t_bytecodes: - case t_bclosure: - case t_cfun: - case t_cfunfixed: - case t_cclosure: - return @'compiled-function'; + case t_base_string: + return @'base-string'; + case t_stream: + return @'stream'; + case t_readtable: + return @'readtable'; + case t_pathname: + return @'pathname'; + case t_random: + return @'random-state'; + case t_bytecodes: + case t_bclosure: + case t_cfun: + case t_cfunfixed: + case t_cclosure: + return @'compiled-function'; #ifdef ECL_THREADS - case t_process: - return @'mp::process'; - case t_lock: - return @'mp::lock'; - case t_condition_variable: - return @'mp::condition-variable'; - case t_semaphore: - return @'mp::semaphore'; - case t_barrier: - return @'mp::barrier'; - case t_mailbox: - return @'mp::mailbox'; + case t_process: + return @'mp::process'; + case t_lock: + return @'mp::lock'; + case t_condition_variable: + return @'mp::condition-variable'; + case t_semaphore: + return @'mp::semaphore'; + case t_barrier: + return @'mp::barrier'; + case t_mailbox: + return @'mp::mailbox'; #endif - case t_codeblock: - return @'si::code-block'; - case t_foreign: - return @'si::foreign-data'; - case t_frame: - return @'si::frame'; - case t_weak_pointer: - return @'ext::weak-pointer'; + case t_codeblock: + return @'si::code-block'; + case t_foreign: + return @'si::foreign-data'; + case t_frame: + return @'si::frame'; + case t_weak_pointer: + return @'ext::weak-pointer'; #ifdef ECL_SSE2 - case t_sse_pack: - return @'ext::sse-pack'; + case t_sse_pack: + return @'ext::sse-pack'; #endif - default: - ecl_internal_error("not a lisp data object"); - } + default: + ecl_internal_error("not a lisp data object"); + } } cl_object ecl_check_cl_type(cl_object fun, cl_object p, cl_type t) { - while (ecl_t_of(p) != t) { - p = ecl_type_error(fun, "argument", p, ecl_type_to_symbol(t)); - } - return p; + while (ecl_t_of(p) != t) { + p = ecl_type_error(fun, "argument", p, ecl_type_to_symbol(t)); + } + return p; } void assert_type_integer(cl_object p) { - cl_type t = ecl_t_of(p); - if (t != t_fixnum && t != t_bignum) - FEwrong_type_nth_arg(@[coerce], 1, p, @[integer]); + cl_type t = ecl_t_of(p); + if (t != t_fixnum && t != t_bignum) + FEwrong_type_nth_arg(@[coerce], 1, p, @[integer]); } void assert_type_non_negative_integer(cl_object p) { - cl_type t = ecl_t_of(p); + cl_type t = ecl_t_of(p); - if (t == t_fixnum) { - if (ecl_fixnum_plusp(p)) - return; - } else if (t == t_bignum) { - if (_ecl_big_sign(p) >= 0) - return; - } - FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0),@'*'), p); + if (t == t_fixnum) { + if (ecl_fixnum_plusp(p)) + return; + } else if (t == t_bignum) { + if (_ecl_big_sign(p) >= 0) + return; + } + FEwrong_type_argument(cl_list(3,@'integer',ecl_make_fixnum(0),@'*'), p); } void assert_type_proper_list(cl_object p) { - if (ECL_ATOM(p) && p != ECL_NIL) - FEtype_error_list(p); - if (cl_list_length(p) == ECL_NIL) - FEcircular_list(p); + if (ECL_ATOM(p) && p != ECL_NIL) + FEtype_error_list(p); + if (cl_list_length(p) == ECL_NIL) + FEcircular_list(p); } cl_object cl_type_of(cl_object x) { - cl_object t; - cl_type tx = ecl_t_of(x); - switch (tx) { - case t_instance: { - cl_object cl = ECL_CLASS_OF(x); - t = ECL_CLASS_NAME(cl); - if (t == ECL_NIL || cl != cl_find_class(2, t, ECL_NIL)) - t = cl; - break; - } - case t_fixnum: - case t_bignum: - t = cl_list(3, @'integer', x, x); - break; - case t_character: { - int i = ECL_CHAR_CODE(x); - if (ecl_standard_char_p(i)) { - t = @'standard-char'; - } else if (ecl_base_char_p(i)) { - t = @'base-char'; - } else { - t = @'character'; - } - break; - } + cl_object t; + cl_type tx = ecl_t_of(x); + switch (tx) { + case t_instance: { + cl_object cl = ECL_CLASS_OF(x); + t = ECL_CLASS_NAME(cl); + if (t == ECL_NIL || cl != cl_find_class(2, t, ECL_NIL)) + t = cl; + break; + } + case t_fixnum: + case t_bignum: + t = cl_list(3, @'integer', x, x); + break; + case t_character: { + int i = ECL_CHAR_CODE(x); + if (ecl_standard_char_p(i)) { + t = @'standard-char'; + } else if (ecl_base_char_p(i)) { + t = @'base-char'; + } else { + t = @'character'; + } + break; + } - case t_symbol: - if (x == ECL_T) - t = @'boolean'; - else if (x->symbol.hpack == cl_core.keyword_package) - t = @'keyword'; - else - t = @'symbol'; - break; - case t_array: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - !Null(CAR(x->array.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)), - cl_array_dimensions(x)); - break; - case t_vector: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - !Null(CAR(x->vector.displaced))) { - t = cl_list(3, @'vector', ecl_elttype_to_symbol(ecl_array_elttype(x)), - ecl_make_fixnum(x->vector.dim)); - } else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) || - (cl_elttype)x->vector.elttype != ecl_aet_object) { - t = cl_list(3, @'simple-array', - ecl_elttype_to_symbol(ecl_array_elttype(x)), - cl_array_dimensions(x)); - } else { - t = cl_list(2, @'simple-vector', ecl_make_fixnum(x->vector.dim)); - } - break; + case t_symbol: + if (x == ECL_T) + t = @'boolean'; + else if (x->symbol.hpack == cl_core.keyword_package) + t = @'keyword'; + else + t = @'symbol'; + break; + case t_array: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + !Null(CAR(x->array.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)), + cl_array_dimensions(x)); + break; + case t_vector: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + !Null(CAR(x->vector.displaced))) { + t = cl_list(3, @'vector', ecl_elttype_to_symbol(ecl_array_elttype(x)), + ecl_make_fixnum(x->vector.dim)); + } else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) || + (cl_elttype)x->vector.elttype != ecl_aet_object) { + t = cl_list(3, @'simple-array', + ecl_elttype_to_symbol(ecl_array_elttype(x)), + cl_array_dimensions(x)); + } else { + t = cl_list(2, @'simple-vector', ecl_make_fixnum(x->vector.dim)); + } + break; #ifdef ECL_UNICODE - case t_string: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->string.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'character', cl_list(1, ecl_make_fixnum(x->string.dim))); - break; + case t_string: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->string.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'character', cl_list(1, ecl_make_fixnum(x->string.dim))); + break; #endif - case t_base_string: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->base_string.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'base-char', cl_list(1, ecl_make_fixnum(x->base_string.dim))); - break; - case t_bitvector: - if (ECL_ADJUSTABLE_ARRAY_P(x) || - ECL_ARRAY_HAS_FILL_POINTER_P(x) || - !Null(CAR(x->vector.displaced))) - t = @'array'; - else - t = @'simple-array'; - t = cl_list(3, t, @'bit', cl_list(1, ecl_make_fixnum(x->vector.dim))); - break; - case t_stream: - switch (x->stream.mode) { - case ecl_smm_synonym: t = @'synonym-stream'; break; - case ecl_smm_broadcast: t = @'broadcast-stream'; break; - case ecl_smm_concatenated: t = @'concatenated-stream'; break; - case ecl_smm_two_way: t = @'two-way-stream'; break; - case ecl_smm_string_input: - case ecl_smm_string_output: t = @'string-stream'; break; - case ecl_smm_echo: t = @'echo-stream'; break; - case ecl_smm_sequence_input: - case ecl_smm_sequence_output: t = @'ext::sequence-stream'; break; - default: t = @'file-stream'; break; - } - break; - case t_pathname: - t = x->pathname.logical? @'logical-pathname' : @'pathname'; - break; - case t_list: - t = Null(x) ? @'null' : @'cons'; - break; + case t_base_string: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->base_string.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'base-char', cl_list(1, ecl_make_fixnum(x->base_string.dim))); + break; + case t_bitvector: + if (ECL_ADJUSTABLE_ARRAY_P(x) || + ECL_ARRAY_HAS_FILL_POINTER_P(x) || + !Null(CAR(x->vector.displaced))) + t = @'array'; + else + t = @'simple-array'; + t = cl_list(3, t, @'bit', cl_list(1, ecl_make_fixnum(x->vector.dim))); + break; + case t_stream: + switch (x->stream.mode) { + case ecl_smm_synonym: t = @'synonym-stream'; break; + case ecl_smm_broadcast: t = @'broadcast-stream'; break; + case ecl_smm_concatenated: t = @'concatenated-stream'; break; + case ecl_smm_two_way: t = @'two-way-stream'; break; + case ecl_smm_string_input: + case ecl_smm_string_output: t = @'string-stream'; break; + case ecl_smm_echo: t = @'echo-stream'; break; + case ecl_smm_sequence_input: + case ecl_smm_sequence_output: t = @'ext::sequence-stream'; break; + default: t = @'file-stream'; break; + } + break; + case t_pathname: + t = x->pathname.logical? @'logical-pathname' : @'pathname'; + break; + case t_list: + t = Null(x) ? @'null' : @'cons'; + break; #ifdef ECL_SSE2 - case t_sse_pack: - t = @'ext::sse-pack'; - break; + case t_sse_pack: + t = @'ext::sse-pack'; + break; #endif - default: - t = ecl_type_to_symbol(tx); - } - @(return t) + default: + t = ecl_type_to_symbol(tx); + } + @(return t); } cl_object ecl_make_integer_type(cl_object min, cl_object max) { - return cl_list(3, @'integer', min, max); + return cl_list(3, @'integer', min, max); } diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index 287eded04..f41e64baa 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - unixfsys.c -- Unix file system interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * unixfsys.d - Unix file system interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -59,49 +54,49 @@ ecl_def_ct_base_string(str_slash,"/",1,static,const); static cl_object coerce_to_posix_filename(cl_object filename) { - /* This converts a pathname designator into a namestring, with the - * particularity that directories do not end with a slash '/', because - * this is not supported on all POSIX platforms (most notably Windows) - */ - filename = si_coerce_to_filename(filename); - return cl_string_right_trim(str_slash, filename); + /* This converts a pathname designator into a namestring, with the + * particularity that directories do not end with a slash '/', because + * this is not supported on all POSIX platforms (most notably Windows) + */ + filename = si_coerce_to_filename(filename); + return cl_string_right_trim(str_slash, filename); } static int safe_chdir(const char *path, cl_object prefix) { - if (prefix != ECL_NIL) { - cl_object aux = make_constant_base_string(path); - aux = si_base_string_concatenate(2, prefix, aux); - return safe_chdir((char *)aux->base_string.self, ECL_NIL); - } else { - int output; - ecl_disable_interrupts(); - output = chdir((char *)path); - ecl_enable_interrupts(); - return output; - } + if (prefix != ECL_NIL) { + cl_object aux = make_constant_base_string(path); + aux = si_base_string_concatenate(2, prefix, aux); + return safe_chdir((char *)aux->base_string.self, ECL_NIL); + } else { + int output; + ecl_disable_interrupts(); + output = chdir((char *)path); + ecl_enable_interrupts(); + return output; + } } static int safe_stat(const char *path, struct stat *sb) { - int output; - ecl_disable_interrupts(); - output = stat(path, sb); - ecl_enable_interrupts(); - return output; + int output; + ecl_disable_interrupts(); + output = stat(path, sb); + ecl_enable_interrupts(); + return output; } #ifdef HAVE_LSTAT static int safe_lstat(const char *path, struct stat *sb) { - int output; - ecl_disable_interrupts(); - output = lstat(path, sb); - ecl_enable_interrupts(); - return output; + int output; + ecl_disable_interrupts(); + output = lstat(path, sb); + ecl_enable_interrupts(); + return output; } #endif @@ -109,23 +104,23 @@ safe_lstat(const char *path, struct stat *sb) static cl_object drive_host_prefix(cl_object pathname) { - cl_object device = pathname->pathname.device; - cl_object host = pathname->pathname.host; - cl_object output = ECL_NIL; - if (device != ECL_NIL) { - output = make_base_string_copy("X:"); - output->base_string.self[0] = device->base_string.self[0]; - } - if (host != ECL_NIL) { - cl_object slash = cl_core.slash; - if (output != ECL_NIL) - output = si_base_string_concatenate(5, output, slash, slash, - host, slash); - else - output = si_base_string_concatenate(4, slash, slash, host, - slash); - } - return output; + cl_object device = pathname->pathname.device; + cl_object host = pathname->pathname.host; + cl_object output = ECL_NIL; + if (device != ECL_NIL) { + output = make_base_string_copy("X:"); + output->base_string.self[0] = device->base_string.self[0]; + } + if (host != ECL_NIL) { + cl_object slash = cl_core.slash; + if (output != ECL_NIL) + output = si_base_string_concatenate(5, output, slash, slash, + host, slash); + else + output = si_base_string_concatenate(4, slash, slash, host, + slash); + } + return output; } #else #define drive_host_prefix(x) ECL_NIL @@ -137,8 +132,8 @@ drive_host_prefix(cl_object pathname) cl_object ecl_cstring_to_pathname(char *s) { - cl_object string = ecl_make_simple_base_string(s, -1); - return cl_parse_namestring(1, string); + cl_object string = ecl_make_simple_base_string(s, -1); + return cl_parse_namestring(1, string); } /* @@ -147,42 +142,42 @@ ecl_cstring_to_pathname(char *s) */ static cl_object current_dir(void) { - cl_object output; - const char *ok; + cl_object output; + const char *ok; #ifdef _MSC_VER - unsigned char *c; + unsigned char *c; #endif - cl_index size = 128; + cl_index size = 128; - do { - output = ecl_alloc_adjustable_base_string(size); - ecl_disable_interrupts(); - ok = getcwd((char*)output->base_string.self, size); - if (ok == NULL && errno != ERANGE) { - perror("ext::getcwd error"); - ecl_internal_error("Can't work without CWD"); - } - ecl_enable_interrupts(); - size += 256; - } while (ok == NULL); - size = strlen((char*)output->base_string.self); - if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) { - /* Too large to host the trailing '/' */ - cl_object other = ecl_alloc_adjustable_base_string(size+2); - strcpy((char*)other->base_string.self, (char*)output->base_string.self); - output = other; - } + do { + output = ecl_alloc_adjustable_base_string(size); + ecl_disable_interrupts(); + ok = getcwd((char*)output->base_string.self, size); + if (ok == NULL && errno != ERANGE) { + perror("ext::getcwd error"); + ecl_internal_error("Can't work without CWD"); + } + ecl_enable_interrupts(); + size += 256; + } while (ok == NULL); + size = strlen((char*)output->base_string.self); + if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) { + /* Too large to host the trailing '/' */ + cl_object other = ecl_alloc_adjustable_base_string(size+2); + strcpy((char*)other->base_string.self, (char*)output->base_string.self); + output = other; + } #ifdef _MSC_VER - for (c = output->base_string.self; *c; c++) - if (*c == '\\') - *c = '/'; + for (c = output->base_string.self; *c; c++) + if (*c == '\\') + *c = '/'; #endif - if (output->base_string.self[size-1] != '/') { - output->base_string.self[size++] = '/'; - output->base_string.self[size] = 0; - } - output->base_string.fillp = size; - return output; + if (output->base_string.self[size-1] != '/') { + output->base_string.self[size++] = '/'; + output->base_string.self[size] = 0; + } + output->base_string.fillp = size; + return output; } /* @@ -191,155 +186,155 @@ current_dir(void) { static cl_object file_kind(char *filename, bool follow_links) { - cl_object output; + cl_object output; #if defined(ECL_MS_WINDOWS_HOST) - DWORD dw; - ecl_disable_interrupts(); - dw = GetFileAttributes( filename ); - if (dw == -1) - output = ECL_NIL; - else if ( dw & FILE_ATTRIBUTE_DIRECTORY ) - output = @':directory'; - else - output = @':file'; - ecl_enable_interrupts(); + DWORD dw; + ecl_disable_interrupts(); + dw = GetFileAttributes( filename ); + if (dw == -1) + output = ECL_NIL; + else if ( dw & FILE_ATTRIBUTE_DIRECTORY ) + output = @':directory'; + else + output = @':file'; + ecl_enable_interrupts(); #else - struct stat buf; + struct stat buf; # ifdef HAVE_LSTAT - if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0) + if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0) # else - if (safe_stat(filename, &buf) < 0) + if (safe_stat(filename, &buf) < 0) # endif - output = ECL_NIL; + output = ECL_NIL; # ifdef HAVE_LSTAT - else if (S_ISLNK(buf.st_mode)) - output = @':link'; + else if (S_ISLNK(buf.st_mode)) + output = @':link'; # endif - else if (S_ISDIR(buf.st_mode)) - output = @':directory'; - else if (S_ISREG(buf.st_mode)) - output = @':file'; - else - output = @':special'; + else if (S_ISDIR(buf.st_mode)) + output = @':directory'; + else if (S_ISREG(buf.st_mode)) + output = @':file'; + else + output = @':special'; #endif - return output; + return output; } cl_object si_file_kind(cl_object filename, cl_object follow_links) { - filename = coerce_to_posix_filename(filename); - @(return file_kind((char*)filename->base_string.self, !Null(follow_links))) + filename = coerce_to_posix_filename(filename); + @(return file_kind((char*)filename->base_string.self, !Null(follow_links))); } #if defined(HAVE_LSTAT) && !defined(ECL_MS_WINDOWS_HOST) static cl_object si_readlink(cl_object filename) { - /* Given a filename which is a symlink, this routine returns - * the value of this link in the form of a pathname. */ - cl_index size = 128, written; - cl_object output, kind; - do { - output = ecl_alloc_adjustable_base_string(size); - ecl_disable_interrupts(); - written = readlink((char*)filename->base_string.self, - (char*)output->base_string.self, size); - ecl_enable_interrupts(); - size += 256; - } while (written == size); - output->base_string.self[written] = '\0'; - kind = file_kind((char*)output->base_string.self, FALSE); - if (kind == @':directory') { - output->base_string.self[written++] = '/'; - output->base_string.self[written] = '\0'; - } - output->base_string.fillp = written; - return output; + /* Given a filename which is a symlink, this routine returns + * the value of this link in the form of a pathname. */ + cl_index size = 128, written; + cl_object output, kind; + do { + output = ecl_alloc_adjustable_base_string(size); + ecl_disable_interrupts(); + written = readlink((char*)filename->base_string.self, + (char*)output->base_string.self, size); + ecl_enable_interrupts(); + size += 256; + } while (written == size); + output->base_string.self[written] = '\0'; + kind = file_kind((char*)output->base_string.self, FALSE); + if (kind == @':directory') { + output->base_string.self[written++] = '/'; + output->base_string.self[written] = '\0'; + } + output->base_string.fillp = written; + return output; } #endif /* HAVE_LSTAT */ static cl_object enter_directory(cl_object base_dir, cl_object subdir, bool ignore_if_failure) { - /* Assuming we start in "base_dir", enter a subdirectory named by - * "subdir", which may be a string, :UP, :ABSOLUTE or :RELATIVE. - * If the operation succeeds, return the truename of the resulting - * path -- resolving any links in the process. */ - cl_object aux, output, kind; - if (subdir == @':absolute') { - return cl_make_pathname(4, @':directory', ecl_list1(subdir), - @':defaults', base_dir); - } else if (subdir == @':relative') { - /* Nothing to do */ - return base_dir; - } else if (subdir == @':up') { - aux = make_constant_base_string(".."); - } else if (!ECL_BASE_STRING_P(subdir)) { - unlikely_if (!ecl_fits_in_base_string(subdir)) - FEerror("Directory component ~S found in pathname~& ~S" - "~&is not allowed in TRUENAME or DIRECTORY", - 1, subdir); - aux = si_coerce_to_base_string(subdir); - } else { - aux = subdir; - } - /* We now compose a new path based on the base directory and - * the new component. We have to verify that the new pathname is - * a directory and if it is a link recover the true name. */ - aux = ecl_append(base_dir->pathname.directory, ecl_list1(aux)); - output = cl_make_pathname(4, @':directory', aux, @':defaults', base_dir); - aux = ecl_namestring(output, ECL_NAMESTRING_FORCE_BASE_STRING); - /* We remove the trailing '/' from the namestring because the - * POSIX library does not like it. */ - aux->base_string.self[--aux->base_string.fillp] = 0; - kind = file_kind((char*)aux->base_string.self, FALSE); - if (kind == ECL_NIL) { - if (ignore_if_failure) return ECL_NIL; - FEcannot_open(output); + /* Assuming we start in "base_dir", enter a subdirectory named by + * "subdir", which may be a string, :UP, :ABSOLUTE or :RELATIVE. + * If the operation succeeds, return the truename of the resulting + * path -- resolving any links in the process. */ + cl_object aux, output, kind; + if (subdir == @':absolute') { + return cl_make_pathname(4, @':directory', ecl_list1(subdir), + @':defaults', base_dir); + } else if (subdir == @':relative') { + /* Nothing to do */ + return base_dir; + } else if (subdir == @':up') { + aux = make_constant_base_string(".."); + } else if (!ECL_BASE_STRING_P(subdir)) { + unlikely_if (!ecl_fits_in_base_string(subdir)) + FEerror("Directory component ~S found in pathname~& ~S" + "~&is not allowed in TRUENAME or DIRECTORY", + 1, subdir); + aux = si_coerce_to_base_string(subdir); + } else { + aux = subdir; + } + /* We now compose a new path based on the base directory and + * the new component. We have to verify that the new pathname is + * a directory and if it is a link recover the true name. */ + aux = ecl_append(base_dir->pathname.directory, ecl_list1(aux)); + output = cl_make_pathname(4, @':directory', aux, @':defaults', base_dir); + aux = ecl_namestring(output, ECL_NAMESTRING_FORCE_BASE_STRING); + /* We remove the trailing '/' from the namestring because the + * POSIX library does not like it. */ + aux->base_string.self[--aux->base_string.fillp] = 0; + kind = file_kind((char*)aux->base_string.self, FALSE); + if (kind == ECL_NIL) { + if (ignore_if_failure) return ECL_NIL; + FEcannot_open(output); #ifdef HAVE_LSTAT - } else if (kind == @':link') { - output = cl_truename(ecl_merge_pathnames(si_readlink(aux), - base_dir, @':default')); - if (output->pathname.name != ECL_NIL || - output->pathname.type != ECL_NIL) - goto WRONG_DIR; - return output; + } else if (kind == @':link') { + output = cl_truename(ecl_merge_pathnames(si_readlink(aux), + base_dir, @':default')); + if (output->pathname.name != ECL_NIL || + output->pathname.type != ECL_NIL) + goto WRONG_DIR; + return output; #endif - } else if (kind != @':directory') { - WRONG_DIR: - if (ignore_if_failure) return ECL_NIL; - FEerror("The directory~& ~S~&in pathname~& ~S~&" - "actually points to a file or special device.", - 2, subdir, base_dir); - } - if (subdir == @':up') { - cl_object newdir= output->pathname.directory; - newdir = ecl_nbutlast(newdir, 2); - if (Null(newdir)) { - if (ignore_if_failure) return ECL_NIL; - FEerror("Pathname contained an :UP component " - "that goes above the base directory:" - "~& ~S", 1, output); - } - output->pathname.directory = newdir; - } - return output; + } else if (kind != @':directory') { + WRONG_DIR: + if (ignore_if_failure) return ECL_NIL; + FEerror("The directory~& ~S~&in pathname~& ~S~&" + "actually points to a file or special device.", + 2, subdir, base_dir); + } + if (subdir == @':up') { + cl_object newdir= output->pathname.directory; + newdir = ecl_nbutlast(newdir, 2); + if (Null(newdir)) { + if (ignore_if_failure) return ECL_NIL; + FEerror("Pathname contained an :UP component " + "that goes above the base directory:" + "~& ~S", 1, output); + } + output->pathname.directory = newdir; + } + return output; } static cl_object make_absolute_pathname(cl_object orig_pathname) { - cl_object base_dir = si_getcwd(0); - cl_object pathname = coerce_to_file_pathname(orig_pathname); - return ecl_merge_pathnames(pathname, base_dir, @':default'); + cl_object base_dir = si_getcwd(0); + cl_object pathname = coerce_to_file_pathname(orig_pathname); + return ecl_merge_pathnames(pathname, base_dir, @':default'); } static cl_object make_base_pathname(cl_object pathname) { - return ecl_make_pathname(pathname->pathname.host, - pathname->pathname.device, - ecl_list1(@':absolute'), - ECL_NIL, ECL_NIL, ECL_NIL, @':local'); + return ecl_make_pathname(pathname->pathname.host, + pathname->pathname.device, + ecl_list1(@':absolute'), + ECL_NIL, ECL_NIL, ECL_NIL, @':local'); } #define FOLLOW_SYMLINKS 1 @@ -347,65 +342,66 @@ make_base_pathname(cl_object pathname) static cl_object file_truename(cl_object pathname, cl_object filename, int flags) { - cl_object kind; - if (Null(pathname)) { - if (Null(filename)) { - ecl_internal_error("file_truename:" - " both FILENAME and PATHNAME are null!"); - } - pathname = cl_pathname(filename); - } else if (Null(filename)) { - filename = ecl_namestring(pathname, ECL_NAMESTRING_FORCE_BASE_STRING); - if (Null(filename)) { - FEerror("Unprintable pathname ~S found in TRUENAME", 1, pathname); - } - } - kind = file_kind((char*)filename->base_string.self, FALSE); - if (kind == ECL_NIL) { - FEcannot_open(filename); + cl_object kind; + if (Null(pathname)) { + if (Null(filename)) { + ecl_internal_error("file_truename:" + " both FILENAME and PATHNAME are null!"); + } + pathname = cl_pathname(filename); + } else if (Null(filename)) { + filename = ecl_namestring(pathname, ECL_NAMESTRING_FORCE_BASE_STRING); + if (Null(filename)) { + FEerror("Unprintable pathname ~S found in TRUENAME", 1, pathname); + } + } + kind = file_kind((char*)filename->base_string.self, FALSE); + if (kind == ECL_NIL) { + FEcannot_open(filename); #ifdef HAVE_LSTAT - } else if (kind == @':link' && (flags & FOLLOW_SYMLINKS)) { - /* The link might be a relative pathname. In that case - * we have to merge with the original pathname. On - * the other hand, if the link is broken – return file - * truename "as is". */ - struct stat filestatus; - if (safe_stat(filename->base_string.self, &filestatus) < 0) - @(return pathname kind); - filename = si_readlink(filename); - pathname = ecl_make_pathname(pathname->pathname.host, - pathname->pathname.device, - pathname->pathname.directory, - ECL_NIL, ECL_NIL, ECL_NIL, @':local'); - pathname = ecl_merge_pathnames(filename, pathname, @':default'); - return cl_truename(pathname); + } else if (kind == @':link' && (flags & FOLLOW_SYMLINKS)) { + /* The link might be a relative pathname. In that case + * we have to merge with the original pathname. On + * the other hand, if the link is broken – return file + * truename "as is". */ + struct stat filestatus; + if (safe_stat(filename->base_string.self, &filestatus) < 0) { + @(return pathname kind); + } + filename = si_readlink(filename); + pathname = ecl_make_pathname(pathname->pathname.host, + pathname->pathname.device, + pathname->pathname.directory, + ECL_NIL, ECL_NIL, ECL_NIL, @':local'); + pathname = ecl_merge_pathnames(filename, pathname, @':default'); + return cl_truename(pathname); #endif - } else if (kind == @':directory'){ - /* If the pathname is a directory but we have supplied - a file name, correct the type by appending a directory - separator and re-parsing again the namestring */ - if (pathname->pathname.name != ECL_NIL || - pathname->pathname.type != ECL_NIL) { - pathname = si_base_string_concatenate - (2, filename, - make_constant_base_string("/")); - pathname = cl_truename(pathname); - } - } - /* ECL does not contemplate version numbers - in directory pathnames */ - if (pathname->pathname.name == ECL_NIL && - pathname->pathname.type == ECL_NIL) { - /* We have to destructively change the - * pathname version here. Otherwise - * merge_pathnames will not do it. It is - * safe because coerce_to_file_pathname - * created a copy. */ - pathname->pathname.version = ECL_NIL; - } else { - pathname->pathname.version = @':newest'; - } - @(return pathname kind) + } else if (kind == @':directory'){ + /* If the pathname is a directory but we have supplied + a file name, correct the type by appending a directory + separator and re-parsing again the namestring */ + if (pathname->pathname.name != ECL_NIL || + pathname->pathname.type != ECL_NIL) { + pathname = si_base_string_concatenate + (2, filename, + make_constant_base_string("/")); + pathname = cl_truename(pathname); + } + } + /* ECL does not contemplate version numbers + in directory pathnames */ + if (pathname->pathname.name == ECL_NIL && + pathname->pathname.type == ECL_NIL) { + /* We have to destructively change the + * pathname version here. Otherwise + * merge_pathnames will not do it. It is + * safe because coerce_to_file_pathname + * created a copy. */ + pathname->pathname.version = ECL_NIL; + } else { + pathname->pathname.version = @':newest'; + } + @(return pathname kind); } /* @@ -416,333 +412,333 @@ file_truename(cl_object pathname, cl_object filename, int flags) cl_object cl_truename(cl_object orig_pathname) { - cl_object pathname = make_absolute_pathname(orig_pathname); - cl_object base_dir = make_base_pathname(pathname); - cl_object dir; - /* We process the directory part of the filename, removing all - * possible symlinks. To do so, we inspect recursively the - * directory which contains our file, and come back. We also have to - * ensure that the filename itself does not point to a symlink: if so, - * then we resolve the value of the symlink and continue traversing - * the filesystem. - */ - for (dir = pathname->pathname.directory; !Null(dir); dir = ECL_CONS_CDR(dir)) - { - base_dir = enter_directory(base_dir, ECL_CONS_CAR(dir), 0); - } - pathname = ecl_merge_pathnames(base_dir, pathname, @':default'); - @(return file_truename(pathname, ECL_NIL, FOLLOW_SYMLINKS)) + cl_object pathname = make_absolute_pathname(orig_pathname); + cl_object base_dir = make_base_pathname(pathname); + cl_object dir; + /* We process the directory part of the filename, removing all + * possible symlinks. To do so, we inspect recursively the + * directory which contains our file, and come back. We also have to + * ensure that the filename itself does not point to a symlink: if so, + * then we resolve the value of the symlink and continue traversing + * the filesystem. + */ + for (dir = pathname->pathname.directory; !Null(dir); dir = ECL_CONS_CDR(dir)) + { + base_dir = enter_directory(base_dir, ECL_CONS_CAR(dir), 0); + } + pathname = ecl_merge_pathnames(base_dir, pathname, @':default'); + @(return file_truename(pathname, ECL_NIL, FOLLOW_SYMLINKS)); } int ecl_backup_open(const char *filename, int option, int mode) { - char *backupfilename = ecl_alloc(strlen(filename) + 5); - if (backupfilename == NULL) { - FElibc_error("Cannot allocate memory for backup filename", 0); - } + char *backupfilename = ecl_alloc(strlen(filename) + 5); + if (backupfilename == NULL) { + FElibc_error("Cannot allocate memory for backup filename", 0); + } - strcat(strcpy(backupfilename, filename), ".BAK"); - ecl_disable_interrupts(); + strcat(strcpy(backupfilename, filename), ".BAK"); + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - /* Windows' rename doesn't replace an existing file */ - if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) { - ecl_enable_interrupts(); - FElibc_error("Cannot remove the file ~S", 1, - ecl_make_constant_base_string(backupfilename,-1)); - } + /* Windows' rename doesn't replace an existing file */ + if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) { + ecl_enable_interrupts(); + FElibc_error("Cannot remove the file ~S", 1, + ecl_make_constant_base_string(backupfilename,-1)); + } #endif - if (rename(filename, backupfilename)) { - ecl_enable_interrupts(); - FElibc_error("Cannot rename the file ~S to ~S.", 2, - ecl_make_constant_base_string(filename,-1), - ecl_make_constant_base_string(backupfilename,-1)); - } - ecl_enable_interrupts(); - ecl_dealloc(backupfilename); - return open(filename, option, mode); + if (rename(filename, backupfilename)) { + ecl_enable_interrupts(); + FElibc_error("Cannot rename the file ~S to ~S.", 2, + ecl_make_constant_base_string(filename,-1), + ecl_make_constant_base_string(backupfilename,-1)); + } + ecl_enable_interrupts(); + ecl_dealloc(backupfilename); + return open(filename, option, mode); } cl_object ecl_file_len(int f) { - struct stat filestatus; - memset(&filestatus, 0, sizeof(filestatus)); - ecl_disable_interrupts(); - fstat(f, &filestatus); - ecl_enable_interrupts(); - return ecl_make_integer(filestatus.st_size); + struct stat filestatus; + memset(&filestatus, 0, sizeof(filestatus)); + ecl_disable_interrupts(); + fstat(f, &filestatus); + ecl_enable_interrupts(); + return ecl_make_integer(filestatus.st_size); } @(defun rename-file (oldn newn &key (if_exists @':error')) - cl_object old_filename, new_filename, old_truename, new_truename; - int error; -@ + cl_object old_filename, new_filename, old_truename, new_truename; + int error; + @ - /* 1) Get the old filename, and complain if it has wild components, - * or if it does not exist. Notice that the filename to be renamed - * is not the truename, because we might be renaming a symbolic link. - */ - old_truename = cl_truename(oldn); - old_filename = coerce_to_posix_filename(old_truename); + /* 1) Get the old filename, and complain if it has wild components, + * or if it does not exist. Notice that the filename to be renamed + * is not the truename, because we might be renaming a symbolic link. + */ + old_truename = cl_truename(oldn); + old_filename = coerce_to_posix_filename(old_truename); - /* 2) Create the new file name. */ - newn = ecl_merge_pathnames(newn, oldn, @':newest'); - new_filename = si_coerce_to_filename(newn); + /* 2) Create the new file name. */ + newn = ecl_merge_pathnames(newn, oldn, @':newest'); + new_filename = si_coerce_to_filename(newn); - while (if_exists == @':error' || if_exists == ECL_NIL) - { - if (cl_probe_file(new_filename) == ECL_NIL) { - if_exists = ECL_T; - break; - } - /* if the file already exists */ - if (if_exists == @':error') { - const char *msg = "When trying to rename ~S, ~S already exists"; - if_exists = - si_signal_simple_error - (6, @'file-error', /* condition */ - @':supersede', /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, oldn, new_filename), /* format args */ - @':pathname', /* file-error options */ - new_filename); - if (if_exists == ECL_T) if_exists= @':error'; - } - if (if_exists == ECL_NIL) { - @(return ECL_NIL ECL_NIL ECL_NIL) - } - } - if (ecl_unlikely(if_exists != @':supersede' && if_exists != ECL_T)) { - /* invalid key */ - FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", - 1, if_exists); - } - { - ecl_disable_interrupts(); + while (if_exists == @':error' || if_exists == ECL_NIL) + { + if (cl_probe_file(new_filename) == ECL_NIL) { + if_exists = ECL_T; + break; + } + /* if the file already exists */ + if (if_exists == @':error') { + const char *msg = "When trying to rename ~S, ~S already exists"; + if_exists = + si_signal_simple_error + (6, @'file-error', /* condition */ + @':supersede', /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, oldn, new_filename), /* format args */ + @':pathname', /* file-error options */ + new_filename); + if (if_exists == ECL_T) if_exists= @':error'; + } + if (if_exists == ECL_NIL) { + @(return ECL_NIL ECL_NIL ECL_NIL); + } + } + if (ecl_unlikely(if_exists != @':supersede' && if_exists != ECL_T)) { + /* invalid key */ + FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", + 1, if_exists); + } + { + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - error = SetErrorMode(0); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - switch (GetLastError()) { - case ERROR_ALREADY_EXISTS: - case ERROR_FILE_EXISTS: - break; - default: - goto FAILURE_CLOBBER; - }; - if (MoveFileEx((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self, - MOVEFILE_REPLACE_EXISTING)) { - SetErrorMode(error); - goto SUCCESS; - } - /* hack for win95/novell */ - chmod((char*)old_filename->base_string.self, 0777); - chmod((char*)new_filename->base_string.self, 0777); - SetFileAttributesA((char*)new_filename->base_string.self, - FILE_ATTRIBUTE_NORMAL); - SetFileAttributesA((char*)new_filename->base_string.self, - FILE_ATTRIBUTE_TEMPORARY); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - /* fallback on old behavior */ - (void)DeleteFileA((char*)new_filename->base_string.self); - if (MoveFile((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self)) { - SetErrorMode(error); - goto SUCCESS; - } - /* fall through */ + error = SetErrorMode(0); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + switch (GetLastError()) { + case ERROR_ALREADY_EXISTS: + case ERROR_FILE_EXISTS: + break; + default: + goto FAILURE_CLOBBER; + }; + if (MoveFileEx((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self, + MOVEFILE_REPLACE_EXISTING)) { + SetErrorMode(error); + goto SUCCESS; + } + /* hack for win95/novell */ + chmod((char*)old_filename->base_string.self, 0777); + chmod((char*)new_filename->base_string.self, 0777); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_NORMAL); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_TEMPORARY); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + /* fallback on old behavior */ + (void)DeleteFileA((char*)new_filename->base_string.self); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { + SetErrorMode(error); + goto SUCCESS; + } + /* fall through */ #else - if (rename((char*)old_filename->base_string.self, - (char*)new_filename->base_string.self) == 0) { - goto SUCCESS; - } + if (rename((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self) == 0) { + goto SUCCESS; + } #endif - } -FAILURE_CLOBBER: - ecl_enable_interrupts(); - { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Unable to rename file ~S to ~S.~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_NIL, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(3, oldn, newn, c_error), /* format args */ - @':pathname', /* file-error options */ - oldn); - } + } + FAILURE_CLOBBER: + ecl_enable_interrupts(); + { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Unable to rename file ~S to ~S.~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_NIL, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(3, oldn, newn, c_error), /* format args */ + @':pathname', /* file-error options */ + oldn); + } -SUCCESS: - ecl_enable_interrupts(); - new_truename = cl_truename(newn); - @(return newn old_truename new_truename) -@) + SUCCESS: + ecl_enable_interrupts(); + new_truename = cl_truename(newn); + @(return newn old_truename new_truename); + @) static int directory_pathname_p(cl_object path) { - return (path->pathname.name == ECL_NIL) && - (path->pathname.type == ECL_NIL); + return (path->pathname.name == ECL_NIL) && + (path->pathname.type == ECL_NIL); } cl_object cl_delete_file(cl_object file) { - cl_object path = cl_pathname(file); - int isdir = directory_pathname_p(path); - cl_object filename = coerce_to_posix_filename(path); - int ok, code; + cl_object path = cl_pathname(file); + int isdir = directory_pathname_p(path); + cl_object filename = coerce_to_posix_filename(path); + int ok, code; - ecl_disable_interrupts(); - ok = (isdir? rmdir : unlink)((char*)filename->base_string.self); - ecl_enable_interrupts(); + ecl_disable_interrupts(); + ok = (isdir? rmdir : unlink)((char*)filename->base_string.self); + ecl_enable_interrupts(); - if (ok < 0) { - const char *msg = - isdir? - "Cannot delete the directory ~S.~%C library error: ~S" : - "Cannot delete the file ~S.~%C library error: ~S"; - cl_object c_error = _ecl_strerror(errno); - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(2, file, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } - @(return ECL_T) + if (ok < 0) { + const char *msg = + isdir? + "Cannot delete the directory ~S.~%C library error: ~S" : + "Cannot delete the file ~S.~%C library error: ~S"; + cl_object c_error = _ecl_strerror(errno); + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(2, file, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } + @(return ECL_T); } cl_object cl_probe_file(cl_object file) { - /* INV: Both SI:FILE-KIND and TRUENAME complain if "file" has wildcards */ - @(return (si_file_kind(file, ECL_T) != ECL_NIL? cl_truename(file) : ECL_NIL)) + /* INV: Both SI:FILE-KIND and TRUENAME complain if "file" has wildcards */ + @(return (si_file_kind(file, ECL_T) != ECL_NIL? cl_truename(file) : ECL_NIL)); } cl_object cl_file_write_date(cl_object file) { - cl_object time, filename = coerce_to_posix_filename(file); - struct stat filestatus; - if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { - time = ECL_NIL; - } else { - time = UTC_time_to_universal_time(filestatus.st_mtime); - } - @(return time) + cl_object time, filename = coerce_to_posix_filename(file); + struct stat filestatus; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { + time = ECL_NIL; + } else { + time = UTC_time_to_universal_time(filestatus.st_mtime); + } + @(return time); } cl_object cl_file_author(cl_object file) { - cl_object output, filename = coerce_to_posix_filename(file); - struct stat filestatus; - if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { - const char *msg = "Unable to read file author for ~S." - "~%C library error: ~S"; - cl_object c_error = _ecl_strerror(errno); - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - ecl_make_constant_base_string(msg,strlen(msg)), /* format */ - cl_list(2, file, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } + cl_object output, filename = coerce_to_posix_filename(file); + struct stat filestatus; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) { + const char *msg = "Unable to read file author for ~S." + "~%C library error: ~S"; + cl_object c_error = _ecl_strerror(errno); + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + ecl_make_constant_base_string(msg,strlen(msg)), /* format */ + cl_list(2, file, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } #ifdef HAVE_PWD_H - { - struct passwd *pwent; - ecl_disable_interrupts(); - pwent = getpwuid(filestatus.st_uid); - ecl_enable_interrupts(); - output = make_base_string_copy(pwent->pw_name); - } + { + struct passwd *pwent; + ecl_disable_interrupts(); + pwent = getpwuid(filestatus.st_uid); + ecl_enable_interrupts(); + output = make_base_string_copy(pwent->pw_name); + } #else - output = make_constant_base_string("UNKNOWN"); + output = make_constant_base_string("UNKNOWN"); #endif - @(return output) + @(return output); } cl_object ecl_homedir_pathname(cl_object user) { - cl_index i; - cl_object namestring; - const char *h, *d; - if (!Null(user)) { + cl_index i; + cl_object namestring; + const char *h, *d; + if (!Null(user)) { #ifdef HAVE_PWD_H - struct passwd *pwent = NULL; + struct passwd *pwent = NULL; #endif - char *p; - /* This ensures that our string has the right length - and it is terminated with a '\0' */ - user = si_copy_to_simple_base_string(user); - p = (char*)user->base_string.self; - i = user->base_string.fillp; - if (i > 0 && *p == '~') { - p++; - i--; - } - if (i == 0) - return ecl_homedir_pathname(ECL_NIL); + char *p; + /* This ensures that our string has the right length + and it is terminated with a '\0' */ + user = si_copy_to_simple_base_string(user); + p = (char*)user->base_string.self; + i = user->base_string.fillp; + if (i > 0 && *p == '~') { + p++; + i--; + } + if (i == 0) + return ecl_homedir_pathname(ECL_NIL); #ifdef HAVE_PWD_H - pwent = getpwnam(p); - if (pwent == NULL) - FEerror("Unknown user ~S.", 1, p); - namestring = make_base_string_copy(pwent->pw_dir); + pwent = getpwnam(p); + if (pwent == NULL) + FEerror("Unknown user ~S.", 1, p); + namestring = make_base_string_copy(pwent->pw_dir); #endif - FEerror("Unknown user ~S.", 1, p); - } else if ((h = getenv("HOME"))) { - namestring = make_base_string_copy(h); + FEerror("Unknown user ~S.", 1, p); + } else if ((h = getenv("HOME"))) { + namestring = make_base_string_copy(h); #if defined(ECL_MS_WINDOWS_HOST) - } else if ((h = getenv("HOMEPATH")) && (d = getenv("HOMEDRIVE"))) { - namestring = - si_base_string_concatenate(2, - make_constant_base_string(d), - make_constant_base_string(h)); + } else if ((h = getenv("HOMEPATH")) && (d = getenv("HOMEDRIVE"))) { + namestring = + si_base_string_concatenate(2, + make_constant_base_string(d), + make_constant_base_string(h)); #endif - } else { - namestring = make_constant_base_string("/"); - } - if (namestring->base_string.self[0] == '~') { - FEerror("Not a valid home pathname ~S", 1, namestring); - } - i = namestring->base_string.fillp; - if (!IS_DIR_SEPARATOR(namestring->base_string.self[i-1])) - namestring = si_base_string_concatenate(2, namestring, - ECL_CODE_CHAR(DIR_SEPARATOR)); - return cl_parse_namestring(3, namestring, ECL_NIL, ECL_NIL); + } else { + namestring = make_constant_base_string("/"); + } + if (namestring->base_string.self[0] == '~') { + FEerror("Not a valid home pathname ~S", 1, namestring); + } + i = namestring->base_string.fillp; + if (!IS_DIR_SEPARATOR(namestring->base_string.self[i-1])) + namestring = si_base_string_concatenate(2, namestring, + ECL_CODE_CHAR(DIR_SEPARATOR)); + return cl_parse_namestring(3, namestring, ECL_NIL, ECL_NIL); } @(defun user_homedir_pathname (&optional host) -@ - /* Ignore optional host argument. */ - @(return ecl_homedir_pathname(ECL_NIL)); -@) + @ + /* Ignore optional host argument. */ + @(return ecl_homedir_pathname(ECL_NIL)); + @) static bool string_match(const char *s, cl_object pattern) { - if (pattern == ECL_NIL || pattern == @':wild') { - return 1; - } else { - cl_index ls = strlen(s); - ecl_def_ct_base_string(strng, s, ls, /*auto*/, const); - return ecl_string_match(strng, 0, ls, - pattern, 0, ecl_length(pattern)); - } + if (pattern == ECL_NIL || pattern == @':wild') { + return 1; + } else { + cl_index ls = strlen(s); + ecl_def_ct_base_string(strng, s, ls, /*auto*/, const); + return ecl_string_match(strng, 0, ls, + pattern, 0, ecl_length(pattern)); + } } /* @@ -755,96 +751,96 @@ static cl_object list_directory(cl_object base_dir, cl_object text_mask, cl_object pathname_mask, int flags) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object out = ECL_NIL; - cl_object prefix = ecl_namestring(base_dir, ECL_NAMESTRING_FORCE_BASE_STRING); - cl_object component, component_path, kind; - char *text; + const cl_env_ptr the_env = ecl_process_env(); + cl_object out = ECL_NIL; + cl_object prefix = ecl_namestring(base_dir, ECL_NAMESTRING_FORCE_BASE_STRING); + cl_object component, component_path, kind; + char *text; #if defined(HAVE_DIRENT_H) - DIR *dir; - struct dirent *entry; + DIR *dir; + struct dirent *entry; - ecl_disable_interrupts(); - dir = opendir((char*)prefix->base_string.self); - if (dir == NULL) { - out = ECL_NIL; - goto OUTPUT; - } + ecl_disable_interrupts(); + dir = opendir((char*)prefix->base_string.self); + if (dir == NULL) { + out = ECL_NIL; + goto OUTPUT; + } - while ((entry = readdir(dir))) { - text = entry->d_name; + while ((entry = readdir(dir))) { + text = entry->d_name; #else # ifdef ECL_MS_WINDOWS_HOST - WIN32_FIND_DATA fd; - HANDLE hFind = NULL; - BOOL found = FALSE; + WIN32_FIND_DATA fd; + HANDLE hFind = NULL; + BOOL found = FALSE; - ecl_disable_interrupts(); - for (;;) { - if (hFind == NULL) { - cl_object aux = make_constant_base_string(".\\*"); - cl_object mask = si_base_string_concatenate(2, prefix, aux); - hFind = FindFirstFile((char*)mask->base_string.self, &fd); - if (hFind == INVALID_HANDLE_VALUE) { - out = ECL_NIL; - goto OUTPUT; - } - found = TRUE; - } else { - found = FindNextFile(hFind, &fd); - } - if (!found) - break; - text = fd.cFileName; + ecl_disable_interrupts(); + for (;;) { + if (hFind == NULL) { + cl_object aux = make_constant_base_string(".\\*"); + cl_object mask = si_base_string_concatenate(2, prefix, aux); + hFind = FindFirstFile((char*)mask->base_string.self, &fd); + if (hFind == INVALID_HANDLE_VALUE) { + out = ECL_NIL; + goto OUTPUT; + } + found = TRUE; + } else { + found = FindNextFile(hFind, &fd); + } + if (!found) + break; + text = fd.cFileName; # else /* sys/dir.h as in SYSV */ - FILE *fp; - char iobuffer[BUFSIZ]; - DIRECTORY dir; + FILE *fp; + char iobuffer[BUFSIZ]; + DIRECTORY dir; - ecl_disable_interrupts(); - fp = fopen((char*)prefix->base_string.self, OPEN_R); - if (fp == NULL) { - out = ECL_NIL; - goto OUTPUT; - } - setbuf(fp, iobuffer); - for (;;) { - if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0) - break; - if (dir.d_ino == 0) - continue; - text = dir.d_name; + ecl_disable_interrupts(); + fp = fopen((char*)prefix->base_string.self, OPEN_R); + if (fp == NULL) { + out = ECL_NIL; + goto OUTPUT; + } + setbuf(fp, iobuffer); + for (;;) { + if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0) + break; + if (dir.d_ino == 0) + continue; + text = dir.d_name; # endif /* !ECL_MS_WINDOWS_HOST */ #endif /* !HAVE_DIRENT_H */ - if (text[0] == '.' && - (text[1] == '\0' || - (text[1] == '.' && text[2] == '\0'))) - continue; - if (!string_match(text, text_mask)) - continue; - component = make_constant_base_string(text); - component = si_base_string_concatenate(2, prefix, component); - component_path = cl_pathname(component); - if (!Null(pathname_mask)) { - if (Null(cl_pathname_match_p(component, pathname_mask))) - continue; - } - component_path = file_truename(component_path, component, flags); - kind = ecl_nth_value(the_env, 1); - out = CONS(CONS(component_path, kind), out); + if (text[0] == '.' && + (text[1] == '\0' || + (text[1] == '.' && text[2] == '\0'))) + continue; + if (!string_match(text, text_mask)) + continue; + component = make_constant_base_string(text); + component = si_base_string_concatenate(2, prefix, component); + component_path = cl_pathname(component); + if (!Null(pathname_mask)) { + if (Null(cl_pathname_match_p(component, pathname_mask))) + continue; } + component_path = file_truename(component_path, component, flags); + kind = ecl_nth_value(the_env, 1); + out = CONS(CONS(component_path, kind), out); + } #ifdef HAVE_DIRENT_H - closedir(dir); + closedir(dir); #else # ifdef ECL_MS_WINDOWS_HOST - FindClose(hFind); + FindClose(hFind); # else - fclose(fp); + fclose(fp); # endif /* !ECL_MS_WINDOWS_HOST */ #endif /* !HAVE_DIRENT_H */ - ecl_enable_interrupts(); -OUTPUT: - return cl_nreverse(out); + ecl_enable_interrupts(); + OUTPUT: + return cl_nreverse(out); } /* @@ -857,28 +853,28 @@ OUTPUT: static cl_object dir_files(cl_object base_dir, cl_object pathname, int flags) { - cl_object all_files, output = ECL_NIL; - cl_object mask; - cl_object name = pathname->pathname.name; - cl_object type = pathname->pathname.type; - if (name == ECL_NIL && type == ECL_NIL) { - return cl_list(1, base_dir); - } - mask = ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, - name, type, pathname->pathname.version, - @':local'); - for (all_files = list_directory(base_dir, ECL_NIL, mask, flags); - !Null(all_files); - all_files = ECL_CONS_CDR(all_files)) - { - cl_object record = ECL_CONS_CAR(all_files); - cl_object new = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') { - output = CONS(new, output); - } - } - return output; + cl_object all_files, output = ECL_NIL; + cl_object mask; + cl_object name = pathname->pathname.name; + cl_object type = pathname->pathname.type; + if (name == ECL_NIL && type == ECL_NIL) { + return cl_list(1, base_dir); + } + mask = ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL, + name, type, pathname->pathname.version, + @':local'); + for (all_files = list_directory(base_dir, ECL_NIL, mask, flags); + !Null(all_files); + all_files = ECL_CONS_CDR(all_files)) + { + cl_object record = ECL_CONS_CAR(all_files); + cl_object new = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') { + output = CONS(new, output); + } + } + return output; } /* @@ -890,356 +886,356 @@ dir_files(cl_object base_dir, cl_object pathname, int flags) static cl_object dir_recursive(cl_object base_dir, cl_object directory, cl_object filemask, int flags) { - cl_object item, output = ECL_NIL; + cl_object item, output = ECL_NIL; AGAIN: - /* There are several possibilities here: - * - * 1) The list of subdirectories DIRECTORY is empty, and only PATHNAME - * remains to be inspected. If there is no file name or type, then - * we simply output the truename of the current directory. Otherwise - * we have to find a file which corresponds to the description. - */ - if (directory == ECL_NIL) { - return ecl_nconc(dir_files(base_dir, filemask, flags), output); - } - /* - * 2) We have not yet exhausted the DIRECTORY component of the - * pathname. We have to enter some subdirectory, determined by - * CAR(DIRECTORY) and scan it. - */ - item = ECL_CONS_CAR(directory); + /* There are several possibilities here: + * + * 1) The list of subdirectories DIRECTORY is empty, and only PATHNAME + * remains to be inspected. If there is no file name or type, then + * we simply output the truename of the current directory. Otherwise + * we have to find a file which corresponds to the description. + */ + if (directory == ECL_NIL) { + return ecl_nconc(dir_files(base_dir, filemask, flags), output); + } + /* + * 2) We have not yet exhausted the DIRECTORY component of the + * pathname. We have to enter some subdirectory, determined by + * CAR(DIRECTORY) and scan it. + */ + item = ECL_CONS_CAR(directory); - if (item == @':wild' || ecl_wild_string_p(item)) { - /* - * 2.1) If CAR(DIRECTORY) is a string or :WILD, we have to - * enter & scan all subdirectories in our curent directory. - */ - cl_object next_dir = list_directory(base_dir, item, ECL_NIL, flags); - for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { - cl_object record = ECL_CONS_CAR(next_dir); - cl_object component = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') - continue; - item = dir_recursive(cl_pathname(component), - ECL_CONS_CDR(directory), - filemask, flags); - output = ecl_nconc(item, output); - } - } else if (item == @':wild-inferiors') { - /* - * 2.2) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do - * scan all subdirectories from _all_ levels, looking for a - * tree that matches the remaining part of DIRECTORY. - */ - cl_object next_dir = list_directory(base_dir, ECL_NIL, ECL_NIL, flags); - for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { - cl_object record = ECL_CONS_CAR(next_dir); - cl_object component = ECL_CONS_CAR(record); - cl_object kind = ECL_CONS_CDR(record); - if (kind != @':directory') - continue; - item = dir_recursive(cl_pathname(component), - directory, filemask, flags); - output = ecl_nconc(item, output); - } - directory = ECL_CONS_CDR(directory); - goto AGAIN; - } else { /* :ABSOLUTE, :RELATIVE, :UP, component without wildcards */ - /* - * 2.2) If CAR(DIRECTORY) is :ABSOLUTE, :RELATIVE or :UP we update - * the directory to reflect the root, the current or the parent one. - */ - base_dir = enter_directory(base_dir, item, 1); - /* - * If enter_directory() fails, we simply ignore this path. This is - * what other implementations do and is consistent with the behavior - * for the file part. - */ - if (Null(base_dir)) - return ECL_NIL; - directory = ECL_CONS_CDR(directory); - goto AGAIN; - } - return output; + if (item == @':wild' || ecl_wild_string_p(item)) { + /* + * 2.1) If CAR(DIRECTORY) is a string or :WILD, we have to + * enter & scan all subdirectories in our curent directory. + */ + cl_object next_dir = list_directory(base_dir, item, ECL_NIL, flags); + for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { + cl_object record = ECL_CONS_CAR(next_dir); + cl_object component = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') + continue; + item = dir_recursive(cl_pathname(component), + ECL_CONS_CDR(directory), + filemask, flags); + output = ecl_nconc(item, output); + } + } else if (item == @':wild-inferiors') { + /* + * 2.2) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do + * scan all subdirectories from _all_ levels, looking for a + * tree that matches the remaining part of DIRECTORY. + */ + cl_object next_dir = list_directory(base_dir, ECL_NIL, ECL_NIL, flags); + for (; !Null(next_dir); next_dir = ECL_CONS_CDR(next_dir)) { + cl_object record = ECL_CONS_CAR(next_dir); + cl_object component = ECL_CONS_CAR(record); + cl_object kind = ECL_CONS_CDR(record); + if (kind != @':directory') + continue; + item = dir_recursive(cl_pathname(component), + directory, filemask, flags); + output = ecl_nconc(item, output); + } + directory = ECL_CONS_CDR(directory); + goto AGAIN; + } else { /* :ABSOLUTE, :RELATIVE, :UP, component without wildcards */ + /* + * 2.2) If CAR(DIRECTORY) is :ABSOLUTE, :RELATIVE or :UP we update + * the directory to reflect the root, the current or the parent one. + */ + base_dir = enter_directory(base_dir, item, 1); + /* + * If enter_directory() fails, we simply ignore this path. This is + * what other implementations do and is consistent with the behavior + * for the file part. + */ + if (Null(base_dir)) + return ECL_NIL; + directory = ECL_CONS_CDR(directory); + goto AGAIN; + } + return output; } @(defun directory (mask &key (resolve_symlinks ECL_T) &allow_other_keys) - cl_object base_dir; - cl_object output; -@ - mask = coerce_to_file_pathname(mask); - mask = make_absolute_pathname(mask); - base_dir = make_base_pathname(mask); - output = dir_recursive(base_dir, mask->pathname.directory, mask, - Null(resolve_symlinks)? 0 : FOLLOW_SYMLINKS); - @(return output) -@) + cl_object base_dir; + cl_object output; + @ + mask = coerce_to_file_pathname(mask); + mask = make_absolute_pathname(mask); + base_dir = make_base_pathname(mask); + output = dir_recursive(base_dir, mask->pathname.directory, mask, + Null(resolve_symlinks)? 0 : FOLLOW_SYMLINKS); + @(return output); + @) @(defun ext::getcwd (&optional (change_d_p_d ECL_NIL)) - cl_object output; -@ - output = cl_parse_namestring(3, current_dir(), ECL_NIL, ECL_NIL); - if (!Null(change_d_p_d)) { - ECL_SETQ(the_env, @'*default-pathname-defaults*', output); - } - @(return output) -@) + cl_object output; + @ + output = cl_parse_namestring(3, current_dir(), ECL_NIL, ECL_NIL); + if (!Null(change_d_p_d)) { + ECL_SETQ(the_env, @'*default-pathname-defaults*', output); + } + @(return output); + @) cl_object si_get_library_pathname(void) { - cl_object s = cl_core.library_pathname; - if (!Null(s)) { - goto OUTPUT_UNCHANGED; - } else { - const char *v = getenv("ECLDIR"); - if (v) { - s = make_constant_base_string(v); - goto OUTPUT; - } - } + cl_object s = cl_core.library_pathname; + if (!Null(s)) { + goto OUTPUT_UNCHANGED; + } else { + const char *v = getenv("ECLDIR"); + if (v) { + s = make_constant_base_string(v); + goto OUTPUT; + } + } #if defined(ECL_MS_WINDOWS_HOST) - { - char *buffer; - HMODULE hnd; - cl_index len, ep; - s = ecl_alloc_adjustable_base_string(cl_core.path_max); - buffer = (char*)s->base_string.self; - ecl_disable_interrupts(); - hnd = GetModuleHandle("ecl.dll"); - len = GetModuleFileName(hnd, buffer, cl_core.path_max-1); - ecl_enable_interrupts(); - if (len == 0) { - FEerror("GetModuleFileName failed (last error = ~S)", - 1, ecl_make_fixnum(GetLastError())); - } - s->base_string.fillp = len; - /* GetModuleFileName returns a file name. We have to strip - * the directory component. */ - s = cl_make_pathname(8, @':name', ECL_NIL, @':type', ECL_NIL, - @':version', ECL_NIL, - @':defaults', s); - s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); - } + { + char *buffer; + HMODULE hnd; + cl_index len, ep; + s = ecl_alloc_adjustable_base_string(cl_core.path_max); + buffer = (char*)s->base_string.self; + ecl_disable_interrupts(); + hnd = GetModuleHandle("ecl.dll"); + len = GetModuleFileName(hnd, buffer, cl_core.path_max-1); + ecl_enable_interrupts(); + if (len == 0) { + FEerror("GetModuleFileName failed (last error = ~S)", + 1, ecl_make_fixnum(GetLastError())); + } + s->base_string.fillp = len; + /* GetModuleFileName returns a file name. We have to strip + * the directory component. */ + s = cl_make_pathname(8, @':name', ECL_NIL, @':type', ECL_NIL, + @':version', ECL_NIL, + @':defaults', s); + s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); + } #else - s = make_constant_base_string(ECLDIR "/"); + s = make_constant_base_string(ECLDIR "/"); #endif OUTPUT: - { - cl_object true_pathname = cl_probe_file(s); - if (Null(true_pathname)) { - s = current_dir(); - } else { - /* Produce a string */ - s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); - } - } - cl_core.library_pathname = s; + { + cl_object true_pathname = cl_probe_file(s); + if (Null(true_pathname)) { + s = current_dir(); + } else { + /* Produce a string */ + s = ecl_namestring(s, ECL_NAMESTRING_FORCE_BASE_STRING); + } + } + cl_core.library_pathname = s; OUTPUT_UNCHANGED: - @(return s); + @(return s); } @(defun ext::chdir (directory &optional (change_d_p_d ECL_T)) - cl_object previous = si_getcwd(0); - cl_object namestring; -@ - /* This will fail if the new directory does not exist */ - directory = cl_truename(directory); - if (directory->pathname.name != ECL_NIL || - directory->pathname.type != ECL_NIL) - FEerror("~A is not a directory pathname.", 1, directory); - namestring = ecl_namestring(directory, - ECL_NAMESTRING_TRUNCATE_IF_ERROR | - ECL_NAMESTRING_FORCE_BASE_STRING); - if (safe_chdir((char*)namestring->base_string.self, ECL_NIL) < 0) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Can't change the current directory to ~A." - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, directory, c_error), /* format args */ - @':pathname', /* file-error options */ - directory); - } else if (change_d_p_d != ECL_NIL) { - ECL_SETQ(the_env, @'*default-pathname-defaults*', directory); - } - @(return previous) -@) + cl_object previous = si_getcwd(0); + cl_object namestring; + @ + /* This will fail if the new directory does not exist */ + directory = cl_truename(directory); + if (directory->pathname.name != ECL_NIL || + directory->pathname.type != ECL_NIL) + FEerror("~A is not a directory pathname.", 1, directory); + namestring = ecl_namestring(directory, + ECL_NAMESTRING_TRUNCATE_IF_ERROR | + ECL_NAMESTRING_FORCE_BASE_STRING); + if (safe_chdir((char*)namestring->base_string.self, ECL_NIL) < 0) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Can't change the current directory to ~A." + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, directory, c_error), /* format args */ + @':pathname', /* file-error options */ + directory); + } else if (change_d_p_d != ECL_NIL) { + ECL_SETQ(the_env, @'*default-pathname-defaults*', directory); + } + @(return previous) + @) cl_object si_mkdir(cl_object directory, cl_object mode) { - int modeint, ok; - cl_object filename = si_coerce_to_base_string(directory); + int modeint, ok; + cl_object filename = si_coerce_to_base_string(directory); - if (ecl_unlikely(!ECL_FIXNUMP(mode) || - ecl_fixnum_minusp(mode) || - ecl_fixnum_greater(mode, ecl_make_fixnum(0777)))) { - FEwrong_type_nth_arg(@[si::mkdir], 2, mode, - ecl_make_integer_type(ecl_make_fixnum(0), - ecl_make_fixnum(0777))); - } - modeint = ecl_fixnum(mode); - { - /* Ensure a clean string, without trailing slashes, - * and null terminated. */ - cl_index last = filename->base_string.fillp; - if (last > 1) { - ecl_character c = filename->base_string.self[last-1]; - if (IS_DIR_SEPARATOR(c)) - last--; - } - filename = ecl_subseq(filename, 0, last); - } - ecl_disable_interrupts(); + if (ecl_unlikely(!ECL_FIXNUMP(mode) || + ecl_fixnum_minusp(mode) || + ecl_fixnum_greater(mode, ecl_make_fixnum(0777)))) { + FEwrong_type_nth_arg(@[si::mkdir], 2, mode, + ecl_make_integer_type(ecl_make_fixnum(0), + ecl_make_fixnum(0777))); + } + modeint = ecl_fixnum(mode); + { + /* Ensure a clean string, without trailing slashes, + * and null terminated. */ + cl_index last = filename->base_string.fillp; + if (last > 1) { + ecl_character c = filename->base_string.self[last-1]; + if (IS_DIR_SEPARATOR(c)) + last--; + } + filename = ecl_subseq(filename, 0, last); + } + ecl_disable_interrupts(); #if defined(ECL_MS_WINDOWS_HOST) - ok = mkdir((char*)filename->base_string.self); + ok = mkdir((char*)filename->base_string.self); #else - ok = mkdir((char*)filename->base_string.self, modeint); + ok = mkdir((char*)filename->base_string.self, modeint); #endif - ecl_enable_interrupts(); + ecl_enable_interrupts(); - if (ecl_unlikely(ok < 0)) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Could not create directory ~S" - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(2, filename, c_error), /* format args */ - @':pathname', /* file-error options */ - filename); - } - @(return filename) + if (ecl_unlikely(ok < 0)) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Could not create directory ~S" + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(2, filename, c_error), /* format args */ + @':pathname', /* file-error options */ + filename); + } + @(return filename); } cl_object si_mkstemp(cl_object template) { - cl_object output; - cl_index l; - int fd; + cl_object output; + cl_index l; + int fd; #if defined(ECL_MS_WINDOWS_HOST) - cl_object phys, dir, file; - char strTempDir[MAX_PATH]; - char strTempFileName[MAX_PATH]; - char *s; - int ok; + cl_object phys, dir, file; + char strTempDir[MAX_PATH]; + char strTempFileName[MAX_PATH]; + char *s; + int ok; - phys = cl_translate_logical_pathname(1, template); - dir = cl_make_pathname(8, - @':type', ECL_NIL, - @':name', ECL_NIL, - @':version', ECL_NIL, - @':defaults', phys); - dir = si_coerce_to_filename(dir); - file = cl_file_namestring(phys); + phys = cl_translate_logical_pathname(1, template); + dir = cl_make_pathname(8, + @':type', ECL_NIL, + @':name', ECL_NIL, + @':version', ECL_NIL, + @':defaults', phys); + dir = si_coerce_to_filename(dir); + file = cl_file_namestring(phys); - l = dir->base_string.fillp; - memcpy(strTempDir, dir->base_string.self, l); - strTempDir[l] = 0; - for (s = strTempDir; *s; s++) - if (*s == '/') - *s = '\\'; + l = dir->base_string.fillp; + memcpy(strTempDir, dir->base_string.self, l); + strTempDir[l] = 0; + for (s = strTempDir; *s; s++) + if (*s == '/') + *s = '\\'; - ecl_disable_interrupts(); - ok = GetTempFileName(strTempDir, (char*)file->base_string.self, 0, - strTempFileName); - ecl_enable_interrupts(); - if (!ok) { - output = ECL_NIL; - } else { - l = strlen(strTempFileName); - output = ecl_alloc_simple_base_string(l); - memcpy(output->base_string.self, strTempFileName, l); - } + ecl_disable_interrupts(); + ok = GetTempFileName(strTempDir, (char*)file->base_string.self, 0, + strTempFileName); + ecl_enable_interrupts(); + if (!ok) { + output = ECL_NIL; + } else { + l = strlen(strTempFileName); + output = ecl_alloc_simple_base_string(l); + memcpy(output->base_string.self, strTempFileName, l); + } #else - template = si_coerce_to_filename(template); - l = template->base_string.fillp; - output = ecl_alloc_simple_base_string(l + 6); - memcpy(output->base_string.self, template->base_string.self, l); - memcpy(output->base_string.self + l, "XXXXXX", 6); + template = si_coerce_to_filename(template); + l = template->base_string.fillp; + output = ecl_alloc_simple_base_string(l + 6); + memcpy(output->base_string.self, template->base_string.self, l); + memcpy(output->base_string.self + l, "XXXXXX", 6); - ecl_disable_interrupts(); + ecl_disable_interrupts(); # ifdef HAVE_MKSTEMP - fd = mkstemp((char*)output->base_string.self); + fd = mkstemp((char*)output->base_string.self); # else - if (mktemp((char*)output->base_string.self)) { - fd = open((char*)output->base_string.self, O_CREAT|O_TRUNC, 0666); - } else { - fd = -1; - } + if (mktemp((char*)output->base_string.self)) { + fd = open((char*)output->base_string.self, O_CREAT|O_TRUNC, 0666); + } else { + fd = -1; + } # endif - ecl_enable_interrupts(); + ecl_enable_interrupts(); - if (fd < 0) { - output = ECL_NIL; - } else { - close(fd); - } + if (fd < 0) { + output = ECL_NIL; + } else { + close(fd); + } #endif - @(return (Null(output)? output : cl_truename(output))) + @(return (Null(output)? output : cl_truename(output))); } cl_object si_rmdir(cl_object directory) { - return cl_delete_file(cl_make_pathname(6, @':name', ECL_NIL, - @':type', ECL_NIL, - @':defaults', directory)); + return cl_delete_file(cl_make_pathname(6, @':name', ECL_NIL, + @':type', ECL_NIL, + @':defaults', directory)); } cl_object si_copy_file(cl_object orig, cl_object dest) { - FILE *in, *out; - int ok = 0; - orig = si_coerce_to_filename(orig); - dest = si_coerce_to_filename(dest); - ecl_disable_interrupts(); - in = fopen((char*)orig->base_string.self, OPEN_R); - if (in) { - out = fopen((char*)dest->base_string.self, OPEN_W); - if (out) { - unsigned char *buffer = ecl_alloc_atomic(1024); - cl_index size; - do { - size = fread(buffer, 1, 1024, in); - fwrite(buffer, 1, size, out); - } while (size == 1024); - ok = 1; - fclose(out); - } - fclose(in); - } - ecl_enable_interrupts(); - @(return (ok? ECL_T : ECL_NIL)) + FILE *in, *out; + int ok = 0; + orig = si_coerce_to_filename(orig); + dest = si_coerce_to_filename(dest); + ecl_disable_interrupts(); + in = fopen((char*)orig->base_string.self, OPEN_R); + if (in) { + out = fopen((char*)dest->base_string.self, OPEN_W); + if (out) { + unsigned char *buffer = ecl_alloc_atomic(1024); + cl_index size; + do { + size = fread(buffer, 1, 1024, in); + fwrite(buffer, 1, size, out); + } while (size == 1024); + ok = 1; + fclose(out); + } + fclose(in); + } + ecl_enable_interrupts(); + @(return (ok? ECL_T : ECL_NIL)); } cl_object si_chmod(cl_object file, cl_object mode) { - mode_t code = ecl_to_uint32_t(mode); - cl_object filename = coerce_to_posix_filename(file); - unlikely_if (chmod((char*)filename->base_string.self, code)) { - cl_object c_error = _ecl_strerror(errno); - const char *msg = "Unable to change mode of file ~S to value ~O" - "~%C library error: ~S"; - si_signal_simple_error - (6, @'file-error', /* condition */ - ECL_T, /* continuable */ - /* format */ - ecl_make_constant_base_string(msg,strlen(msg)), - cl_list(3, file, mode, c_error), /* format args */ - @':pathname', /* file-error options */ - file); - } - @(return) + mode_t code = ecl_to_uint32_t(mode); + cl_object filename = coerce_to_posix_filename(file); + unlikely_if (chmod((char*)filename->base_string.self, code)) { + cl_object c_error = _ecl_strerror(errno); + const char *msg = "Unable to change mode of file ~S to value ~O" + "~%C library error: ~S"; + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_T, /* continuable */ + /* format */ + ecl_make_constant_base_string(msg,strlen(msg)), + cl_list(3, file, mode, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + } + @(return); } diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 4bc874a5a..81de2b063 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -1,21 +1,16 @@ -/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */ -/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - unixsys.s -- Unix shell interface. -*/ -/* - Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. - Copyright (c) 1990, Giuseppe Attardi. - Copyright (c) 2001, Juan Jose Garcia Ripoll. - - ECL 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. -*/ + * unixsys.s - Unix shell interface + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ #include #include @@ -48,10 +43,10 @@ cl_object si_getpid(void) { #if defined(NACL) - FElibc_error("si_getpid not implemented",1); - @(return Cnil) + FElibc_error("si_getpid not implemented",1); + @(return ECL_NIL); #else - @(return ecl_make_fixnum(getpid())) + @(return ecl_make_fixnum(getpid())); #endif } @@ -59,9 +54,9 @@ cl_object si_getuid(void) { #if defined(ECL_MS_WINDOWS_HOST) - @(return ecl_make_fixnum(0)); + @(return ecl_make_fixnum(0)); #else - @(return ecl_make_integer(getuid())); + @(return ecl_make_integer(getuid())); #endif } @@ -72,171 +67,171 @@ cl_object si_make_pipe() { #if defined(NACL) - FElibc_error("si_make_pipe not implemented",1); - @(return Cnil) + FElibc_error("si_make_pipe not implemented",1); + @(return ECL_NIL); #else - cl_object output; - int fds[2], ret; + cl_object output; + int fds[2], ret; #if defined(ECL_MS_WINDOWS_HOST) - ret = _pipe(fds, 4096, _O_BINARY); + ret = _pipe(fds, 4096, _O_BINARY); #else - ret = pipe(fds); + ret = pipe(fds); #endif - if (ret < 0) { - FElibc_error("Unable to create pipe", 0); - output = ECL_NIL; - } else { - cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); - cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], ecl_smm_output, 8, - ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); - output = cl_make_two_way_stream(in, out); - } - @(return output) + if (ret < 0) { + FElibc_error("Unable to create pipe", 0); + output = ECL_NIL; + } else { + cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], ecl_smm_input, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); + cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], ecl_smm_output, 8, + ECL_STREAM_DEFAULT_FORMAT, ECL_NIL); + output = cl_make_two_way_stream(in, out); + } + @(return output); #endif } static cl_object from_list_to_execve_argument(cl_object l, char ***environp) { - cl_object p; - cl_index i, j, total_size = 0, nstrings = 0; - cl_object buffer; - char **environ; - for (p = l; !Null(p); p = ECL_CONS_CDR(p)) { - cl_object s; - if (!CONSP(p)) { - FEerror("In EXT:RUN-PROGRAM, environment " - "is not a list of strings", 0); - } - s = ECL_CONS_CAR(p); - if (!ECL_BASE_STRING_P(s)) { - FEerror("In EXT:RUN-PROGRAM, environment " - "is not a list of base strings", 0); - } - total_size += s->base_string.fillp + 1; - nstrings++; - } - /* Extra place for ending null */ - total_size++; - buffer = ecl_alloc_simple_base_string(++total_size); - environ = ecl_alloc_atomic((nstrings + 1) * sizeof(char*)); - for (j = i = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) { - cl_object s = ECL_CONS_CAR(p); - cl_index l = s->base_string.fillp; - if (i + l + 1 >= total_size) { - FEerror("In EXT:RUN-PROGRAM, environment list" - " changed during execution.", 0); - break; - } - environ[j++] = (char*)(buffer->base_string.self + i); - memcpy(buffer->base_string.self + i, - s->base_string.self, - l); - i += l; - buffer->base_string.self[i++] = 0; - } - buffer->base_string.self[i++] = 0; - environ[j] = 0; - if (environp) *environp = environ; - return buffer; + cl_object p; + cl_index i, j, total_size = 0, nstrings = 0; + cl_object buffer; + char **environ; + for (p = l; !Null(p); p = ECL_CONS_CDR(p)) { + cl_object s; + if (!CONSP(p)) { + FEerror("In EXT:RUN-PROGRAM, environment " + "is not a list of strings", 0); + } + s = ECL_CONS_CAR(p); + if (!ECL_BASE_STRING_P(s)) { + FEerror("In EXT:RUN-PROGRAM, environment " + "is not a list of base strings", 0); + } + total_size += s->base_string.fillp + 1; + nstrings++; + } + /* Extra place for ending null */ + total_size++; + buffer = ecl_alloc_simple_base_string(++total_size); + environ = ecl_alloc_atomic((nstrings + 1) * sizeof(char*)); + for (j = i = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) { + cl_object s = ECL_CONS_CAR(p); + cl_index l = s->base_string.fillp; + if (i + l + 1 >= total_size) { + FEerror("In EXT:RUN-PROGRAM, environment list" + " changed during execution.", 0); + break; + } + environ[j++] = (char*)(buffer->base_string.self + i); + memcpy(buffer->base_string.self + i, + s->base_string.self, + l); + i += l; + buffer->base_string.self[i++] = 0; + } + buffer->base_string.self[i++] = 0; + environ[j] = 0; + if (environp) *environp = environ; + return buffer; } static cl_object make_external_process() { - return _ecl_funcall1(@'ext::make-external-process'); + return _ecl_funcall1(@'ext::make-external-process'); } static cl_object external_process_pid(cl_object p) { - return ecl_structure_ref(p, @'ext::external-process', 0); + return ecl_structure_ref(p, @'ext::external-process', 0); } static cl_object external_process_status(cl_object p) { - return ecl_structure_ref(p, @'ext::external-process', 4); + return ecl_structure_ref(p, @'ext::external-process', 4); } static cl_object external_process_code(cl_object p) { - return ecl_structure_ref(p, @'ext::external-process', 5); + return ecl_structure_ref(p, @'ext::external-process', 5); } static void set_external_process_pid(cl_object process, cl_object pid) { - ecl_structure_set(process, @'ext::external-process', 0, pid); + ecl_structure_set(process, @'ext::external-process', 0, pid); } static void set_external_process_streams(cl_object process, cl_object input, cl_object output, cl_object error) { - ecl_structure_set(process, @'ext::external-process', 1, input); - ecl_structure_set(process, @'ext::external-process', 2, output); - ecl_structure_set(process, @'ext::external-process', 3, error); + ecl_structure_set(process, @'ext::external-process', 1, input); + ecl_structure_set(process, @'ext::external-process', 2, output); + ecl_structure_set(process, @'ext::external-process', 3, error); } static void update_process_status(cl_object process, cl_object status, cl_object code) { - ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL); - ecl_structure_set(process, @'ext::external-process', 4, status); - ecl_structure_set(process, @'ext::external-process', 5, code); + ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL); + ecl_structure_set(process, @'ext::external-process', 4, status); + ecl_structure_set(process, @'ext::external-process', 5, code); } #if defined(SIGCHLD) && !defined(ECL_MS_WINDOWS_HOST) static void add_external_process(cl_env_ptr env, cl_object process) { - cl_object l = ecl_list1(process); - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - ECL_RPLACD(l, cl_core.external_processes); - cl_core.external_processes = l; - } - ECL_WITH_SPINLOCK_END; - ecl_enable_interrupts_env(env); + cl_object l = ecl_list1(process); + ecl_disable_interrupts_env(env); + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + ECL_RPLACD(l, cl_core.external_processes); + cl_core.external_processes = l; + } + ECL_WITH_SPINLOCK_END; + ecl_enable_interrupts_env(env); } static void remove_external_process(cl_env_ptr env, cl_object process) { - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_core.external_processes = - ecl_delete_eq(process, cl_core.external_processes); - } - ECL_WITH_SPINLOCK_END; - ecl_enable_interrupts_env(env); + ecl_disable_interrupts_env(env); + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + cl_core.external_processes = + ecl_delete_eq(process, cl_core.external_processes); + } + ECL_WITH_SPINLOCK_END; + ecl_enable_interrupts_env(env); } static cl_object find_external_process(cl_env_ptr env, cl_object pid) { - cl_object output = ECL_NIL; - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_object p; - for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) { - cl_object process = ECL_CONS_CAR(p); - if (external_process_pid(process) == pid) { - output = process; - break; - } - } - } - ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock); - ecl_enable_interrupts_env(env); - return output; + cl_object output = ECL_NIL; + ecl_disable_interrupts_env(env); + ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); + { + cl_object p; + for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) { + cl_object process = ECL_CONS_CAR(p); + if (external_process_pid(process) == pid) { + output = process; + break; + } + } + } + ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock); + ecl_enable_interrupts_env(env); + return output; } #else #define add_external_process(env,p) @@ -246,176 +241,174 @@ find_external_process(cl_env_ptr env, cl_object pid) static cl_object ecl_waitpid(cl_object pid, cl_object wait) { - cl_object status, code; + cl_object status, code; #if defined(NACL) - FElibc_error("ecl_waitpid not implemented",1); - @(return Cnil) + FElibc_error("ecl_waitpid not implemented",1); + @(return ECL_NIL); #elif defined(ECL_MS_WINDOWS_HOST) - cl_env_ptr the_env = ecl_process_env(); - HANDLE *hProcess = ecl_foreign_data_pointer_safe(pid); - DWORD exitcode; - int ok; - WaitForSingleObject(*hProcess, Null(wait)? 0 : INFINITE); - ecl_disable_interrupts_env(the_env); - ok = GetExitCodeProcess(*hProcess, &exitcode); - if (!ok) { - status = @':error'; - code = ECL_NIL; - } else if (exitcode == STILL_ACTIVE) { - status = @':running'; - code = ECL_NIL; - } else { - status = @':exited'; - code = ecl_make_fixnum(exitcode); - pid->foreign.data = NULL; - CloseHandle(*hProcess); - } - ecl_enable_interrupts_env(the_env); + cl_env_ptr the_env = ecl_process_env(); + HANDLE *hProcess = ecl_foreign_data_pointer_safe(pid); + DWORD exitcode; + int ok; + WaitForSingleObject(*hProcess, Null(wait)? 0 : INFINITE); + ecl_disable_interrupts_env(the_env); + ok = GetExitCodeProcess(*hProcess, &exitcode); + if (!ok) { + status = @':error'; + code = ECL_NIL; + } else if (exitcode == STILL_ACTIVE) { + status = @':running'; + code = ECL_NIL; + } else { + status = @':exited'; + code = ecl_make_fixnum(exitcode); + pid->foreign.data = NULL; + CloseHandle(*hProcess); + } + ecl_enable_interrupts_env(the_env); #else - int code_int, error; - error = waitpid(ecl_to_fix(pid), &code_int, Null(wait)? WNOHANG : 0); - if (error < 0) { - if (errno == EINTR) { - status = @':abort'; - } else { - status = @':error'; - } - code = ECL_NIL; - pid = ECL_NIL; - } else if (error == 0) { - status = ECL_NIL; - code = ECL_NIL; - pid = ECL_NIL; - } else { - pid = ecl_make_fixnum(error); - if (WIFEXITED(code_int)) { - status = @':exited'; - code = ecl_make_fixnum(WEXITSTATUS(code_int)); - } else if (WIFSIGNALED(code_int)) { - status = @':signaled'; - code = ecl_make_fixnum(WTERMSIG(code_int)); - } else if (WIFSTOPPED(code_int)) { - status = @':stopped'; - code = ecl_make_fixnum(WSTOPSIG(code_int)); - } else { - status = @':running'; - code = ECL_NIL; - } - } + int code_int, error; + error = waitpid(ecl_to_fix(pid), &code_int, Null(wait)? WNOHANG : 0); + if (error < 0) { + if (errno == EINTR) { + status = @':abort'; + } else { + status = @':error'; + } + code = ECL_NIL; + pid = ECL_NIL; + } else if (error == 0) { + status = ECL_NIL; + code = ECL_NIL; + pid = ECL_NIL; + } else { + pid = ecl_make_fixnum(error); + if (WIFEXITED(code_int)) { + status = @':exited'; + code = ecl_make_fixnum(WEXITSTATUS(code_int)); + } else if (WIFSIGNALED(code_int)) { + status = @':signaled'; + code = ecl_make_fixnum(WTERMSIG(code_int)); + } else if (WIFSTOPPED(code_int)) { + status = @':stopped'; + code = ecl_make_fixnum(WSTOPSIG(code_int)); + } else { + status = @':running'; + code = ECL_NIL; + } + } #endif - @(return status code pid) + @(return status code pid); } @(defun si::wait-for-all-processes (&key (process ECL_NIL)) -@ -{ - const cl_env_ptr env = ecl_process_env(); + @ + { + const cl_env_ptr env = ecl_process_env(); #if defined(SIGCHLD) && !defined(ECL_WINDOWS_HOST) - do { - cl_object status = ecl_waitpid(ecl_make_fixnum(-1), ECL_NIL); - cl_object code = env->values[1]; - cl_object pid = env->values[2]; - if (Null(pid)) { - if (status != @':abort') - break; - } else { - cl_object p = find_external_process(env, pid); - if (!Null(p)) { - set_external_process_pid(p, ECL_NIL); - update_process_status(p, status, code); - } - if (status != @':running') { - remove_external_process(env, p); ecl_delete_eq(p, cl_core.external_processes); - } - } - } while (1); + do { + cl_object status = ecl_waitpid(ecl_make_fixnum(-1), ECL_NIL); + cl_object code = env->values[1]; + cl_object pid = env->values[2]; + if (Null(pid)) { + if (status != @':abort') + break; + } else { + cl_object p = find_external_process(env, pid); + if (!Null(p)) { + set_external_process_pid(p, ECL_NIL); + update_process_status(p, status, code); + } + if (status != @':running') { + remove_external_process(env, p); ecl_delete_eq(p, cl_core.external_processes); + } + } + } while (1); #endif - ecl_return0(env); -} -@) + ecl_return0(env); + } + @) #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) cl_object si_close_windows_handle(cl_object h) { - if (ecl_t_of(h) == t_foreign) { - HANDLE *ph = (HANDLE*)h->foreign.data; - if (ph) CloseHandle(*ph); - } + if (ecl_t_of(h) == t_foreign) { + HANDLE *ph = (HANDLE*)h->foreign.data; + if (ph) CloseHandle(*ph); + } } static cl_object make_windows_handle(HANDLE h) { - cl_object foreign = ecl_allocate_foreign_data(@':pointer-void', - sizeof(HANDLE*)); - HANDLE *ph = (HANDLE*)foreign->foreign.data; - *ph = h; - si_set_finalizer(foreign, @'si::close-windows-handle'); - return foreign; + cl_object foreign = ecl_allocate_foreign_data(@':pointer-void', + sizeof(HANDLE*)); + HANDLE *ph = (HANDLE*)foreign->foreign.data; + *ph = h; + si_set_finalizer(foreign, @'si::close-windows-handle'); + return foreign; } #endif @(defun ext::external-process-wait (process &optional (wait ECL_NIL)) -@ -{ - cl_object status, code, pid; - AGAIN: - pid = external_process_pid(process); - if (Null(pid)) { - /* If PID is NIL, it may be because the process failed, - * or because it is being updated by a separate thread, - * which is why we have to spin here. Note also the order - * here: status is updated _after_ code, and hence we - * check it _before_ code. */ - do { - ecl_musleep(0.0, 1); - status = external_process_status(process); - } while (status == @':running'); - code = external_process_code(process); - } else { - status = ecl_waitpid(pid, wait); - code = ecl_nth_value(the_env, 1); - pid = ecl_nth_value(the_env, 2); - /* A SIGCHLD interrupt may abort waitpid. If this - * is the case, the signal handler may have consumed - * the process status and we have to start over again */ - if (Null(pid)) { - if (!Null(wait)) goto AGAIN; - status = external_process_status(process); - code = external_process_code(process); - } else { - update_process_status(process, status, code); - remove_external_process(the_env, process); - } - } - @(return status code) -} -@) + @ { + cl_object status, code, pid; + AGAIN: + pid = external_process_pid(process); + if (Null(pid)) { + /* If PID is NIL, it may be because the process failed, + * or because it is being updated by a separate thread, + * which is why we have to spin here. Note also the order + * here: status is updated _after_ code, and hence we + * check it _before_ code. */ + do { + ecl_musleep(0.0, 1); + status = external_process_status(process); + } while (status == @':running'); + code = external_process_code(process); + } else { + status = ecl_waitpid(pid, wait); + code = ecl_nth_value(the_env, 1); + pid = ecl_nth_value(the_env, 2); + /* A SIGCHLD interrupt may abort waitpid. If this + * is the case, the signal handler may have consumed + * the process status and we have to start over again */ + if (Null(pid)) { + if (!Null(wait)) goto AGAIN; + status = external_process_status(process); + code = external_process_code(process); + } else { + update_process_status(process, status, code); + remove_external_process(the_env, process); + } + } + @(return status code); + } @) #if defined(ECL_MS_WINDOWS_HOST) HANDLE ecl_stream_to_HANDLE(cl_object s, bool output) { - if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) - return INVALID_HANDLE_VALUE; - switch ((enum ecl_smmode)s->stream.mode) { + if (ecl_unlikely(!ECL_ANSI_STREAM_P(s))) + return INVALID_HANDLE_VALUE; + switch ((enum ecl_smmode)s->stream.mode) { #if defined(ECL_WSOCK) - case ecl_smm_input_wsock: - case ecl_smm_output_wsock: - case ecl_smm_io_wsock: + case ecl_smm_input_wsock: + case ecl_smm_output_wsock: + case ecl_smm_io_wsock: #endif #if defined(ECL_MS_WINDOWS_HOST) - case ecl_smm_io_wcon: + case ecl_smm_io_wcon: #endif - return (HANDLE)IO_FILE_DESCRIPTOR(s); - default: { - int stream_descriptor = ecl_stream_to_handle(s, output); - return (stream_descriptor < 0)? - INVALID_HANDLE_VALUE: - (HANDLE)_get_osfhandle(stream_descriptor); - } - } + return (HANDLE)IO_FILE_DESCRIPTOR(s); + default: { + int stream_descriptor = ecl_stream_to_handle(s, output); + return (stream_descriptor < 0)? + INVALID_HANDLE_VALUE: + (HANDLE)_get_osfhandle(stream_descriptor); + } + } } #endif @@ -423,100 +416,100 @@ ecl_stream_to_HANDLE(cl_object s, bool output) static void create_descriptor(cl_object stream, cl_object direction, HANDLE *child, int *parent) { - SECURITY_ATTRIBUTES attr; - HANDLE current = GetCurrentProcess(); - attr.nLength = sizeof(SECURITY_ATTRIBUTES); - attr.lpSecurityDescriptor = NULL; - attr.bInheritHandle = TRUE; + SECURITY_ATTRIBUTES attr; + HANDLE current = GetCurrentProcess(); + attr.nLength = sizeof(SECURITY_ATTRIBUTES); + attr.lpSecurityDescriptor = NULL; + attr.bInheritHandle = TRUE; - if (stream == @':stream') { - /* Creates a pipe that we can write to and the - child reads from. We duplicate one extreme of the - pipe so that the child does not inherit it. */ - HANDLE tmp; - if (CreatePipe(&tmp, child, &attr, 0) == 0) - return; + if (stream == @':stream') { + /* Creates a pipe that we can write to and the + child reads from. We duplicate one extreme of the + pipe so that the child does not inherit it. */ + HANDLE tmp; + if (CreatePipe(&tmp, child, &attr, 0) == 0) + return; - if (DuplicateHandle(current, tmp, current, - &tmp, 0, FALSE, - DUPLICATE_CLOSE_SOURCE | - DUPLICATE_SAME_ACCESS) == 0) - return; + if (DuplicateHandle(current, tmp, current, + &tmp, 0, FALSE, + DUPLICATE_CLOSE_SOURCE | + DUPLICATE_SAME_ACCESS) == 0) + return; - if (direction == @':input') { + if (direction == @':input') { #ifdef cygwin - *parent = cygwin_attach_handle_to_fd - (0, -1, tmp, S_IRWXU, GENERIC_WRITE); + *parent = cygwin_attach_handle_to_fd + (0, -1, tmp, S_IRWXU, GENERIC_WRITE); #else - *parent = _open_osfhandle - ((intptr_t)tmp, _O_WRONLY); + *parent = _open_osfhandle + ((intptr_t)tmp, _O_WRONLY); #endif - } - else { + } + else { #ifdef cygwin - *parent = cygwin_attach_handle_to_fd - (0, -1, tmp, S_IRWXU, GENERIC_READ); + *parent = cygwin_attach_handle_to_fd + (0, -1, tmp, S_IRWXU, GENERIC_READ); #else - *parent = _open_osfhandle - ((intptr_t)tmp, _O_RDONLY); + *parent = _open_osfhandle + ((intptr_t)tmp, _O_RDONLY); #endif - } + } - if (*parent < 0) - printf("open_osfhandle failed\n"); - } - else if (Null(stream)) { - *child = NULL; - } - else if (!Null(cl_streamp(stream))) { - HANDLE stream_handle = ecl_stream_to_HANDLE - (stream, direction != @':input'); - if (stream_handle == INVALID_HANDLE_VALUE) { - FEerror("~S argument to RUN-PROGRAM does not " - "have a file handle:~%~S", 2, direction, stream); - } - DuplicateHandle(current, stream_handle, - current, child, 0, TRUE, - DUPLICATE_SAME_ACCESS); - } - else { - FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); - } + if (*parent < 0) + printf("open_osfhandle failed\n"); + } + else if (Null(stream)) { + *child = NULL; + } + else if (!Null(cl_streamp(stream))) { + HANDLE stream_handle = ecl_stream_to_HANDLE + (stream, direction != @':input'); + if (stream_handle == INVALID_HANDLE_VALUE) { + FEerror("~S argument to RUN-PROGRAM does not " + "have a file handle:~%~S", 2, direction, stream); + } + DuplicateHandle(current, stream_handle, + current, child, 0, TRUE, + DUPLICATE_SAME_ACCESS); + } + else { + FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); + } } #else static void create_descriptor(cl_object stream, cl_object direction, int *child, int *parent) { - if (stream == @':stream') { - int fd[2]; - pipe(fd); - if (direction == @':input') { - *parent = fd[1]; - *child = fd[0]; - } else { - *parent = fd[0]; - *child = fd[1]; - } - } - else if (Null(stream)) { - if (direction == @':input') - *child = open("/dev/null", O_RDONLY); - else - *child = open("/dev/null", O_WRONLY); - } - else if (!Null(cl_streamp(stream))) { - *child = ecl_stream_to_handle - (stream, direction != @':input'); - if (*child >= 0) { - *child = dup(*child); - } else { - FEerror("~S argument to RUN-PROGRAM does not " - "have a file handle:~%~S", 2, direction, stream); - } - } - else { - FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); - } + if (stream == @':stream') { + int fd[2]; + pipe(fd); + if (direction == @':input') { + *parent = fd[1]; + *child = fd[0]; + } else { + *parent = fd[0]; + *child = fd[1]; + } + } + else if (Null(stream)) { + if (direction == @':input') + *child = open("/dev/null", O_RDONLY); + else + *child = open("/dev/null", O_WRONLY); + } + else if (!Null(cl_streamp(stream))) { + *child = ecl_stream_to_handle + (stream, direction != @':input'); + if (*child >= 0) { + *child = dup(*child); + } else { + FEerror("~S argument to RUN-PROGRAM does not " + "have a file handle:~%~S", 2, direction, stream); + } + } + else { + FEerror("Invalid ~S argument to EXT:RUN-PROGRAM", 1, stream); + } } #endif @(defun ext::run-program (command argv &key (input @':stream') (output @':stream') @@ -525,273 +518,273 @@ create_descriptor(cl_object stream, cl_object direction, (if_output_exists @':error') (if_error_exists @':error') (external_format @':default')) - int parent_write = 0, parent_read = 0, parent_error = 0; - int child_pid; - cl_object pid, process; - cl_object stream_write; - cl_object stream_read; - cl_object stream_error; - cl_object exit_status = ECL_NIL; -@ - command = si_copy_to_simple_base_string(command); - argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); - process = make_external_process(); + int parent_write = 0, parent_read = 0, parent_error = 0; + int child_pid; + cl_object pid, process; + cl_object stream_write; + cl_object stream_read; + cl_object stream_error; + cl_object exit_status = ECL_NIL; + @ + command = si_copy_to_simple_base_string(command); + argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); + process = make_external_process(); -{ - if (input == @'t') - input = ecl_symbol_value(@'*standard-input*'); - if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) - input = cl_open(5, input, - @':direction', @':input', - @':if-does-not-exist', if_input_does_not_exist, - @':external-format', external_format); + { + if (input == @'t') + input = ecl_symbol_value(@'*standard-input*'); + if (ECL_STRINGP(input) || ECL_PATHNAMEP(input)) + input = cl_open(5, input, + @':direction', @':input', + @':if-does-not-exist', if_input_does_not_exist, + @':external-format', external_format); - if (output == @'t') - output = ecl_symbol_value(@'*standard-output*'); - if (ECL_STRINGP(output) || ECL_PATHNAMEP(output)) - output = cl_open(7, output, - @':direction', @':output', - @':if-exists', if_output_exists, - @':if-does-not-exist', @':create', - @':external-format', external_format); + if (output == @'t') + output = ecl_symbol_value(@'*standard-output*'); + if (ECL_STRINGP(output) || ECL_PATHNAMEP(output)) + output = cl_open(7, output, + @':direction', @':output', + @':if-exists', if_output_exists, + @':if-does-not-exist', @':create', + @':external-format', external_format); - if (error == @'t') - error = ecl_symbol_value(@'*error-output*'); - if (ECL_STRINGP(error) || ECL_PATHNAMEP(error)) - error = cl_open(7, error, - @':direction', @':output', - @':if-exists', if_error_exists, - @':if-does-not-exist', @':create', - @':external-format', external_format); -} + if (error == @'t') + error = ecl_symbol_value(@'*error-output*'); + if (ECL_STRINGP(error) || ECL_PATHNAMEP(error)) + error = cl_open(7, error, + @':direction', @':output', + @':if-exists', if_error_exists, + @':if-does-not-exist', @':create', + @':external-format', external_format); + } #if defined(ECL_MS_WINDOWS_HOST) -{ - BOOL ok; - STARTUPINFO st_info; - PROCESS_INFORMATION pr_info; - HANDLE child_stdout, child_stdin, child_stderr; - HANDLE current = GetCurrentProcess(); - HANDLE saved_stdout, saved_stdin, saved_stderr; - cl_object env_buffer; - char *env = NULL; + { + BOOL ok; + STARTUPINFO st_info; + PROCESS_INFORMATION pr_info; + HANDLE child_stdout, child_stdin, child_stderr; + HANDLE current = GetCurrentProcess(); + HANDLE saved_stdout, saved_stdin, saved_stderr; + cl_object env_buffer; + char *env = NULL; - /* Enclose each argument, as well as the file name - in double quotes, to avoid problems when these - arguments or file names have spaces */ - command = - cl_format(4, ECL_NIL, - ecl_make_simple_base_string("~S~{ ~S~}", -1), - command, argv); - command = si_copy_to_simple_base_string(command); - command = ecl_null_terminated_base_string(command); + /* Enclose each argument, as well as the file name + in double quotes, to avoid problems when these + arguments or file names have spaces */ + command = + cl_format(4, ECL_NIL, + ecl_make_simple_base_string("~S~{ ~S~}", -1), + command, argv); + command = si_copy_to_simple_base_string(command); + command = ecl_null_terminated_base_string(command); - if (!Null(environ)) { - env_buffer = from_list_to_execve_argument(environ, NULL); - env = env_buffer->base_string.self; - } - create_descriptor(input, @':input', &child_stdin, &parent_write); - create_descriptor(output, @':output', &child_stdout, &parent_read); - if (error == @':output') - /* The child inherits a duplicate of its own output - handle.*/ - DuplicateHandle(current, child_stdout, current, - &child_stderr, 0, TRUE, - DUPLICATE_SAME_ACCESS); - else - create_descriptor(error, @':error', &child_stderr, &parent_error); + if (!Null(environ)) { + env_buffer = from_list_to_execve_argument(environ, NULL); + env = env_buffer->base_string.self; + } + create_descriptor(input, @':input', &child_stdin, &parent_write); + create_descriptor(output, @':output', &child_stdout, &parent_read); + if (error == @':output') + /* The child inherits a duplicate of its own output + handle.*/ + DuplicateHandle(current, child_stdout, current, + &child_stderr, 0, TRUE, + DUPLICATE_SAME_ACCESS); + else + create_descriptor(error, @':error', &child_stderr, &parent_error); - add_external_process(the_env, process); + add_external_process(the_env, process); #if 1 - ZeroMemory(&st_info, sizeof(STARTUPINFO)); - st_info.cb = sizeof(STARTUPINFO); - st_info.lpTitle = NULL; /* No window title, just exec name */ - st_info.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW; /* Specify std{in,out,err} */ - st_info.wShowWindow = SW_HIDE; - st_info.hStdInput = child_stdin; - st_info.hStdOutput = child_stdout; - st_info.hStdError = child_stderr; - ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); - ok = CreateProcess(NULL, command->base_string.self, - NULL, NULL, /* lpProcess/ThreadAttributes */ - TRUE, /* Inherit handles (for files) */ - /*CREATE_NEW_CONSOLE |*/ - 0 /*(input == ECL_T || output == ECL_T || error == ECL_T ? 0 : CREATE_NO_WINDOW)*/, - env, /* Inherit environment */ - NULL, /* Current directory */ - &st_info, /* Startup info */ - &pr_info); /* Process info */ + ZeroMemory(&st_info, sizeof(STARTUPINFO)); + st_info.cb = sizeof(STARTUPINFO); + st_info.lpTitle = NULL; /* No window title, just exec name */ + st_info.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW; /* Specify std{in,out,err} */ + st_info.wShowWindow = SW_HIDE; + st_info.hStdInput = child_stdin; + st_info.hStdOutput = child_stdout; + st_info.hStdError = child_stderr; + ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); + ok = CreateProcess(NULL, command->base_string.self, + NULL, NULL, /* lpProcess/ThreadAttributes */ + TRUE, /* Inherit handles (for files) */ + /*CREATE_NEW_CONSOLE |*/ + 0 /*(input == ECL_T || output == ECL_T || error == ECL_T ? 0 : CREATE_NO_WINDOW)*/, + env, /* Inherit environment */ + NULL, /* Current directory */ + &st_info, /* Startup info */ + &pr_info); /* Process info */ #else /* 1 */ - saved_stdin = GetStdHandle(STD_INPUT_HANDLE); - saved_stdout = GetStdHandle(STD_OUTPUT_HANDLE); - saved_stderr = GetStdHandle(STD_ERROR_HANDLE); - SetStdHandle(STD_INPUT_HANDLE, child_stdin); - SetStdHandle(STD_OUTPUT_HANDLE, child_stdout); - SetStdHandle(STD_ERROR_HANDLE, child_stderr); - ZeroMemory(&st_info, sizeof(STARTUPINFO)); - st_info.cb = sizeof(STARTUPINFO); - ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); - ok = CreateProcess(NULL, command->base_string.self, - NULL, NULL, /* lpProcess/ThreadAttributes */ - TRUE, /* Inherit handles (for files) */ - /*CREATE_NEW_CONSOLE |*/ - 0, - NULL, /* Inherit environment */ - NULL, /* Current directory */ - &st_info, /* Startup info */ - &pr_info); /* Process info */ - SetStdHandle(STD_INPUT_HANDLE, saved_stdin); - SetStdHandle(STD_OUTPUT_HANDLE, saved_stdout); - SetStdHandle(STD_ERROR_HANDLE, saved_stderr); + saved_stdin = GetStdHandle(STD_INPUT_HANDLE); + saved_stdout = GetStdHandle(STD_OUTPUT_HANDLE); + saved_stderr = GetStdHandle(STD_ERROR_HANDLE); + SetStdHandle(STD_INPUT_HANDLE, child_stdin); + SetStdHandle(STD_OUTPUT_HANDLE, child_stdout); + SetStdHandle(STD_ERROR_HANDLE, child_stderr); + ZeroMemory(&st_info, sizeof(STARTUPINFO)); + st_info.cb = sizeof(STARTUPINFO); + ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); + ok = CreateProcess(NULL, command->base_string.self, + NULL, NULL, /* lpProcess/ThreadAttributes */ + TRUE, /* Inherit handles (for files) */ + /*CREATE_NEW_CONSOLE |*/ + 0, + NULL, /* Inherit environment */ + NULL, /* Current directory */ + &st_info, /* Startup info */ + &pr_info); /* Process info */ + SetStdHandle(STD_INPUT_HANDLE, saved_stdin); + SetStdHandle(STD_OUTPUT_HANDLE, saved_stdout); + SetStdHandle(STD_ERROR_HANDLE, saved_stderr); #endif /* 1 */ - /* Child handles must be closed in the parent process */ - /* otherwise the created pipes are never closed */ - if (ok) { - CloseHandle(pr_info.hThread); - pid = make_windows_handle(pr_info.hProcess); - } else { - char *message; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&message, 0, NULL); - printf("%s\n", message); - LocalFree(message); - pid = ECL_NIL; - } - set_external_process_pid(process, pid); - if (child_stdin) CloseHandle(child_stdin); - if (child_stdout) CloseHandle(child_stdout); - if (child_stderr) CloseHandle(child_stderr); -} + /* Child handles must be closed in the parent process */ + /* otherwise the created pipes are never closed */ + if (ok) { + CloseHandle(pr_info.hThread); + pid = make_windows_handle(pr_info.hProcess); + } else { + char *message; + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&message, 0, NULL); + printf("%s\n", message); + LocalFree(message); + pid = ECL_NIL; + } + set_external_process_pid(process, pid); + if (child_stdin) CloseHandle(child_stdin); + if (child_stdout) CloseHandle(child_stdout); + if (child_stderr) CloseHandle(child_stderr); + } #elif !defined(NACL) /* mingw */ -{ - int child_stdin, child_stdout, child_stderr; - int pipe_fd[2]; - argv = CONS(command, ecl_nconc(argv, ecl_list1(ECL_NIL))); - argv = _ecl_funcall3(@'coerce', argv, @'vector'); + { + int child_stdin, child_stdout, child_stderr; + int pipe_fd[2]; + argv = CONS(command, ecl_nconc(argv, ecl_list1(ECL_NIL))); + argv = _ecl_funcall3(@'coerce', argv, @'vector'); - create_descriptor(input, @':input', &child_stdin, &parent_write); - create_descriptor(output, @':output', &child_stdout, &parent_read); - if (error == @':output') - child_stderr = child_stdout; - else - create_descriptor(error, @':error', &child_stderr, &parent_error); + create_descriptor(input, @':input', &child_stdin, &parent_write); + create_descriptor(output, @':output', &child_stdout, &parent_read); + if (error == @':output') + child_stderr = child_stdout; + else + create_descriptor(error, @':error', &child_stderr, &parent_error); - add_external_process(the_env, process); - pipe(pipe_fd); - child_pid = fork(); - if (child_pid == 0) { - /* Child */ - int j; - void **argv_ptr = (void **)argv->vector.self.t; - { - /* Wait for the parent to set up its process structure */ - char sync[1]; - close(pipe_fd[1]); - while (read(pipe_fd[0], sync, 1) < 1) { - printf("\nError reading child pipe %d", errno); - fflush(stdout); - } - close(pipe_fd[0]); - } - dup2(child_stdin, STDIN_FILENO); - if (parent_write) close(parent_write); - dup2(child_stdout, STDOUT_FILENO); - if (parent_read) close(parent_read); - dup2(child_stderr, STDERR_FILENO); - if (parent_error) close(parent_error); - for (j = 0; j < argv->vector.fillp; j++) { - cl_object arg = argv->vector.self.t[j]; - if (arg == ECL_NIL) { - argv_ptr[j] = NULL; - } else { - argv_ptr[j] = arg->base_string.self; - } - } - if (!Null(environ)) { - char **pstrings; - cl_object buffer = from_list_to_execve_argument(environ, - &pstrings); - execve((char*)command->base_string.self, argv_ptr, pstrings); - } else { - execvp((char*)command->base_string.self, argv_ptr); - } - /* at this point exec has failed */ - perror("exec"); - abort(); + add_external_process(the_env, process); + pipe(pipe_fd); + child_pid = fork(); + if (child_pid == 0) { + /* Child */ + int j; + void **argv_ptr = (void **)argv->vector.self.t; + { + /* Wait for the parent to set up its process structure */ + char sync[1]; + close(pipe_fd[1]); + while (read(pipe_fd[0], sync, 1) < 1) { + printf("\nError reading child pipe %d", errno); + fflush(stdout); } - if (child_pid < 0) { - pid = ECL_NIL; + close(pipe_fd[0]); + } + dup2(child_stdin, STDIN_FILENO); + if (parent_write) close(parent_write); + dup2(child_stdout, STDOUT_FILENO); + if (parent_read) close(parent_read); + dup2(child_stderr, STDERR_FILENO); + if (parent_error) close(parent_error); + for (j = 0; j < argv->vector.fillp; j++) { + cl_object arg = argv->vector.self.t[j]; + if (arg == ECL_NIL) { + argv_ptr[j] = NULL; } else { - pid = ecl_make_fixnum(child_pid); + argv_ptr[j] = arg->base_string.self; } - set_external_process_pid(process, pid); - { - /* This guarantees that the child process does not exit - * before we have created the process structure. If we do not - * do this, the SIGPIPE signal may arrive before - * set_external_process_pid() and our call to external-process-wait - * down there may block indefinitely. */ - char sync[1]; - close(pipe_fd[0]); - while (write(pipe_fd[1], sync, 1) < 1) { - printf("\nError writing child pipe %d", errno); - fflush(stdout); - } - close(pipe_fd[1]); - } - close(child_stdin); - close(child_stdout); - close(child_stderr); -} + } + if (!Null(environ)) { + char **pstrings; + cl_object buffer = from_list_to_execve_argument(environ, + &pstrings); + execve((char*)command->base_string.self, argv_ptr, pstrings); + } else { + execvp((char*)command->base_string.self, argv_ptr); + } + /* at this point exec has failed */ + perror("exec"); + abort(); + } + if (child_pid < 0) { + pid = ECL_NIL; + } else { + pid = ecl_make_fixnum(child_pid); + } + set_external_process_pid(process, pid); + { + /* This guarantees that the child process does not exit + * before we have created the process structure. If we do not + * do this, the SIGPIPE signal may arrive before + * set_external_process_pid() and our call to external-process-wait + * down there may block indefinitely. */ + char sync[1]; + close(pipe_fd[0]); + while (write(pipe_fd[1], sync, 1) < 1) { + printf("\nError writing child pipe %d", errno); + fflush(stdout); + } + close(pipe_fd[1]); + } + close(child_stdin); + close(child_stdout); + close(child_stderr); + } #else -{ - FElibc_error("ext::run-program not implemented",1); - @(return Cnil) -} + { + FElibc_error("ext::run-program not implemented",1); + @(return ECL_NIL); + } #endif /* mingw */ - if (Null(pid)) { - if (parent_write) close(parent_write); - if (parent_read) close(parent_read); - if (parent_error) close(parent_error); - parent_write = 0; - parent_read = 0; - parent_error = 0; - remove_external_process(the_env, process); - FEerror("Could not spawn subprocess to run ~S.", 1, command); - } - if (parent_write > 0) { - stream_write = ecl_make_stream_from_fd(command, parent_write, - ecl_smm_output, 8, - external_format, ECL_T); - } else { - parent_write = 0; - stream_write = cl_core.null_stream; - } - if (parent_read > 0) { - stream_read = ecl_make_stream_from_fd(command, parent_read, - ecl_smm_input, 8, - external_format, ECL_T); - } else { - parent_read = 0; - stream_read = cl_core.null_stream; - } - if (parent_error > 0) { - stream_error = ecl_make_stream_from_fd(command, parent_error, - ecl_smm_input, 8, - external_format, ECL_T); - } else { - parent_error = 0; - stream_error = cl_core.null_stream; - } - set_external_process_streams(process, stream_write, stream_read, - stream_error); - if (!Null(wait)) { - exit_status = si_external_process_wait(2, process, ECL_T); - exit_status = ecl_nth_value(the_env, 1); - } - @(return ((parent_read || parent_write)? - cl_make_two_way_stream(stream_read, stream_write) : - ECL_NIL) - exit_status - process) -@) + if (Null(pid)) { + if (parent_write) close(parent_write); + if (parent_read) close(parent_read); + if (parent_error) close(parent_error); + parent_write = 0; + parent_read = 0; + parent_error = 0; + remove_external_process(the_env, process); + FEerror("Could not spawn subprocess to run ~S.", 1, command); + } + if (parent_write > 0) { + stream_write = ecl_make_stream_from_fd(command, parent_write, + ecl_smm_output, 8, + external_format, ECL_T); + } else { + parent_write = 0; + stream_write = cl_core.null_stream; + } + if (parent_read > 0) { + stream_read = ecl_make_stream_from_fd(command, parent_read, + ecl_smm_input, 8, + external_format, ECL_T); + } else { + parent_read = 0; + stream_read = cl_core.null_stream; + } + if (parent_error > 0) { + stream_error = ecl_make_stream_from_fd(command, parent_error, + ecl_smm_input, 8, + external_format, ECL_T); + } else { + parent_error = 0; + stream_error = cl_core.null_stream; + } + set_external_process_streams(process, stream_write, stream_read, + stream_error); + if (!Null(wait)) { + exit_status = si_external_process_wait(2, process, ECL_T); + exit_status = ecl_nth_value(the_env, 1); + } + @(return ((parent_read || parent_write)? + cl_make_two_way_stream(stream_read, stream_write) : + ECL_NIL) + exit_status + process); + @)