mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-11 07:20:29 -07:00
reader: merge back readtable.d into read.d and reader.d
This commit is contained in:
Daniel Kochmański
parent
6f22cbd27d
commit
09e8d7dd04
5 changed files with 378 additions and 410 deletions
|
|
@ -70,8 +70,8 @@ WRITER_OBJS = print.o printer/float_to_digits.o printer/float_to_string.o
|
|||
printer/write_list.o printer/write_code.o printer/write_sse.o \
|
||||
printer/print_unreadable.o
|
||||
|
||||
READER_OBJS = readtable.o reader.o read.o reader/rtab_cl.o \
|
||||
reader/parse_token.o reader/parse_integer.o reader/parse_number.o
|
||||
READER_OBJS = reader.o read.o reader/rtab_cl.o \
|
||||
reader/parse_token.o reader/parse_integer.o reader/parse_number.o
|
||||
|
||||
STREAM_OBJS = stream.o file.o streams/strm_os.o streams/strm_clos.o \
|
||||
streams/strm_string.o streams/strm_composite.o streams/strm_common.o \
|
||||
|
|
|
|||
321
src/c/read.d
321
src/c/read.d
|
|
@ -27,59 +27,6 @@
|
|||
|
||||
#define read_suppress (ecl_symbol_value(@'*read-suppress*') != ECL_NIL)
|
||||
|
||||
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 cl_object patch_sharp(const cl_env_ptr env, cl_object x);
|
||||
|
||||
cl_object
|
||||
|
|
@ -674,6 +621,274 @@ si_read_token(cl_object strm)
|
|||
ecl_return1(the_env, object);
|
||||
}
|
||||
|
||||
/* -- readtable ----------------------------------------------------- */
|
||||
|
||||
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]);
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
error_locked_readtable(cl_object r)
|
||||
{
|
||||
cl_error(2, @"Cannot modify locked readtable ~A.", r);
|
||||
}
|
||||
|
||||
cl_object
|
||||
cl_readtablep(cl_object readtable)
|
||||
{
|
||||
@(return (ECL_READTABLEP(readtable) ? ECL_T : ECL_NIL));
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_standard_readtable()
|
||||
{
|
||||
@(return cl_core.standard_readtable);
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
@(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
|
||||
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);
|
||||
}
|
||||
|
||||
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
|
||||
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].table;
|
||||
if (ECL_HASH_TABLE_P(d)) {
|
||||
d = si_copy_hash_table(d);
|
||||
}
|
||||
to_rtab[i].table = 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;
|
||||
}
|
||||
|
||||
@(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);
|
||||
@)
|
||||
|
||||
@(defun set_macro_character (c function &optional non_terminating_p
|
||||
(readtable ecl_current_readtable()))
|
||||
@
|
||||
if (readtable->readtable.locked) {
|
||||
error_locked_readtable(readtable);
|
||||
}
|
||||
ecl_readtable_set(readtable, ecl_char_code(c),
|
||||
Null(non_terminating_p)?
|
||||
cat_terminating :
|
||||
cat_non_terminating,
|
||||
function,
|
||||
ECL_NIL);
|
||||
@(return ECL_T);
|
||||
@)
|
||||
|
||||
@(defun get_macro_character (c &optional (readtable ecl_current_readtable()))
|
||||
enum ecl_chattrib cat;
|
||||
cl_object macro;
|
||||
@
|
||||
if (Null(readtable))
|
||||
readtable = cl_core.standard_readtable;
|
||||
cat = ecl_readtable_get(readtable, ecl_char_code(c), ¯o, NULL);
|
||||
@(return macro ((cat == cat_non_terminating)? ECL_T : ECL_NIL));
|
||||
@)
|
||||
|
||||
@(defun set_syntax_from_char (tochr fromchr
|
||||
&o (tordtbl ecl_current_readtable())
|
||||
fromrdtbl)
|
||||
enum ecl_chattrib cat;
|
||||
cl_object macro, table;
|
||||
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, ¯o, &table);
|
||||
if (ECL_HASH_TABLE_P(table)) {
|
||||
table = si_copy_hash_table(table);
|
||||
}
|
||||
ecl_readtable_set(tordtbl, tc, cat, macro, table);
|
||||
@(return ECL_T);
|
||||
@)
|
||||
|
||||
/* -- dispatch macro character -------------------------------------- */
|
||||
@(defun make_dispatch_macro_character
|
||||
(chr &optional non_terminating_p (readtable ecl_current_readtable()))
|
||||
enum ecl_chattrib cat;
|
||||
cl_object table;
|
||||
int c;
|
||||
@
|
||||
if (readtable->readtable.locked) {
|
||||
error_locked_readtable(readtable);
|
||||
}
|
||||
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),
|
||||
ecl_ct_default_rehash_size,
|
||||
ecl_ct_default_rehash_threshold);
|
||||
ecl_readtable_set(readtable, c, cat, cl_core.dispatch_reader, 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), NULL, &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, NULL, &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));
|
||||
@)
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
|
|
|
|||
107
src/c/reader.d
107
src/c/reader.d
|
|
@ -26,6 +26,74 @@
|
|||
#include <ecl/ecl-inl.h>
|
||||
#include <ecl/bytecodes.h>
|
||||
|
||||
int
|
||||
ecl_readtable_get(cl_object readtable, int c, cl_object *macro, cl_object *table)
|
||||
{
|
||||
cl_object m, t;
|
||||
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));
|
||||
pair = ECL_CONS_CDR(pair);
|
||||
m = ECL_CONS_CAR(pair);
|
||||
pair = ECL_CONS_CDR(pair);
|
||||
t = ECL_CONS_CAR(pair);
|
||||
}
|
||||
}
|
||||
} else
|
||||
#endif
|
||||
{
|
||||
m = readtable->readtable.table[c].macro;
|
||||
t = readtable->readtable.table[c].table;
|
||||
cat = readtable->readtable.table[c].syntax_type;
|
||||
}
|
||||
if (macro) *macro = m;
|
||||
if (table) *table = t;
|
||||
return cat;
|
||||
}
|
||||
|
||||
void
|
||||
ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat,
|
||||
cl_object macro, cl_object table)
|
||||
{
|
||||
#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),
|
||||
ecl_ct_default_rehash_size,
|
||||
ecl_ct_default_rehash_threshold);
|
||||
readtable->readtable.hash = hash;
|
||||
}
|
||||
_ecl_sethash(ECL_CODE_CHAR(c), hash,
|
||||
CONS(ecl_make_fixnum(cat),
|
||||
CONS(macro,
|
||||
CONS(table, ECL_NIL))));
|
||||
} else
|
||||
#endif
|
||||
{
|
||||
readtable->readtable.table[c].macro = macro;
|
||||
readtable->readtable.table[c].table = table;
|
||||
readtable->readtable.table[c].syntax_type = cat;
|
||||
}
|
||||
}
|
||||
|
||||
/* FIXME unicode defines a range of "safe" characters, so that there are no
|
||||
misleading pseudo-spaces in symbols and such. Investigate that. */
|
||||
bool
|
||||
ecl_invalid_character_p(int c)
|
||||
{
|
||||
return (c <= 32) || (c == 127);
|
||||
}
|
||||
|
||||
/* -- tokens ---------------------------------------------------------------- */
|
||||
|
||||
static cl_object
|
||||
ecl_make_token()
|
||||
{
|
||||
|
|
@ -52,6 +120,45 @@ si_token_escape(cl_object token)
|
|||
ecl_return1(the_env, object);
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
/* FIXME pools should be resizeable stacks. */
|
||||
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) {
|
||||
TOKEN_STRING_FILLP(string) = l+1;
|
||||
env->string_pool = CONS(string, pool);
|
||||
}
|
||||
}
|
||||
@(return);
|
||||
}
|
||||
|
||||
/* FIXME pools should be resizeable stacks. */
|
||||
cl_object
|
||||
|
|
|
|||
|
|
@ -1,354 +0,0 @@
|
|||
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
|
||||
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
|
||||
|
||||
/*
|
||||
* readtable.d - readtable implementation
|
||||
*
|
||||
* 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>
|
||||
|
||||
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].table;
|
||||
if (ECL_HASH_TABLE_P(d)) {
|
||||
d = si_copy_hash_table(d);
|
||||
}
|
||||
to_rtab[i].table = 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;
|
||||
}
|
||||
|
||||
@(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, @"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);
|
||||
}
|
||||
|
||||
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, cl_object *table)
|
||||
{
|
||||
cl_object m, t;
|
||||
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));
|
||||
pair = ECL_CONS_CDR(pair);
|
||||
m = ECL_CONS_CAR(pair);
|
||||
pair = ECL_CONS_CDR(pair);
|
||||
t = ECL_CONS_CAR(pair);
|
||||
}
|
||||
}
|
||||
} else
|
||||
#endif
|
||||
{
|
||||
m = readtable->readtable.table[c].macro;
|
||||
t = readtable->readtable.table[c].table;
|
||||
cat = readtable->readtable.table[c].syntax_type;
|
||||
}
|
||||
if (macro) *macro = m;
|
||||
if (table) *table = t;
|
||||
return cat;
|
||||
}
|
||||
|
||||
void
|
||||
ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat,
|
||||
cl_object macro, cl_object 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),
|
||||
ecl_ct_default_rehash_size,
|
||||
ecl_ct_default_rehash_threshold);
|
||||
readtable->readtable.hash = hash;
|
||||
}
|
||||
_ecl_sethash(ECL_CODE_CHAR(c), hash,
|
||||
CONS(ecl_make_fixnum(cat),
|
||||
CONS(macro,
|
||||
CONS(table, ECL_NIL))));
|
||||
} else
|
||||
#endif
|
||||
{
|
||||
readtable->readtable.table[c].macro = macro;
|
||||
readtable->readtable.table[c].table = table;
|
||||
readtable->readtable.table[c].syntax_type = cat;
|
||||
}
|
||||
}
|
||||
|
||||
/* FIXME unicode defines a range of "safe" characters, so that there are no
|
||||
misleading pseudo-spaces in symbols and such. Investigate that. */
|
||||
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 macro, table;
|
||||
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, ¯o, &table);
|
||||
if (ECL_HASH_TABLE_P(table)) {
|
||||
table = si_copy_hash_table(table);
|
||||
}
|
||||
ecl_readtable_set(tordtbl, tc, cat, macro, table);
|
||||
@(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,
|
||||
ECL_NIL);
|
||||
@(return ECL_T);
|
||||
@)
|
||||
|
||||
@(defun get_macro_character (c &optional (readtable ecl_current_readtable()))
|
||||
enum ecl_chattrib cat;
|
||||
cl_object macro;
|
||||
@
|
||||
if (Null(readtable))
|
||||
readtable = cl_core.standard_readtable;
|
||||
cat = ecl_readtable_get(readtable, ecl_char_code(c), ¯o, NULL);
|
||||
@(return macro ((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),
|
||||
ecl_ct_default_rehash_size,
|
||||
ecl_ct_default_rehash_threshold);
|
||||
ecl_readtable_set(readtable, c, cat, cl_core.dispatch_reader, 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), NULL, &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, NULL, &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);
|
||||
@)
|
||||
|
|
@ -679,7 +679,7 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock);
|
|||
cl_fixnum limit, __ecl_high; \
|
||||
for(__ecl_idx = 0; __ecl_idx <= __ecl_ndx; __ecl_idx+=2) { \
|
||||
if (__ecl_idx == __ecl_ndx) { \
|
||||
limit = __ecl_high = ecl_length(string); \
|
||||
limit = __ecl_high = TOKEN_STRING_FILLP(string); \
|
||||
} else { \
|
||||
limit = ecl_fixnum(__ecl_v[__ecl_idx]); \
|
||||
__ecl_high = ecl_fixnum(__ecl_v[__ecl_idx+1]); \
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue