mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-26 06:22:33 -08:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/c/read.d
Daniel Kochmański f78cb49def complex float: rename cl_lispunion member complex to gencomplex 
Complex is a macro specified in complex.h for c99 to simplify using
_Complex type. This file also contains functions to work on complex
floats. To avoid conflicts we rename internal name complex to
gencomplex and update all references to it.
2019-05-06 08:17:33 +02:00

2475 lines
73 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
* 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 <ecl/ecl.h>
#include <ecl/number.h>
#include <assert.h> /* for assert() */
#include <stdio.h>
#include <limits.h>
#include <float.h>
#include <string.h>
#include <stdlib.h>
#include <ecl/internal.h>
#include <ecl/ecl-inl.h>
#include <ecl/bytecodes.h>
#undef _complex
static cl_object dispatch_macro_character(cl_object table, cl_object strm, int c, bool signal_error);
#define read_suppress (ecl_symbol_value(@'*read-suppress*') != ECL_NIL)
#ifdef ECL_UNICODE
# define TOKEN_STRING_DIM(s) ((s)->string.dim)
# define TOKEN_STRING_FILLP(s) ((s)->string.fillp)
# define TOKEN_STRING_CHAR(s,n) ((s)->string.self[n])
# define TOKEN_STRING_CHAR_SET(s,n,c) (s)->string.self[n]=(c)
# define TOKEN_STRING_CHAR_CMP(s,n,c) ((s)->string.self[n]==(c))
#else
# define TOKEN_STRING_DIM(s) ((s)->base_string.dim)
# define TOKEN_STRING_FILLP(s) ((s)->base_string.fillp)
# define TOKEN_STRING_CHAR(s,n) ((s)->base_string.self[n])
# define TOKEN_STRING_CHAR_SET(s,n,c) ((s)->base_string.self[n]=(c))
# define TOKEN_STRING_CHAR_CMP(s,n,c) ((s)->base_string.self[n]==(c))
#endif
#define ECL_READ_ONLY_TOKEN 1
#define ECL_READ_RETURN_IGNORABLE 3
#define ECL_READ_LIST_DOT 4
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) {
#ifdef ECL_UNICODE
output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE);
#else
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);
}
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 0
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);
#else
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);
}
static void extra_argument (int c, cl_object stream, cl_object d);
static cl_object patch_sharp(const cl_env_ptr env, cl_object x);
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();
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;
}
/*
* This routine inverts the case of the characters in the buffer which
* were not escaped. ESCAPE_LIST is a list of intevals of characters
* that were escaped, as in ({(low-limit . high-limit)}*). The list
* goes from the last interval to the first one, in reverse order,
* and thus we run the buffer from the end to the beginning.
*/
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);
}
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;
}
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)) {
if (suppress) {
o = dispatch_macro_character(x, in, c, FALSE);
if (o == OBJNULL)
goto BEGIN;
} else {
o = dispatch_macro_character(x, in, c, TRUE);
}
} 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 (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;
/* 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;
SYMBOL:
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) {
FEreader_error("Cannot find the external symbol ~A in ~S.", in,
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;
}
/*
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);
}
cl_object
si_read_object_or_ignore(cl_object in, cl_object eof)
{
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;
}
static cl_object
right_parenthesis_reader(cl_object in, cl_object character)
{
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));
}
/*
* BACKQUOTE READER
*/
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*'));
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);
#if 0
@(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL));;
#else
@(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*.
*/
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;
}
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);
}
/* 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, TRUE);
}
/*
Returns OBJNULL if no dispatch function is defined and signal_error
is false
*/
static cl_object
dispatch_macro_character(cl_object table, cl_object in, int c, bool signal_error)
{
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)) {
if (signal_error) {
FEreader_error("No dispatch function defined "
"for character ~S",
in, 1, dc);
} else {
return OBJNULL;
}
}
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));
}
static cl_object
void_reader(cl_object in, cl_object c)
{
/* no result */
@(return);
}
static cl_object
semicolon_reader(cl_object in, cl_object c)
{
int auxc;
do
auxc = ecl_read_char(in);
while (auxc != '\n' && auxc != EOF);
/* no result */
@(return);
}
/*
sharpmacro routines
*/
static cl_object
sharp_generic_error(cl_object in, cl_object c, cl_object n)
{
FEreader_error("The character ~:C is not a valid dispatch macro character",
in, 1, c);
}
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;
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->gencomplex.real = real;
x->gencomplex.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);
}
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);
}
static cl_object
sharp_Y_reader(cl_object in, cl_object c, cl_object d)
{
cl_index i;
cl_object x, rv, nth, lex;
if (d != ECL_NIL && !read_suppress)
extra_argument('Y', 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);
}
rv = ecl_alloc_object(t_bytecodes);
rv->bytecodes.name = 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);
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;
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;
if (lex != ECL_NIL) {
cl_object x = ecl_alloc_object(t_bclosure);
x->bclosure.code = rv;
x->bclosure.lex = lex;
x->bclosure.entry = _ecl_bclosure_dispatch_vararg;
rv = x;
}
@(return rv);
}
#define QUOTE 1
#define EVAL 2
#define LIST 3
#define LISTX 4
#define APPEND 5
#define NCONC 6
/*
*----------------------------------------------------------------------
* Stack of unknown size
*----------------------------------------------------------------------
*/
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);
}
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);
}
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_fixnum 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);
}
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;
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);
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);
} else if (c == ':' && !read_suppress) {
FEreader_error("An uninterned symbol must not contain a package prefix", in, 0);
}
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);
}
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);
}
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;
}
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'))));
}
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'))));
}
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'))));
}
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'))));
}
#define sharp_A_reader void_reader
#define sharp_S_reader void_reader
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*');
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;
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)
{
/* The hash table maintains an association as follows:
*
* [1] object -> itself
* The object has been processed by patch_sharp, use 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 might
* or might not yet be processed by do_patch_sharp().
*/
/* If x is a list, it is processed iteratively. For this, we store
* the first and current cons cell */
cl_object first_cons = OBJNULL;
cl_object current_cons = OBJNULL;
AGAIN:
switch (ecl_t_of(x)) {
case t_list: {
cl_object y;
if (Null(x))
return (first_cons ? first_cons : x);
y = ecl_gethash_safe(x, table, table);
if (y == table) {
/* case [2] */
if (first_cons == OBJNULL)
first_cons = x;
break;
} else if (y == x) {
/* case [1] */
return (first_cons ? first_cons : x);
} else {
/* case [3] */
x = y;
if (current_cons != OBJNULL)
ECL_RPLACD(current_cons, x);
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 (first_cons ? first_cons : 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:
current_cons = x;
ECL_RPLACA(x, do_patch_sharp(ECL_CONS_CAR(x), table));
cl_object rest = ECL_CONS_CDR(x);
if (ecl_t_of(rest) == t_list) {
x = rest;
goto AGAIN;
} else {
ECL_RPLACD(x, do_patch_sharp(rest, 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->gencomplex.real, table);
cl_object i = do_patch_sharp(x->gencomplex.imag, table);
if (r != x->gencomplex.real || i != x->gencomplex.imag) {
cl_object c = ecl_make_complex(r, i);
x->gencomplex = c->gencomplex;
}
break;
}
case t_bclosure: {
x->bclosure.lex = do_patch_sharp(x->bclosure.lex, table);
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 (first_cons ? first_cons : x);
}
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);
}
}
#define sharp_plus_reader void_reader
#define sharp_minus_reader void_reader
#define sharp_less_than_reader void_reader
#define sharp_whitespace_reader void_reader
#define sharp_right_parenthesis_reader void_reader
static cl_object
sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d)
{
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;
}
}
/* 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);
}
/*
#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);
}
/*
#$ 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);
}
/*
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]);
}
}
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;
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;
}
#endif
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;
/* 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;
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;
/* 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';
#else
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);
}
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;
}
@(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);
@)
@(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);
@)
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);
}
@(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);
@)
@(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);
#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(value0) && !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 {
#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)--;
#endif
#ifdef ECL_NEWLINE_IS_LFCR /* From \n\r, ignore \r */
ecl_read_char(strm);
#endif
value0 = cl_copy_seq(token);
value1 = (c == EOF? ECL_T : ECL_NIL);
}
si_put_buffer_string(token);
OUTPUT:
@(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);
@)
@(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);
@)
@(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);
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);
@)
@(defun listen (&optional (strm 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);
#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);
}
#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);
}
@)
@(defun clear_input (&optional (strm 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);
@)
@(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
#endif
@(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);
@)
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);
}
static void
error_locked_readtable(cl_object r)
{
cl_error(2,
ecl_make_constant_base_string("Cannot modify locked readtable ~A.",-1),
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);
}
cl_object
cl_readtablep(cl_object readtable)
{
@(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;
#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
#endif
{
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)
{
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
#endif
{
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);
}
@(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);
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);
@)
@(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));
@)
@(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);
@)
@(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);
@)
@(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);
/* 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);
}
@(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);
@)
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));
}
#define make_cf2(f) ecl_make_cfun((f), ECL_NIL, NULL, 2)
#define make_cf3(f) ecl_make_cfun((f), ECL_NIL, NULL, 3)
void
init_read(void)
{
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;
}
#ifdef ECL_UNICODE
r->readtable.hash = ECL_NIL;
#endif
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, '"', 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);
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_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);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\b'),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\t'),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_NEWLINE),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_LINEFEED),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('\f'),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(ECL_CHAR_CODE_RETURN),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(' '),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR(')'),
make_cf3(sharp_generic_error), r);
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('<'),
make_cf3(sharp_generic_error), 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);
#endif
/* Lock the standard read table so that we do not have to make copies
* to keep it unchanged */
r->readtable.locked = 1;
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');
{
cl_object var, val;
var = cl_list(25,
@'*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::*print-package*',
@'si::*print-structure*',
@'si::*sharp-eq-context*',
@'si::*circle-counter*');
val = cl_list(25,
/**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,
/**package**/ cl_core.lisp_package,
/*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));
}
}
/*
*----------------------------------------------------------------------
*
* ecl_init_module --
* reads the data vector from stream into vector VV
*
* Results:
* a vector.
*
*----------------------------------------------------------------------
*/
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');
#else
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));
}
}
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;
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;
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;
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;
#else
VV = block->cblock.data;
#endif
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));
/* Read all data for the library */
#ifdef ECL_EXTERNALIZABLE
{
unlikely_if (block->cblock.data_text == NULL) {
unlikely_if (len > 0)
FEreader_error("Not enough data while loading"
"binary file", in, 0);
} else {
cl_object v = si_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, perm_len * sizeof(cl_object));
memcpy(VVtemp, v->vector.self.t + perm_len, temp_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;
#endif
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_THREAD_SAFE_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_THREAD_SAFE_END;
return block;
}
Reference in a new issue View git blame Copy permalink