gcl.git - GNU Common Lisp

diff --git a/gcl/configure b/gcl/configure
index 6ea12fb8c..d0c505716 100755
--- a/gcl/configure
+++ b/gcl/configure

@@ -7273,7 +7273,7 @@ _ACEOF

else

cat >>confdefs.h <<_ACEOF

-#define OBJNULL NULL

+#define OBJNULL (object)(2*CHCODELIM)

_ACEOF

fi

diff --git a/gcl/configure.in b/gcl/configure.in
index 855ae25f0..8703361e3 100644
--- a/gcl/configure.in
+++ b/gcl/configure.in

@@ -1773,7 +1773,7 @@ if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(

AC_DEFINE_UNQUOTED(LOW_SHFT,$low_shft,[upper immediate fixnum bound])

AC_DEFINE_UNQUOTED(OBJNULL,(object)0x$j,[lowest address non-object])

else

- AC_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object])

+ AC_DEFINE_UNQUOTED(OBJNULL,(object)(2*CHCODELIM),[lowest address non-object])

fi

# echo $j;

diff --git a/gcl/h/compdefs.h b/gcl/h/compdefs.h
index 79318aa30..184f2658a 100644
--- a/gcl/h/compdefs.h
+++ b/gcl/h/compdefs.h

@@ -114,3 +114,4 @@ stp_ordinary

SIGNED_CHAR(x)

FEerror(x,y...)

FEwrong_type_argument(x,y)

+CHCODELIM

diff --git a/gcl/h/globals.h b/gcl/h/globals.h
index 1eb16fd9a..0d914aaba 100644
--- a/gcl/h/globals.h
+++ b/gcl/h/globals.h

@@ -1,5 +1,5 @@

-EXTER union lispunion Cnil_body OBJ_ALIGN;

-EXTER union lispunion Ct_body OBJ_ALIGN;

+EXTER union lispunion Cnil_body __attribute__ ((aligned (8192)));

+EXTER union lispunion Ct_body __attribute__ ((aligned (8192)));

struct call_data {

object fun;

@@ -10,8 +10,6 @@ struct call_data {

};

EXTER struct call_data fcall;

-EXTER union lispunion character_table1[256+128] OBJ_ALIGN;

-

EXTER object Cstd_key_defaults[15];

EXTER char *alloca_val;

EXTER object keyword_package;

diff --git a/gcl/h/object.h b/gcl/h/object.h
index f3c37ee2b..93446769c 100755
--- a/gcl/h/object.h
+++ b/gcl/h/object.h

@@ -238,10 +238,10 @@ struct rtent { /* read table entry */

/* struct character character_table1[256+128]; */

#define character_table (character_table1+128)

-#define code_char(c) (object)(character_table+((unsigned char)(c)))

-#define char_code(obje) ((object)obje)->ch.ch_code

-#define char_font(obje) ((object)obje)->ch.ch_font

-#define char_bits(obje) ((object)obje)->ch.ch_bits

+/* #define code_char(c) (object)(character_table+((unsigned char)(c))) */

+/* #define char_code(obje) ((object)obje)->ch.ch_code */

+#define char_font(obje) (0)/* ((object)obje)->ch.ch_font */

+#define char_bits(obje) (0)/* ((object)obje)->ch.ch_bits */

#define address_int unsigned long

@@ -514,7 +514,7 @@ EXTER unsigned plong signals_allowed, signals_pending;

#define proper_list(a) (type_of(a)==t_cons || (a)==Cnil)

-#define IMMNIL(x) (is_imm_fixnum(x)||x==Cnil)

+#define IMMNIL(x) (is_imm_fixnum(x)||is_imm_character(x)||x==Cnil)

#define eql(a_,b_) ({register object _a=(a_);register object _b=(b_);_a==_b || (!IMMNIL(_a)&&!IMMNIL(_b)&&eql1(_a,_b));})

#define equal(a_,b_) ({register object _a=(a_);register object _b=(b_);_a==_b || (!IMMNIL(_a)&&!IMMNIL(_b)&&equal1(_a,_b));})

diff --git a/gcl/h/type.h b/gcl/h/type.h
index ba3072af1..55849bb01 100644
--- a/gcl/h/type.h
+++ b/gcl/h/type.h

@@ -36,17 +36,21 @@ enum type {

};

+#include "character.h"

+

+#define immp(a_) ((((ufixnum)(a_))-2*CHCODELIM)>=(IM_FIX_BASE-2*CHCODELIM))

+

#define Zcdr(a_) (*(object *)(a_))/* ((a_)->c.c_cdr) */ /*FIXME*/

#ifndef WIDE_CONS

#ifndef USE_SAFE_CDR

#define SAFE_CDR(a_) a_

-#define imcdr(a_) is_imm_fixnum(Zcdr(a_))

+#define imcdr(a_) immp(Zcdr(a_))/* (is_imm_fixnum(Zcdr(a_))||is_imm_character(Zcdr(a_)))FIXME */

#else

-#define SAFE_CDR(a_) ({object _a=(a_);is_imm_fixnum(_a) ? make_fixnum1(fix(_a)) : _a;})

+#define SAFE_CDR(a_) ({object _a=(a_);is_imm_fixnum(_a) ? make_fixnum1(fix(_a)) : (is_imm_character(Zcdr(a_)) ? make_character1(char_code(a_)) : _a);})

#ifdef DEBUG_SAFE_CDR

-#define imcdr(a_) (is_imm_fixnum(Zcdr(a_)) && (error("imfix cdr"),1))

+#define imcdr(a_) ((is_imm_fixnum(Zcdr(a_))||is_imm_character(Zcdr(a_))) && (error("imfix cdr"),1))

#else

#define imcdr(a_) 0

#endif

@@ -59,23 +63,32 @@ enum type {

#endif

-#define is_marked(a_) (imcdr(a_) ? is_marked_imm_fixnum(Zcdr(a_)) : (a_)->d.m)

-#define is_marked_or_free(a_) (imcdr(a_) ? is_marked_imm_fixnum(Zcdr(a_)) : (a_)->md.mf)

-#define mark(a_) if (imcdr(a_)) mark_imm_fixnum(Zcdr(a_)); else (a_)->d.m=1

-#define unmark(a_) if (imcdr(a_)) unmark_imm_fixnum(Zcdr(a_)); else (a_)->d.m=0

-#define is_free(a_) (!is_imm_fixnum(a_) && !imcdr(a_) && (a_)->d.f)

-#define make_free(a_) ({(a_)->fw=0;(a_)->d.f=1;(a_)->fw|=(fixnum)OBJNULL;})/*set_type_of(a_,t_other)*/

+#define imm_mark_bit(a_) ((((fixnum)(a_))<0) ? IM_FIX_LIM : CHCODELIM)

+#define imm_bit_op(a_,b_) ({ufixnum _a=(ufixnum)(a_);_a b_ imm_mark_bit(_a);})

+#define is_marked_imm(a_) imm_bit_op(a_,&)

+#define mark_imm(a_) ((a_)=((object)imm_bit_op(a_,|)))

+#define unmark_imm(a_) ((a_)=((object)imm_bit_op(a_,&~)))

+

+#define is_marked(a_) (imcdr(a_) ? is_marked_imm(Zcdr(a_)) : (a_)->d.m)/*(is_marked_imm_fixnum(Zcdr(a_))||is_marked_imm_character(Zcdr(a_)))*/

+#define is_marked_or_free(a_) (imcdr(a_) ? is_marked_imm(Zcdr(a_)) : (a_)->md.mf)

+#define mark(a_) if (imcdr(a_)) mark_imm(Zcdr(a_)); else (a_)->d.m=1

+#define unmark(a_) if (imcdr(a_)) unmark_imm(Zcdr(a_)); else (a_)->d.m=0

+#define is_free(a_) (!immp(a_) && !imcdr(a_) && (a_)->d.f)

+#define make_free(a_) ({(a_)->fw=0;(a_)->d.f=1;(a_)->d.st=1;})/*(a_)->fw|=(fixnum)OBJNULL;*//*set_type_of(a_,t_other)*/

#define make_unfree(a_) {(a_)->d.f=0;}

#ifdef WIDE_CONS

#define valid_cdr(a_) 0

#else

-#define valid_cdr(a_) (!(a_)->d.e || imcdr(a_))

+#define valid_cdr(a_) !typeword_p(Zcdr(a_))/* (!(a_)->d.e || imcdr(a_)) */

#endif

-#define type_of(x) ({register object _z=(object)(x);\

- (is_imm_fixnum(_z) ? t_fixnum : \

- (valid_cdr(_z) ? (_z==Cnil ? t_symbol : t_cons) : _z->d.t));})

+#define typeword_p(a_) (((((ufixnum)(a_))^IM_FIX_BASE)&(IM_FIX_BASE|(1<<13)|1))==(IM_FIX_BASE|(1<<13)|1))

+

+#define type_of(x) ({register object _z=(object)(x); \

+ (immp(_z) ? (((fixnum)(_z))>=0 ? t_character : t_fixnum) : \

+ (typeword_p(_z->fw) ? _z->d.t : (_z==Cnil ? t_symbol : t_cons)));})

+ /* (valid_cdr(_z) ? (_z==Cnil ? t_symbol : t_cons) : _z->d.t));}) */

#ifdef WIDE_CONS

#define TYPEWORD_TYPE_P(y_) 1

@@ -85,17 +98,17 @@ enum type {

/*Note preserve sgc flag here VVV*/

#define set_type_of(x,y) ({object _x=(object)(x);enum type _y=(y);_x->d.f=0;\

- if (TYPEWORD_TYPE_P(_y)) {_x->d.e=1;_x->d.t=_y;_x->fw|=(fixnum)OBJNULL;}})

+ if (TYPEWORD_TYPE_P(_y)) {_x->d.e=1;_x->d.t=_y;_x->d.st=1;}})/*_x->fw|=(fixnum)OBJNULL;*/

#ifndef WIDE_CONS

#define cdr_listp(x) valid_cdr(x)

#define consp(x) ({register object _z=(object)(x);\

- (!is_imm_fixnum(_z) && valid_cdr(_z) && _z!=Cnil);})

+ (!immp(_z) && valid_cdr(_z) && _z!=Cnil);})

#define listp(x) ({register object _z=(object)(x);\

- (!is_imm_fixnum(_z) && valid_cdr(_z));})

+ (!immp(_z) && valid_cdr(_z));})

#define atom(x) ({register object _z=(object)(x);\

- (is_imm_fixnum(_z) || !valid_cdr(_z) || _z==Cnil);})

+ (immp(_z) || !valid_cdr(_z) || _z==Cnil);})

#else

diff --git a/gcl/o/character.d b/gcl/o/character.d
index 7f714dc60..a26c18dc5 100755
--- a/gcl/o/character.d
+++ b/gcl/o/character.d

@@ -387,9 +387,9 @@ BEGIN:

if (fix(b) == 0 && fix(f) == 0)

@(return `code_char(fix(c))`)

x = alloc_object(t_character);

- char_code(x) = fix(c);

- char_bits(x) = fix(b);

- char_font(x) = fix(f);

+ x->ch.ch_code = fix(c);

+ x->ch.ch_bits = fix(b);

+ x->ch.ch_font = fix(f);

@(return x)

@)

@@ -410,9 +410,9 @@ BEGIN:

if (fix(b) == 0 && fix(f) == 0)

@(return `code_char(code)`)

x = alloc_object(t_character);

- char_code(x) = code;

- char_bits(x) = fix(b);

- char_font(x) = fix(f);

+ x->ch.ch_code = code;

+ x->ch.ch_bits = fix(b);

+ x->ch.ch_font = fix(f);

