mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 01:10:53 -07:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/c/reader/rtab_cl.d
Daniel Kochmański b6ac33834f reader: honor *read-suppress* in #\foo:bar reader
2026-03-07 22:42:12 +01:00

994 lines
31 KiB
C
Raw Blame History

/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
* rtab_cl.d -- readtable for Common Lisp + ECL extensions
*
* 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 <ecl/ecl.h>
#include <ecl/ecl-inl.h>
#include <ecl/number.h>
#include <ecl/internal.h>
#include <ecl/bytecodes.h>
#define read_suppress (ecl_symbol_value(@'*read-suppress*') != ECL_NIL)
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 ecl_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 && !read_suppress)
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);
unlikely_if (read_suppress)
@(return ECL_NIL);
#if 0
@(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), ECL_NIL));;
#else
@(return cl_list(2,@'si::quasiquote',c));
#endif
}
static void
read_string_into_buffer(cl_object in, cl_object c, cl_object buffer)
{
int delim = ECL_CHAR_CODE(c);
cl_object rtbl = ecl_current_readtable();
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(buffer, c);
}
}
static cl_object
double_quote_reader(cl_object in, cl_object c)
{
cl_object output;
cl_object token = si_get_buffer_string();
read_string_into_buffer(in, c, token);
/* Must be kept a SIMPLE-STRING, meaning a (SIMPLE-ARRAY CHARACTERS
* (*)), see CLHS 2.4.5. We thus can't coerce to a BASE-STRING. */
output = cl_copy_seq(token);
si_put_buffer_string(token);
@(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));
}
static cl_object
sharp_double_quote_reader(cl_object in, cl_object c, cl_object d)
{
/* Base string reader. Used for data in compiled files. */
cl_object s, token;
if (d != ECL_NIL && !read_suppress)
extra_argument('"', in, d);
token = si_get_buffer_string();
read_string_into_buffer(in, c, token);
s = si_copy_to_simple_base_string(token);
si_put_buffer_string(token);
if (read_suppress)
@(return ECL_NIL);
@(return s);
}
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_reader3(cl_object in, cl_object c, cl_object f)
{
/* 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, string;
bool suppress = read_suppress;
if (d != ECL_NIL && !suppress) {
unlikely_if (!ECL_FIXNUMP(d) || d != ecl_make_fixnum(0)) {
FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d);
}
}
if(suppress) {
ecl_read_token(in, 1);
return ECL_NIL;
}
token = ecl_read_token(in, 1);
string = token->token.string;
if (TOKEN_STRING_FILLP(string) == 1) {
c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(string,0));
} else if (TOKEN_STRING_FILLP(string) == 2 && TOKEN_STRING_CHAR_CMP(string,0,'^')) {
/* #\^x */
c = ECL_CODE_CHAR(TOKEN_STRING_CHAR(string,1) & 037);
} else {
cl_object nc = cl_name_char(string);
unlikely_if (Null(nc)) {
FEreader_error("~S is an illegal character name.", in, 1, string);
}
c = nc;
}
ecl_put_reader_token(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;
nth = ECL_CONS_CAR(x);
x = ECL_CONS_CDR(x);
rv->bytecodes.flex = nth;
nth = ECL_CONS_CAR(x);
x = ECL_CONS_CDR(x);
rv->bytecodes.nlcl = 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 = ecl_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 */
ecl_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, ecl_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);
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) {
ecl_read_constituent(in, 1);
@(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->run_stack.org[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;
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);
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;
} else if (a == cat_multiple_escape) {
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 the_env = ecl_process_env();
if (d != ECL_NIL && !read_suppress)
extra_argument('.', in, d);
c = ecl_read_eval(in);
ecl_return1(the_env, c);
}
static cl_object
read_number(cl_object in, int radix, cl_object macro_char)
{
cl_index i;
cl_object x;
/* ecl_read_constituent is called with not_first=true, because we are called
by reader macros for composite tokens, like #x123. -- jd 2024-05-12 */
cl_object token = ecl_read_constituent(in, 1);
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'))));
}
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);
}
}
#define sharp_plus_reader void_reader3
#define sharp_minus_reader void_reader3
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);
}
/*
#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);
}
#define make_cf2(f) ecl_make_cfun((cl_objectfn_fixed)(f), ECL_NIL, NULL, 2)
#define make_cf3(f) ecl_make_cfun((cl_objectfn_fixed)(f), ECL_NIL, NULL, 3)
void
init_read(void)
{
struct ecl_readtable_entry *rtab;
cl_object r, r_cmp;
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(ecl_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_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;
r_cmp = ecl_copy_readtable(cl_core.standard_readtable, ECL_NIL);
/* This is specific to this implementation: syntax for base strings */
cl_set_dispatch_macro_character(4, ECL_CODE_CHAR('#'), ECL_CODE_CHAR('"'),
make_cf3(sharp_double_quote_reader), r_cmp);
cl_core.compiler_readtable = r_cmp;
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**/ @'base-string', /* base string syntax */
/**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.compiler_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));
}
}
Reference in a new issue View git blame Copy permalink