/src/io.d

Large files files are truncated, but you can click here to view the full file

/*
 * Input/Output for CLISP
 * Bruno Haible 1990-2005
 * Marcus Daniels 11.3.1997
 * Sam Steingold 1998-2008
 * German comments translated into English: Stefan Kain 2001-06-12
 */

#include "lispbibl.c"
#include "arilev0.c" /* for Division in pr_uint */

/* IO_DEBUG must be undefined in the code comitted to CVS */
/* #define IO_DEBUG 0 */
#ifdef IO_DEBUG
#define PPH_OUT(label,stream)                   \
  do { printf(#label "[%d]: [",__LINE__);       \
    nobject_out(stdout,stream);                 \
    printf("]\n"); } while(0)
#else
#define PPH_OUT(l,s)
#endif

/* ========================================================================
   Readtable-functions
   ======================================================================== */

/* Maximum size of linear per-character arrays. */
#define small_char_code_limit 0x100UL

/* Tables indexed by characters.
 allocate_perchar_table()
 perchar_table_get(table,c)
 perchar_table_put(table,c,value)
 copy_perchar_table(table) */
#if (small_char_code_limit < char_code_limit)
 /* A simple-vector of small_char_code_limit+1 elements, the last entry being
  a hash table for the non-base characters. */
local object allocate_perchar_table (void) {
  /* Allocate the hash table.
   (MAKE-HASH-TABLE :KEY-TYPE 'CHARACTER
                    :VALUE-TYPE '(OR FUNCTION SIMPLE-VECTOR)
                    :TEST 'FASTHASH-EQ :WARN-IF-NEEDS-REHASH-AFTER-GC T) */
  pushSTACK(S(Ktest)); pushSTACK(S(fasthash_eq));
  pushSTACK(S(Kwarn_if_needs_rehash_after_gc)); pushSTACK(T);
  funcall(L(make_hash_table),4);
  pushSTACK(value1);
  /* Allocate the simple-vector. */
  var object table = allocate_vector(small_char_code_limit+1);
  TheSvector(table)->data[small_char_code_limit] = popSTACK();
  return table;
}
local object perchar_table_get (object table, chart c) {
  if (as_cint(c) < small_char_code_limit) {
    return TheSvector(table)->data[as_cint(c)];
  } else {
    var object value = gethash(code_char(c),
                               TheSvector(table)->data[small_char_code_limit],
                               false);
    return (eq(value,nullobj) ? NIL : value);
  }
}
local void perchar_table_put (object table, chart c, object value) {
  if (as_cint(c) < small_char_code_limit) {
    TheSvector(table)->data[as_cint(c)] = value;
  } else {
    shifthash(TheSvector(table)->data[small_char_code_limit],
              code_char(c),value,true);
  }
}
local object copy_perchar_table (object table) {
  pushSTACK(copy_svector(table));
  /* Allocate a new hash table.
   (MAKE-HASH-TABLE :KEY-TYPE 'CHARACTER
                    :VALUE-TYPE '(OR FUNCTION SIMPLE-VECTOR)
                    :TEST 'FASTHASH-EQ :WARN-IF-NEEDS-REHASH-AFTER-GC T) */
  pushSTACK(S(Ktest)); pushSTACK(S(fasthash_eq));
  pushSTACK(S(Kwarn_if_needs_rehash_after_gc)); pushSTACK(T);
  funcall(L(make_hash_table),4);
  pushSTACK(value1);
  /* stack layout: table, newht. */
  map_hashtable(TheSvector(STACK_1)->data[small_char_code_limit],
                key,value,{ shifthash(STACK_(0+1),key,value,true); });
  var object newht = popSTACK();
  var object table1 = popSTACK();
  TheSvector(table1)->data[small_char_code_limit] = newht;
  return table1;
}
#else
 /* A simple-vector of char_code_limit elements. */
#define allocate_perchar_table()  allocate_vector(char_code_limit)
#define perchar_table_get(table,c)  TheSvector(table)->data[(uintP)as_cint(c)]
#define perchar_table_put(table,c,value)  (TheSvector(table)->data[(uintP)as_cint(c)] = (value))
#define copy_perchar_table(table)  copy_svector(table)
#endif

/* Structure of Readtables (cf. LISPBIBL.D):
   readtable_syntax_table
      bitvector consisting of char_code_limit bytes: for each character the
                                                     syntaxcode is assigned
   readtable_macro_table
      a vector with char_code_limit elements: for each character
      either    (if the character is not a read-macro)
                NIL
      or        (if the character is a dispatch-macro)
                a vector with char_code_limit functions/NILs,
      or        (if the character is a read-macro defined by a function)
                the function, which is called, when the character is read.
   readtable_case
      a fixnum in {0,1,2,3}

 meaning of case (in sync with CONSTOBJ.D!): */
#define case_upcase    0
#define case_downcase  1
#define case_preserve  2
#define case_invert    3

/* meaning of the entries in the syntax_table: */
#define syntax_illegal      0   /* unprintable, excluding whitespace */
#define syntax_single_esc   1   /* '\' (Single Escape) */
#define syntax_multi_esc    2   /* '|' (Multiple Escape) */
#define syntax_constituent  3   /* the rest (Constituent) */
#define syntax_whitespace   4   /* TAB,LF,FF,CR,' ' (Whitespace) */
#define syntax_eof          5   /* EOF */
#define syntax_t_macro      6   /* '()'"' (Terminating Macro) */
#define syntax_nt_macro     7   /* '#' (Non-Terminating Macro) */
/* <= syntax_constituent : if an object starts with such a character, it's a
         token. (syntax_illegal will deliver an error then.)
   >= syntax_t_macro : macro-character. if an object starts like that:
         call read-macro function.

 Syntax tables, indexed by characters.
 allocate_syntax_table()
 syntax_table_get(table,c)
 syntax_table_put(table,c,value)
 syntax_table_put can trigger GC */
#if (small_char_code_limit < char_code_limit)
 /* A cons, consisting of a simple-bit-vector with small_char_code_limit
  bytes, and a hash table mapping characters to fixnums. Characters not
  found in the hash table are assumed to have the syntax code
  (graphic_char_p(ch) ? syntax_constituent : syntax_illegal). */
local object allocate_syntax_table (void) {
  /* Allocate the hash table.
   (MAKE-HASH-TABLE :KEY-TYPE 'CHARACTER
                    :VALUE-TYPE 'FIXNUM
                    :TEST 'FASTHASH-EQ :WARN-IF-NEEDS-REHASH-AFTER-GC T) */
  pushSTACK(S(Ktest)); pushSTACK(S(fasthash_eq));
  pushSTACK(S(Kwarn_if_needs_rehash_after_gc)); pushSTACK(T);
  funcall(L(make_hash_table),4);
  pushSTACK(value1);
  /* Allocate the simple-bit-vector. */
  pushSTACK(allocate_bit_vector(Atype_8Bit,small_char_code_limit));
  var object new_cons = allocate_cons();
  Car(new_cons) = popSTACK();
  Cdr(new_cons) = popSTACK();
  return new_cons;
}
local uintB syntax_table_get_notinline (object table, chart c) {
  var object val = gethash(code_char(c),Cdr(table),false);
  if (!eq(val,nullobj))
    return posfixnum_to_V(val);
  else
    return (graphic_char_p(c) ? syntax_constituent : syntax_illegal);
}
local inline uintB syntax_table_get (object table, chart c) {
  return (as_cint(c) < small_char_code_limit
          ? TheSbvector(Car(table))->data[as_cint(c)]
          : syntax_table_get_notinline(table,c));
}
local maygc void syntax_table_put_notinline (object table, chart c, uintB value)
{
  shifthash(Cdr(table),code_char(c),fixnum(value),true);
}
local inline maygc void syntax_table_put (object table, chart c, uintB value) {
  if (as_cint(c) < small_char_code_limit)
    TheSbvector(Car(table))->data[as_cint(c)] = value;
  else
    syntax_table_put_notinline(table,c,value);
}
#else
/* A simple-bit-vector with char_code_limit bytes. */
#define allocate_syntax_table()         \
  allocate_bit_vector(Atype_8Bit,char_code_limit)
#define syntax_table_get(table,c)       \
  TheSbvector(table)->data[as_cint(c)]
#define syntax_table_put(table,c,value) \
  (TheSbvector(table)->data[as_cint(c)] = (value))
#endif
#define syntax_readtable_get(rt,c)     \
  syntax_table_get(TheReadtable(rt)->readtable_syntax_table,c)
#define syntax_readtable_put(rt,c,v)   \
  syntax_table_put(TheReadtable(rt)->readtable_syntax_table,c,v)

/* standard(original) syntaxtable(readtable)  for read characters: */
local const uintB orig_syntax_table [small_char_code_limit] = {
#define illg  syntax_illegal
#define sesc  syntax_single_esc
#define mesc  syntax_multi_esc
#define cnst  syntax_constituent
#define whsp  syntax_whitespace
#define tmac  syntax_t_macro
#define nmac  syntax_nt_macro
  illg,illg,illg,illg,illg,illg,illg,illg, /* chr(0) upto chr(7) */
  cnst,whsp,whsp,illg,whsp,whsp,illg,illg, /* chr(8) upto chr(15) */
  illg,illg,illg,illg,illg,illg,illg,illg, /* chr(16) upto chr(23) */
  illg,illg,illg,illg,illg,illg,illg,illg, /* chr(24) upto chr(31) */
  whsp,cnst,tmac,nmac,cnst,cnst,cnst,tmac, /* ' !"#$%&'' */
  tmac,tmac,cnst,cnst,tmac,cnst,cnst,cnst, /* '()*+,-./' */
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst, /* '01234567' */
  cnst,cnst,cnst,tmac,cnst,cnst,cnst,cnst, /* '89:;<=>?' */
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst, /* '@ABCDEFG' */
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst, /* 'HIJKLMNO' */
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst, /* 'PQRSTUVW' */
  cnst,cnst,cnst,cnst,sesc,cnst,cnst,cnst, /* 'XYZ[\]^_' */
  tmac,cnst,cnst,cnst,cnst,cnst,cnst,cnst, /* '`abcdefg' */
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst, /* 'hijklmno' */
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst, /* 'pqrstuvw' */
  cnst,cnst,cnst,cnst,mesc,cnst,cnst,cnst, /* 'xyz{|}~',chr(127) */
 #if defined(UNICODE) || defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS)
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  whsp,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
 #elif defined(NEXTSTEP_CHS)
  whsp,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
 #else  /* defined(ASCII_CHS) && !defined(UNICODE) */
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
  illg,illg,illg,illg,illg,illg,illg,illg,
 #endif
#undef illg
#undef sesc
#undef mesc
#undef cnst
#undef whsp
#undef tmac
#undef nmac
};
#if (small_char_code_limit < char_code_limit)
#define orig_syntax_table_get(c)  \
      (as_cint(c) < small_char_code_limit                          \
       ? orig_syntax_table[as_cint(c)]                             \
       : (graphic_char_p(c) ? syntax_constituent : syntax_illegal))
#else
#define orig_syntax_table_get(c)  orig_syntax_table[as_cint(c)]
#endif

/* UP: returns the standard (original) readtable.
 orig_readtable()
 < result: standard(original) readtable
 can trigger GC */
local maygc object orig_readtable (void) {
  {                             /* initialize the syntax-table: */
    var object s_table = allocate_syntax_table(); /* new bitvector */
    pushSTACK(s_table);                           /* save */
    /* and fill with the original: */
   #if (small_char_code_limit < char_code_limit)
    s_table = Car(s_table);
   #endif
    var const uintB * ptr1 = &orig_syntax_table[0];
    var uintB* ptr2 = &TheSbvector(s_table)->data[0];
    var uintC count;
    dotimesC(count,small_char_code_limit, { *ptr2++ = *ptr1++; } );
  }
  {                             /* initialize dispatch-macro '#': */
    var object d_table = allocate_perchar_table(); /* new vector */
    pushSTACK(d_table);                            /* save */
    /* and add the sub-character-functions for '#': */
    var gcv_object_t* table = &TheSvector(d_table)->data[0];
    table['\''] = L(function_reader);
    table['|'] = L(comment_reader);
    table['\\'] = L(char_reader);
    table['B'] = L(binary_reader);
    table['O'] = L(octal_reader);
    table['X'] = L(hexadecimal_reader);
    table['R'] = L(radix_reader);
    table['C'] = L(complex_reader);
    table[':'] = L(uninterned_reader);
    table['*'] = L(bit_vector_reader);
    table['('] = L(vector_reader);
    table['A'] = L(array_reader);
    table['.'] = L(read_eval_reader);
    table[','] = L(load_eval_reader);
    table['='] = L(label_definition_reader);
    table['#'] = L(label_reference_reader);
    table['<'] = L(not_readable_reader);
    table[')'] = L(syntax_error_reader);
    table[' '] = L(syntax_error_reader); /* #\Space */
    table[NL] = L(syntax_error_reader); /* #\Newline = 10 = #\Linefeed */
    table[BS] = L(syntax_error_reader); /* #\Backspace */
    table[TAB] = L(syntax_error_reader);    /* #\Tab */
    table[CR] = L(syntax_error_reader);     /* #\Return */
    table[PG] = L(syntax_error_reader);     /* #\Page */
    table[RUBOUT] = L(syntax_error_reader); /* #\Rubout */
    table['+'] = L(feature_reader);
    table['-'] = L(not_feature_reader);
    table['S'] = L(structure_reader);
    table['Y'] = L(closure_reader);
    table['"'] = L(clisp_pathname_reader);
    table['P'] = L(ansi_pathname_reader);
  }
  {                             /* initialize READ-macros: */
    var object m_table = allocate_perchar_table(); /* new NIL-filled vector */
    /* and add the macro-characters: */
    var gcv_object_t* table = &TheSvector(m_table)->data[0];
    table['('] = L(lpar_reader);
    table[')'] = L(rpar_reader);
    table['"'] = L(string_reader);
    table['\''] = L(quote_reader);
    table['#'] = popSTACK();    /* dispatch-vector for '#' */
    table[';'] = L(line_comment_reader);
    table['`'] = S(backquote_reader); /* cf. BACKQUOTE.LISP */
    table[','] = S(comma_reader);     /* cf. BACKQUOTE.LISP */
    pushSTACK(m_table);               /* save */
  }
  { /* build readtable: */
    var object readtable = allocate_readtable(); /* new readtable */
    TheReadtable(readtable)->readtable_macro_table = popSTACK(); /* m_table */
    TheReadtable(readtable)->readtable_syntax_table = popSTACK(); /* s_table */
    TheReadtable(readtable)->readtable_case = fixnum(case_upcase); /* :UPCASE */
    return readtable;
  }
}

/* UP: copies a readtable
 copy_readtable_contents(from_readtable,to_readtable)
 > from-readtable
 > to-readtable
 < result : to-Readtable with same content
 can trigger GC */
local maygc object copy_readtable_contents (object from_readtable,
                                            object to_readtable) {
  /* copy the case-slot: */
  TheReadtable(to_readtable)->readtable_case =
    TheReadtable(from_readtable)->readtable_case;
  { /* copy the syntaxtable: */
    var object stable1;
    var object stable2;
   #if (small_char_code_limit < char_code_limit)
    pushSTACK(to_readtable);
    pushSTACK(from_readtable);
    /* Allocate a new hash table.
     (MAKE-HASH-TABLE :KEY-TYPE 'CHARACTER
                      :VALUE-TYPE 'FIXNUM
                      :TEST 'FASTHASH-EQ :WARN-IF-NEEDS-REHASH-AFTER-GC T) */
    pushSTACK(S(Ktest)); pushSTACK(S(fasthash_eq));
    pushSTACK(S(Kwarn_if_needs_rehash_after_gc)); pushSTACK(T);
    funcall(L(make_hash_table),4);
    pushSTACK(value1);
    /* stack layout: to-readtable, from-readtable, newht. */
    map_hashtable(Cdr(TheReadtable(STACK_1)->readtable_syntax_table),ch,entry,
                  { shifthash(STACK_(0+1),ch,entry,true); });
    {
      var object newht = popSTACK();
      from_readtable = popSTACK();
      to_readtable = popSTACK();
      stable1 = Car(TheReadtable(from_readtable)->readtable_syntax_table);
      stable2 = TheReadtable(to_readtable)->readtable_syntax_table;
      Cdr(stable2) = newht;
      stable2 = Car(stable2);
    }
   #else
    stable1 = TheReadtable(from_readtable)->readtable_syntax_table;
    stable2 = TheReadtable(to_readtable)->readtable_syntax_table;
   #endif
    var const uintB* ptr1 = &TheSbvector(stable1)->data[0];
    var uintB* ptr2 = &TheSbvector(stable2)->data[0];
    var uintC count;
    dotimesC(count,small_char_code_limit, { *ptr2++ = *ptr1++; } );
  }
  /* copy the macro-table: */
  pushSTACK(to_readtable);      /* save to-readtable */
  {
    var object mtable1 = TheReadtable(from_readtable)->readtable_macro_table;
    var object mtable2 = TheReadtable(to_readtable)->readtable_macro_table;
    var uintL i;
    for (i = 0; i < small_char_code_limit; i++) {
      /* copy entry number i: */
      var object entry = TheSvector(mtable1)->data[i];
      if (simple_vector_p(entry)) {
        /* simple-vector is copied element for element: */
        pushSTACK(mtable1); pushSTACK(mtable2);
        entry = copy_perchar_table(entry);
        mtable2 = popSTACK(); mtable1 = popSTACK();
      }
      TheSvector(mtable2)->data[i] = entry;
    }
   #if (small_char_code_limit < char_code_limit)
    pushSTACK(mtable2);
    pushSTACK(mtable1);
    /* Allocate a new hash table.
     (MAKE-HASH-TABLE :KEY-TYPE 'CHARACTER
                      :VALUE-TYPE '(OR FUNCTION SIMPLE-VECTOR)
                      :TEST 'FASTHASH-EQ :WARN-IF-NEEDS-REHASH-AFTER-GC T) */
    pushSTACK(S(Ktest)); pushSTACK(S(fasthash_eq));
    pushSTACK(S(Kwarn_if_needs_rehash_after_gc)); pushSTACK(T);
    funcall(L(make_hash_table),4);
    mtable1 = STACK_0;
    STACK_0 = value1;
    /* stack layout: mtable2, newht. */
    map_hashtable(TheSvector(mtable1)->data[small_char_code_limit],ch,entry, {
      if (simple_vector_p(entry))
        entry = copy_perchar_table(entry);
      shifthash(STACK_(0+1),ch,entry,true);
    });
    TheSvector(STACK_1)->data[small_char_code_limit] = STACK_0;
    skipSTACK(2);
   #endif
  }
  return popSTACK();            /* to-readtable as result */
}

/* UP: copies a readtable
 copy_readtable(readtable)
 > readtable: Readtable
 < result: copy of readtable, semantically equivalent
 can trigger GC */
local maygc object copy_readtable (object from_readtable) {
  pushSTACK(from_readtable);           /* save */
  pushSTACK(allocate_syntax_table());  /* new empty syntaxtable */
  pushSTACK(allocate_perchar_table()); /* new empty macro-table */
  var object to_readtable = allocate_readtable(); /* new readtable */
  /* fill: */
  TheReadtable(to_readtable)->readtable_macro_table = popSTACK();
  TheReadtable(to_readtable)->readtable_syntax_table = popSTACK();
  /* and copy content: */
  return copy_readtable_contents(popSTACK(),to_readtable);
}

/* error at wrong value of *READTABLE*
 error_bad_readtable(); */
nonreturning_function(local, error_bad_readtable, (void)) {
  /* correct *READTABLE*: */
  var object sym = S(readtablestern); /* Symbol *READTABLE* */
  var object oldvalue = Symbol_value(sym);
  Symbol_value(sym) = O(standard_readtable); /* := CL standard readtable */
  /* and report the error: */
  pushSTACK(oldvalue);          /* TYPE-ERROR slot DATUM */
  pushSTACK(S(readtable));      /* TYPE-ERROR slot EXPECTED-TYPE */
  pushSTACK(sym);
  error(type_error,
         GETTEXT("The value of ~S was not a readtable. It has been reset."));
}

/* Macro: fetches the current readtable.
 get_readtable(readtable =);
 < readtable : the current readtable */
#if 0
  #define get_readtable(assignment)                     \
    { if (!readtablep(Symbol_value(S(readtablestern)))) \
        { error_bad_readtable(); }                      \
      assignment Symbol_value(S(readtablestern)); }
#else  /* or (optimized): */
  #define get_readtable(assignment)                                     \
    { if (!(orecordp(Symbol_value(S(readtablestern)))                   \
        && (Record_type( assignment Symbol_value(S(readtablestern)) )   \
            == Rectype_Readtable)))                                     \
        { error_bad_readtable(); }}
#endif


/* =======================================================================
   Initialization
   ======================================================================= */

/* UP: Initializes the reader.
 init_reader();
 can trigger GC */
global maygc void init_reader (void) {
  /* initialize *READ-BASE*: */
  define_variable(S(read_base),fixnum(10)); /* *READ-BASE* := 10 */
  /* initialize *READ-SUPPRESS*: */
  define_variable(S(read_suppress),NIL);  /* *READ-SUPPRESS* := NIL */
  /* initialize *READ-EVAL*: */
  define_variable(S(read_eval),T);        /* *READ-EVAL* := T */
  /* initialize *READING-ARRAY* */
  define_variable(S(reading_array),NIL);  /* *READING-ARRAY* := NIL */
  /* initialize *READING-STRUCT* */
  define_variable(S(reading_struct),NIL); /* *READING-STRUCT* := NIL */
  { /* initialize *READTABLE*: */
    var object readtable = orig_readtable();
    O(standard_readtable) = readtable; /* that is the standard-readtable, */
    readtable = copy_readtable(readtable);        /* one copy of it */
    define_variable(S(readtablestern),readtable); /* =: *READTABLE* */
  }
  /* initialize token_buff_1 and token_buff_2: */
  O(token_buff_1) = NIL;
  /* token_buff_1 and token_buff_2 will be initialized
   with a semi-simple-string and a semi-simple-byte-vector
   at the first call of get_buffers (see below).
   Displaced-String initialisieren:
   new array (with data-vector NIL), Displaced, rank=1 */
  O(displaced_string) =
    allocate_iarray(bit(arrayflags_displaced_bit)|
                    bit(arrayflags_dispoffset_bit)|
                    Atype_Char,
                    1,
                    Array_type_string);
}

/* (SYS::%DEFIO dispatch-reader vector-index) post-initialises the I/O. */
LISPFUNN(defio,2) {
  O(dispatch_reader) = STACK_1;
  O(dispatch_reader_index) = STACK_0;
  VALUES0; skipSTACK(2);
}


/* ======================================================================
   LISP - Functions for readtables
   ====================================================================== */

/* error, if argument is no Readtable.
 check_readtable(obj);
 > obj: possibly erroneous Argument
 can trigger GC */
local maygc object check_readtable (object obj) {
  while (!readtablep(obj)) {
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(obj);          /* TYPE-ERROR slot DATUM */
    pushSTACK(S(readtable)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(S(readtable)); pushSTACK(obj);
    pushSTACK(TheSubr(subr_self)->name);
    check_value(type_error,GETTEXT("~S: argument ~S is not a ~S"));
    obj = value1;
  }
  return obj;
}

LISPFUN(copy_readtable,seclass_read,0,2,norest,nokey,0,NIL)
{ /* (COPY-READTABLE [from-readtable [to-readtable]]), CLTL p. 361 */
  var object from_readtable = STACK_1;
  if (!boundp(from_readtable)) {
    /* no arguments are given */
    get_readtable(from_readtable=); /* current readtable */
    VALUES1(copy_readtable(from_readtable));
  } else {
    if (nullp(from_readtable))
      /* instead of NIL take the standard-readtable */
      from_readtable = STACK_1 = O(standard_readtable);
    else /* check from-readtable: */
      from_readtable = STACK_1 = check_readtable(from_readtable);
    /* from-readtable is OK */
    var object to_readtable = STACK_0;
    if (missingp(to_readtable))
      /* copy from-readtable, without to-readtable */
      VALUES1(copy_readtable(from_readtable));
    else { /* check to-readtable and perform the copying: */
      to_readtable = check_readtable(to_readtable);
      from_readtable = STACK_1; /* restore: check_readtable() may cons */
      VALUES1(copy_readtable_contents(from_readtable,to_readtable));
    }
  }
  skipSTACK(2);
}

LISPFUN(set_syntax_from_char,seclass_default,2,2,norest,nokey,0,NIL)
{ /* (SET-SYNTAX-FROM-CHAR to-char from-char [to-readtable [from-readtable]]),
 CLTL p. 361 */
  var chart to_char = char_code(check_char(STACK_3));
  var chart from_char = char_code(check_char(STACK_2));
  var object to_readtable = STACK_1;
  /* check to-readtable: */
  if (!boundp(to_readtable)) { /* default is the current readtable */
    get_readtable(to_readtable=STACK_1=);
  } else
    to_readtable = STACK_1 = check_readtable(to_readtable);
  /* check from-readtable: */
  var object from_readtable = STACK_0;
  if (missingp(from_readtable)) { /* default is the standard-readtable */
    STACK_0 = from_readtable = O(standard_readtable);
  } else {
    STACK_0 = from_readtable = check_readtable(from_readtable);
    to_readtable = STACK_1; /* restore: check_readtable() may cons */
  }
  /* now to_char, from_char, to_readtable, from_readtable are OK. */
  /* copy syntaxcode: */
  syntax_readtable_put(to_readtable,to_char,
                       syntax_readtable_get(from_readtable,from_char));
  /* copy macro-function/vector: */
  var object entry =
    perchar_table_get(TheReadtable(STACK_0)->readtable_macro_table,from_char);
  if (simple_vector_p(entry))
    /* if entry is a simple-vector, it must be copied: */
    entry = copy_perchar_table(entry);
  perchar_table_put(TheReadtable(STACK_1)->readtable_macro_table,to_char,entry);
  VALUES1(T);
  skipSTACK(4);
}

/* UP: checks an optional readtable-argument,
 with default = current readtable.
 > readtable: Argument
 < result: readtable
 can trigger GC */
local maygc object test_readtable_arg (object readtable) {
  if (!boundp(readtable)) {
    get_readtable(readtable=); /* the current readtable is default */
  } else
    readtable = check_readtable(readtable);
  return readtable;
}

/* UP: checks an optional readtable-argument,
 with default = current readtable, nil = standard-readtable.
 > readtable: Argument
 < result: readtable
 can trigger GC */
local maygc object test_readtable_null_arg (object readtable) {
  if (!boundp(readtable)) {
    get_readtable(readtable=); /* the current readtable is default */
  } else if (nullp(readtable)) {
    readtable = O(standard_readtable); /* respectively the standard-readtable */
  } else
    readtable = check_readtable(readtable);
  return readtable;
}

/* UP: checks the next-to-last optional argument of
 SET-MACRO-CHARACTER and MAKE-DISPATCH-MACRO-CHARACTER.
 > arg: non-terminating-p - Argument
 < result: new syntaxcode */
local uintB test_nontermp_arg (object arg) {
  if (missingp(arg))
    return syntax_t_macro;      /* terminating is default */
  else
    return syntax_nt_macro;     /* non-terminating-p given and /= NIL */
}

LISPFUN(set_macro_character,seclass_default,2,2,norest,nokey,0,NIL)
{ /* (SET-MACRO-CHARACTER char function [non-terminating-p [readtable]]),
 CLTL p. 362 */
  var chart c = char_code(check_char(STACK_3));
  { /* check function and convert into an object of type FUNCTION: */
    var object function = coerce_function(STACK_2);
    if (cclosurep(function)
        && eq(TheCclosure(function)->clos_codevec,
              TheCclosure(O(dispatch_reader))->clos_codevec)) {
      var object vector =
        TheCclosure(function)->clos_consts[posfixnum_to_V(O(dispatch_reader_index))];
      if (simple_vector_p(vector)) {
        /* It's a clone of #'dispatch-reader. Pull out the vector. */
        function = copy_perchar_table(vector);
      }
    }
    STACK_2 = function;
  }
  var object readtable = test_readtable_arg(popSTACK()); /* readtable */
  var uintB syntaxcode = test_nontermp_arg(popSTACK()); /* new syntaxcode */
  STACK_1 = readtable;
  /* set syntaxcode: */
  syntax_table_put(TheReadtable(readtable)->readtable_syntax_table,c,syntaxcode);
  /* add macrodefinition: */
  perchar_table_put(TheReadtable(STACK_1)->readtable_macro_table,c,STACK_0);
  VALUES1(T);
  skipSTACK(2);
}

LISPFUN(get_macro_character,seclass_read,1,1,norest,nokey,0,NIL)
{ /* (GET-MACRO-CHARACTER char [readtable]), CLTL p. 362 */
  var chart c = char_code(check_char(STACK_1));
  var object readtable = test_readtable_null_arg(STACK_0); /* Readtable */
  skipSTACK(2);
  /* Test the Syntaxcode: */
  var object nontermp = NIL; /* non-terminating-p Flag */
  switch (syntax_readtable_get(readtable,c)) {
    case syntax_nt_macro: { nontermp = T; }
    case syntax_t_macro: { /* nontermp = NIL; */
      /* c is a macro-character. */
      var object entry =
        perchar_table_get(TheReadtable(readtable)->readtable_macro_table,c);
      if (simple_vector_p(entry)) {
        /* c is a dispatch-macro-character. */
        if (nullp(O(dispatch_reader))) {
          /* Shouldn't happen (bootstrapping problem). */
          pushSTACK(code_char(c));
          pushSTACK(TheSubr(subr_self)->name);
          error(error_condition,GETTEXT("~S: ~S is a dispatch macro character"));
        }
        /* Clone #'dispatch-reader. */
        pushSTACK(copy_perchar_table(entry));
        var object newclos = allocate_cclosure_copy(O(dispatch_reader));
        do_cclosure_copy(newclos,O(dispatch_reader));
        TheCclosure(newclos)->clos_consts[posfixnum_to_V(O(dispatch_reader_index))] = popSTACK();
        value1 = newclos;
      } else
        value1 = entry;
    } break;
    default: /* nontermp = NIL; */
      value1 = NIL; break;
  }
  value2 = nontermp; mv_count=2; /* nontermp as second value */
}

LISPFUN(make_dispatch_macro_character,seclass_default,1,2,norest,nokey,0,NIL)
{ /* (MAKE-DISPATCH-MACRO-CHARACTER char [non-terminating-p [readtable]]),
 CLTL p. 363 */
  var object readtable = test_readtable_arg(STACK_0); /* Readtable */
  var uintB syntaxcode = test_nontermp_arg(STACK_1); /* new syntaxcode */
  STACK_1 = readtable;
  var chart c = char_code(check_char(STACK_2));
  /* fetch new (empty) dispatch-macro-table: */
  STACK_0 = allocate_perchar_table(); /* vector, filled with NIL */
  /* store everything in the readtable: */
  /* syntaxcode into syntax-table: */
  syntax_table_put(TheReadtable(STACK_1)->readtable_syntax_table,c,syntaxcode);
  /* new dispatch-macro-table into the macrodefinition table: */
  perchar_table_put(TheReadtable(STACK_1)->readtable_macro_table,c,STACK_0);
  VALUES1(T);
  skipSTACK(3);
}

/* UP: checks the arguments disp-char and sub-char.
 > in STACK: *(argsp STACKop 1) = disp-char, *(argsp STACKop 0) = sub-char
 > STACK_0: readtable
 < result: the dispatch-macro-table for disp-char,
             nullobj if sub-char is a digit.
 can trigger GC */
local maygc object test_disp_sub_char (gcv_object_t* argsp) {
  var object sub_ch = check_char(*(argsp STACKop 0));  /* sub-char */
 retry_disp_ch:
  var object disp_ch = check_char(*(argsp STACKop 1)); /* disp-char */
  var chart disp_c = char_code(disp_ch);
  var object entry =
    perchar_table_get(TheReadtable(STACK_0)->readtable_macro_table,disp_c);
  if (!simple_vector_p(entry)) {
    pushSTACK(NIL);             /* no PLACE */
    pushSTACK(disp_ch);
    pushSTACK(TheSubr(subr_self)->name);
    check_value(error_condition,GETTEXT("~S: ~S is not a dispatch macro character"));
    *(argsp STACKop 1) = value1;
    goto retry_disp_ch;
  }
  /* disp-char is a dispatching-macro-character, entry is the vector. */
  var cint sub_c = as_cint(up_case(char_code(sub_ch))); /* convert sub-char into upper case */
  if ((sub_c >= '0') && (sub_c <= '9'))                 /* digit */
    return nullobj;
  else                          /* valid sub-char */
    return entry;
}

LISPFUN(set_dispatch_macro_character,seclass_default,3,1,norest,nokey,0,NIL)
{ /* (SET-DISPATCH-MACRO-CHARACTER disp-char sub-char function [readtable]),
 CLTL p. 364 */
  /* check function and convert it into an object of Type FUNCTION: */
  STACK_1 = coerce_function(STACK_1);
  STACK_0 = test_readtable_arg(STACK_0); /* Readtable */
  var object dm_table = test_disp_sub_char(&STACK_2);
  if (eq(dm_table,nullobj)) {
    pushSTACK(STACK_2);           /* sub-char, TYPE-ERROR slot DATUM */
    pushSTACK(O(type_not_digit)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(STACK_(2+2));
    pushSTACK(TheSubr(subr_self)->name);
    error(type_error,GETTEXT("~S: digit ~C not allowed as sub-char"));
  } else {
    /* add function to the dispatch-macro-table */
    perchar_table_put(dm_table,up_case(char_code(STACK_2)),STACK_1);
    VALUES1(T); skipSTACK(4);
  }
}

LISPFUN(get_dispatch_macro_character,seclass_read,2,1,norest,nokey,0,NIL)
{ /* (GET-DISPATCH-MACRO-CHARACTER disp-char sub-char [readtable]),
     CLTL p. 364 */
  STACK_0 = test_readtable_null_arg(STACK_0); /* readtable */
  var object dm_table = test_disp_sub_char(&STACK_1);
  VALUES1(eq(dm_table,nullobj) ? NIL /* NIL or Function as value */
          : perchar_table_get(dm_table,up_case(char_code(STACK_1))));
  skipSTACK(3);
}

#define RTCase(rt) ((uintW)posfixnum_to_V(TheReadtable(rt)->readtable_case))

LISPFUNN(readtable_case,1)
{ /* (READTABLE-CASE readtable), CLTL2 S. 549 */
  var object readtable = check_readtable(popSTACK()); /* Readtable */
  VALUES1((&O(rtcase_0))[RTCase(readtable)]);
}

LISPFUNN(set_readtable_case,2)
{ /* (SYSTEM::SET-READTABLE-CASE readtable value), CLTL2 p. 549 */
  var object value = popSTACK();
 retry_readtable_case:
  /* convert symbol value into an index by searching in table O(rtcase..): */
  var const gcv_object_t* ptr = &O(rtcase_0);
  var uintC rtcase = 0;
  var uintC count = 4;
  while (count--) {
    if (eq(*ptr,value))
      goto found;
    ptr++; rtcase++;
  };
  { /* invalid value */
    pushSTACK(NIL); /* no PLACE */
    pushSTACK(value);          /* TYPE-ERROR slot DATUM */
    pushSTACK(O(type_rtcase)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(O(rtcase_3)); pushSTACK(O(rtcase_2));
    pushSTACK(O(rtcase_1)); pushSTACK(O(rtcase_0));
    pushSTACK(value);
    pushSTACK(S(set_readtable_case));
    check_value(type_error,GETTEXT("~S: new value ~S should be ~S, ~S, ~S or ~S."));
    value = value1;
  }
  goto retry_readtable_case;
 found: /* found in table */
  var object readtable = check_readtable(popSTACK()); /* readtable */
  TheReadtable(readtable)->readtable_case = fixnum(rtcase);
  VALUES1(*ptr);
}

/* ======================================================================
   some auxiliary routines and macros for READ and PRINT
   ====================================================================== */

/* UP: fetches the value of a symbol. must be fixnum >=2, <=36.
 get_base(symbol)
 > symbol: Symbol
 < result: value of the Symbols, >=2, <=36. */
local uintL get_base (object symbol) {
  var object value = Symbol_value(symbol);
  var uintV intvalue;
  if (posfixnump(value)
      && (intvalue = posfixnum_to_V(value),
          ((intvalue >= 2) && (intvalue <= 36)))) {
    return intvalue;
  } else {
    Symbol_value(symbol) = fixnum(10);
    pushSTACK(value);           /* TYPE-ERROR slot DATUM */
    pushSTACK(O(type_radix));   /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(value);
    pushSTACK(symbol);
    error(type_error,
          GETTEXT("The value of ~S should be an integer between 2 and 36, not ~S.\n"
                  "It has been reset to 10."));
  }
}

/* UP: fetches the value of *PRINT-BASE*
 get_print_base()
 < uintL result: >=2, <=36 */
#define get_print_base()  \
    (!nullpSv(print_readably) ? 10 : get_base(S(print_base)))

/* UP: fetches the value of *READ-BASE*
 get_read_base()
 < uintL result: >=2, <=36 */
#define get_read_base()  get_base(S(read_base))


/* ======================================================================
   R E A D
   ====================================================================== */

/* Characters are read one by one.
 Their syntax codes are determined by use the readtable, cf. CLTL table 22-1.
 Syntax code 'constituent' starts a new (extended) token.
 For every character in the token, its attribute a_xxxx is looked up by use
 of the attribute table, cf. CLTL table 22-3.
 O(token_buff_1) is a semi-simple-string, which contains the characters of
 the currently read extended-token.
 O(token_buff_2) is a semi-simple-byte-vektor, which contains the attributes
 of the currently read extended-token.
 Both have the same length (in characters respectively bytes).

 Special objects, that can be returned by READ:
 eof_value: special object, that indicates EOF
 dot_value: auxiliary value for the detection of single dots

 ------------------------ READ on character-level ---------------------------

 error, if read object is not a character:
 error_charread(ch,&stream); */
nonreturning_function(local, error_charread, (object ch, const gcv_object_t* stream_)) {
  pushSTACK(*stream_);          /* STREAM-ERROR slot STREAM */
  pushSTACK(ch);                /* Character */
  pushSTACK(*stream_);          /* Stream */
  pushSTACK(S(read));
  error(stream_error,
        GETTEXT("~S from ~S: character read should be a character: ~S"));
}

/* UP: Reads a character and calculates its syntaxcode.
 read_char_syntax(ch=,scode=,&stream);
 > stream: Stream
 < stream: Stream
 < object ch: Character or eof_value
 < uintWL scode: Syntaxcode (from the current readtable) respectively syntax_eof
 can trigger GC */
#define read_char_syntax(ch_assignment,scode_assignment,stream_)        \
  { var object ch0 = read_char(stream_);        /* read character */    \
    ch_assignment ch0;                                                  \
    if (eq(ch0,eof_value))               /* EOF ? */                    \
      { scode_assignment syntax_eof; }                                  \
    else { /* Check for character: */                                   \
      if (!charp(ch0)) { error_charread(ch0,stream_); }                 \
     {var object readtable;                                             \
      get_readtable(readtable = );                                      \
      scode_assignment           /* fetch syntaxcode from table */      \
        syntax_readtable_get(readtable,char_code(ch0));                 \
     }}}

/* error-message at EOF outside of objects
 error_eof_outside(&stream);
 > stream: Stream */
nonreturning_function(local, error_eof_outside, (const gcv_object_t* stream_)) {
  pushSTACK(*stream_);          /* STREAM-ERROR slot STREAM */
  pushSTACK(*stream_);          /* Stream */
  pushSTACK(S(read));
  error(end_of_file,GETTEXT("~S: input stream ~S has reached its end"));
}

/* error-message at EOF inside of objects
 error_eof_inside(&stream);
 > stream: Stream */
nonreturning_function(local, error_eof_inside, (const gcv_object_t* stream_)) {
  pushSTACK(*stream_);          /* STREAM-ERROR slot STREAM */
  if (posfixnump(Symbol_value(S(read_line_number)))) { /* check SYS::*READ-LINE-NUMBER* */
    pushSTACK(Symbol_value(S(read_line_number)));      /* line-number */
    pushSTACK(*stream_);                               /* Stream */
    pushSTACK(S(read));
    error(end_of_file,GETTEXT("~S: input stream ~S ends within an object. Last opening parenthesis probably in line ~S."));
  } else {
    pushSTACK(*stream_);        /* Stream */
    pushSTACK(S(read));
    error(end_of_file,GETTEXT("~S: input stream ~S ends within an object"));
  }
}

/* error-message at EOF, according to *READ-RECURSIVE-P*
 error_eof(&stream);
 > stream: Stream */
nonreturning_function(local, error_eof, (const gcv_object_t* stream_)) {
  if (!nullpSv(read_recursive_p)) /* *READ-RECURSIVE-P* /= NIL ? */
    error_eof_inside(stream_);
  else
    error_eof_outside(stream_);
}

/* UP: read up to the next non-whitespace-character, without consuming it
 At EOF --> Error.
 wpeek_char_syntax(ch=,scode=,&stream);
 > stream: Stream
 < stream: Stream
 < object ch: next character
 < uintWL scode: its syntaxcode
 can trigger GC */
#define wpeek_char_syntax(ch_assignment,scode_assignment,stream_)       \
  { while (1) {                                                         \
    object ch0 = read_char(stream_);              /* read Character */  \
    if (eq(ch0,eof_value)) { error_eof(stream_); }  /* EOF -> Error */  \
    /* check for Character: */                                          \
    if (!charp(ch0)) { error_charread(ch0,stream_); }                   \
   {var object readtable;                                               \
    get_readtable(readtable = );                                        \
    if (!((scode_assignment        /* fetch Syntaxcode from table */    \
           syntax_readtable_get(readtable,char_code(ch0)))              \
          == syntax_whitespace))                                        \
      /* no Whitespace -> push back last read character */              \
      { unread_char(stream_,ch0); ch_assignment ch0; break; }           \
   }}}

/* UP: read up to the next non-whitespace-character, without consuming it.
 wpeek_char_eof(&stream)
 > stream: Stream
 < stream: Stream
 < result: next character or eof_value
 can trigger GC */
local maygc object wpeek_char_eof (const gcv_object_t* stream_) {
  while (1) {
    var object ch = peek_char(stream_); /* peek character */
    if (eq(ch,eof_value))               /* EOF ? */
      return ch;
    /* check for Character: */
    if (!charp(ch))
      error_charread(ch,stream_);
    var object readtable;
    get_readtable(readtable = );
    if (!((                     /* fetch Syntaxcode from table */
           syntax_readtable_get(readtable,char_code(ch)))
          == syntax_whitespace))
      return ch;
    read_char(stream_); /* drop the last (whitespace) character */
  }
}

/* ------------------- READ at token-level -------------------------------

 read_token and test_potential_number_syntax, test_number_syntax need
 the attributes according to CLTL table 22-3.
 During test_potential_number_syntax attributes are transformed,
 a_digit partially into a_alpha or a_letter or a_expo_m.

 meaning of the entries in attribute_table: */
#define a_illg          0 /* illegal constituent */
#define a_pack_m        1 /* ':' = Package-marker */
#define a_alpha         2 /* character without special property (alphabetic) */
#define a_escaped       3 /* character without special property, not subject to case conversion */
#define a_ratio         4 /* '/' */
#define a_dot           5 /* '.' */
#define a_plus          6 /* '+' */
#define a_minus         7 /* '-' */
#define a_extens        8 /* '_^' extension characters */
#define a_digit         9 /* '0123456789' */
#define a_letterdigit  10 /* 'A'-'Z','a'-'z' less than base, not 'esfdlESFDL' */
#define a_expodigit    11 /* 'esfdlESFDL' less than base */
#define a_letter       12 /* 'A'-'Z','a'-'z', not 'esfdlESFDL' */
#define a_expo_m       13 /* 'esfdlESFDL' */
/* >= a_letter            -  'A'-'Z','a'-'z'
   >= a_digit             - '0123456789','A'-'Z','a'-'z'
   >= a_ratio             - what a potential number must consist of */

/* attribute-table for constituents, first interpretation:
 note: first, 0-9,A-Z,a-z are interpreted as a_digit or a_expo_m,
 then (if no integer can be deduced out of token), a_digit
 is interpreted as a_alpha (alphabetic) above of *READ-BASE*. */
local const uintB attribute_table[small_char_code_limit] = {
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg, /* chr(0) upto chr(7) */
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg, /* chr(8) upto chr(15) */
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg, /* chr(16) upto chr(23) */
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg, /* chr(24) upto chr(31) */
  a_illg,  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, /* ' !"#$%&'' */
  a_alpha, a_alpha, a_alpha, a_plus,  a_alpha, a_minus, a_dot,   a_ratio, /* '()*+,-./' */
  a_digit, a_digit, a_digit, a_digit, a_digit, a_digit, a_digit, a_digit, /* '01234567' */
  a_digit, a_digit, a_pack_m,a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, /* '89:;<=>?' */
  a_alpha, a_letter,a_letter,a_letter,a_expo_m,a_expo_m,a_expo_m,a_letter, /* '@ABCDEFG' */
  a_letter,a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter, /* 'HIJKLMNO' */
  a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter,a_letter, /* 'PQRSTUVW' */
  a_letter,a_letter,a_letter,a_alpha, a_alpha, a_alpha, a_extens,a_extens, /* 'XYZ[\]^_' */
  a_alpha, a_letter,a_letter,a_letter,a_expo_m,a_expo_m,a_expo_m,a_letter, /* '`abcdefg' */
  a_letter,a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter, /* 'hijklmno' */
  a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter,a_letter, /* 'pqrstuvw' */
  a_letter,a_letter,a_letter,a_alpha, a_alpha, a_alpha, a_alpha, /* 'xyz{|}~' */
#if defined(UNICODE) || defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS)
  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
#elif defined(NEXTSTEP_CHS)
                                                                 a_illg,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
 #else  /* defined(ASCII_CHS) && !defined(UNICODE) */
                                                                 a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
 #endif
};

/* Returns the attribute code for a character code.
 attribute_of(c)
 > chart c: character code
 < uintB result: attribute code */
#if (small_char_code_limit < char_code_limit) /* i.e. defined(UNICODE) */
  #define attribute_of(c)                               \
    (uintB)(as_cint(c) < small_char_code_limit          \
            ? attribute_table[as_cint(c)]               \
            : (graphic_char_p(c) ? a_alpha : a_illg))
#else
  #define attribute_of(c)  attribute_table[as_cint(c)]
#endif

/* Flag. indicates, if a single-escape- or multiple-escape-character
 occurred in the last read token: */
local bool token_escape_flag;

/* UP: delivers two buffers.
 if two buffers are available in the reservoir O(token_buff_1), O(token_buff_2),
 they are extracted. Otherwise new ones are allocated.
 If the buffers are not needed anymore, they can be written back to
 O(token_buff_1) and O(token_buff_2).
 < STACK_1: a Semi-Simple String with Fill-Pointer 0
 < STACK_0: a Semi-Simple Byte-Vector with Fill-Pointer 0
 < STACK: decreased by 2
 can trigger GC */
local maygc void get_buffers (void) {
  /* Mechanism:
   O(token_buff_1) and O(token_buff_2) hold a Semi-Simple-String
   and a Semi-Simple-Byte-Vector, which are extracted if necessary (and marked
   with O(toke…