@(return x)

@)

@@ -474,9 +474,9 @@ int w, r;

if (fix(f) == 0)

@(return `code_char(dw)`)

x = alloc_object(t_character);

- char_code(x) = dw;

- char_bits(x) = 0;

- char_font(x) = fix(f);

+ x->ch.ch_code = dw;

+ x->ch.ch_bits = 0;

+ x->ch.ch_font = fix(f);

@(return x)

@)

@@ -506,11 +506,11 @@ int w, r;

@(return Cnil)

if (b == 0 && f == 0)

@(return `code_char(c)`)

- x = alloc_object(t_character);

- char_code(x) = c;

- char_bits(x) = b;

- char_font(x) = f;

- @(return x)

+ /* x = alloc_object(t_character); */

+ /* char_code(x) = c; */

+ /* char_bits(x) = b; */

+ /* char_font(x) = f; */

+ @(return Cnil)

@)

@(defun char_name (c)

@@ -578,25 +578,6 @@ int w, r;

void

gcl_init_character()

{

- int i;

-

- for (i = 0; i < CHCODELIM; i++) {

- object x=(object)(character_table+i);

- x->fw=0;

- set_type_of(x,t_character);

- /* character_table[i].ch.t = (short)t_character; */

- character_table[i].ch.ch_code = i;

- character_table[i].ch.ch_font = 0;

- character_table[i].ch.ch_bits = 0;

- }

-#ifdef AV

- for (i = -128; i < 0; i++) {

- character_table[i].ch.t = (short)t_character;

- character_table[i].ch.ch_code = i+CHCODELIM;

- character_table[i].ch.ch_font = 0;

- character_table[i].ch.ch_bits = 0;

- }

-#endif

make_constant("CHAR-CODE-LIMIT", make_fixnum(CHCODELIM));

make_constant("CHAR-FONT-LIMIT", make_fixnum(CHFONTLIM));

diff --git a/gcl/o/format.c b/gcl/o/format.c
index 2816acbb5..04969fb38 100755
--- a/gcl/o/format.c
+++ b/gcl/o/format.c

@@ -334,7 +334,7 @@ LOOP:

fmt_param[n].fmt_param_value = fix(x);

} else if (type_of(x) == t_character) {

fmt_param[n].fmt_param_type = fmt_char;

- fmt_param[n].fmt_param_value = x->ch.ch_code;

+ fmt_param[n].fmt_param_value = char_code(x);

} else if (x == Cnil) {

fmt_param[n].fmt_param_type = fmt_null;

} else

diff --git a/gcl/o/read.d b/gcl/o/read.d
index f00a77af9..46fae3e85 100755
--- a/gcl/o/read.d
+++ b/gcl/o/read.d

@@ -603,7 +603,7 @@ BEGIN:

});

a = cat(c);

} while (a == cat_whitespace);

- if (c->ch.ch_code == '(') { /* Loose package extension */

+ if (char_code(c) == '(') { /* Loose package extension */

LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */

if (LP) {

if (PP0-P0>=MAX_PACKAGE_STACK)

@@ -613,7 +613,7 @@ BEGIN:

}

} else if (LP)

FEerror("Loose package prefix must be followed by a list",0);

- if (c->ch.ch_code==')' && PP0>P0) PP0--; /* regardless of error behavior,

+ if (char_code(c)==')' && PP0>P0) PP0--; /* regardless of error behavior,

will pop stack to beginning as parens

must match before the reader starts */

delimiting_char = vs_head;

diff --git a/gcl/o/sequence.d b/gcl/o/sequence.d
index 270046f2a..e70b93ebf 100755
--- a/gcl/o/sequence.d
+++ b/gcl/o/sequence.d

@@ -159,7 +159,7 @@ object val;

goto E;

if (type_of(val) != t_character)

FEwrong_type_argument(sLcharacter, val);

- seq->st.st_self[index] = val->ch.ch_code;

+ seq->st.st_self[index] = char_code(val);

return(val);

default: