home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / io.d < prev    next >
Encoding:
Text File  |  1994-12-28  |  377.3 KB  |  8,966 lines
  1. # Ein-/Ausgabe fⁿr CLISP
  2. # Bruno Haible 28.12.1994
  3. # Marcus Daniels 11.3.1994
  4.  
  5. #include "lispbibl.c"
  6. #include "arilev0.c" # fⁿr Division in pr_uint
  7.  
  8.  
  9. # =============================================================================
  10. # Readtable-Funktionen
  11. # =============================================================================
  12.  
  13. #define RM_anzahl   256  # Anzahl READ-Macro-Pointer
  14. #define DRM_anzahl  256  # Anzahl Dispatch-READ-Macro-Pointer
  15.  
  16. # Aufbau von Readtables (siehe LISPBIBL.D):
  17.   # readtable_syntax_table
  18.   #    ein Bitvektor mit RM_anzahl Bytes: Zu jedem Character der Syntaxcode
  19.   # readtable_macro_table
  20.   #    ein Vektor mit RM_anzahl Elementen: Zu jedem Character
  21.   #    entweder  (wenn das Character keinen Read-Macro darstellt)
  22.   #              NIL
  23.   #    oder      (wenn das Character einen Dispatch-Macro darstellt)
  24.   #              ein Vektor mit DRM_anzahl Funktionen/NILs,
  25.   #    oder      (wenn das Character einen sonstigen Read-Macro darstellt)
  26.   #              die Funktion, die aufgerufen wird, wenn das Character vorkommt.
  27.   # readtable_case
  28.   #    ein Fixnum in {0,1,2}
  29.  
  30. # Bedeutung von case (mit CONSTOBJ.D abgestimmt!):
  31.   #define case_upcase    0
  32.   #define case_downcase  1
  33.   #define case_preserve  2
  34.  
  35. # Bedeutung der EintrΣge in der syntax_table:
  36.   #define syntax_illegal      0  # nichtdruckende, soweit nicht whitespace
  37.   #define syntax_single_esc   1  # '\' (Single Escape)
  38.   #define syntax_multi_esc    2  # '|' (Multiple Escape)
  39.   #define syntax_constituent  3  # alles ⁿbrige (Constituent)
  40.   #define syntax_whitespace   4  # TAB,LF,FF,CR,' ' (Whitespace)
  41.   #define syntax_eof          5  # EOF
  42.   #define syntax_t_macro      6  # '()'"' (Terminating Macro)
  43.   #define syntax_nt_macro     7  # '#' (Non-Terminating Macro)
  44. # <= syntax_constituent : Wenn ein Objekt damit anfΣngt, ist es ein Token.
  45. #                         (ILL liefert dann einen einen Error.)
  46. # >= syntax_t_macro : Macro-Zeichen.
  47. #                     Wenn ein Objekt damit anfΣngt: Macro-Funktion aufrufen.
  48.  
  49. # originale Syntaxtabelle fⁿr eingelesene Zeichen:
  50.   local uintB orig_syntax_table [RM_anzahl] = {
  51.     #define illg  syntax_illegal
  52.     #define sesc  syntax_single_esc
  53.     #define mesc  syntax_multi_esc
  54.     #define cnst  syntax_constituent
  55.     #define whsp  syntax_whitespace
  56.     #define tmac  syntax_t_macro
  57.     #define nmac  syntax_nt_macro
  58.       illg,illg,illg,illg,illg,illg,illg,illg,   # chr(0) bis chr(7)
  59.       cnst,whsp,whsp,illg,whsp,whsp,illg,illg,   # chr(8) bis chr(15)
  60.       illg,illg,illg,illg,illg,illg,illg,illg,   # chr(16) bis chr(23)
  61.       illg,illg,illg,illg,illg,illg,illg,illg,   # chr(24) bis chr(31)
  62.       whsp,cnst,tmac,nmac,cnst,cnst,cnst,tmac,   # ' !"#$%&''
  63.       tmac,tmac,cnst,cnst,tmac,cnst,cnst,cnst,   # '()*+,-./'
  64.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '01234567'
  65.       cnst,cnst,cnst,tmac,cnst,cnst,cnst,cnst,   # '89:;<=>?'
  66.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '@ABCDEFG'
  67.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # 'HIJKLMNO'
  68.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # 'PQRSTUVW'
  69.       cnst,cnst,cnst,cnst,sesc,cnst,cnst,cnst,   # 'XYZ[\]^_'
  70.       tmac,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '`abcdefg'
  71.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # 'hijklmno'
  72.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # 'pqrstuvw'
  73.       cnst,cnst,cnst,cnst,mesc,cnst,cnst,cnst,   # 'xyz{|}~',chr(127)
  74.     #if defined(ATARI_CHS) || defined(IBMPC_CHS) # ATARI_CHS:
  75.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '╟ⁿΘΓΣαστ'
  76.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # 'ΩδΦ∩ε∞─┼'
  77.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '╔µ╞⌠÷≥√∙'
  78.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # ' ╓▄óúÑ▀ '
  79.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # 'ßφ≤·±╤¬o'
  80.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '┐ ¼╜╝í½╗'
  81.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # 'π⌡╪°  └├'
  82.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '╒¿┤ ╢⌐« '
  83.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '        ' hebrΣische Buchstaben
  84.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '        ' hebrΣische Buchstaben
  85.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '        ' hebrΣische Buchstaben
  86.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '     º  ' hebrΣische Buchstaben und Symbole
  87.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '      ╡ ' griechische Buchstaben
  88.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '        ' griechische Buchstaben und Symbole
  89.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # ' ▒    ≈ ' Symbole
  90.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,   # '░    ▓│»' Symbole
  91.     #elif defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS)
  92.       illg,illg,illg,illg,illg,illg,illg,illg,
  93.       illg,illg,illg,illg,illg,illg,illg,illg,
  94.       illg,illg,illg,illg,illg,illg,illg,illg,
  95.       illg,illg,illg,illg,illg,illg,illg,illg,
  96.       whsp,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  97.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  98.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  99.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  100.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  101.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  102.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  103.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  104.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  105.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  106.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  107.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  108.     #elif defined(NEXTSTEP_CHS)
  109.       whsp,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  110.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  111.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  112.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  113.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  114.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  115.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  116.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  117.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  118.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  119.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  120.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  121.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  122.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  123.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  124.       cnst,cnst,cnst,cnst,cnst,cnst,cnst,cnst,
  125.     #else # defined(ASCII_CHS)
  126.       illg,illg,illg,illg,illg,illg,illg,illg,
  127.       illg,illg,illg,illg,illg,illg,illg,illg,
  128.       illg,illg,illg,illg,illg,illg,illg,illg,
  129.       illg,illg,illg,illg,illg,illg,illg,illg,
  130.       illg,illg,illg,illg,illg,illg,illg,illg,
  131.       illg,illg,illg,illg,illg,illg,illg,illg,
  132.       illg,illg,illg,illg,illg,illg,illg,illg,
  133.       illg,illg,illg,illg,illg,illg,illg,illg,
  134.       illg,illg,illg,illg,illg,illg,illg,illg,
  135.       illg,illg,illg,illg,illg,illg,illg,illg,
  136.       illg,illg,illg,illg,illg,illg,illg,illg,
  137.       illg,illg,illg,illg,illg,illg,illg,illg,
  138.       illg,illg,illg,illg,illg,illg,illg,illg,
  139.       illg,illg,illg,illg,illg,illg,illg,illg,
  140.       illg,illg,illg,illg,illg,illg,illg,illg,
  141.       illg,illg,illg,illg,illg,illg,illg,illg,
  142.     #endif
  143.     #undef illg
  144.     #undef sesc
  145.     #undef mesc
  146.     #undef cnst
  147.     #undef whsp
  148.     #undef tmac
  149.     #undef nmac
  150.     };
  151.  
  152. # UP: Liefert die originale Readtable.
  153. # orig_readtable()
  154. # < ergebnis: Originale Readtable
  155. # kann GC ausl÷sen
  156.   local object orig_readtable (void);
  157.   local object orig_readtable()
  158.     { # Syntax-Tabelle initialisieren:
  159.       { var reg4 object s_table = allocate_bit_vector(RM_anzahl*8); # neuer Bitvektor
  160.         pushSTACK(s_table); # retten
  161.         # und mit dem Original fⁿllen:
  162.         { var reg1 uintB* ptr1 = &orig_syntax_table[0];
  163.           var reg2 uintB* ptr2 = &TheSbvector(s_table)->data[0];
  164.           var reg3 uintC count;
  165.           dotimesC(count,RM_anzahl, { *ptr2++ = *ptr1++; } );
  166.       } }
  167.       # Dispatch-Macro '#' initialisieren:
  168.       { var reg2 object d_table = allocate_vector(DRM_anzahl); # neuer Vektor
  169.         pushSTACK(d_table); # retten
  170.         # und die Sub-Character-Funktionen zu '#' eintragen:
  171.         { var reg1 object* table = &TheSvector(d_table)->data[0];
  172.           table['\''] = L(function_reader);
  173.           table['|'] = L(comment_reader);
  174.           table['\\'] = L(char_reader);
  175.           table['B'] = L(binary_reader);
  176.           table['O'] = L(octal_reader);
  177.           table['X'] = L(hexadecimal_reader);
  178.           table['R'] = L(radix_reader);
  179.           table['C'] = L(complex_reader);
  180.           table[':'] = L(uninterned_reader);
  181.           table['*'] = L(bit_vector_reader);
  182.           table['('] = L(vector_reader);
  183.           table['A'] = L(array_reader);
  184.           table['.'] = L(read_eval_reader);
  185.           table[','] = L(load_eval_reader);
  186.           table['='] = L(label_definition_reader);
  187.           table['#'] = L(label_reference_reader);
  188.           table['<'] = L(not_readable_reader);
  189.           table[')'] = L(syntax_error_reader);
  190.           table[' '] = L(syntax_error_reader); # #\Space
  191.           table[NL] = L(syntax_error_reader); # #\Newline = 10 = #\Linefeed
  192.           table[BS] = L(syntax_error_reader); # #\Backspace
  193.           table[TAB] = L(syntax_error_reader); # #\Tab
  194.           table[CR] = L(syntax_error_reader); # #\Return
  195.           table[PG] = L(syntax_error_reader); # #\Page
  196.           table[RUBOUT] = L(syntax_error_reader); # #\Rubout
  197.           table['+'] = L(feature_reader);
  198.           table['-'] = L(not_feature_reader);
  199.           table['S'] = L(structure_reader);
  200.           table['Y'] = L(closure_reader);
  201.           table['"'] = L(pathname_reader);
  202.       } }
  203.       # READ-Macros initialisieren:
  204.       { var reg2 object m_table = allocate_vector(RM_anzahl); # neuer Vektor, mit NIL gefⁿllt
  205.         # und die Macro-Characters eintragen:
  206.         { var reg1 object* table = &TheSvector(m_table)->data[0];
  207.           table['('] = L(lpar_reader);
  208.           table[')'] = L(rpar_reader);
  209.           table['"'] = L(string_reader);
  210.           table['\''] = L(quote_reader);
  211.           table['#'] = popSTACK(); # Dispatch-Vektor fⁿr '#'
  212.           table[';'] = L(line_comment_reader);
  213.           table['`'] = S(backquote_reader); # siehe BACKQUOT.LSP
  214.           table[','] = S(comma_reader); # siehe BACKQUOT.LSP
  215.         }
  216.         pushSTACK(m_table); # retten
  217.       }
  218.       # Readtable bauen:
  219.       { var reg1 object readtable = allocate_readtable(); # neue Readtable
  220.         TheReadtable(readtable)->readtable_macro_table = popSTACK(); # m_table
  221.         TheReadtable(readtable)->readtable_syntax_table = popSTACK(); # s_table
  222.         TheReadtable(readtable)->readtable_case = fixnum(case_upcase); # :UPCASE
  223.         return readtable;
  224.     } }
  225.  
  226. # UP: Kopiert eine Readtable
  227. # copy_readtable_contents(from_readtable,to_readtable)
  228. # > from-readtable
  229. # > to-readtable
  230. # < ergebnis : to-Readtable desselben Inhalts
  231. # kann GC ausl÷sen
  232.   local object copy_readtable_contents (object from_readtable, object to_readtable);
  233.   local object copy_readtable_contents(from_readtable,to_readtable)
  234.     var reg6 object from_readtable;
  235.     var reg5 object to_readtable;
  236.     { # den Case-Slot kopieren:
  237.       TheReadtable(to_readtable)->readtable_case = TheReadtable(from_readtable)->readtable_case;
  238.       # die Syntaxtabelle kopieren:
  239.       { var reg1 uintB* ptr1 = &TheSbvector(TheReadtable(from_readtable)->readtable_syntax_table)->data[0];
  240.         var reg2 uintB* ptr2 = &TheSbvector(TheReadtable(to_readtable)->readtable_syntax_table)->data[0];
  241.         var reg3 uintC count;
  242.         dotimesC(count,RM_anzahl, { *ptr2++ = *ptr1++; } );
  243.       }
  244.       # die Macro-Tabelle kopieren:
  245.       pushSTACK(to_readtable); # to-readtable retten
  246.       { var reg3 object mtable1 = TheReadtable(from_readtable)->readtable_macro_table;
  247.         var reg4 object mtable2 = TheReadtable(to_readtable)->readtable_macro_table;
  248.         var reg2 uintL i;
  249.         for (i=0; i<RM_anzahl; i++)
  250.           { # Eintrag Nummer i kopieren:
  251.             var reg1 object entry = TheSvector(mtable1)->data[i];
  252.             if (simple_vector_p(entry))
  253.               # Simple-Vector wird elementweise kopiert:
  254.               { pushSTACK(mtable1); pushSTACK(mtable2);
  255.                 entry = copy_svector(entry);
  256.                 mtable2 = popSTACK(); mtable1 = popSTACK();
  257.               }
  258.             TheSvector(mtable2)->data[i] = entry;
  259.       }   }
  260.       return popSTACK(); # to-readtable als Ergebnis
  261.     }
  262.  
  263. # UP: Kopiert eine Readtable
  264. # copy_readtable(readtable)
  265. # > readtable: Readtable
  266. # < ergebnis: Kopie der Readtable, semantisch gleich
  267. # kann GC ausl÷sen
  268.   local object copy_readtable (object from_readtable);
  269.   local object copy_readtable(from_readtable)
  270.     var reg2 object from_readtable;
  271.     { pushSTACK(from_readtable); # retten
  272.       pushSTACK(allocate_bit_vector(RM_anzahl*8)); # neue leere Syntaxtabelle
  273.       pushSTACK(allocate_vector(RM_anzahl)); # neue leere Macro-Tabelle
  274.      {var reg1 object to_readtable = allocate_readtable(); # neue Readtable
  275.       # fⁿllen:
  276.       TheReadtable(to_readtable)->readtable_macro_table = popSTACK();
  277.       TheReadtable(to_readtable)->readtable_syntax_table = popSTACK();
  278.       # und Inhalt kopieren:
  279.       return copy_readtable_contents(popSTACK(),to_readtable);
  280.     }}
  281.  
  282. # Fehler bei falschem Wert von *READTABLE*
  283. # fehler_bad_readtable();
  284.   nonreturning_function(local, fehler_bad_readtable, (void));
  285.   local void fehler_bad_readtable()
  286.     { # *READTABLE* korrigieren:
  287.       var reg1 object sym = S(readtablestern); # Symbol *READTABLE*
  288.       var reg2 object oldvalue = Symbol_value(sym);
  289.       Symbol_value(sym) = O(standard_readtable); # := Standard-Readtable von Common Lisp
  290.       # und Fehler melden:
  291.       pushSTACK(oldvalue); # Wert fⁿr Slot DATUM von TYPE-ERROR
  292.       pushSTACK(S(readtable)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  293.       pushSTACK(sym);
  294.       fehler(type_error,
  295.              DEUTSCH ? "Der Wert von ~ war keine Readtable, mu▀te zurⁿckgesetzt werden." :
  296.              ENGLISH ? "The value of ~ was not a readtable. It has been reset." :
  297.              FRANCAIS ? "La valeur de ~ n'Θtait pas un ½readtable╗ et fut remise α la valeur standard." :
  298.              ""
  299.             );
  300.     }
  301.  
  302. # Macro: Holt die aktuelle Readtable.
  303. # get_readtable(readtable =);
  304. # < readtable : die aktuelle Readtable
  305.   #if 0
  306.     #define get_readtable(zuweisung)  \
  307.       { if (!readtablep(Symbol_value(S(readtablestern)))) { fehler_bad_readtable(); }  \
  308.         zuweisung Symbol_value(S(readtablestern));                                     \
  309.       }
  310.   #else # oder (optimierter):
  311.     #define get_readtable(zuweisung)  \
  312.       { if (!(morecordp(Symbol_value(S(readtablestern)))                                                 \
  313.               && (TheRecord( zuweisung Symbol_value(S(readtablestern)) )->rectype == Rectype_Readtable)  \
  314.            ) )                                                                                           \
  315.           { fehler_bad_readtable(); }                                                                    \
  316.       }
  317.   #endif
  318.  
  319.  
  320. # =============================================================================
  321. # Initialisierung
  322. # =============================================================================
  323.  
  324. # UP: Initialisiert den Reader.
  325. # init_reader();
  326. # kann GC ausl÷sen
  327.   global void init_reader (void);
  328.   global void init_reader()
  329.     { # *READ-BASE* initialisieren:
  330.         define_variable(S(read_base),fixnum(10)); # *READ-BASE* := 10
  331.       # *READ-SUPPRESS* initialisieren:
  332.         define_variable(S(read_suppress),NIL);          # *READ-SUPPRESS* := NIL
  333.       # *READTABLE* initialisieren:
  334.       { var reg1 object readtable = orig_readtable();
  335.         O(standard_readtable) = readtable; # Das ist die Standard-Readtable,
  336.         readtable = copy_readtable(readtable); # eine Kopie von ihr
  337.         define_variable(S(readtablestern),readtable);   # =: *READTABLE*
  338.       }
  339.       # token_buff_1 und token_buff_2 initialisieren:
  340.         O(token_buff_1) = NIL;
  341.         # token_buff_1 und token_buff_2 werden beim ersten Aufruf von
  342.         # get_buffers (s.u.) mit zwei Semi-Simple-Strings initialisiert.
  343.       # Displaced-String initialisieren:
  344.         # neuer Array (mit Datenvektor NIL), Displaced, Rang=1
  345.         O(displaced_string) =
  346.           allocate_array(bit(arrayflags_displaced_bit)|bit(arrayflags_dispoffset_bit)|
  347.                          bit(arrayflags_notbytep_bit)|Atype_String_Char,
  348.                          1,
  349.                          string_type
  350.                         );
  351.     }
  352.  
  353.  
  354. # =============================================================================
  355. # LISP - Funktionen fⁿr Readtables
  356. # =============================================================================
  357.  
  358. # Fehler, wenn Argument keine Readtable ist.
  359. # fehler_readtable(obj);
  360. # > obj: fehlerhaftes Argument
  361. # > subr_self: Aufrufer (ein SUBR)
  362.   nonreturning_function(local, fehler_readtable, (object obj));
  363.   local void fehler_readtable(obj)
  364.     var reg1 object obj;
  365.     { pushSTACK(obj); # Wert fⁿr Slot DATUM von TYPE-ERROR
  366.       pushSTACK(S(readtable)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  367.       pushSTACK(obj);
  368.       pushSTACK(TheSubr(subr_self)->name);
  369.       fehler(type_error,
  370.              DEUTSCH ? "~: Argument ~ ist keine Readtable." :
  371.              ENGLISH ? "~: argument ~ is not a readtable" :
  372.              FRANCAIS ? "~ : L'argument ~ n'est pas un ½readtable╗." :
  373.              ""
  374.             );
  375.     }
  376.  
  377. LISPFUN(copy_readtable,0,2,norest,nokey,0,NIL)
  378. # (COPY-READTABLE [from-readtable [to-readtable]]), CLTL S. 361
  379.   { var reg1 object from_readtable = STACK_1;
  380.     if (eq(from_readtable,unbound))
  381.       # gar keine Argumente angegeben
  382.       { get_readtable(from_readtable=); # aktuelle Readtable
  383.         value1 = copy_readtable(from_readtable); # kopieren
  384.       }
  385.       else
  386.       { if (nullp(from_readtable))
  387.           # statt NIL nimm die Standard-Readtable
  388.           { from_readtable = O(standard_readtable); }
  389.           else
  390.           # from-readtable ⁿberprⁿfen:
  391.           { if (!readtablep(from_readtable)) { fehler_readtable(from_readtable); } }
  392.         # from-readtable ist OK
  393.        {var reg2 object to_readtable = STACK_0;
  394.         if (eq(to_readtable,unbound) || nullp(to_readtable))
  395.           # kopiere from-readtable, ohne to-readtable
  396.           { value1 = copy_readtable(from_readtable); }
  397.           else
  398.           # to-readtable ⁿberprⁿfen und umkopieren:
  399.           { if (!readtablep(to_readtable)) { fehler_readtable(to_readtable); }
  400.             value1 = copy_readtable_contents(from_readtable,to_readtable);
  401.           }
  402.       }}
  403.     mv_count=1; skipSTACK(2);
  404.   }
  405.  
  406. LISPFUN(set_syntax_from_char,2,2,norest,nokey,0,NIL)
  407. # (SET-SYNTAX-FROM-CHAR to-char from-char [to-readtable [from-readtable]]),
  408. # CLTL S. 361
  409.   { var reg3 object to_char = STACK_3;
  410.     var reg4 object from_char = STACK_2;
  411.     var reg2 object to_readtable = STACK_1;
  412.     var reg1 object from_readtable = STACK_0;
  413.     skipSTACK(4);
  414.     # to-char ⁿberprⁿfen:
  415.     if (!string_char_p(to_char)) { fehler_string_char(to_char); } # mu▀ ein String-Char sein
  416.     # from-char ⁿberprⁿfen:
  417.     if (!string_char_p(from_char)) { fehler_string_char(from_char); } # mu▀ ein String-Char sein
  418.     # to-readtable ⁿberprⁿfen:
  419.     if (eq(to_readtable,unbound))
  420.       { get_readtable(to_readtable=); } # Default ist die aktuelle Readtable
  421.       else
  422.       { if (!readtablep(to_readtable)) { fehler_readtable(to_readtable); } }
  423.     # from-readtable ⁿberprⁿfen:
  424.     if (eq(from_readtable,unbound) || nullp(from_readtable))
  425.       { from_readtable = O(standard_readtable); } # Default ist die Standard-Readtable
  426.       else
  427.       { if (!readtablep(from_readtable)) { fehler_readtable(from_readtable); } }
  428.     # Nun sind to_char, from_char, to_readtable, from_readtable OK.
  429.     { var reg5 uintL to_c = char_code(to_char);
  430.       var reg6 uintL from_c = char_code(from_char);
  431.       # Syntaxcode kopieren:
  432.       TheSbvector(TheReadtable(to_readtable)->readtable_syntax_table)->data[to_c] =
  433.         TheSbvector(TheReadtable(from_readtable)->readtable_syntax_table)->data[from_c];
  434.       # Macro-Funktion/Vektor kopieren:
  435.      {var reg1 object entry =
  436.         TheSvector(TheReadtable(from_readtable)->readtable_macro_table)->data[from_c];
  437.       if (simple_vector_p(entry))
  438.         # Ist entry ein Simple-Vector, so mu▀ er kopiert werden:
  439.         { pushSTACK(to_readtable);
  440.           entry = copy_svector(entry);
  441.           to_readtable = popSTACK();
  442.         }
  443.       TheSvector(TheReadtable(to_readtable)->readtable_macro_table)->data[to_c] =
  444.         entry;
  445.     }}
  446.     value1 = T; mv_count=1; # Wert T
  447.   }
  448.  
  449. # UP: ▄berprⁿft ein optionales Readtable-Argument,
  450. # mit Default = Current Readtable.
  451. # > STACK_0: Argument
  452. # > subr_self: Aufrufer (ein SUBR)
  453. # < STACK: um 1 erh÷ht
  454. # < ergebnis: readtable
  455.   local object test_readtable_arg (void);
  456.   local object test_readtable_arg()
  457.     { var reg1 object readtable = popSTACK();
  458.       if (eq(readtable,unbound))
  459.         { get_readtable(readtable=); } # Default ist die aktuelle Readtable
  460.         else
  461.         { if (!readtablep(readtable)) { fehler_readtable(readtable); } } # ⁿberprⁿfen
  462.       return readtable;
  463.     }
  464.  
  465. # UP: ▄berprⁿft ein optionales Readtable-Argument,
  466. # mit Default = Current Readtable, NIL = Standard-Readtable.
  467. # > STACK_0: Argument
  468. # > subr_self: Aufrufer (ein SUBR)
  469. # < STACK: um 1 erh÷ht
  470. # < ergebnis: readtable
  471.   local object test_readtable_null_arg (void);
  472.   local object test_readtable_null_arg()
  473.     { var reg1 object readtable = popSTACK();
  474.       if (eq(readtable,unbound))
  475.         { get_readtable(readtable=); } # Default ist die aktuelle Readtable
  476.       elif (nullp(readtable))
  477.         { readtable = O(standard_readtable); } # bzw. die Standard-Readtable
  478.       else
  479.         { if (!readtablep(readtable)) { fehler_readtable(readtable); } } # ⁿberprⁿfen
  480.       return readtable;
  481.     }
  482.  
  483. # UP: ▄berprⁿft das vorletzte optionale Argument von
  484. # SET-MACRO-CHARACTER und MAKE-DISPATCH-MACRO-CHARACTER.
  485. # > STACK_0: non-terminating-p - Argument
  486. # > subr_self: Aufrufer (ein SUBR)
  487. # < STACK: um 1 erh÷ht
  488. # < ergebnis: neuer Syntaxcode
  489.   local uintB test_nontermp_arg (void);
  490.   local uintB test_nontermp_arg()
  491.     { var reg1 object arg = popSTACK();
  492.       if (eq(arg,unbound) || nullp(arg))
  493.         { return syntax_t_macro; } # Default ist terminating
  494.         else
  495.         { return syntax_nt_macro; } # non-terminating-p angegeben und /= NIL
  496.     }
  497.  
  498. LISPFUN(set_macro_character,2,2,norest,nokey,0,NIL)
  499. # (SET-MACRO-CHARACTER char function [non-terminating-p [readtable]]),
  500. # CLTL S. 362
  501.   { # char ⁿberprⁿfen:
  502.     { var reg1 object ch = STACK_3;
  503.       if (!string_char_p(ch)) { fehler_string_char(ch); }
  504.     }
  505.     # function ⁿberprⁿfen und in ein Objekt vom Typ FUNCTION umwandeln:
  506.     STACK_2 = coerce_function(STACK_2);
  507.    {var reg1 object readtable = test_readtable_arg(); # Readtable
  508.     var reg4 uintB syntaxcode = test_nontermp_arg(); # neuer Syntaxcode
  509.     var reg3 object function = popSTACK();
  510.     var reg2 uintL c = char_code(popSTACK());
  511.     # Syntaxcode setzen:
  512.     TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[c] =
  513.       syntaxcode;
  514.     # Macrodefinition eintragen:
  515.     TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[c] =
  516.       function;
  517.     value1 = T; mv_count=1; # 1 Wert T
  518.   }}
  519.  
  520. LISPFUN(get_macro_character,1,1,norest,nokey,0,NIL)
  521. # (GET-MACRO-CHARACTER char [readtable]), CLTL S. 362
  522.   { # char ⁿberprⁿfen:
  523.     { var reg1 object ch = STACK_1;
  524.       if (!string_char_p(ch)) { fehler_string_char(ch); }
  525.     }
  526.    {var reg1 object readtable = test_readtable_null_arg(); # Readtable
  527.     var reg4 object ch = popSTACK();
  528.     var reg2 uintL c = char_code(ch);
  529.     # Teste den Syntaxcode:
  530.     var reg3 object nontermp = NIL; # non-terminating-p Flag
  531.     switch (TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[c])
  532.       { case syntax_nt_macro: nontermp = T;
  533.         case syntax_t_macro: # nontermp = NIL;
  534.           # c ist ein Macro-Character.
  535.           { var reg1 object entry =
  536.               TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[c];
  537.             if (simple_vector_p(entry))
  538.               # c ist ein Dispatch-Macro-Character.
  539.               { pushSTACK(ch);
  540.                 pushSTACK(TheSubr(subr_self)->name);
  541.                 fehler(error,
  542.                        DEUTSCH ? "~: ~ ist ein Dispatch-Macro-Zeichen." :
  543.                        ENGLISH ? "~: ~ is a dispatch macro character" :
  544.                        FRANCAIS ? "~ : ~ est un caractΦre de ½macro-dispatch╗." :
  545.                        ""
  546.                       );
  547.               }
  548.               # Besser wΣre es, eine Funktion zurⁿckzugeben, die den Vektor
  549.               # mit den Dispatch-Macro-Zeichen-Definitionen enthΣlt, und bei
  550.               # SET-MACRO-CHARACTER auf eine solche Funktion zu testen. ??
  551.               else
  552.               { value1 = entry; break; }
  553.           }
  554.         default: # nontermp = NIL;
  555.           value1 = NIL; break;
  556.       }
  557.     value2 = nontermp; mv_count=2; # nontermp als 2. Wert
  558.   }}
  559.  
  560. LISPFUN(make_dispatch_macro_character,1,2,norest,nokey,0,NIL)
  561. # (MAKE-DISPATCH-MACRO-CHARACTER char [non-terminating-p [readtable]]),
  562. # CLTL S. 363
  563.   { var reg1 object readtable = test_readtable_arg(); # Readtable
  564.     var reg5 uintB syntaxcode = test_nontermp_arg(); # neuer Syntaxcode
  565.     # char ⁿberprⁿfen:
  566.     var reg3 object ch = popSTACK();
  567.     if (!string_char_p(ch)) { fehler_string_char(ch); }
  568.    {var reg2 uintL c = char_code(ch);
  569.     # neue (leere) Dispatch-Macro-Tabelle holen:
  570.     pushSTACK(readtable);
  571.     {var reg4 object dm_table = allocate_vector(DRM_anzahl); # Vektor, mit NIL gefⁿllt
  572.      readtable = popSTACK();
  573.     # alles in der Readtable ablegen:
  574.      # Syntaxcode in die Syntax-Table:
  575.      TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[c] =
  576.        syntaxcode;
  577.      # neue Dispatch-Macro-Tabelle in die Macrodefinitionen-Tabelle:
  578.      TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[c] =
  579.        dm_table;
  580.     }
  581.     value1 = T; mv_count=1; # 1 Wert T
  582.   }}
  583.  
  584. # UP: ▄berprⁿft die Argumente disp-char und sub-char.
  585. # > STACK: STACK_1 = disp-char, STACK_0 = sub-char
  586. # > readtable: Readtable
  587. # > subr_self: Aufrufer (ein SUBR)
  588. # < STACK: um 2 erh÷ht (au▀er wenn sub-char eine Ziffer ist)
  589. # < ergebnis: Pointer auf den zu sub-char geh÷renden Eintrag in der
  590. #             Dispatch-Macro-Tabelle zu disp-char,
  591. #             NULL falls sub-char eine Ziffer ist.
  592.   local object* test_disp_sub_char (object readtable);
  593.   local object* test_disp_sub_char(readtable)
  594.     var reg1 object readtable;
  595.     { var reg6 object sub_ch = popSTACK(); # sub-char
  596.       var reg5 object disp_ch = popSTACK(); # disp-char
  597.       if (!string_char_p(disp_ch)) { fehler_string_char(disp_ch); } # disp-char mu▀ ein String-Char sein
  598.       if (!string_char_p(sub_ch)) { fehler_string_char(sub_ch); } # sub-char mu▀ ein String-Char sein
  599.      {var reg4 uintL disp_c = char_code(disp_ch);
  600.       var reg2 object entry = TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[disp_c];
  601.       if (!simple_vector_p(entry))
  602.         { pushSTACK(disp_ch);
  603.           pushSTACK(TheSubr(subr_self)->name);
  604.           fehler(error,
  605.                  DEUTSCH ? "~: ~ ist kein Dispatch-Macro-Zeichen." :
  606.                  ENGLISH ? "~: ~ is not a dispatch macro character" :
  607.                  FRANCAIS ? "~ : ~ n'est pas un caractΦre de ½macro-dispatch╗." :
  608.                  ""
  609.                 );
  610.         }
  611.       # disp-char ist ein Dispatching-Macro-Character, entry der Vektor.
  612.       {var reg3 uintB sub_c = up_case(char_code(sub_ch)); # sub-char in Gro▀buchstaben umwandeln
  613.        if ((sub_c >= '0') && (sub_c <= '9'))
  614.          # Ziffer
  615.          { pushSTACK(sub_ch); return (object*)NULL; }
  616.          else
  617.          # gⁿltiges sub-char
  618.          { return &TheSvector(entry)->data[(uintP)sub_c]; }
  619.     }}}
  620.  
  621. LISPFUN(set_dispatch_macro_character,3,1,norest,nokey,0,NIL)
  622. # (SET-DISPATCH-MACRO-CHARACTER disp-char sub-char function [readtable]),
  623. # CLTL S. 364
  624.   { # function ⁿberprⁿfen und in ein Objekt vom Typ FUNCTION umwandeln:
  625.     STACK_1 = coerce_function(STACK_1);
  626.    {var reg2 object readtable = test_readtable_arg(); # Readtable
  627.     var reg3 object function = popSTACK(); # function
  628.     var reg1 object* ptr = test_disp_sub_char(readtable);
  629.     if (ptr == (object*)NULL)
  630.       { # STACK_0 = sub-char, Wert fⁿr Slot DATUM von TYPE-ERROR
  631.         pushSTACK(O(type_not_digit)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  632.         pushSTACK(STACK_1);
  633.         pushSTACK(TheSubr(subr_self)->name);
  634.         fehler(type_error,
  635.                DEUTSCH ? "~: Ziffer $ als sub-char nicht erlaubt." :
  636.                ENGLISH ? "~: digit $ not allowed as sub-char" :
  637.                FRANCAIS ? "~ : Un chiffre $ n'est pas permis comme sous-caractΦre." :
  638.                ""
  639.               );
  640.       }
  641.       else
  642.       { *ptr = function; # Funktion in die Dispatch-Macro-Tabelle eintragen
  643.         value1 = T; mv_count=1; # 1 Wert T
  644.       }
  645.   }}
  646.  
  647. LISPFUN(get_dispatch_macro_character,2,1,norest,nokey,0,NIL)
  648. # (GET-DISPATCH-MACRO-CHARACTER disp-char sub-char [readtable]), CLTL S. 364
  649.   { var reg2 object readtable = test_readtable_null_arg(); # Readtable
  650.     var reg1 object* ptr = test_disp_sub_char(readtable);
  651.     value1 = (ptr == (object*)NULL ? NIL : *ptr); mv_count=1; # NIL oder Funktion als Wert
  652.   }
  653.  
  654. LISPFUNN(readtable_case,1)
  655. # (READTABLE-CASE readtable), CLTL2 S. 549
  656.   { var reg1 object readtable = popSTACK(); # Readtable
  657.     if (!readtablep(readtable)) { fehler_readtable(readtable); } # ⁿberprⁿfen
  658.     value1 = (&O(rtcase_0))[(uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case)];
  659.     mv_count=1;
  660.   }
  661.  
  662. LISPFUNN(set_readtable_case,2)
  663. # (SYSTEM::SET-READTABLE-CASE readtable value), CLTL2 S. 549
  664.   { var reg4 object value = popSTACK();
  665.     var reg5 object readtable = popSTACK(); # Readtable
  666.     if (!readtablep(readtable)) { fehler_readtable(readtable); } # ⁿberprⁿfen
  667.     # Symbol value in einen Index umwandeln durch Suche in der Tabelle O(rtcase..):
  668.    {var reg1 object* ptr = &O(rtcase_0);
  669.     var reg3 object rtcase = Fixnum_0;
  670.     var reg2 uintC count;
  671.     dotimesC(count,3,
  672.       { if (eq(*ptr,value)) goto found;
  673.         ptr++; rtcase = fixnum_inc(rtcase,1);
  674.       });
  675.     # kein gⁿltiger Wert
  676.     pushSTACK(value); # Wert fⁿr Slot DATUM von TYPE-ERROR
  677.     pushSTACK(O(type_rtcase)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  678.     pushSTACK(O(rtcase_2)); pushSTACK(O(rtcase_1)); pushSTACK(O(rtcase_0));
  679.     pushSTACK(value);
  680.     pushSTACK(S(set_readtable_case));
  681.     fehler(type_error,
  682.            DEUTSCH ? "~: neuer Wert ~ sollte ~, ~ oder ~ sein." :
  683.            ENGLISH ? "~: new value ~ should be ~, ~ or ~." :
  684.            FRANCAIS ? "~ : La nouvelle valeur ~ devrait Ωtre ~, ~ ou ~." :
  685.            ""
  686.           );
  687.     found: # in der Tabelle gefunden
  688.     TheReadtable(readtable)->readtable_case = rtcase;
  689.     value1 = value; mv_count=1;
  690.   }}
  691.  
  692. # =============================================================================
  693. # Einige Hilfsroutinen und Macros fⁿr READ und PRINT
  694. # =============================================================================
  695.  
  696. # Testet den dynamischen Wert eines Symbols auf /=NIL
  697. # < TRUE, wenn /= NIL
  698. # #define test_value(sym)  (!nullp(Symbol_value(sym)))
  699.   #define test_value(sym)  (!eq(NIL,Symbol_value(sym)))
  700.  
  701. # UP: Holt den Wert eines Symbols. Mu▀ Fixnum >=2, <=36 sein.
  702. # get_base(symbol)
  703. # > symbol: Symbol
  704. # < ergebnis: Wert des Symbols, >=2, <=36.
  705.   local uintL get_base (object symbol);
  706.   local uintL get_base(symbol)
  707.     var reg3 object symbol;
  708.     { var reg2 object value = Symbol_value(symbol);
  709.       var reg1 uintL wert;
  710.       if (posfixnump(value) &&
  711.           (wert = posfixnum_to_L(value), ((wert >= 2) && (wert <= 36)))
  712.          )
  713.         { return wert; }
  714.         else
  715.         { Symbol_value(symbol) = fixnum(10); # Wert auf 10 setzen
  716.           pushSTACK(value); # Wert fⁿr Slot DATUM von TYPE-ERROR
  717.           pushSTACK(O(type_radix)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  718.           pushSTACK(value);
  719.           pushSTACK(symbol);
  720.           fehler(type_error,
  721.                  DEUTSCH ? "Der Wert von ~ sollte eine ganze Zahl zwischen 2 und 36 sein, nicht ~." NLstring
  722.                            "Er wird auf 10 gesetzt." :
  723.                  ENGLISH ? "The value of ~ should be an integer between 2 and 36, not ~." NLstring
  724.                            "It has been reset to 10." :
  725.                  FRANCAIS ? "La valeur de ~ doit Ωtre un nombre entier entre 2 et 36 et non ~." NLstring
  726.                             "Elle a ΘtΘ mise α 10." :
  727.                  ""
  728.                 );
  729.         }
  730.     }
  731.  
  732. # UP: Holt den Wert von *PRINT-BASE*
  733. # get_print_base()
  734. # < uintL ergebnis: >=2, <=36
  735.   #define get_print_base()  \
  736.     (test_value(S(print_readably)) ? 10 : get_base(S(print_base)))
  737.  
  738. # UP: Holt den Wert von *READ-BASE*
  739. # get_read_base()
  740. # < uintL ergebnis: >=2, <=36
  741.   #define get_read_base()  get_base(S(read_base))
  742.  
  743.  
  744. # =============================================================================
  745. #                              R E A D
  746. # =============================================================================
  747.  
  748. # Es werden einzelne Characters gelesen.
  749. # Mit Hilfe der Readtable werden Syntaxcodes (vgl. CLTL Table 22-1) gebildet.
  750. # Bei Syntaxcode = constituent wird ein (Extended) Token angefangen.
  751. # Mit Hilfe der Attributtabelle (vgl. CLTL Table 22-3) wird jedem Character
  752. # im Token ein Attribut a_xxxx zugeordnet.
  753. # O(token_buff_1) ist ein Semi-Simple-String, der die Characters des
  754. # gerade eingelesenen Extended-Tokens enthΣlt.
  755. # O(token_buff_2) ist ein Semi-Simple-String, der die Attribute des
  756. # gerade eingelesenen Extended-Tokens enthΣlt.
  757. # Beide haben dieselbe LΣnge.
  758.  
  759. # Spezielle Objekte, die bei READ als Ergebnis kommen k÷nnen:
  760. #   eof_value: spezielles Objekt, das EOF anzeigt
  761. #   dot_value: Hilfswert zum Erkennen einzelner Dots
  762.  
  763. # ------------------------ READ auf Character-Ebene ---------------------------
  764.  
  765. # Fehler, wenn Zeichen kein String-Char ist:
  766. # fehler_charread(ch,&stream);
  767.   nonreturning_function(local, fehler_charread, (object ch, object* stream_));
  768.   local void fehler_charread(ch,stream_)
  769.     var reg2 object ch;
  770.     var reg1 object* stream_;
  771.     { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  772.       pushSTACK(ch); # Character
  773.       pushSTACK(*stream_); # Stream
  774.       pushSTACK(S(read));
  775.       fehler(stream_error,
  776.              DEUTSCH ? "~ von ~: Gelesenes Zeichen ist kein String-Char: ~" :
  777.              ENGLISH ? "~ from ~: character read should be a string-char: ~" :
  778.              FRANCAIS ? "~ de ~ : le caractΦre lu n'est pas de type STRING-CHAR." :
  779.              ""
  780.             );
  781.     }
  782.  
  783. # UP: Liest ein Zeichen und berechnet seinen Syntaxcode.
  784. # read_char_syntax(ch=,scode=,&stream);
  785. # > stream: Stream
  786. # < stream: Stream
  787. # < object ch: String-Char oder eof_value
  788. # < uintWL scode: Syntaxcode (aus der aktuellen Readtable) bzw. syntax_eof
  789. # kann GC ausl÷sen
  790.   #define read_char_syntax(ch_zuweisung,scode_zuweisung,stream_)  \
  791.     { var reg1 object ch0 = read_char(stream_); # Character lesen      \
  792.       ch_zuweisung ch0;                                                \
  793.       if (eq(ch0,eof_value)) # EOF ?                                   \
  794.         { scode_zuweisung syntax_eof; }                                \
  795.         else                                                           \
  796.         # sonst Character.                                             \
  797.         { # Auf String-Char ⁿberprⁿfen:                                \
  798.           if (!string_char_p(ch0)) { fehler_charread(ch0,stream_); }   \
  799.          {var reg2 object readtable;                                   \
  800.           get_readtable(readtable = );                                 \
  801.           scode_zuweisung # Syntaxcode aus Tabelle holen               \
  802.             TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[(uintP)char_code(ch0)]; \
  803.         }}                                                             \
  804.     }
  805.  
  806. # Case-Konversion:
  807.   typedef uintB case_converter (uintB c);
  808.   local uintB preserve_case (uintB c);
  809.   local uintB preserve_case(c)
  810.     var reg1 uintB c;
  811.     { return c; }
  812.  
  813. # Fehlermeldung bei EOF au▀erhalb von Objekten
  814. # fehler_eof_aussen(&stream);
  815. # > stream: Stream
  816.   nonreturning_function(local, fehler_eof_aussen, (object* stream_));
  817.   local void fehler_eof_aussen(stream_)
  818.     var reg1 object* stream_;
  819.     { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  820.       pushSTACK(*stream_); # Stream
  821.       pushSTACK(S(read));
  822.       fehler(end_of_file,
  823.              DEUTSCH ? "~: Eingabestream ~ ist zu Ende." :
  824.              ENGLISH ? "~: input stream ~ has reached its end" :
  825.              FRANCAIS ? "~ : Le ½stream╗ d'entrΘe ~ est ΘpuisΘ." :
  826.              ""
  827.             );
  828.     }
  829.  
  830. # Fehlermeldung bei EOF innerhalb von Objekten
  831. # fehler_eof_innen(&stream);
  832. # > stream: Stream
  833.   nonreturning_function(local, fehler_eof_innen, (object* stream_));
  834.   local void fehler_eof_innen(stream_)
  835.     var reg1 object* stream_;
  836.     { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  837.       if (mposfixnump(Symbol_value(S(read_line_number)))) # SYS::*READ-LINE-NUMBER* abfragen
  838.         { pushSTACK(Symbol_value(S(read_line_number))); # Zeilennummer
  839.           pushSTACK(*stream_); # Stream
  840.           pushSTACK(S(read));
  841.           fehler(end_of_file,
  842.                  DEUTSCH ? "~: Eingabestream ~ endet innerhalb eines Objekts. Letzte ÷ffnende Klammer vermutlich in Zeile ~." :
  843.                  ENGLISH ? "~: input stream ~ ends within an object. Last opening parenthesis probably in line ~." :
  844.                  FRANCAIS ? "~ : Le ½stream╗ d'entrΘe ~ se termine α l'intΘrieur d'un objet. La derniΦre parenthΦse ouverte se trouve probablement dans la ligne ~." :
  845.                  ""
  846.                 );
  847.         }
  848.         else
  849.         { pushSTACK(*stream_); # Stream
  850.           pushSTACK(S(read));
  851.           fehler(end_of_file,
  852.                  DEUTSCH ? "~: Eingabestream ~ endet innerhalb eines Objekts." :
  853.                  ENGLISH ? "~: input stream ~ ends within an object" :
  854.                  FRANCAIS ? "~ : Le ½stream╗ d'entrΘe ~ se termine α l'intΘrieur d'un objet." :
  855.                  ""
  856.                 );
  857.     }   }
  858.  
  859. # Fehlermeldung bei EOF, je nach *READ-RECURSIVE-P*
  860. # fehler_eof(&stream);
  861. # > stream: Stream
  862.   nonreturning_function(local, fehler_eof, (object* stream_));
  863.   local void fehler_eof(stream_)
  864.     var reg1 object* stream_;
  865.     { if (test_value(S(read_recursive_p))) # *READ-RECURSIVE-P* /= NIL ?
  866.         { fehler_eof_innen(stream_); }
  867.         else
  868.         { fehler_eof_aussen(stream_); }
  869.     }
  870.  
  871. # UP: Liest bis zum nΣchsten non-whitespace-Zeichen, ohne dieses zu
  872. # verbrauchen. Bei EOF Error.
  873. # wpeek_char_syntax(ch=,scode=,&stream);
  874. # > stream: Stream
  875. # < stream: Stream
  876. # < object ch: nΣchstes String-Char
  877. # < uintWL scode: sein Syntaxcode
  878. # kann GC ausl÷sen
  879.   #define wpeek_char_syntax(ch_zuweisung,scode_zuweisung,stream_)  \
  880.     { loop                                                                 \
  881.         { var reg1 object ch0 = read_char(stream_); # Character lesen      \
  882.           if (eq(ch0,eof_value)) { fehler_eof(stream_); } # EOF -> Error   \
  883.           # sonst Character.                                               \
  884.           # Auf String-Char ⁿberprⁿfen:                                    \
  885.           if (!string_char_p(ch0)) { fehler_charread(ch0,stream_); }       \
  886.           {var reg2 object readtable;                                      \
  887.            get_readtable(readtable = );                                    \
  888.            if (!((scode_zuweisung # Syntaxcode aus Tabelle holen           \
  889.                     TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[(uintP)char_code(ch0)] \
  890.                  )                                                         \
  891.                  == syntax_whitespace                                      \
  892.               ) )                                                          \
  893.              # kein Whitespace -> letztes gelesenes Zeichen zurⁿckschieben \
  894.              { unread_char(stream_,ch0); ch_zuweisung ch0; break; }        \
  895.         } }                                                                \
  896.     }
  897.  
  898. # UP: Liest bis zum nΣchsten non-whitespace-Zeichen, ohne dieses zu
  899. # verbrauchen.
  900. # wpeek_char_eof(&stream)
  901. # > stream: Stream
  902. # < stream: Stream
  903. # < ergebnis: nΣchstes String-Char oder eof_value
  904. # kann GC ausl÷sen
  905.   local object wpeek_char_eof (object* stream_);
  906.   local object wpeek_char_eof(stream_)
  907.     var reg3 object* stream_;
  908.     { loop
  909.         { var reg1 object ch = read_char(stream_); # Character lesen
  910.           if (eq(ch,eof_value)) { return ch; } # EOF ?
  911.           # sonst Character.
  912.           # Auf String-Char ⁿberprⁿfen:
  913.           if (!string_char_p(ch)) { fehler_charread(ch,stream_); }
  914.           {var reg2 object readtable;
  915.            get_readtable(readtable = );
  916.            if (!(( # Syntaxcode aus Tabelle holen
  917.                   TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[(uintP)char_code(ch)]
  918.                  )
  919.                  == syntax_whitespace
  920.               ) )
  921.              # kein Whitespace -> letztes gelesenes Zeichen zurⁿckschieben
  922.              { unread_char(stream_,ch); return ch; }
  923.         } }
  924.     }
  925.  
  926. # ------------------------ READ auf Token-Ebene -------------------------------
  927.  
  928. # Bei read_token und test_potential_number_syntax, test_number_syntax werden
  929. # die Attribute gemΣ▀ CLTL Table 22-3 gebraucht.
  930. # WΣhrend test_potential_number_syntax werden Attribute umgewandelt,
  931. # a_digit teilweise in a_alpha oder a_letter oder a_expo_m.
  932.  
  933. # Bedeutung der EintrΣge in attribute_table:
  934.   #define a_illg     0   # illegales Constituent
  935.   #define a_pack_m   1   # ':' = Package-marker
  936.   #define a_alpha    2   # Zeichen ohne besondere Eigenschaften (alphabetic)
  937.   #define a_ratio    3   # '/'
  938.   #define a_dot      4   # '.'
  939.   #define a_plus     5   # '+'
  940.   #define a_minus    6   # '-'
  941.   #define a_extens   7   # '_^' extension characters
  942.   #define a_digit    8   # '0123456789'
  943.   #define a_letter   9   # 'A'-'Z','a'-'z', nicht 'esfdlESFDL'
  944.   #define a_expo_m  10   # 'esfdlESFDL'
  945.   #    >= a_letter       #  'A'-'Z','a'-'z'
  946.   #    >= a_digit        # '0123456789','A'-'Z','a'-'z'
  947.   #    >= a_ratio        # woraus eine potential number bestehen mu▀
  948.  
  949. # Attributtabelle fⁿr Constituents, Erstinterpretation:
  950. # Anmerkung: 0-9,A-Z,a-z werden erst als a_digit oder a_expo_m interpretiert,
  951. # dann (falls sich kein Integer aus einem Token ergibt) wird a_digit
  952. # oberhalb von *READ-BASE* als a_alpha (alphabetic) interpretiert.
  953.   local uintB attribute_table[RM_anzahl] = {
  954.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(0) bis chr(7)
  955.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(8) bis chr(15)
  956.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(16) bis chr(23)
  957.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(24) bis chr(31)
  958.     a_illg,  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # ' !"#$%&''
  959.     a_alpha, a_alpha, a_alpha, a_plus,  a_alpha, a_minus, a_dot,   a_ratio,  # '()*+,-./'
  960.     a_digit, a_digit, a_digit, a_digit, a_digit, a_digit, a_digit, a_digit,  # '01234567'
  961.     a_digit, a_digit, a_pack_m,a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '89:;<=>?'
  962.     a_alpha, a_letter,a_letter,a_letter,a_expo_m,a_expo_m,a_expo_m,a_letter, # '@ABCDEFG'
  963.     a_letter,a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter, # 'HIJKLMNO'
  964.     a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter,a_letter, # 'PQRSTUVW'
  965.     a_letter,a_letter,a_letter,a_alpha, a_alpha, a_alpha, a_extens,a_extens, # 'XYZ[\]^_'
  966.     a_alpha, a_letter,a_letter,a_letter,a_expo_m,a_expo_m,a_expo_m,a_letter, # '`abcdefg'
  967.     a_letter,a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter, # 'hijklmno'
  968.     a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter,a_letter, # 'pqrstuvw'
  969.     a_letter,a_letter,a_letter,a_alpha, a_alpha, a_alpha, a_alpha,           # 'xyz{|}~'
  970.     #if defined(ATARI_CHS) || defined(IBMPC_CHS)                             # ATARI_CHS:
  971.                                                                    a_alpha,  # chr(127)
  972.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '╟ⁿΘΓΣαστ'
  973.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'ΩδΦ∩ε∞─┼'
  974.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '╔µ╞⌠÷≥√∙'
  975.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # ' ╓▄óúÑ▀ '
  976.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'ßφ≤·±╤¬o'
  977.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '┐ ¼╜╝í½╗'
  978.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'π⌡╪°  └├'
  979.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '╒¿┤ ╢⌐« '
  980.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' hebrΣische Buchstaben
  981.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' hebrΣische Buchstaben
  982.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' hebrΣische Buchstaben
  983.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '     º  ' hebrΣische Buchstaben und Symbole
  984.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '      ╡ ' griechische Buchstaben
  985.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' griechische Buchstaben und Symbole
  986.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # ' ▒    ≈ ' Symbole
  987.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '░    ▓│»' Symbole
  988.     #elif defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS)
  989.                                                                    a_illg,
  990.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  991.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  992.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  993.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  994.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  995.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  996.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  997.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  998.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  999.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1000.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1001.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1002.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1003.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1004.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1005.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1006.     #elif defined(NEXTSTEP_CHS)
  1007.                                                                    a_illg,
  1008.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1009.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1010.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1011.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1012.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1013.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1014.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1015.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1016.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1017.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1018.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1019.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1020.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1021.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1022.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1023.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1024.     #else # defined(ASCII_CHS)
  1025.                                                                    a_illg,
  1026.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1027.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1028.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1029.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1030.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1031.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1032.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1033.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1034.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1035.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1036.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1037.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1038.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1039.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1040.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1041.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1042.     #endif
  1043.     };
  1044.  
  1045. # Flag. Zeigt an, ob im letztgelesenen Token
  1046. # ein Single-Escape- oder Multiple-Escape-Zeichen vorkam:
  1047.   local boolean token_escape_flag;
  1048.  
  1049. # UP: Liefert zwei Buffer.
  1050. # Falls im Reservoir O(token_buff_1), O(token_buff_2) zwei verfⁿgbar sind,
  1051. # werden sie entnommen. Sonst werden neue alloziert.
  1052. # Werden die Buffer nicht mehr gebraucht, so k÷nnen sie in
  1053. # O(token_buff_1) und O(token_buff_2) geschrieben werden.
  1054. # < -(STACK),-(STACK): zwei Semi-Simple Strings mit Fill-Pointer 0
  1055. # < STACK: um 2 erniedrigt
  1056. # kann GC ausl÷sen
  1057.   local void get_buffers (void);
  1058.   local void get_buffers()
  1059.     { # Mechanismus:
  1060.       # In O(token_buff_1) und O(token_buff_2) stehen zwei
  1061.       # Semi-Simple-Strings, die bei Bedarf entnommen (und mit
  1062.       # O(token_buff_1) := NIL als entnommen markiert) und nach Gebrauch
  1063.       # wieder hineingesetzt werden k÷nnen. Reentrant!
  1064.       var reg1 object buff_1 = O(token_buff_1);
  1065.       if (!nullp(buff_1))
  1066.         # Buffer entnehmen und leeren:
  1067.         { TheArray(buff_1)->dims[1] = 0; # Fill-Pointer:=0
  1068.           pushSTACK(buff_1); # 1. Buffer fertig
  1069.          {var reg2 object buff_2 = O(token_buff_2);
  1070.           TheArray(buff_2)->dims[1] = 0; # Fill-Pointer:=0
  1071.           pushSTACK(buff_2); # 2. Buffer fertig
  1072.           O(token_buff_1) = NIL; # Buffer als entnommen markieren
  1073.         }}
  1074.         else
  1075.         # Buffer sind gerade entnommen und mⁿssen neu alloziert werden:
  1076.         { pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String mit Fill-Pointer=0
  1077.           pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String mit Fill-Pointer=0
  1078.         }
  1079.     }
  1080.  
  1081. # UP: Liest ein Extended Token.
  1082. # read_token(&stream);
  1083. # > stream: Stream
  1084. # < stream: Stream
  1085. # < O(token_buff_1): gelesene Characters
  1086. # < O(token_buff_2): ihre Attributcodes
  1087. # < token_escape_flag: Escape-Zeichen-Flag
  1088. # kann GC ausl÷sen
  1089.   local void read_token (object* stream_);
  1090.  
  1091. # UP: Liest ein Extended Token, erstes Zeichen bereits gelesen.
  1092. # read_token_1(&stream,ch,scode);
  1093. # > stream: Stream
  1094. # > ch, scode: erstes Zeichen und sein Syntaxcode
  1095. # < stream: Stream
  1096. # < O(token_buff_1): gelesene Characters
  1097. # < O(token_buff_2): ihre Attributcodes
  1098. # < token_escape_flag: Escape-Zeichen-Flag
  1099. # kann GC ausl÷sen
  1100.   local void read_token_1 (object* stream_, object ch, uintWL scode);
  1101.  
  1102.   local void read_token(stream_)
  1103.     var reg3 object* stream_;
  1104.     { # erstes Zeichen lesen:
  1105.       var reg4 object ch;
  1106.       var reg5 uintWL scode;
  1107.       read_char_syntax(ch = ,scode = ,stream_);
  1108.       # Token aufbauen:
  1109.       read_token_1(stream_,ch,scode);
  1110.     }
  1111.  
  1112.   local void read_token_1(stream_,ch,scode)
  1113.     var reg5 object* stream_;
  1114.     var reg4 object ch;
  1115.     var reg3 uintWL scode;
  1116.     { # leere Token-Buffer holen, auf den STACK:
  1117.       get_buffers(); # (brauche ch nicht zu retten)
  1118.       # Bis zum Ende von read_token_1 liegen die beiden Buffer im Stack.
  1119.       # (So kann read_char rekursiv read aufrufen...)
  1120.       # Danach (wΣhrend test_potential_number_syntax, test_number_syntax,
  1121.       # test_dots, read_internal bis zum Ende von read_internal) liegen
  1122.       # die Buffer in O(token_buff_1) und O(token_buff_2). Nach dem Ende von
  1123.       # read_internal ist ihr Inhalt wertlos, und sie k÷nnen fⁿr weitere
  1124.       # read-Operationen benutzt werden.
  1125.      {var reg8 boolean multiple_escape_flag = FALSE;
  1126.       var reg9 boolean escape_flag = FALSE;
  1127.       # Funktion zur Case-Umwandlung besorgen:
  1128.       var reg7 case_converter* case_convert;
  1129.       {var reg1 object readtable;
  1130.        get_readtable(readtable = );
  1131.        switch ((uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case))
  1132.          { case case_upcase:   case_convert = &up_case; break;
  1133.            case case_downcase: case_convert = &down_case; break;
  1134.            case case_preserve: case_convert = &preserve_case; break;
  1135.            default: NOTREACHED
  1136.       }  }
  1137.       goto char_read;
  1138.       loop
  1139.         { # Hier wird das Token in STACK_1 (Semi-Simple-String fⁿr Characters)
  1140.           # und STACK_0 (Semi-Simple-String fⁿr Attributcodes) aufgebaut.
  1141.           # Multiple-Escape-Flag zeigt an, ob man sich zwischen |...| befindet.
  1142.           # Escape-Flag zeigt an, ob ein Escape-Character vorgekommen ist.
  1143.           read_char_syntax(ch = ,scode = ,stream_); # nΣchstes Zeichen lesen
  1144.           char_read:
  1145.           switch(scode)
  1146.             { case syntax_illegal:
  1147.                 # illegal -> Error melden:
  1148.                 pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1149.                 pushSTACK(ch); # Zeichen
  1150.                 pushSTACK(*stream_); # Stream
  1151.                 pushSTACK(S(read));
  1152.                 fehler(stream_error,
  1153.                        DEUTSCH ? "~ von ~: Zeichen ~ ist nicht erlaubt." :
  1154.                        ENGLISH ? "~ from ~: illegal character ~" :
  1155.                        FRANCAIS ? "~ de ~ : Le caractΦre ~ n'est pas permis ici." :
  1156.                        ""
  1157.                       );
  1158.                 break;
  1159.               case syntax_single_esc:
  1160.                 # Single-Escape-Zeichen ->
  1161.                 # nΣchstes Zeichen lesen und unverΣndert ⁿbernehmen
  1162.                 escape_flag = TRUE;
  1163.                 read_char_syntax(ch = ,scode = ,stream_); # nΣchstes Zeichen lesen
  1164.                 if (scode==syntax_eof) # EOF erreicht?
  1165.                   { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1166.                     pushSTACK(*stream_);
  1167.                     pushSTACK(S(read));
  1168.                     fehler(end_of_file,
  1169.                            DEUTSCH ? "~: Eingabestream ~ endet mitten im Token nach Single-Escape-Zeichen." :
  1170.                            ENGLISH ? "~: input stream ~ ends within a token after single escape character" :
  1171.                            FRANCAIS ? "~ : Le ½stream╗ d'entrΘe ~ se termine α l'intΘrieur d'un lexΦme, suivant un caractΦre de simple Θchappement." :
  1172.                            ""
  1173.                           );
  1174.                   }
  1175.               escape:
  1176.                 # nach Escape-Zeichen:
  1177.                 # Zeichen unverΣndert ins Token ⁿbernehmen
  1178.                 ssstring_push_extend(STACK_1,char_code(ch));
  1179.                 ssstring_push_extend(STACK_0,a_alpha);
  1180.                 break;
  1181.               case syntax_multi_esc:
  1182.                 # Multiple-Escape-Zeichen
  1183.                 multiple_escape_flag = !multiple_escape_flag;
  1184.                 escape_flag = TRUE;
  1185.                 break;
  1186.               case syntax_constituent:
  1187.               case syntax_nt_macro:
  1188.                 # normales Constituent
  1189.                 if (multiple_escape_flag) # Zwischen Multiple-Escape-Zeichen?
  1190.                   goto escape; # ja -> Zeichen unverΣndert ⁿbernehmen
  1191.                 # als Gro▀-/Klein-Buchstabe ins Token ⁿbernehmen:
  1192.                 {var reg1 uintB c = (*case_convert)(char_code(ch));
  1193.                  ssstring_push_extend(STACK_1,c);
  1194.                  ssstring_push_extend(STACK_0,attribute_table[c]);
  1195.                 }
  1196.                 break;
  1197.               case syntax_whitespace:
  1198.               case syntax_t_macro:
  1199.                 # whitespace oder terminating macro ->
  1200.                 # Token endet wohl vor diesem Character.
  1201.                 if (multiple_escape_flag) # Zwischen Multiple-Escape-Zeichen?
  1202.                   goto escape; # ja -> Zeichen unverΣndert ⁿbernehmen
  1203.                 # Token ist zu Ende.
  1204.                 # Schiebe das Character auf den Stream zurⁿck,
  1205.                 # falls es kein Whitespace ist oder
  1206.                 # es ein Whitespace ist und *READ-PRESERVE-WHITESPACE* /= NIL.
  1207.                 if ((!(scode == syntax_whitespace))
  1208.                     || test_value(S(read_preserve_whitespace))
  1209.                    )
  1210.                   { unread_char(stream_,ch); }
  1211.                 goto ende;
  1212.               case syntax_eof:
  1213.                 # EOF erreicht.
  1214.                 if (multiple_escape_flag) # zwischen Multiple-Escape-Zeichen?
  1215.                   { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1216.                     pushSTACK(*stream_);
  1217.                     pushSTACK(S(read));
  1218.                     fehler(end_of_file,
  1219.                            DEUTSCH ? "~: Eingabestream ~ endet mitten im Token nach Multiple-Escape-Zeichen." :
  1220.                            ENGLISH ? "~: input stream ~ ends within a token after multiple escape character" :
  1221.                            FRANCAIS ? "~ : Le ½stream╗ d'entrΘe se termine au milieu d'un lexΦme, suivant un caractΦre de multi-Θchappement." :
  1222.                            ""
  1223.                           );
  1224.                   }
  1225.                 # nein -> Token normal zu Ende
  1226.                 goto ende;
  1227.               default: NOTREACHED
  1228.         }   }
  1229.       ende:
  1230.       # Nun ist Token zu Ende, multiple_escape_flag = FALSE.
  1231.       token_escape_flag = escape_flag; # Escape-Flag abspeichern
  1232.       O(token_buff_2) = popSTACK(); # Attributcode-Buffer
  1233.       O(token_buff_1) = popSTACK(); # Character-Buffer
  1234.     }}
  1235.  
  1236. # --------------- READ zwischen Token-Ebene und Objekt-Ebene ------------------
  1237.  
  1238. # UP: ▄berprⁿft, ob der Token-Buffer eine potential-number enthΣlt, und
  1239. # wandelt, als Vorbereitung auf Zahl-Lese-Routinen, Attributcodes um.
  1240. # test_potential_number_syntax(&base,&token_info);
  1241. # > O(token_buff_1): gelesene Characters
  1242. # > O(token_buff_2): ihre Attributcodes
  1243. # > base: Ziffernsystembasis (Wert von *READ-BASE* oder *PRINT-BASE*)
  1244. # < base: Ziffernsystembasis (= 10 oder altes base)
  1245. # Innerhalb von O(token_buff_2) wird umgewandelt:
  1246. #   Falls potential number:
  1247. #     >=a_letter oberhalb der Ziffernsystembasis -> a_alpha
  1248. #   Falls nicht potential number:
  1249. #     Unterscheidung zwischen [a_pack_m | a_dot | sonstiges] bleibt erhalten.
  1250. # < ergebnis: TRUE, falls potential number vorliegt
  1251. #             (und dann ist token_info mit {charptr, attrptr, len} gefⁿllt)
  1252.   typedef struct { uintB* charptr; uintB* attrptr; uintL len; } token_info;
  1253.   local boolean test_potential_number_syntax (uintWL* base_, token_info* info);
  1254.   local boolean test_potential_number_syntax(base_,info)
  1255.     var reg8 uintWL* base_;
  1256.     var reg9 token_info* info;
  1257.     # Ein Token ist potential number, wenn (CLTL, S. 341)
  1258.     # - es ausschlie▀lich aus Ziffern, '+','-','/','^','_','.' und
  1259.     #   Number-Markern besteht. Die Basis fⁿr die Ziffern ist dabei vom
  1260.     #   Kontext abhΣngig, jedoch immer 10, wenn ein Punkt '.' vorkommt.
  1261.     #   Ein Number-Marker ist ein Buchstabe, der keine Ziffer ist und
  1262.     #   nicht neben einem anderen solchen steht.
  1263.     # - es mindestens eine Ziffer enthΣlt,
  1264.     # - es mit einer Ziffer, '+','-','.','^' oder '_' beginnt,
  1265.     # - es nicht mit '+' oder '-' endet.
  1266.     # ▄berprⁿfung:
  1267.     # 1. Suche, ob ein Punkt vorkommt. Falls ja, Basis:=10.
  1268.     # 2. Alles >=a_letter (also 'A'-'Z','a'-'z'), was einen Wert <Basis hat,
  1269.     #    wird in a_digit umgewandelt.
  1270.     # (Jetzt wird a_digit als "digit" und >=a_letter als "letter" interpretiert.)
  1271.     # 3. Test, ob nur >=a_ratio vorkommen. Nein -> kein potential number.
  1272.     # 4. Test, ob ein a_digit vorkommt. Nein -> kein potential number.
  1273.     # (Jetzt ist die LΣnge >0.)
  1274.     # 5. Test, ob nebeneinanderliegende >=a_letter vorkommen.
  1275.     #    Ja -> kein potential number.
  1276.     # 6. Test, ob erstes Zeichenattribut >=a_dot,<=a_digit.
  1277.     #    Nein -> kein potential number.
  1278.     # 7. Test, ob letztes Zeichenattribut =a_plus oder =a_minus.
  1279.     #    Ja -> kein potential number.
  1280.     # 8. Potential number liegt vor.
  1281.     { var reg7 uintB* charptr0; # Pointer auf die Characters
  1282.       var reg5 uintB* attrptr0; # Pointer auf die Attribute
  1283.       var reg6 uintL len; # LΣnge des Token
  1284.       # initialisieren:
  1285.       { var reg1 object buff = O(token_buff_1); # erster Semi-Simple String
  1286.         len = TheArray(buff)->dims[1]; # LΣnge = Fill-Pointer
  1287.         buff = TheArray(buff)->data; # Simple-String
  1288.         charptr0 = &TheSstring(buff)->data[0]; # ab hier kommen die Characters
  1289.         buff = O(token_buff_2); # zweiter Semi-Simple String
  1290.         buff = TheArray(buff)->data; # Simple-String
  1291.         attrptr0 = &TheSstring(buff)->data[0]; # ab hier kommen die Attributcodes
  1292.       }
  1293.       # 1. Suche, ob ein Punkt vorkommt:
  1294.       { var reg1 uintB* attrptr = attrptr0;
  1295.         var reg2 uintL count;
  1296.         dotimesL(count,len, { if (*attrptr++ == a_dot) goto dot; } );
  1297.         # kein Punkt -> base unverΣndert lassen
  1298.         goto no_dot;
  1299.         # Punkt -> base := 10
  1300.         dot: *base_ = 10;
  1301.         no_dot: ;
  1302.       }
  1303.       # 2. Alles >=a_letter mit Wert <Basis in a_digit umwandeln:
  1304.       { var reg2 uintB* attrptr = attrptr0;
  1305.         var reg3 uintB* charptr = charptr0;
  1306.         var reg4 uintL count;
  1307.         dotimesL(count,len,
  1308.           { if (*attrptr >= a_letter)
  1309.               # Attributcode >= a_letter
  1310.               { var reg1 uintB c = *charptr; # Zeichen, mu▀ 'A'-'Z','a'-'Z' sein
  1311.                 if (c >= 'a') { c -= 'a'-'A'; }
  1312.                 if ((c - 'A') + 10 < *base_) # Wert < Basis ?
  1313.                   { *attrptr = a_digit; } # in a_digit umwandeln
  1314.               }
  1315.             attrptr++; charptr++;
  1316.           });
  1317.       }
  1318.       # 3. Teste, ob nur Attributcodes >=a_ratio vorkommen:
  1319.       { var reg1 uintB* attrptr = attrptr0;
  1320.         var reg2 uintL count;
  1321.         dotimesL(count,len,
  1322.           { if (!(*attrptr++ >= a_ratio))
  1323.               { return FALSE; } # nein -> kein potential number
  1324.           });
  1325.       }
  1326.       # 4. Teste, ob ein a_digit vorkommt:
  1327.       { var reg1 uintB* attrptr = attrptr0;
  1328.         var reg2 uintL count;
  1329.         dotimesL(count,len, { if (*attrptr++ == a_digit) goto digit_ok; } );
  1330.         return FALSE; # kein potential number
  1331.         digit_ok: ;
  1332.       }
  1333.       # LΣnge len>0.
  1334.       # 5. Teste, ob hintereinander zwei Attributcodes >= a_letter kommen:
  1335.       { var reg1 uintB* attrptr = attrptr0;
  1336.         var reg2 uintL count;
  1337.         dotimesL(count,len-1,
  1338.           { if (*attrptr++ >= a_letter)
  1339.               { if (*attrptr >= a_letter)
  1340.                   { return FALSE; }
  1341.               }
  1342.           });
  1343.       }
  1344.       # 6. Teste, ob erster Attributcode >=a_dot, <=a_digit ist:
  1345.       { var reg1 uintB attr = attrptr0[0];
  1346.         if (!((attr >= a_dot) && (attr <= a_digit)))
  1347.           { return FALSE; }
  1348.       }
  1349.       # 7. Teste, ob letzter Attributcode = a_plus oder a_minus ist:
  1350.       { var reg1 uintB attr = attrptr0[len-1];
  1351.         if ((attr == a_plus) || (attr == a_minus))
  1352.           { return FALSE; }
  1353.       }
  1354.       # 8. Potential number liegt vor.
  1355.       info->charptr = charptr0; info->attrptr = attrptr0; info->len = len;
  1356.       return TRUE;
  1357.     }
  1358.  
  1359. # UP: ▄berprⁿft, ob der Token-Buffer eine Zahl enthΣlt (Syntax gemΣ▀ CLTL
  1360. # Table 22-2), und stellt gegebenenfalls die fⁿr die Umwandlung in eine Zahl
  1361. # n÷tigen Parameter zur Verfⁿgung.
  1362. # test_number_syntax(&base,&string,&info)
  1363. # > O(token_buff_1): gelesene Characters
  1364. # > O(token_buff_2): ihre Attributcodes
  1365. # > token_escape_flag: Escape-Zeichen-Flag
  1366. # > base: Ziffernsystembasis (Wert von *READ-BASE* oder *PRINT-BASE*)
  1367. # < base: Ziffernsystembasis
  1368. # < string: Simple-String mit den Characters
  1369. # < info.sign: Vorzeichen (/=0 falls negativ)
  1370. # < ergebnis: Zahl-Typ
  1371. #     0 : keine Zahl (dann sind auch base,string,info bedeutungslos)
  1372. #     1 : Integer
  1373. #         < index1: Index der ersten Ziffer
  1374. #         < index2: Index nach der letzten Ziffer
  1375. #         (also index2-index1 Ziffern, incl. evtl. Dezimalpunkt am Schlu▀)
  1376. #     2 : Rational
  1377. #         < index1: Index der ersten Ziffer
  1378. #         < index3: Index von '/'
  1379. #         < index2: Index nach der letzten Ziffer
  1380. #         (also index3-index1 ZΣhler-Ziffern, index2-index3-1 Nenner-Ziffern)
  1381. #     3 : Float
  1382. #         < index1: Index vom Mantissenanfang (excl. Vorzeichen)
  1383. #         < index4: Index nach dem Mantissenende
  1384. #         < index2: Index beim Ende der Characters
  1385. #         < index3: Index nach dem Dezimalpunkt (=index4 falls keiner da)
  1386. #         (also Mantisse mit index4-index1 Characters: Ziffern und max. 1 '.')
  1387. #         (also index4-index3 Nachkommaziffern)
  1388. #         (also bei index4<index2: index4 = Index des Exponent-Markers,
  1389. #               index4+1 = Index des Exponenten-Vorzeichens oder der ersten
  1390. #               Exponenten-Ziffer)
  1391.   typedef struct { signean sign;
  1392.                    uintL index1;
  1393.                    uintL index2;
  1394.                    uintL index3;
  1395.                    uintL index4;
  1396.                  }
  1397.           zahl_info;
  1398.   local uintWL test_number_syntax (uintWL* base_, object* string_, zahl_info* info);
  1399.   local uintWL test_number_syntax(base_,string_,info)
  1400.     var reg8 uintWL* base_;
  1401.     var reg9 object* string_;
  1402.     var reg8 zahl_info* info;
  1403.     # Methode:
  1404.     # 1. Auf potential number testen.
  1405.     #    Dann kommen nur Attributcodes >= a_ratio vor,
  1406.     #    und bei a_dot ist base=10.
  1407.     # 2. Vorzeichen { a_plus | a_minus | } lesen, merken.
  1408.     # 3. versuchen, das Token als rationale Zahl zu interpretieren:
  1409.     #    Teste, ob die Syntax
  1410.     #    { a_plus | a_minus | }                               # schon gelesen
  1411.     #    { a_digit < base }+ { a_ratio { a_digit < base }+ | }
  1412.     #    vorliegt.
  1413.     # 4. base:=10 setzen, und falls base vorher >10 war, den Characters
  1414.     #    'A'-'Z','a'-'z' (waren frⁿher a_letter oder a_expo_m, sind aber evtl.
  1415.     #    durch test_potential_number_syntax in a_digit umgewandelt worden)
  1416.     #    wieder ihren Attributcode gemΣ▀ Tabelle zuordnen (a_letter -> keine
  1417.     #    Zahl oder a_expo_m).
  1418.     # 5. versuchen, das Token als Floating-Point-Zahl oder Dezimal-Integer
  1419.     #    zu interpretieren:
  1420.     #    Teste, ob die Syntax
  1421.     #    { a_plus | a_minus | }                               # schon gelesen
  1422.     #    { a_digit }* { a_dot { a_digit }* | }
  1423.     #    { a_expo_m { a_plus | a_minus | } { a_digit }+ | }
  1424.     #    vorliegt.
  1425.     #    Falls Exponent vorliegt, mⁿssen Vor- oder Nachkommastellen kommen;
  1426.     #      es ist ein Float, Typ wird vom Exponent-Marker (e,E liefern den
  1427.     #      Wert der Variablen *read-default-float-format* als Typ).
  1428.     #    Falls kein Exponent:
  1429.     #      Falls kein Dezimalpunkt da, ist es keine Zahl (hΣtte schon bei
  1430.     #        Schritt 3 geliefert werden mⁿssen, aber base hatte offenbar
  1431.     #        nicht gepa▀t).
  1432.     #      Falls Dezimalpunkt vorhanden:
  1433.     #        Falls Nachkommastellen vorliegen, ist es ein Float (Typ wird
  1434.     #          von der Variablen *read-default-float-format* angegeben).
  1435.     #        Falls keine Nachkommastellen kommen:
  1436.     #          Falls Vorkommastellen da waren, Dezimal-Integer.
  1437.     #          Sonst keine Zahl.
  1438.     {  var reg9 uintB* charptr0; # Pointer auf die Characters
  1439.        var reg9 uintB* attrptr0; # Pointer auf die Attribute
  1440.        var reg6 uintL len; # LΣnge des Token
  1441.        # 1. Auf potential number testen:
  1442.        { if (token_escape_flag) # Token mit Escape-Zeichen ->
  1443.            { return 0; } # keine potential number -> keine Zahl
  1444.          # Escape-Flag gel÷scht.
  1445.         {var token_info info;
  1446.          if (!test_potential_number_syntax(base_,&info)) # potential number ?
  1447.            { return 0; } # nein -> keine Zahl
  1448.          # ja -> Ausgabeparameter von test_potential_number_syntax lesen:
  1449.          charptr0 = info.charptr;
  1450.          attrptr0 = info.attrptr;
  1451.          len = info.len;
  1452.        }}
  1453.        *string_ = TheArray(O(token_buff_1))->data; # Simple-String
  1454.      { var reg9 uintL index0 = 0;
  1455.        # 2. Vorzeichen lesen und merken:
  1456.        { info->sign = 0; # Vorzeichen:=positiv
  1457.          switch (*attrptr0)
  1458.            { case a_minus: info->sign = -1; # Vorzeichen:=negativ
  1459.              case a_plus:
  1460.                # Vorzeichen ⁿberlesen:
  1461.                charptr0++; attrptr0++; index0++;
  1462.              default: break;
  1463.            }
  1464.        }
  1465.        info->index1 = index0; # Startindex
  1466.        info->index2 = len; # Endindex
  1467.        # info->sign und info->index1 und info->index2 fertig.
  1468.        # charptr0 und attrptr0 und index0 ab jetzt unverΣndert.
  1469.       {var reg7 uintB flags = 0; # alle Flags l÷schen
  1470.        # 3. Rationale Zahl
  1471.        { var reg4 uintB* charptr = charptr0;
  1472.          var reg3 uintB* attrptr = attrptr0;
  1473.          var reg5 uintL index = index0;
  1474.          # flags & bit(0)  zeigt an, ob bereits ein a_digit < base
  1475.          #                 angetroffen ist.
  1476.          # flags & bit(1)  zeigt an, ob bereits ein a_ratio angetroffen ist
  1477.          #                 (und dann ist info->index3 dessen Position)
  1478.          loop
  1479.            { # nΣchstes Zeichen
  1480.              if (index>=len) break;
  1481.             {var reg2 uintB attr = *attrptr++; # dessen Attributcode
  1482.              if (attr==a_digit)
  1483.                { var reg1 uintB c = *charptr++; # Character (Digit, also '0'-'9','A'-'Z','a'-'z')
  1484.                  # Wert bestimmen:
  1485.                  var reg1 uintB wert = (c<'A' ? c-'0' : c<'a' ? c-'A'+10 : c-'a'+10);
  1486.                  if (wert >= *base_) # Digit mit Wert >=base ?
  1487.                    goto schritt4; # ja -> keine rationale Zahl
  1488.                  # Digit mit Wert <base
  1489.                  flags |= bit(0); # Bit 0 setzen
  1490.                  index++;
  1491.                }
  1492.              elif (attr==a_ratio)
  1493.                { if (flags & bit(1)) # nicht der einzige '/' ?
  1494.                    goto schritt4; # ja -> keine rationale Zahl
  1495.                  flags |= bit(1); # erster '/'
  1496.                  if (!(flags & bit(0))) # keine Ziffern vor dem Bruchstrich?
  1497.                    goto schritt4; # ja -> keine rationale Zahl
  1498.                  flags &= ~bit(0); # Bit 0 l÷schen, neuer Block fΣngt an
  1499.                  info->index3 = index; # Index des '/' merken
  1500.                  charptr++; index++;
  1501.                }
  1502.              else
  1503.                # Attributcode /= a_digit, a_ratio -> keine rationale Zahl
  1504.                goto schritt4;
  1505.            }}
  1506.          # Token zu Ende
  1507.          if (!(flags & bit(0))) # keine Ziffern im letzten Block ?
  1508.            goto schritt4; # ja -> keine rationale Zahl
  1509.          # rationale Zahl
  1510.          if (!(flags & bit(1))) # a_ratio aufgetreten?
  1511.            # nein -> Integer liegt vor, info ist fertig.
  1512.            { return 1; }
  1513.            else
  1514.            # ja -> Bruch liegt vor, info ist fertig.
  1515.            { return 2; }
  1516.        }
  1517.        schritt4:
  1518.        # 4. base:=10, mit Eliminierung von 'A'-'Z','a'-'z'
  1519.        if (*base_ > 10)
  1520.          { var reg3 uintB* charptr = charptr0;
  1521.            var reg4 uintB* attrptr = attrptr0;
  1522.            var reg5 uintL count;
  1523.            dotimesL(count,len-index0,
  1524.              { var reg1 uintB c = *charptr++; # nΣchstes Character
  1525.                if (((c>='A') && (c<='Z')) || ((c>='a') && (c<='z')))
  1526.                  { var reg2 uintB attr = attribute_table[c]; # dessen wahrer Attributcode
  1527.                    if (attr == a_letter) # Ist er = a_letter ?
  1528.                      { return 0; } # ja -> keine Zahl
  1529.                    # sonst (mu▀ a_expo_m sein) eintragen:
  1530.                    *attrptr = attr;
  1531.                  }
  1532.                attrptr++;
  1533.              });
  1534.          }
  1535.        *base_ = 10;
  1536.        # 5. Floating-Point-Zahl oder Dezimal-Integer
  1537.        { var reg2 uintB* attrptr = attrptr0;
  1538.          var reg3 uintL index = index0;
  1539.          # flags & bit(2)  zeigt an, ob bereits ein a_dot angetroffen ist
  1540.          #                 (und dann ist info->index3 die Position danach)
  1541.          # flags & bit(3)  zeigt an, ob im letzten Ziffernblock bereits ein
  1542.          #                 a_digit angetroffen wurde.
  1543.          # flags & bit(4)  zeigt an, ob a_dot vorkam und es Vorkommastellen
  1544.          #                 gab.
  1545.          loop
  1546.            { # nΣchstes Zeichen
  1547.              if (index>=len) break;
  1548.             {var reg1 uintB attr = *attrptr++; # dessen Attributcode
  1549.              if (attr==a_digit)
  1550.                # Digit ('0'-'9')
  1551.                { flags |= bit(3); index++; }
  1552.              elif (attr==a_dot)
  1553.                { if (flags & bit(2)) # nicht das einzige '.' ?
  1554.                    { return 0; } # ja -> keine Zahl
  1555.                  flags |= bit(2); # erster '.'
  1556.                  if (flags & bit(3)) { flags |= bit(4); } # evtl. mit Vorkommastellen
  1557.                  flags &= ~bit(3); # Flag zurⁿcksetzen
  1558.                  index++;
  1559.                  info->index3 = index; # Index nach dem '.' merken
  1560.                }
  1561.              elif (attr==a_expo_m)
  1562.                { goto expo; } # Nun kommt der Exponent
  1563.              else
  1564.                { return 0; } # sonst kein Float, also keine Zahl
  1565.            }}
  1566.          # Token zu Ende, kein Exponent
  1567.          if (!(flags & bit(2))) # nur Dezimalziffern ohne '.' ?
  1568.            { return 0; } # ja -> keine Zahl
  1569.          info->index4 = index;
  1570.          if (flags & bit(3)) # mit Nachkommastellen?
  1571.            { return 3; } # ja -> Float, info fertig.
  1572.          # nein.
  1573.          if (!(flags & bit(4))) # auch ohne Vorkommastellen?
  1574.            { return 0; } # ja -> nur '.' -> keine Zahl
  1575.          # Nur Vorkomma-, keine Nachkommastellen -> Dezimal-Integer.
  1576.          # Brauche Dot ganz hinten nicht wegzuschneiden (wird ⁿberlesen).
  1577.          { return 1; }
  1578.          expo:
  1579.          # Exponent erreicht.
  1580.          info->index4 = index;
  1581.          index++; # Exponent-Marker mitzΣhlen
  1582.          if (!(flags & bit(2))) { info->index3 = info->index4; } # Default fⁿr index3
  1583.          if (!(flags & (bit(3)|bit(4)))) # Kamen Vor- oder Nachkommastellen vor?
  1584.            { return 0; } # nein -> keine Zahl
  1585.          # Exponententeil weiter abarbeiten:
  1586.          # flags & bit(5)  zeigt an, ob bereits eine Exponenten-Ziffer da war.
  1587.          if (index>=len) { return 0; } # String zu Ende -> keine Zahl
  1588.          switch (*attrptr)
  1589.            { case a_plus:
  1590.              case a_minus:
  1591.                attrptr++; index++; # Exponenten-Vorzeichen ⁿbergehen
  1592.              default: break;
  1593.            }
  1594.          loop
  1595.            { # nΣchstes Zeichen im Exponenten:
  1596.              if (index>=len) break;
  1597.              # Es dⁿrfen nur noch Digits kennen:
  1598.              if (!(*attrptr++ == a_digit)) { return 0; }
  1599.              flags |= bit(5);
  1600.              index++;
  1601.            }
  1602.          # Token nach Exponent zu Ende
  1603.          if (!(flags & bit(5))) # keine Ziffer im Exponenten?
  1604.            { return 0; } # ja -> keine Zahl
  1605.          return 3; # Float, info fertig.
  1606.        }
  1607.     }}}
  1608.  
  1609. # UP: ▄berprⁿft, ob ein Token nur aus Dots besteht.
  1610. # test_dots()
  1611. # > O(token_buff_1): gelesene Characters
  1612. # > O(token_buff_2): ihre Attributcodes
  1613. # < ergebnis: TRUE, falls Token leer ist oder nur aus Dots besteht
  1614.   local boolean test_dots (void);
  1615.   local boolean test_dots()
  1616.     { # Suche nach Attributcode /= a_dot:
  1617.       var reg3 object string = O(token_buff_2); # Semi-Simple-String
  1618.       var reg4 uintL len = TheArray(string)->dims[1]; # Fill-Pointer
  1619.       string = TheArray(string)->data; # Simple-String
  1620.      {var reg1 uintB* attrptr = &TheSstring(string)->data[0];
  1621.       var reg2 uintL count;
  1622.       dotimesL(count,len,
  1623.         { if (!(*attrptr++ == a_dot)) # Attributcode /= a_dot gefunden?
  1624.             { return FALSE; } # ja -> fertig, FALSE
  1625.         });
  1626.       # alles Dots.
  1627.       return TRUE;
  1628.     }}
  1629.  
  1630. # UP: Wandelt ein Zahl-Token in Gro▀buchstaben um.
  1631. # upcase_token();
  1632. # > O(token_buff_1): gelesene Characters
  1633. # > O(token_buff_2): ihre Attributcodes
  1634.   local void upcase_token (void);
  1635.   local void upcase_token()
  1636.     { var reg3 object string = O(token_buff_1); # Semi-Simple-String
  1637.       var reg2 uintL len = TheArray(string)->dims[1]; # Fill-Pointer
  1638.       string = TheArray(string)->data; # Simple-String
  1639.      {var reg1 uintB* charptr = &TheSstring(string)->data[0];
  1640.       dotimesL(len,len, { *charptr = up_case(*charptr); charptr++; } );
  1641.     }}
  1642.  
  1643. # UP: Behandelt ein Read-Macro-Character:
  1644. # Ruft die zugeh÷rige Macro-Funktion auf, bei Dispatch-Characters erst noch
  1645. # Zahl-Argument und Subchar einlesen.
  1646. # read_macro(ch,&stream)
  1647. # > ch: Macro-Character, ein String-Char
  1648. # > stream: Stream
  1649. # < stream: Stream
  1650. # < mv_count/mv_space: max. 1 Wert
  1651. # kann GC ausl÷sen
  1652.   local Values read_macro (object ch, object* stream_);
  1653.   local Values read_macro(ch,stream_)
  1654.     var reg9 object ch;
  1655.     var reg5 object* stream_;
  1656.     { var reg4 object readtable;
  1657.       get_readtable(readtable = ); # aktuelle Readtable (brauche ch nicht zu retten)
  1658.      {var reg3 object macrodef = # Macro-Definition aus Tabelle holen
  1659.         TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[(uintP)char_code(ch)];
  1660.       if (nullp(macrodef)) # =NIL ?
  1661.         { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1662.           pushSTACK(ch);
  1663.           pushSTACK(*stream_);
  1664.           pushSTACK(S(read));
  1665.           fehler(stream_error,
  1666.                  DEUTSCH ? "~ von ~: ~ hat keine Macrozeichendefinition." :
  1667.                  ENGLISH ? "~ from ~: ~ has no macro character definition" :
  1668.                  FRANCAIS ? "~ de ~ : ~ n'a pas de dΘfinition de macro-caractΦre." :
  1669.                  ""
  1670.                 );
  1671.         }
  1672.       if (!simple_vector_p(macrodef)) # ein Simple-Vector?
  1673.         # ch normales Macro-Character, macrodef Funktion
  1674.         { pushSTACK(*stream_); # Stream als 1. Argument
  1675.           pushSTACK(ch); # Character als 2. Argument
  1676.           funcall(macrodef,2); # Funktion aufrufen
  1677.           if (mv_count > 1)
  1678.             { pushSTACK(fixnum(mv_count)); # Wertezahl als Fixnum
  1679.               pushSTACK(ch);
  1680.               pushSTACK(*stream_);
  1681.               pushSTACK(S(read));
  1682.               fehler(error,
  1683.                      DEUTSCH ? "~ von ~: Macrozeichendefinition zu ~ darf keine ~ Werte liefern, sondern h÷chstens einen." :
  1684.                      ENGLISH ? "~ from ~: macro character definition for ~ may not return ~ values, only one value." :
  1685.                      FRANCAIS ? "~ de ~ : La dΘfinition du macro-caractΦre ~ ne doit pas retourner ~ valeurs mais au plus une." :
  1686.                      ""
  1687.                     );
  1688.             }
  1689.           # h÷chstens 1 Wert.
  1690.           return; # mv_space/mv_count belassen
  1691.         }
  1692.         else
  1693.         # Dispatch-Macro-Zeichen.
  1694.         { pushSTACK(macrodef); # Vektor retten
  1695.          {var reg8 object arg; # Argument (Integer >=0 oder NIL)
  1696.           var reg7 object subch; # sub-char
  1697.           var reg6 uintB subc; # sub-char
  1698.           # Ziffern des Argumentes lesen:
  1699.           { var reg2 boolean flag = FALSE; # Flag, ob schon eine Ziffer kam
  1700.             pushSTACK(Fixnum_0); # bisheriger Integer := 0
  1701.             loop
  1702.               { var reg1 object nextch = read_char(stream_); # Character lesen
  1703.                 if (eq(nextch,eof_value))
  1704.                   { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1705.                     pushSTACK(ch); # main char
  1706.                     pushSTACK(*stream_); # Stream
  1707.                     pushSTACK(S(read));
  1708.                     fehler(end_of_file,
  1709.                            DEUTSCH ? "~: Eingabestream ~ endet innerhalb eines Read-Macro zu ~" :
  1710.                            ENGLISH ? "~: input stream ~ ends within read macro beginning to ~" :
  1711.                            FRANCAIS ? "~ : Le ½stream╗ d'entrΘe se termine α l'intΘrieur d'un macro de lecture en ~" :
  1712.                            ""
  1713.                           );
  1714.                   }
  1715.                 # sonst Character. Auf String-Char ⁿberprⁿfen.
  1716.                 if (!string_char_p(nextch)) { fehler_charread(nextch,stream_); }
  1717.                {var reg1 uintB c = char_code(nextch);
  1718.                 if (!((c>='0') && (c<='9'))) # keine Ziffer -> Schleife fertig
  1719.                   { subc = c; break; }
  1720.                 # Integer mal 10 nehmen und Ziffer addieren:
  1721.                 STACK_0 = mal_10_plus_x(STACK_0,(c-'0'));
  1722.                 flag = TRUE;
  1723.               }}
  1724.             # Argument in STACK_0 fertig (nur falls flag=TRUE).
  1725.             arg = popSTACK();
  1726.             if (!flag) { arg = NIL; } # kam keine Ziffer -> Argument := NIL
  1727.           }
  1728.           # Weiter geht's mit Subchar (String-Char subc)
  1729.           subch = code_char(subc);
  1730.           subc = up_case(subc); # Subchar in Gro▀buchstaben umwandeln
  1731.           macrodef = popSTACK(); # Vektor zurⁿck
  1732.           macrodef = TheSvector(macrodef)->data[subc]; # Subchar-Funktion oder NIL
  1733.           if (nullp(macrodef))
  1734.             # NIL -> undefiniert
  1735.             { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1736.               pushSTACK(subch); # Subchar
  1737.               pushSTACK(ch); # Mainchar
  1738.               pushSTACK(*stream_); # Stream
  1739.               pushSTACK(S(read));
  1740.               fehler(stream_error,
  1741.                      DEUTSCH ? "~ von ~: Nach ~ ist ~ als Dispatch-Macrozeichen undefiniert." :
  1742.                      ENGLISH ? "~ from ~: After ~ is ~ an undefined dispatch macro character" :
  1743.                      FRANCAIS ? "~ de ~ : AprΦs ~ ~ n'est plus dΘfini comme macro caractΦre de ½dispatch╗." :
  1744.                      ""
  1745.                     );
  1746.             }
  1747.           pushSTACK(*stream_); # Stream als 1. Argument
  1748.           pushSTACK(subch); # Subchar als 2. Argument
  1749.           pushSTACK(arg); # Argument (NIL oder Integer>=0) als 3. Argument
  1750.           funcall(macrodef,3); # Funktion aufrufen
  1751.           if (mv_count > 1)
  1752.             { pushSTACK(fixnum(mv_count)); # Wertezahl als Fixnum
  1753.               pushSTACK(ch); # Mainchar
  1754.               pushSTACK(subch); # Subchar
  1755.               pushSTACK(*stream_); # Stream
  1756.               pushSTACK(S(read));
  1757.               fehler(error,
  1758.                      DEUTSCH ? "~ von ~: Dispatch-Macrozeichen-Definition zu ~ nach ~ darf keine ~ Werte liefern,"
  1759.                                " sondern h÷chstens einen." :
  1760.                      ENGLISH ? "~ from ~: dispatch macro character definition for ~ after ~ may not return ~ values,"
  1761.                                " only one value." :
  1762.                      FRANCAIS ? "~ de ~ : La dΘfinition de caractΦre macro de ½dispatch╗ pour ~ aprΦs ~ ne doit pas retourner ~ valeurs." :
  1763.                      ""
  1764.                     );
  1765.             }
  1766.           # h÷chstens 1 Wert.
  1767.           return; # mv_space/mv_count belassen
  1768.         }}
  1769.     }}
  1770.  
  1771. # ------------------------ READ auf Objekt-Ebene ------------------------------
  1772.  
  1773. # UP: Liest ein Objekt ein.
  1774. # ▄berliest dabei fⁿhrenden Whitespace und Kommentar.
  1775. # Ma▀geblich sind die aktuellen Werte von SYS::*READ-PRESERVE-WHITESPACE*
  1776. # (fⁿrs evtl. ▄berlesen des ersten Whitespace nach dem Objekt)
  1777. # und SYS::*READ-RECURSIVE-P* (fⁿr EOF-Behandlung).
  1778. # read_internal(&stream)
  1779. # > stream: Stream
  1780. # < stream: Stream
  1781. # < ergebnis: gelesenes Objekt (eof_value bei EOF, dot_value bei einzelnem Punkt)
  1782. # kann GC ausl÷sen
  1783.   local object read_internal (object* stream_);
  1784.   local object read_internal(stream_)
  1785.     var reg6 object* stream_;
  1786.     { wloop: # Schleife zum ▄berlesen von fⁿhrendem Whitespace/Kommentar:
  1787.        {var reg2 object ch;
  1788.         var reg1 uintWL scode;
  1789.         read_char_syntax(ch = ,scode = ,stream_); # Zeichen lesen
  1790.         switch(scode)
  1791.           { case syntax_whitespace:
  1792.               # Whitespace -> wegwerfen und weiterlesen
  1793.               goto wloop;
  1794.             case syntax_t_macro:
  1795.             case syntax_nt_macro:
  1796.               # Macro-Zeichen am Token-Anfang
  1797.               read_macro(ch,stream_); # Macro-Funktion ausfⁿhren
  1798.               if (mv_count==0)
  1799.                 # 0 Werte -> weiterlesen
  1800.                 { goto wloop; }
  1801.                 else
  1802.                 # 1 Wert -> als Ergebnis
  1803.                 { return value1; }
  1804.             case syntax_eof:
  1805.               # EOF am Token-Anfang
  1806.               if (test_value(S(read_recursive_p))) # *READ-RECURSIVE-P* /= NIL ?
  1807.                 # ja -> EOF innerhalb eines Objektes -> Fehler
  1808.                 { fehler_eof_innen(stream_); }
  1809.               # sonst eof_value als Wert:
  1810.               return eof_value;
  1811.             case syntax_illegal:
  1812.               # read_token_1 liefert Error
  1813.             case syntax_single_esc:
  1814.             case syntax_multi_esc:
  1815.             case syntax_constituent:
  1816.               # Token lesen: Mit dem Zeichen ch fΣngt ein Token an.
  1817.               read_token_1(stream_,ch,scode); # Token zu Ende lesen
  1818.               break;
  1819.             default: NOTREACHED
  1820.        }  }
  1821.       # Token gelesen
  1822.       if (test_value(S(read_suppress))) # *READ-SUPPRESS* /= NIL ?
  1823.         { return NIL; } # ja -> Token nicht interpretieren, NIL als Wert
  1824.       # Token mu▀ interpretiert werden
  1825.       # Der Token liegt in O(token_buff_1), O(token_buff_2), token_escape_flag.
  1826.       if ((!token_escape_flag) && test_dots())
  1827.         # Token ist eine Folge von Dots, ohne Escape-Characters gelesen.
  1828.         # LΣnge ist damit automatisch >0.
  1829.         { var reg1 uintL len = TheArray(O(token_buff_1))->dims[1]; # LΣnge des Token
  1830.           if (len > 1)
  1831.             # LΣnge>1 -> Fehler
  1832.             { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1833.               pushSTACK(*stream_);
  1834.               pushSTACK(S(read));
  1835.               fehler(stream_error,
  1836.                      DEUTSCH ? "~ von ~: Ein nur aus Punkten bestehendes Token ist nicht einlesbar." :
  1837.                      ENGLISH ? "~ from ~: a token consisting only of dots cannot be meaningfully read in" :
  1838.                      FRANCAIS ? "~ de ~ : Un lexΦme ne comprenant que des points ne peut pas Ωtre lu." :
  1839.                      ""
  1840.                     );
  1841.             }
  1842.           # LΣnge=1 -> dot_value als Wert
  1843.           return dot_value;
  1844.         }
  1845.       # Token ist OK
  1846.       { var uintWL base = get_read_base(); # Wert von *READ-BASE*
  1847.         # Token als Zahl interpretierbar?
  1848.         var object string;
  1849.         var zahl_info info;
  1850.         var reg3 uintWL numtype = test_number_syntax(&base,&string,&info);
  1851.         if (!(numtype==0)) # Zahl?
  1852.           { upcase_token(); # in Gro▀buchstaben umwandeln
  1853.             switch (numtype)
  1854.               { case 1: # Integer
  1855.                   return read_integer(base,info.sign,string,info.index1,info.index2);
  1856.                 case 2: # Rational
  1857.                   return read_rational(base,info.sign,string,info.index1,info.index3,info.index2);
  1858.                 case 3: # Float
  1859.                   return read_float(base,info.sign,string,info.index1,info.index4,info.index2,info.index3);
  1860.                 default: NOTREACHED
  1861.           }   }
  1862.       }
  1863.       # Token nicht als Zahl interpretierbar.
  1864.       # Wir interpretieren das Token als Symbol (auch dann, wenn das Token
  1865.       # Potential-number-Syntax hat, also ein 'reserved token' (im Sinne
  1866.       # von CLTL S. 341 oben) ist).
  1867.       # Dazu erst einmal die Verteilung der Doppelpunkte (Characters mit
  1868.       # Attributcode a_pack_m) feststellen:
  1869.       # Suche von vorne den ersten Doppelpunkt. FΣlle (CLTL S. 343-344):
  1870.       # 1. Kein Doppelpunkt -> aktuelle Package
  1871.       # 2. Ein oder zwei Doppelpunkte am Anfang -> Keyword
  1872.       # 3. Ein Doppelpunkt, nicht am Anfang -> externes Symbol
  1873.       # 4. Zwei Doppelpunkte, nicht am Anfang -> internes Symbol
  1874.       # In den letzten drei FΣllen dⁿrfen keine weiteren Doppelpunkte mehr
  1875.       # kommen.
  1876.       # (Da▀ bei 2. der Namensteil bzw. bei 3. und 4. der Packageteil und
  1877.       # der Namensteil nicht die Syntax einer Zahl haben, kann hier nicht
  1878.       # mehr ⁿberprⁿft werden, weil sich TOKEN_ESCAPE_FLAG auf das ganze
  1879.       # Token bezieht. Vergleiche |USER|:: und |USER|::|| )
  1880.       { var reg5 object buff_2 = O(token_buff_2); # Attributcode-Buffer
  1881.         var reg4 uintL len = TheArray(buff_2)->dims[1]; # LΣnge = Fill-Pointer
  1882.         var reg2 uintB* attrptr = &TheSstring(TheArray(buff_2)->data)->data[0];
  1883.         var reg3 uintL index = 0;
  1884.         # stets attrptr = &TheSstring(...)->data[index].
  1885.         # Token wird in Packagenamen und Namen zerhackt:
  1886.         var reg7 uintL pack_end_index;
  1887.         var reg8 uintL name_start_index;
  1888.         var reg9 boolean external_internal_flag = FALSE; # vorlΣufig external
  1889.         loop
  1890.           { if (index>=len) goto current; # kein Doppelpunkt gefunden -> current package
  1891.             if (*attrptr++ == a_pack_m) break;
  1892.             index++;
  1893.           }
  1894.         # erster Doppelpunkt bei Index index gefunden
  1895.         pack_end_index = index; # Packagename endet hier
  1896.         index++;
  1897.         name_start_index = index; # Symbolname fΣngt (vorlΣufig) hier an
  1898.         # Tokenende erreicht -> externes Symbol:
  1899.         if (index>=len) goto ex_in_ternal;
  1900.         # Kommt sofort danach ein weiterer Doppelpunkt?
  1901.         index++;
  1902.         if (*attrptr++ == a_pack_m)
  1903.           # zwei Doppelpunkte nebeneinander
  1904.           { name_start_index = index; # Symbolname fΣngt erst hier an
  1905.             external_internal_flag = TRUE; # internal
  1906.           }
  1907.           else
  1908.           # erster Doppelpunkt war isoliert
  1909.           {} # external
  1910.         # Es dⁿrfen keine weiteren Doppelpunkte kommen:
  1911.         loop
  1912.           { if (index>=len) goto ex_in_ternal; # kein weiterer Doppelpunkt gefunden -> ok
  1913.             if (*attrptr++ == a_pack_m) break;
  1914.             index++;
  1915.           }
  1916.         { # Fehlermeldung
  1917.           pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  1918.           pushSTACK(copy_string(O(token_buff_1))); # Character-Buffer kopieren
  1919.           pushSTACK(*stream_); # Stream
  1920.           pushSTACK(S(read));
  1921.           fehler(stream_error,
  1922.                  DEUTSCH ? "~ von ~: Zuviele Doppelpunkte im Token ~" :
  1923.                  ENGLISH ? "~ from ~: too many colons in token ~" :
  1924.                  FRANCAIS ? "~ de ~ : Trop de deux-points dans le lexΦme ~" :
  1925.                  ""
  1926.                 );
  1927.         }
  1928.         # Symbol suchen bzw. erzeugen:
  1929.         current: # Symbol in der current package suchen.
  1930.         # Symbolname = O(token_buff_1) = (subseq O(token_buff_1) 0 len)
  1931.         # ist ein nicht-simpler String.
  1932.         { var object sym;
  1933.           # Symbol internieren (und dabei String kopieren, falls das Symbol
  1934.           # neu erzeugt werden mu▀):
  1935.           intern(O(token_buff_1),get_current_package(),&sym);
  1936.           return sym;
  1937.         }
  1938.         ex_in_ternal: # externes/internes Symbol bilden
  1939.         # Packagename = (subseq O(token_buff_1) 0 pack_end_index),
  1940.         # Symbolname = (subseq O(token_buff_1) name_start_index len).
  1941.         if (pack_end_index==0)
  1942.           # Doppelpunkt(e) am Anfang -> Keyword bilden:
  1943.           { # Symbolname = (subseq O(token_buff_1) name_start_index len).
  1944.             # Hilfs-String adjustieren:
  1945.             var reg1 object hstring = O(displaced_string);
  1946.             TheArray(hstring)->data = O(token_buff_1); # Datenvektor
  1947.             TheArray(hstring)->dims[0] = name_start_index; # Displaced-Offset
  1948.             TheArray(hstring)->totalsize =
  1949.               TheArray(hstring)->dims[1] = len - name_start_index; # LΣnge
  1950.             # Symbol in die Keyword-Package internieren (und dabei
  1951.             # String kopieren, falls das Symbol neu erzeugt werden mu▀):
  1952.             return intern_keyword(hstring);
  1953.           }
  1954.         { # Packagename = (subseq O(token_buff_1) 0 pack_end_index).
  1955.           # Hilfs-String adjustieren:
  1956.           var reg1 object hstring = O(displaced_string);
  1957.           TheArray(hstring)->data = O(token_buff_1); # Datenvektor
  1958.           TheArray(hstring)->dims[0] = 0; # Displaced-Offset
  1959.           TheArray(hstring)->totalsize =
  1960.             TheArray(hstring)->dims[1] = pack_end_index; # LΣnge
  1961.           # Package mit diesem Namen suchen:
  1962.          {var reg2 object pack = find_package(hstring);
  1963.           if (nullp(pack)) # Package nicht gefunden?
  1964.             { pushSTACK(copy_string(hstring)); # Displaced-String kopieren, Wert fⁿr Slot PACKAGE von PACKAGE-ERROR
  1965.               pushSTACK(STACK_0);
  1966.               pushSTACK(*stream_); # Stream
  1967.               pushSTACK(S(read));
  1968.               fehler(package_error,
  1969.                      DEUTSCH ? "~ von ~: Eine Package mit dem Namen ~ gibt es nicht." :
  1970.                      ENGLISH ? "~ from ~: there is no package with name ~" :
  1971.                      FRANCAIS ? "~ de ~ : Il n'y a pas de paquetage de nom ~." :
  1972.                      ""
  1973.                     );
  1974.             }
  1975.           # Hilfs-String adjustieren:
  1976.           TheArray(hstring)->dims[0] = name_start_index; # Displaced-Offset
  1977.           TheArray(hstring)->totalsize =
  1978.             TheArray(hstring)->dims[1] = len - name_start_index; # LΣnge
  1979.           if (external_internal_flag)
  1980.             # internal
  1981.             { # Symbol internieren (und dabei String kopieren,
  1982.               # falls das Symbol neu erzeugt werden mu▀):
  1983.               var object sym;
  1984.               intern(hstring,pack,&sym);
  1985.               return sym;
  1986.             }
  1987.             else
  1988.             # external
  1989.             { # externes Symbol mit diesem Printnamen suchen:
  1990.               var object sym;
  1991.               if (find_external_symbol(hstring,pack,&sym))
  1992.                 { return sym; } # sym gefunden
  1993.                 else
  1994.                 { pushSTACK(pack); # Wert fⁿr Slot PACKAGE von PACKAGE-ERROR
  1995.                   pushSTACK(copy_string(hstring)); # Displaced-String kopieren
  1996.                   pushSTACK(STACK_1); # pack
  1997.                   pushSTACK(*stream_); # Stream
  1998.                   pushSTACK(S(read));
  1999.                   fehler(package_error,
  2000.                          DEUTSCH ? "~ von ~: In ~ gibt es kein externes Symbol mit Namen ~" :
  2001.                          ENGLISH ? "~ from ~: ~ has no external symbol with name ~" :
  2002.                          FRANCAIS ? "~ de ~ : ~ ne comprend pas de symbole externe de nom ~." :
  2003.                          ""
  2004.                         );
  2005.             }   }
  2006.         }}
  2007.     } }
  2008.  
  2009. # UP: Liest ein Objekt ein, mit SYS::*READ-RECURSIVE-P* /= NIL
  2010. # (und SYS::*READ-PRESERVE-WHITESPACE* = NIL, vgl. CLTL S. 377 mitte).
  2011. # Meldet bei EOF einen Error.
  2012. # read_recursive(&stream)
  2013. # > stream: Stream
  2014. # < stream: Stream
  2015. # < ergebnis: gelesenes Objekt (dot_value bei einzelnem Punkt)
  2016. # kann GC ausl÷sen
  2017.   local object read_recursive (object* stream_);
  2018.   local object read_recursive(stream_)
  2019.     var reg3 object* stream_;
  2020.     { check_SP(); check_STACK(); # Stacks auf ▄berlauf testen
  2021.       if (test_value(S(read_recursive_p)))
  2022.         # schon rekursiv
  2023.         { return read_internal(stream_); }
  2024.         else
  2025.         { # SYS::*READ-RECURSIVE-P* an T binden:
  2026.           dynamic_bind(S(read_recursive_p),T);
  2027.           # und SYS::*READ-PRESERVE-WHITESPACE* an NIL binden:
  2028.           dynamic_bind(S(read_preserve_whitespace),NIL);
  2029.           # und Objekt lesen:
  2030.          {var reg4 object ergebnis = read_internal(stream_);
  2031.           dynamic_unbind();
  2032.           dynamic_unbind();
  2033.           return ergebnis;
  2034.         }}
  2035.     }
  2036.  
  2037. # Fehlermeldung wegen unpassendem Dot
  2038. # fehler_dot(stream);
  2039. # > stream: Stream
  2040.   nonreturning_function(local, fehler_dot, (object stream));
  2041.   local void fehler_dot(stream)
  2042.     var reg1 object stream;
  2043.     { pushSTACK(stream); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2044.       pushSTACK(stream); # Stream
  2045.       pushSTACK(S(read));
  2046.       fehler(stream_error,
  2047.              DEUTSCH ? "~ von ~: Token \".\" an dieser Stelle nicht erlaubt." :
  2048.              ENGLISH ? "~ from ~: token \".\" not allowed here" :
  2049.              FRANCAIS ? "~ de ~ : Le lexΦme \".\" n'est pas permis ici." :
  2050.              ""
  2051.             );
  2052.     }
  2053.  
  2054. # UP: Liest ein Objekt ein, mit SYS::*READ-RECURSIVE-P* /= NIL
  2055. # (und SYS::*READ-PRESERVE-WHITESPACE* = NIL, vgl. CLTL S. 377 mitte).
  2056. # Meldet Error bei EOF oder Token ".".
  2057. # (Das entspricht dem Idiom (read stream t nil t).)
  2058. # read_recursive_no_dot(&stream)
  2059. # > stream: Stream
  2060. # < stream: Stream
  2061. # < ergebnis: gelesenes Objekt
  2062. # kann GC ausl÷sen
  2063.   local object read_recursive_no_dot (object* stream_);
  2064.   local object read_recursive_no_dot(stream_)
  2065.     var reg2 object* stream_;
  2066.     { # READ rekursiv aufrufen:
  2067.       var reg1 object ergebnis = read_recursive(stream_);
  2068.       # und bei "." einen Error melden:
  2069.       if (eq(ergebnis,dot_value)) { fehler_dot(*stream_); }
  2070.       return ergebnis;
  2071.     }
  2072.  
  2073. # UP: Entflicht #n# - Referenzen zu #n= - Markierungen in einem Objekt.
  2074. # > Wert von SYS::*READ-REFERENCE-TABLE*:
  2075. #     Aliste von Paaren (Markierung . markiertes Objekt), wobei
  2076. #     jede Markierung ein Objekt  #<READ-LABEL n>  ist.
  2077. # > obj: Objekt
  2078. # < ergebnis: destruktiv modifiziertes Objekt ohne Referenzen
  2079.   local object make_references (object obj);
  2080.   local object make_references(obj)
  2081.     var reg3 object obj;
  2082.     { var reg2 object alist = Symbol_value(S(read_reference_table));
  2083.       # SYS::*READ-REFERENCE-TABLE* = NIL -> nichts zu tun:
  2084.       if (nullp(alist))
  2085.         { return obj; }
  2086.         else
  2087.         { # ▄berprⁿfen, ob SYS::*READ-REFERENCE-TABLE* eine Aliste ist:
  2088.          {var reg1 object alistr = alist; # Liste durchlaufen
  2089.           while (consp(alistr))
  2090.             { # jedes Listenelement mu▀ ein Cons sein:
  2091.               if (!mconsp(Car(alistr))) goto fehler_badtable;
  2092.               alistr = Cdr(alistr);
  2093.             }
  2094.           if (!nullp(alistr))
  2095.             { fehler_badtable:
  2096.               pushSTACK(S(read_reference_table));
  2097.               pushSTACK(S(read));
  2098.               fehler(error,
  2099.                      DEUTSCH ? "~: Der Wert von ~ wurde von au▀en verΣndert." :
  2100.                      ENGLISH ? "~: the value of ~ has been arbitrarily altered" :
  2101.                      FRANCAIS ? "~ : La valeur de ~ fut modifiΘe extΘrieurement." :
  2102.                      ""
  2103.                     );
  2104.             }
  2105.          }# Aliste alist ist OK
  2106.           pushSTACK(obj);
  2107.           {var reg1 object bad_reference =
  2108.             subst_circ(&STACK_0,alist); # Referenzen durch Objekte substituieren
  2109.            if (!eq(bad_reference,nullobj))
  2110.              { pushSTACK(unbound); # "Wert" fⁿr Slot STREAM von STREAM-ERROR
  2111.                pushSTACK(Symbol_value(S(read_reference_table)));
  2112.                pushSTACK(S(read_reference_table));
  2113.                pushSTACK(obj);
  2114.                pushSTACK(bad_reference);
  2115.                pushSTACK(S(read));
  2116.                fehler(stream_error,
  2117.                       DEUTSCH ? "~: ~ aus ~ ist in ~ = ~ nicht aufgefⁿhrt." :
  2118.                       ENGLISH ? "~: no entry for ~ from ~ in ~ = ~" :
  2119.                       FRANCAIS ? "~ : ~ dans ~ n'est pas ΘnoncΘ dans ~ = ~." :
  2120.                       ""
  2121.                      );
  2122.           }  }
  2123.           return popSTACK();
  2124.         }
  2125.     }
  2126.  
  2127. # UP: Liest ein Objekt ein, mit SYS::*READ-RECURSIVE-P* = NIL .
  2128. # (Top-Level-Aufruf des Readers)
  2129. # read_top(&stream,whitespace-p)
  2130. # > whitespace-p: gibt an, ob danach whitespace zu verbrauchen ist
  2131. # > stream: Stream
  2132. # < stream: Stream
  2133. # < ergebnis: gelesenes Objekt (eof_value bei EOF, dot_value bei einzelnem Punkt)
  2134. # kann GC ausl÷sen
  2135.   local object read_top (object* stream_, object whitespace_p);
  2136.   local object read_top(stream_,whitespace_p)
  2137.     var reg3 object* stream_;
  2138.     var reg4 object whitespace_p;
  2139.     {
  2140.      #if STACKCHECKR
  2141.       var reg6 object* STACKbefore = STACK; # STACK aufheben fⁿr spΣter
  2142.      #endif
  2143.       # SYS::*READ-RECURSIVE-P* an NIL binden:
  2144.       dynamic_bind(S(read_recursive_p),NIL);
  2145.       # und SYS::*READ-PRESERVE-WHITESPACE* an whitespace_p binden:
  2146.       dynamic_bind(S(read_preserve_whitespace),whitespace_p);
  2147.       # SYS::*READ-REFERENCE-TABLE* an die leere Tabelle NIL binden:
  2148.       dynamic_bind(S(read_reference_table),NIL);
  2149.       # SYS::*BACKQUOTE-LEVEL* an NIL binden:
  2150.       dynamic_bind(S(backquote_level),NIL);
  2151.       # Objekt lesen:
  2152.      {var reg5 object obj = read_internal(stream_);
  2153.       # Verweise entflechten:
  2154.       obj = make_references(obj);
  2155.       dynamic_unbind();
  2156.       dynamic_unbind();
  2157.       dynamic_unbind();
  2158.       dynamic_unbind();
  2159.      #if STACKCHECKR
  2160.       # ▄berprⁿfen, ob Stack aufgerΣumt:
  2161.       if (!(STACK == STACKbefore))
  2162.         { abort(); } # wenn nicht, in den Debugger
  2163.      #endif
  2164.       return obj;
  2165.     }}
  2166.  
  2167. # UP: Liest ein Objekt ein.
  2168. # read(&stream,recursive-p,whitespace-p)
  2169. # > recursive-p: gibt an, ob rekursiver Aufruf von READ, mit Error bei EOF
  2170. # > whitespace-p: gibt an, ob danach whitespace zu verbrauchen ist
  2171. # > stream: Stream
  2172. # < stream: Stream
  2173. # < ergebnis: gelesenes Objekt (eof_value bei EOF, dot_value bei einzelnem Punkt)
  2174. # kann GC ausl÷sen
  2175.   global object read (object* stream_, object recursive_p, object whitespace_p);
  2176.   global object read(stream_,recursive_p,whitespace_p)
  2177.     var reg1 object* stream_;
  2178.     var reg2 object recursive_p;
  2179.     var reg3 object whitespace_p;
  2180.     { if (nullp(recursive_p)) # recursive-p abfragen
  2181.         # nein -> Top-Level-Aufruf
  2182.         { return read_top(stream_,whitespace_p); }
  2183.         else
  2184.         # ja -> rekursiver Aufruf
  2185.         { return read_recursive(stream_); }
  2186.     }
  2187.  
  2188. # ----------------------------- READ-Macros -----------------------------------
  2189.  
  2190. # UP: Liest eine Liste ein.
  2191. # read_delimited_list(&stream,endch,ifdotted)
  2192. # > endch: erwartetes Endzeichen, ein String-Char
  2193. # > ifdotted: #DOT_VALUE falls Dotted List erlaubt, #EOF_VALUE sonst
  2194. # > stream: Stream
  2195. # < stream: Stream
  2196. # < ergebnis: gelesenes Objekt
  2197. # kann GC ausl÷sen
  2198.   local object read_delimited_list (object* stream_, object endch, object ifdotted);
  2199. # Dito mit gesetztem SYS::*READ-RECURSIVE-P* :
  2200.   local object read_delimited_list_recursive (object* stream_, object endch, object ifdotted);
  2201. # Erst die allgemeine Funktion:
  2202.   #ifdef RISCOS_CCBUG
  2203.     #pragma -z0
  2204.   #endif
  2205.   local object read_delimited_list(stream_,endch,ifdotted)
  2206.     var reg1 object* stream_;
  2207.     var reg2 object endch;
  2208.     var reg3 object ifdotted;
  2209.     { var reg4 object ergebnis;
  2210.       # SYS::*READ-LINE-NUMBER* an (SYS::LINE-NUMBER stream) binden
  2211.       # (fⁿr Fehlermeldung, damit man die Zeile der ÷ffnenden Klammer erfΣhrt):
  2212.       pushSTACK(*stream_); C_line_number();
  2213.       dynamic_bind(S(read_line_number),value1);
  2214.       # evtl. zuerst noch SYS::*READ-RECURSIVE-P* an T binden:
  2215.       if (test_value(S(read_recursive_p))) # schon rekursiv?
  2216.         { ergebnis = read_delimited_list_recursive(stream_,endch,ifdotted); }
  2217.         else
  2218.         # nein -> SYS::*READ-RECURSIVE-P* an T binden:
  2219.         { dynamic_bind(S(read_recursive_p),T);
  2220.           ergebnis = read_delimited_list_recursive(stream_,endch,ifdotted);
  2221.           dynamic_unbind();
  2222.         }
  2223.       dynamic_unbind();
  2224.       return ergebnis;
  2225.     }
  2226.   #ifdef RISCOS_CCBUG
  2227.     #pragma -z1
  2228.   #endif
  2229. # Dann die speziellere Funktion:
  2230.   local object read_delimited_list_recursive(stream_,endch,ifdotted)
  2231.     var reg1 object* stream_;
  2232.     var reg4 object endch;
  2233.     var reg6 object ifdotted;
  2234.     { # Brauche endch und ifdotted nicht zu retten.
  2235.       { var reg5 object object1; # erstes Listenelement
  2236.         loop # Schleife, um erstes Listenelement zu lesen
  2237.           { # nΣchstes non-whitespace Character:
  2238.             var reg2 object ch;
  2239.             var reg3 uintWL scode;
  2240.             wpeek_char_syntax(ch = ,scode = ,stream_);
  2241.             if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2242.               # ja -> leere Liste als Ergebnis
  2243.               { read_char(stream_); # Endezeichen verbrauchen
  2244.                 return NIL;
  2245.               }
  2246.             if (scode < syntax_t_macro) # Macro-Character?
  2247.               # nein -> 1. Objekt lesen:
  2248.               { object1 = read_recursive_no_dot(stream_); break; }
  2249.               else
  2250.               # ja -> zugeh÷riges Zeichen lesen und Macro-Funktion ausfⁿhren:
  2251.               { ch = read_char(stream_);
  2252.                 read_macro(ch,stream_);
  2253.                 if (!(mv_count==0)) # Wert zurⁿck?
  2254.                   { object1 = value1; break; } # ja -> als 1. Objekt nehmen
  2255.                   # nein -> ⁿberlesen
  2256.               }
  2257.           }
  2258.         # object1 ist das 1. Objekt
  2259.         pushSTACK(object1);
  2260.       }
  2261.       { var reg2 object new_cons = allocate_cons(); # Listenanfang basteln
  2262.         Car(new_cons) = popSTACK(); # new_cons = (cons object1 nil)
  2263.         #ifdef IMMUTABLE_CONS
  2264.         if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2265.           { pushSTACK(make_imm_cons(new_cons)); }
  2266.           else
  2267.         #endif
  2268.           { pushSTACK(new_cons); }
  2269.         pushSTACK(new_cons);
  2270.       }
  2271.       # Stackaufbau: Gesamtliste, (last Gesamtliste).
  2272.       loop # Schleife ⁿber weitere Listenelemente
  2273.         { var reg5 object object1; # weiteres Listenelement
  2274.           loop # Schleife, um weiteres Listenelement zu lesen
  2275.             { # nΣchstes non-whitespace Character:
  2276.               var reg2 object ch;
  2277.               var reg3 uintWL scode;
  2278.               wpeek_char_syntax(ch = ,scode = ,stream_);
  2279.               if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2280.                 # ja -> Liste beenden
  2281.                 { finish_list:
  2282.                   read_char(stream_); # Endezeichen verbrauchen
  2283.                   skipSTACK(1); return popSTACK(); # Gesamtliste als Ergebnis
  2284.                 }
  2285.               if (scode < syntax_t_macro) # Macro-Character?
  2286.                 # nein -> nΣchstes Objekt lesen:
  2287.                 { object1 = read_recursive(stream_);
  2288.                   if (eq(object1,dot_value)) goto dot;
  2289.                   break;
  2290.                 }
  2291.                 else
  2292.                 # ja -> zugeh÷riges Zeichen lesen und Macro-Funktion ausfⁿhren:
  2293.                 { ch = read_char(stream_);
  2294.                   read_macro(ch,stream_);
  2295.                   if (!(mv_count==0)) # Wert zurⁿck?
  2296.                     { object1 = value1; break; } # ja -> als nΣchstes Objekt nehmen
  2297.                     # nein -> ⁿberlesen
  2298.                 }
  2299.             }
  2300.           # nΣchstes Objekt in die Liste einhΣngen:
  2301.           pushSTACK(object1);
  2302.          {var reg2 object new_cons = allocate_cons(); # nΣchstes Listen-Cons
  2303.           Car(new_cons) = popSTACK(); # (cons object1 nil)
  2304.           #ifdef IMMUTABLE_CONS
  2305.           if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2306.             Cdr(STACK_0) = make_imm_cons(new_cons);
  2307.             else
  2308.           #endif
  2309.             Cdr(STACK_0) = new_cons; # =: (cdr (last Gesamtliste))
  2310.           STACK_0 = new_cons;
  2311.         }}
  2312.       dot: # Dot gelesen
  2313.       if (!eq(ifdotted,dot_value)) # war keiner erlaubt?
  2314.         { fehler_dot(*stream_); }
  2315.       { var reg5 object object1; # letztes Listenelement
  2316.         loop # Schleife, um letztes Listenelement zu lesen
  2317.           { # nΣchstes non-whitespace Character:
  2318.             var reg2 object ch;
  2319.             var reg3 uintWL scode;
  2320.             wpeek_char_syntax(ch = ,scode = ,stream_);
  2321.             if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2322.               # ja -> Fehler
  2323.               { fehler_dot:
  2324.                 pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2325.                 pushSTACK(*stream_); # Stream
  2326.                 pushSTACK(S(read_delimited_list));
  2327.                 fehler(stream_error,
  2328.                        DEUTSCH ? "~ von ~: Kein korrekter Listenabschlu▀ einer Dotted List." :
  2329.                        ENGLISH ? "~ from ~: illegal end of dotted list" :
  2330.                        FRANCAIS ? "~ de ~ : liste pointΘe ne se termine pas correctement." :
  2331.                        ""
  2332.                       );
  2333.               }
  2334.             if (scode < syntax_t_macro) # Macro-Character?
  2335.               # nein -> letztes Objekt lesen:
  2336.               { object1 = read_recursive_no_dot(stream_); break; }
  2337.               else
  2338.               # ja -> zugeh÷riges Zeichen lesen und Macro-Funktion ausfⁿhren:
  2339.               { ch = read_char(stream_);
  2340.                 read_macro(ch,stream_);
  2341.                 if (!(mv_count==0)) # Wert zurⁿck?
  2342.                   { object1 = value1; break; } # ja -> als letztes Objekt nehmen
  2343.                   # nein -> ⁿberlesen
  2344.               }
  2345.           }
  2346.         # object1 ist das letzte Objekt
  2347.         # als (cdr (last Gesamtliste)) in die Liste einhΣngen:
  2348.         Cdr(STACK_0) = object1;
  2349.       }
  2350.       loop # Schleife, um Kommentar nach letztem Listenelement zu lesen
  2351.         { # nΣchstes non-whitespace Character:
  2352.           var reg2 object ch;
  2353.           var reg3 uintWL scode;
  2354.           wpeek_char_syntax(ch = ,scode = ,stream_);
  2355.           if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2356.             { goto finish_list; } # ja -> Liste fertig
  2357.           if (scode < syntax_t_macro) # Macro-Character?
  2358.             # nein -> Dot kam zu frⁿh, Fehler
  2359.             { goto fehler_dot; }
  2360.             else
  2361.             # ja -> zugeh÷riges Zeichen lesen und Macro-Funktion ausfⁿhren:
  2362.             { ch = read_char(stream_);
  2363.               read_macro(ch,stream_);
  2364.               if (!(mv_count==0)) # Wert zurⁿck?
  2365.                 { goto fehler_dot; } # ja -> Dot kam zu frⁿh, Fehler
  2366.                 # nein -> ⁿberlesen
  2367.             }
  2368.         }
  2369.     }
  2370.  
  2371. # Macro: ▄berprⁿft das Stream-Argument eines SUBRs.
  2372. # stream_ = test_stream_arg(stream);
  2373. # > stream: Stream-Argument im STACK
  2374. # > subr_self: Aufrufer (ein SUBR)
  2375. # < stream_: &stream
  2376.   #define test_stream_arg(stream)  \
  2377.     (!mstreamp(stream) ? (fehler_stream(stream), (object*)NULL) : &(stream))
  2378.  
  2379. # (set-macro-character #\(
  2380. #   #'(lambda (stream char)
  2381. #       (read-delimited-list #\) stream t :dot-allowed t)
  2382. # )   )
  2383. LISPFUNN(lpar_reader,2) # liest (
  2384.   { var reg1 object* stream_ = test_stream_arg(STACK_1);
  2385.     # Liste nach '(' bis ')' lesen, Dot erlaubt:
  2386.     value1 = read_delimited_list(stream_,code_char(')'),dot_value); mv_count=1;
  2387.     skipSTACK(2);
  2388.   }
  2389.  
  2390. # #| ( ( |#
  2391. # (set-macro-character #\)
  2392. #   #'(lambda (stream char)
  2393. #       (error "~ von ~: ~ am Anfang eines Objekts" 'read stream char)
  2394. # )   )
  2395. LISPFUNN(rpar_reader,2) # liest )
  2396.   { var reg1 object* stream_ = test_stream_arg(STACK_1);
  2397.     pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2398.     pushSTACK(STACK_(0+1)); # char
  2399.     pushSTACK(*stream_); # stream
  2400.     pushSTACK(S(read));
  2401.     fehler(stream_error,
  2402.            DEUTSCH ? "~ von ~: ~ am Anfang eines Objekts" :
  2403.            ENGLISH ? "~ from ~: an object cannot start with ~" :
  2404.            FRANCAIS ? "~ de ~ : un object ne peut pas commencer par ~" :
  2405.            ""
  2406.           );
  2407.   }
  2408.  
  2409. # (set-macro-character #\"
  2410. #   #'(lambda (stream char)
  2411. #       (let ((buffer (make-array 50 :element-type 'string-char
  2412. #                                    :adjustable t :fill-pointer 0
  2413. #            ))       )
  2414. #         (loop
  2415. #           (multiple-value-bind (ch sy) (read-char-syntax stream)
  2416. #             (cond ((eq sy 'eof-code)
  2417. #                    (error "~: Eingabestream ~ endet innerhalb eines Strings."
  2418. #                           'read stream
  2419. #                   ))
  2420. #                   ((eql ch char) (return (coerce buffer 'simple-string)))
  2421. #                   ((eq sy 'single-escape)
  2422. #                    (multiple-value-setq (ch sy) (read-char-syntax stream))
  2423. #                    (when (eq sy 'eof-code) (error ...))
  2424. #                    (vector-push-extend ch buffer)
  2425. #                   )
  2426. #                   (t (vector-push-extend ch buffer))
  2427. #         ) ) )
  2428. #         (if *read-suppress* nil (coerce buffer 'simple-string))
  2429. # )   ) )
  2430. LISPFUNN(string_reader,2) # liest "
  2431.   { var reg1 object* stream_ = test_stream_arg(STACK_1);
  2432.     # Stackaufbau: stream, char.
  2433.     if (test_value(S(read_suppress))) # *READ-SUPPRESS* /= NIL ?
  2434.       # ja -> String nur ⁿberlesen:
  2435.       { loop
  2436.           { # nΣchstes Zeichen lesen:
  2437.             var reg2 object ch;
  2438.             var reg3 uintWL scode;
  2439.             read_char_syntax(ch = ,scode = ,stream_);
  2440.             if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2441.             if (eq(ch,STACK_0)) break; # selbes Zeichen wie char -> fertig
  2442.             if (scode == syntax_single_esc) # Single-Escape-Character?
  2443.               # ja -> nochmal ein Zeichen lesen:
  2444.               { read_char_syntax(ch = ,scode = ,stream_);
  2445.                 if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2446.               }
  2447.           }
  2448.         value1 = NIL; # NIL als Wert
  2449.       }
  2450.       else
  2451.       # nein -> String wirklich lesen
  2452.       { get_buffers(); # zwei leere Buffer auf den Stack
  2453.         # Stackaufbau: stream, char, andererBuffer, Buffer.
  2454.         loop
  2455.           { # nΣchstes Zeichen lesen:
  2456.             var reg2 object ch;
  2457.             var reg3 uintWL scode;
  2458.             read_char_syntax(ch = ,scode = ,stream_);
  2459.             if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2460.             if (eq(ch,STACK_2)) break; # selbes Zeichen wie char -> fertig
  2461.             if (scode == syntax_single_esc) # Single-Escape-Character?
  2462.               # ja -> nochmal ein Zeichen lesen:
  2463.               { read_char_syntax(ch = ,scode = ,stream_);
  2464.                 if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2465.               }
  2466.             # Zeichen ch in den Buffer schieben:
  2467.             ssstring_push_extend(STACK_0,char_code(ch));
  2468.           }
  2469.         # Buffer kopieren und dabei in Simple-String umwandeln:
  2470.         { var reg2 object string = copy_string(STACK_0);
  2471.           #ifdef IMMUTABLE_ARRAY
  2472.           if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2473.             { string = make_imm_array(string); }
  2474.           #endif
  2475.           value1 = string;
  2476.         }
  2477.         # Buffer zur Wiederverwendung freigeben:
  2478.         O(token_buff_2) = popSTACK(); O(token_buff_1) = popSTACK();
  2479.       }
  2480.     mv_count=1; skipSTACK(2); return;
  2481.     fehler_eof:
  2482.       pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2483.       pushSTACK(*stream_); # Stream
  2484.       pushSTACK(S(read));
  2485.       fehler(end_of_file,
  2486.              DEUTSCH ? "~: Eingabestream ~ endet innerhalb eines Strings." :
  2487.              ENGLISH ? "~: input stream ~ ends within a string" :
  2488.              FRANCAIS ? "~ : Le ½stream╗ d'entrΘe ~ se termine au milieu d'une chaεne." :
  2489.              ""
  2490.             );
  2491.   }
  2492.  
  2493. # Liest ein Objekt und bildet eine zweielementige Liste.
  2494. # list2_reader(stream_);
  2495. # > Stackaufbau: stream, symbol.
  2496. # erh÷ht STACK um 2
  2497. # verΣndert STACK, kann GC ausl÷sen
  2498.   local Values list2_reader (object* stream_);
  2499.   local Values list2_reader(stream_)
  2500.     var reg3 object* stream_;
  2501.     { var reg4 object obj = read_recursive_no_dot(stream_); # Objekt lesen
  2502.       pushSTACK(obj);
  2503.       pushSTACK(allocate_cons()); # zweites Listencons
  2504.      {var reg1 object new_cons1 = allocate_cons(); # erstes Listencons
  2505.       var reg2 object new_cons2 = popSTACK(); # zweites Listencons
  2506.       Car(new_cons2) = popSTACK(); # new_cons2 = (cons obj nil)
  2507.       #ifdef IMMUTABLE_CONS
  2508.       if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2509.         { new_cons2 = make_imm_cons(new_cons2); }
  2510.       #endif
  2511.       Cdr(new_cons1) = new_cons2; Car(new_cons1) = STACK_0; # new_cons1 = (cons symbol new_cons2)
  2512.       #ifdef IMMUTABLE_CONS
  2513.       if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2514.         { new_cons1 = make_imm_cons(new_cons1); }
  2515.       #endif
  2516.       value1 = new_cons1; mv_count=1; skipSTACK(2);
  2517.     }}
  2518.  
  2519. # (set-macro-character #\'
  2520. #   #'(lambda (stream char)
  2521. #       (list 'QUOTE (read stream t nil t))
  2522. # )   )
  2523. LISPFUNN(quote_reader,2) # liest '
  2524.   { var reg3 object* stream_ = test_stream_arg(STACK_1);
  2525.     STACK_0 = S(quote); return_Values list2_reader(stream_);
  2526.   }
  2527.  
  2528. # (set-macro-character #\;
  2529. #   #'(lambda (stream char)
  2530. #       (loop
  2531. #         (let ((ch (read-char stream)))
  2532. #           (when (or (eql ch 'eof-code) (eql ch #\Newline)) (return))
  2533. #       ) )
  2534. #       (values)
  2535. # )   )
  2536. LISPFUNN(line_comment_reader,2) # liest ;
  2537.   { var reg2 object* stream_ = test_stream_arg(STACK_1);
  2538.     loop
  2539.       { var reg1 object ch = read_char(stream_); # Zeichen lesen
  2540.         if (eq(ch,eof_value) || eq(ch,code_char(NL))) break;
  2541.       }
  2542.     value1 = NIL; mv_count=0; skipSTACK(2); # keine Werte zurⁿck
  2543.   }
  2544.  
  2545. # ------------------------- READ-Dispatch-Macros ------------------------------
  2546.  
  2547. # Fehlermeldung wegen einer unerlaubten Zahl bei Dispatch-Macros
  2548. # fehler_dispatch_zahl();
  2549. # > STACK_1: Stream
  2550. # > STACK_0: sub-char
  2551.   nonreturning_function(local, fehler_dispatch_zahl, (void));
  2552.   local void fehler_dispatch_zahl()
  2553.     { pushSTACK(STACK_1); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2554.       pushSTACK(STACK_(0+1)); # sub-char
  2555.       pushSTACK(STACK_(1+2)); # Stream
  2556.       pushSTACK(S(read));
  2557.       fehler(stream_error,
  2558.              DEUTSCH ? "~ von ~: Zwischen #"" und $ darf keine Zahl stehen." :
  2559.              ENGLISH ? "~ from ~: no number allowed between #"" and $" :
  2560.              FRANCAIS ? "~ de ~ : il ne faut pas de nombre entre #"" et $" :
  2561.              ""
  2562.             );
  2563.     }
  2564.  
  2565. # UP: ▄berprⁿft die Abwesenheit eines Infix-Arguments n
  2566. # test_no_infix()
  2567. # > Stackaufbau: Stream, sub-char, n.
  2568. # < ergebnis: &stream
  2569. # erh÷ht STACK um 1
  2570. # verΣndert STACK
  2571.   local object* test_no_infix (void);
  2572.   local object* test_no_infix()
  2573.     { var reg1 object* stream_ = test_stream_arg(STACK_2);
  2574.       var reg2 object n = popSTACK();
  2575.       if ((!nullp(n)) && (!test_value(S(read_suppress))))
  2576.         # Bei n/=NIL und *READ-SUPPRESS*=NIL : Fehler melden
  2577.         { fehler_dispatch_zahl(); }
  2578.       return stream_;
  2579.     }
  2580.  
  2581. # (set-dispatch-macro-character #\# #\'
  2582. #   #'(lambda (stream sub-char n)
  2583. #       (when n (error ...))
  2584. #       (list 'FUNCTION (read stream t nil t))
  2585. # )   )
  2586. LISPFUNN(function_reader,3) # liest #'
  2587.   { var reg3 object* stream_ = test_no_infix(); # n mu▀ NIL sein
  2588.     STACK_0 = S(function); return_Values list2_reader(stream_);
  2589.   }
  2590.  
  2591. # (set-dispatch-macro-character #\# #\|
  2592. #   #'(lambda (stream sub-char n) ; mit (not (eql sub-char #\#))
  2593. #       (when n (error ...))
  2594. #       (prog ((depth 0) ch)
  2595. #         1
  2596. #         (setq ch (read-char))
  2597. #         2
  2598. #         (case ch
  2599. #           (eof-code (error ...))
  2600. #           (sub-char (case (setq ch (read-char))
  2601. #                       (eof-code (error ...))
  2602. #                       (#\# (when (minusp (decf depth)) (return)))
  2603. #                       (t (go 2))
  2604. #           )         )
  2605. #           (#\# (case (setq ch (read-char))
  2606. #                  (eof-code (error ...))
  2607. #                  (sub-char (incf depth) (go 1))
  2608. #                  (t (go 2))
  2609. #           )    )
  2610. #           (t (go 1))
  2611. #       ) )
  2612. #       (values)
  2613. # )   )
  2614. LISPFUNN(comment_reader,3) # liest #|
  2615.   { var reg1 object* stream_ = test_no_infix(); # n mu▀ NIL sein
  2616.     var reg3 uintL depth = 0;
  2617.     var reg2 object ch;
  2618.     loop1:
  2619.       ch = read_char(stream_);
  2620.     loop2:
  2621.       if (eq(ch,eof_value)) goto fehler_eof; # EOF -> Error
  2622.       elif (eq(ch,STACK_0))
  2623.         # sub-char gelesen
  2624.         { ch = read_char(stream_); # nΣchstes Zeichen
  2625.           if (eq(ch,eof_value)) goto fehler_eof; # EOF -> Error
  2626.           elif (eq(ch,code_char('#')))
  2627.             # sub-char und '#' gelesen -> depth erniedrigen:
  2628.             { if (depth==0) goto fertig;
  2629.               depth--; goto loop1;
  2630.             }
  2631.           else
  2632.             goto loop2;
  2633.         }
  2634.       elif (eq(ch,code_char('#')))
  2635.         # '#' gelesen
  2636.         { ch = read_char(stream_); # nΣchstes Zeichen
  2637.           if (eq(ch,eof_value)) goto fehler_eof; # EOF -> Error
  2638.           elif (eq(ch,STACK_0))
  2639.             # '#' und sub-char gelesen -> depth erh÷hen:
  2640.             { depth++; goto loop1; }
  2641.           else
  2642.             goto loop2;
  2643.         }
  2644.       else goto loop1;
  2645.     fehler_eof:
  2646.       pushSTACK(STACK_1); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2647.       pushSTACK(STACK_(0+1)); # sub-char
  2648.       pushSTACK(STACK_(0+2)); # sub-char
  2649.       pushSTACK(STACK_(1+3)); # Stream
  2650.       pushSTACK(S(read));
  2651.       fehler(end_of_file,
  2652.              DEUTSCH ? "~: Eingabestream ~ endet innerhalb eines Kommentars #$ ... $#" :
  2653.              ENGLISH ? "~: input stream ~ ends within a comment #$ ... $#" :
  2654.              FRANCAIS ? "~ : Le ½stream╗ d'entrΘe se termine au cours d'un commentaire #$ ... $#" :
  2655.              ""
  2656.             );
  2657.     fertig:
  2658.       value1 = NIL; mv_count=0; skipSTACK(2); # keine Werte zurⁿck
  2659.   }
  2660.  
  2661. # (set-dispatch-macro-character #\# #\\ 
  2662. #   #'(lambda (stream sub-char n)
  2663. #       (let ((token (read-token-1 stream #\\ 'single-escape)))
  2664. #         ; token ist ein String der LΣnge >=1
  2665. #         (unless *read-suppress*
  2666. #           (if n
  2667. #             (unless (< n char-font-limit) ; sowieso n>=0
  2668. #               (error "~ von ~: Fontnummer ~ fⁿr Zeichen ist zu gro▀ (mu▀ <~ sein)."
  2669. #                       'read stream        n                 char-font-limit
  2670. #             ) )
  2671. #             (setq n 0)
  2672. #           )
  2673. #           (let ((pos 0) (bits 0))
  2674. #             (loop
  2675. #               (if (= (+ pos 1) (length token))
  2676. #                 (return (make-char (char token pos) bits n))
  2677. #                 (let ((hyphen (position #\- token :start pos)))
  2678. #                   (if hyphen
  2679. #                     (flet ((equalx (name)
  2680. #                              (or (string-equal token name :start1 pos :end1 hyphen)
  2681. #                                  (string-equal token name :start1 pos :end1 hyphen :end2 1)
  2682. #                           )) )
  2683. #                       (cond ((equalx "CONTROL")
  2684. #                              (setq bits (logior bits char-control-bit)))
  2685. #                             ((equalx "META")
  2686. #                              (setq bits (logior bits char-meta-bit)))
  2687. #                             ((equalx "SUPER")
  2688. #                              (setq bits (logior bits char-super-bit)))
  2689. #                             ((equalx "HYPER")
  2690. #                              (setq bits (logior bits char-hyper-bit)))
  2691. #                             (t (error "~ von ~: Ein Character-Bit mit Namen ~ gibt es nicht."
  2692. #                                        'read stream (subseq token pos hyphen)
  2693. #                       )     )  )
  2694. #                       (setq pos (1+ hyphen))
  2695. #                     )
  2696. #                     (return
  2697. #                       (make-char
  2698. #                         (cond ((and (< (+ pos 4) (length token))
  2699. #                                     (string-equal token "CODE" :start1 pos :end1 (+ pos 4))
  2700. #                                )
  2701. #                                (code-char (parse-integer token :start (+ pos 4) :junk-allowed nil)) ; ohne Vorzeichen!
  2702. #                               )
  2703. #                               ((name-char (subseq token pos)))
  2704. #                               (t (error "~ von ~: Ein Character mit Namen ~ gibt es nicht."
  2705. #                                          'read stream (subseq token pos)
  2706. #                         )     )  )
  2707. #                         bits n
  2708. #                     ) )
  2709. #             ) ) ) )
  2710. # )   ) ) ) )
  2711. LISPFUNN(char_reader,3) # liest #\ 
  2712.   { # Stackaufbau: Stream, sub-char, n.
  2713.     var reg10 object* stream_ = test_stream_arg(STACK_2);
  2714.     # Token lesen, mit Dummy-Character '\' als Token-Anfang:
  2715.     read_token_1(stream_,code_char('\\'),syntax_single_esc);
  2716.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  2717.     if (test_value(S(read_suppress)))
  2718.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  2719.     # Zeichen aufbauen:
  2720.    {var reg9 cint c = 0; # im Aufbau befindliches Zeichen
  2721.     # Font bestimmen:
  2722.     if (!nullp(STACK_0)) # n=NIL -> Default-Font 0
  2723.       { var reg1 uintL font;
  2724.         if (mposfixnump(STACK_0) && ((font = posfixnum_to_L(STACK_0)) < char_font_limit))
  2725.           { c |= (font << char_font_shift_c); } # font einbauen
  2726.           else
  2727.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2728.             pushSTACK(fixnum(char_font_limit)); # char-font-limit
  2729.             pushSTACK(STACK_(0+2)); # n
  2730.             pushSTACK(*stream_); # Stream
  2731.             pushSTACK(S(read));
  2732.             fehler(stream_error,
  2733.                    DEUTSCH ? "~ von ~: Fontnummer ~ fⁿr Zeichen ist zu gro▀ (mu▀ < ~ sein)" :
  2734.                    ENGLISH ? "~ from ~: font number ~ for character is too large, should be < ~" :
  2735.                    FRANCAIS ? "~ de ~ : Le numΘro ~ de font de caractΦre est trop grand (devrait Ωtre < ~)." :
  2736.                    ""
  2737.                   );
  2738.           }
  2739.       }
  2740.     # Font fertig.
  2741.     { var reg5 object token = O(token_buff_1); # gelesenes Token als Semi-Simple-String
  2742.       var reg7 uintL len = TheArray(token)->dims[1]; # LΣnge = Fill-Pointer
  2743.       var reg6 object hstring = O(displaced_string); # Hilfsstring
  2744.       TheArray(hstring)->data = token; # Datenvektor := O(token_buff_1)
  2745.       token = TheArray(token)->data; # Simple-String mit Token
  2746.      {var reg8 uintL pos = 0; # momentane Position im Token
  2747.       loop # Suche nΣchstes Hyphen
  2748.         { if (len-pos == 1) goto remains_one; # einbuchstabiger Charactername?
  2749.           { var reg7 uintL hyphen = pos; # hyphen := pos
  2750.             loop
  2751.               { if (hyphen == len) goto no_more_hyphen; # schon Token-Ende?
  2752.                 if (TheSstring(token)->data[hyphen] == '-') break; # Hyphen gefunden?
  2753.                 hyphen++; # nein -> weitersuchen
  2754.               }
  2755.             # Hyphen bei Position hyphen gefunden
  2756.            {var reg10 uintL sub_len = hyphen-pos;
  2757.             TheArray(hstring)->dims[0] = pos; # Displaced-Offset := pos
  2758.             TheArray(hstring)->totalsize =
  2759.               TheArray(hstring)->dims[1] = sub_len; # LΣnge := hyphen-pos
  2760.             # Jetzt ist hstring = (subseq token pos hyphen)
  2761.             if (sub_len==1)
  2762.               # LΣnge=1 -> auf Bitnamen-Abkⁿrzungen ⁿberprⁿfen:
  2763.               { var reg4 uintB bitname1 = TheSstring(token)->data[pos]; # (char token pos)
  2764.                 bitname1 = up_case(bitname1); # als Gro▀buchstabe
  2765.                 # Ist es einer der Anfangsbuchstaben der Bitnamen?
  2766.                {var reg1 object* bitnameptr = &O(bitname_0);
  2767.                 var reg2 uintL bitnr = char_bits_shift_c;
  2768.                 var reg3 uintL count;
  2769.                 dotimesL(count,char_bits_len_c, # alle Bitnamen durchlaufen
  2770.                   { var reg1 object bitname = *bitnameptr++; # nΣchster Bitname (Simple-String)
  2771.                     if (TheSstring(bitname)->data[0] == bitname1) # mit bitname1 als Anfangsbuchstaben?
  2772.                       { c |= bit(bitnr); goto bit_ok; } # ja -> entsprechendes Bit setzen
  2773.                     bitnr++;
  2774.                   });
  2775.               }}
  2776.             # Ist es einer der Bitnamen selber?
  2777.             {var reg1 object* bitnameptr = &O(bitname_0);
  2778.              var reg2 uintL bitnr = char_bits_shift_c;
  2779.              var reg3 uintL count;
  2780.              dotimesL(count,char_bits_len_c, # alle Bitnamen durchlaufen
  2781.                { var reg1 object bitname = *bitnameptr++; # nΣchster Bitname (Simple-String)
  2782.                  if (string_equal(hstring,bitname)) # mit hstring vergleichen
  2783.                    { c |= bit(bitnr); goto bit_ok; } # gleich -> entsprechendes Bit setzen
  2784.                  bitnr++;
  2785.                });
  2786.             }
  2787.             # Displaced-String hstring ist kein Bitname -> Error
  2788.             { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2789.               pushSTACK(copy_string(hstring)); # Displaced-String kopieren
  2790.               pushSTACK(*stream_); # Stream
  2791.               pushSTACK(S(read));
  2792.               fehler(stream_error,
  2793.                      DEUTSCH ? "~ von ~: Ein Character-Bit mit Namen ~ gibt es nicht." :
  2794.                      ENGLISH ? "~ from ~: there is no character bit with name ~" :
  2795.                      FRANCAIS ? "~ de ~ : ~ n'est pas le nom d'un bit de caractΦre." :
  2796.                      ""
  2797.                     );
  2798.             }
  2799.             bit_ok: # Bitname gefunden, Bit gesetzt
  2800.             # Mit diesem Bitnamen fertig.
  2801.             pos = hyphen+1; # zum nΣchsten
  2802.         } }}
  2803.       remains_one: # einbuchstabiger Charactername
  2804.       {var reg1 uintB code = TheSstring(token)->data[pos]; # (char token pos)
  2805.        c |= (code << char_code_shift_c); # Code einbauen
  2806.        value1 = int_char(c); mv_count=1; skipSTACK(3); return;
  2807.       }
  2808.       no_more_hyphen: # kein weiteres Hyphen gefunden.
  2809.       {var reg10 uintL sub_len = len-pos; # LΣnge des Characternamens
  2810.        TheArray(hstring)->dims[0] = pos; # Displaced-Offset := pos
  2811.        /* TheArray(hstring)->totalsize =          */
  2812.        /*   TheArray(hstring)->dims[1] = sub_len; */ # LΣnge := len-pos
  2813.        # hstring = (subseq token pos hyphen) = restlicher Charactername
  2814.        # Test auf Characternamen "CODExxxx" (xxxx Dezimalzahl <256):
  2815.        if (sub_len > 4)
  2816.          { TheArray(hstring)->totalsize =
  2817.              TheArray(hstring)->dims[1] = 4;
  2818.            # hstring = (subseq token pos (+ pos 4))
  2819.            if (!string_equal(hstring,O(charname_prefix))) # = "Code" ?
  2820.              goto not_codexxxx; # nein -> weiter
  2821.            # Dezimalzahl entziffern:
  2822.           {var reg2 uintWL code = 0; # bisher gelesenes xxxx (<char_code_limit)
  2823.            var reg4 uintL index = pos+4;
  2824.            var reg3 uintB* charptr = &TheSstring(token)->data[index];
  2825.            loop
  2826.              { if (index == len) break; # Token-Ende erreicht?
  2827.               {var reg1 uintB c = *charptr++; # nΣchstes Character
  2828.                # soll Ziffer sein:
  2829.                if (!((c>='0') && (c<='9'))) goto not_codexxxx;
  2830.                code = 10*code + (c-'0'); # Ziffer dazunehmen
  2831.                # code soll < char_code_limit bleiben:
  2832.                if (code >= char_code_limit) goto not_codexxxx;
  2833.                index++;
  2834.              }}
  2835.            # Charactername war vom Typ "Codexxxx" mit code = xxxx < char_code_limit
  2836.            c |= ((cint)code << char_code_shift_c); # Code einbauen
  2837.            value1 = int_char(c); mv_count=1; skipSTACK(3); return;
  2838.          }}
  2839.        not_codexxxx:
  2840.        # Test auf Characternamen wie NAME-CHAR:
  2841.        TheArray(hstring)->totalsize =
  2842.          TheArray(hstring)->dims[1] = sub_len; # LΣnge := len-pos
  2843.        {var reg1 object ch = name_char(hstring); # Character mit diesem Namen suchen
  2844.         if (nullp(ch))
  2845.           # nicht gefunden -> Error
  2846.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2847.             pushSTACK(copy_string(hstring)); # Charactername kopieren
  2848.             pushSTACK(*stream_); # Stream
  2849.             pushSTACK(S(read));
  2850.             fehler(stream_error,
  2851.                    DEUTSCH ? "~ von ~: Ein Character mit Namen ~ gibt es nicht." :
  2852.                    ENGLISH ? "~ from ~: there is no character with name ~" :
  2853.                    FRANCAIS ? "~ de ~ : ~ n'est pas le nom d'un caractΦre." :
  2854.                    ""
  2855.                   );
  2856.           }
  2857.         # gefunden
  2858.         c |= char_int(ch); # Code einbauen
  2859.         value1 = int_char(c); mv_count=1; skipSTACK(3); return;
  2860.       }}
  2861.   }}}}
  2862.  
  2863. # (defun radix-1 (stream sub-char n base)
  2864. #   (let ((token (read-token stream)))
  2865. #     (unless *read-suppress*
  2866. #       (when n (error ...))
  2867. #       (if (case (test-number-syntax token base)
  2868. #             (integer t) (decimal-integer nil) (rational t) (float nil)
  2869. #           )
  2870. #         (read-number token base)
  2871. #         (error "~ von ~: Das Token ~ nach # ~ lΣ▀t sich nicht als rationale Zahl in Basis ~ interpretieren."
  2872. #                 'read stream token sub-char base
  2873. # ) ) ) ) )
  2874.   # UP fⁿr #B #O #X #R
  2875.   # radix_2(base)
  2876.   # > base: Basis (>=2, <=36)
  2877.   # > Stackaufbau: Stream, sub-char, base.
  2878.   # > O(token_buff_1), O(token_buff_2), token_escape_flag: gelesenes Token
  2879.   # < STACK: aufgerΣumt
  2880.   # < mv_space/mv_count: Werte
  2881.   # kann GC ausl÷sen
  2882.   local Values radix_2 (uintWL base);
  2883.   local Values radix_2(base)
  2884.     var uintWL base;
  2885.     { # ▄berprⁿfe, ob das Token eine rationale Zahl darstellt:
  2886.       var object string;
  2887.       var zahl_info info;
  2888.       upcase_token(); # in Gro▀buchstaben umwandeln
  2889.       switch (test_number_syntax(&base,&string,&info))
  2890.         { case 1: # Integer
  2891.             # letztes Character ein Punkt?
  2892.             if (TheSstring(string)->data[info.index2-1] == '.')
  2893.               # ja -> Dezimal-Integer, nicht in Basis base
  2894.               goto not_rational;
  2895.             # test_number_syntax wurde bereits im Schritt 3 fertig,
  2896.             # also ist base immer noch unverΣndert.
  2897.             skipSTACK(3);
  2898.             value1 = read_integer(base,info.sign,string,info.index1,info.index2);
  2899.             mv_count=1; return;
  2900.           case 2: # Rational
  2901.             # test_number_syntax wurde bereits im Schritt 3 fertig,
  2902.             # also ist base immer noch unverΣndert.
  2903.             skipSTACK(3);
  2904.             value1 = read_rational(base,info.sign,string,info.index1,info.index3,info.index2);
  2905.             mv_count=1; return;
  2906.           case 0: # keine Zahl
  2907.           case 3: # Float
  2908.           not_rational: # keine rationale Zahl
  2909.             pushSTACK(STACK_2); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2910.             pushSTACK(STACK_(0+1)); # base
  2911.             pushSTACK(STACK_(1+2)); # sub-char
  2912.             pushSTACK(copy_string(O(token_buff_1))); # Token
  2913.             pushSTACK(STACK_(2+4)); # Stream
  2914.             pushSTACK(S(read));
  2915.             fehler(stream_error,
  2916.                    DEUTSCH ? "~ von ~: Das Token ~ nach #$ lΣ▀t sich nicht als rationale Zahl in Basis ~ interpretieren." :
  2917.                    ENGLISH ? "~ from ~: token ~ after #$ is not a rational number in base ~" :
  2918.                    FRANCAIS ? "~ de ~ : Le lexΦme ~ aprΦs ne peut Ωtre interprΘtΘ comme nombre rationnel en base ~." :
  2919.                    ""
  2920.                   );
  2921.           default: NOTREACHED
  2922.         }
  2923.     }
  2924.   # UP fⁿr #B #O #X
  2925.   # radix_1(base)
  2926.   # > base: Basis (>=2, <=36)
  2927.   # > Stackaufbau: Stream, sub-char, n.
  2928.   # < STACK: aufgerΣumt
  2929.   # < mv_space/mv_count: Werte
  2930.   # kann GC ausl÷sen
  2931.   local Values radix_1 (uintWL base);
  2932.   local Values radix_1(base)
  2933.     var reg2 uintWL base;
  2934.     { var reg1 object* stream_ = test_stream_arg(STACK_2);
  2935.       read_token(stream_); # Token lesen
  2936.       # bei *READ-SUPPRESS* /= NIL sofort fertig:
  2937.       if (test_value(S(read_suppress)))
  2938.         { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  2939.       if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  2940.       pushSTACK(fixnum(base)); # base als Fixnum
  2941.       return_Values radix_2(base);
  2942.     }
  2943.  
  2944. # (set-dispatch-macro-character #\# #\B
  2945. #   #'(lambda (stream sub-char n) (radix-1 stream sub-char n 2))
  2946. # )
  2947. LISPFUNN(binary_reader,3) # liest #B
  2948.   { return_Values radix_1(2); }
  2949.  
  2950. # (set-dispatch-macro-character #\# #\O
  2951. #   #'(lambda (stream sub-char n) (radix-1 stream sub-char n 8))
  2952. # )
  2953. LISPFUNN(octal_reader,3) # liest #O
  2954.   { return_Values radix_1(8); }
  2955.  
  2956. # (set-dispatch-macro-character #\# #\X
  2957. #   #'(lambda (stream sub-char n) (radix-1 stream sub-char n 16))
  2958. # )
  2959. LISPFUNN(hexadecimal_reader,3) # liest #X
  2960.   { return_Values radix_1(16); }
  2961.  
  2962. # (set-dispatch-macro-character #\# #\R
  2963. #   #'(lambda (stream sub-char n)
  2964. #       (if *read-suppress*
  2965. #         (if (and n (<= 2 n 36))
  2966. #           (radix-1 stream sub-char nil n)
  2967. #           (error "~ von ~: Zwischen # und R mu▀ eine Zahlsystembasis zwischen 2 und 36 angegeben werden."
  2968. #                   'read stream
  2969. #         ) )
  2970. #         (progn (read-token stream) nil)
  2971. # )   ) )
  2972. LISPFUNN(radix_reader,3) # liest #R
  2973.   { var reg1 object* stream_ = test_stream_arg(STACK_2);
  2974.     read_token(stream_); # Token lesen
  2975.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  2976.     if (test_value(S(read_suppress)))
  2977.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  2978.     # n ⁿberprⁿfen:
  2979.     if (nullp(STACK_0))
  2980.       { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2981.         pushSTACK(*stream_); # Stream
  2982.         pushSTACK(S(read));
  2983.         fehler(stream_error,
  2984.                DEUTSCH ? "~ von ~: Zwischen #"" und R mu▀ die Zahlsystembasis angegeben werden." :
  2985.                ENGLISH ? "~ from ~: the number base must be given between #"" and R" :
  2986.                FRANCAIS ? "~ de ~ : La base numΘrique doit Ωtre spΘcifiΘe entre #"" et R." :
  2987.                ""
  2988.               );
  2989.       }
  2990.    {var reg2 uintL base;
  2991.     # n mu▀ ein Fixnum zwischen 2 und 36 (inclusive) sein:
  2992.     if (mposfixnump(STACK_0) &&
  2993.         (base = posfixnum_to_L(STACK_0), (base >= 2) && (base <= 36))
  2994.        )
  2995.       { return_Values radix_2(base); } # Token als rationale Zahl interpretieren
  2996.       else
  2997.       { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  2998.         pushSTACK(STACK_(0+1)); # n
  2999.         pushSTACK(*stream_); # Stream
  3000.         pushSTACK(S(read));
  3001.         fehler(stream_error,
  3002.                DEUTSCH ? "~ von ~: Die zwischen #"" und R angegebene Basis ~ liegt nicht zwischen 2 und 36." :
  3003.                ENGLISH ? "~ from ~: The base ~ given between #"" and R should lie between 2 and 36" :
  3004.                FRANCAIS ? "~ de ~ : La base numΘrique ~ spΘcifiΘe entre #"" et R doit Ωtre entre 2 et 36." :
  3005.                ""
  3006.               );
  3007.       }
  3008.   }}
  3009.  
  3010. # (set-dispatch-macro-character #\# #\C
  3011. #   #'(lambda (stream sub-char n)
  3012. #       (declare (ignore sub-char))
  3013. #       (if *read-suppress*
  3014. #         (progn (read stream t nil t) nil)
  3015. #         (if n
  3016. #           (error "~: Zwischen # und C ist keine Zahl erlaubt." 'read)
  3017. #           (let ((h (read stream t nil t)))
  3018. #             (if (and (consp h) (consp (cdr h)) (null (cddr h))
  3019. #                      (numberp (first h)) (not (complexp (first h)))
  3020. #                      (numberp (second h)) (not (complexp (second h)))
  3021. #                 )
  3022. #               (apply #'complex h)
  3023. #               (error "~: Falsche Syntax fⁿr komplexe Zahl: #C~" 'read h)
  3024. # )   ) ) ) ) )
  3025. LISPFUNN(complex_reader,3) # liest #C
  3026.   { var reg3 object* stream_ = test_no_infix(); # n mu▀ NIL sein
  3027.     var reg1 object obj = read_recursive_no_dot(stream_); # nΣchstes Objekt lesen
  3028.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3029.     if (test_value(S(read_suppress)))
  3030.       { value1 = NIL; mv_count=1; skipSTACK(2); return; } # NIL als Wert
  3031.     obj = make_references(obj); # und Verweise vorzeitig entflechten
  3032.     # ▄berprⁿfen, ob dies eine zweielementige Liste von reellen Zahlen ist:
  3033.     if (!consp(obj)) goto bad; # obj mu▀ ein Cons sein !
  3034.    {var reg2 object obj2 = Cdr(obj);
  3035.     if (!consp(obj2)) goto bad; # obj2 mu▀ ein Cons sein !
  3036.     if (!nullp(Cdr(obj2))) goto bad; # mit (cdr obj2) = nil !
  3037.     if_realp(Car(obj), ; , goto bad; ); # und (car obj) eine reelle Zahl !
  3038.     if_realp(Car(obj2), ; , goto bad; ); # und (car obj2) eine reelle Zahl !
  3039.     # (apply #'COMPLEX obj) durchfⁿhren:
  3040.     apply(L(complex),0,obj);
  3041.     mv_count=1; skipSTACK(2); return; # value1 als Wert
  3042.    }
  3043.    {bad:
  3044.       pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3045.       pushSTACK(obj); # Objekt
  3046.       pushSTACK(*stream_); # Stream
  3047.       pushSTACK(S(read));
  3048.       fehler(stream_error,
  3049.              DEUTSCH ? "~ von ~: Falsche Syntax fⁿr komplexe Zahl: #C~" :
  3050.              ENGLISH ? "~ from ~: bad syntax for complex number: #C~" :
  3051.              FRANCAIS ? "~ de ~ : Syntaxe inadmissible pour un nombre complexe: #C~" :
  3052.              ""
  3053.             );
  3054.   }}
  3055.  
  3056. # (set-dispatch-macro-character #\# #\:
  3057. #   #'(lambda (stream sub-char n)
  3058. #       (declare (ignore sub-char))
  3059. #       (if *read-suppress*
  3060. #         (progn (read stream t nil t) nil)
  3061. #         (let ((name (read-token stream))) ; eine Form, die nur ein Token ist
  3062. #           (when n (error ...))
  3063. #           [▄berprⁿfe, ob auch keine Package-Marker im Token vorkommen.]
  3064. #           (make-symbol token)
  3065. # )   ) ) )
  3066. LISPFUNN(uninterned_reader,3) # liest #:
  3067.   { var reg3 object* stream_ = test_stream_arg(STACK_2);
  3068.     # bei *READ-SUPPRESS* /= NIL Form lesen und NIL liefern:
  3069.     if (test_value(S(read_suppress)))
  3070.       { read_recursive(stream_);
  3071.         value1 = NIL; mv_count=1; skipSTACK(3); return;
  3072.       }
  3073.     {# nΣchstes Zeichen lesen:
  3074.      var reg4 object ch;
  3075.      var reg5 uintWL scode;
  3076.      read_char_syntax(ch = ,scode = ,stream_);
  3077.      if (scode == syntax_eof) { fehler_eof_innen(stream_); } # EOF -> Error
  3078.      if (scode > syntax_constituent)
  3079.        # kein Zeichen, das am Token-Anfang stehen kann -> Error
  3080.        { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3081.          pushSTACK(*stream_); # Stream
  3082.          pushSTACK(S(read));
  3083.          fehler(stream_error,
  3084.                 DEUTSCH ? "~ von ~: Nach #: mu▀ ein Token folgen." :
  3085.                 ENGLISH ? "~ from ~: token expected after #:" :
  3086.                 FRANCAIS ? "~ de ~ : Il faut un lexΦme aprΦs #:" :
  3087.                 ""
  3088.                );
  3089.        }
  3090.      # Token zu Ende lesen:
  3091.      read_token_1(stream_,ch,scode);
  3092.     }
  3093.     if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  3094.     {# Token kopieren und dabei in Simple-String umwandeln:
  3095.      var reg5 object string = copy_string(O(token_buff_1));
  3096.      # Auf Package-Marker testen:
  3097.      {var reg3 object buff_2 = O(token_buff_2); # Attributcode-Buffer
  3098.       var reg2 uintL len = TheArray(buff_2)->dims[1]; # LΣnge = Fill-Pointer
  3099.       var reg1 uintB* attrptr = &TheSstring(TheArray(buff_2)->data)->data[0];
  3100.       # Teste, ob einer der len Attributcodes ab attrptr ein a_pack_m ist:
  3101.       dotimesL(len,len, { if (*attrptr++ == a_pack_m) goto fehler_dopp; } );
  3102.      }
  3103.      # uninterniertes Symbol mit diesem Namen bauen:
  3104.      value1 = make_symbol(string); mv_count=1; skipSTACK(2); return;
  3105.      fehler_dopp:
  3106.        pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3107.        pushSTACK(string); # Token
  3108.        pushSTACK(*stream_); # Stream
  3109.        pushSTACK(S(read));
  3110.        fehler(stream_error,
  3111.               DEUTSCH ? "~ von ~: Das Token ~ nach #: darf keine Doppelpunkte enthalten." :
  3112.               ENGLISH ? "~ from ~: token ~ after #: should contain no colon" :
  3113.               FRANCAIS ? "~ de ~ : Le lexΦme ~ aprΦs ne doit pas contenir de deux-points." :
  3114.               ""
  3115.              );
  3116.   } }
  3117.  
  3118. # (set-dispatch-macro-character #\# #\*
  3119. #   #'(lambda (stream sub-char n)
  3120. #       (declare (ignore sub-char))
  3121. #       (let* ((token (read-token stream)))
  3122. #         (unless *read-suppress*
  3123. #           (unless (or [Escape-Zeichen im Token verwendet]
  3124. #                       (every #'(lambda (ch) (member ch '(#\0 #\1))) token))
  3125. #             (error "~ von ~: Nach #* dⁿrfen nur Nullen und Einsen kommen."
  3126. #                     'read stream
  3127. #           ) )
  3128. #           (let ((l (length token)))
  3129. #             (if n
  3130. #               (cond ((< n l)
  3131. #                      (error "~ von ~: Bit-Vektor lΣnger als angegebene LΣnge ~."
  3132. #                              'read stream n
  3133. #                     ))
  3134. #                     ((and (plusp n) (zerop l))
  3135. #                      (error "~ von ~: Element fⁿr Bit-Vektor der LΣnge ~ mu▀ spezifiziert werden."
  3136. #                              'read stream n
  3137. #               )     ))
  3138. #               (setq n l)
  3139. #             )
  3140. #             (let ((bv (make-array n :element-type 'bit))
  3141. #                   (i 0)
  3142. #                   b)
  3143. #               (loop
  3144. #                 (when (= i n) (return))
  3145. #                 (when (< i l) (setq b (case (char token i) (#\0 0) (#\1 1))))
  3146. #                 (setf (sbit bv i) b)
  3147. #                 (incf i)
  3148. #               )
  3149. #               bv
  3150. # )   ) ) ) ) )
  3151. LISPFUNN(bit_vector_reader,3) # liest #*
  3152.   { var reg8 object* stream_ = test_stream_arg(STACK_2);
  3153.     read_token(stream_); # Token lesen
  3154.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3155.     if (test_value(S(read_suppress)))
  3156.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  3157.     # Test, ob kein Escape-Zeichen und nur Nullen und Einsen verwendet:
  3158.     if (token_escape_flag)
  3159.       { fehler_nur01:
  3160.         pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3161.         pushSTACK(*stream_); # Stream
  3162.         pushSTACK(S(read));
  3163.         fehler(stream_error,
  3164.                DEUTSCH ? "~ von ~: Nach #* dⁿrfen nur Nullen und Einsen kommen." :
  3165.                ENGLISH ? "~ from ~: only zeroes and ones are allowed after #*" :
  3166.                FRANCAIS ? "~ de ~ : Seuls 0 et 1 sont permis aprΦs #*" :
  3167.                ""
  3168.               );
  3169.       }
  3170.    {var reg7 object buff_1 = O(token_buff_1); # Character-Buffer
  3171.     var reg6 uintL len = TheArray(buff_1)->dims[1]; # LΣnge = Fill-Pointer
  3172.     {var reg2 uintB* charptr = &TheSstring(TheArray(buff_1)->data)->data[0];
  3173.      var reg3 uintL count;
  3174.      dotimesL(count,len,
  3175.        { var reg1 uintB c = *charptr++; # nΣchstes Character
  3176.          if (!((c=='0') || (c=='1'))) # nur '0' und '1' sind OK
  3177.            goto fehler_nur01;
  3178.        });
  3179.     }
  3180.     # n ⁿberprⁿfen:
  3181.     {var reg5 uintL n; # LΣnge des Bitvektors
  3182.      if (nullp(STACK_0))
  3183.        { n = len; } # Defaultwert ist die TokenlΣnge
  3184.        else
  3185.        { # n angegeben, ein Integer >=0.
  3186.          n = (mposfixnump(STACK_0) ? posfixnum_to_L(STACK_0) # Fixnum -> Wert
  3187.                                    : bitm(oint_data_len)-1 # Bignum -> gro▀er Wert
  3188.              );
  3189.          if (n<len)
  3190.            { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3191.              pushSTACK(STACK_(0+1)); # n
  3192.              pushSTACK(*stream_); # Stream
  3193.              pushSTACK(S(read));
  3194.              fehler(stream_error,
  3195.                     DEUTSCH ? "~ von ~: Bit-Vektor lΣnger als angegebene LΣnge ~." :
  3196.                     ENGLISH ? "~ from ~: bit vector is longer than the explicitly given length ~" :
  3197.                     FRANCAIS ? "~ de ~ : Le vecteur de bits est plus long que la longueur explicite ~." :
  3198.                     ""
  3199.                    );
  3200.            }
  3201.          if ((n>0) && (len==0))
  3202.            { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3203.              pushSTACK(STACK_(0+1)); # n
  3204.              pushSTACK(*stream_); # Stream
  3205.              pushSTACK(S(read));
  3206.              fehler(stream_error,
  3207.                     DEUTSCH ? "~ von ~: Element fⁿr Bit-Vektor der LΣnge ~ mu▀ spezifiziert werden." :
  3208.                     ENGLISH ? "~ from ~: must specify element of bit vector of length ~" :
  3209.                     FRANCAIS ? "~ de ~ : Il faut spΘcifier un ΘlΘment pour un vecteur de bits de longueur ~." :
  3210.                     ""
  3211.                    );
  3212.            }
  3213.        }
  3214.      # Erzeuge neuen Bit-Vektor der LΣnge n:
  3215.      {var reg2 object bv = allocate_bit_vector(n);
  3216.       # und fⁿlle die Bits ein:
  3217.       buff_1 = O(token_buff_1);
  3218.       { var reg4 uintB* charptr = &TheSstring(TheArray(buff_1)->data)->data[0];
  3219.         var reg3 uintB ch; # letztes Zeichen ('0' oder '1')
  3220.         var reg1 uintL index = 0;
  3221.         while (index < n)
  3222.           { if (index < len) { ch = *charptr++; } # evtl. nΣchstes Character holen
  3223.             if (ch == '0')
  3224.               { sbvector_bclr(bv,index); } # Null -> Bit l÷schen
  3225.               else
  3226.               { sbvector_bset(bv,index); } # Eins -> Bit setzen
  3227.             index++;
  3228.           }
  3229.       }
  3230.       #ifdef IMMUTABLE_ARRAY
  3231.       if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  3232.         { bv = make_imm_array(bv); }
  3233.       #endif
  3234.       value1 = bv; mv_count=1; skipSTACK(3); # bv als Wert
  3235.   }}}}
  3236.  
  3237. # (set-dispatch-macro-character #\# #\(
  3238. #   #'(lambda (stream sub-char n)
  3239. #       (declare (ignore sub-char))
  3240. #       (let* ((elements (read-delimited-list #\) stream t)))
  3241. #         (unless *read-suppress*
  3242. #           (let ((l (length elements)))
  3243. #             (if n
  3244. #               (cond ((< n l)
  3245. #                      (error "~ von ~: Vektor lΣnger als angegebene LΣnge ~."
  3246. #                              'read stream n
  3247. #                     ))
  3248. #                     ((and (plusp n) (zerop l))
  3249. #                      (error "~ von ~: Element fⁿr Vektor der LΣnge ~ mu▀ spezifiziert werden."
  3250. #                              'read stream n
  3251. #               )     ))
  3252. #               (setq n l)
  3253. #             )
  3254. #             (let ((v (make-array n))
  3255. #                   (i 0)
  3256. #                   b)
  3257. #               (loop
  3258. #                 (when (= i n) (return))
  3259. #                 (when (< i l) (setq b (pop elements)))
  3260. #                 (setf (svref v i) b)
  3261. #                 (incf i)
  3262. #               )
  3263. #               v
  3264. # )   ) ) ) ) )
  3265. LISPFUNN(vector_reader,3) # liest #(
  3266.   { var reg8 object* stream_ = test_stream_arg(STACK_2);
  3267.     # Liste bis zur Klammer zu lesen, Dot nicht erlaubt:
  3268.     var reg2 object elements = read_delimited_list(stream_,code_char(')'),eof_value);
  3269.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3270.     if (test_value(S(read_suppress)))
  3271.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  3272.    {var reg6 uintL len = llength(elements); # ListenlΣnge
  3273.     # n ⁿberprⁿfen:
  3274.     var reg5 uintL n; # LΣnge des Vektors
  3275.     if (nullp(STACK_0))
  3276.       { n = len; } # Defaultwert ist die TokenlΣnge
  3277.       else
  3278.       { # n angegeben, ein Integer >=0.
  3279.         n = (mposfixnump(STACK_0) ? posfixnum_to_L(STACK_0) # Fixnum -> Wert
  3280.                                   : bitm(oint_data_len)-1 # Bignum -> gro▀er Wert
  3281.             );
  3282.         if (n<len)
  3283.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3284.             pushSTACK(STACK_(0+1)); # n
  3285.             pushSTACK(*stream_); # Stream
  3286.             pushSTACK(S(read));
  3287.             fehler(stream_error,
  3288.                    DEUTSCH ? "~ von ~: Vektor lΣnger als angegebene LΣnge ~." :
  3289.                    ENGLISH ? "~ from ~: vector is longer than the explicitly given length ~" :
  3290.                    FRANCAIS ? "~ de ~ : Le vecteur est plus long que la longueur explicite ~." :
  3291.                    ""
  3292.                   );
  3293.           }
  3294.         if ((n>0) && (len==0))
  3295.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3296.             pushSTACK(STACK_(0+1)); # n
  3297.             pushSTACK(*stream_); # Stream
  3298.             pushSTACK(S(read));
  3299.             fehler(stream_error,
  3300.                    DEUTSCH ? "~ von ~: Element fⁿr Vektor der LΣnge ~ mu▀ spezifiziert werden." :
  3301.                    ENGLISH ? "~ from ~: must specify element of vector of length ~" :
  3302.                    FRANCAIS ? "~ de ~ : Il faut spΘcifier un ΘlΘment pour un vecteur de longueur ~." :
  3303.                    ""
  3304.                   );
  3305.           }
  3306.       }
  3307.     # Erzeuge neuen Vektor der LΣnge n:
  3308.     pushSTACK(elements); # Liste retten
  3309.     {var reg7 object v = allocate_vector(n);
  3310.      elements = popSTACK(); # Liste zurⁿck
  3311.      # und fⁿlle die Elemente ein:
  3312.      { var reg4 object* vptr = &TheSvector(v)->data[0];
  3313.        var reg3 object el; # letztes Element
  3314.        var reg1 uintL index = 0;
  3315.        while (index < n)
  3316.          { if (index < len) { el = Car(elements); elements = Cdr(elements); } # evtl. nΣchstes Element holen
  3317.            *vptr++ = el;
  3318.            index++;
  3319.          }
  3320.      }
  3321.      #ifdef IMMUTABLE_ARRAY
  3322.      if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  3323.        { v = make_imm_array(v); }
  3324.      #endif
  3325.      value1 = v; mv_count=1; skipSTACK(3); # v als Wert
  3326.   }}}
  3327.  
  3328. # (set-dispatch-macro-character #\# #\A
  3329. #   #'(lambda (stream sub-char n)
  3330. #       (declare (ignore sub-char))
  3331. #       (if *read-suppress*
  3332. #         (progn (read stream t nil t) nil)
  3333. #         (if (null n)
  3334. #           (let ((h (read stream t nil t)))
  3335. #             (if (and (consp h) (consp (cdr h)) (consp (cddr h)) (null (cdddr h)))
  3336. #               (make-array (second h) :element-type (first h) :initial-contents (third h))
  3337. #               (error "~: Falsche Syntax fⁿr Array: #A~" 'read h)
  3338. #           ) )
  3339. #           (let* ((rank n)
  3340. #                  (cont (let ((*backquote-level* nil)) (read stream t nil t)))
  3341. #                  (dims '())
  3342. #                  (eltype 't))
  3343. #             (when (plusp rank)
  3344. #               (let ((subcont cont) (i 0))
  3345. #                 (loop
  3346. #                   (let ((l (length subcont)))
  3347. #                     (push l dims)
  3348. #                     (incf i) (when (>= i rank) (return))
  3349. #                     (when (plusp l) (setq subcont (elt subcont 0)))
  3350. #                 ) )
  3351. #                 (cond ((stringp subcont) (setq eltype 'string-char))
  3352. #                       ((bit-vector-p subcont) (setq eltype 'bit))
  3353. #             ) ) )
  3354. #             (make-array (nreverse dims) :element-type eltype :initial-contents cont)
  3355. # )   ) ) ) )
  3356. LISPFUNN(array_reader,3) # liest #A
  3357.   { var reg2 object* stream_ = test_stream_arg(STACK_2);
  3358.     # Stackaufbau: stream, sub-char, n.
  3359.     if (test_value(S(read_suppress))) # *READ-SUPPRESS* /= NIL ?
  3360.       # ja -> nΣchstes Objekt ⁿberlesen:
  3361.       { read_recursive_no_dot(stream_);
  3362.         value1 = NIL; mv_count=1; skipSTACK(3); return;
  3363.       }
  3364.    {
  3365.     #ifdef IMMUTABLE_ARRAY
  3366.     var reg5 uintB flags = TheStream(*stream_)->strmflags;
  3367.     #endif
  3368.     if (nullp(STACK_0)) # n nicht angegeben?
  3369.       # ja -> Liste (eltype dims contents) lesen:
  3370.       { var reg1 object obj = read_recursive_no_dot(stream_); # Liste lesen
  3371.         obj = make_references(obj); # Verweise entflechten
  3372.         # (Das ist ungefΣhrlich, da wir diese #A-Syntax fⁿr Arrays mit
  3373.         # Elementtyp T nicht benutzen, und Byte-Arrays enthalten keine Verweise.)
  3374.         if (!consp(obj)) goto bad;
  3375.         { var reg3 object obj2 = Cdr(obj);
  3376.           if (!consp(obj2)) goto bad;
  3377.          {var reg4 object obj3 = Cdr(obj2);
  3378.           if (!consp(obj3)) goto bad;
  3379.           if (!nullp(Cdr(obj3))) goto bad;
  3380.           # (MAKE-ARRAY dims :element-type eltype :initial-contents contents) aufrufen:
  3381.           STACK_2 = Car(obj2); STACK_1 = S(Kelement_type); STACK_0 = Car(obj);
  3382.           pushSTACK(S(Kinitial_contents)); pushSTACK(Car(obj3));
  3383.           goto call_make_array;
  3384.         }}
  3385.         bad:
  3386.           pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3387.           pushSTACK(obj); # Objekt
  3388.           pushSTACK(*stream_); # Stream
  3389.           pushSTACK(S(read));
  3390.           fehler(stream_error,
  3391.                  DEUTSCH ? "~ von ~: Falsche Syntax fⁿr Array: #A~" :
  3392.                  ENGLISH ? "~ from ~: bad syntax for array: #A~" :
  3393.                  FRANCAIS ? "~ de ~ : Syntaxe inadmissible pour une matrice: #A~" :
  3394.                  ""
  3395.                 );
  3396.       }
  3397.     # n gibt den Rang des Arrays an.
  3398.     # Inhalt lesen:
  3399.     { dynamic_bind(S(backquote_level),NIL); # SYS::*BACKQUOTE-LEVEL* an NIL binden
  3400.      {var reg1 object contents = read_recursive_no_dot(stream_);
  3401.       dynamic_unbind();
  3402.       pushSTACK(contents); pushSTACK(contents);
  3403.     }}
  3404.     STACK_4 = NIL; # dims := '()
  3405.     # Stackaufbau: dims, -, rank, subcontents, contents.
  3406.     # Dimensionen und Elementtyp bestimmen:
  3407.     if (eq(STACK_2,Fixnum_0)) # rank=0 ?
  3408.       { STACK_2 = S(t); } # ja -> eltype := 'T
  3409.       else
  3410.       { var reg3 object i = Fixnum_0; # bisherige Verschachtelungstiefe
  3411.         loop
  3412.           { pushSTACK(STACK_1); funcall(L(length),1); # (LENGTH subcontents)
  3413.             # auf dims pushen:
  3414.             STACK_3 = value1;
  3415.             {var reg1 object new_cons = allocate_cons();
  3416.              Car(new_cons) = STACK_3; Cdr(new_cons) = STACK_4;
  3417.              STACK_4 = new_cons;
  3418.             }
  3419.             # Tiefe erh÷hen:
  3420.             i = fixnum_inc(i,1); if (eql(i,STACK_2)) break;
  3421.             # erstes Element von subcontents fⁿr die weiteren Dimensionen:
  3422.             if (!eq(STACK_3,Fixnum_0)) # (nur falls (length subcontents) >0)
  3423.               { pushSTACK(STACK_1); pushSTACK(Fixnum_0); funcall(L(elt),2);
  3424.                 STACK_1 = value1; # subcontents := (ELT subcontents 0)
  3425.               }
  3426.           }
  3427.         nreverse(STACK_4); # Liste dims umdrehen
  3428.         # eltype bestimmen je nach innerstem subcontents:
  3429.         STACK_2 = (mstringp(STACK_1) ? S(string_char) : # String: STRING-CHAR
  3430.                    m_bit_vector_p(STACK_1) ? S(bit) : # Bitvektor: BIT
  3431.                    S(t)                               # sonst (Liste): T
  3432.                   );
  3433.       }
  3434.     # Stackaufbau: dims, -, eltype, -, contents.
  3435.     # MAKE-ARRAY aufrufen:
  3436.     STACK_3 = S(Kelement_type); STACK_1 = S(Kinitial_contents);
  3437.     call_make_array:
  3438.     funcall(L(make_array),5);
  3439.     #ifdef IMMUTABLE_ARRAY
  3440.     if (flags & strmflags_immut_B)
  3441.       { # Ergebnis-Array value1 immutabel machen:
  3442.         if (!array_simplep(value1))
  3443.           { var reg1 object dv = TheArray(value1)->data; # Datenvektor: Simple-Array
  3444.             if (!array_simplep(dv)) # Simple-Byte-Vektor?
  3445.               { TheArray(dv)->data = make_imm_array(TheArray(dv)->data); }
  3446.             TheArray(value1)->data = make_imm_array(dv);
  3447.           }
  3448.         value1 = make_imm_array(value1);
  3449.       }
  3450.     #endif
  3451.     mv_count=1; return;
  3452.   }}
  3453.  
  3454. # (set-dispatch-macro-character #\# #\.
  3455. #   #'(lambda (stream sub-char n)
  3456. #       (declare (ignore sub-char))
  3457. #       (let ((h (read stream t nil t)))
  3458. #         (unless *read-suppress*
  3459. #           (if n
  3460. #             (error "~ von ~: Zwischen # und . ist keine Zahl erlaubt."
  3461. #                     'read stream
  3462. #             )
  3463. #             (eval h)
  3464. # )   ) ) ) )
  3465. LISPFUNN(read_eval_reader,3) # liest #.
  3466.   { var reg2 object* stream_ = test_stream_arg(STACK_2);
  3467.     var reg1 object obj = read_recursive_no_dot(stream_); # Form lesen
  3468.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3469.     if (test_value(S(read_suppress)))
  3470.       { value1 = NIL; mv_count=1; skipSTACK(3); return; }
  3471.     if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  3472.     obj = make_references(obj); # Verweise entflechten
  3473.     eval_noenv(obj); # Form auswerten
  3474.     mv_count=1; skipSTACK(2); # nur 1 Wert zurⁿck
  3475.   }
  3476.  
  3477. # (set-dispatch-macro-character #\# #\,
  3478. #   #'(lambda (stream sub-char n)
  3479. #       (declare (ignore sub-char))
  3480. #       (let ((h (read stream t nil t)))
  3481. #         (unless *read-suppress*
  3482. #           (if n
  3483. #             (error "~ von ~: Zwischen # und , ist keine Zahl erlaubt."
  3484. #                     'read stream
  3485. #             )
  3486. #             (if sys::*compiling* (make-load-time-eval h) (eval h))
  3487. # )   ) ) ) )
  3488. LISPFUNN(load_eval_reader,3) # liest #,
  3489.   { var reg2 object* stream_ = test_stream_arg(STACK_2);
  3490.     var reg1 object obj = read_recursive_no_dot(stream_); # Form lesen
  3491.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3492.     if (test_value(S(read_suppress)))
  3493.       { value1 = NIL; mv_count=1; skipSTACK(3); return; }
  3494.     if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  3495.     obj = make_references(obj); # Verweise entflechten
  3496.     if (test_value(S(compiling)))
  3497.       # Im Compiler:
  3498.       { pushSTACK(obj);
  3499.        {var reg3 object new = allocate_loadtimeeval(); # Load-time-Eval-Objekt
  3500.         TheLoadtimeeval(new)->loadtimeeval_form = popSTACK(); # mit obj als Form
  3501.         value1 = new;
  3502.       }}
  3503.       else
  3504.       # Im Interpreter:
  3505.       { eval_noenv(obj); } # Form auswerten
  3506.     mv_count=1; skipSTACK(2); # nur 1 Wert zurⁿck
  3507.   }
  3508.  
  3509. # (set-dispatch-macro-character #\# #\=
  3510. #   #'(lambda (stream sub-char n)
  3511. #       (if *read-suppress*
  3512. #         (if n
  3513. #           (if (sys::fixnump n)
  3514. #             (let* ((label (make-internal-label n))
  3515. #                    (h (assoc label sys::*read-reference-table* :test #'eq)))
  3516. #               (if (consp h)
  3517. #                 (error "~ von ~: Label #~= darf nicht zweimal definiert werden." 'read stream n)
  3518. #                 (progn
  3519. #                   (push (setq h (cons label label)) sys::*read-reference-table*)
  3520. #                   (let ((obj (read stream t nil t)))
  3521. #                     (if (eq obj label)
  3522. #                       (error "~ von ~: #~= #~# ist nicht erlaubt." 'read stream n n)
  3523. #                       (setf (cdr h) obj)
  3524. #             ) ) ) ) )
  3525. #             (error "~ von ~: Label #~= zu gro▀" 'read stream n)
  3526. #           )
  3527. #           (error "~ von ~: Zwischen # und = mu▀ eine Zahl angegeben werden." 'read stream)
  3528. #         )
  3529. #         (values) ; keine Werte (Kommentar)
  3530. # )   ) )
  3531.  
  3532. # (set-dispatch-macro-character #\# #\#
  3533. #   #'(lambda (stream sub-char n)
  3534. #       (unless *read-suppress*
  3535. #         (if n
  3536. #           (if (sys::fixnump n)
  3537. #             (let* ((label (make-internal-label n))
  3538. #                    (h (assoc label sys::*read-reference-table* :test #'eq)))
  3539. #               (if (consp h)
  3540. #                 label ; wird spΣter entflochten
  3541. #                 ; (man k÷nnte auch (cdr h) zurⁿckliefern)
  3542. #                 (error "~ von ~: Label #~= ist nicht definiert." 'read stream n)
  3543. #               )
  3544. #             (error "~ von ~: Label #~# zu gro▀" 'read stream n)
  3545. #           )
  3546. #           (error "~ von ~: Zwischen # und # mu▀ eine Zahl angegeben werden." 'read stream)
  3547. # )   ) ) )
  3548.  
  3549. # UP: Bildet ein internes Label und sucht es in der *READ-REFERENCE-TABLE* auf.
  3550. # lookup_label()
  3551. # > Stackaufbau: Stream, sub-char, n.
  3552. # < ergebnis: (or (assoc label sys::*read-reference-table* :test #'eq) label)
  3553.   local object lookup_label (void);
  3554.   local object lookup_label()
  3555.     { var reg4 object n = STACK_0;
  3556.       if (nullp(n)) # nicht angegeben?
  3557.         { pushSTACK(STACK_2); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3558.           pushSTACK(STACK_(1+1)); # sub-char
  3559.           pushSTACK(STACK_(2+2)); # Stream
  3560.           pushSTACK(S(read));
  3561.           fehler(stream_error,
  3562.                  DEUTSCH ? "~ von ~: Zwischen #"" und $ mu▀ eine Zahl angegeben werden." :
  3563.                  ENGLISH ? "~ from ~: a number must be given between #"" and $" :
  3564.                  FRANCAIS ? "~ de ~ : Un nombre doit Ωtre spΘcifiΘ entre #"" et $" :
  3565.                  ""
  3566.                 );
  3567.         }
  3568.       # n ist ein Integer >=0
  3569.       if (!(posfixnump(n) && (posfixnum_to_L(n) < bit(oint_data_len-2))))
  3570.         # n ist zu gro▀
  3571.         { pushSTACK(STACK_2); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3572.           pushSTACK(STACK_(1+1)); # sub-char
  3573.           pushSTACK(STACK_(0+2)); # n
  3574.           pushSTACK(STACK_(2+3)); # Stream
  3575.           pushSTACK(S(read));
  3576.           fehler(stream_error,
  3577.                  DEUTSCH ? "~ von ~: Label #~? zu gro▀" :
  3578.                  ENGLISH ? "~ from ~: label #~? too large" :
  3579.                  FRANCAIS ? "~ de ~ : La marque #~? est trop grande." :
  3580.                  ""
  3581.                 );
  3582.         }
  3583.      {var reg3 object label = # Internal-Label mit Nummer n
  3584.         type_data_object(system_type, bit(0) + (posfixnum_to_L(n)<<1) );
  3585.       var reg2 object alist = # Wert von SYS::*READ-REFERENCE-TABLE*
  3586.         Symbol_value(S(read_reference_table));
  3587.       # (assoc label alist :test #'eq) ausfⁿhren:
  3588.       while (consp(alist))
  3589.         { var reg1 object acons = Car(alist); # Listenelement
  3590.           if (!consp(acons)) goto bad_reftab; # mu▀ ein Cons sein !
  3591.           if (eq(Car(acons),label)) # dessen CAR = label ?
  3592.             { return acons; } # ja -> fertig
  3593.           alist = Cdr(alist);
  3594.         }
  3595.       if (nullp(alist)) # Listenende mit NIL ?
  3596.         { return label; } # ja -> (assoc ...) = NIL -> fertig mit label
  3597.       bad_reftab: # Wert von SYS::*READ-REFERENCE-TABLE* ist keine Aliste
  3598.         pushSTACK(Symbol_value(S(read_reference_table))); # Wert von SYS::*READ-REFERENCE-TABLE*
  3599.         pushSTACK(S(read_reference_table)); # SYS::*READ-REFERENCE-TABLE*
  3600.         pushSTACK(STACK_(2+2)); # Stream
  3601.         pushSTACK(S(read));
  3602.         fehler(error,
  3603.                DEUTSCH ? "~ von ~: Der Wert von ~ wurde von au▀en verΣndert, er ist keine A-Liste: ~" :
  3604.                ENGLISH ? "~ from ~: the value of ~ has been altered arbitrarily, it is not an alist: ~" :
  3605.                FRANCAIS ? "~ de ~ : La valeur de ~ a ΘtΘ modifiΘe extΘrieurement, elle n'est plus une aliste: ~" :
  3606.                ""
  3607.               );
  3608.     }}
  3609.  
  3610. LISPFUNN(label_definition_reader,3) # liest #=
  3611.   { # bei *READ-SUPPRESS* /= NIL wird #n= als Kommentar behandelt:
  3612.     if (test_value(S(read_suppress)))
  3613.       { value1 = NIL; mv_count=0; skipSTACK(3); return; } # keine Werte
  3614.     # Label bilden und in der Tabelle aufsuchen:
  3615.    {var reg4 object lookup = lookup_label();
  3616.     if (consp(lookup))
  3617.       # gefunden -> war schon da -> Fehler:
  3618.       { pushSTACK(STACK_2); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3619.         pushSTACK(STACK_(0+1)); # n
  3620.         pushSTACK(STACK_(2+2)); # Stream
  3621.         pushSTACK(S(read));
  3622.         fehler(stream_error,
  3623.                DEUTSCH ? "~ von ~: Label #~= darf nicht zweimal definiert werden." :
  3624.                ENGLISH ? "~ from ~: label #~= may not be defined twice" :
  3625.                FRANCAIS ? "~ de ~ : La marque #~= ne peut pas Ωtre dΘfinie deux fois." :
  3626.                ""
  3627.               );
  3628.       }
  3629.       else
  3630.       # lookup = label, nicht GC-gefΣhrdet.
  3631.       # (push (setq h (cons label label)) sys::*read-reference-table*) :
  3632.       {var reg3 object* stream_ = test_stream_arg(STACK_2);
  3633.        {var reg1 object new_cons = allocate_cons();
  3634.         Car(new_cons) = Cdr(new_cons) = lookup; # h = (cons label label)
  3635.         pushSTACK(new_cons); # h retten
  3636.        }
  3637.        {var reg1 object new_cons = allocate_cons(); # neues Listen-Cons
  3638.         Car(new_cons) = STACK_0;
  3639.         Cdr(new_cons) = Symbol_value(S(read_reference_table));
  3640.         Symbol_value(S(read_reference_table)) = new_cons;
  3641.        }
  3642.        {var reg2 object obj = read_recursive_no_dot(stream_); # Objekt lesen
  3643.         var reg1 object h = popSTACK();
  3644.         if (eq(obj,Car(h))) # gelesenes Objekt = (car h) = label ?
  3645.           # ja -> zyklische Definition -> Error
  3646.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3647.             pushSTACK(STACK_(0+1)); # n
  3648.             pushSTACK(STACK_(0+2)); # n
  3649.             pushSTACK(*stream_); # Stream
  3650.             pushSTACK(S(read));
  3651.             fehler(stream_error,
  3652.                    DEUTSCH ? "~ von ~: #~= #~#"" ist nicht erlaubt." :
  3653.                    ENGLISH ? "~ from ~: #~= #~#"" is illegal" :
  3654.                    FRANCAIS ? "~ de ~ : #~= #~#"" n'est pas permis." :
  3655.                    ""
  3656.                   );
  3657.           }
  3658.         # gelesenes Objekt als (cdr h) eintragen:
  3659.         Cdr(h) = obj;
  3660.         value1 = obj; mv_count=1; skipSTACK(3); # obj als Wert
  3661.       }}
  3662.   }}
  3663.  
  3664. LISPFUNN(label_reference_reader,3) # liest ##
  3665.   { # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3666.     if (test_value(S(read_suppress)))
  3667.       { value1 = NIL; mv_count=1; skipSTACK(3); return; }
  3668.     # Label bilden und in der Tabelle aufsuchen:
  3669.    {var reg1 object lookup = lookup_label();
  3670.     if (consp(lookup))
  3671.       # gefunden -> Label als gelesenes Objekt zurⁿck:
  3672.       { value1 = Car(lookup); mv_count=1; skipSTACK(3); }
  3673.       else
  3674.       # nicht gefunden
  3675.       { pushSTACK(STACK_2); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3676.         pushSTACK(STACK_(0+1)); # n
  3677.         pushSTACK(STACK_(2+2)); # Stream
  3678.         pushSTACK(S(read));
  3679.         fehler(stream_error,
  3680.                DEUTSCH ? "~ von ~: Label #~#"" ist nicht definiert." :
  3681.                ENGLISH ? "~ from ~: undefined label #~#" :
  3682.                FRANCAIS ? "~ de ~ : La marque #~#"" n'est pas dΘfinie." :
  3683.                ""
  3684.               );
  3685.       }
  3686.   }}
  3687.  
  3688. # (set-dispatch-macro-character #\# #\<
  3689. #   #'(lambda (stream sub-char n)
  3690. #       (error "~ von ~: Als #<...> ausgegebene Objekte sind nicht mehr einlesbar."
  3691. #               'read stream
  3692. # )   ) )
  3693. LISPFUNN(not_readable_reader,3) # liest #<
  3694.   { var reg1 object* stream_ = test_stream_arg(STACK_2);
  3695.     pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3696.     pushSTACK(*stream_); # Stream
  3697.     pushSTACK(S(read));
  3698.     fehler(stream_error,
  3699.            DEUTSCH ? "~ von ~: Als #<...> ausgegebene Objekte sind nicht mehr einlesbar." :
  3700.            ENGLISH ? "~ from ~: objects printed as #<...> cannot be read back in" :
  3701.            FRANCAIS ? "~ de ~ : Des objets qui ont ΘtΘ imprimΘs en forme #<...> ne peuvent servir d'entrΘe." :
  3702.            ""
  3703.           );
  3704.   }
  3705.  
  3706. # (dolist (ch '(#\) #\Space #\Newline #\Linefeed #\Backspace #\Rubout #\Tab #\Return #\Page))
  3707. #   (set-dispatch-macro-character #\# ch
  3708. #     #'(lambda (stream sub-char n)
  3709. #         (error "~ von ~: Wegen ~ als # ausgegebene Objekte sind nicht mehr einlesbar."
  3710. #                 'read stream '*print-level*
  3711. # ) )   ) )
  3712. LISPFUNN(syntax_error_reader,3) # liest #) und #whitespace
  3713.   { var reg1 object* stream_ = test_stream_arg(STACK_2);
  3714.     pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3715.     pushSTACK(S(print_level));
  3716.     pushSTACK(*stream_); # Stream
  3717.     pushSTACK(S(read));
  3718.     fehler(stream_error,
  3719.            DEUTSCH ? "~ von ~: Wegen ~ als #"" ausgegebene Objekte sind nicht mehr einlesbar." :
  3720.            ENGLISH ? "~ from ~: objects printed as #"" in view of ~ cannot be read back in" :
  3721.            FRANCAIS ? "~ de ~ : Des objets qui ont ΘtΘ imprimΘs en #"" α cause de ~ ne peuvent servir d'entrΘe." :
  3722.            ""
  3723.           );
  3724.   }
  3725.  
  3726. # Hilfsfunktion fⁿr #+ und #- :
  3727. # (defun interpret-feature (feature)
  3728. #   (flet ((eqs (x y) (and (symbolp x) (symbolp y)
  3729. #                          (string= (symbol-name x) (symbol-name y))
  3730. #         ))          )
  3731. #     (cond ((symbolp feature) (member feature *features* :test #'eqs))
  3732. #           ((atom feature)
  3733. #            (error "~: Als Feature ist ~ nicht erlaubt." 'read feature)
  3734. #           )
  3735. #           ((eqs (car feature) 'and)
  3736. #            (every #'interpret-feature (cdr feature))
  3737. #           )
  3738. #           ((eqs (car feature) 'or)
  3739. #            (some #'interpret-feature (cdr feature))
  3740. #           )
  3741. #           ((eqs (car feature) 'not)
  3742. #            (not (interpret-feature (second feature)))
  3743. #           )
  3744. #           (t (error "~: Als Feature ist ~ nicht erlaubt." 'read feature))
  3745. # ) ) )
  3746.  
  3747. # UP: Stellt das Erfⁿlltsein eines Feature-Ausdruckes fest.
  3748. # interpret_feature(expr)
  3749. # > expr: ein Feature-Ausdruck
  3750. # > STACK_1: Stream
  3751. # < ergebnis: Wahrheitswert: 0 falls erfⁿllt, ~0 falls nicht erfⁿllt.
  3752.   local uintWL interpret_feature (object expr);
  3753.   local uintWL interpret_feature(expr)
  3754.     var reg3 object expr;
  3755.     { check_SP();
  3756.       if (symbolp(expr))
  3757.         # expr Symbol, in *FEATURES* suchen:
  3758.         { var reg2 object pname = Symbol_name(expr); # dem Namen nach suchen
  3759.           var reg1 object list = Symbol_value(S(features)); # Wert von *FEATURES*
  3760.           while (consp(list))
  3761.             { if (msymbolp(Car(list))
  3762.                   && string_gleich(Symbol_name(Car(list)),pname)
  3763.                  )
  3764.                 goto ja;
  3765.               list = Cdr(list);
  3766.             }
  3767.           goto nein;
  3768.         }
  3769.       elif (consp(expr) && msymbolp(Car(expr)))
  3770.         { var reg5 object opname = Symbol_name(Car(expr));
  3771.           var reg4 uintWL and_or_flag;
  3772.           if (string_gleich(opname,Symbol_name(S(and))))
  3773.             # expr = (AND ...)
  3774.             { and_or_flag = 0; goto and_or; }
  3775.           elif (string_gleich(opname,Symbol_name(S(or))))
  3776.             # expr = (OR ...)
  3777.             { and_or_flag = ~0;
  3778.               and_or:
  3779.               # Listenelemente von expr so lange abinterpretieren, bis ein
  3780.               # Ergebnis /=and_or_flag kommt. Default ist and_or_flag.
  3781.               { var reg1 object list = Cdr(expr);
  3782.                 while (consp(list))
  3783.                   { # Listenelement abinterpretieren:
  3784.                     var reg3 uintWL sub_erg = interpret_feature(Car(list));
  3785.                     if (!(sub_erg == and_or_flag)) { return sub_erg; }
  3786.                     list = Cdr(list);
  3787.                   }
  3788.                 if (nullp(list)) { return and_or_flag; }
  3789.                 # expr war eine Dotted List -> Fehler
  3790.             } }
  3791.           elif (string_gleich(opname,Symbol_name(S(not))))
  3792.             { # expr = (NOT ...) soll die Gestalt (NOT obj) haben:
  3793.               var reg1 object opargs = Cdr(expr);
  3794.               if (consp(opargs) && nullp(Cdr(opargs)))
  3795.                 { return ~interpret_feature(Car(opargs)); }
  3796.               # expr hat keine korrekte Gestalt -> Fehler
  3797.             }
  3798.           # falscher (car expr) -> Fehler
  3799.         }
  3800.       bad: # Falscher Aufbau eines Feature-Ausdrucks
  3801.         pushSTACK(STACK_1); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3802.         pushSTACK(expr); # Feature-Ausdruck
  3803.         pushSTACK(STACK_(1+2)); # Stream
  3804.         pushSTACK(S(read));
  3805.         fehler(stream_error,
  3806.                DEUTSCH ? "~ von ~: Als Feature ist ~ nicht erlaubt." :
  3807.                ENGLISH ? "~ from ~: illegal feature ~" :
  3808.                FRANCAIS ? "~ de ~ : Feature ~ n'est pas permis." :
  3809.                ""
  3810.               );
  3811.       ja: return 0; # expr ist erfⁿllt
  3812.       nein: return ~0; # expr ist nicht erfⁿllt
  3813.     }
  3814.  
  3815. # UP fⁿr #+ und #-
  3816. # feature(sollwert)
  3817. # > sollwert: gewⁿnschter Wahrheitswert des Feature-Ausdrucks
  3818. # > Stackaufbau: Stream, sub-char, n.
  3819. # < STACK: um 3 erh÷ht
  3820. # < mv_space/mv_count: Werte
  3821. # kann GC ausl÷sen
  3822.   local Values feature (uintWL sollwert);
  3823.   local Values feature(sollwert)
  3824.     var reg3 uintWL sollwert;
  3825.     { var reg2 object* stream_ = test_no_infix(); # n mu▀ NIL sein
  3826.       var reg1 object expr = read_recursive_no_dot(stream_); # Feature-Ausdruck lesen
  3827.       # Bei *READ-SUPPRESS* /= NIL: nicht interpretieren
  3828.       if (test_value(S(read_suppress)))
  3829.         { read_recursive_no_dot(stream_); # nΣchstes Objekt lesen
  3830.           # und alles als Kommentar behandeln: keine Werte
  3831.           value1 = NIL; mv_count=0; skipSTACK(2); return;
  3832.         }
  3833.       # Feature-Ausdruck interpretieren:
  3834.       expr = make_references(expr); # zuvor Verweise entflechten
  3835.       if (interpret_feature(expr) == sollwert)
  3836.         # Wahrheitswert "wahr"
  3837.         { # nΣchstes Objekt lesen und als Wert:
  3838.           value1 = read_recursive_no_dot(stream_); mv_count=1;
  3839.         }
  3840.         else
  3841.         # Wahrheitswert "falsch"
  3842.         { # *READ-SUPPRESS* an T binden, Objekt lesen, Kommentar
  3843.           dynamic_bind(S(read_suppress),T);
  3844.           read_recursive_no_dot(stream_);
  3845.           dynamic_unbind();
  3846.           value1 = NIL; mv_count=0; # keine Werte
  3847.         }
  3848.       skipSTACK(2);
  3849.     }
  3850.  
  3851. # (set-dispatch-macro-character #\# #\+
  3852. #   #'(lambda (stream sub-char n)
  3853. #       (declare (ignore sub-char))
  3854. #       (if n
  3855. #         (error "~ von ~: Zwischen # und + darf keine Zahl kommen" 'read stream)
  3856. #         (let ((feature (read stream t nil t)))
  3857. #           (if (and (not *read-suppress*) (interpret-feature feature))
  3858. #             (read stream t nil t)
  3859. #             (let ((*read-suppress* t))
  3860. #               (read stream t nil t)
  3861. #               (values)
  3862. # )   ) ) ) ) )
  3863. LISPFUNN(feature_reader,3) # liest #+
  3864.   { return_Values feature(0); }
  3865.  
  3866. # (set-dispatch-macro-character #\# #\-
  3867. #   #'(lambda (stream sub-char n)
  3868. #       (declare (ignore sub-char))
  3869. #       (if n
  3870. #         (error "~ von ~: Zwischen # und - darf keine Zahl kommen" 'read stream)
  3871. #         (let ((feature (read stream t nil t)))
  3872. #           (if (or *read-suppress* (interpret-feature feature))
  3873. #             (let ((*read-suppress* t))
  3874. #               (read stream t nil t)
  3875. #               (values)
  3876. #             )
  3877. #             (read stream t nil t)
  3878. # )   ) ) ) )
  3879. LISPFUNN(not_feature_reader,3) # liest #-
  3880.   { return_Values feature(~0); }
  3881.  
  3882. # (set-dispatch-macro-character #\# #\S
  3883. #   #'(lambda (stream char n)
  3884. #       (declare (ignore char))
  3885. #       (if *read-suppress*
  3886. #         (progn (read stream t nil t) nil)
  3887. #         (if n
  3888. #           (error "~: Zwischen # und S ist keine Zahl erlaubt." 'read)
  3889. #           (let ((args (let ((*backquote-level* nil)) (read stream t nil t))))
  3890. #             (if (consp args)
  3891. #               (let ((name (first args)))
  3892. #                 (if (symbolp name)
  3893. #                   (let ((desc (get name 'DEFSTRUCT-DESCRIPTION)))
  3894. #                     (if desc
  3895. #                       (if (svref desc 2)
  3896. #                         (values
  3897. #                           (apply (svref desc 2) ; der Konstruktor
  3898. #                                  (structure-arglist-expand name (cdr args))
  3899. #                         ) )
  3900. #                         (error "~: Structures des Typs ~ k÷nnen nicht eingelesen werden (Konstruktorfunktion unbekannt)"
  3901. #                                'read name
  3902. #                       ) )
  3903. #                       (error "~: Es ist noch keine Structure des Typs ~ definiert worden"
  3904. #                              'read name
  3905. #                   ) ) )
  3906. #                   (error "~: Der Typ einer Structure mu▀ ein Symbol sein, nicht ~"
  3907. #                          'read name
  3908. #               ) ) )
  3909. #               (error "~: Nach #S mu▀, in Klammern, der Typ und der Inhalt der Structure kommen, nicht ~"
  3910. #                      'read args
  3911. # )   ) ) ) ) ) )
  3912. # (defun structure-arglist-expand (name args)
  3913. #   (cond ((null args) nil)
  3914. #         ((atom args) (error "~: Eine Structure ~ darf keine Komponente . enthalten" 'read name))
  3915. #         ((not (symbolp (car args)))
  3916. #          (error "~: ~ ist kein Symbol und daher kein Slot der Structure ~" 'read (car args) name)
  3917. #         )
  3918. #         ((null (cdr args)) (error "~: Wert der Komponente ~ in der Structure ~ fehlt" 'read (car args) name))
  3919. #         ((atom (cdr args)) (error "~: Eine Structure ~ darf keine Komponente . enthalten" 'read name))
  3920. #         (t (let ((kw (intern (symbol-name (car args)) (find-package "KEYWORD"))))
  3921. #              (list* kw (cadr args) (structure-arglist-expand name (cddr args)))
  3922. # ) )     )  )
  3923. LISPFUNN(structure_reader,3) # liest #S
  3924.   { var reg2 object* stream_ = test_no_infix(); # n mu▀ NIL sein
  3925.     # bei *READ-SUPPRESS* /= NIL nur ein Objekt lesen:
  3926.     if (test_value(S(read_suppress)))
  3927.       { read_recursive_no_dot(stream_); # Objekt lesen und wegwerfen,
  3928.         value1 = NIL; mv_count=1; skipSTACK(2); return; # NIL als Wert
  3929.       }
  3930.     # SYS::*BACKQUOTE-LEVEL* an NIL binden und Objekt lesen:
  3931.     dynamic_bind(S(backquote_level),NIL);
  3932.    {var reg1 object args = read_recursive_no_dot(stream_);
  3933.     dynamic_unbind();
  3934.     # gelesene Liste ⁿberprⁿfen:
  3935.     if (atomp(args))
  3936.       { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3937.         pushSTACK(args); # Argumente
  3938.         pushSTACK(*stream_); # Stream
  3939.         pushSTACK(S(read));
  3940.         fehler(stream_error,
  3941.                DEUTSCH ? "~ von ~: Nach #S mu▀, in Klammern, der Typ und der Inhalt der Structure kommen, nicht ~" :
  3942.                ENGLISH ? "~ from ~: #S must be followed by the type and the contents of the structure, not ~" :
  3943.                FRANCAIS ? "~ de ~ : AprΦs #S on s'attend au type et au contenu de la structure, entre parenthΦses, et pas α ~" :
  3944.                ""
  3945.               );
  3946.       }
  3947.     {var reg5 object name = Car(args); # Typ der Structure
  3948.      STACK_0 = args = Cdr(args); # Restliste retten
  3949.      # Stackaufbau: Stream, restl.Args.
  3950.      if (!symbolp(name)) # Typ mu▀ ein Symbol sein !
  3951.        { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3952.          pushSTACK(name);
  3953.          pushSTACK(*stream_); # Stream
  3954.          pushSTACK(S(read));
  3955.          fehler(stream_error,
  3956.                 DEUTSCH ? "~ von ~: Der Typ einer Structure mu▀ ein Symbol sein, nicht ~" :
  3957.                 ENGLISH ? "~ from ~: the type of a structure should be a symbol, not ~" :
  3958.                 FRANCAIS ? "~ de ~ : Le type d'une structure doit Ωtre un symbole et non ~" :
  3959.                 ""
  3960.                );
  3961.        }
  3962.      pushSTACK(name);
  3963.      # Stackaufbau: Stream, restl.Args, name.
  3964.      if (eq(name,S(hash_table))) # Symbol HASH-TABLE ?
  3965.        # ja -> speziell behandeln, keine Structure:
  3966.        { # Hash-Tabelle
  3967.          # Restliche Argumentliste mu▀ ein Cons sein:
  3968.          if (!consp(args))
  3969.            { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  3970.              pushSTACK(name);
  3971.              pushSTACK(*stream_); # Stream
  3972.              pushSTACK(S(read));
  3973.              fehler(stream_error,
  3974.                     DEUTSCH ? "~ von ~: Fehlerhafte ~." :
  3975.                     ENGLISH ? "~ from ~: bad ~" :
  3976.                     FRANCAIS ? "~ de ~ : ~ inadmissible." :
  3977.                     ""
  3978.                    );
  3979.            }
  3980.          # (MAKE-HASH-TABLE :TEST (car args) :INITIAL-CONTENTS (cdr args))
  3981.          pushSTACK(S(Ktest)); # :TEST
  3982.          pushSTACK(Car(args)); # Test (Symbol)
  3983.          pushSTACK(S(Kinitial_contents)); # :INITIAL-CONTENTS
  3984.          pushSTACK(Cdr(args)); # Aliste ((Key_1 . Value_1) ... (Key_n . Value_n))
  3985.          funcall(L(make_hash_table),4); # Hash-Tabelle bauen
  3986.          mv_count=1; # value1 als Wert
  3987.          skipSTACK(3); return;
  3988.        }
  3989.      if (eq(name,S(random_state))) # Symbol RANDOM-STATE ?
  3990.        # ja -> speziell behandeln, keine Structure:
  3991.        { # Random-State
  3992.          # Restliche Argumentliste mu▀ ein Cons mit NIL als CDR und
  3993.          # einem Simple-Bit-Vektor der LΣnge 64 als CAR sein:
  3994.          if (!(consp(args)
  3995.                && nullp(Cdr(args))
  3996.                && m_simple_bit_vector_p(Car(args))
  3997.                && (TheSbvector(Car(args))->length == 64)
  3998.             ) )
  3999.            { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4000.              pushSTACK(name);
  4001.              pushSTACK(*stream_); # Stream
  4002.              pushSTACK(S(read));
  4003.              fehler(stream_error,
  4004.                     DEUTSCH ? "~ von ~: Fehlerhafter ~." :
  4005.                     ENGLISH ? "~ from ~: bad ~" :
  4006.                     FRANCAIS ? "~ de ~ : ~ inadmissible." :
  4007.                     ""
  4008.                    );
  4009.            }
  4010.          STACK_0 = Car(args); # Simple-Bit-Vektor retten
  4011.         {var reg3 object ergebnis = allocate_random_state(); # neuer Random-State
  4012.          The_Random_state(ergebnis)->random_state_seed = popSTACK(); # fⁿllen
  4013.          value1 = ergebnis; mv_count=1; skipSTACK(2); return;
  4014.        }}
  4015.      if (eq(name,S(pathname))) # Symbol PATHNAME ?
  4016.        # ja -> speziell behandeln, keine Structure:
  4017.        { STACK_1 = make_references(args); pushSTACK(L(make_pathname)); }
  4018.      #ifdef LOGICAL_PATHNAMES
  4019.      elif (eq(name,S(logical_pathname))) # Symbol LOGICAL-PATHNAME ?
  4020.        # ja -> speziell behandeln, keine Structure:
  4021.        { STACK_1 = make_references(args); pushSTACK(L(make_logical_pathname)); }
  4022.      #endif
  4023.      elif (eq(name,S(byte))) # Symbol BYTE ?
  4024.        # ja -> speziell behandeln, keine Structure:
  4025.        { pushSTACK(S(make_byte)); }
  4026.      else
  4027.        # (GET name 'SYS::DEFSTRUCT-DESCRIPTION) ausfⁿhren:
  4028.        {var reg4 object description = get(name,S(defstruct_description));
  4029.         if (eq(description,unbound)) # nichts gefunden?
  4030.           # Structure dieses Typs undefiniert
  4031.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4032.             pushSTACK(name);
  4033.             pushSTACK(*stream_); # Stream
  4034.             pushSTACK(S(read));
  4035.             fehler(stream_error,
  4036.                    DEUTSCH ? "~ von ~: Es ist noch keine Structure des Typs ~ definiert worden." :
  4037.                    ENGLISH ? "~ from ~: no structure of type ~ has been defined" :
  4038.                    FRANCAIS ? "~ de ~ : Aucune structure de type ~ n'est dΘfinie." :
  4039.                    ""
  4040.                   );
  4041.           }
  4042.         # description mu▀ ein Simple-Vector der LΣnge >=4 sein:
  4043.         if (!(simple_vector_p(description) && (TheSvector(description)->length >= 4)))
  4044.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4045.             pushSTACK(name);
  4046.             pushSTACK(S(defstruct_description));
  4047.             pushSTACK(*stream_); # Stream
  4048.             pushSTACK(S(read));
  4049.             fehler(stream_error,
  4050.                    DEUTSCH ? "~ von ~: Schlecht aufgebaute ~ zu ~" :
  4051.                    ENGLISH ? "~ from ~: bad ~ for ~" :
  4052.                    FRANCAIS ? "~ de ~ : Mauvaise ~ appartenante α ~" :
  4053.                    ""
  4054.                   );
  4055.           }
  4056.         # Konstruktorfunktion holen:
  4057.         {var reg6 object constructor = # (svref description 2)
  4058.            TheSvector(description)->data[2];
  4059.          if (nullp(constructor))
  4060.            { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4061.              pushSTACK(name);
  4062.              pushSTACK(*stream_); # Stream
  4063.              pushSTACK(S(read));
  4064.              fehler(stream_error,
  4065.                     DEUTSCH ? "~ von ~: Structures des Typs ~ k÷nnen nicht eingelesen werden (Konstruktorfunktion unbekannt)" :
  4066.                     ENGLISH ? "~ from ~: structures of type ~ cannot be read in, missing constructor function" :
  4067.                     FRANCAIS ? "~ de ~ : Des structures de type ~ ne peuvent Ωtre entrΘes car la fonction constructeur est inconnue." :
  4068.                     ""
  4069.                    );
  4070.            }
  4071.     # Konstruktorfunktion mit angepa▀ter Argumentliste aufrufen:
  4072.          pushSTACK(constructor);
  4073.     }  }}# Stackaufbau: Stream, restl.Args, name, Konstruktor.
  4074.     {var reg5 uintC argcount = 0; # Zahl der Argumente fⁿr den Konstruktor
  4075.      loop # restliche Argumentliste durchlaufen,
  4076.           # Argumente fⁿr den Konstruktor auf den STACK legen:
  4077.        { check_STACK();
  4078.          args = *(stream_ STACKop -1); # restliche Args
  4079.          if (nullp(args)) break; # keine mehr -> Argumente im STACK fertig
  4080.          if (atomp(args))
  4081.            { dotted:
  4082.              pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4083.              pushSTACK(*(stream_ STACKop -2)); # name
  4084.              pushSTACK(*stream_); # Stream
  4085.              pushSTACK(S(read));
  4086.              fehler(stream_error,
  4087.                     DEUTSCH ? "~ von ~: Eine Structure ~ darf keine Komponente \".\" enthalten." :
  4088.                     ENGLISH ? "~ from ~: a structure ~ may not contain a component \".\"" :
  4089.                     FRANCAIS ? "~ de ~ : Une structure ~ ne doit pas contenir un composant \".\"" :
  4090.                     ""
  4091.                    );
  4092.            }
  4093.          {var reg4 object slot = Car(args);
  4094.           if (!symbolp(slot))
  4095.             { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4096.               pushSTACK(*(stream_ STACKop -2)); # name
  4097.               pushSTACK(slot);
  4098.               pushSTACK(*stream_); # Stream
  4099.               pushSTACK(S(read));
  4100.               fehler(stream_error,
  4101.                      DEUTSCH ? "~ von ~: ~ ist kein Symbol und daher kein Slot der Structure ~." :
  4102.                      ENGLISH ? "~ from ~: ~ is not a symbol, not a slot name of structure ~" :
  4103.                      FRANCAIS ? "~ de ~ : ~ n'est pas un symbole, donc pas le nom d'un composant de la structure ~." :
  4104.                      ""
  4105.                     );
  4106.             }
  4107.           if (nullp(Cdr(args)))
  4108.             { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4109.               pushSTACK(*(stream_ STACKop -2)); # name
  4110.               pushSTACK(slot);
  4111.               pushSTACK(*stream_); # Stream
  4112.               pushSTACK(S(read));
  4113.               fehler(stream_error,
  4114.                      DEUTSCH ? "~ von ~: Wert der Komponente ~ in der Structure ~ fehlt." :
  4115.                      ENGLISH ? "~ from ~: missing value of slot ~ in structure ~" :
  4116.                      FRANCAIS ? "~ de ~ : La valeur du composant ~ dans la structure ~ manque." :
  4117.                      ""
  4118.                     );
  4119.             }
  4120.           if (matomp(Cdr(args))) goto dotted;
  4121.           {var reg3 object kw = intern_keyword(Symbol_name(slot)); # Slotname als Keyword
  4122.            pushSTACK(kw); # Keyword in den STACK
  4123.           }
  4124.           args = *(stream_ STACKop -1); # wieder dieselben restlichen Args
  4125.           args = Cdr(args);
  4126.           pushSTACK(Car(args)); # Slot-value in den STACK
  4127.           *(stream_ STACKop -1) = Cdr(args); # Argliste verkⁿrzen
  4128.          }
  4129.          argcount += 2; # und mitzΣhlen
  4130.          if (argcount == 0)
  4131.            # ArgumentezΣhler zu gro▀ geworden
  4132.            { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4133.              pushSTACK(*(stream_ STACKop -2)); # name
  4134.              pushSTACK(*stream_); # Stream
  4135.              pushSTACK(S(read));
  4136.              fehler(stream_error,
  4137.                     DEUTSCH ? "~ von ~: Zu viele Komponenten fⁿr Structure ~." :
  4138.                     ENGLISH ? "~ from ~: too many slots for structure ~" :
  4139.                     FRANCAIS ? "~ de ~ : Trop de composants pour une structure ~." :
  4140.                     ""
  4141.                    );
  4142.            }
  4143.        }
  4144.      funcall(*(stream_ STACKop -3),argcount); # Konstruktor aufrufen
  4145.      mv_count=1; skipSTACK(4); return; # value1 als Wert
  4146.     }
  4147.   }}
  4148.  
  4149. # (set-dispatch-macro-character #\# #\Y
  4150. #   #'(lambda (stream sub-char arg)
  4151. #       (declare (ignore sub-char))
  4152. #       (if arg
  4153. #         ; Codevector lesen
  4154. #         (let ((obj (let ((*read-base* 16.)) (read stream t nil t))))
  4155. #           (unless *read-suppress*
  4156. #             (unless (= (length obj) arg)
  4157. #               (error "Falsche LΣnge eines Closure-Vektors: ~S" arg)
  4158. #             )
  4159. #             (make-code-vector obj) ; Simple-Bit-Vektor, Inhalt: arg Bytes
  4160. #         ) )
  4161. #         ; Closure lesen
  4162. #         (let ((obj (read stream t nil t)))
  4163. #           (unless *read-suppress*
  4164. #             (%make-closure (first obj) (second obj) (cddr obj))
  4165. # )   ) ) ) )
  4166.   # Fehlermeldung wegen falscher Syntax eines Code-Vektors
  4167.   # fehler_closure_badchar();
  4168.   # > Stackaufbau: stream, sub-char, arg.
  4169.     nonreturning_function(local, fehler_closure_badchar, (void));
  4170.     local void fehler_closure_badchar()
  4171.       { pushSTACK(STACK_2); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4172.         pushSTACK(STACK_(0+1)); # n
  4173.         pushSTACK(STACK_(2+2)); # Stream
  4174.         pushSTACK(S(read));
  4175.         fehler(stream_error,
  4176.                DEUTSCH ? "~ von ~: Falsche Syntax nach #~Y fⁿr Codevektor einer Closure" :
  4177.                ENGLISH ? "~ from ~: illegal syntax of closure code vector after #~Y" :
  4178.                FRANCAIS ? "~ de ~ : Mauvaise syntaxe de vecteur pour le code d'une ½closure╗ aprΦs #~Y" :
  4179.                ""
  4180.               );
  4181.       }
  4182.   # UP: ▄berprⁿft, ob String-Char ch mit Syntaxcode scode eine
  4183.   # Hexadezimal-Ziffer ist, und liefert ihren Wert.
  4184.   # hexziffer(ch,scode)
  4185.   # > ch, scode: String-Char (oder eof_value) und sein Syntaxcode
  4186.   # > Stackaufbau: stream, sub-char, arg.
  4187.   # < ergebnis: Wert (>=0, <16) der Hexziffer
  4188.     local uintB hexziffer (object ch, uintWL scode);
  4189.     local uintB hexziffer(ch,scode)
  4190.       var reg2 object ch;
  4191.       var reg3 uintWL scode;
  4192.       { if (scode == syntax_eof) { fehler_eof_innen(&STACK_2); }
  4193.         # ch ist ein String-Char
  4194.        {var reg1 uintB c = char_code(ch);
  4195.         if (c<'0') goto badchar; if (c<='9') { return (c-'0'); } # '0'..'9'
  4196.         if (c<'A') goto badchar; if (c<='F') { return (c-'A'+10); } # 'A'..'F'
  4197.         if (c<'a') goto badchar; if (c<='f') { return (c-'a'+10); } # 'a'..'f'
  4198.         badchar: fehler_closure_badchar();
  4199.       }}
  4200. LISPFUNN(closure_reader,3) # liest #Y
  4201.   { var reg3 object* stream_ = test_stream_arg(STACK_2);
  4202.     # bei *READ-SUPPRESS* /= NIL nur ein Objekt lesen:
  4203.     if (test_value(S(read_suppress)))
  4204.       { read_recursive_no_dot(stream_); # Objekt lesen, wegwerfen
  4205.         value1 = NIL; mv_count=1; skipSTACK(3); return; # NIL als Wert
  4206.       }
  4207.     # je nach n :
  4208.     if (nullp(STACK_0))
  4209.       # n=NIL -> Closure lesen:
  4210.       { var reg1 object obj = read_recursive_no_dot(stream_); # Objekt lesen
  4211.         if (!(consp(obj) && mconsp(Cdr(obj)))) # LΣnge >=2 ?
  4212.           { pushSTACK(*stream_); # Wert fⁿr Slot STREAM von STREAM-ERROR
  4213.             pushSTACK(obj);
  4214.             pushSTACK(*stream_); # Stream
  4215.             pushSTACK(S(read));
  4216.             fehler(stream_error,
  4217.                    DEUTSCH ? "~ von ~: Objekt #Y~ hat nicht die Syntax einer compilierten Closure." :
  4218.                    ENGLISH ? "~ from ~: object #Y~ has not the syntax of a compiled closure" :
  4219.                    FRANCAIS ? "~ de ~ : L'objet #Y~ n'a pas la syntaxe d'une ½closure╗ compilΘe." :
  4220.                    ""
  4221.                   );
  4222.           }
  4223.         skipSTACK(3);
  4224.         # (SYS::%MAKE-CLOSURE (first obj) (second obj) (cddr obj)) ausfⁿhren:
  4225.         pushSTACK(Car(obj)); obj = Cdr(obj); # 1. Argument
  4226.         pushSTACK(Car(obj)); obj = Cdr(obj); # 2. Argument
  4227.         pushSTACK(obj); # 3. Argument
  4228.         funcall(L(make_closure),3);
  4229.         mv_count=1; # value1 als Wert
  4230.       }
  4231.       else
  4232.       # n angegeben -> Codevektor lesen:
  4233.       # Syntax: #nY(b1 ... bn), wo n ein Fixnum >=0 und b1,...,bn
  4234.       # Fixnums >=0, <256 in Basis 16 sind (jeweils ein- oder zweistellig).
  4235.       # Beispielsweise #9Y(0 4 F CD 6B8FD1e4 5)
  4236.       { # n ist ein Integer >=0.
  4237.         var reg6 uintL n =
  4238.           (mposfixnump(STACK_0) ? posfixnum_to_L(STACK_0) # Fixnum -> Wert
  4239.                                 : bitm(oint_data_len)-1 # Bignum -> gro▀er Wert
  4240.           );
  4241.         # neuen Bit-Vektor mit n Bytes besorgen:
  4242.         STACK_1 = allocate_bit_vector(8*n);
  4243.         # Stackaufbau: Stream, Codevektor, n.
  4244.        {var reg2 object ch;
  4245.         var reg1 uintWL scode;
  4246.         # Whitespace ⁿberlesen:
  4247.         do { read_char_syntax(ch = ,scode = ,stream_); } # Zeichen lesen
  4248.            until (!(scode == syntax_whitespace));
  4249.         # Es mu▀ ein '(' folgen:
  4250.         if (!eq(ch,code_char('('))) { fehler_closure_badchar(); }
  4251.         {var reg5 uintL index = 0;
  4252.          until (index==n)
  4253.            { # Whitespace ⁿberlesen:
  4254.              do { read_char_syntax(ch = ,scode = ,stream_); } # Zeichen lesen
  4255.                 until (!(scode == syntax_whitespace));
  4256.             {# es mu▀ eine Hex-Ziffer folgen:
  4257.              var reg4 uintB zif = hexziffer(ch,scode);
  4258.              # nΣchstes Character lesen:
  4259.              read_char_syntax(ch = ,scode = ,stream_);
  4260.              if (scode == syntax_eof) { fehler_eof_innen(stream_); } # EOF -> Error
  4261.              if ((scode == syntax_whitespace) || eq(ch,code_char(')')))
  4262.                # Whitespace oder Klammer zu
  4263.                { # wird auf den Stream zurⁿckgeschoben:
  4264.                  unread_char(stream_,ch);
  4265.                }
  4266.                else
  4267.                { # es mu▀ eine zweite Hex-Ziffer sein
  4268.                  zif = 16*zif + hexziffer(ch,scode); # zur ersten Hex-Ziffer dazu
  4269.                  # (Nach der zweiten Hex-Ziffer wird kein Whitespace verlangt.)
  4270.                }
  4271.              # zif = gelesenes Byte. In den Codevektor eintragen:
  4272.              TheSbvector(STACK_1)->data[index] = zif;
  4273.              index++;
  4274.            }}
  4275.         }
  4276.         # Whitespace ⁿberlesen:
  4277.         do { read_char_syntax(ch = ,scode = ,stream_); } # Zeichen lesen
  4278.            until (!(scode == syntax_whitespace));
  4279.         # Es mu▀ ein ')' folgen:
  4280.         if (!eq(ch,code_char(')'))) { fehler_closure_badchar(); }
  4281.         # Codevektor als Wert:
  4282.         value1 = STACK_1; mv_count=1; skipSTACK(3);
  4283.       }}
  4284.   }
  4285.  
  4286. # (set-dispatch-macro-character #\# #\"
  4287. #   #'(lambda (stream sub-char n)
  4288. #       (unless *read-suppress*
  4289. #         (if n
  4290. #           (error "~ von ~: Zwischen # und " ist keine Zahl erlaubt."
  4291. #                  'read stream
  4292. #       ) ) )
  4293. #       (unread-char sub-char stream)
  4294. #       (let ((obj (read stream t nil t))) ; String lesen
  4295. #         (unless *read-suppress* (pathname obj))
  4296. # )   ) )
  4297. LISPFUNN(pathname_reader,3) # liest #"
  4298.   { test_no_infix(); # n mu▀ NIL sein
  4299.     # Stackaufbau: Stream, sub-char #\".
  4300.    {var reg1 object string = # String lesen, der mit " anfΣngt
  4301.       (funcall(L(string_reader),2),value1);
  4302.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  4303.     if (test_value(S(read_suppress)))
  4304.       { value1 = NIL; mv_count=1; return; } # NIL als Wert
  4305.     # Bilde (pathname string) = (values (parse-namestring string)) :
  4306.     pushSTACK(string); funcall(L(parse_namestring),1); # (PARSE-NAMESTRING string)
  4307.     mv_count=1; # nur 1 Wert
  4308.   }}
  4309.  
  4310. # ------------------------ LISP-Funktionen des Readers ------------------------
  4311.  
  4312. # UP: ▄berprⁿft ein Input-Stream-Argument.
  4313. # Default ist der Wert von *STANDARD-INPUT*.
  4314. # test_istream(&stream);
  4315. # > subr_self: Aufrufer (ein SUBR)
  4316. # > stream: Input-Stream-Argument
  4317. # < stream: Input-Stream (ein Stream)
  4318.   local void test_istream (object* stream_);
  4319.   local void test_istream(stream_)
  4320.     var reg2 object* stream_;
  4321.     { var reg1 object stream = *stream_;
  4322.       if (eq(stream,unbound) || nullp(stream))
  4323.         # statt #<UNBOUND> oder NIL: Wert von *STANDARD-INPUT*
  4324.         { *stream_ = var_stream(S(standard_input)); }
  4325.       elif (eq(stream,T))
  4326.         # statt T: Wert von *TERMINAL-IO*
  4327.         { *stream_ = var_stream(S(terminal_io)); }
  4328.       else
  4329.         { if (!streamp(stream)) { fehler_stream(stream); } }
  4330.     }
  4331.  
  4332. # EOF-Handling, beendet Reader-Funktionen.
  4333. # eof_handling()
  4334. # > STACK_3: Input-Stream
  4335. # > STACK_2: eof-error-p
  4336. # > STACK_1: eof-value
  4337. # > STACK_0: recursive-p
  4338. # < mv_space/mv_count: Werte
  4339.   local Values eof_handling (void);
  4340.   local Values eof_handling()
  4341.     { if (!nullp(STACK_2)) # eof-error-p /= NIL (z.B. = #<UNBOUND>) ?
  4342.         # Error melden:
  4343.         { var reg1 object recursive_p = STACK_0;
  4344.           if (eq(recursive_p,unbound) || nullp(recursive_p))
  4345.             { fehler_eof_aussen(&STACK_3); } # EOF melden
  4346.             else
  4347.             { fehler_eof_innen(&STACK_3); } # EOF innerhalb Objekt melden
  4348.         }
  4349.         else
  4350.         # EOF verarzten:
  4351.         { var reg1 object eofval = STACK_1;
  4352.           if (eq(eofval,unbound)) { eofval = eof_value; } # Default ist #<EOF>
  4353.           value1 = eofval; mv_count=1; skipSTACK(4); # eofval als Wert
  4354.         }
  4355.     }
  4356.  
  4357. # UP fⁿr READ und READ-PRESERVING-WHITESPACE
  4358. # read_w(whitespace-p)
  4359. # > whitespace-p: gibt an, ob danach whitespace zu verbrauchen ist
  4360. # > Stackaufbau: input-stream, eof-error-p, eof-value, recursive-p.
  4361. # < STACK: aufgerΣumt
  4362. # < mv_space/mv_count: Werte
  4363.   local Values read_w (object whitespace_p);
  4364.   local Values read_w(whitespace_p)
  4365.     var reg3 object whitespace_p;
  4366.     { # input-stream ⁿberprⁿfen:
  4367.       test_istream(&STACK_3);
  4368.       # recursive-p-Argument abfragen:
  4369.      {var reg2 object recursive_p = STACK_0;
  4370.       if (eq(recursive_p,unbound) || nullp(recursive_p))
  4371.         # nicht-rekursiver Aufruf
  4372.         { var reg1 object obj = read_top(&STACK_3,whitespace_p);
  4373.           if (eq(obj,dot_value)) { fehler_dot(STACK_3); } # Dot -> Error
  4374.           if (eq(obj,eof_value))
  4375.             { return_Values eof_handling(); } # EOF-Behandlung
  4376.             else
  4377.             { value1 = obj; mv_count=1; skipSTACK(4); } # obj als Wert
  4378.         }
  4379.         else
  4380.         # rekursiver Aufruf
  4381.         { value1 = read_recursive_no_dot(&STACK_3); mv_count=1; skipSTACK(4); }
  4382.     }}
  4383.  
  4384. LISPFUN(read,0,4,norest,nokey,0,NIL)
  4385. # (READ [input-stream [eof-error-p [eof-value [recursive-p]]]]), CLTL S. 375
  4386.   { return_Values read_w(NIL); } # whitespace-p := NIL
  4387.  
  4388. LISPFUN(read_preserving_whitespace,0,4,norest,nokey,0,NIL)
  4389. # (READ-PRESERVING-WHITESPACE [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4390. # CLTL S. 376
  4391.   { return_Values read_w(T); } # whitespace-p := T
  4392.  
  4393. LISPFUN(read_delimited_list,1,2,norest,nokey,0,NIL)
  4394. # (READ-DELIMITED-LIST char [input-stream [recursive-p]]), CLTL S. 377
  4395.   { # char ⁿberprⁿfen:
  4396.     var reg3 object ch = STACK_2;
  4397.     if (!string_char_p(ch)) { fehler_string_char(ch); }
  4398.     # input-stream ⁿberprⁿfen:
  4399.     test_istream(&STACK_1);
  4400.     # recursive-p-Argument abfragen:
  4401.    {var reg2 object recursive_p = popSTACK();
  4402.     # Stackaufbau: char, input-stream.
  4403.     if (eq(recursive_p,unbound) || nullp(recursive_p))
  4404.       # nicht-rekursiver Aufruf
  4405.       { var reg4 object* stream_ = &STACK_0;
  4406.         # SYS::*READ-REFERENCE-TABLE* an die leere Tabelle NIL binden:
  4407.         dynamic_bind(S(read_reference_table),NIL);
  4408.         # SYS::*BACKQUOTE-LEVEL* an NIL binden:
  4409.         dynamic_bind(S(backquote_level),NIL);
  4410.        {var reg1 object obj = read_delimited_list(stream_,ch,eof_value); # Liste lesen
  4411.         obj = make_references(obj); # Verweise entflechten
  4412.         dynamic_unbind();
  4413.         dynamic_unbind();
  4414.         value1 = obj; # Liste als Wert
  4415.       }}
  4416.       else
  4417.       # rekursiver Aufruf
  4418.       { value1 = read_delimited_list(&STACK_0,ch,eof_value); }
  4419.     # (Beide Male Liste gelesen, keine Dotted List zugelassen.)
  4420.     mv_count=1; skipSTACK(2);
  4421.   }}
  4422.  
  4423. LISPFUN(read_line,0,4,norest,nokey,0,NIL)
  4424. # (READ-LINE [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4425. # CLTL S. 378
  4426.   { # input-stream ⁿberprⁿfen:
  4427.     var reg2 object* stream_ = &STACK_3;
  4428.     test_istream(stream_);
  4429.     get_buffers(); # zwei leere Buffer auf den Stack
  4430.     loop
  4431.       { var reg1 object ch = read_char(stream_); # nΣchstes Zeichen lesen
  4432.         if (eq(ch,eof_value)) goto eof; # EOF ?
  4433.         # sonst Character. Auf String-Char ⁿberprⁿfen:
  4434.         if (!string_char_p(ch)) { fehler_string_char(ch); }
  4435.         if (eq(ch,code_char(NL))) goto eol; # NL -> End of Line
  4436.         # sonstiges Character in den Buffer schreiben:
  4437.         ssstring_push_extend(STACK_0,char_code(ch));
  4438.       }
  4439.     eol: # End of Line
  4440.     { # Buffer kopieren und dabei in Simple-String umwandeln:
  4441.       value1 = copy_string(STACK_0);
  4442.       # Buffer zur Wiederverwendung freigeben:
  4443.       O(token_buff_2) = popSTACK(); O(token_buff_1) = popSTACK();
  4444.       value2 = NIL; mv_count=2; # NIL als 2. Wert
  4445.       skipSTACK(4); return;
  4446.     }
  4447.     eof: # End of File
  4448.     { var reg1 object buff = STACK_0; # Buffer
  4449.       # Buffer zur Wiederverwendung freigeben:
  4450.       O(token_buff_2) = popSTACK(); O(token_buff_1) = popSTACK();
  4451.       # Buffer leer ?
  4452.       if (TheArray(buff)->dims[1] == 0) # LΣnge (Fill-Pointer) = 0 ?
  4453.         { return_Values eof_handling(); } # ja -> EOF speziell behandeln
  4454.         else
  4455.         { # Buffer kopieren und dabei in Simple-String umwandeln:
  4456.           value1 = copy_string(buff);
  4457.           value2 = T; mv_count=2; # T als 2. Wert
  4458.           skipSTACK(4); return;
  4459.     }   }
  4460.   }
  4461.  
  4462. LISPFUN(read_char,0,4,norest,nokey,0,NIL)
  4463. # (READ-CHAR [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4464. # CLTL S. 379
  4465.   { # input-stream ⁿberprⁿfen:
  4466.     var reg2 object* stream_ = &STACK_3;
  4467.     test_istream(stream_);
  4468.    {var reg1 object ch = read_char(stream_); # Character lesen
  4469.     if (eq(ch,eof_value))
  4470.       { return_Values eof_handling(); }
  4471.       else
  4472.       { value1 = ch; mv_count=1; skipSTACK(4); return; } # ch als Wert
  4473.   }}
  4474.  
  4475. LISPFUN(unread_char,1,1,norest,nokey,0,NIL)
  4476. # (UNREAD-CHAR char [input-stream]), CLTL S. 379
  4477.   { # input-stream ⁿberprⁿfen:
  4478.     var reg2 object* stream_ = &STACK_0;
  4479.     test_istream(stream_);
  4480.    {var reg1 object ch = STACK_1; # char
  4481.     if (!charp(ch)) # mu▀ ein Character sein !
  4482.       { pushSTACK(ch); # Wert fⁿr Slot DATUM von TYPE-ERROR
  4483.         pushSTACK(S(character)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  4484.         pushSTACK(ch);
  4485.         pushSTACK(TheSubr(subr_self)->name);
  4486.         fehler(type_error,
  4487.                DEUTSCH ? "~: ~ ist kein Character." :
  4488.                ENGLISH ? "~: ~ is not a character" :
  4489.                FRANCAIS ? "~ : ~ n'est pas un caractΦre." :
  4490.                ""
  4491.               );
  4492.       }
  4493.     unread_char(stream_,ch); # char auf Stream zurⁿckschieben
  4494.     value1 = NIL; mv_count=1; skipSTACK(2); # NIL als Wert
  4495.   }}
  4496.  
  4497. LISPFUN(peek_char,0,5,norest,nokey,0,NIL)
  4498. # (PEEK-CHAR [peek-type [input-stream [eof-error-p [eof-value [recursive-p]]]]]),
  4499. # CLTL S. 379
  4500.   { # input-stream ⁿberprⁿfen:
  4501.     var reg2 object* stream_ = &STACK_3;
  4502.     test_istream(stream_);
  4503.     # Fallunterscheidung nach peek-type:
  4504.    {var reg3 object peek_type = STACK_4;
  4505.     if (eq(peek_type,unbound) || nullp(peek_type))
  4506.       # Default NIL: 1 Zeichen peeken
  4507.       { var reg1 object ch = peek_char(stream_);
  4508.         if (eq(ch,eof_value)) goto eof;
  4509.         value1 = ch; mv_count=1; skipSTACK(5); return; # ch als Wert
  4510.       }
  4511.     elif (eq(peek_type,T))
  4512.       # T: Whitespace-Peek
  4513.       { var reg1 object ch = wpeek_char_eof(stream_);
  4514.         if (eq(ch,eof_value)) goto eof;
  4515.         value1 = ch; mv_count=1; skipSTACK(5); return; # ch als Wert
  4516.       }
  4517.     elif (charp(peek_type))
  4518.       # peek-type ist ein Character
  4519.       { var reg1 object ch;
  4520.         loop
  4521.           { ch = read_char(stream_); # Zeichen lesen
  4522.             if (eq(ch,eof_value)) goto eof;
  4523.             if (eq(ch,peek_type)) break; # das vorgegebene Ende-Zeichen?
  4524.           }
  4525.         unread_char(stream_,ch); # Zeichen zurⁿckschieben
  4526.         value1 = ch; mv_count=1; skipSTACK(5); return; # ch als Wert
  4527.       }
  4528.     else
  4529.       { pushSTACK(peek_type); # Wert fⁿr Slot DATUM von TYPE-ERROR
  4530.         pushSTACK(O(type_peektype)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  4531.         pushSTACK(peek_type);
  4532.         pushSTACK(TheSubr(subr_self)->name);
  4533.         fehler(type_error,
  4534.                DEUTSCH ? "~: Peek-Type mu▀ NIL oder T oder ein Character sein, nicht ~" :
  4535.                ENGLISH ? "~: peek type should be NIL or T or a character, not ~" :
  4536.                FRANCAIS ? "~ : Le mode de PEEK doit Ωtre NIL ou T ou un caractΦre et non ~" :
  4537.                ""
  4538.               );
  4539.       }
  4540.     eof: # EOF liegt vor
  4541.       eof_handling(); skipSTACK(1); return;
  4542.   }}
  4543.  
  4544. LISPFUN(listen,0,1,norest,nokey,0,NIL)
  4545. # (LISTEN [input-stream]), CLTL S. 380
  4546.   { test_istream(&STACK_0); # input-stream ⁿberprⁿfen
  4547.     if (stream_listen(popSTACK()) == 0) # Zeichen verfⁿgbar?
  4548.       { value1 = T; mv_count=1; } # Wert T
  4549.       else
  4550.       { value1 = NIL; mv_count=1; } # Wert NIL
  4551.   }
  4552.  
  4553. LISPFUN(read_char_no_hang,0,4,norest,nokey,0,NIL)
  4554. # (READ-CHAR-NO-HANG [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4555. # CLTL S. 380
  4556.   { # input-stream ⁿberprⁿfen:
  4557.     var reg3 object* stream_ = &STACK_3;
  4558.     test_istream(stream_);
  4559.    {var reg2 object stream = *stream_;
  4560.     if (!(TheStream(stream)->strmflags & bit(strmflags_rd_ch_bit_B)))
  4561.       { fehler_illegal_streamop(S(read_char_no_hang),stream); }
  4562.     { var reg1 signean status = stream_listen(stream);
  4563.       if (status < 0) # EOF ?
  4564.         { return_Values eof_handling(); }
  4565.       elif (status == 0) # Zeichen verfⁿgbar
  4566.         { var reg3 object ch = read_char(stream_); # Character lesen
  4567.           if (eq(ch,eof_value)) # sicherheitshalber nochmals auf EOF abfragen
  4568.             { return_Values eof_handling(); }
  4569.             else
  4570.             { value1 = ch; mv_count=1; skipSTACK(4); return; } # ch als Wert
  4571.         }
  4572.       else # (status > 0) # kein Zeichen verfⁿgbar
  4573.         # statt zu warten, sofort NIL als Wert:
  4574.         { value1 = NIL; mv_count=1; skipSTACK(4); return; }
  4575.   }}}
  4576.  
  4577. LISPFUN(clear_input,0,1,norest,nokey,0,NIL)
  4578. # (CLEAR-INPUT [input-stream]), CLTL S. 380
  4579.   { test_istream(&STACK_0); # input-stream ⁿberprⁿfen
  4580.     clear_input(popSTACK());
  4581.     value1 = NIL; mv_count=1; # Wert NIL
  4582.   }
  4583.  
  4584. LISPFUN(read_from_string,1,2,norest,key,3,\
  4585.         (kw(preserve_whitespace),kw(start),kw(end)) )
  4586. # (READ-FROM-STRING string [eof-error-p [eof-value [:preserve-whitespace] [:start] [:end]]]),
  4587. # CLTL S. 380
  4588. # Methode:
  4589. # (defun read-from-string (string &optional (eof-error-p t) (eof-value nil)
  4590. #                          &key (start 0) (end nil) (preserve-whitespace nil)
  4591. #                          &aux index)
  4592. #   (values
  4593. #     (with-input-from-string (stream string :start start :end end :index index)
  4594. #       (funcall (if preserve-whitespace #'read-preserving-whitespace #'read)
  4595. #                stream eof-error-p eof-value nil
  4596. #     ) )
  4597. #     index
  4598. # ) )
  4599. # oder macroexpandiert:
  4600. # (defun read-from-string (string &optional (eof-error-p t) (eof-value nil)
  4601. #                          &key (start 0) (end nil) (preserve-whitespace nil))
  4602. #   (let ((stream (make-string-input-stream string start end)))
  4603. #     (values
  4604. #       (unwind-protect
  4605. #         (funcall (if preserve-whitespace #'read-preserving-whitespace #'read)
  4606. #                  stream eof-error-p eof-value nil
  4607. #         )
  4608. #         (close stream)
  4609. #       )
  4610. #       (system::string-input-stream-index stream)
  4611. # ) ) )
  4612. # oder vereinfacht:
  4613. # (defun read-from-string (string &optional (eof-error-p t) (eof-value nil)
  4614. #                          &key (start 0) (end nil) (preserve-whitespace nil))
  4615. #   (let ((stream (make-string-input-stream string start end)))
  4616. #     (values
  4617. #       (funcall (if preserve-whitespace #'read-preserving-whitespace #'read)
  4618. #                stream eof-error-p eof-value nil
  4619. #       )
  4620. #       (system::string-input-stream-index stream)
  4621. # ) ) )
  4622.   { # Stackaufbau: string, eof-error-p, eof-value, preserve-whitespace, start, end.
  4623.     # :preserve-whitespace-Argument verarbeiten:
  4624.     var reg1 object preserve_whitespace = STACK_2;
  4625.     if (eq(preserve_whitespace,unbound)) { preserve_whitespace = NIL; }
  4626.     # MAKE-STRING-INPUT-STREAM mit Argumenten string, start, end aufrufen:
  4627.     STACK_2 = STACK_5; # string
  4628.     if (eq(STACK_1,unbound)) { STACK_1 = Fixnum_0; } # start hat Default 0
  4629.     if (eq(STACK_0,unbound)) { STACK_0 = NIL; } # end hat Default NIL
  4630.     STACK_5 = preserve_whitespace;
  4631.     funcall(L(make_string_input_stream),3);
  4632.     # Stackaufbau: preserve-whitespace, eof-error-p, eof-value.
  4633.     pushSTACK(STACK_1); pushSTACK(STACK_1);
  4634.     STACK_3 = STACK_2 = value1;
  4635.     # Stackaufbau: preserve-whitespace, stream, stream, eof-error-p, eof-value.
  4636.     pushSTACK(NIL); read_w(STACK_5); # READ bzw. READ-PRESERVE-WHITESPACE
  4637.     # Stackaufbau: preserve-whitespace, stream.
  4638.     STACK_1 = value1; # gelesenes Objekt
  4639.     funcall(L(string_input_stream_index),1); # (SYS::STRING-INPUT-STREAM-INDEX stream)
  4640.     value2 = value1; value1 = popSTACK(); # Index als 2., Objekt als 1. Wert
  4641.     mv_count=2;
  4642.   }
  4643.  
  4644. LISPFUN(parse_integer,1,0,norest,key,4,\
  4645.         (kw(start),kw(end),kw(radix),kw(junk_allowed)) )
  4646. # (PARSE-INTEGER string [:start] [:end] [:radix] [:junk-allowed]), CLTL S. 381
  4647.   { # :junk-allowed-Argument verarbeiten:
  4648.     var reg7 boolean junk_allowed;
  4649.     {var reg1 object arg = popSTACK();
  4650.      if (eq(arg,unbound) || nullp(arg))
  4651.        { junk_allowed = FALSE; }
  4652.        else
  4653.        { junk_allowed = TRUE; }
  4654.     }
  4655.     # junk_allowed = Wert des :junk-allowed-Arguments.
  4656.     # :radix-Argument verarbeiten:
  4657.    {var reg5 uintL base;
  4658.     {var reg1 object arg = popSTACK();
  4659.      if (eq(arg,unbound))
  4660.        { base = 10; } # Default 10
  4661.        else
  4662.        { if (posfixnump(arg) &&
  4663.              (base = posfixnum_to_L(arg), ((base >= 2) && (base <= 36)))
  4664.             )
  4665.            {} # OK
  4666.            else
  4667.            { pushSTACK(arg); # Wert fⁿr Slot DATUM von TYPE-ERROR
  4668.              pushSTACK(O(type_radix)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  4669.              pushSTACK(arg); # base
  4670.              pushSTACK(S(Kradix));
  4671.              pushSTACK(TheSubr(subr_self)->name);
  4672.              fehler(type_error,
  4673.                     DEUTSCH ? "~: ~-Argument mu▀ ein Integer zwischen 2 und 36 sein, nicht ~" :
  4674.                     ENGLISH ? "~: ~ argument should be an integer between 2 and 36, not ~" :
  4675.                     FRANCAIS ? "~ : L'argument ~ doit Ωtre un entier entre 2 et 36, pas ~" :
  4676.                     ""
  4677.                    );
  4678.     }  }   }
  4679.     # base = Wert des :radix-Arguments.
  4680.     { # string, :start und :end ⁿberprⁿfen:
  4681.       var object string; # String
  4682.       var uintL start; # Wert des :start-Arguments
  4683.       var uintL len; # Anzahl der angesprochenen Characters
  4684.       var reg2 uintB* charptr = test_string_limits(&string,&start,&len);
  4685.       # STACK jetzt aufgerΣumt.
  4686.       # Datenvektor holen:
  4687.       var uintL start_offset = 0;
  4688.       var reg9 object sstring = array_displace_check(string,len,&start_offset);
  4689.       var reg8 uintL end_offset = start_offset; # Offset vom String zum Datenvektor
  4690.       # Schleifenvariablen:
  4691.       var reg4 uintL index = start;
  4692.       var reg3 uintL count = len;
  4693.       # Ab jetzt:
  4694.       #   string : der String,
  4695.       #   sstring : sein Datenvektor (ein Simple-String),
  4696.       #   start : Index des ersten Characters im String,
  4697.       #   charptr : Pointer in den Datenvektor auf das nΣchste Character,
  4698.       #   index : Index in den String,
  4699.       #   count : verbleibende Anzahl Characters.
  4700.       var reg6 signean sign; # Vorzeichen
  4701.      {var reg1 uintB c; # letztes gelesenes Character
  4702.       # 1. Schritt: Whitespace ⁿbergehen
  4703.       loop
  4704.         { if (count==0) goto badsyntax; # Stringstⁿck schon zu Ende ?
  4705.           c = *charptr; # nΣchstes Character
  4706.           if (!(orig_syntax_table[c] == syntax_whitespace)) # kein Whitespace?
  4707.             break;
  4708.           charptr++; index++; count--; # Whitespacezeichen ⁿbergehen
  4709.         }
  4710.       # 2. Schritt: Vorzeichen lesen
  4711.       sign = 0; # Vorzeichen := positiv
  4712.       switch (c)
  4713.         { case '-': sign = -1; # Vorzeichen := negativ
  4714.           case '+': # Vorzeichen angetroffen
  4715.             charptr++; index++; count--; # ⁿbergehen
  4716.             if (count==0) goto badsyntax; # Stringstⁿck schon zu Ende ?
  4717.           default: break;
  4718.         }
  4719.      }# Vorzeichen fertig, es kommt noch was (count>0).
  4720.       start_offset = start_offset + index;
  4721.       # Ab jetzt:  start_offset = Offset der ersten Ziffer im Datenvektor.
  4722.       # 3. Schritt: Ziffern lesen
  4723.       loop
  4724.         { var reg1 uintB c = *charptr; # nΣchstes Character
  4725.           # Test auf Ziffer: (digit-char-p (code-char c) base) ?
  4726.           # (vgl. DIGIT-CHAR-P in CHARSTRG.D)
  4727.           if (c > 'z') break; # zu gro▀ -> nein
  4728.           if (c >= 'a') { c -= 'a'-'A'; } # Character >='a',<='z' in Gro▀buchstaben wandeln
  4729.           # Nun ist $00 <= c <= $60.
  4730.           if (c < '0') break;
  4731.           # $30 <= c <= $60 in Zahlwert umwandeln:
  4732.           if (c <= '9') { c = c - '0'; }
  4733.           else if (c >= 'A') { c = c - 'A' + 10; }
  4734.           else break;
  4735.           # Nun ist c der Zahlwert der Ziffer, >=0, <=41.
  4736.           if (c >= (uintB)base) break; # nur gⁿltig, falls 0 <= c < base.
  4737.           # *charptr ist eine gⁿltige Ziffer.
  4738.           charptr++; index++; count--; # ⁿbergehen
  4739.           if (count==0) break;
  4740.         }
  4741.       # Ziffern fertig.
  4742.       end_offset = end_offset + index;
  4743.       # Ab jetzt:  end_offset = Offset nach der letzten Ziffer im Datenvektor.
  4744.       if (start_offset == end_offset) # gab es keine Ziffern?
  4745.         goto badsyntax;
  4746.       # 4. Schritt: evtl. Whitespace am Schlu▀ ⁿbergehen
  4747.       if (!junk_allowed) # (falls junk_allowed, ist nichts zu tun)
  4748.         { while (!(count==0))
  4749.             { var reg1 uintB c = *charptr; # nΣchstes Character
  4750.               if (!(orig_syntax_table[c] == syntax_whitespace)) # kein Whitespace?
  4751.                 goto badsyntax;
  4752.               charptr++; index++; count--; # Whitespacezeichen ⁿbergehen
  4753.             }
  4754.         }
  4755.       # 5. Schritt: Ziffernfolge in Zahl umwandeln
  4756.       value1 = read_integer(base,sign,sstring,start_offset,end_offset);
  4757.       value2 = fixnum(index); # Index als 2. Wert
  4758.       mv_count=2; return;
  4759.       badsyntax: # Illegales Zeichen
  4760.       if (!junk_allowed)
  4761.         # Error melden:
  4762.         { pushSTACK(unbound); # "Wert" fⁿr Slot STREAM von STREAM-ERROR
  4763.           pushSTACK(string);
  4764.           pushSTACK(TheSubr(subr_self)->name);
  4765.           fehler(stream_error,
  4766.                  DEUTSCH ? "~: String ~ hat nicht die Syntax eines Integers." :
  4767.                  ENGLISH ? "~: string ~ hasn't integer syntax" :
  4768.                  FRANCAIS ? "~ : La chaεne ~ n'a pas la syntaxe d'un nombre entier." :
  4769.                  ""
  4770.                 );
  4771.         }
  4772.       value1 = NIL; # NIL als 1. Wert
  4773.       value2 = fixnum(index); # Index als 2. Wert
  4774.       mv_count=2; return;
  4775.   }}}
  4776.  
  4777.  
  4778. # =============================================================================
  4779. #                              P R I N T
  4780. # =============================================================================
  4781.  
  4782. # Grundidee des Printers:
  4783. # Vom Datentyp abhΣngig, wird die externe ReprΣsentation des Objekts auf den
  4784. # Stream ausgegeben, rekursiv. Der Unterschied zwischen PRINT und PPRINT
  4785. # besteht darin, da▀ an einigen Stellen statt einem Space ein Newline und
  4786. # einige Spaces ausgegeben werden. Um dies zu bewerkstelligen, wird die
  4787. # externe ReprΣsentation der Teil-Objekte auf einen Pretty-Printer-Hilfs-
  4788. # (PPHELP-)Stream ausgegeben, dann ⁿberprⁿft, ob man mehrere Zeilen braucht
  4789. # oder eine ausreicht, und schlie▀lich (davon abhΣngig) Whitespace eingefⁿgt.
  4790. # Die genauere Spezifikation der prin_object-Routine:
  4791. # > Stream,
  4792. # > ZeilenlΣnge L,
  4793. # > Linker Rand fⁿr Einzeiler L1,
  4794. # > Linker Rand fⁿr Mehrzeiler LM,
  4795. # > Anzahl der auf der letzten Zeile am Schlu▀ noch zu schlie▀enden Klammern
  4796. #   K (Fixnum >=0) und Flag, ob bei Mehrzeilern die letzten schlie▀enden
  4797. #   Klammern in einer eigenen Zeile, justiert unterhalb der entsprechenden
  4798. #   ÷ffnenden Klammern, erscheinen sollen.
  4799. #   [Der Einfachheit halber ist hier stets K=0 und Flag=True, d.h. alle
  4800. #   schlie▀enden Klammern von Mehrzeilern erscheinen in einer eigenen Zeile.]
  4801. # < Stream, auf den das Objekt ausgegeben wurde,
  4802. #   entweder als Einzeiler (der LΣnge <=L-L1-K)
  4803. #   oder als Mehrzeiler (mit Newline und LM Spaces statt Space zwischen
  4804. #   Teilobjekten), jede Zeile (wenn's geht) der LΣnge <=L, letzte Zeile
  4805. #   (wenn's geht) der LΣnge <=L-K.
  4806. # < Falls der Stream ein PPHELP-Stream ist, enthΣlt er den Modus und eine
  4807. #   nichtleere Liste der ausgegebenen Zeilen (in umgekehrter Reihenfolge).
  4808.  
  4809. # ---------------------- allgemeine Unterprogramme ----------------------------
  4810.  
  4811. # UP: Gibt ein unsigned Integer mit max. 32 Bit dezimal auf einen Stream aus.
  4812. # pr_uint(&stream,uint);
  4813. # > uint: Unsigned Integer
  4814. # > stream: Stream
  4815. # < stream: Stream
  4816. # kann GC ausl÷sen
  4817.   local void pr_uint (object* stream_, uintL x);
  4818.   local void pr_uint(stream_,x)
  4819.     var reg5 object* stream_;
  4820.     var reg1 uintL x;
  4821.     { var uintB ziffern[10]; # max. 10 Ziffern, da 0 <= x < 2^32 <= 10^10
  4822.       var reg3 uintB* ziffptr = &ziffern[0];
  4823.       var reg4 uintC ziffcount = 0; # Anzahl der Ziffern
  4824.       # Ziffern produzieren:
  4825.       do { var reg2 uintB zif;
  4826.            divu_3216_3216(x,10,x=,zif=); # x := floor(x/10), zif := Rest
  4827.            *ziffptr++ = zif; ziffcount++; # Ziffer abspeichern
  4828.          }
  4829.          until (x==0);
  4830.       # Ziffern in umgekehrter Reihenfolge ausgeben:
  4831.       dotimespC(ziffcount,ziffcount,
  4832.         { write_schar(stream_,'0' + *--ziffptr); }
  4833.         );
  4834.     }
  4835.  
  4836. # UP: Gibt ein Nibble hexadezimal (mit 1 Hex-Ziffer) auf einen Stream aus.
  4837. # pr_hex1(&stream,x);
  4838. # > x: Nibble (>=0,<16)
  4839. # > stream: Stream
  4840. # < stream: Stream
  4841. # kann GC ausl÷sen
  4842.   local void pr_hex1 (object* stream_, uint4 x);
  4843.   local void pr_hex1(stream_,x)
  4844.     var reg2 object* stream_;
  4845.     var reg1 uint4 x;
  4846.     { write_schar(stream_, ( x<10 ? '0'+(uintB)x : 'A'+(uintB)x-10 ) ); }
  4847.  
  4848. # UP: Gibt ein Byte hexadezimal (mit 2 Hex-Ziffern) auf einen Stream aus.
  4849. # pr_hex2(&stream,x);
  4850. # > x: Byte
  4851. # > stream: Stream
  4852. # < stream: Stream
  4853. # kann GC ausl÷sen
  4854.   local void pr_hex2 (object* stream_, uint8 x);
  4855.   local void pr_hex2(stream_,x)
  4856.     var reg2 object* stream_;
  4857.     var reg1 uint8 x;
  4858.     { pr_hex1(stream_,(uint4)(x>>4)); # Bits 7..4 ausgeben
  4859.       pr_hex1(stream_,(uint4)(x & (bit(4)-1))); # Bits 3..0 ausgeben
  4860.     }
  4861.  
  4862. # UP: Gibt eine Adresse mit 24 Bit hexadezimal (mit 6 Hex-Ziffern)
  4863. # auf einen Stream aus.
  4864. # pr_hex6(&stream,obj);
  4865. # > Adressbits von obj: Unsigned Integer
  4866. # > stream: Stream
  4867. # < stream: Stream
  4868. # kann GC ausl÷sen
  4869.   local void pr_hex6 (object* stream_, object obj);
  4870.   local void pr_hex6(stream_,obj)
  4871.     var reg2 object* stream_;
  4872.     var reg3 object obj;
  4873.     { var reg1 oint x = (as_oint(obj) >> oint_addr_shift) << addr_shift;
  4874.       write_schar(stream_,'#'); write_schar(stream_,'x'); # PrΣfix fⁿr "Hexadezimal"
  4875.       #define pr_hexpart(k)  # Bits k+7..k ausgeben:  \
  4876.         if (((oint_addr_mask>>oint_addr_shift)<<addr_shift) & minus_wbit(k)) \
  4877.           { pr_hex2(stream_,(uint8)(x >> k) & (((oint_addr_mask>>oint_addr_shift)<<addr_shift) >> k) & 0xFF); }
  4878.       #ifdef WIDE_HARD
  4879.       pr_hexpart(56);
  4880.       pr_hexpart(48);
  4881.       pr_hexpart(40);
  4882.       pr_hexpart(32);
  4883.       #endif
  4884.       pr_hexpart(24);
  4885.       pr_hexpart(16);
  4886.       pr_hexpart(8);
  4887.       pr_hexpart(0);
  4888.       #undef pr_hexpart
  4889.     }
  4890.  
  4891. # *PRINT-READABLY* /= NIL bewirkt u.a. implizit dasselbe wie
  4892. # *PRINT-ESCAPE* = T, *PRINT-BASE* = 10, *PRINT-RADIX* = T,
  4893. # *PRINT-CIRCLE* = T, *PRINT-LEVEL* = NIL, *PRINT-LENGTH* = NIL,
  4894. # *PRINT-GENSYM* = T, *PRINT-ARRAY* = T, *PRINT-CLOSURE* = T.
  4895.  
  4896. # Fehlermeldung bei *PRINT-READABLY* /= NIL.
  4897. # fehler_print_readably(obj);
  4898.   nonreturning_function(local, fehler_print_readably, (object obj));
  4899.   local void fehler_print_readably(obj)
  4900.     var reg1 object obj;
  4901.     # (error "~: Trotz ~ kann ~ nicht wiedereinlesbar ausgegeben werden."
  4902.     #        'print '*print-readably* obj
  4903.     # )
  4904.     { dynamic_bind(S(print_readably),NIL); # *PRINT-READABLY* an NIL binden
  4905.       pushSTACK(unbound); # "Wert" fⁿr Slot STREAM von STREAM-ERROR
  4906.       pushSTACK(obj);
  4907.       pushSTACK(S(print_readably));
  4908.       pushSTACK(S(print));
  4909.       fehler(stream_error,
  4910.              DEUTSCH ? "~: Trotz ~ kann ~ nicht wiedereinlesbar ausgegeben werden." :
  4911.              ENGLISH ? "~: Despite of ~, ~ cannot be printed readably." :
  4912.              FRANCAIS ? "~ : MalgrΘ ~, ~ ne peut pas Ωtre imprimΘ de faτon lisible." :
  4913.              ""
  4914.             );
  4915.     }
  4916.  
  4917. # Fehlermeldung bei unzulΣssigem Wert von *PRINT-CASE*.
  4918. # fehler_print_case();
  4919.   nonreturning_function(local, fehler_print_case, (void));
  4920.   local void fehler_print_case()
  4921.     # (error "~: Der Wert ~ von ~ ist weder ~ noch ~ noch ~.
  4922.     #         Er wird auf ~ gesetzt."
  4923.     #        'print *print-case* '*print-case* ':upcase ':downcase ':capitalize
  4924.     #        ':upcase
  4925.     # )
  4926.     { var reg1 object print_case = S(print_case);
  4927.       pushSTACK(Symbol_value(print_case)); # Wert fⁿr Slot DATUM von TYPE-ERROR
  4928.       pushSTACK(O(type_printcase)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  4929.       pushSTACK(S(Kupcase)); # :UPCASE
  4930.       pushSTACK(S(Kcapitalize)); # :CAPITALIZE
  4931.       pushSTACK(S(Kdowncase)); # :DOWNCASE
  4932.       pushSTACK(S(Kupcase)); # :UPCASE
  4933.       pushSTACK(print_case);
  4934.       pushSTACK(Symbol_value(print_case));
  4935.       pushSTACK(S(print));
  4936.       Symbol_value(print_case) = S(Kupcase); # (setq *PRINT-CASE* ':UPCASE)
  4937.       fehler(type_error,
  4938.              DEUTSCH ? "~: Der Wert ~ von ~ ist weder ~ noch ~ noch ~." NLstring
  4939.                        "Er wird auf ~ gesetzt." :
  4940.              ENGLISH ? "~: the value ~ of ~ is neither ~ nor ~ nor ~." NLstring
  4941.                        "It is reset to ~." :
  4942.              FRANCAIS ? "~ : La valeur ~ de ~ n'est ni ~ ni ~ ni ~." NLstring
  4943.                         "Elle est remplacΘe par ~." :
  4944.              ""
  4945.             );
  4946.     }
  4947.  
  4948. # Macro: Fragt den Wert von *PRINT-CASE* ab und verzweigt je nachdem.
  4949. # switch_print_case(upcase_statement,downcase_statement,capitalize_statement);
  4950.   #define switch_print_case(upcase_statement,downcase_statement,capitalize_statement)  \
  4951.     {var reg3 object print_case = Symbol_value(S(print_case)); # Wert von *PRINT-CASE* \
  4952.      if (eq(print_case,S(Kupcase))) # = :UPCASE ?            \
  4953.        { upcase_statement }                                  \
  4954.      elif (eq(print_case,S(Kdowncase))) # = :DOWNCASE ?      \
  4955.        { downcase_statement }                                \
  4956.      elif (eq(print_case,S(Kcapitalize))) # = :CAPITALIZE ?  \
  4957.        { capitalize_statement }                              \
  4958.      else # keines der drei -> Error                         \
  4959.        { fehler_print_case(); }                              \
  4960.     }
  4961.  
  4962. # UP: Gibt einen Teil eines Simple-String elementweise auf einen Stream aus.
  4963. # write_sstring_ab(&stream,string,start,len);
  4964. # > string: Simple-String
  4965. # > start: Startindex
  4966. # > len: Anzahl der auszugebenden Zeichen
  4967. # > stream: Stream
  4968. # < stream: Stream
  4969. # kann GC ausl÷sen
  4970.   #ifndef STRM_WR_SS
  4971.   local void write_sstring_ab (object* stream_, object string, uintL start, uintL len);
  4972.   local void write_sstring_ab(stream_,string,start,len)
  4973.     var reg3 object* stream_;
  4974.     var reg5 object string;
  4975.     var reg4 uintL start;
  4976.     var reg2 uintL len;
  4977.     { var reg1 uintL index = start;
  4978.       pushSTACK(string); # Simple-String retten
  4979.       dotimesL(len,len,
  4980.         { write_schar(stream_,TheSstring(STACK_0)->data[index]);
  4981.           index++;
  4982.         });
  4983.       skipSTACK(1);
  4984.     }
  4985.   #else
  4986.     typedef void (* wr_ss_Pseudofun) (object* stream_, object string, uintL start, uintL len);
  4987.     #define wr_ss(strm)  (*(wr_ss_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ss)))
  4988.     #define write_sstring_ab(stream_,string,start,len)  \
  4989.       wr_ss(*stream_)(stream_,string,start,len)
  4990.   #endif
  4991.  
  4992. # UP: Gibt einen Simple-String elementweise auf einen Stream aus.
  4993. # write_sstring(&stream,string);
  4994. # > string: Simple-String
  4995. # > stream: Stream
  4996. # < stream: Stream
  4997. # kann GC ausl÷sen
  4998.   global void write_sstring (object* stream_, object string);
  4999.   global void write_sstring(stream_,string)
  5000.     var reg2 object* stream_;
  5001.     var reg1 object string;
  5002.     { write_sstring_ab(stream_,string,0,TheSstring(string)->length); }
  5003.  
  5004. # UP: Gibt einen String elementweise auf einen Stream aus.
  5005. # write_string(&stream,string);
  5006. # > string: String
  5007. # > stream: Stream
  5008. # < stream: Stream
  5009. # kann GC ausl÷sen
  5010.   global void write_string (object* stream_, object string);
  5011.   global void write_string(stream_,string)
  5012.     var reg2 object* stream_;
  5013.     var reg1 object string;
  5014.     { if (simple_string_p(string))
  5015.         # Simple-String
  5016.         { write_sstring(stream_,string); }
  5017.         else
  5018.         # nicht-simpler String
  5019.         { var reg3 uintL len = vector_length(string); # LΣnge
  5020.           var uintL offset = 0; # Offset vom String in den Datenvektor
  5021.           var reg4 object sstring = array1_displace_check(string,len,&offset); # Datenvektor
  5022.           write_sstring_ab(stream_,sstring,offset,len);
  5023.         }
  5024.     }
  5025.  
  5026. # UP: Gibt einen Simple-String je nach (READTABLE-CASE *READTABLE*) und
  5027. # *PRINT-CASE* auf einen Stream aus.
  5028. # write_sstring_case(&stream,string);
  5029. # > string: Simple-String
  5030. # > stream: Stream
  5031. # < stream: Stream
  5032. # kann GC ausl÷sen
  5033.   local void write_sstring_case (object* stream_, object string);
  5034.   local void write_sstring_case(stream_,string)
  5035.     var reg6 object* stream_;
  5036.     var reg7 object string;
  5037.     { # (READTABLE-CASE *READTABLE*) abfragen:
  5038.       var reg1 object readtable;
  5039.       get_readtable(readtable = ); # aktuelle Readtable
  5040.       switch ((uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case))
  5041.         { case case_upcase:
  5042.             # *PRINT-CASE* abfragen. Danach richtet sich, wie Gro▀buchstaben
  5043.             # ausgegeben werden. Kleinbuchstaben werden immer klein ausgegeben.
  5044.             switch_print_case(
  5045.               # :UPCASE -> Gro▀buchstaben in Upcase ausgeben:
  5046.               { write_sstring(stream_,string); },
  5047.               # :DOWNCASE -> Gro▀buchstaben in Downcase ausgeben:
  5048.               { var reg1 uintL index = 0;
  5049.                 var reg2 uintL count;
  5050.                 pushSTACK(string); # Simple-String retten
  5051.                 dotimesL(count,TheSstring(string)->length,
  5052.                   { write_schar(stream_,down_case(TheSstring(STACK_0)->data[index]));
  5053.                     index++;
  5054.                   });
  5055.                 skipSTACK(1);
  5056.               },
  5057.               # :CAPITALIZE -> jeweils den ersten Gro▀buchstaben eines Wortes
  5058.               # als Gro▀buchstaben, alle anderen als Kleinbuchstaben ausgeben.
  5059.               # (Vgl. NSTRING_CAPITALIZE in CHARSTRG.D)
  5060.               # Erste Version:
  5061.               #   (lambda (s &aux (l (length s)))
  5062.               #     (prog ((i 0) c)
  5063.               #       1 ; Suche ab hier den nΣchsten Wortanfang
  5064.               #         (if (= i l) (return))
  5065.               #         (setq c (char s i))
  5066.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  5067.               #       ; Wortanfang gefunden
  5068.               #       (write-char c) (incf i) ; Gro▀buchstaben als Gro▀buchstaben ausgeben
  5069.               #       2 ; mitten im Wort
  5070.               #         (if (= i l) (return))
  5071.               #         (setq c (char s i))
  5072.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  5073.               #         (write-char (char-downcase c)) ; Gro▀buchstaben klein ausgeben
  5074.               #         (incf i) (go 2)
  5075.               #   ) )
  5076.               # Es werden also genau die Zeichen mit char-downcase ausgegeben, vor
  5077.               # denen ein alphanumerisches Zeichen auftrat und die selber
  5078.               # alphanumerisch sind.
  5079.               # [Da alle Uppercase-Characters (nach CLTL S. 236 oben) alphabetisch
  5080.               # und damit auch alphanumerisch sind und auf den anderen Characters
  5081.               # char-downcase nichts tut: Es werden genau die Zeichen mit
  5082.               # char-downcase ausgegeben, vor denen ein alphanumerisches Zeichen
  5083.               # auftrat. Wir benutzen dies aber nicht.]
  5084.               # Zweite Version:
  5085.               #   (lambda (s &aux (l (length s)))
  5086.               #     (prog ((i 0) c (flag nil))
  5087.               #       1 (if (= i l) (return))
  5088.               #         (setq c (char s i))
  5089.               #         (let ((newflag (alphanumericp c)))
  5090.               #           (when (and flag newflag) (setq c (char-downcase c)))
  5091.               #           (setq flag newflag)
  5092.               #         )
  5093.               #         (write-char c) (incf i) (go 1)
  5094.               #   ) )
  5095.               # Dritte Version:
  5096.               #   (lambda (s &aux (l (length s)))
  5097.               #     (prog ((i 0) c (flag nil))
  5098.               #       1 (if (= i l) (return))
  5099.               #         (setq c (char s i))
  5100.               #         (when (and (shiftf flag (alphanumericp c)) flag)
  5101.               #           (setq c (char-downcase c))
  5102.               #         )
  5103.               #         (write-char c) (incf i) (go 1)
  5104.               #   ) )
  5105.               { var reg3 boolean flag = FALSE;
  5106.                 var reg4 uintL index = 0;
  5107.                 var reg5 uintL count;
  5108.                 pushSTACK(string); # Simple-String retten
  5109.                 dotimesL(count,TheSstring(string)->length,
  5110.                   { # flag zeigt an, ob gerade innerhalb eines Wortes
  5111.                     var reg2 boolean oldflag = flag;
  5112.                     var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nΣchstes Zeichen
  5113.                     if ((flag = alphanumericp(c)) && oldflag)
  5114.                       # alphanumerisches Zeichen im Wort:
  5115.                       { c = down_case(c); } # Gro▀- in Kleinbuchstaben umwandeln
  5116.                     write_schar(stream_,c); # und ausgeben
  5117.                     index++;
  5118.                   });
  5119.                 skipSTACK(1);
  5120.               }
  5121.               );
  5122.             break;
  5123.           case case_downcase:
  5124.             # *PRINT-CASE* abfragen. Danach richtet sich, wie Kleinbuchstaben
  5125.             # ausgegeben werden. Gro▀buchstaben werden immer gro▀ ausgegeben.
  5126.             switch_print_case(
  5127.               # :UPCASE -> Kleinbuchstaben in Upcase ausgeben:
  5128.               { var reg1 uintL index = 0;
  5129.                 var reg2 uintL count;
  5130.                 pushSTACK(string); # Simple-String retten
  5131.                 dotimesL(count,TheSstring(string)->length,
  5132.                   { write_schar(stream_,up_case(TheSstring(STACK_0)->data[index]));
  5133.                     index++;
  5134.                   });
  5135.                 skipSTACK(1);
  5136.               },
  5137.               # :DOWNCASE -> Kleinbuchstaben in Downcase ausgeben:
  5138.               { write_sstring(stream_,string); },
  5139.               # :CAPITALIZE -> jeweils den ersten Kleinbuchstaben eines Wortes
  5140.               # als Gro▀buchstaben, alle anderen als Kleinbuchstaben ausgeben.
  5141.               # (Vgl. NSTRING_CAPITALIZE in CHARSTRG.D)
  5142.               # Erste Version:
  5143.               #   (lambda (s &aux (l (length s)))
  5144.               #     (prog ((i 0) c)
  5145.               #       1 ; Suche ab hier den nΣchsten Wortanfang
  5146.               #         (if (= i l) (return))
  5147.               #         (setq c (char s i))
  5148.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  5149.               #       ; Wortanfang gefunden
  5150.               #       (write-char (char-upcase c)) ; Kleinbuchstaben gro▀ ausgeben
  5151.               #       (incf i)
  5152.               #       2 ; mitten im Wort
  5153.               #         (if (= i l) (return))
  5154.               #         (setq c (char s i))
  5155.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  5156.               #         (write-char c) ; Kleinbuchstaben klein ausgeben
  5157.               #         (incf i) (go 2)
  5158.               #   ) )
  5159.               # Es werden also genau die Zeichen mit char-upcase ausgegeben, vor
  5160.               # denen kein alphanumerisches Zeichen auftrat und die aber selber
  5161.               # alphanumerisch sind.
  5162.               # Zweite Version:
  5163.               #   (lambda (s &aux (l (length s)))
  5164.               #     (prog ((i 0) c (flag nil))
  5165.               #       1 (if (= i l) (return))
  5166.               #         (setq c (char s i))
  5167.               #         (when (and (not (shiftf flag (alphanumericp c))) flag)
  5168.               #           (setq c (char-upcase c))
  5169.               #         )
  5170.               #         (write-char c) (incf i) (go 1)
  5171.               #   ) )
  5172.               { var reg3 boolean flag = FALSE;
  5173.                 var reg4 uintL index = 0;
  5174.                 var reg5 uintL count;
  5175.                 pushSTACK(string); # Simple-String retten
  5176.                 dotimesL(count,TheSstring(string)->length,
  5177.                   { # flag zeigt an, ob gerade innerhalb eines Wortes
  5178.                     var reg2 boolean oldflag = flag;
  5179.                     var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nΣchstes Zeichen
  5180.                     if ((flag = alphanumericp(c)) && !oldflag)
  5181.                       # alphanumerisches Zeichen am Wortanfang:
  5182.                       { c = up_case(c); } # Klein- in Gro▀buchstaben umwandeln
  5183.                     write_schar(stream_,c); # und ausgeben
  5184.                     index++;
  5185.                   });
  5186.                 skipSTACK(1);
  5187.               }
  5188.               );
  5189.             break;
  5190.           case case_preserve:
  5191.             # *PRINT-CASE* ignorieren.
  5192.             write_sstring(stream_,string);
  5193.             break;
  5194.           default: NOTREACHED
  5195.     }   }
  5196.  
  5197. # UP: Gibt eine Anzahl Spaces auf einen Stream aus.
  5198. # spaces(&stream,anzahl);
  5199. # > anzahl: Anzahl Spaces (Fixnum>=0)
  5200. # > stream: Stream
  5201. # < stream: Stream
  5202. # kann GC ausl÷sen
  5203.   local void spaces (object* stream_, object anzahl);
  5204.   local void spaces(stream_,anzahl)
  5205.     var reg1 object* stream_;
  5206.     var reg3 object anzahl;
  5207.     { var reg2 uintL count;
  5208.       dotimesL(count,posfixnum_to_L(anzahl), { write_schar(stream_,' '); } );
  5209.     }
  5210.  
  5211. # ------------------- Unterprogramme fⁿr Pretty-Print -------------------------
  5212.  
  5213. # Variablen:
  5214. # ==========
  5215.  
  5216. # ZeilenlΣnge L                  Wert von SYS::*PRIN-LINELENGTH*,
  5217. #                                  Fixnum>=0 oder NIL
  5218. # Zeilenposition                 im PPHELP-Stream, Fixnum>=0
  5219. # Linker Rand L1 fⁿr Einzeiler   Wert von SYS::*PRIN-L1*, Fixnum>=0
  5220. # Linker Rand LM fⁿr Mehrzeiler  Wert von SYS::*PRIN-LM*, Fixnum>=0
  5221. # Modus                          im PPHELP-Stream: NIL fⁿr Einzeiler,
  5222. #                                                  T fⁿr Mehrzeiler
  5223.   #define einzeiler NIL
  5224.   #define mehrzeiler T
  5225.  
  5226. # Komponenten eines Pretty-Print-Hilfs-Streams:
  5227. #   strm_pphelp_lpos     Line Position (Fixnum>=0)
  5228. #   strm_pphelp_strings  nichtleere Liste von Semi-Simple-Strings. Sie
  5229. #                        enthalten den bisherigen Output (in umgekehrter
  5230. #                        Reihenfolge: letzte Zeile als CAR).
  5231. #   strm_pphelp_modus    Modus: Einzeiler, falls nur 1 String vorkommt und
  5232. #                        dieser kein NL enthΣlt, sonst Mehrzeiler.
  5233. # WRITE-CHAR schiebt sein Character immer nur auf die letzte Zeile
  5234. # und aktualisiert lpos und modus.
  5235.  
  5236. # wΣhrend Justify:
  5237. # voriger Inhalt des Streams     Werte von SYS::*PRIN-JBSTRINGS*,
  5238. #                                  SYS::*PRIN-JBMODUS*, SYS::*PRIN-JBLPOS*
  5239. # bisherige Bl÷cke (Liste von Bl÷cken,
  5240. # mehrzeiliger Block = nichtleere Liste von Semi-Simple-Strings,
  5241. # einzeiliger Block = Semi-Simple-String)
  5242. #                                Wert von SYS::*PRIN-JBLOCKS*
  5243.  
  5244. # fⁿr Einhaltung von *PRINT-LEVEL*:
  5245. # SYS::*PRIN-LEVEL*              aktuelle Ausgabetiefe (Fixnum>=0)
  5246.  
  5247. # fⁿr Wiedereinlesbarkeit von Backquote-Expressions:
  5248. # SYS::*PRIN-BQLEVEL*            aktuelle Backquote-Tiefe (Fixnum>=0)
  5249.  
  5250. # wenn der Printer nach au▀en verlassen wird:
  5251. # SYS::*PRIN-STREAM*             aktueller Stream (Default: NIL),
  5252. # um ein rekursives PRINT oder WRITE zu erkennen.
  5253.  
  5254. # fⁿr Einhaltung von *PRINT-LENGTH*:
  5255. # LΣngenbegrenzung (uintL >=0 oder ~0)      lokal
  5256. # bisherige LΣnge (uintL >=0)               lokal
  5257.  
  5258. # fⁿr sch÷ne Ausgabe von Klammern:
  5259. # *PRINT-RPARS* (T oder NIL) zeigt an, ob Klammern zu in einer extra Zeile
  5260. # als "   ) ) )" ausgegeben werden sollen oder nicht.
  5261. # SYS::*PRIN-RPAR* = Position der letzten ge÷ffneten Klammer (Fixnum>=0,
  5262. #                    oder NIL falls die schlie▀ende Klammer ans Zeilenende
  5263. #                    und nicht unter die ÷ffnende Klammer soll)
  5264.  
  5265. # Unterprogramme:
  5266. # ===============
  5267.  
  5268. # Sie arbeiten auf dem Stream und sind korrekt zu schachteln,
  5269. # da sie den STACK verΣndern k÷nnen.
  5270.  
  5271. # UP: FΣngt in PPHELP-Stream A5 eine neue Zeile an.
  5272. # pphelp_newline(&stream);
  5273. # > stream: Stream
  5274. # < stream: Stream
  5275. # kann GC ausl÷sen
  5276.   local void pphelp_newline (object* stream_);
  5277.   local void pphelp_newline(stream_)
  5278.     var reg3 object* stream_;
  5279.     {  # (push (make-ssstring 50) (strm-pphelp-strings stream)) :
  5280.        pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String
  5281.      { var reg2 object new_cons = allocate_cons(); # neues Cons
  5282.        Car(new_cons) = popSTACK();
  5283.       {var reg1 object stream = *stream_;
  5284.        Cdr(new_cons) = TheStream(stream)->strm_pphelp_strings;
  5285.        TheStream(stream)->strm_pphelp_strings = new_cons;
  5286.        # Line-Position := 0, Modus := Mehrzeiler :
  5287.        TheStream(stream)->strm_pphelp_lpos = Fixnum_0;
  5288.        TheStream(stream)->strm_pphelp_modus = mehrzeiler;
  5289.     }}}
  5290.  
  5291. # Klammer auf und Klammer zu
  5292. # --------------------------
  5293. # Korrekt zu schachteln.
  5294.   #define KLAMMER_AUF  klammer_auf(stream_);
  5295.   #define KLAMMER_ZU   klammer_zu(stream_);
  5296.  
  5297. # UP: Gibt eine Klammer '(' auf den Stream aus und merkt sich eventuell
  5298. # die Position.
  5299. # klammer_auf(&stream);
  5300. # > stream: Stream
  5301. # < stream: Stream
  5302. # verΣndert STACK
  5303. # kann GC ausl÷sen
  5304.   local void klammer_auf (object* stream_);
  5305.   local void klammer_auf(stream_)
  5306.     var reg3 object* stream_;
  5307.     { var reg1 object stream = *stream_;
  5308.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5309.         # normaler Stream
  5310.         { write_schar(stream_,'('); }
  5311.         else
  5312.         # Pretty-Print-Hilfs-Stream
  5313.         { var reg2 object pos = # Position fⁿr die Klammer zu
  5314.             (test_value(S(print_rpars)) # *PRINT-RPARS* /= NIL ?
  5315.               ? TheStream(stream)->strm_pphelp_lpos # ja -> aktuelle Position (Fixnum>=0)
  5316.               : NIL                                 # nein -> NIL
  5317.             );
  5318.           dynamic_bind(S(prin_rpar),pos); # SYS::*PRIN-RPAR* daran binden
  5319.           write_schar(stream_,'(');
  5320.         }
  5321.     }
  5322.  
  5323. # UP: Gibt eine Klammer ')' auf den Stream aus, evtl. an der gemerkten
  5324. # Position.
  5325. # klammer_zu(&stream);
  5326. # > stream: Stream
  5327. # < stream: Stream
  5328. # verΣndert STACK
  5329. # kann GC ausl÷sen
  5330.   local void klammer_zu (object* stream_);
  5331.   local void klammer_zu(stream_)
  5332.     var reg10 object* stream_;
  5333.     { var reg4 object stream = *stream_;
  5334.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5335.         # normaler Stream
  5336.         { write_schar(stream_,')'); }
  5337.         else
  5338.         # Pretty-Print-Hilfs-Stream
  5339.         { # gewⁿnschte Position der Klammer zu holen:
  5340.           var reg9 object pos = Symbol_value(S(prin_rpar)); # SYS::*PRIN-RPAR*
  5341.           if (nullp(pos)) goto hinten; # keine -> Klammer hinten ausgeben
  5342.           # Klammer an Position pos ausgeben:
  5343.           if (eq(TheStream(stream)->strm_pphelp_modus,mehrzeiler)
  5344.               && !nullp(Cdr(TheStream(stream)->strm_pphelp_strings))
  5345.              )
  5346.             # Mehrzeiler mit mehr als einer Zeile ("echter" Mehrzeiler)
  5347.             {  # Klammer an die gewⁿnschte Position ausgeben.
  5348.                # Dazu Test, ob die letzte Zeile im Stream
  5349.                # 1. bis zur gewⁿnschten Position (einschlie▀lich) nur Spaces
  5350.                # und
  5351.                # 2. sonst nur Spaces und ')' enthΣlt.
  5352.                # Wenn ja, Klammer an die gewⁿnschte Position setzen.
  5353.                # Wenn nein, neue Zeile anfangen, Spaces und die Klammer ausgeben.
  5354.                var reg8 object lastline = # letzte Zeile
  5355.                  Car(TheStream(stream)->strm_pphelp_strings);
  5356.                var reg7 uintL len = TheArray(lastline)->dims[1]; # LΣnge = Fill-Pointer der Zeile
  5357.                var reg6 uintL need = posfixnum_to_L(pos) + 1; # n÷tige Anzahl Spaces
  5358.                if (len < need) # Zeile zu kurz ?
  5359.                  goto new_line; # ja -> neue Zeile anfangen
  5360.                lastline = TheArray(lastline)->data; # letzte Zeile, Simple-String
  5361.              { var reg2 uintB* charptr = &TheSstring(lastline)->data[0];
  5362.                # Teste, ob need Spaces kommen:
  5363.                {var reg3 uintL count;
  5364.                 dotimesL(count,need,
  5365.                   { if (!(*charptr++ == ' ')) # Space ?
  5366.                       goto new_line; # nein -> neue Zeile anfangen
  5367.                   });
  5368.                }
  5369.               {var reg5 uintB* charptr1 = charptr; # Position merken
  5370.                # Teste, ob len-need mal Space oder ')' kommt:
  5371.                {var reg3 uintL count;
  5372.                 dotimesL(count,len-need,
  5373.                   { var reg1 uintB c = *charptr++;
  5374.                     if (!((c == ' ') || (c == ')'))) # Space oder ')' ?
  5375.                       goto new_line; # nein -> neue Zeile anfangen
  5376.                   });
  5377.                }
  5378.                # Klammer an die gewⁿnschte Position pos = need-1 setzen:
  5379.                *--charptr1 = ')';
  5380.             }}}
  5381.             else
  5382.             # Einzeiler.
  5383.             { # Klammer mu▀ wohl hinten ausgegeben werden.
  5384.               # Ausnahme: Wenn Line-Position = SYS::*PRIN-LINELENGTH* ist,
  5385.               #           wⁿrde ⁿber die Zeile hinausgeschrieben;
  5386.               #           stattdessen wird eine neue Zeile angefangen.
  5387.               if (eq(Symbol_value(S(prin_linelength)), # Wert von SYS::*PRIN-LINELENGTH*
  5388.                      TheStream(stream)->strm_pphelp_lpos # = Line-Position ?
  5389.                  )  )
  5390.                 { new_line: # neue Zeile anfangen
  5391.                   pphelp_newline(stream_); spaces(stream_,pos);
  5392.                 }
  5393.               hinten: # Klammer hinten ausgeben
  5394.               write_schar(stream_,')');
  5395.             }
  5396.           # Bindung von SYS::*PRIN-RPAR* aufl÷sen:
  5397.           dynamic_unbind();
  5398.     }   }
  5399.  
  5400. # Justify
  5401. # -------
  5402. # Korrekt zu schachteln,
  5403. # jeweils 1 mal JUSTIFY_START,
  5404. # dann beliebige Ausgaben, durch JUSTIFY_SPACE getrennt,
  5405. # dann 1 mal entweder
  5406. #     JUSTIFY_END_ENG (fa▀t auch in Mehrzeilern kurze Bl÷cke in eine Zeile)
  5407. #     oder
  5408. #     JUSTIFY_END_WEIT (in Mehrzeilern belegt jeder Block eine eigene Zeile).
  5409.   #define JUSTIFY_START     justify_start(stream_);
  5410.   #define JUSTIFY_SPACE     justify_space(stream_);
  5411.   #define JUSTIFY_END_ENG   justify_end_eng(stream_);
  5412.   #define JUSTIFY_END_WEIT  justify_end_weit(stream_);
  5413.  
  5414. # UP: Leert einen Pretty-Print-Hilfsstream.
  5415. # justify_empty_1(&stream);
  5416. # > stream: Stream
  5417. # < stream: Stream
  5418. # kann GC ausl÷sen
  5419.   local void justify_empty_1 (object* stream_);
  5420.   local void justify_empty_1(stream_)
  5421.     var reg3 object* stream_;
  5422.     {  pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String
  5423.      { var reg2 object new_cons = allocate_cons(); # neues Cons
  5424.        Car(new_cons) = popSTACK();
  5425.        # new_cons = (list (make-ssstring 50))
  5426.       {var reg1 object stream = *stream_;
  5427.        TheStream(stream)->strm_pphelp_strings = new_cons; # neue, leere Zeile
  5428.        TheStream(stream)->strm_pphelp_modus = einzeiler; # Modus := Einzeiler
  5429.     }}}
  5430.  
  5431. # UP: Beginnt einen Justify-Block.
  5432. # justify_start(&stream);
  5433. # > stream: Stream
  5434. # < stream: Stream
  5435. # verΣndert STACK
  5436.   local void justify_start (object* stream_);
  5437.   local void justify_start(stream_)
  5438.     var reg2 object* stream_;
  5439.     { var reg1 object stream = *stream_;
  5440.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5441.         {} # normaler Stream -> nichts zu tun
  5442.         else
  5443.         # Pretty-Print-Hilfs-Stream
  5444.         { # SYS::*PRIN-JBSTRINGS* an den Inhalt des Streams binden:
  5445.           dynamic_bind(S(prin_jbstrings),TheStream(stream)->strm_pphelp_strings);
  5446.           # SYS::*PRIN-JBMODUS* an den Modus des Streams binden:
  5447.           dynamic_bind(S(prin_jbmodus),TheStream(stream)->strm_pphelp_modus);
  5448.           # SYS::*PRIN-JBLPOS* an die Line-Position des Streams binden:
  5449.           dynamic_bind(S(prin_jblpos),TheStream(stream)->strm_pphelp_lpos);
  5450.           # SYS::*PRIN-JBLOCKS* an () binden:
  5451.           dynamic_bind(S(prin_jblocks),NIL);
  5452.           # Stream leeren:
  5453.           justify_empty_1(stream_);
  5454.         }
  5455.     }
  5456.  
  5457. # UP: Leert Inhalt eines Pretty-Print-Hilfsstream aus in die Variable
  5458. # SYS::*PRIN-JBLOCKS*.
  5459. # justify_empty_2(&stream);
  5460. # > stream: Stream
  5461. # < stream: Stream
  5462. # kann GC ausl÷sen
  5463.   local void justify_empty_2 (object* stream_);
  5464.   local void justify_empty_2(stream_)
  5465.     var reg3 object* stream_;
  5466.     { var reg1 object stream = *stream_;
  5467.       var reg2 object new_cons;
  5468.       # SYS::*PRIN-JBLOCKS* um den Inhalt des Streams erweitern:
  5469.       if (eq(TheStream(stream)->strm_pphelp_modus,mehrzeiler))
  5470.         # Mehrzeiler.
  5471.         { # (push strings SYS::*PRIN-JBLOCKS*)
  5472.           new_cons = allocate_cons(); # neues Cons
  5473.           Car(new_cons) = TheStream(*stream_)->strm_pphelp_strings;
  5474.         }
  5475.         else
  5476.         # Einzeiler.
  5477.         { # (push (first strings) SYS::*PRIN-JBLOCKS*), oder kⁿrzer:
  5478.           # (setq SYS::*PRIN-JBLOCKS* (rplacd strings SYS::*PRIN-JBLOCKS*))
  5479.           new_cons = TheStream(stream)->strm_pphelp_strings;
  5480.         }
  5481.       Cdr(new_cons) = Symbol_value(S(prin_jblocks));
  5482.       Symbol_value(S(prin_jblocks)) = new_cons;
  5483.     }
  5484.  
  5485. # UP: Gibt einen Zwischenraum aus, der bei Justify gedehnt werden kann.
  5486. # justify_space(&stream);
  5487. # > stream: Stream
  5488. # < stream: Stream
  5489. # kann GC ausl÷sen
  5490.   local void justify_space (object* stream_);
  5491.   local void justify_space(stream_)
  5492.     var reg1 object* stream_;
  5493.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5494.         # normaler Stream -> nur ein Space
  5495.         { write_schar(stream_,' '); }
  5496.         else
  5497.         # Pretty-Print-Hilfs-Stream
  5498.         { justify_empty_2(stream_); # Streaminhalt retten
  5499.           justify_empty_1(stream_); # Stream leeren
  5500.           # Line-Position := SYS::*PRIN-LM* (Fixnum>=0)
  5501.           TheStream(*stream_)->strm_pphelp_lpos = Symbol_value(S(prin_lm));
  5502.         }
  5503.     }
  5504.  
  5505. # UP: Beendet einen Justify-Block, bestimmt die Gestalt des Blockes und
  5506. # gibt seinen Inhalt auf den alten Stream aus.
  5507. # justify_end_eng(&stream);
  5508. # > stream: Stream
  5509. # < stream: Stream
  5510. # kann GC ausl÷sen
  5511.   local void justify_end_eng (object* stream_);
  5512.   local void justify_end_eng(stream_)
  5513.     var reg2 object* stream_;
  5514.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5515.         {} # normaler Stream -> nichts zu tun
  5516.         else
  5517.         # Pretty-Print-Hilfs-Stream
  5518.         { justify_empty_2(stream_); # Streaminhalt retten
  5519.           # Streaminhalt restaurieren, d.h. Werte von SYS::*PRIN-JBSTRINGS*,
  5520.           # SYS::*PRIN-JBMODUS*, SYS::*PRIN-JBLPOS* in den Stream zurⁿck:
  5521.          {var reg1 object stream = *stream_;
  5522.           # jetzige Line-Position retten:
  5523.           pushSTACK(TheStream(stream)->strm_pphelp_lpos);
  5524.           # alten Streaminhalt wiederherstellen:
  5525.           TheStream(stream)->strm_pphelp_strings = Symbol_value(S(prin_jbstrings));
  5526.           TheStream(stream)->strm_pphelp_modus = Symbol_value(S(prin_jbmodus));
  5527.           TheStream(stream)->strm_pphelp_lpos = Symbol_value(S(prin_jblpos));
  5528.           # (nichtleere) Liste von Bl÷cken auf den Stream ausgeben:
  5529.           pushSTACK(nreverse(Symbol_value(S(prin_jblocks)))); # (nreverse SYS::*PRIN-JBLOCKS*)
  5530.           # Die Bl÷cke werden einzeln ausgegeben. Mehrzeiler werden
  5531.           # voneinander und von den Einzeilern durch Newline getrennt.
  5532.           # Es werden jedoch m÷glichst viele aufeinanderfolgende Einzeiler
  5533.           # (durch Space getrennt) in eine Zeile gepackt.
  5534.           loop # Blockliste STACK_0 durchlaufen:
  5535.             { var reg3 object block = Car(STACK_0); # nΣchster Block
  5536.               STACK_0 = Cdr(STACK_0); # Blockliste verkⁿrzen
  5537.               if (consp(block))
  5538.                 # Mehrzeiliger Teilblock
  5539.                 { # Zeilen in die richtige Reihenfolge bringen:
  5540.                   block = nreverse(block);
  5541.                   # erste Zeile auf den PPHELP-Stream ausgeben:
  5542.                   pushSTACK(block);
  5543.                   write_string(stream_,Car(block));
  5544.                   block = popSTACK();
  5545.                   # restliche Zeilen an die Zeilen im Stream vorne dranhΣngen:
  5546.                   stream = *stream_;
  5547.                   TheStream(stream)->strm_pphelp_strings =
  5548.                     nreconc(Cdr(block),TheStream(stream)->strm_pphelp_strings);
  5549.                   # Modus := Mehrzeiler:
  5550.                   TheStream(stream)->strm_pphelp_modus = mehrzeiler;
  5551.                   if (matomp(STACK_0)) # Restliste leer?
  5552.                     # ja -> Line-Position zurⁿck, fertig
  5553.                     { TheStream(stream)->strm_pphelp_lpos = STACK_1;
  5554.                       break;
  5555.                     }
  5556.                   # neue Zeile anfangen und weiter:
  5557.                   goto new_line;
  5558.                 }
  5559.                 else
  5560.                 # Einzeiliger Teilblock
  5561.                 { # auf den PPHELP-Stream ausgeben:
  5562.                   write_string(stream_,block);
  5563.                   if (matomp(STACK_0)) # Restliste leer?
  5564.                     break; # ja -> fertig
  5565.                   # nΣchster Block ein Mehrzeiler?
  5566.                   block = Car(STACK_0); # nΣchster Block
  5567.                   if (atomp(block)) # ein Mehrzeiler oder Einzeiler?
  5568.                     # Es ist ein Einzeiler.
  5569.                     # Pa▀t er noch auf dieselbe Zeile,
  5570.                     # d.h. ist  Line-Position + 1 + length(Einzeiler) <= L ?
  5571.                     { var reg4 object linelength = Symbol_value(S(prin_linelength)); # L = SYS::*PRIN-LINELENGTH*
  5572.                       if (nullp(linelength) # =NIL -> pa▀t
  5573.                           || (posfixnum_to_L(TheStream(*stream_)->strm_pphelp_lpos) # Line-Position
  5574.                               + TheArray(block)->dims[1] # LΣnge = Fill-Pointer des Einzeilers
  5575.                               < posfixnum_to_L(linelength) # < linelength ?
  5576.                          )   )
  5577.                         # Pa▀t noch.
  5578.                         { # Space statt Newline ausgeben:
  5579.                           write_schar(stream_,' ');
  5580.                         }
  5581.                         else
  5582.                         # Pa▀t nicht mehr.
  5583.                         goto new_line;
  5584.                     }
  5585.                     else
  5586.                     # Mehrzeiler -> neue Zeile und weiter
  5587.                     { new_line: # neue Zeile anfangen
  5588.                       pphelp_newline(stream_); # neue Zeile, dabei Modus:=Mehrzeiler
  5589.                       spaces(stream_,Symbol_value(S(prin_lm))); # SYS::*PRIN-LM* Spaces
  5590.                     }
  5591.                 }
  5592.             }
  5593.           skipSTACK(2); # leere Restliste und alte Line-Position vergessen
  5594.           # Bindungen von JUSTIFY_START rⁿckgΣngig machen:
  5595.           dynamic_unbind();
  5596.           dynamic_unbind();
  5597.           dynamic_unbind();
  5598.           dynamic_unbind();
  5599.         }}
  5600.     }
  5601.  
  5602. # UP: Beendet einen Justify-Block, bestimmt die Gestalt des Blockes und
  5603. # gibt seinen Inhalt auf den alten Stream aus.
  5604. # justify_end_weit(&stream);
  5605. # > stream: Stream
  5606. # < stream: Stream
  5607. # kann GC ausl÷sen
  5608.   local void justify_end_weit (object* stream_);
  5609.   local void justify_end_weit(stream_)
  5610.     var reg2 object* stream_;
  5611.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5612.         {} # normaler Stream -> nichts zu tun
  5613.         else
  5614.         # Pretty-Print-Hilfs-Stream
  5615.         { justify_empty_2(stream_); # Streaminhalt retten
  5616.           # Streaminhalt restaurieren, d.h. Werte von SYS::*PRIN-JBSTRINGS*,
  5617.           # SYS::*PRIN-JBMODUS*, SYS::*PRIN-JBLPOS* in den Stream zurⁿck:
  5618.          {var reg1 object stream = *stream_;
  5619.           # jetzige Line-Position retten:
  5620.           pushSTACK(TheStream(stream)->strm_pphelp_lpos);
  5621.           # alten Streaminhalt wiederherstellen:
  5622.           TheStream(stream)->strm_pphelp_strings = Symbol_value(S(prin_jbstrings));
  5623.           TheStream(stream)->strm_pphelp_modus = Symbol_value(S(prin_jbmodus));
  5624.           TheStream(stream)->strm_pphelp_lpos = Symbol_value(S(prin_jblpos));
  5625.           # Prⁿfe, ob die Bl÷cke in SYS::*PRIN-JBLOCKS* alle Einzeiler sind:
  5626.           {var reg3 object blocks = Symbol_value(S(prin_jblocks)); # SYS::*PRIN-JBLOCKS*
  5627.            do # (nichtleere) Blockliste durchgehen:
  5628.               { if (mconsp(Car(blocks))) # ein Teilblock Mehrzeiler ?
  5629.                   goto gesamt_mehrzeiler; # ja -> insgesamt ein Mehrzeiler
  5630.                 blocks = Cdr(blocks);
  5631.               }
  5632.               while (consp(blocks));
  5633.           }
  5634.           # Prⁿfe, ob die Bl÷cke in SYS::*PRIN-JBLOCKS*
  5635.           # (jeder Block Einzeiler) zusammen einen Einzeiler ergeben k÷nnen:
  5636.           # Ist L=NIL (keine RandbeschrΣnkung) oder
  5637.           # L1 + (GesamtlΣnge der Bl÷cke) + (Anzahl der Bl÷cke-1) <= L ?
  5638.           { var reg5 object linelength = Symbol_value(S(prin_linelength)); # L = SYS::*PRIN-LINELENGTH*
  5639.             if (nullp(linelength)) goto gesamt_einzeiler; # =NIL -> Einzeiler
  5640.            {var reg4 uintL totalneed = posfixnum_to_L(Symbol_value(S(prin_l1))); # Summe := L1 = SYS::*PRIN-L1*
  5641.             var reg3 object blocks = Symbol_value(S(prin_jblocks)); # SYS::*PRIN-JBLOCKS*
  5642.             do # (nichtleere) Blockliste durchgehen:
  5643.                { var reg1 object block = Car(blocks); # Block (Einzeiler)
  5644.                  totalneed += TheArray(block)->dims[1] + 1; # dessen LΣnge+1 dazu
  5645.                  blocks = Cdr(blocks);
  5646.                }
  5647.                while (consp(blocks));
  5648.             # totalneed = L1 + (GesamtlΣnge der Bl÷cke) + (Anzahl der Bl÷cke)
  5649.             # Vergleiche dies mit linelength + 1 :
  5650.             if (totalneed <= posfixnum_to_L(linelength)+1)
  5651.               { goto gesamt_einzeiler; }
  5652.               else
  5653.               { goto gesamt_mehrzeiler; }
  5654.           }}
  5655.           gesamt_einzeiler: # Insgesamt ein Einzeiler.
  5656.           # Bl÷cke einzeln, durch Spaces getrennt, auf den Stream ausgeben:
  5657.           { pushSTACK(nreverse(Symbol_value(S(prin_jblocks)))); # (nreverse SYS::*PRIN-JBLOCKS*)
  5658.             loop # (nichtleere) Blockliste STACK_0 durchlaufen:
  5659.               { var reg3 object block = Car(STACK_0); # nΣchster Block
  5660.                 # (ein Einzeiler, String ohne #\Newline)
  5661.                 STACK_0 = Cdr(STACK_0); # Blockliste verkⁿrzen
  5662.                 write_string(stream_,block); # Block auf den Stream ausgeben
  5663.                 if (matomp(STACK_0)) break; # Restliste leer -> fertig
  5664.                 write_schar(stream_,' '); # #\Space ausgeben
  5665.               }
  5666.             goto fertig;
  5667.           }
  5668.           gesamt_mehrzeiler: # Insgesamt ein Mehrzeiler.
  5669.           # Bl÷cke einzeln, durch Newline getrennt, auf den Stream ausgeben:
  5670.           { pushSTACK(nreverse(Symbol_value(S(prin_jblocks)))); # (nreverse SYS::*PRIN-JBLOCKS*)
  5671.             loop # (nichtleere) Blockliste STACK_0 durchlaufen:
  5672.               { var reg3 object block = Car(STACK_0); # nΣchster Block
  5673.                 STACK_0 = Cdr(STACK_0); # Blockliste verkⁿrzen
  5674.                 if (consp(block))
  5675.                   # Mehrzeiliger Teilblock
  5676.                   { # Zeilen in die richtige Reihenfolge bringen:
  5677.                     block = nreverse(block);
  5678.                     # erste Zeile auf den PPHELP-Stream ausgeben:
  5679.                     pushSTACK(block);
  5680.                     write_string(stream_,Car(block));
  5681.                     block = popSTACK();
  5682.                     # restliche Zeilen an die Zeilen im Stream vorne dranhΣngen:
  5683.                     stream = *stream_;
  5684.                     TheStream(stream)->strm_pphelp_strings =
  5685.                       nreconc(Cdr(block),TheStream(stream)->strm_pphelp_strings);
  5686.                   }
  5687.                   else
  5688.                   # Einzeiliger Teilblock
  5689.                   { # auf den PPHELP-Stream ausgeben:
  5690.                     write_string(stream_,block);
  5691.                   }
  5692.                 if (matomp(STACK_0)) break; # Restliste leer?
  5693.                 pphelp_newline(stream_); # neue Zeile anfangen
  5694.                 spaces(stream_,Symbol_value(S(prin_lm))); # SYS::*PRIN-LM* Spaces
  5695.               }
  5696.             stream = *stream_;
  5697.             # Line-Position zurⁿck:
  5698.             TheStream(stream)->strm_pphelp_lpos = STACK_1;
  5699.             # GesamtModus := Mehrzeiler:
  5700.             TheStream(stream)->strm_pphelp_modus = mehrzeiler;
  5701.             goto fertig;
  5702.           }
  5703.           fertig: # Line-Position stimmt nun.
  5704.           skipSTACK(2); # leere Restliste und alte Line-Position vergessen
  5705.           # Bindungen von JUSTIFY_START rⁿckgΣngig machen:
  5706.           dynamic_unbind();
  5707.           dynamic_unbind();
  5708.           dynamic_unbind();
  5709.           dynamic_unbind();
  5710.         }}
  5711.     }
  5712.  
  5713. # Indent
  5714. # ------
  5715. # Korrekt zu schachteln, jeweils 1 mal INDENT_START und 1 mal INDENT_END.
  5716.   #define INDENT_START(delta)  indent_start(stream_,delta);
  5717.   #define INDENT_END           indent_end(stream_);
  5718.  
  5719. # UP: Bindet die linken RΣnder SYS::*PRIN-L1* und SYS::*PRIN-LM* an um
  5720. # delta h÷here Werte.
  5721. # indent_start(&stream,delta);
  5722. # > delta: Einrⁿckungswert
  5723. # > stream: Stream
  5724. # < stream: Stream
  5725. # verΣndert STACK
  5726.   local void indent_start (object* stream_, uintL delta);
  5727.   local void indent_start(stream_,delta)
  5728.     var reg1 object* stream_;
  5729.     var reg2 uintL delta;
  5730.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5731.         {} # normaler Stream -> nichts zu tun
  5732.         else
  5733.         # Pretty-Print-Hilfs-Stream
  5734.         { # SYS::*PRIN-L1* binden:
  5735.           {var reg3 object new_L1 = fixnum_inc(Symbol_value(S(prin_l1)),delta);
  5736.            dynamic_bind(S(prin_l1),new_L1);
  5737.           }
  5738.           # SYS::*PRIN-LM* binden:
  5739.           {var reg3 object new_LM = fixnum_inc(Symbol_value(S(prin_lm)),delta);
  5740.            dynamic_bind(S(prin_lm),new_LM);
  5741.           }
  5742.     }   }
  5743.  
  5744. # UP: Beendet einen Indent-Block.
  5745. # indent_end(&stream);
  5746. # > stream: Stream
  5747. # < stream: Stream
  5748. # verΣndert STACK
  5749.   local void indent_end (object* stream_);
  5750.   local void indent_end(stream_)
  5751.     var reg1 object* stream_;
  5752.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5753.         {} # normaler Stream -> nichts zu tun
  5754.         else
  5755.         # Pretty-Print-Hilfs-Stream
  5756.         { # die beiden Bindungen von INDENT_START aufl÷sen:
  5757.           dynamic_unbind();
  5758.           dynamic_unbind();
  5759.     }   }
  5760.  
  5761. # Indent Preparation
  5762. # ------------------
  5763. # Dient dazu, um eine variable Zeichenzahl einzurⁿcken.
  5764. # Korrekt zu schachteln,
  5765. #   erst 1 mal INDENTPREP_START,
  5766. #   dann einige Zeichen (kein #\Newline!)
  5767. #   und dann 1 mal INDENTPREP_END.
  5768. # Danach kann sofort mit INDENT_START fortgefahren werden.
  5769.   #define INDENTPREP_START  indentprep_start(stream_);
  5770.   #define INDENTPREP_END    indentprep_end(stream_);
  5771.  
  5772. # UP: Merkt sich die augenblickliche Position.
  5773. # indentprep_start(&stream);
  5774. # > stream: Stream
  5775. # < stream: Stream
  5776. # verΣndert STACK
  5777.   local void indentprep_start (object* stream_);
  5778.   local void indentprep_start(stream_)
  5779.     var reg2 object* stream_;
  5780.     { var reg1 object stream = *stream_;
  5781.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5782.         {} # normaler Stream -> nichts zu tun
  5783.         else
  5784.         # Pretty-Print-Hilfs-Stream
  5785.         { # Line-Position merken:
  5786.           pushSTACK(TheStream(stream)->strm_pphelp_lpos);
  5787.     }   }
  5788.  
  5789. # UP: Subtrahiert die Positionen, liefert die Einrⁿckungsbreite.
  5790. # indentprep_end(&stream)
  5791. # > stream: Stream
  5792. # < stream: Stream
  5793. # < ergebnis: Einrⁿckungsbreite
  5794. # verΣndert STACK
  5795.   local uintL indentprep_end (object* stream_);
  5796.   local uintL indentprep_end(stream_)
  5797.     var reg2 object* stream_;
  5798.     { var reg1 object stream = *stream_;
  5799.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5800.         { return 0; } # normaler Stream -> nichts zu tun
  5801.         else
  5802.         # Pretty-Print-Hilfs-Stream
  5803.         { var reg3 uintL lpos_now = # jetzige Line-Position
  5804.             posfixnum_to_L(TheStream(stream)->strm_pphelp_lpos);
  5805.           var reg4 uintL lpos_before = # gemerkte Line-Position
  5806.             posfixnum_to_L(popSTACK());
  5807.           return (lpos_now>=lpos_before ? lpos_now-lpos_before : 0);
  5808.     }   }
  5809.  
  5810. # Level
  5811. # -----
  5812. # Korrekt zu schachteln,
  5813. # jeweils 1 mal LEVEL_CHECK am Anfang einer pr_xxx-Routine
  5814. #     und 1 mal LEVEL_END am Ende.
  5815.   #define LEVEL_CHECK  { if (level_check(stream_)) return; }
  5816.   #define LEVEL_END    level_end(stream_);
  5817.  
  5818. # UP: Gibt die Darstellung eines LISP-Objektes bei ▄berschreitung von
  5819. # *PRINT-LEVEL* aus.
  5820. # pr_level(&stream);
  5821. # > stream: Stream
  5822. # < stream: Stream
  5823. # kann GC ausl÷sen
  5824.   local void pr_level (object* stream_);
  5825.   local void pr_level(stream_)
  5826.     var reg1 object* stream_;
  5827.     { write_schar(stream_,'#'); }
  5828.  
  5829. # UP: Testet, ob SYS::*PRIN-LEVEL* den Wert von *PRINT-LEVEL* erreicht hat.
  5830. # Wenn ja, nur '#' ausgeben und Rⁿcksprung aus dem aufrufenden UP (!).
  5831. # Wenn nein, wird SYS::*PRIN-LEVEL* incrementiert gebunden.
  5832. # if (level_check(&stream)) return;
  5833. # > stream: Stream
  5834. # < stream: Stream
  5835. # Wenn ja: kann GC ausl÷sen
  5836. # Wenn nein: verΣndert STACK
  5837.   local boolean level_check (object* stream_);
  5838.   local boolean level_check(stream_)
  5839.     var reg3 object* stream_;
  5840.     { var reg2 object level = Symbol_value(S(prin_level)); # SYS::*PRIN-LEVEL*, ein Fixnum >=0
  5841.       var reg1 object limit = Symbol_value(S(print_level)); # *PRINT-LEVEL*
  5842.       if (!test_value(S(print_readably))
  5843.           && posfixnump(limit) # BeschrΣnkung vorhanden?
  5844.           && (posfixnum_to_L(level) >= posfixnum_to_L(limit)) # und erreicht oder ⁿberschritten?
  5845.          )
  5846.         # ja -> '#' ausgeben und herausspringen:
  5847.         { pr_level(stream_); return TRUE; }
  5848.         else
  5849.         # nein -> *PRINT-LEVEL* noch unerreicht.
  5850.         { # binde SYS::*PRIN-LEVEL* an (1+ SYS::*PRIN-LEVEL*) :
  5851.           level = fixnum_inc(level,1); # (incf level)
  5852.           dynamic_bind(S(prin_level),level);
  5853.           return FALSE;
  5854.     }   }
  5855.  
  5856. # UP: Beendet einen Block mit erh÷htem SYS::*PRIN-LEVEL*.
  5857. # level_end(&stream);
  5858. # > stream: Stream
  5859. # < stream: Stream
  5860. # verΣndert STACK
  5861.   local void level_end (object* stream_);
  5862.   local void level_end(stream_)
  5863.     var reg1 object* stream_;
  5864.     { dynamic_unbind(); }
  5865.  
  5866. # Length
  5867. # ------
  5868.  
  5869. # UP: Liefert die LΣngengrenze fⁿr strukturierte Objekte wie z.B. Listen.
  5870. # get_print_length()
  5871. # < ergebnis: LΣngengrenze
  5872.   local uintL get_print_length (void);
  5873.   local uintL get_print_length()
  5874.     { var reg1 object limit = Symbol_value(S(print_length)); # *PRINT-LENGTH*
  5875.       return (!test_value(S(print_readably))
  5876.               && posfixnump(limit) # ein Fixnum >=0 ?
  5877.               ? posfixnum_to_L(limit) # ja
  5878.               : ~(uintL)0             # nein -> Grenze "unendlich"
  5879.              );
  5880.     }
  5881.  
  5882.  
  5883. # ------------------------ Haupt-PRINT-Routine --------------------------------
  5884.  
  5885. # UP: Stellt fest, ob ein Objekt wegen *PRINT-CIRCLE* in #n= oder #n# -
  5886. # Schreibweise ausgegeben werden mu▀.
  5887. # circle_p(obj)
  5888. # > obj: Objekt
  5889. # < ergebnis: NULL, falls obj normal auszugeben ist
  5890. #      sonst: ergebnis->flag: TRUE, falls obj als #n=... auszugeben ist
  5891. #                             FALSE, falls obj als #n# auszugeben ist
  5892. #             ergebnis->n: n
  5893. #             ergebnis->ptr: Im Fall #n=... ist vor der Ausgabe
  5894. #                            das Fixnum *ptr zu incrementieren.
  5895.   typedef struct { boolean flag; uintL n; object* ptr; }  circle_info;
  5896.   local circle_info* circle_p (object obj);
  5897.   local circle_info* circle_p(obj)
  5898.     var reg3 object obj;
  5899.     { # *PRINT-CIRCLE* abfragen:
  5900.       if (test_value(S(print_circle)))
  5901.         { var reg5 object table = Symbol_value(S(print_circle_table)); # SYS::*PRINT-CIRCLE-TABLE*
  5902.           if (!simple_vector_p(table)) # sollte ein Simple-Vector sein !
  5903.             { bad_table:
  5904.               dynamic_bind(S(print_circle),NIL); # *PRINT-CIRCLE* an NIL binden
  5905.               pushSTACK(S(print_circle_table)); # SYS::*PRINT-CIRCLE-TABLE*
  5906.               pushSTACK(S(print));
  5907.               fehler(error,
  5908.                      DEUTSCH ? "~: Der Wert von ~ wurde von au▀en verΣndert." :
  5909.                      ENGLISH ? "~: the value of ~ has been arbitrarily altered" :
  5910.                      FRANCAIS ? "~ : La valeur de ~ fut modifiΘe extΘrieurement." :
  5911.                      ""
  5912.                     );
  5913.             }
  5914.           # Durch den Vektor table = #(i ...) mit m+1 (0<=i<=m) Elementen
  5915.           # durchlaufen:
  5916.           # Kommt obj unter den Elementen 1,...,i vor -> Fall FALSE, n:=Index.
  5917.           # Kommt obj unter den Elementen i+1,...,m vor -> bringe
  5918.           #   obj an die Stelle i+1, Fall TRUE, n:=i+1, nachher i:=i+1.
  5919.           # Sonst Fall NULL.
  5920.           { local circle_info info; # Platz fⁿr die Rⁿckgabe der Werte
  5921.             var reg4 uintL m1 = TheSvector(table)->length; # LΣnge m+1
  5922.             if (m1==0) goto bad_table; # sollte >0 sein!
  5923.            {var reg1 object* ptr = &TheSvector(table)->data[0]; # Pointer in den Vektor
  5924.             var reg6 uintL i = posfixnum_to_L(*ptr++); # erstes Element i
  5925.             var reg2 uintL index = 1;
  5926.             until (index == m1) # Schleife m mal durchlaufen
  5927.               { if (eq(*ptr++,obj)) # obj mit nΣchstem Vektor-Element vergleichen
  5928.                   goto found;
  5929.                 index++;
  5930.               }
  5931.             # nicht gefunden -> fertig
  5932.             goto normal;
  5933.             found: # obj als Vektor-Element index gefunden, 1 <= index <= m,
  5934.                    # ptr = &TheSvector(table)->data[index+1] .
  5935.             if (index <= i)
  5936.               # obj ist als #n# auszugeben, n=index.
  5937.               { info.flag = FALSE; info.n = index; return &info; }
  5938.               else
  5939.               # obj an Position i+1 bringen:
  5940.               { i = i+1;
  5941.                 # (rotatef (svref Vektor i) (svref Vektor index)) :
  5942.                 { var reg7 object* ptr_i = &TheSvector(table)->data[i];
  5943.                   *--ptr = *ptr_i; *ptr_i = obj;
  5944.                 }
  5945.                 # obj ist als #n=... auszugeben, n=i.
  5946.                 info.flag = TRUE; info.n = i;
  5947.                 info.ptr = &TheSvector(table)->data[0]; # nachher i im Vektor erh÷hen
  5948.                 return &info;
  5949.               }
  5950.         } }}
  5951.       normal: # obj ist normal auszugeben
  5952.         return (circle_info*)NULL;
  5953.     }
  5954.  
  5955. # Eine pr_xxx-Routine bekommt &stream und obj ⁿbergeben:
  5956.   typedef void pr_routine (object* stream_, object obj);
  5957.  
  5958. # UP: ▄berprⁿft, ob ein Objekt eine ZirkularitΣt ist, und gibt es in
  5959. # diesem Falle als #n# oder mit #n=-PrΣfix (und sonst normal) aus.
  5960. # pr_circle(&stream,obj,&pr_xxx);
  5961. # > obj: Objekt
  5962. # > pr_xxx: Ausgabe-Routine, die &stream und obj ⁿbergeben bekommt
  5963. # > stream: Stream
  5964. # < stream: Stream
  5965. # kann GC ausl÷sen
  5966.   local void pr_circle (object* stream_, object obj, pr_routine* pr_xxx);
  5967.   local void pr_circle(stream_,obj,pr_xxx)
  5968.     var reg1 object* stream_;
  5969.     var reg3 object obj;
  5970.     var reg4 pr_routine* pr_xxx;
  5971.     { # Feststellen, ob ZirkularitΣt:
  5972.       var reg2 circle_info* info = circle_p(obj);
  5973.       if (info == (circle_info*)NULL)
  5974.         # keine ZirkularitΣt, obj normal ausgeben:
  5975.         { (*pr_xxx)(stream_,obj); }
  5976.         else
  5977.         # ZirkularitΣt
  5978.         if (info->flag)
  5979.           # obj als #n=... ausgeben:
  5980.           { # erst noch fⁿr circle_p das Fixnum im Vektor incrementieren:
  5981.             { var reg1 object* ptr = info->ptr;
  5982.               *ptr = fixnum_inc(*ptr,1);
  5983.             }
  5984.             { var reg5 uintL n = info->n;
  5985.               pushSTACK(obj); # obj retten
  5986.               # PrΣfix ausgeben und Einrⁿckungstiefe berechnen:
  5987.               INDENTPREP_START;
  5988.               write_schar(stream_,'#');
  5989.               pr_uint(stream_,n);
  5990.               write_schar(stream_,'=');
  5991.             }
  5992.             { var reg5 uintL indent = INDENTPREP_END;
  5993.               obj = popSTACK(); # obj zurⁿck
  5994.               # obj (eingerⁿckt) ausgeben:
  5995.               INDENT_START(indent);
  5996.               (*pr_xxx)(stream_,obj);
  5997.               INDENT_END;
  5998.           } }
  5999.           else
  6000.           # obj als #n# ausgeben:
  6001.           { var reg5 uintL n = info->n;
  6002.             write_schar(stream_,'#');
  6003.             pr_uint(stream_,n);
  6004.             write_schar(stream_,'#');
  6005.           }
  6006.     }
  6007.  
  6008. # Nun kommen die einzelnen pr_xxx-Routinen:
  6009.   local_function pr_routine prin_object;
  6010.   local_function pr_routine prin_object_dispatch;
  6011.   local_function pr_routine pr_symbol;
  6012.   local_function pr_routine pr_symbol_part;
  6013.   local_function pr_routine pr_like_symbol;
  6014.   local_function pr_routine pr_character;
  6015.   local_function pr_routine pr_string;
  6016.   local_function pr_routine pr_list;
  6017.   local_function pr_routine pr_cons;
  6018.   local_function pr_routine pr_list_quote;
  6019.   local_function pr_routine pr_list_function;
  6020.   local_function pr_routine pr_list_backquote;
  6021.   local_function pr_routine pr_list_splice;
  6022.   local_function pr_routine pr_list_nsplice;
  6023.   local_function pr_routine pr_list_unquote;
  6024.   local_function pr_routine pr_real_number;
  6025.   local_function pr_routine pr_number;
  6026.   local_function pr_routine pr_array_nil;
  6027.   local_function pr_routine pr_bvector;
  6028.   local_function pr_routine pr_vector;
  6029.   local_function pr_routine pr_array;
  6030.   local_function pr_routine pr_structure;
  6031.   local_function pr_routine pr_machine;
  6032.   local_function pr_routine pr_system;
  6033.   local_function pr_routine pr_orecord;
  6034.   local_function pr_routine pr_subr;
  6035.   local_function pr_routine pr_fsubr;
  6036.   local_function pr_routine pr_closure;
  6037.   local_function pr_routine pr_cclosure;
  6038.   local_function pr_routine pr_cclosure_lang;
  6039.   local_function pr_routine pr_cclosure_codevector;
  6040.   local_function pr_routine pr_stream;
  6041.   local_function pr_routine pr_instance;
  6042.  
  6043. # UP: Gibt ein Objekt auf einen Stream aus.
  6044. # prin_object(&stream,obj);
  6045. # > obj: Objekt
  6046. # > stream: Stream
  6047. # < stream: Stream
  6048. # kann GC ausl÷sen
  6049.   local void prin_object(stream_,obj)
  6050.     var reg2 object* stream_;
  6051.     var reg1 object obj;
  6052.     { restart_it:
  6053.       # Auf Tastatur-Interrupt testen:
  6054.       interruptp(
  6055.         { pushSTACK(obj); # obj retten, stream ist im STACK sicher
  6056.           pushSTACK(S(print)); tast_break(); # PRINT ruft Break-Schleife auf
  6057.           obj = popSTACK(); # obj zurⁿck
  6058.           goto restart_it;
  6059.         }
  6060.         );
  6061.       # auf Stackⁿberlauf testen:
  6062.       check_SP(); check_STACK();
  6063.       # ZirkularitΣt behandeln:
  6064.       pr_circle(stream_,obj,&prin_object_dispatch);
  6065.     }
  6066.   local void prin_object_dispatch(stream_,obj)
  6067.     var reg2 object* stream_;
  6068.     var reg1 object obj;
  6069.     { # Nach der Typinfo verzweigen:
  6070.       switch (typecode(obj))
  6071.         { case_machine: # Maschinenpointer
  6072.             pr_machine(stream_,obj); break;
  6073.           case_obvector: # Bit/Byte-Vektor
  6074.             if (!((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_Bit))
  6075.               { pr_vector(stream_,obj); break; } # Byte-Vektor
  6076.           case_sbvector: # Bit-Vektor
  6077.             pr_bvector(stream_,obj); break;
  6078.           case_string: # String
  6079.             pr_string(stream_,obj); break;
  6080.           case_vector: # (vector t)
  6081.             pr_vector(stream_,obj); break;
  6082.           case_array1: # allgemeiner Array
  6083.             pr_array(stream_,obj); break;
  6084.           case_closure: # Closure
  6085.             pr_closure(stream_,obj); break;
  6086.           case_instance: # CLOS-Instanz
  6087.             pr_instance(stream_,obj); break;
  6088.           #ifdef case_structure
  6089.           case_structure: # Structure
  6090.             pr_structure(stream_,obj); break;
  6091.           #endif
  6092.           #ifdef case_stream
  6093.           case_stream: # Stream
  6094.             pr_stream(stream_,obj); break;
  6095.           #endif
  6096.           case_orecord: # OtherRecord
  6097.             pr_orecord(stream_,obj); break;
  6098.           case_char: # Character
  6099.             pr_character(stream_,obj); break;
  6100.           case_subr: # SUBR
  6101.             pr_subr(stream_,obj); break;
  6102.           case_system: # Frame-Pointer, Read-Label, System
  6103.             pr_system(stream_,obj); break;
  6104.           case_number: # Zahl
  6105.             pr_number(stream_,obj); break;
  6106.           case_symbol: # Symbol
  6107.             pr_symbol(stream_,obj); break;
  6108.           case_cons: # Cons
  6109.             pr_cons(stream_,obj); break;
  6110.           default: NOTREACHED
  6111.         }
  6112.     }
  6113.  
  6114.  
  6115. # ------------- PRINT-Routinen fⁿr verschiedene Datentypen --------------------
  6116.  
  6117. #                      -------- Symbole --------
  6118.  
  6119. # UP: Gibt ein Symbol auf einen Stream aus.
  6120. # pr_symbol(&stream,sym);
  6121. # > sym: Symbol
  6122. # > stream: Stream
  6123. # < stream: Stream
  6124. # kann GC ausl÷sen
  6125.   local void pr_symbol(stream_,sym)
  6126.     var reg2 object* stream_;
  6127.     var reg1 object sym;
  6128.     { # *PRINT-ESCAPE* abfragen:
  6129.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6130.         # mit Escape-Zeichen und evtl. Packagenamen:
  6131.         { if (!accessiblep(sym,get_current_package()))
  6132.             # Falls Symbol accessible und nicht verdeckt,
  6133.             # keinen Packagenamen und keine Packagemarker ausgeben.
  6134.             # Sonst:
  6135.             { var reg3 object home;
  6136.               pushSTACK(sym); # Symbol retten
  6137.               if (keywordp(sym)) # Keyword ?
  6138.                 goto one_marker; # ja -> nur 1 Packagemarker ausgeben
  6139.               home = Symbol_package(sym); # Home-package des Symbols
  6140.               if (nullp(home))
  6141.                 # uninterniertes Symbol ausgeben
  6142.                 { # *PRINT-GENSYM* abfragen:
  6143.                   if (test_value(S(print_gensym)) || test_value(S(print_readably)))
  6144.                     # Syntax #:name verwenden
  6145.                     { write_schar(stream_,'#'); goto one_marker; }
  6146.                     # sonst ohne PrΣfix ausgeben
  6147.                 }
  6148.                 else
  6149.                 # Symbol mit Packagenamen und 1 oder 2 Packagemarkern ausgeben
  6150.                 { pushSTACK(home); # Home-Package retten
  6151.                   pr_symbol_part(stream_,ThePackage(home)->pack_name); # Packagenamen ausgeben
  6152.                   home = popSTACK(); # Home-Package zurⁿck
  6153.                   if (externalp(STACK_0,home)) # Symbol extern in seiner Home-Package?
  6154.                     goto one_marker; # ja -> 1 Packagemarker
  6155.                   write_schar(stream_,':'); # sonst 2 Packagemarker
  6156.                   one_marker:
  6157.                   write_schar(stream_,':');
  6158.                 }
  6159.               sym = popSTACK(); # sym zurⁿck
  6160.             }
  6161.           pr_symbol_part(stream_,Symbol_name(sym)); # Symbolnamen ausgeben
  6162.         }
  6163.         else
  6164.         # Symbol ohne Escape-Zeichen ausgeben:
  6165.         # nur den Symbolnamen unter Kontrolle von *PRINT-CASE* ausgeben
  6166.         { write_sstring_case(stream_,Symbol_name(sym)); }
  6167.     }
  6168.  
  6169. # UP: Gibt einen Symbol-Teil (Packagename oder Symbolname) mit Escape-Zeichen
  6170. # aus.
  6171. # pr_symbol_part(&stream,string);
  6172. # > string: Simple-String
  6173. # > stream: Stream
  6174. # < stream: Stream
  6175. # kann GC ausl÷sen
  6176.   local void pr_symbol_part(stream_,string)
  6177.     var reg7 object* stream_;
  6178.     var reg8 object string;
  6179.     { # Feststellen, ob der Name ohne |...| au▀enrum ausgegeben werden kann:
  6180.       # Dies kann er dann, wenn er:
  6181.       # 1. nicht leer ist und
  6182.       # 2. mit einem Character mit Syntaxcode Constituent anfΣngt und
  6183.       # 3. nur aus Characters mit Syntaxcode Constituent oder
  6184.       #    Nonterminating Macro besteht und
  6185.       # 4. keine Klein-/Gro▀buchstaben (je nach readtable_case)
  6186.       #    und keine Doppelpunkte enthΣlt und
  6187.       # 5. nicht Potential-Number Syntax (mit *PRINT-BASE* als Basis) hat.
  6188.       var reg4 uintL len = TheSstring(string)->length; # LΣnge
  6189.       # Bedingung 1 ⁿberprⁿfen:
  6190.       if (len==0) goto surround; # LΣnge=0 -> mu▀ |...| verwenden
  6191.       # Bedingungen 2-4 ⁿberprⁿfen:
  6192.       { # Brauche die Attributcodetabelle und die aktuelle Syntaxcodetabelle:
  6193.         var reg5 uintB* syntax_table; # Syntaxcodetabelle, RM_anzahl Elemente
  6194.         var reg6 uintW rtcase; # readtable-case
  6195.         { var reg1 object readtable;
  6196.           get_readtable(readtable = ); # aktuelle Readtable
  6197.           syntax_table = &TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[0];
  6198.           rtcase = posfixnum_to_L(TheReadtable(readtable)->readtable_case);
  6199.         }
  6200.         # String durchlaufen:
  6201.         { var reg2 uintB* charptr = &TheSstring(string)->data[0];
  6202.           var reg3 uintL count = len;
  6203.           var reg1 uintB c = *charptr++; # erstes Character
  6204.           # sein Syntaxcode soll Constituent sein:
  6205.           if (!(syntax_table[c] == syntax_constituent))
  6206.             goto surround; # nein -> mu▀ |...| verwenden
  6207.           loop
  6208.             { if (attribute_table[c] == a_pack_m) # Attributcode Package-Marker ?
  6209.                 goto surround; # ja -> mu▀ |...| verwenden
  6210.               switch (rtcase)
  6211.                 { case case_upcase:
  6212.                     if (!(c == up_case(c))) # war c ein Kleinbuchstabe?
  6213.                       goto surround; # ja -> mu▀ |...| verwenden
  6214.                     break;
  6215.                   case case_downcase:
  6216.                     if (!(c == down_case(c))) # war c ein Gro▀buchstabe?
  6217.                       goto surround; # ja -> mu▀ |...| verwenden
  6218.                     break;
  6219.                   case case_preserve:
  6220.                     break;
  6221.                   default: NOTREACHED
  6222.                 }
  6223.               count--; if (count == 0) break; # String zu Ende -> Schleifenende
  6224.               c = *charptr++; # nΣchstes Character
  6225.               switch (syntax_table[c]) # sein Syntaxcode
  6226.                 { case syntax_constituent:
  6227.                   case syntax_nt_macro:
  6228.                     break;
  6229.                   default: # Syntaxcode /= Constituent, Nonterminating Macro
  6230.                     goto surround; # -> mu▀ |...| verwenden
  6231.                 }
  6232.             }
  6233.       } }
  6234.       # Bedingung 5 ⁿberprⁿfen:
  6235.       { pushSTACK(string); # String retten
  6236.         get_buffers(); # zwei Buffer allozieren, in den STACK
  6237.         # und fⁿllen:
  6238.         { var reg2 uintL index = 0;
  6239.           until (index == len)
  6240.             { var reg1 uintB c = TheSstring(STACK_2)->data[index]; # nΣchstes Character
  6241.               ssstring_push_extend(STACK_1,c); # in den Character-Buffer
  6242.               ssstring_push_extend(STACK_0,attribute_table[c]); # und in den Attributcode-Buffer
  6243.               index++;
  6244.         }   }
  6245.         O(token_buff_2) = popSTACK(); # Attributcode-Buffer
  6246.         O(token_buff_1) = popSTACK(); # Character-Buffer
  6247.         string = popSTACK(); # String zurⁿck
  6248.         if (test_dots()) goto surround; # nur Punkte -> mu▀ |...| verwenden
  6249.         # Potential-Number-Syntax?
  6250.         { var uintWL base = get_print_base(); # Wert von *PRINT-BASE*
  6251.           var token_info info;
  6252.           if (test_potential_number_syntax(&base,&info))
  6253.             goto surround; # ja -> mu▀ |...| verwenden
  6254.       } }
  6255.       # Name kann ohne Escape-Characters ausgegeben werden.
  6256.       # Dabei jedoch *PRINT-CASE* beachten:
  6257.       write_sstring_case(stream_,string);
  6258.       return;
  6259.       surround: # Namen unter Verwendung der Escape-Character |...| ausgeben:
  6260.       { # Syntaxcodetabelle holen:
  6261.         { var reg1 object readtable;
  6262.           get_readtable(readtable = ); # aktuelle Readtable
  6263.           pushSTACK(TheReadtable(readtable)->readtable_syntax_table);
  6264.         }
  6265.         pushSTACK(string);
  6266.         # Stackaufbau: syntax_table, string.
  6267.         write_schar(stream_,'|');
  6268.         { var reg2 uintL index = 0;
  6269.           until (index == len)
  6270.             { var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nΣchstes Character
  6271.               switch (TheSbvector(STACK_1)->data[c]) # dessen Syntaxcode
  6272.                 { case syntax_single_esc:
  6273.                   case syntax_multi_esc:
  6274.                     # Dem Escape-Character c wird ein '\' vorangestellt:
  6275.                     write_schar(stream_,'\\');
  6276.                   default: ;
  6277.                 }
  6278.               write_schar(stream_,c); # Character ausgeben
  6279.               index++;
  6280.         }   }
  6281.         write_schar(stream_,'|');
  6282.         skipSTACK(2);
  6283.       }
  6284.     }
  6285.  
  6286. # UP: Gibt einen Simple-String wie einen Symbol-Teil aus.
  6287. # pr_like_symbol(&stream,string);
  6288. # > string: Simple-String
  6289. # > stream: Stream
  6290. # < stream: Stream
  6291. # kann GC ausl÷sen
  6292.   local void pr_like_symbol(stream_,string)
  6293.     var reg1 object* stream_;
  6294.     var reg2 object string;
  6295.     { # *PRINT-ESCAPE* abfragen:
  6296.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6297.         { pr_symbol_part(stream_,string); } # mit Escape-Zeichen ausgeben
  6298.         else
  6299.         { write_sstring_case(stream_,string); } # ohne Escape-Zeichen ausgeben
  6300.     }
  6301.  
  6302. #                      -------- Characters --------
  6303.  
  6304. # UP: Gibt ein Character auf einen Stream aus.
  6305. # pr_character(&stream,ch);
  6306. # > ch: Character
  6307. # > stream: Stream
  6308. # < stream: Stream
  6309. # kann GC ausl÷sen
  6310.   local void pr_character(stream_,ch)
  6311.     var reg4 object* stream_;
  6312.     var reg6 object ch;
  6313.     { # *PRINT-ESCAPE* abfragen:
  6314.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6315.         # Character mit Escape-Zeichen ausgeben.
  6316.         # Syntax:  # [font] \ char
  6317.         # bzw.     # [font] \ charname
  6318.         # bzw.     # [font] \ bitname - ... - bitname - [\] char
  6319.         # bzw.     # [font] \ bitname - ... - bitname - charname
  6320.         { var reg2 cint c = char_int(ch);
  6321.           write_schar(stream_,'#');
  6322.          {var reg1 cint font = (c >> char_font_shift_c) & (char_font_limit-1); # Font
  6323.           if (!(font==0)) # Falls font /=0 :
  6324.             { pr_uint(stream_,font); } # Fontnummer dezimal ausgeben
  6325.          }
  6326.           write_schar(stream_,'\\');
  6327.          {var reg1 cint bits = (c >> char_bits_shift_c) & (char_bits_limit-1); # Bits
  6328.           if (bits==0)
  6329.             # keine Bits auszugeben ->
  6330.             # Syntax  # [font] \ char  oder  # [font] \ charname
  6331.             { var reg3 uintB code = (c >> char_code_shift_c) & (char_code_limit-1); # Code
  6332.               var reg5 object charname = char_name(code); # Name des Characters
  6333.               if (nullp(charname))
  6334.                 # kein Name vorhanden
  6335.                 { write_schar(stream_,code); }
  6336.                 else
  6337.                 # Namen (Simple-String) ausgeben
  6338.                 { write_sstring_case(stream_,charname); }
  6339.             }
  6340.             else
  6341.             # Es sind Bits auszugeben
  6342.             { # Bitnamen ausgeben:
  6343.               { var reg3 object* bitnameptr = &O(bitname_0);
  6344.                 var reg5 uintC count;
  6345.                 dotimesC(count,char_bits_len_c, # alle Bits und Bitnamen durchgehen
  6346.                   { if (bits & bit(0))
  6347.                       # Bit war gesetzt -> Bitnamen *bitnameptr ausgeben:
  6348.                       { write_sstring_case(stream_,*bitnameptr);
  6349.                         write_schar(stream_,'-');
  6350.                       }
  6351.                     bits = bits >> 1;
  6352.                     bitnameptr++;
  6353.                   });
  6354.               }
  6355.               # Noch auszugeben:  charname  oder  [\]char
  6356.               { var reg3 uintB code = (c >> char_code_shift_c) & (char_code_limit-1); # Code
  6357.                 var reg5 object charname = char_name(code); # Name des Characters
  6358.                 if (nullp(charname))
  6359.                   # kein Name vorhanden
  6360.                   { # code selbst ausgeben.
  6361.                     # Falls es
  6362.                     # - den Syntaxcode Constituent oder Nonterminating Macro hat und
  6363.                     # - in der Gro▀-/Klein-Schreibung zur readtable-case pa▀t,
  6364.                     # kann man sich den '\' sparen:
  6365.                     { var reg7 object readtable;
  6366.                       get_readtable(readtable = ); # aktuelle Readtable
  6367.                       switch ((uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case))
  6368.                         { case case_upcase:
  6369.                             if (!(code == up_case(code))) # code ein Kleinbuchstabe?
  6370.                               goto backslash; # ja -> Backslash n÷tig
  6371.                             break;
  6372.                           case case_downcase:
  6373.                             if (!(code == down_case(code))) # code ein Gro▀buchstabe?
  6374.                               goto backslash; # ja -> Backslash n÷tig
  6375.                             break;
  6376.                           case case_preserve:
  6377.                             break;
  6378.                           default: NOTREACHED
  6379.                         }
  6380.                       # Syntaxcode-Tabelle holen:
  6381.                      {var reg8 object syntax_table = TheReadtable(readtable)->readtable_syntax_table; # Syntaxcode-Tabelle
  6382.                       switch (TheSbvector(syntax_table)->data[code]) # Syntaxcode
  6383.                         { case syntax_constituent:
  6384.                           case syntax_nt_macro:
  6385.                             # Syntaxcode Constituent oder Nonterminating Macro
  6386.                             goto no_backslash; # kein '\' n÷tig
  6387.                           default: ;
  6388.                     }}  }
  6389.                     backslash:
  6390.                     write_schar(stream_,'\\');
  6391.                     no_backslash:
  6392.                     write_schar(stream_,code);
  6393.                   }
  6394.                   else
  6395.                   # Namen (Simple-String) ausgeben
  6396.                   { write_sstring_case(stream_,charname); }
  6397.             } }
  6398.         }}
  6399.         else
  6400.         # Character ohne Escape-Zeichen ausgeben
  6401.         { write_char(stream_,ch); } # ch selbst ausgeben
  6402.     }
  6403.  
  6404. #                      -------- Strings --------
  6405.  
  6406. # UP: Gibt einen Teil eines Simple-String auf einen Stream aus.
  6407. # pr_sstring_ab(&stream,string,start,len);
  6408. # > string: Simple-String
  6409. # > start: Startindex
  6410. # > len: Anzahl der auszugebenden Zeichen
  6411. # > stream: Stream
  6412. # < stream: Stream
  6413. # kann GC ausl÷sen
  6414.   local void pr_sstring_ab (object* stream_, object string, uintL start, uintL len);
  6415.   local void pr_sstring_ab(stream_,string,start,len)
  6416.     var reg4 object* stream_;
  6417.     var reg6 object string;
  6418.     var reg5 uintL start;
  6419.     var reg3 uintL len;
  6420.     { # *PRINT-ESCAPE* abfragen:
  6421.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6422.         # mit Escape-Zeichen:
  6423.         { var reg2 uintL index = start;
  6424.           pushSTACK(string); # Simple-String retten
  6425.           write_schar(stream_,'"'); # vorher ein Anfⁿhrungszeichen
  6426.           dotimesL(len,len,
  6427.             { var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nΣchstes Zeichen
  6428.               # bei c = #\" oder c = #\\ erst noch ein '\' ausgeben:
  6429.               if ((c=='"') || (c=='\\')) { write_schar(stream_,'\\'); }
  6430.               write_schar(stream_,c);
  6431.               index++;
  6432.             });
  6433.           write_schar(stream_,'"'); # nachher ein Anfⁿhrungszeichen
  6434.           skipSTACK(1);
  6435.         }
  6436.         else
  6437.         # ohne Escape-Zeichen: nur write_sstring_ab
  6438.         { write_sstring_ab(stream_,string,start,len); }
  6439.     }
  6440.  
  6441. # UP: Gibt einen String auf einen Stream aus.
  6442. # pr_string(&stream,string);
  6443. # > string: String
  6444. # > stream: Stream
  6445. # < stream: Stream
  6446. # kann GC ausl÷sen
  6447.   local void pr_string(stream_,string)
  6448.     var reg2 object* stream_;
  6449.     var reg1 object string;
  6450.     { var reg3 uintL len = vector_length(string); # LΣnge
  6451.       var uintL offset = 0; # Offset vom String in den Datenvektor
  6452.       var reg4 object sstring = array_displace_check(string,len,&offset); # Datenvektor
  6453.       pr_sstring_ab(stream_,sstring,offset,len);
  6454.     }
  6455.  
  6456. #                    -------- Conses, Listen --------
  6457.  
  6458. # UP: Stellt fest, ob ein Cons auf eine spezielle Art und Weise auszugeben
  6459. # ist.
  6460. # special_list_p(obj)
  6461. # > obj: Objekt, ein Cons
  6462. # < ergebnis: Adresse der entsprechenden pr_list_xxx-Routine, falls ja,
  6463. #             NULL, falls nein.
  6464.   local pr_routine* special_list_p (object obj);
  6465.   local pr_routine* special_list_p(obj)
  6466.     var reg2 object obj;
  6467.     { # Spezielle Listen sind die der Form
  6468.       # (QUOTE a), (FUNCTION a), (SYS::BACKQUOTE a [b]) und
  6469.       # (SYS::SPLICE a), (SYS::NSPLICE a), (SYS::UNQUOTE a)
  6470.       # falls SYS::*PRIN-BQLEVEL* > 0
  6471.       var reg1 object head = Car(obj);
  6472.       var reg3 pr_routine* pr_xxx;
  6473.       if (eq(head,S(quote))) # QUOTE
  6474.         { pr_xxx = &pr_list_quote; goto test2; }
  6475.       elif (eq(head,S(function))) # FUNCTION
  6476.         { pr_xxx = &pr_list_function; goto test2; }
  6477.       elif (eq(head,S(backquote))) # SYS::BACKQUOTE
  6478.         { pr_xxx = &pr_list_backquote;
  6479.           # Teste noch, ob obj eine Liste der LΣnge 2 oder 3 ist.
  6480.           obj = Cdr(obj); # Der CDR
  6481.           if (consp(obj) && # mu▀ ein Cons sein,
  6482.               (obj = Cdr(obj), # der CDDR
  6483.                (atomp(obj) ? nullp(obj) : nullp(Cdr(obj))) # NIL oder eine einelementige Liste
  6484.              ))
  6485.             { return pr_xxx; }
  6486.             else
  6487.             { return (pr_routine*)NULL; }
  6488.         }
  6489.       elif (eq(head,S(splice))) # SYS::SPLICE
  6490.         { pr_xxx = &pr_list_splice; goto test2bq; }
  6491.       elif (eq(head,S(nsplice))) # SYS::NSPLICE
  6492.         { pr_xxx = &pr_list_nsplice; goto test2bq; }
  6493.       elif (eq(head,S(unquote))) # SYS::UNQUOTE
  6494.         { pr_xxx = &pr_list_unquote; goto test2bq; }
  6495.       else
  6496.         { return (pr_routine*)NULL; }
  6497.       test2bq: # Teste noch, ob SYS::*PRIN-BQLEVEL* > 0 und
  6498.                # obj eine Liste der LΣnge 2 ist.
  6499.         { var reg4 object bqlevel = Symbol_value(S(prin_bqlevel));
  6500.           if (!(posfixnump(bqlevel) && !eq(bqlevel,Fixnum_0)))
  6501.             { return (pr_routine*)NULL; }
  6502.         }
  6503.       test2: # Teste noch, ob obj eine Liste der LΣnge 2 ist.
  6504.         if (mconsp(Cdr(obj)) && nullp(Cdr(Cdr(obj))))
  6505.           { return pr_xxx; }
  6506.           else
  6507.           { return (pr_routine*)NULL; }
  6508.     }
  6509.  
  6510. # UP: Gibt eine Liste auf einen Stream aus, NIL als ().
  6511. # pr_list(&stream,list);
  6512. # > list: Liste
  6513. # > stream: Stream
  6514. # < stream: Stream
  6515. # kann GC ausl÷sen
  6516.   local void pr_list(stream_,list)
  6517.     var reg2 object* stream_;
  6518.     var reg1 object list;
  6519.     { if (nullp(list))
  6520.         # NIL als () ausgeben:
  6521.         { write_schar(stream_,'('); write_schar(stream_,')'); }
  6522.         else
  6523.         # ein Cons
  6524.         { pr_cons(stream_,list); }
  6525.     }
  6526.  
  6527. # UP: Gibt ein Cons auf einen Stream aus.
  6528. # pr_cons(&stream,list);
  6529. # > list: Cons
  6530. # > stream: Stream
  6531. # < stream: Stream
  6532. # kann GC ausl÷sen
  6533.   local void pr_cons(stream_,list)
  6534.     var reg2 object* stream_;
  6535.     var reg3 object list;
  6536.     { # SpezialfΣlle abfangen:
  6537.       { var reg1 pr_routine* special = special_list_p(list);
  6538.         if (!(special == (pr_routine*)NULL))
  6539.           { (*special)(stream_,list); # spezielle pr_list_xxx-Routine aufrufen
  6540.             return;
  6541.       }   }
  6542.       LEVEL_CHECK;
  6543.       { var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  6544.         var reg4 uintL length = 0; # bisherige LΣnge := 0
  6545.         pushSTACK(list); # Liste retten
  6546.        {var reg1 object* list_ = &STACK_0; # und merken, wo sie sitzt
  6547.         KLAMMER_AUF; # '('
  6548.         INDENT_START(1); # um 1 Zeichen einrⁿcken, wegen '('
  6549.         JUSTIFY_START;
  6550.         # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  6551.         if (length_limit==0) goto dots;
  6552.         loop
  6553.           { # ab hier den CAR ausgeben
  6554.             list = *list_; *list_ = Cdr(list); # Liste verkⁿrzen
  6555.             prin_object(stream_,Car(list)); # den CAR ausgeben
  6556.             length++; # LΣnge incrementieren
  6557.             # ab hier den Listenrest ausgeben
  6558.             if (nullp(*list_)) goto end_of_list; # Listenrest=NIL -> Listenende
  6559.             JUSTIFY_SPACE; # ein Space ausgeben
  6560.             if (matomp(*list_)) goto dotted_list; # Dotted List ?
  6561.             # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  6562.             if (length >= length_limit) goto dots;
  6563.             # Prⁿfen, ob Dotted-List-Schreibweise n÷tig:
  6564.             list = *list_;
  6565.             if (!(circle_p(list) == (circle_info*)NULL)) # wegen ZirkularitΣt n÷tig?
  6566.               goto dotted_list;
  6567.             if (!(special_list_p(list) == (pr_routine*)NULL)) # wegen QUOTE o.Σ. n÷tig?
  6568.               goto dotted_list;
  6569.           }
  6570.         dotted_list: # Listenrest in Dotted-List-Schreibweise ausgeben:
  6571.           write_schar(stream_,'.');
  6572.           JUSTIFY_SPACE;
  6573.           prin_object(stream_,*list_);
  6574.           goto end_of_list;
  6575.         dots: # Listenrest durch '...' abkⁿrzen:
  6576.           write_schar(stream_,'.');
  6577.           write_schar(stream_,'.');
  6578.           write_schar(stream_,'.');
  6579.           goto end_of_list;
  6580.         end_of_list: # Listeninhalt ausgegeben.
  6581.         JUSTIFY_END_ENG;
  6582.         INDENT_END;
  6583.         KLAMMER_ZU;
  6584.         skipSTACK(1);
  6585.       }}
  6586.       LEVEL_END;
  6587.     }
  6588.  
  6589. # Ausgabe von ...                              als ...
  6590. # (quote object)                               'object
  6591. # (function object)                            #'object
  6592. # (backquote original-form [expanded-form])    `original-form
  6593. # (splice (unquote form))                      ,@form
  6594. # (splice form)                                ,@'form
  6595. # (nsplice (unquote form))                     ,.form
  6596. # (nsplice form)                               ,.'form
  6597. # (unquote form)                               ,form
  6598.  
  6599.   local void pr_list_quote(stream_,list) # list = (QUOTE object)
  6600.     var reg2 object* stream_;
  6601.     var reg1 object list;
  6602.     { pushSTACK(Car(Cdr(list))); # (second list) retten
  6603.       write_schar(stream_,'\''); # "'" ausgeben
  6604.       list = popSTACK();
  6605.       INDENT_START(1); # um 1 Zeichen einrⁿcken wegen "'"
  6606.       prin_object(stream_,list); # object ausgeben
  6607.       INDENT_END;
  6608.     }
  6609.  
  6610.   local void pr_list_function(stream_,list) # list = (FUNCTION object)
  6611.     var reg2 object* stream_;
  6612.     var reg1 object list;
  6613.     { pushSTACK(Car(Cdr(list))); # (second list) retten
  6614.       write_schar(stream_,'#'); # "#" ausgeben
  6615.       write_schar(stream_,'\''); # "'" ausgeben
  6616.       list = popSTACK();
  6617.       INDENT_START(2); # um 2 Zeichen einrⁿcken wegen "#'"
  6618.       prin_object(stream_,list); # object ausgeben
  6619.       INDENT_END;
  6620.     }
  6621.  
  6622.   local void pr_list_backquote(stream_,list) # list = (BACKQUOTE original-form [expanded-form])
  6623.     var reg2 object* stream_;
  6624.     var reg1 object list;
  6625.     { pushSTACK(Car(Cdr(list))); # (second list) retten
  6626.       write_schar(stream_,'`'); # '`' ausgeben
  6627.       list = popSTACK();
  6628.       # SYS::*PRIN-BQLEVEL* um 1 erh÷hen:
  6629.       {var reg3 object bqlevel = Symbol_value(S(prin_bqlevel));
  6630.        if (!posfixnump(bqlevel)) { bqlevel = Fixnum_0; }
  6631.        dynamic_bind(S(prin_bqlevel),fixnum_inc(bqlevel,1));
  6632.       }
  6633.       INDENT_START(1); # um 1 Zeichen einrⁿcken wegen '`'
  6634.       prin_object(stream_,list); # original-form ausgeben
  6635.       INDENT_END;
  6636.       dynamic_unbind();
  6637.     }
  6638.  
  6639.   local void pr_list_bothsplice (object* stream_, object list, object ch);
  6640.   local void pr_list_bothsplice(stream_,list,ch)
  6641.     var reg2 object* stream_;
  6642.     var reg1 object list;
  6643.     var reg3 object ch;
  6644.     # list = (SPLICE object), ch = '@' oder
  6645.     # list = (NSPLICE object), ch = '.'
  6646.     { pushSTACK(Car(Cdr(list))); # (second list) retten
  6647.       write_schar(stream_,','); # Komma ausgeben
  6648.       write_char(stream_,ch); # '@' bzw. '.' ausgeben
  6649.       list = popSTACK();
  6650.       # SYS::*PRIN-BQLEVEL* um 1 verringern:
  6651.       dynamic_bind(S(prin_bqlevel),fixnum_inc(Symbol_value(S(prin_bqlevel)),-1));
  6652.       # Ist dies von der Form (UNQUOTE form) ?
  6653.       if (consp(list) && eq(Car(list),S(unquote))
  6654.           && mconsp(Cdr(list)) && nullp(Cdr(Cdr(list)))
  6655.          )
  6656.         # ja -> noch die Form ausgeben:
  6657.         { list = Car(Cdr(list)); # (second object)
  6658.           INDENT_START(2); # um 2 Zeichen einrⁿcken wegen ",@" bzw. ",."
  6659.           prin_object(stream_,list); # Form ausgeben
  6660.           INDENT_END;
  6661.         }
  6662.         else
  6663.         # nein -> noch ein Quote und object ausgeben:
  6664.         { pushSTACK(list); # object retten
  6665.           write_schar(stream_,'\''); # "'" ausgeben
  6666.           list = popSTACK();
  6667.           INDENT_START(3); # um 3 Zeichen einrⁿcken wegen ",@'" bzw. ",.'"
  6668.           prin_object(stream_,list); # object ausgeben
  6669.           INDENT_END;
  6670.         }
  6671.       dynamic_unbind();
  6672.     }
  6673.  
  6674.   local void pr_list_splice(stream_,list) # list = (SPLICE object)
  6675.     var reg2 object* stream_;
  6676.     var reg1 object list;
  6677.     { pr_list_bothsplice(stream_,list,code_char('@')); }
  6678.  
  6679.   local void pr_list_nsplice(stream_,list) # list = (NSPLICE object)
  6680.     var reg2 object* stream_;
  6681.     var reg1 object list;
  6682.     { pr_list_bothsplice(stream_,list,code_char('.')); }
  6683.  
  6684.   local void pr_list_unquote(stream_,list) # list = (UNQUOTE object)
  6685.     var reg2 object* stream_;
  6686.     var reg1 object list;
  6687.     { pushSTACK(Car(Cdr(list))); # (second list) retten
  6688.       write_schar(stream_,','); # ',' ausgeben
  6689.       list = popSTACK();
  6690.       # SYS::*PRIN-BQLEVEL* um 1 verringern:
  6691.       dynamic_bind(S(prin_bqlevel),fixnum_inc(Symbol_value(S(prin_bqlevel)),-1));
  6692.       INDENT_START(1); # um 1 Zeichen einrⁿcken wegen ','
  6693.       prin_object(stream_,list); # object ausgeben
  6694.       INDENT_END;
  6695.       dynamic_unbind();
  6696.     }
  6697.  
  6698. #                      -------- Zahlen --------
  6699.  
  6700. # UP: Gibt eine reelle Zahl auf einen Stream aus.
  6701. # pr_real_number(&stream,number);
  6702. # > number: reelle Zahl
  6703. # > stream: Stream
  6704. # < stream: Stream
  6705. # kann GC ausl÷sen
  6706.   local void pr_real_number(stream_,number)
  6707.     var reg2 object* stream_;
  6708.     var reg1 object number;
  6709.     { if (R_rationalp(number))
  6710.         # rationale Zahl
  6711.         { var reg3 uintWL base = get_print_base(); # Wert von *PRINT-BASE*
  6712.           # *PRINT-RADIX* abfragen:
  6713.           if (test_value(S(print_radix)) || test_value(S(print_readably)))
  6714.             # Radix-Specifier ausgeben:
  6715.             { pushSTACK(number); # number retten
  6716.               switch (base)
  6717.                 { case 2: # Basis 2
  6718.                     write_schar(stream_,'#'); write_schar(stream_,'b'); break;
  6719.                   case 8: # Basis 8
  6720.                     write_schar(stream_,'#'); write_schar(stream_,'o'); break;
  6721.                   case 16: # Basis 16
  6722.                     write_schar(stream_,'#'); write_schar(stream_,'x'); break;
  6723.                   case 10: # Basis 10
  6724.                     if (RA_integerp(number))
  6725.                       { # Basis 10 bei Integers durch nachgestellten Punkt
  6726.                         # kennzeichnen:
  6727.                         skipSTACK(1);
  6728.                         print_integer(number,base,stream_);
  6729.                         write_schar(stream_,'.');
  6730.                         return;
  6731.                       }
  6732.                   default: # Basis in #nR-Schreibweise ausgeben:
  6733.                     write_schar(stream_,'#');
  6734.                     pr_uint(stream_,base);
  6735.                     write_schar(stream_,'r');
  6736.                     break;
  6737.                 }
  6738.               number = popSTACK();
  6739.             }
  6740.           if (RA_integerp(number))
  6741.             # Integer in Basis base ausgeben:
  6742.             { print_integer(number,base,stream_); }
  6743.             else
  6744.             # Ratio in Basis base ausgeben:
  6745.             { pushSTACK(TheRatio(number)->rt_den); # Nenner retten
  6746.               print_integer(TheRatio(number)->rt_num,base,stream_); # ZΣhler ausgeben
  6747.               write_schar(stream_,'/'); # Bruchstrich
  6748.               print_integer(popSTACK(),base,stream_); # Nenner ausgeben
  6749.             }
  6750.         }
  6751.         else
  6752.         # Float
  6753.         { print_float(number,stream_); }
  6754.     }
  6755.  
  6756. # UP: Gibt eine Zahl auf einen Stream aus.
  6757. # pr_number(&stream,number);
  6758. # > number: Zahl
  6759. # > stream: Stream
  6760. # < stream: Stream
  6761. # kann GC ausl÷sen
  6762.   local void pr_number(stream_,number)
  6763.     var reg3 object* stream_;
  6764.     var reg2 object number;
  6765.     { if (N_realp(number))
  6766.         # reelle Zahl
  6767.         { pr_real_number(stream_,number); }
  6768.         else
  6769.         # komplexe Zahl
  6770.         { pushSTACK(number); # Zahl retten
  6771.          {var reg1 object* number_ = &STACK_0; # und merken, wo sie sitzt
  6772.           write_schar(stream_,'#'); write_schar(stream_,'C');
  6773.           KLAMMER_AUF;
  6774.           INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#C('
  6775.           JUSTIFY_START;
  6776.           pr_real_number(stream_,TheComplex(*number_)->c_real); # Realteil ausgeben
  6777.           JUSTIFY_SPACE;
  6778.           pr_real_number(stream_,TheComplex(*number_)->c_imag); # ImaginΣrteil ausgeben
  6779.           JUSTIFY_END_ENG;
  6780.           INDENT_END;
  6781.           KLAMMER_ZU;
  6782.           skipSTACK(1);
  6783.         }}
  6784.     }
  6785.  
  6786. #            -------- Arrays bei *PRINT-ARRAY*=NIL --------
  6787.  
  6788. # UP: Gibt einen Array in Kurzform auf einen Stream aus.
  6789. # pr_array_nil(&stream,obj);
  6790. # > obj: Array
  6791. # > stream: Stream
  6792. # < stream: Stream
  6793. # kann GC ausl÷sen
  6794.   local void pr_array_nil(stream_,obj)
  6795.     var reg2 object* stream_;
  6796.     var reg3 object obj;
  6797.     { pushSTACK(obj); # Array retten
  6798.      {var reg1 object* obj_ = &STACK_0; # und merken, wo er sitzt
  6799.       write_schar(stream_,'#'); write_schar(stream_,'<');
  6800.       INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  6801.       JUSTIFY_START;
  6802.       write_sstring_case(stream_,O(printstring_array)); # "ARRAY" ausgeben
  6803.       JUSTIFY_SPACE;
  6804.       prin_object_dispatch(stream_,array_element_type(*obj_)); # Elementtyp (Symbol oder Liste) ausgeben
  6805.       JUSTIFY_SPACE;
  6806.       pr_list(stream_,array_dimensions(*obj_)); # Dimensionsliste ausgeben
  6807.       if (array_has_fill_pointer_p(*obj_))
  6808.         # Array mit Fill-Pointer -> auch den Fill-Pointer ausgeben:
  6809.         { JUSTIFY_SPACE;
  6810.           write_sstring_case(stream_,O(printstring_fill_pointer)); # "FILL-POINTER=" ausgeben
  6811.           pr_uint(stream_,vector_length(*obj_)); # LΣnge (=Fill-Pointer) ausgeben
  6812.         }
  6813.       JUSTIFY_END_ENG;
  6814.       INDENT_END;
  6815.       write_schar(stream_,'>');
  6816.       skipSTACK(1);
  6817.     }}
  6818.  
  6819. #                    -------- Bit-Vektoren --------
  6820.  
  6821. # UP: Gibt einen Teil eines Simple-Bit-Vektors auf einen Stream aus.
  6822. # pr_sbvector_ab(&stream,bv,start,len);
  6823. # > bv: Simple-Bit-Vektor
  6824. # > start: Startindex
  6825. # > len: Anzahl der auszugebenden Bits
  6826. # > stream: Stream
  6827. # < stream: Stream
  6828. # kann GC ausl÷sen
  6829.   local void pr_sbvector_ab (object* stream_, object bv, uintL start, uintL len);
  6830.   local void pr_sbvector_ab(stream_,bv,start,len)
  6831.     var reg3 object* stream_;
  6832.     var reg5 object bv;
  6833.     var reg4 uintL start;
  6834.     var reg2 uintL len;
  6835.     { var reg1 uintL index = start;
  6836.       pushSTACK(bv); # Simple-Bit-Vektor retten
  6837.       write_schar(stream_,'#'); write_schar(stream_,'*');
  6838.       dotimesL(len,len,
  6839.         { write_char(stream_,
  6840.                      (sbvector_btst(STACK_0,index) ? code_char('1') : code_char('0'))
  6841.                     );
  6842.           index++;
  6843.         });
  6844.       skipSTACK(1);
  6845.     }
  6846.  
  6847. # UP: Gibt einen Bit-Vektor auf einen Stream aus.
  6848. # pr_bvector(&stream,bv);
  6849. # > bv: Bit-Vektor
  6850. # > stream: Stream
  6851. # < stream: Stream
  6852. # kann GC ausl÷sen
  6853.   local void pr_bvector(stream_,bv)
  6854.     var reg2 object* stream_;
  6855.     var reg1 object bv;
  6856.     { # *PRINT-ARRAY* abfragen:
  6857.       if (test_value(S(print_array)) || test_value(S(print_readably)))
  6858.         # bv elementweise ausgeben:
  6859.         { var reg3 uintL len = vector_length(bv); # LΣnge
  6860.           var uintL offset = 0; # Offset vom Bit-Vektor in den Datenvektor
  6861.           var reg4 object sbv = array_displace_check(bv,len,&offset); # Datenvektor
  6862.           pr_sbvector_ab(stream_,sbv,offset,len);
  6863.         }
  6864.         else
  6865.         # *PRINT-ARRAY* = NIL -> in Kurzform ausgeben:
  6866.         { pr_array_nil(stream_,bv); }
  6867.     }
  6868.  
  6869. #                -------- Allgemeine Vektoren --------
  6870.  
  6871. # UP: Gibt einen allgemeinen Vektor auf einen Stream aus.
  6872. # pr_vector(&stream,v);
  6873. # > v: allgemeiner Vektor
  6874. # > stream: Stream
  6875. # < stream: Stream
  6876. # kann GC ausl÷sen
  6877.   local void pr_vector(stream_,v)
  6878.     var reg4 object* stream_;
  6879.     var reg7 object v;
  6880.     { # *PRINT-ARRAY* abfragen:
  6881.       if (test_value(S(print_array)) || test_value(S(print_readably)))
  6882.         # v elementweise ausgeben:
  6883.         { LEVEL_CHECK;
  6884.           { var reg8 boolean readable = # Flag, ob LΣnge und Typ mit ausgegeben werden
  6885.               (test_value(S(print_readably)) && !general_vector_p(v) ? TRUE : FALSE);
  6886.             var reg6 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  6887.             var reg5 uintL length = 0; # bisherige LΣnge := 0
  6888.             # Vektor elementweise abarbeiten:
  6889.             var reg3 uintL len = vector_length(v); # Vektor-LΣnge
  6890.             var uintL offset = 0; # Offset vom Vektor in den Datenvektor
  6891.             {var reg1 object sv = array_displace_check(v,len,&offset); # Datenvektor
  6892.              pushSTACK(sv); # Simple-Vektor retten
  6893.             }
  6894.            {var reg1 object* sv_ = &STACK_0; # und merken, wo er sitzt
  6895.             var reg2 uintL index = 0 + offset; # Startindex = 0 im Vektor
  6896.             if (readable)
  6897.               { write_schar(stream_,'#'); write_schar(stream_,'A');
  6898.                 KLAMMER_AUF; # '(' ausgeben
  6899.                 INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#A('
  6900.                 JUSTIFY_START;
  6901.                 prin_object_dispatch(stream_,array_element_type(*sv_)); # Elementtyp ausgeben
  6902.                 JUSTIFY_SPACE;
  6903.                 pushSTACK(fixnum(len));
  6904.                 pr_list(stream_,listof(1)); # Liste mit der LΣnge ausgeben
  6905.                 JUSTIFY_SPACE;
  6906.                 KLAMMER_AUF; # '('
  6907.                 INDENT_START(1); # um 1 Zeichen einrⁿcken, wegen '('
  6908.               }
  6909.               else
  6910.               { write_schar(stream_,'#');
  6911.                 KLAMMER_AUF; # '('
  6912.                 INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#('
  6913.               }
  6914.             JUSTIFY_START;
  6915.             dotimesL(len,len,
  6916.               { # (au▀er vorm ersten Element) Space ausgeben:
  6917.                 if (!(length==0)) { JUSTIFY_SPACE; }
  6918.                 # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  6919.                 if (length >= length_limit)
  6920.                   { # Rest durch '...' abkⁿrzen:
  6921.                     write_schar(stream_,'.');
  6922.                     write_schar(stream_,'.');
  6923.                     write_schar(stream_,'.');
  6924.                     break;
  6925.                   }
  6926.                 # Vektorelement ausgeben:
  6927.                 prin_object(stream_,datenvektor_aref(*sv_,index));
  6928.                 length++; # LΣnge incrementieren
  6929.                 index++; # dann zum nΣchsten Vektor-Element
  6930.               });
  6931.             JUSTIFY_END_ENG;
  6932.             INDENT_END;
  6933.             KLAMMER_ZU;
  6934.             if (readable)
  6935.               { JUSTIFY_END_ENG;
  6936.                 INDENT_END;
  6937.                 KLAMMER_ZU;
  6938.               }
  6939.             skipSTACK(1);
  6940.           }}
  6941.           LEVEL_END;
  6942.         }
  6943.         else
  6944.         # *PRINT-ARRAY* = NIL -> in Kurzform ausgeben:
  6945.         { pr_array_nil(stream_,v); }
  6946.     }
  6947.  
  6948. #               -------- Mehrdimensionale Arrays --------
  6949.  
  6950. # (defun %print-array (array stream)
  6951. #   (let ((rank (array-rank array))
  6952. #         (dims (array-dimensions array))
  6953. #         (eltype (array-element-type array)))
  6954. #     (write-char #\# stream)
  6955. #     (if (zerop (array-total-size array))
  6956. #       ; wiedereinlesbare Ausgabe von leeren mehrdimensionalen Arrays
  6957. #       (progn
  6958. #         (write-char #\A stream)
  6959. #         (prin1 dims stream)
  6960. #       )
  6961. #       (progn
  6962. #         (let ((*print-base* 10.)) (prin1 rank stream))
  6963. #         (write-char #\A stream)
  6964. #         (if (and (plusp rank)
  6965. #                  (or (eq eltype 'bit) (eq eltype 'string-char))
  6966. #                  (or (null *print-length*) (>= *print-length* (array-dimension array (1- rank))))
  6967. #             )
  6968. #           ; kⁿrzere Ausgabe von mehrdimensionalen Bit- und String-Char-Arrays
  6969. #           (let* ((lastdim (array-dimension array (1- rank)))
  6970. #                  (offset 0)
  6971. #                  (sub-array (make-array 0 :element-type eltype :adjustable t)))
  6972. #             (labels ((help (dimsr)
  6973. #                        (if (null dimsr)
  6974. #                          (progn
  6975. #                            (prin1
  6976. #                              (adjust-array sub-array lastdim :displaced-to array
  6977. #                                            :displaced-index-offset offset
  6978. #                              )
  6979. #                              stream
  6980. #                            )
  6981. #                            (setq offset (+ offset lastdim))
  6982. #                          )
  6983. #                          (let ((dimsrr (rest dimsr)))
  6984. #                            (write-char #\( stream)
  6985. #                            (dotimes (i (first dimsr))
  6986. #                              (unless (zerop i) (write-char #\space stream))
  6987. #                              (help dimsrr)
  6988. #                            )
  6989. #                            (write-char #\) stream)
  6990. #                     )) ) )
  6991. #               (help (nbutlast dims))
  6992. #           ) )
  6993. #           ; normale Ausgabe von mehrdimensionalen Arrays
  6994. #           (let ((indices (make-list rank))) ; Liste von rank Indizes
  6995. #             (labels ((help (dimsr indicesr)
  6996. #                        (if (null dimsr)
  6997. #                          (prin1 (apply #'aref array indices) stream)
  6998. #                          (let ((dimsrr (rest dimsr)) (indicesrr (rest indicesr)))
  6999. #                            (write-char #\( stream)
  7000. #                            (dotimes (i (first dimsr))
  7001. #                              (unless (zerop i) (write-char #\space stream))
  7002. #                              (rplaca indicesr i)
  7003. #                              (help dimsrr indicesrr)
  7004. #                            )
  7005. #                            (write-char #\) stream)
  7006. #                     )) ) )
  7007. #               (help dims indices)
  7008. #           ) )
  7009. #       ) )
  7010. # ) ) )
  7011.  
  7012. # UP's zur Ausgabe eines Elements bzw. eines Teil-Arrays:
  7013. # pr_array_elt_xxx(&stream,obj,&info);
  7014. # > obj: Datenvektor
  7015. # > info.index: Index des ersten auszugebenden Elements
  7016. # > info.count: Anzahl der auszugebenden Elemente
  7017. # > stream: Stream
  7018. # < stream: Stream
  7019. # < info.index: um info.count erh÷ht
  7020. # kann GC ausl÷sen
  7021.   typedef struct { uintL index; uintL count; }  pr_array_info;
  7022.   typedef void pr_array_elt_routine (object* stream_, object obj, pr_array_info* info);
  7023. # UP zur Ausgabe eines Elements:
  7024. # Bei ihr ist info.count = 1.
  7025.   local_function pr_array_elt_routine pr_array_elt_t;
  7026. # Zwei UPs zur Ausgabe eines Teil-Arrays:
  7027.   local_function pr_array_elt_routine pr_array_elt_bvector; # Teilarray ist Bit-Vektor
  7028.   local_function pr_array_elt_routine pr_array_elt_string; # Teilarray ist String
  7029.  
  7030.   local void pr_array_elt_t(stream_,obj,info)
  7031.     var reg3 object* stream_;
  7032.     var reg1 object obj; # Simple-Vektor
  7033.     var reg2 pr_array_info* info;
  7034.     { # Element von allgemeinem Typ holen und ausgeben:
  7035.       prin_object(stream_,datenvektor_aref(obj,info->index));
  7036.       info->index++;
  7037.     }
  7038.  
  7039.   local void pr_array_elt_bvector(stream_,obj,info)
  7040.     var reg3 object* stream_;
  7041.     var reg2 object obj; # Simple-Bit-Vektor
  7042.     var reg1 pr_array_info* info;
  7043.     { # Teil-Bit-Vektor ausgeben:
  7044.       pr_sbvector_ab(stream_,obj,info->index,info->count);
  7045.       info->index += info->count;
  7046.     }
  7047.  
  7048.   local void pr_array_elt_string(stream_,obj,info)
  7049.     var reg3 object* stream_;
  7050.     var reg2 object obj; # Simple-String
  7051.     var reg1 pr_array_info* info;
  7052.     { # Teil-String ausgeben:
  7053.       pr_sstring_ab(stream_,obj,info->index,info->count);
  7054.       info->index += info->count;
  7055.     }
  7056.  
  7057. # UP: Gibt einen Teil eines Arrays aus.
  7058. # pr_array_rekursion(locals,depth);
  7059. # > depth: Rekursionstiefe
  7060. # > locals: Variablen:
  7061. #     *(locals->stream_) :   Stream
  7062. #     *(locals->obj_) :      Datenvektor
  7063. #     locals->dims_sizes:    Adresse der Tabelle der Dimensionen des Arrays
  7064. #                            und ihrer Teilprodukte
  7065. #     *(locals->pr_one_elt): Funktion zur Ausgabe eines Elements/Teil-Arrays
  7066. #     locals->info:          Parameter fⁿr diese Funktion
  7067. #     locals->info.index:    Start-Index im Datenvektor
  7068. #     locals->length_limit:  LΣngenbegrenzung
  7069. # < locals->info.index: End-Index im Datenvektor
  7070. # kann GC ausl÷sen
  7071.   typedef struct { object* stream_;
  7072.                    object* obj_;
  7073.                    array_dim_size* dims_sizes;
  7074.                    pr_array_elt_routine* pr_one_elt;
  7075.                    pr_array_info info;
  7076.                    uintL length_limit;
  7077.                  }
  7078.           pr_array_locals;
  7079.   local void pr_array_rekursion (pr_array_locals* locals, uintL depth);
  7080.   local void pr_array_rekursion(locals,depth)
  7081.     var reg1 pr_array_locals* locals;
  7082.     var reg5 uintL depth;
  7083.     { check_SP(); check_STACK();
  7084.       if (depth==0)
  7085.         # Rekursionstiefe 0 -> Rekursionsbasis
  7086.         { (*(locals->pr_one_elt)) # Funktion pr_one_elt aufrufen, mit
  7087.             (locals->stream_, # Streamadresse,
  7088.              *(locals->obj_), # Datenvektor obj,
  7089.              &(locals->info) # Infopointer
  7090.             ); # als Argumenten
  7091.           # Diese Funktion erh÷ht locals->info.index selbst.
  7092.         }
  7093.         else
  7094.         { depth--; # Rekursionstiefe verkleinern (noch >=0)
  7095.          {var reg2 object* stream_ = locals->stream_;
  7096.           var reg3 uintL length = 0; # bisherige LΣnge := 0
  7097.           var reg6 uintL endindex = locals->info.index # Start-Index im Datenvektor
  7098.                                     + locals->dims_sizes[depth].dimprod # + Dimensionenprodukt
  7099.                                     ; # liefert den End-Index dieses Teil-Arrays
  7100.           var reg4 uintL count = locals->dims_sizes[depth].dim;
  7101.           KLAMMER_AUF; # '(' ausgeben
  7102.           INDENT_START(1); # um 1 Zeichen einrⁿcken, wegen '('
  7103.           JUSTIFY_START;
  7104.           # Schleife ⁿber Dimension (r-depth): jeweils einen Teil-Array ausgeben
  7105.           dotimesL(count,count,
  7106.             { # (au▀er vorm ersten Teil-Array) Space ausgeben:
  7107.               if (!(length==0)) { JUSTIFY_SPACE; }
  7108.               # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7109.               if (length >= locals->length_limit)
  7110.                 { # Rest durch '...' abkⁿrzen:
  7111.                   write_schar(stream_,'.');
  7112.                   write_schar(stream_,'.');
  7113.                   write_schar(stream_,'.');
  7114.                   break;
  7115.                 }
  7116.               # Teil-Array ausgeben:
  7117.               # (rekursiv, mit verkleinerter depth, und locals->info.index
  7118.               # wird ohne weiteres Zutun von einem Aufruf zum nΣchsten
  7119.               # weitergereicht)
  7120.               pr_array_rekursion(locals,depth);
  7121.               length++; # LΣnge incrementieren
  7122.               # locals->info.index ist schon incrementiert
  7123.             });
  7124.           JUSTIFY_END_WEIT;
  7125.           INDENT_END;
  7126.           KLAMMER_ZU; # ')' ausgeben
  7127.           locals->info.index = endindex; # jetzt am End-Index angelangt
  7128.         }}
  7129.     }
  7130.  
  7131. # UP: Gibt einen mehrdimensionalen Array auf einen Stream aus.
  7132. # pr_array(&stream,obj);
  7133. # > obj: mehrdimensionaler Array
  7134. # > stream: Stream
  7135. # < stream: Stream
  7136. # kann GC ausl÷sen
  7137.   local void pr_array(stream_,obj)
  7138.     var reg3 object* stream_;
  7139.     var reg2 object obj;
  7140.     { # *PRINT-ARRAY* abfragen:
  7141.       if (test_value(S(print_array)) || test_value(S(print_readably)))
  7142.         # obj elementweise ausgeben:
  7143.         {   LEVEL_CHECK;
  7144.          {  # Rang bestimmen und Dimensionen und Teilprodukte holen:
  7145.             var reg4 uintL r = (uintL)(TheArray(obj)->rank); # Rang
  7146.             var DYNAMIC_ARRAY(reg7,dims_sizes,array_dim_size,r); # dynamisch allozierter Array
  7147.             array_dims_sizes(obj,dims_sizes); # fⁿllen
  7148.           { var reg5 uintL depth = r; # Tiefe der Rekursion
  7149.             var pr_array_locals locals; # lokale Variablen
  7150.             var reg9 boolean readable = TRUE; # Flag, ob Dimensionen und Typ mit ausgegeben werden
  7151.             locals.stream_ = stream_;
  7152.             locals.dims_sizes = dims_sizes;
  7153.             locals.length_limit = get_print_length(); # LΣngenbegrenzung
  7154.             # Entscheidung ⁿber zu verwendende Routine:
  7155.             {var reg1 uintB atype = TheArray(obj)->flags & arrayflags_atype_mask;
  7156.              if ((r>0) && (locals.length_limit >= dims_sizes[0].dim))
  7157.                { switch (atype)
  7158.                    { case Atype_Bit:
  7159.                        # ganze Bitvektoren statt einzelnen Bits ausgeben
  7160.                        locals.pr_one_elt = &pr_array_elt_bvector;
  7161.                        goto nicht_einzeln;
  7162.                      case Atype_String_Char:
  7163.                        # ganze Strings statt einzelnen Characters ausgeben
  7164.                        locals.pr_one_elt = &pr_array_elt_string;
  7165.                      nicht_einzeln:
  7166.                        # Nicht einzelne Elemente, sondern eindimensionale
  7167.                        # Teil-Arrays ausgeben.
  7168.                        depth--; # dafⁿr depth := r-1
  7169.                        locals.info.count = dims_sizes[0].dim; # Dim_r als "ElementarlΣnge"
  7170.                        locals.dims_sizes++; # betrachte nur noch Dim_1, ..., Dim_(r-1)
  7171.                        readable = FALSE; # automatisch wiedereinlesbar
  7172.                        goto routine_ok;
  7173.                      default: ;
  7174.                }   }
  7175.              locals.pr_one_elt = &pr_array_elt_t;
  7176.              locals.info.count = 1; # 1 als "ElementarlΣnge"
  7177.              if (atype==Atype_T)
  7178.                { readable = FALSE; } # automatisch wiedereinlesbar
  7179.              routine_ok:
  7180.              locals.info.index = 0; # Start-Index ist 0
  7181.             }
  7182.             if (!test_value(S(print_readably)))
  7183.               { readable = FALSE; } # braucht nicht wiedereinlesbar zu sein
  7184.             pushSTACK(obj); # Array retten
  7185.            {var reg8 object* obj_ = &STACK_0; # und merken, wo er sitzt
  7186.             # Datenvektor holen:
  7187.             var reg6 uintL size = TheArray(obj)->totalsize;
  7188.             if (size == 0)
  7189.               { readable = TRUE; } # sonst wei▀ man nicht einmal die Dimensionen
  7190.             obj = array1_displace_check(obj,size,&locals.info.index); # Datenvektor
  7191.             # locals.info.index = Offset vom Array in den Datenvektor
  7192.             pushSTACK(obj); locals.obj_ = &STACK_0; # obj im Stack unterbringen
  7193.             # Los geht's.
  7194.             if (readable)
  7195.               { write_schar(stream_,'#'); write_schar(stream_,'A');
  7196.                 KLAMMER_AUF; # '(' ausgeben
  7197.                 INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#A('
  7198.                 JUSTIFY_START;
  7199.                 prin_object_dispatch(stream_,array_element_type(*obj_)); # Elementtyp (Symbol oder Liste) ausgeben
  7200.                 JUSTIFY_SPACE;
  7201.                 pr_list(stream_,array_dimensions(*obj_)); # Dimensionsliste ausgeben
  7202.                 JUSTIFY_SPACE;
  7203.                 pr_array_rekursion(&locals,depth); # Array-Elemente ausgeben
  7204.                 JUSTIFY_END_ENG;
  7205.                 INDENT_END;
  7206.                 KLAMMER_ZU; # ')' ausgeben
  7207.               }
  7208.               else
  7209.               { # Erst PrΣfix #nA ausgeben:
  7210.                 INDENTPREP_START;
  7211.                 write_schar(stream_,'#');
  7212.                 pr_uint(stream_,r); # Rang dezimal ausgeben
  7213.                 write_schar(stream_,'A');
  7214.                 {var reg1 uintL indent = INDENTPREP_END;
  7215.                 # Dann die Array-Elemente ausgeben:
  7216.                  INDENT_START(indent);
  7217.                 }
  7218.                 pr_array_rekursion(&locals,depth);
  7219.                 INDENT_END;
  7220.               }
  7221.             skipSTACK(2);
  7222.             FREE_DYNAMIC_ARRAY(dims_sizes);
  7223.             LEVEL_END;
  7224.         }}}}
  7225.         else
  7226.         # *PRINT-ARRAY* = NIL -> in Kurzform ausgeben:
  7227.         { pr_array_nil(stream_,obj); }
  7228.     }
  7229.  
  7230. #                     -------- Structures --------
  7231.  
  7232. # (defun %print-structure (structure stream)
  7233. #   (let ((name (type-of structure)))
  7234. #     (let ((fun (get name 'STRUCTURE-PRINT)))
  7235. #       (if fun
  7236. #         (funcall fun structure stream *PRIN-LEVEL*)
  7237. #         (let ((description (get name 'DEFSTRUCT-DESCRIPTION)))
  7238. #           (if description
  7239. #             (let ((readable (svref description 2)))
  7240. #               (write-string (if readable "#S(" "#<") stream)
  7241. #               (prin1 name stream)
  7242. #               (dolist (slot (svref description 3))
  7243. #                 (when (first slot)
  7244. #                   (write-char #\space stream)
  7245. #                   (prin1 (intern (symbol-name (first slot)) *KEYWORD-PACKAGE*) stream)
  7246. #                   (write-char #\space stream)
  7247. #                   (prin1 (%structure-ref name structure (second slot)) stream)
  7248. #               ) )
  7249. #               (write-string (if readable ")" ">") stream)
  7250. #             )
  7251. #             (progn
  7252. #               (write-string "#<" stream)
  7253. #               (prin1 name stream)
  7254. #               (do ((l (%record-length structure))
  7255. #                    (i 1 (1+ i)))
  7256. #                   ((>= i l))
  7257. #                 (write-char #\space stream)
  7258. #                 (prin1 (%structure-ref name structure i) stream)
  7259. #               )
  7260. #               (write-string ">" stream)
  7261. # ) ) ) ) ) ) )
  7262.  
  7263. # Vorbereitung des Aufrufs einer externen Print-Funktion
  7264. # pr_external_1(stream)
  7265. # > stream: Stream
  7266. # < ergebnis: Anzahl dynamische Bindungen, die aufzul÷sen sind.
  7267.   local uintC pr_external_1 (object stream);
  7268.   local uintC pr_external_1(stream)
  7269.     var reg3 object stream;
  7270.     { var reg2 uintC count = 1;
  7271.       if (test_value(S(print_readably)))
  7272.         { # Damit die benutzerdefinierten Print-Funktionen, die noch nichts
  7273.           # von *PRINT-READABLY* wissen, sich trotzdem danach benehmen,
  7274.           # binden wir die anderen Printer-Variablen passend:
  7275.           # *PRINT-READABLY* erzwingt *PRINT-ESCAPE* = T :
  7276.           if (!test_value(S(print_escape)))
  7277.             { dynamic_bind(S(print_escape),T); count++; }
  7278.           # *PRINT-READABLY* erzwingt *PRINT-BASE* = 10 :
  7279.           if (!eq(Symbol_value(S(print_base)),fixnum(10)))
  7280.             { dynamic_bind(S(print_base),fixnum(10)); count++; }
  7281.           # *PRINT-READABLY* erzwingt *PRINT-RADIX* = T :
  7282.           if (!test_value(S(print_radix)))
  7283.             { dynamic_bind(S(print_radix),T); count++; }
  7284.           # *PRINT-READABLY* erzwingt *PRINT-CIRCLE* = T :
  7285.           if (!test_value(S(print_circle)))
  7286.             { dynamic_bind(S(print_circle),T); count++; }
  7287.           # *PRINT-READABLY* erzwingt *PRINT-LEVEL* = NIL :
  7288.           if (test_value(S(print_level)))
  7289.             { dynamic_bind(S(print_level),NIL); count++; }
  7290.           # *PRINT-READABLY* erzwingt *PRINT-LENGTH* = NIL :
  7291.           if (test_value(S(print_length)))
  7292.             { dynamic_bind(S(print_length),NIL); count++; }
  7293.           # *PRINT-READABLY* erzwingt *PRINT-GENSYM* = T :
  7294.           if (!test_value(S(print_gensym)))
  7295.             { dynamic_bind(S(print_gensym),T); count++; }
  7296.           # *PRINT-READABLY* erzwingt *PRINT-ARRAY* = T :
  7297.           if (!test_value(S(print_array)))
  7298.             { dynamic_bind(S(print_array),T); count++; }
  7299.           # *PRINT-READABLY* erzwingt *PRINT-CLOSURE* = T :
  7300.           if (!test_value(S(print_closure)))
  7301.             { dynamic_bind(S(print_closure),T); count++; }
  7302.         }
  7303.       # SYS::*PRIN-STREAM* an stream binden:
  7304.       dynamic_bind(S(prin_stream),stream);
  7305.       return count;
  7306.     }
  7307.  
  7308. # Nachbereitung des Aufrufs einer externen Print-Funktion
  7309. # pr_external_2(count);
  7310. # > count: Anzahl dynamische Bindungen, die aufzul÷sen sind.
  7311.   #define pr_external_2(countvar)  \
  7312.     dotimespC(countvar,countvar, { dynamic_unbind(); } );
  7313.  
  7314. # UP: Aufruf einer (externen) Print-Funktion fⁿr Structures
  7315. # pr_structure_external(&stream,structure,function);
  7316. # > stream: Stream
  7317. # > structure: Structure
  7318. # > function: Print-Funktion fⁿr Structures dieses Typs
  7319. # kann GC ausl÷sen
  7320.   local void pr_structure_external (object* stream_, object structure, object function);
  7321.   local void pr_structure_external(stream_,structure,function)
  7322.     var reg3 object* stream_;
  7323.     var reg4 object structure;
  7324.     var reg5 object function;
  7325.     { var reg2 object stream = *stream_;
  7326.       var reg1 uintC count = pr_external_1(stream); # Bindungen erstellen
  7327.       # (funcall fun Structure Stream SYS::*PRIN-LEVEL*) :
  7328.       pushSTACK(structure); # Structure als 1. Argument
  7329.       pushSTACK(stream); # Stream als 2. Argument
  7330.       pushSTACK(Symbol_value(S(prin_level))); # Wert von SYS::*PRIN-LEVEL* als 3. Argument
  7331.       funcall(function,3);
  7332.       pr_external_2(count); # Bindungen aufl÷sen
  7333.     }
  7334.  
  7335. # UP: Gibt eine Structure auf einen Stream aus.
  7336. # pr_structure(&stream,structure);
  7337. # > structure: Structure
  7338. # > stream: Stream
  7339. # < stream: Stream
  7340. # kann GC ausl÷sen
  7341.   local void pr_structure(stream_,structure)
  7342.     var reg3 object* stream_;
  7343.     var reg10 object structure;
  7344.     { LEVEL_CHECK;
  7345.       # Typ der Structure bestimmen (vgl. TYPE-OF):
  7346.       { var reg10 object name = Car(TheStructure(structure)->structure_types);
  7347.         # name = (car '(name_1 ... name_i-1 name_i)) = name_1.
  7348.         pushSTACK(structure);
  7349.         pushSTACK(name);
  7350.       # Stackaufbau: structure, name.
  7351.       # (GET name 'SYS::STRUCTURE-PRINT) ausfⁿhren:
  7352.        {var reg10 object fun = get(name,S(structure_print));
  7353.         if (!eq(fun,unbound))
  7354.           # vorgegebene Print-Funktion aufrufen:
  7355.           { structure = STACK_1;
  7356.             # Dabei *PRINT-CIRCLE* beachten:
  7357.             # *PRINT-CIRCLE* = NIL ->
  7358.             # Fⁿr den Fall, da▀ *PRINT-CIRCLE* an T gebunden werden wird,
  7359.             # mu▀ SYS::*PRINT-CIRCLE-TABLE* an #<UNBOUND> gebunden werden
  7360.             # (es sei denn, es ist bereits = #<UNBOUND>).
  7361.             if ((!test_value(S(print_circle)))
  7362.                 && (!eq(Symbol_value(S(print_circle_table)),unbound))
  7363.                )
  7364.               { dynamic_bind(S(print_circle_table),unbound);
  7365.                 pr_structure_external(stream_,structure,fun);
  7366.                 dynamic_unbind();
  7367.               }
  7368.               else
  7369.               { pr_structure_external(stream_,structure,fun); }
  7370.             skipSTACK(2);
  7371.           }
  7372.           else
  7373.           # keine vorgegebene Print-Funktion gefunden.
  7374.           { # Stackaufbau: structure, name.
  7375.             var reg4 object* structure_ = &STACK_1;
  7376.             # Es ist *(structure_ STACKop 0) = structure
  7377.             # und    *(structure_ STACKop -1) = name .
  7378.             # (GET name 'SYS::DEFSTRUCT-DESCRIPTION) ausfⁿhren:
  7379.             var reg8 object description = get(name,S(defstruct_description));
  7380.             if (!eq(description,unbound))
  7381.               # Structure mit Slot-Namen ausgeben:
  7382.               { pushSTACK(description);
  7383.                 # Stackaufbau: structure, name, description.
  7384.                 # description mu▀ ein Simple-Vector der LΣnge >=4 sein !
  7385.                 if (!(simple_vector_p(description)
  7386.                       && (TheSvector(description)->length >= 4)
  7387.                    ) )
  7388.                   { bad_description:
  7389.                     pushSTACK(S(defstruct_description));
  7390.                     pushSTACK(S(print));
  7391.                     fehler(error,
  7392.                            DEUTSCH ? "~: Schlecht aufgebaute ~" :
  7393.                            ENGLISH ? "~: bad ~" :
  7394.                            FRANCAIS ? "~ : Mauvaise ~" :
  7395.                            ""
  7396.                           );
  7397.                   }
  7398.                {var reg9 boolean readable = # TRUE falls (svref description 2) /= NIL
  7399.                   !nullp(TheSvector(description)->data[2]);
  7400.                 if (readable)
  7401.                   # Structure wiedereinlesbar ausgeben:
  7402.                   { write_schar(stream_,'#'); write_schar(stream_,'S');
  7403.                     KLAMMER_AUF;
  7404.                     INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#S('
  7405.                   }
  7406.                   else
  7407.                   # Structure nicht wiedereinlesbar ausgeben:
  7408.                   { if (test_value(S(print_readably))) { fehler_print_readably(*structure_); }
  7409.                     write_schar(stream_,'#'); write_schar(stream_,'<');
  7410.                     INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7411.                   }
  7412.                 JUSTIFY_START;
  7413.                 prin_object(stream_,*(structure_ STACKop -1)); # name ausgeben
  7414.                 pushSTACK(TheSvector(*(structure_ STACKop -2))->data[3]);
  7415.                 # Slot-Liste STACK_0 = (svref description 3) durchlaufen:
  7416.                 { var reg7 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7417.                   var reg6 uintL length = 0; # bisherige LΣnge := 0
  7418.                   while (mconsp(STACK_0))
  7419.                     { var reg5 object slot = STACK_0;
  7420.                       STACK_0 = Cdr(slot); # Liste verkⁿrzen
  7421.                       slot = Car(slot); # ein einzelner slot
  7422.                       if (!consp(slot)) goto bad_description; # sollte ein Cons sein
  7423.                       if (!nullp(Car(slot))) # Slot (NIL ...) ⁿbergehen
  7424.                         { pushSTACK(slot); # Slot retten
  7425.                           JUSTIFY_SPACE; # Space ausgeben
  7426.                           # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7427.                           if (length >= length_limit)
  7428.                             { # Rest durch '...' abkⁿrzen:
  7429.                               write_schar(stream_,'.');
  7430.                               write_schar(stream_,'.');
  7431.                               write_schar(stream_,'.');
  7432.                               skipSTACK(1); # slot vergessen
  7433.                               break;
  7434.                             }
  7435.                          {var reg1 object* slot_ = &STACK_0; # da sitzt der Slot
  7436.                           JUSTIFY_START;
  7437.                           write_schar(stream_,':'); # Keyword-Kennzeichen
  7438.                           {var reg4 object obj = Car(*slot_); # (first slot)
  7439.                            if (!symbolp(obj)) goto bad_description; # sollte ein Symbol sein
  7440.                            pr_like_symbol(stream_,Symbol_name(obj)); # Symbolnamen der Komponente ausgeben
  7441.                           }
  7442.                           JUSTIFY_SPACE;
  7443.                           {var reg4 object obj = Cdr(*slot_); # (cdr slot)
  7444.                            if (!consp(obj)) goto bad_description; # sollte ein Cons sein
  7445.                            # (SYS::%STRUCTURE-REF name Structure (second slot)) ausfⁿhren:
  7446.                            pushSTACK(*(structure_ STACKop -1)); # name als 1. Argument
  7447.                            pushSTACK(*(structure_ STACKop 0)); # Structure als 2. Argument
  7448.                            pushSTACK(Car(obj)); # (second slot) als 3. Argument
  7449.                            funcall(L(structure_ref),3);
  7450.                           }
  7451.                           prin_object(stream_,value1); # Komponente ausgeben
  7452.                           JUSTIFY_END_ENG;
  7453.                           skipSTACK(1); # slot vergessen
  7454.                     }   }}
  7455.                 }
  7456.                 skipSTACK(1);
  7457.                 JUSTIFY_END_ENG;
  7458.                 if (readable) # Beendung der Fallunterscheidung von oben
  7459.                   { INDENT_END;
  7460.                     KLAMMER_ZU;
  7461.                   }
  7462.                   else
  7463.                   { INDENT_END;
  7464.                     write_schar(stream_,'>');
  7465.                   }
  7466.                 skipSTACK(3);
  7467.               }}
  7468.               else
  7469.               # Structure elementweise, ohne Komponenten-Namen ausgeben.
  7470.               { if (test_value(S(print_readably))) { fehler_print_readably(*structure_); }
  7471.                 write_schar(stream_,'#'); write_schar(stream_,'<');
  7472.                 INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7473.                 JUSTIFY_START;
  7474.                 prin_object(stream_,*(structure_ STACKop -1)); # name ausgeben
  7475.                {var reg1 uintC len = TheStructure(*structure_)->reclength; # LΣnge der Structure (>=1)
  7476.                 var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7477.                 var reg4 uintL length = 0; # Index = bisherige LΣnge := 0
  7478.                 dotimesC(len,len-1,
  7479.                   { JUSTIFY_SPACE; # Space ausgeben
  7480.                     # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7481.                     if (length >= length_limit)
  7482.                       { # Rest durch '...' abkⁿrzen:
  7483.                         write_schar(stream_,'.');
  7484.                         write_schar(stream_,'.');
  7485.                         write_schar(stream_,'.');
  7486.                         break;
  7487.                       }
  7488.                     length++; # Index erh÷hen
  7489.                     # Komponente ausgeben:
  7490.                     prin_object(stream_,TheStructure(*structure_)->recdata[length]);
  7491.                   });
  7492.                 JUSTIFY_END_ENG;
  7493.                 INDENT_END;
  7494.                 write_schar(stream_,'>');
  7495.                 skipSTACK(2);
  7496.               }}
  7497.           }
  7498.       }}
  7499.       LEVEL_END;
  7500.     }
  7501.  
  7502. #                 -------- Maschinenpointer --------
  7503.  
  7504. # UP: Gibt einen Objekt #<BLABLA #x......> auf einen Stream aus.
  7505. # pr_hex6_obj(&stream,obj,string);
  7506. # > obj: Objekt
  7507. # > string: Simple-String "BLABLA"
  7508. # > stream: Stream
  7509. # < stream: Stream
  7510. # kann GC ausl÷sen
  7511.   local void pr_hex6_obj (object* stream_, object obj, object string);
  7512.   local void pr_hex6_obj(stream_,obj,string)
  7513.     var reg1 object* stream_;
  7514.     var reg4 object obj;
  7515.     var reg3 object string;
  7516.     { pushSTACK(string); # String retten
  7517.      {var reg2 object* string_ = &STACK_0; # und merken, wo er sitzt
  7518.       write_schar(stream_,'#'); write_schar(stream_,'<');
  7519.       INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7520.       JUSTIFY_START;
  7521.       write_sstring_case(stream_,*string_); # String ausgeben
  7522.       JUSTIFY_SPACE;
  7523.       pr_hex6(stream_,obj); # obj als Adresse ausgeben
  7524.       JUSTIFY_END_ENG;
  7525.       INDENT_END;
  7526.       write_schar(stream_,'>');
  7527.       skipSTACK(1);
  7528.     }}
  7529.  
  7530. # UP: Gibt einen Maschinenpointer auf einen Stream aus.
  7531. # pr_machine(&stream,obj);
  7532. # > obj: Maschinenpointer
  7533. # > stream: Stream
  7534. # < stream: Stream
  7535. # kann GC ausl÷sen
  7536.   local void pr_machine(stream_,obj)
  7537.     var reg1 object* stream_;
  7538.     var reg2 object obj;
  7539.     { # #<ADDRESS #x...>
  7540.       if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7541.       pr_hex6_obj(stream_,obj,O(printstring_address));
  7542.     }
  7543.  
  7544. #        -------- Frame-Pointer, Read-Label, System --------
  7545.  
  7546. # UP: Gibt einen Systempointer auf einen Stream aus.
  7547. # pr_system(&stream,obj);
  7548. # > obj: Systempointer
  7549. # > stream: Stream
  7550. # < stream: Stream
  7551. # kann GC ausl÷sen
  7552.   local void pr_system(stream_,obj)
  7553.     var reg2 object* stream_;
  7554.     var reg1 object obj;
  7555.     { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7556.       if (as_oint(obj) & wbit(0 + oint_addr_shift))
  7557.         if (as_oint(obj) & wbit(oint_data_len-1 + oint_addr_shift))
  7558.           # System-Pointer
  7559.           { if (eq(obj,unbound)) # #<UNBOUND>
  7560.               { write_sstring_case(stream_,O(printstring_unbound)); }
  7561.             elif (eq(obj,specdecl)) # #<SPECIAL REFERENCE>
  7562.               { write_sstring_case(stream_,O(printstring_special_reference)); }
  7563.             elif (eq(obj,disabled)) # #<DISABLED POINTER>
  7564.               { write_sstring_case(stream_,O(printstring_disabled_pointer)); }
  7565.             elif (eq(obj,dot_value)) # #<DOT>
  7566.               { write_sstring_case(stream_,O(printstring_dot)); }
  7567.             elif (eq(obj,eof_value)) # #<END OF FILE>
  7568.               { write_sstring_case(stream_,O(printstring_eof)); }
  7569.             else # #<SYSTEM-POINTER #x...>
  7570.               { pr_hex6_obj(stream_,obj,O(printstring_system)); }
  7571.           }
  7572.           else
  7573.           # Read-Label
  7574.           { # #<READ-LABEL ...>
  7575.             write_schar(stream_,'#'); write_schar(stream_,'<');
  7576.             INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7577.             JUSTIFY_START;
  7578.             write_sstring_case(stream_,O(printstring_read_label)); # "READ-LABEL"
  7579.             JUSTIFY_SPACE;
  7580.             pr_uint(stream_,(as_oint(obj) >> (oint_addr_shift+1)) & (bit(oint_data_len-2)-1)); # Bits 21..0 dezimal ausgeben
  7581.             JUSTIFY_END_ENG;
  7582.             INDENT_END;
  7583.             write_schar(stream_,'>');
  7584.           }
  7585.         else
  7586.         # Frame-Pointer
  7587.         { # #<FRAME-POINTER #x...>
  7588.           pr_hex6_obj(stream_,obj,O(printstring_frame_pointer));
  7589.         }
  7590.     }
  7591.  
  7592. #                        -------- Records --------
  7593.  
  7594. # UP: Gibt den Rest eines Record aus. Nur innerhalb eines JUSTIFY-Blocks!
  7595. # Die Ausgabe fΣngt im Normalfall mit einem JUSTIFY_SPACE an.
  7596. # pr_record_ab(&stream,&obj,start,now);
  7597. # > obj: Record
  7598. # > start: Startindex
  7599. # > now: Anzahl der bereits ausgegebenen Items (fⁿr *PRINT-LENGTH*)
  7600. # > stream: Stream
  7601. # < stream: Stream
  7602. # kann GC ausl÷sen
  7603.   local void pr_record_ab (object* stream_, object* obj_, uintL index, uintL length);
  7604.   local void pr_record_ab(stream_,obj_,index,length)
  7605.     var reg2 object* stream_;
  7606.     var reg1 object* obj_;
  7607.     var reg3 uintL index;
  7608.     var reg4 uintL length;
  7609.     { var reg5 uintL len = (uintL)(TheRecord(*obj_)->reclength); # LΣnge des Record
  7610.       var reg6 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7611.       loop
  7612.         { if (index >= len) break; # Index >= RecordlΣnge -> fertig
  7613.           JUSTIFY_SPACE; # Space ausgeben
  7614.           # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7615.           if (length >= length_limit)
  7616.             { # Rest durch '...' abkⁿrzen:
  7617.               write_schar(stream_,'.');
  7618.               write_schar(stream_,'.');
  7619.               write_schar(stream_,'.');
  7620.               break;
  7621.             }
  7622.           # Komponente ausgeben:
  7623.           prin_object(stream_,TheRecord(*obj_)->recdata[index]);
  7624.           length++; # bisherige LΣnge erh÷hen
  7625.           index++; # zur nΣchsten Komponente
  7626.         }
  7627.     }
  7628.  
  7629. # UP: Gibt eine Liste als Rest eines Record aus.
  7630. # Nur innerhalb eines JUSTIFY-Blocks!
  7631. # Die Ausgabe fΣngt im Normalfall mit einem JUSTIFY_SPACE an.
  7632. # pr_record_rest(&stream,obj,now);
  7633. # > obj: Liste
  7634. # > now: Anzahl der bereits ausgegebenen Items (fⁿr *PRINT-LENGTH*)
  7635. # > stream: Stream
  7636. # < stream: Stream
  7637. # kann GC ausl÷sen
  7638.   local void pr_record_rest (object* stream_, object obj, uintL length);
  7639.   local void pr_record_rest(stream_,obj,length)
  7640.     var reg2 object* stream_;
  7641.     var reg5 object obj;
  7642.     var reg3 uintL length;
  7643.     { var reg4 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7644.       pushSTACK(obj);
  7645.       while (mconsp(STACK_0))
  7646.         { JUSTIFY_SPACE; # Space ausgeben
  7647.           # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7648.           if (length >= length_limit)
  7649.             { # Rest durch '...' abkⁿrzen:
  7650.               write_schar(stream_,'.');
  7651.               write_schar(stream_,'.');
  7652.               write_schar(stream_,'.');
  7653.               break;
  7654.             }
  7655.           {var reg1 object list = STACK_0;
  7656.            STACK_0 = Cdr(list); # Liste verkⁿrzen
  7657.            prin_object(stream_,Car(list)); # Element der Liste ausgeben
  7658.           }
  7659.           length++; # LΣnge incrementieren
  7660.         }
  7661.       skipSTACK(1);
  7662.     }
  7663.  
  7664. # UP: Gibt einen OtherRecord mit Slotnamen auf einen Stream aus.
  7665. # pr_record_descr(&stream,obj,name,readable,slotlist);
  7666. # > obj: OtherRecord
  7667. # > name: Struktur-Name
  7668. # > readable: Flag, ob wiedereinlesbar auszugeben
  7669. # > slotlist: Liste ((slotname . accessor) ...)
  7670. # > stream: Stream
  7671. # < stream: Stream
  7672. # kann GC ausl÷sen
  7673.   local void pr_record_descr (object* stream_, object obj, object name, boolean readable, object slotlist);
  7674.   local void pr_record_descr(stream_,obj,name,readable,slotlist)
  7675.     var reg2 object* stream_;
  7676.     var reg7 object obj;
  7677.     var reg8 object name;
  7678.     var reg8 boolean readable;
  7679.     var reg9 object slotlist;
  7680.     { LEVEL_CHECK;
  7681.       pushSTACK(obj);
  7682.       pushSTACK(name);
  7683.       pushSTACK(slotlist);
  7684.       # Stackaufbau: obj, name, slotlist.
  7685.      {var reg3 object* obj_ = &STACK_2;
  7686.       # Es ist *(obj_ STACKop 0) = obj
  7687.       # und    *(obj_ STACKop -1) = name
  7688.       # und    *(obj_ STACKop -2) = slotlist .
  7689.       if (readable)
  7690.         # obj wiedereinlesbar ausgeben:
  7691.         { write_schar(stream_,'#'); write_schar(stream_,'S');
  7692.           KLAMMER_AUF;
  7693.           INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#S('
  7694.         }
  7695.         else
  7696.         # obj nicht wiedereinlesbar ausgeben:
  7697.         { if (test_value(S(print_readably))) { fehler_print_readably(STACK_2); }
  7698.           write_schar(stream_,'#'); write_schar(stream_,'<');
  7699.           INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7700.         }
  7701.       JUSTIFY_START;
  7702.       prin_object(stream_,*(obj_ STACKop -1)); # name ausgeben
  7703.       pushSTACK(*(obj_ STACKop -2));
  7704.       # Slot-Liste STACK_0 = (svref description 3) durchlaufen:
  7705.       { var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7706.         var reg4 uintL length = 0; # bisherige LΣnge := 0
  7707.         while (mconsp(STACK_0))
  7708.           { {var reg1 object slotlistr = STACK_0;
  7709.              STACK_0 = Cdr(slotlistr); # Liste verkⁿrzen
  7710.              pushSTACK(Car(slotlistr)); # ein einzelner slot
  7711.             }
  7712.             JUSTIFY_SPACE; # Space ausgeben
  7713.             # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7714.             if (length >= length_limit)
  7715.               { # Rest durch '...' abkⁿrzen:
  7716.                 write_schar(stream_,'.');
  7717.                 write_schar(stream_,'.');
  7718.                 write_schar(stream_,'.');
  7719.                 skipSTACK(1); # slot vergessen
  7720.                 break;
  7721.               }
  7722.            {var reg1 object* slot_ = &STACK_0; # da sitzt der Slot
  7723.             JUSTIFY_START;
  7724.             write_schar(stream_,':'); # Keyword-Kennzeichen
  7725.             # (first slot) sollte ein Symbol sein
  7726.             pr_like_symbol(stream_,Symbol_name(Car(*slot_))); # Symbolnamen der Komponente ausgeben
  7727.             JUSTIFY_SPACE;
  7728.             pushSTACK(*(obj_ STACKop 0)); # obj als Argument
  7729.             funcall(Cdr(*slot_),1); # accessor aufrufen
  7730.             prin_object(stream_,value1); # Komponente ausgeben
  7731.             JUSTIFY_END_ENG;
  7732.             skipSTACK(1); # slot vergessen
  7733.       }   }}
  7734.       skipSTACK(1);
  7735.       JUSTIFY_END_ENG;
  7736.       if (readable) # Beendung der Fallunterscheidung von oben
  7737.         { INDENT_END;
  7738.           KLAMMER_ZU;
  7739.         }
  7740.         else
  7741.         { INDENT_END;
  7742.           write_schar(stream_,'>');
  7743.         }
  7744.       skipSTACK(3);
  7745.       LEVEL_END;
  7746.     }}
  7747.  
  7748. # UP: Gibt einen OtherRecord auf einen Stream aus.
  7749. # pr_orecord(&stream,obj);
  7750. # > obj: OtherRecord
  7751. # > stream: Stream
  7752. # < stream: Stream
  7753. # kann GC ausl÷sen
  7754.   local void pr_orecord(stream_,obj)
  7755.     var reg2 object* stream_;
  7756.     var reg3 object obj;
  7757.     { switch (TheRecord(obj)->rectype)
  7758.         { case Rectype_Hashtable:
  7759.             # je nach *PRINT-ARRAY* :
  7760.             # #<HASH-TABLE #x...> oder
  7761.             # #S(HASH-TABLE test (Key_1 . Value_1) ... (Key_n . Value_n))
  7762.             if (test_value(S(print_array)) || test_value(S(print_readably)))
  7763.               { LEVEL_CHECK;
  7764.                 pushSTACK(obj); # Hash-Tabelle retten
  7765.                {var reg7 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  7766.                 write_schar(stream_,'#'); write_schar(stream_,'S');
  7767.                 KLAMMER_AUF;
  7768.                 INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#S('
  7769.                 JUSTIFY_START;
  7770.                 prin_object(stream_,S(hash_table)); # Symbol HASH-TABLE ausgeben
  7771.                 obj = *obj_;
  7772.                 { var reg1 uintL index = # Index in den Key-Value-Vektor
  7773.                     2*posfixnum_to_L(TheHashtable(obj)->ht_maxcount);
  7774.                   pushSTACK(TheHashtable(obj)->ht_kvtable); # Key-Value-Vektor
  7775.                  {var reg6 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7776.                   var reg5 uintL length = 0; # bisherige LΣnge := 0
  7777.                   JUSTIFY_SPACE; # Space ausgeben
  7778.                   # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7779.                   if (length >= length_limit) goto dots;
  7780.                   # Hash-Test ausgeben:
  7781.                   { var reg4 uintB flags = TheHashtable(*obj_)->recflags;
  7782.                     var reg7 object test = # Test-Symbol EQ/EQL/EQUAL
  7783.                       (flags & bit(0) ? S(eq) :
  7784.                        flags & bit(1) ? S(eql) :
  7785.                        flags & bit(2) ? S(equal) :
  7786.                                         NIL # (Default-Symbol)
  7787.                       );
  7788.                     prin_object(stream_,test);
  7789.                   }
  7790.                   loop
  7791.                     { length++; # bisherige LΣnge erh÷hen
  7792.                       # nΣchstes auszugebendes Key-Value-Paar suchen:
  7793.                       loop
  7794.                         { if (index==0) goto kvtable_end; # kvtable zu Ende?
  7795.                           index -= 2; # Index verringern
  7796.                           if (!eq(TheSvector(STACK_0)->data[index+0],unbound)) # Key /= "leer" ?
  7797.                             break;
  7798.                         }
  7799.                       JUSTIFY_SPACE; # Space ausgeben
  7800.                       # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  7801.                       if (length >= length_limit)
  7802.                         { dots:
  7803.                           # Rest durch '...' abkⁿrzen:
  7804.                           write_schar(stream_,'.');
  7805.                           write_schar(stream_,'.');
  7806.                           write_schar(stream_,'.');
  7807.                           break;
  7808.                         }
  7809.                       # Cons (Key . Value) bilden und ausgeben:
  7810.                       obj = allocate_cons();
  7811.                       { var reg4 object* ptr = &TheSvector(STACK_0)->data[index];
  7812.                         Car(obj) = ptr[0]; # Key
  7813.                         Cdr(obj) = ptr[1]; # Value
  7814.                       }
  7815.                       prin_object(stream_,obj);
  7816.                     }
  7817.                   kvtable_end: # Ende der Ausgabe der Key-Value-Paare
  7818.                   skipSTACK(1);
  7819.                 }}
  7820.                 JUSTIFY_END_ENG;
  7821.                 INDENT_END;
  7822.                 KLAMMER_ZU;
  7823.                 skipSTACK(1);
  7824.                 LEVEL_END;
  7825.               }}
  7826.               else
  7827.               { pr_hex6_obj(stream_,obj,O(printstring_hash_table)); }
  7828.             break;
  7829.           case Rectype_Package:
  7830.             # je nach *PRINT-READABLY*:
  7831.             # #<PACKAGE name> oder #.(SYSTEM::%FIND-PACKAGE "name")
  7832.             { pushSTACK(obj); # Package retten
  7833.              {var reg1 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  7834.               if (!test_value(S(print_readably)))
  7835.                 { write_schar(stream_,'#'); write_schar(stream_,'<');
  7836.                   INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7837.                   JUSTIFY_START;
  7838.                   write_sstring_case(stream_,O(printstring_package)); # "PACKAGE"
  7839.                   JUSTIFY_SPACE;
  7840.                   pr_like_symbol(stream_,ThePackage(*obj_)->pack_name); # Name ausgeben
  7841.                   JUSTIFY_END_ENG;
  7842.                   INDENT_END;
  7843.                   write_schar(stream_,'>');
  7844.                 }
  7845.                 else
  7846.                 { write_schar(stream_,'#'); write_schar(stream_,'.');
  7847.                   KLAMMER_AUF; # '('
  7848.                   INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#.('
  7849.                   JUSTIFY_START;
  7850.                   pr_symbol(stream_,S(pfind_package)); # SYSTEM::%FIND-PACKAGE
  7851.                   JUSTIFY_SPACE;
  7852.                   pr_string(stream_,ThePackage(*obj_)->pack_name); # Name ausgeben
  7853.                   JUSTIFY_END_ENG;
  7854.                   INDENT_END;
  7855.                   KLAMMER_ZU;
  7856.                 }
  7857.               skipSTACK(1);
  7858.             }}break;
  7859.           case Rectype_Readtable:
  7860.             # #<READTABLE #x...>
  7861.             if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7862.             pr_hex6_obj(stream_,obj,O(printstring_readtable));
  7863.             break;
  7864.           case Rectype_Pathname:
  7865.             {
  7866.               #ifdef PATHNAME_NOEXT
  7867.               # nur bei *PRINT-ESCAPE* /= NIL (sonst s.u.)
  7868.               if (test_value(S(print_escape)) || test_value(S(print_readably)))
  7869.                 # Pathnames, deren Namestring als ein anderer Pathname interpretiert
  7870.                 # wⁿrde, geben wir anders aus. Wegen der Regel der Aufspaltung in
  7871.                 # Name und Typ am letzten Punkt sind dies folgende FΣlle:
  7872.                 # - Typ = NIL, und der Name enthΣlt Punkte,
  7873.                 # - Typ enthΣlt Punkte.
  7874.                 { var reg5 object part = ThePathname(obj)->pathname_type;
  7875.                   if (nullp(part)) { part = ThePathname(obj)->pathname_name; }
  7876.                   if (simple_string_p(part))
  7877.                     # Feststellung, ob part Punkte enthΣlt:
  7878.                     { var reg4 uintL count = TheSstring(part)->length;
  7879.                       var reg1 uintB* ptr = &TheSstring(part)->data[0];
  7880.                       dotimesL(count,count, { if (*ptr++ == '.') goto pathname_nonstring; } );
  7881.                 }   }
  7882.               #endif
  7883.               # Bei *PRINT-READABLY* komponentenweise ausgeben (sicher ist sicher):
  7884.               if (test_value(S(print_readably))) goto pathname_nonstring;
  7885.               pushSTACK(obj); # Pathname retten
  7886.               # (NAMESTRING pathname) ausfⁿhren:
  7887.               pushSTACK(obj); funcall(L(namestring),1);
  7888.               obj = value1;
  7889.               if (stringp(obj)) # sollte einen String liefern (liefert z.Zt. sogar immer einen Simple-String)
  7890.                 # Syntax #"namestring"
  7891.                 { # *PRINT-ESCAPE* abfragen:
  7892.                   if (test_value(S(print_escape)) || test_value(S(print_readably)))
  7893.                     { STACK_0 = obj; # String retten
  7894.                       write_schar(stream_,'#'); # '#' ausgeben
  7895.                       pr_string(stream_,STACK_0); # String (in Anfⁿhrungszeichen) ausgeben
  7896.                     }
  7897.                     else
  7898.                     # keine Anfⁿhrungszeichen -> auch kein '#' ausgeben:
  7899.                     { write_string(stream_,obj); }
  7900.                   skipSTACK(1);
  7901.                 }
  7902.                 else
  7903.                 # Falls NAMESTRING keinen String lieferte:
  7904.                 { obj = popSTACK(); # Pathname zurⁿck
  7905.                   pathname_nonstring:
  7906.                   # #S(PATHNAME :DEVICE device :DIRECTORY directory :NAME name :TYPE type)
  7907.                   pr_record_descr(stream_,obj,S(pathname),TRUE,O(pathname_slotlist));
  7908.                 }
  7909.             }
  7910.             break;
  7911.           #ifdef LOGICAL_PATHNAMES
  7912.           case Rectype_Logpathname:
  7913.             # #S(LOGICAL-PATHNAME :HOST host :DIRECTORY directory :NAME name :TYPE type :VERSION version)
  7914.             pr_record_descr(stream_,obj,S(logical_pathname),TRUE,O(pathname_slotlist));
  7915.             break;
  7916.           #endif
  7917.           case Rectype_Random_State:
  7918.             # #S(RANDOM-STATE seed)
  7919.             { LEVEL_CHECK;
  7920.               pushSTACK(obj); # Random-State retten
  7921.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  7922.               write_schar(stream_,'#'); write_schar(stream_,'S');
  7923.               KLAMMER_AUF;
  7924.               INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#S('
  7925.               JUSTIFY_START;
  7926.               prin_object(stream_,S(random_state)); # Symbol RANDOM-STATE ausgeben
  7927.               pr_record_ab(stream_,obj_,0,0); # Komponente ausgeben
  7928.               JUSTIFY_END_ENG;
  7929.               INDENT_END;
  7930.               KLAMMER_ZU;
  7931.               skipSTACK(1);
  7932.               LEVEL_END;
  7933.             }}break;
  7934.           #ifndef case_structure
  7935.           case Rectype_Structure: # Structure
  7936.             pr_structure(stream_,obj); break;
  7937.           #endif
  7938.           #ifndef case_stream
  7939.           case Rectype_Stream: # Stream
  7940.             pr_stream(stream_,obj); break;
  7941.           #endif
  7942.           case Rectype_Byte:
  7943.             #if 0
  7944.             # #<BYTE size position>
  7945.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7946.               LEVEL_CHECK;
  7947.               pushSTACK(obj); # Byte retten
  7948.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  7949.               write_schar(stream_,'#'); write_schar(stream_,'<');
  7950.               INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7951.               JUSTIFY_START;
  7952.               write_sstring_case(stream_,O(printstring_byte)); # "BYTE"
  7953.               pr_record_ab(stream_,obj_,0,0); # Komponenten ausgeben
  7954.               JUSTIFY_END_ENG;
  7955.               INDENT_END;
  7956.               write_schar(stream_,'>');
  7957.               skipSTACK(1);
  7958.               LEVEL_END;
  7959.             }}
  7960.             #else
  7961.             # #S(BYTE :SIZE size :POSITION position)
  7962.             pr_record_descr(stream_,obj,S(byte),TRUE,O(byte_slotlist));
  7963.             #endif
  7964.             break;
  7965.           case Rectype_Fsubr: # Fsubr
  7966.             pr_fsubr(stream_,obj);
  7967.             break;
  7968.           case Rectype_Loadtimeeval:
  7969.             # #.form
  7970.             { pushSTACK(TheLoadtimeeval(obj)->loadtimeeval_form); # form retten
  7971.               write_schar(stream_,'#'); write_schar(stream_,'.');
  7972.               obj = popSTACK();
  7973.               INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#.'
  7974.               prin_object(stream_,obj); # form ausgeben
  7975.               INDENT_END;
  7976.             } break;
  7977.           case Rectype_Symbolmacro:
  7978.             # #<SYMBOL-MACRO expansion>
  7979.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7980.               LEVEL_CHECK;
  7981.               pushSTACK(obj); # Symbol-Macro retten
  7982.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  7983.               write_schar(stream_,'#'); write_schar(stream_,'<');
  7984.               INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  7985.               JUSTIFY_START;
  7986.               write_sstring_case(stream_,O(printstring_symbolmacro)); # "SYMBOL-MACRO"
  7987.               pr_record_ab(stream_,obj_,0,0); # Komponente ausgeben
  7988.               JUSTIFY_END_ENG;
  7989.               INDENT_END;
  7990.               write_schar(stream_,'>');
  7991.               skipSTACK(1);
  7992.               LEVEL_END;
  7993.             }}
  7994.             break;
  7995.           #ifdef ALIEN
  7996.           case Rectype_Alienfun:
  7997.             # #<ALIEN-FUNCTION address>
  7998.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7999.               LEVEL_CHECK;
  8000.               pushSTACK(obj); # Alienfun retten
  8001.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8002.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8003.               INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  8004.               JUSTIFY_START;
  8005.               write_sstring_case(stream_,O(printstring_alienfun)); # "ALIEN-FUNCTION"
  8006.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*
  8007.                var reg4 uintL length = 0; # bisherige LΣnge := 0
  8008.                # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  8009.                if (length >= length_limit) goto alienfun_end;
  8010.                JUSTIFY_SPACE; # Space ausgeben
  8011.                # Adresse ausgeben:
  8012.                pr_hex6(stream_,TheAlienfun(*obj_)->alienfun_address);
  8013.                length++; # bisherige LΣnge erh÷hen
  8014.               }
  8015.               alienfun_end:
  8016.               JUSTIFY_END_ENG;
  8017.               INDENT_END;
  8018.               write_schar(stream_,'>');
  8019.               skipSTACK(1);
  8020.               LEVEL_END;
  8021.             }}break;
  8022.           case Rectype_Alien:
  8023.             # #<ALIEN type address>
  8024.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8025.               LEVEL_CHECK;
  8026.               pushSTACK(obj); # Alien retten
  8027.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8028.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8029.               INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  8030.               JUSTIFY_START;
  8031.               write_sstring_case(stream_,O(printstring_alien)); # "ALIEN"
  8032.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  8033.                var reg4 uintL length = 0; # bisherige LΣnge := 0
  8034.                # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  8035.                if (length >= length_limit) goto alien_end;
  8036.                JUSTIFY_SPACE; # Space ausgeben
  8037.                # Typ ausgeben:
  8038.                prin_object(stream_,TheAlien(*obj_)->alien_type);
  8039.                length++; # bisherige LΣnge erh÷hen
  8040.                # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  8041.                if (length >= length_limit) goto alien_end;
  8042.                JUSTIFY_SPACE; # Space ausgeben
  8043.                # Adresse ausgeben:
  8044.                pr_hex6(stream_,TheAlien(*obj_)->alien_address);
  8045.                length++; # bisherige LΣnge erh÷hen
  8046.               }
  8047.               alien_end:
  8048.               JUSTIFY_END_ENG;
  8049.               INDENT_END;
  8050.               write_schar(stream_,'>');
  8051.               skipSTACK(1);
  8052.               LEVEL_END;
  8053.             }}break;
  8054.           #endif
  8055.           default:
  8056.             pushSTACK(S(print));
  8057.             fehler(serious_condition,
  8058.                    DEUTSCH ? "~: Record unbekannten Typs ist aufgetaucht!" :
  8059.                    ENGLISH ? "~: an unknown record type has been generated!" :
  8060.                    FRANCAIS ? "~ : Un objet composΘ de type inconnu a ΘtΘ rencontrΘ!" :
  8061.                    ""
  8062.                   );
  8063.     }   }
  8064.  
  8065. #                    -------- SUBRs, FSUBRs --------
  8066.  
  8067. # UP: Gibt ein Objekt in Form #<BLABLA other> auf einen Stream aus.
  8068. # pr_other_obj(&stream,other,string);
  8069. # > other: Objekt
  8070. # > string: Simple-String "BLABLA"
  8071. # > stream: Stream
  8072. # < stream: Stream
  8073. # kann GC ausl÷sen
  8074.   local void pr_other_obj (object* stream_, object other, object string);
  8075.   local void pr_other_obj(stream_,other,string)
  8076.     var reg1 object* stream_;
  8077.     var reg4 object other;
  8078.     var reg3 object string;
  8079.     { pushSTACK(other); # other retten
  8080.       pushSTACK(string); # String retten
  8081.      {var reg2 object* string_ = &STACK_0; # und merken, wo beides sitzt
  8082.       write_schar(stream_,'#'); write_schar(stream_,'<');
  8083.       INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  8084.       JUSTIFY_START;
  8085.       write_sstring_case(stream_,*string_); # String ausgeben
  8086.       JUSTIFY_SPACE;
  8087.       prin_object(stream_,*(string_ STACKop 1)); # other ausgeben
  8088.       JUSTIFY_END_ENG;
  8089.       INDENT_END;
  8090.       write_schar(stream_,'>');
  8091.       skipSTACK(2);
  8092.     }}
  8093.  
  8094. # UP: Gibt ein SUBR auf einen Stream aus.
  8095. # pr_subr(&stream,obj);
  8096. # > obj: SUBR
  8097. # > stream: Stream
  8098. # < stream: Stream
  8099. # kann GC ausl÷sen
  8100.   local void pr_subr(stream_,obj)
  8101.     var reg2 object* stream_;
  8102.     var reg1 object obj;
  8103.     { # #<SYSTEM-FUNCTION name> bzw. #<FOREIGN-FUNCTION name>
  8104.       if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8105.       pr_other_obj(stream_,TheSubr(obj)->name,
  8106.                    ((as_oint(subr_tab_ptr_as_object(&subr_tab)) <= as_oint(obj))
  8107.                     && (as_oint(obj) < as_oint(subr_tab_ptr_as_object(&subr_tab+1)))
  8108.                    ) ? O(printstring_subr) : O(printstring_foreign_subr)
  8109.                   );
  8110.     }
  8111.  
  8112. # UP: Gibt ein FSUBR auf einen Stream aus.
  8113. # pr_fsubr(&stream,obj);
  8114. # > obj: FSUBR
  8115. # > stream: Stream
  8116. # < stream: Stream
  8117. # kann GC ausl÷sen
  8118.   local void pr_fsubr(stream_,obj)
  8119.     var reg2 object* stream_;
  8120.     var reg1 object obj;
  8121.     { # #<SPECIAL-FORM name>
  8122.       if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8123.       pr_other_obj(stream_,TheFsubr(obj)->name,O(printstring_fsubr));
  8124.     }
  8125.  
  8126. #                       -------- Closures --------
  8127.  
  8128. # UP: Gibt eine Closure auf einen Stream aus.
  8129. # pr_closure(&stream,obj);
  8130. # > obj: Closure
  8131. # > stream: Stream
  8132. # < stream: Stream
  8133. # kann GC ausl÷sen
  8134.   local void pr_closure(stream_,obj)
  8135.     var reg1 object* stream_;
  8136.     var reg4 object obj;
  8137.     { if (m_simple_bit_vector_p(TheClosure(obj)->clos_codevec))
  8138.         # compilierte Closure
  8139.         { pr_cclosure(stream_,obj); }
  8140.         else
  8141.         # interpretierte Closure ausgeben: #<CLOSURE ...>
  8142.         { # Falls *PRINT-CLOSURE* /= NIL, alles, sonst den Namen und
  8143.           # (falls noch vorhanden) Lambdaliste und Formen, ausgeben:
  8144.           if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8145.           LEVEL_CHECK;
  8146.           pushSTACK(obj); # Closure retten
  8147.          {var reg2 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  8148.           write_schar(stream_,'#'); write_schar(stream_,'<');
  8149.           INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  8150.           JUSTIFY_START;
  8151.           write_sstring_case(stream_,O(printstring_closure));
  8152.           if (test_value(S(print_closure))) # *PRINT-CLOSURE* abfragen
  8153.             # *PRINT-CLOSURE* /= NIL -> #<CLOSURE komponente1 ...> ausgeben:
  8154.             { pr_record_ab(stream_,obj_,0,0); } # alle weiteren Komponenten ausgeben
  8155.             else
  8156.             # *PRINT-CLOSURE* = NIL -> #<CLOSURE name . form> ausgeben:
  8157.             { JUSTIFY_SPACE;
  8158.               prin_object(stream_,TheIclosure(*obj_)->clos_name); # Name ausgeben
  8159.               # Formenliste elementweise ausgeben:
  8160.               pr_record_rest(stream_,TheIclosure(*obj_)->clos_form,1);
  8161.             }
  8162.           JUSTIFY_END_ENG;
  8163.           INDENT_END;
  8164.           write_schar(stream_,'>');
  8165.           skipSTACK(1);
  8166.           LEVEL_END;
  8167.         }}
  8168.     }
  8169.  
  8170. # UP: Gibt eine compilierte Closure auf einen Stream aus.
  8171. # pr_cclosure(&stream,obj);
  8172. # > obj: compilierte Closure
  8173. # > stream: Stream
  8174. # < stream: Stream
  8175. # kann GC ausl÷sen
  8176.   local void pr_cclosure(stream_,obj)
  8177.     var reg2 object* stream_;
  8178.     var reg1 object obj;
  8179.     { # *PRINT-CLOSURE* abfragen:
  8180.       if (test_value(S(print_closure)) || test_value(S(print_readably)))
  8181.         # *PRINT-CLOSURE /= NIL -> in wiedereinlesbarer Form #Y(...) ausgeben
  8182.         { pr_cclosure_lang(stream_,obj); }
  8183.         else
  8184.         # *PRINT-CLOSURE* = NIL ->
  8185.         # nur #<GENERIC-FUNCTION name> bzw. #<COMPILED-CLOSURE name> ausgeben:
  8186.         { pr_other_obj(stream_,TheClosure(obj)->clos_name,
  8187.                        (TheSbvector(TheClosure(obj)->clos_codevec)->data[CCHD+4] & bit(4) # generische Funktion?
  8188.                         ? O(printstring_generic_function)
  8189.                         : O(printstring_compiled_closure)
  8190.                       ));
  8191.         }
  8192.     }
  8193.  
  8194. # compilierte Closure in wiedereinlesbarer Form ausgeben:
  8195. # (defun %print-cclosure (closure)
  8196. #   (princ "#Y(")
  8197. #   (prin1 (closure-name closure))
  8198. #   (princ " #")
  8199. #   (let ((L (closure-codevec closure)))
  8200. #     (let ((*print-base* 10.)) (prin1 (length L)))
  8201. #     (princ "Y(")
  8202. #     (let ((*print-base* 16.))
  8203. #       (do ((i 0 (1- i))
  8204. #            (x L (cdr x)))
  8205. #           ((endp x))
  8206. #         (when (zerop i) (terpri) (setq i 25))
  8207. #         (princ " ")
  8208. #         (prin1 (car x))
  8209. #     ) )
  8210. #     (princ ")")
  8211. #   )
  8212. #   (terpri)
  8213. #   (dolist (x (closure-consts closure))
  8214. #     (princ " ")
  8215. #     (prin1 x)
  8216. #   )
  8217. #   (princ ")")
  8218. # )
  8219. # UP: Gibt eine compilierte Closure in wiedereinlesbarer Form
  8220. # auf einen Stream aus.
  8221. # pr_cclosure_lang(&stream,obj);
  8222. # > obj: compilierte Closure
  8223. # > stream: Stream
  8224. # < stream: Stream
  8225. # kann GC ausl÷sen
  8226.   local void pr_cclosure_lang(stream_,obj)
  8227.     var reg2 object* stream_;
  8228.     var reg3 object obj;
  8229.     { LEVEL_CHECK;
  8230.       pushSTACK(obj); # Closure retten
  8231.      {var reg1 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  8232.       write_schar(stream_,'#'); write_schar(stream_,'Y');
  8233.       KLAMMER_AUF;
  8234.       INDENT_START(3); # um 3 Zeichen einrⁿcken, wegen '#Y('
  8235.       JUSTIFY_START;
  8236.       prin_object(stream_,TheClosure(*obj_)->clos_name); # Name ausgeben
  8237.       JUSTIFY_SPACE;
  8238.       # Codevektor byteweise ausgeben, dabei ZirkularitΣt behandeln:
  8239.       pr_circle(stream_,TheClosure(*obj_)->clos_codevec,&pr_cclosure_codevector);
  8240.       pr_record_ab(stream_,obj_,2,2); # restliche Komponenten ausgeben
  8241.       JUSTIFY_END_ENG;
  8242.       INDENT_END;
  8243.       KLAMMER_ZU;
  8244.       skipSTACK(1);
  8245.       LEVEL_END;
  8246.     }}
  8247.  
  8248. # UP: Gibt einen Closure-Codevektor in #nY(...)-Schreibweise
  8249. # auf einen Stream aus.
  8250. # pr_cclosure_codevector(&stream,codevec);
  8251. # > codevec: ein Simple-Bit-Vektor
  8252. # > stream: Stream
  8253. # < stream: Stream
  8254. # kann GC ausl÷sen
  8255.   local void pr_cclosure_codevector(stream_,codevec)
  8256.     var reg2 object* stream_;
  8257.     var reg6 object codevec;
  8258.     { LEVEL_CHECK;
  8259.       pushSTACK(codevec); # Codevektor retten
  8260.      {var reg1 object* codevec_ = &STACK_0; # und merken, wo er sitzt
  8261.       var reg3 uintL len = (TheSbvector(codevec)->length)/8; # LΣnge in Bytes
  8262.       # PrΣfix ausgeben:
  8263.       INDENTPREP_START;
  8264.       write_schar(stream_,'#');
  8265.       pr_uint(stream_,len); # LΣnge dezimal ausgeben
  8266.       write_schar(stream_,'Y');
  8267.       {var reg1 uintL indent = INDENTPREP_END;
  8268.       # Hauptteil ausgeben:
  8269.        INDENT_START(indent); # einrⁿcken
  8270.       }
  8271.       KLAMMER_AUF;
  8272.       INDENT_START(1); # um 1 Zeichen einrⁿcken, wegen '('
  8273.       JUSTIFY_START;
  8274.       { var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  8275.         var reg4 uintL length = 0; # Index = bisherige LΣnge := 0
  8276.         dotimesL(len,len,
  8277.           { # (au▀er vorm ersten Element) Space ausgeben:
  8278.             if (!(length==0)) { JUSTIFY_SPACE; }
  8279.             # auf Erreichen von *PRINT-LENGTH* prⁿfen:
  8280.             if (length >= length_limit)
  8281.               { # Rest durch '...' abkⁿrzen:
  8282.                 write_schar(stream_,'.');
  8283.                 write_schar(stream_,'.');
  8284.                 write_schar(stream_,'.');
  8285.                 break;
  8286.               }
  8287.             # Byte ausgeben:
  8288.             pr_hex2(stream_,TheSbvector(*codevec_)->data[length]);
  8289.             length++; # Index erh÷hen
  8290.           });
  8291.       }
  8292.       JUSTIFY_END_ENG;
  8293.       INDENT_END;
  8294.       KLAMMER_ZU;
  8295.       INDENT_END;
  8296.       skipSTACK(1);
  8297.       LEVEL_END;
  8298.     }}
  8299.  
  8300. #                       -------- Streams --------
  8301.  
  8302. # UP: Gibt einen Stream auf einen Stream aus.
  8303. # pr_stream(&stream,obj);
  8304. # > obj: auszugebender Stream
  8305. # > stream: Stream
  8306. # < stream: Stream
  8307. # kann GC ausl÷sen
  8308.   local void pr_stream(stream_,obj)
  8309.     var reg2 object* stream_;
  8310.     var reg4 object obj;
  8311.     { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8312.       pushSTACK(obj); # Stream retten
  8313.      {var reg1 object* obj_ = &STACK_0; # und merken, wo er sitzt
  8314.       write_schar(stream_,'#'); write_schar(stream_,'<');
  8315.       INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  8316.       JUSTIFY_START;
  8317.       # falls Stream geschlossen, "CLOSED " ausgeben:
  8318.       if ((TheStream(*obj_)->strmflags & strmflags_open_B) == 0)
  8319.         { write_sstring_case(stream_,O(printstring_closed)); }
  8320.       # Streamtyp ausgeben:
  8321.       { var reg4 uintL type = TheStream(*obj_)->strmtype;
  8322.        {var reg3 object* stringtable = &O(printstring_closed) + 1;
  8323.         write_sstring_case(stream_,stringtable[type]); # String aus Tabelle holen
  8324.        }
  8325.       # "-STREAM" ausgeben:
  8326.         write_sstring_case(stream_,O(printstring_stream));
  8327.       # Streamspezifische Zusatzinformation:
  8328.         switch (type)
  8329.           { case strmtype_sch_file:
  8330.             case strmtype_ch_file:
  8331.             case strmtype_iu_file:
  8332.             case strmtype_is_file:
  8333.             #ifdef HANDLES
  8334.             case strmtype_handle:
  8335.             #endif
  8336.               # File-Stream
  8337.               JUSTIFY_SPACE;
  8338.               prin_object(stream_,TheStream(*obj_)->strm_file_name); # Filename ausgeben
  8339.               break;
  8340.             case strmtype_synonym:
  8341.               # Synonym-Stream
  8342.               JUSTIFY_SPACE;
  8343.               prin_object(stream_,TheStream(*obj_)->strm_synonym_symbol); # Symbol ausgeben
  8344.               break;
  8345.             case strmtype_broad:
  8346.               # Broadcast-Stream
  8347.               pr_record_rest(stream_,TheStream(*obj_)->strm_broad_list,0); # Streams ausgeben
  8348.               break;
  8349.             case strmtype_concat:
  8350.               # Concatenated-Stream
  8351.               pr_record_rest(stream_,TheStream(*obj_)->strm_concat_list,0); # Streams ausgeben
  8352.               break;
  8353.             case strmtype_buff_in:
  8354.               # Buffered-Input-Stream
  8355.               JUSTIFY_SPACE;
  8356.               prin_object(stream_,TheStream(*obj_)->strm_buff_in_fun); # Funktion ausgeben
  8357.               break;
  8358.             case strmtype_buff_out:
  8359.               # Buffered-Output-Stream
  8360.               JUSTIFY_SPACE;
  8361.               prin_object(stream_,TheStream(*obj_)->strm_buff_out_fun); # Funktion ausgeben
  8362.               break;
  8363.             #ifdef PIPES
  8364.             case strmtype_pipe_in:
  8365.             case strmtype_pipe_out:
  8366.               # Pipe-In/Out-Stream
  8367.               JUSTIFY_SPACE;
  8368.               pr_uint(stream_,posfixnum_to_L(TheStream(*obj_)->strm_pipe_pid)); # Proze▀-Id ausgeben
  8369.               break;
  8370.             #endif
  8371.             #ifdef SOCKETS
  8372.             case strmtype_socket:
  8373.               # Socket-Stream
  8374.               JUSTIFY_SPACE;
  8375.               prin_object(stream_,TheStream(*obj_)->strm_socket_connect); # Verbindungsziel ausgeben
  8376.               break;
  8377.             #endif
  8378.             #ifdef GENERIC_STREAMS
  8379.             case strmtype_generic:
  8380.               # Generic Streams
  8381.               JUSTIFY_SPACE;
  8382.               prin_object(stream_,TheStream(*obj_)->strm_controller_object); # Controller ausgeben
  8383.               break;
  8384.             #endif
  8385.             default:
  8386.               # sonst keine Zusatzinformation
  8387.               break;
  8388.           }
  8389.         if (type==strmtype_sch_file)
  8390.           { JUSTIFY_SPACE;
  8391.             # Zeilennummer ausgeben, in der sich der Stream gerade befindet:
  8392.             write_schar(stream_,'@');
  8393.             pr_number(stream_,TheStream(*obj_)->strm_sch_file_lineno);
  8394.           }
  8395.       }
  8396.       JUSTIFY_END_ENG;
  8397.       INDENT_END;
  8398.       write_schar(stream_,'>');
  8399.       skipSTACK(1);
  8400.     }}
  8401.  
  8402. #                    -------- CLOS-Instanzen --------
  8403.  
  8404. # UP: Gibt eine CLOS-Instanz auf einen Stream aus.
  8405. # pr_instance(&stream,obj);
  8406. # > obj: auszugebende CLOS-Instanz
  8407. # > stream: Stream
  8408. # < stream: Stream
  8409. # kann GC ausl÷sen
  8410.   local void pr_instance(stream_,obj)
  8411.     var reg3 object* stream_;
  8412.     var reg4 object obj;
  8413.     { var reg2 object stream = *stream_;
  8414.       var reg1 uintC count = pr_external_1(stream); # Bindungen erstellen
  8415.       # (CLOS:PRINT-OBJECT obj stream) ausfⁿhren:
  8416.       pushSTACK(obj); pushSTACK(stream); funcall(S(print_object),2);
  8417.       pr_external_2(count); # Bindungen aufl÷sen
  8418.     }
  8419.  
  8420.  
  8421. # ---------------------- Top-Level-Aufruf des Printers ------------------------
  8422.  
  8423. # UP: Gibt ein Objekt auf einen Stream aus.
  8424. # prin1(&stream,obj);
  8425. # > obj: Objekt
  8426. # > stream: Stream
  8427. # < stream: Stream
  8428. # kann GC ausl÷sen
  8429.   # UP: dasselbe mit Behandlung von *PRINT-PRETTY* :
  8430.   local void prin1a (object* stream_, object obj);
  8431.   local void prin1a(stream_,obj)
  8432.     var reg2 object* stream_;
  8433.     var reg3 object obj;
  8434.     { # Streamtyp (PPHELP-Stream oder nicht) mu▀ zu *PRINT-PRETTY* passen.
  8435.       if (test_value(S(print_pretty)))
  8436.         # *PRINT-PRETTY* /= NIL.
  8437.         { # Falls *stream_ kein PPHELP-Stream ist,
  8438.           # mu▀ er durch einen PPHELP-Stream ersetzt werden:
  8439.           if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  8440.             # noch ein normaler Stream
  8441.             { dynamic_bind(S(prin_l1),Fixnum_0); # SYS::*PRIN-L1* an 0 binden
  8442.               dynamic_bind(S(prin_lm),Fixnum_0); # SYS::*PRIN-LM* an 0 binden
  8443.               # SYS::*PRIN-L1* auf dessen Line-Position setzen:
  8444.               Symbol_value(S(prin_l1)) = get_line_position(*stream_);
  8445.               pushSTACK(obj); # Objekt retten
  8446.               pushSTACK(make_pphelp_stream()); # neuer PPHELP-Stream, Line-Position = 0
  8447.               # Objekt auf den neuen Stream ausgeben:
  8448.               prin_object(&STACK_0,STACK_1);
  8449.               # Inhalt des neuen Streams auf den alten Stream ausgeben:
  8450.               {var reg1 object ppstream = popSTACK(); # der neue Stream
  8451.                STACK_0 = nreverse(TheStream(ppstream)->strm_pphelp_strings); # Liste von Output-Zeilen
  8452.                # Falls es ein Mehrzeiler wurde und die alte Line-Position >0
  8453.                # ist, zuerst noch ein Newline auf den alten Stream ausgeben:
  8454.                if (eq(TheStream(ppstream)->strm_pphelp_modus,einzeiler) # Einzeiler ?
  8455.                    || eq(Symbol_value(S(prin_l1)),Fixnum_0) # oder Mehrzeiler, aber ab Position 0 ?
  8456.                   )
  8457.                  goto skip_first_NL; # in die Schleife
  8458.               }
  8459.               do { write_schar(stream_,NL); # #\Newline als Trennzeichen zwischen den Zeilen
  8460.                    skip_first_NL:
  8461.                    # nichtleere Stringliste STACK_0 auf den Stream ausgeben:
  8462.                   {var reg1 object list = STACK_0;
  8463.                    STACK_0 = Cdr(list);
  8464.                    write_string(stream_,Car(list)); # einzelnen String ausgeben
  8465.                  }}
  8466.                  while (mconsp(STACK_0));
  8467.               skipSTACK(1);
  8468.               dynamic_unbind();
  8469.               dynamic_unbind();
  8470.             }
  8471.             else
  8472.             # schon ein PPHELP-Stream
  8473.             { prin_object(stream_,obj); }
  8474.         }
  8475.         else
  8476.         # *PRINT-PRETTY* = NIL.
  8477.         { # Falls *stream_ ein PPHELP-Stream ist, mu▀ er durch einen
  8478.           # einelementigen Broadcast-Stream ersetzt werden:
  8479.           if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  8480.             # normaler Stream
  8481.             { prin_object(stream_,obj); }
  8482.             else
  8483.             # ein PPHELP-Stream
  8484.             { pushSTACK(obj);
  8485.               pushSTACK(make_broadcast1_stream(*stream_)); # Broadcast-Stream auf den Stream *stream_
  8486.               prin_object(&STACK_0,STACK_1);
  8487.               skipSTACK(1);
  8488.             }
  8489.         }
  8490.     }
  8491.   # UP: dasselbe mit Behandlung von *PRINT-CIRCLE* und *PRINT-PRETTY* :
  8492.   local void prin1b (object* stream_, object obj);
  8493.   local void prin1b(stream_,obj)
  8494.     var reg3 object* stream_;
  8495.     var reg2 object obj;
  8496.     { # Falls *PRINT-CIRCLE* /= NIL, in obj nach ZirkularitΣten suchen.
  8497.       if (test_value(S(print_circle)) || test_value(S(print_readably)))
  8498.         # ZirkularitΣten suchen:
  8499.         { pushSTACK(obj);
  8500.          {var reg1 object circularities = # ZirkularitΣtentabelle
  8501.             get_circularities(obj,
  8502.                               test_value(S(print_array)) || test_value(S(print_readably)), # /= 0 genau dann wenn *PRINT-ARRAY* /= NIL
  8503.                               test_value(S(print_closure)) || test_value(S(print_readably)) # /= 0 genau dann wenn *PRINT-CLOSURE* /= NIL
  8504.                              );
  8505.           obj = popSTACK();
  8506.           if (nullp(circularities))
  8507.             # Keine ZirkularitΣten festgestellt.
  8508.             { # Kann *PRINT-CIRCLE* an NIL binden.
  8509.               dynamic_bind(S(print_circle),NIL);
  8510.               prin1a(stream_,obj);
  8511.               dynamic_unbind();
  8512.             }
  8513.           elif (eq(circularities,T))
  8514.             # Stackⁿberlauf trat auf
  8515.             { # ▄berlauf der GET_CIRCULARITIES-Routine behandeln:
  8516.               dynamic_bind(S(print_circle),NIL); # *PRINT-CIRCLE* an NIL binden
  8517.               pushSTACK(S(print));
  8518.               fehler(storage_condition,
  8519.                      DEUTSCH ? "~: Stack reicht nicht zum Feststellen der ZirkularitΣten." :
  8520.                      ENGLISH ? "~: not enough stack space for carrying out circularity analysis" :
  8521.                      FRANCAIS ? "~ : La pile n'est pas suffisante pour analyser les liaisons circulaires." :
  8522.                      ""
  8523.                     );
  8524.             }
  8525.           else
  8526.             # ZirkularitΣtenvektor
  8527.             { # Binde SYS::*PRINT-CIRCLE-TABLE* an den Simple-Vector:
  8528.               dynamic_bind(S(print_circle_table),circularities);
  8529.               if (!test_value(S(print_circle)))
  8530.                 # *PRINT-READABLY* erzwingt *PRINT-CIRCLE* = T
  8531.                 { dynamic_bind(S(print_circle),T);
  8532.                   prin1a(stream_,obj);
  8533.                   dynamic_unbind();
  8534.                 }
  8535.                 else
  8536.                 { prin1a(stream_,obj); }
  8537.               dynamic_unbind();
  8538.             }
  8539.         }}
  8540.         else
  8541.         { prin1a(stream_,obj); }
  8542.     }
  8543.   # UP: dasselbe mit Behandlung von *PRINT-CIRCLE* und *PRINT-PRETTY*
  8544.   # und SYS::*PRIN-STREAM* :
  8545.   global void prin1 (object* stream_, object obj);
  8546.   global void prin1(stream_,obj)
  8547.     var reg1 object* stream_;
  8548.     var reg2 object obj;
  8549.     { # Wert von SYS::*PRIN-STREAM* = dieser Stream ?
  8550.       if (eq(Symbol_value(S(prin_stream)),*stream_))
  8551.         # ja -> rekursiver Aufruf
  8552.         { # Falls SYS::*PRINT-CIRCLE-TABLE* = #<UNBOUND> (was bedeutet, da▀
  8553.           # *PRINT-CIRCLE* vorher NIL war) und jetzt *PRINT-CIRCLE* /= NIL
  8554.           # ist, mu▀ Objekt obj nach ZirkularitΣten abgesucht werden.
  8555.           if (eq(Symbol_value(S(print_circle_table)),unbound))
  8556.             { prin1b(stream_,obj); }
  8557.             else
  8558.             { prin1a(stream_,obj); }
  8559.         }
  8560.         else
  8561.         # nein -> nichtrekursiver Aufruf
  8562.         {
  8563.          #if STACKCHECKP
  8564.           var reg3 object* STACKbefore = STACK; # STACK aufheben fⁿr spΣter
  8565.          #endif
  8566.           dynamic_bind(S(prin_level),Fixnum_0); # SYS::*PRIN-LEVEL* an 0 binden
  8567.           dynamic_bind(S(prin_bqlevel),Fixnum_0); # SYS::*PRIN-BQLEVEL* an 0 binden
  8568.           dynamic_bind(S(prin_l1),Fixnum_0); # SYS::*PRIN-L1* an 0 binden (fⁿr Pretty-Print)
  8569.           dynamic_bind(S(prin_lm),Fixnum_0); # SYS::*PRIN-LM* an 0 binden (fⁿr Pretty-Print)
  8570.           prin1b(stream_,obj);
  8571.           dynamic_unbind();
  8572.           dynamic_unbind();
  8573.           dynamic_unbind();
  8574.           dynamic_unbind();
  8575.          #if STACKCHECKP
  8576.           # ▄berprⁿfen, ob Stack aufgerΣumt:
  8577.           if (!(STACK == STACKbefore))
  8578.             { abort(); } # wenn nicht, in den Debugger
  8579.          #endif
  8580.         }
  8581.     }
  8582.  
  8583. # UP: Gibt erst Newline, dann ein Objekt auf einen Stream aus.
  8584. # print(&stream,obj);
  8585. # > obj: Objekt
  8586. # > stream: Stream
  8587. # < stream: Stream
  8588. # kann GC ausl÷sen
  8589.   global void print (object* stream_, object obj);
  8590.   global void print(stream_,obj)
  8591.     var reg2 object* stream_;
  8592.     var reg1 object obj;
  8593.     { pushSTACK(obj); # Objekt retten
  8594.       write_schar(stream_,NL); # #\Newline ausgeben
  8595.       obj = popSTACK();
  8596.       prin1(stream_,obj); # Objekt ausgeben
  8597.     }
  8598.  
  8599.  
  8600. # ----------------------- LISP-Funktionen des Printers ------------------------
  8601.  
  8602. # UP: ▄berprⁿft ein Output-Stream-Argument.
  8603. # Default ist der Wert von *STANDARD-OUTPUT*.
  8604. # test_ostream();
  8605. # > subr_self: Aufrufer (ein SUBR)
  8606. # > STACK_0: Output-Stream-Argument
  8607. # < STACK_0: Output-Stream (ein Stream)
  8608.   local void test_ostream (void);
  8609.   local void test_ostream()
  8610.     { var reg1 object stream = STACK_0; # Output-Stream-Argument
  8611.       if (eq(stream,unbound) || nullp(stream))
  8612.         # #<UNBOUND> oder NIL -> Wert von *STANDARD-OUTPUT*
  8613.         { STACK_0 = var_stream(S(standard_output)); }
  8614.       elif (eq(stream,T))
  8615.         # T -> Wert von *TERMINAL-IO*
  8616.         { STACK_0 = var_stream(S(terminal_io)); }
  8617.       else
  8618.         # sollte ein Stream sein
  8619.         { if (!streamp(stream)) { fehler_stream(stream); } }
  8620.     }
  8621.  
  8622. # Print-Variablen (siehe CONSTSYM.D):
  8623. #   *PRINT-CASE*     --+
  8624. #   *PRINT-LEVEL*      |
  8625. #   *PRINT-LENGTH*     |
  8626. #   *PRINT-GENSYM*     |
  8627. #   *PRINT-ESCAPE*     | Reihenfolge fest!
  8628. #   *PRINT-RADIX*      | Dieselbe Reihenfolge in CONSTSYM.D
  8629. #   *PRINT-BASE*       | und bei den SUBRs WRITE, WRITE-TO-STRING
  8630. #   *PRINT-ARRAY*      |
  8631. #   *PRINT-CIRCLE*     |
  8632. #   *PRINT-PRETTY*     |
  8633. #   *PRINT-CLOSURE*    |
  8634. #   *PRINT-READABLY* --+
  8635. # erste Print-Variable:
  8636.   #define first_print_var  S(print_case)
  8637. # Anzahl der Print-Variablen:
  8638.   #define print_vars_anz  12
  8639.  
  8640. # UP fⁿr WRITE und WRITE-TO-STRING
  8641. # > STACK_(print_vars_anz+1): Objekt
  8642. # > STACK_(print_vars_anz)..STACK_(1): Argumente zu den Print-Variablen
  8643. # > STACK_0: Stream
  8644.   local void write_up (void);
  8645.   local void write_up()
  8646.     { var reg2 object* argptr = args_end_pointer STACKop (1+print_vars_anz+1); # Pointer ⁿber die Keyword-Argumente
  8647.       var reg5 object obj = NEXT(argptr); # erstes Argument = Objekt
  8648.       # die angegebenen Variablen binden:
  8649.       var reg4 uintC bindcount = 0; # Anzahl der Bindungen
  8650.       {var reg1 object sym = first_print_var; # durchlΣuft die Symbole
  8651.        var reg3 uintC count;
  8652.        dotimesC(count,print_vars_anz,
  8653.          { var reg1 object arg = NEXT(argptr); # nΣchstes Keyword-Argument
  8654.            if (!eq(arg,unbound)) # angegeben?
  8655.              { dynamic_bind(sym,arg); bindcount++; } # ja -> Variable daran binden
  8656.            sym = objectplus(sym,(soint)sizeof(*TheSymbol(sym))<<(oint_addr_shift-addr_shift)); # zum nΣchsten Symbol
  8657.          });
  8658.       }
  8659.       {var reg1 object* stream_ = &NEXT(argptr); # nΣchstes Argument ist der Stream
  8660.        prin1(stream_,obj); # Objekt ausgeben
  8661.       }
  8662.       # Bindungen aufl÷sen:
  8663.       dotimesC(bindcount,bindcount, { dynamic_unbind(); } );
  8664.     }
  8665.  
  8666. LISPFUN(write,1,0,norest,key,13,\
  8667.         (kw(case),kw(level),kw(length),kw(gensym),kw(escape),kw(radix),\
  8668.          kw(base),kw(array),kw(circle),kw(pretty),kw(closure),kw(readably),\
  8669.          kw(stream)) )
  8670. # (WRITE object [:stream] [:escape] [:radix] [:base] [:circle] [:pretty]
  8671. #               [:level] [:length] [:case] [:gensym] [:array] [:closure]
  8672. #               [:readably]),
  8673. # CLTL S. 382
  8674.   { # Stackaufbau: object, Print-Variablen-Argumente, Stream-Argument.
  8675.     test_ostream(); # Output-Stream ⁿberprⁿfen
  8676.     write_up(); # WRITE durchfⁿhren
  8677.     skipSTACK(print_vars_anz+1);
  8678.     value1 = popSTACK(); mv_count=1; # object als Wert
  8679.   }
  8680.  
  8681. # (defun prin1 (object &optional stream)
  8682. #   (test-output-stream stream)
  8683. #   (let ((*print-escape* t))
  8684. #     (prin object stream)
  8685. #   )
  8686. #   object
  8687. # )
  8688.  
  8689. # UP fⁿr PRIN1 und PRINT und PRIN1-TO-STRING
  8690. # > STACK_1: Objekt
  8691. # > STACK_0: Stream
  8692.   local void prin1_up (void);
  8693.   local void prin1_up()
  8694.     { var reg2 object obj = STACK_1;
  8695.       var reg1 object* stream_ = &STACK_0;
  8696.       dynamic_bind(S(print_escape),T); # *PRINT-ESCAPE* an T binden
  8697.       prin1(stream_,obj); # object ausgeben
  8698.       dynamic_unbind();
  8699.     }
  8700.  
  8701. LISPFUN(prin1,1,1,norest,nokey,0,NIL)
  8702. # (PRIN1 object [stream]), CLTL S. 383
  8703.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8704.     prin1_up(); # PRIN1 durchfⁿhren
  8705.     skipSTACK(1);
  8706.     value1 = popSTACK(); mv_count=1; # object als Wert
  8707.   }
  8708.  
  8709. # (defun print (object &optional stream)
  8710. #   (test-output-stream stream)
  8711. #   (terpri stream)
  8712. #   (let ((*print-escape* t))
  8713. #     (prin object stream)
  8714. #   )
  8715. #   (write-char #\Space stream)
  8716. #   object
  8717. # )
  8718. LISPFUN(print,1,1,norest,nokey,0,NIL)
  8719. # (PRINT object [stream]), CLTL S. 383
  8720.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8721.     terpri(&STACK_0); # neue Zeile
  8722.     prin1_up(); # PRIN1 durchfⁿhren
  8723.     write_schar(&STACK_0,' '); # Space danach
  8724.     skipSTACK(1);
  8725.     value1 = popSTACK(); mv_count=1; # object als Wert
  8726.   }
  8727.  
  8728. # (defun pprint (object &optional stream)
  8729. #   (test-output-stream stream)
  8730. #   (terpri stream)
  8731. #   (let ((*print-escape* t) (*print-pretty* t))
  8732. #     (prin object stream)
  8733. #   )
  8734. #   (values)
  8735. # )
  8736. LISPFUN(pprint,1,1,norest,nokey,0,NIL)
  8737. # (PPRINT object [stream]), CLTL S. 383
  8738.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8739.     terpri(&STACK_0); # neue Zeile
  8740.    {var reg2 object obj = STACK_1;
  8741.     var reg1 object* stream_ = &STACK_0;
  8742.     dynamic_bind(S(print_pretty),T); # *PRINT-PRETTY* an T binden
  8743.     dynamic_bind(S(print_escape),T); # *PRINT-ESCAPE* an T binden
  8744.     prin1(stream_,obj); # object ausgeben
  8745.     dynamic_unbind();
  8746.     dynamic_unbind();
  8747.     skipSTACK(2);
  8748.     value1 = NIL; mv_count=0; # keine Werte
  8749.   }}
  8750.  
  8751. # (defun princ (object &optional stream)
  8752. #   (test-output-stream stream)
  8753. #   (let ((*print-escape* nil))
  8754. #     (prin object stream)
  8755. #   )
  8756. #   object
  8757. # )
  8758.  
  8759. # UP fⁿr PRINC und PRINC-TO-STRING
  8760. # > STACK_1: Objekt
  8761. # > STACK_0: Stream
  8762.   local void princ_up (void);
  8763.   local void princ_up()
  8764.     { var reg2 object obj = STACK_1;
  8765.       var reg1 object* stream_ = &STACK_0;
  8766.       dynamic_bind(S(print_escape),NIL); # *PRINT-ESCAPE* an NIL binden
  8767.       prin1(stream_,obj); # object ausgeben
  8768.       dynamic_unbind();
  8769.     }
  8770.  
  8771. LISPFUN(princ,1,1,norest,nokey,0,NIL)
  8772. # (PRINC object [stream]), CLTL S. 383
  8773.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8774.     princ_up(); # PRINC durchfⁿhren
  8775.     skipSTACK(1);
  8776.     value1 = popSTACK(); mv_count=1; # object als Wert
  8777.   }
  8778.  
  8779. # (defun write-to-string (object &rest args
  8780. #                                &key escape radix base circle pretty level
  8781. #                                     length case gensym array closure readably)
  8782. #   (with-output-to-string (stream)
  8783. #     (apply #'write object :stream stream args)
  8784. # ) )
  8785. LISPFUN(write_to_string,1,0,norest,key,12,\
  8786.         (kw(case),kw(level),kw(length),kw(gensym),kw(escape),kw(radix),\
  8787.          kw(base),kw(array),kw(circle),kw(pretty),kw(closure),kw(readably)) )
  8788. # (WRITE-TO-STRING object [:escape] [:radix] [:base] [:circle] [:pretty]
  8789. #                         [:level] [:length] [:case] [:gensym] [:array]
  8790. #                         [:closure] [:readably]),
  8791. # CLTL S. 383
  8792.   { pushSTACK(make_string_output_stream()); # String-Output-Stream
  8793.     write_up(); # WRITE durchfⁿhren
  8794.     value1 = get_output_stream_string(&STACK_0); mv_count=1; # Ergebnis-String als Wert
  8795.     skipSTACK(1+print_vars_anz+1);
  8796.   }
  8797.  
  8798. # (defun prin1-to-string (object)
  8799. #   (with-output-to-string (stream) (prin1 object stream))
  8800. # )
  8801. LISPFUNN(prin1_to_string,1)
  8802. # (PRIN1-TO-STRING object), CLTL S. 383
  8803.   { pushSTACK(make_string_output_stream()); # String-Output-Stream
  8804.     prin1_up(); # PRIN1 durchfⁿhren
  8805.     value1 = get_output_stream_string(&STACK_0); mv_count=1; # Ergebnis-String als Wert
  8806.     skipSTACK(2);
  8807.   }
  8808.  
  8809. # (defun princ-to-string (object)
  8810. #   (with-output-to-string (stream) (princ object stream))
  8811. # )
  8812. LISPFUNN(princ_to_string,1)
  8813. # (PRINC-TO-STRING object), CLTL S. 383
  8814.   { pushSTACK(make_string_output_stream()); # String-Output-Stream
  8815.     princ_up(); # PRINC durchfⁿhren
  8816.     value1 = get_output_stream_string(&STACK_0); mv_count=1; # Ergebnis-String als Wert
  8817.     skipSTACK(2);
  8818.   }
  8819.  
  8820. LISPFUN(write_char,1,1,norest,nokey,0,NIL)
  8821. # (WRITE-CHAR character [stream]), CLTL S. 384
  8822.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8823.    {var reg1 object ch = STACK_1; # character-Argument
  8824.     if (!charp(ch))
  8825.       { pushSTACK(ch); # Wert fⁿr Slot DATUM von TYPE-ERROR
  8826.         pushSTACK(S(character)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  8827.         pushSTACK(ch);
  8828.         pushSTACK(TheSubr(subr_self)->name);
  8829.         fehler(type_error,
  8830.                DEUTSCH ? "~: ~ ist kein Character." :
  8831.                ENGLISH ? "~: ~ is not a character" :
  8832.                FRANCAIS ? "~ : ~ n'est pas un caractΦre." :
  8833.                ""
  8834.               );
  8835.       }
  8836.     write_char(&STACK_0,ch);
  8837.     value1 = ch; mv_count=1; # ch (nicht GC-gefΣhrdet) als Wert
  8838.     skipSTACK(2);
  8839.   }}
  8840.  
  8841. # UP fⁿr WRITE-STRING und WRITE-LINE:
  8842. # ▄berprⁿft die Argumente und gibt einen String-Teil auf einen Stream aus.
  8843. # > subr_self: Aufrufer (ein SUBR)
  8844. # > Stackaufbau: String-Argument, Stream-Argument, :START-Argument, :END-Argument.
  8845. # < Stackaufbau: Stream, String.
  8846. # kann GC ausl÷sen
  8847.   local void write_string_up (void);
  8848.   local void write_string_up()
  8849.     {{ pushSTACK(STACK_2); # Stream ans STACK-Ende
  8850.        test_ostream(); # ⁿberprⁿfen
  8851.        STACK_(2+1) = STACK_(3+1);
  8852.        STACK_(3+1) = STACK_0;
  8853.        skipSTACK(1);
  8854.      }# Stackaufbau: stream, string, :START-Argument, :END-Argument.
  8855.       # Grenzen ⁿberprⁿfen:
  8856.       { var object string;
  8857.         var uintL start;
  8858.         var uintL len;
  8859.         test_string_limits(&string,&start,&len);
  8860.         pushSTACK(string);
  8861.         # Stackaufbau: stream, string.
  8862.        {var reg1 object sstring = array_displace_check(string,len,&start); # Datenvektor
  8863.         # start = Startindex im Datenvektor sstring
  8864.         write_sstring_ab(&STACK_1,sstring,start,len); # angesprochene Characters ausgeben
  8865.       }}
  8866.     }
  8867.  
  8868. LISPFUN(write_string,1,1,norest,key,2, (kw(start),kw(end)) )
  8869. # (WRITE-STRING string [stream] [:start] [:end]), CLTL S. 384
  8870.   { write_string_up(); # ⁿberprⁿfen und ausgeben
  8871.     value1 = popSTACK(); mv_count=1; skipSTACK(1); # string als Wert
  8872.   }
  8873.  
  8874. LISPFUN(write_line,1,1,norest,key,2, (kw(start),kw(end)) )
  8875. # (WRITE-LINE string [stream] [:start] [:end]), CLTL S. 384
  8876.   { write_string_up(); # ⁿberprⁿfen und ausgeben
  8877.     terpri(&STACK_1); # neue Zeile
  8878.     value1 = popSTACK(); mv_count=1; skipSTACK(1); # string als Wert
  8879.   }
  8880.  
  8881. LISPFUN(terpri,0,1,norest,nokey,0,NIL)
  8882. # (TERPRI [stream]), CLTL S. 384
  8883.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8884.     terpri(&STACK_0); # neue Zeile
  8885.     value1 = NIL; mv_count=1; skipSTACK(1); # NIL als Wert
  8886.   }
  8887.  
  8888. LISPFUN(fresh_line,0,1,norest,nokey,0,NIL)
  8889. # (FRESH-LINE [stream]), CLTL S. 384
  8890.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8891.     if (eq(get_line_position(STACK_0),Fixnum_0)) # Line-Position = 0 ?
  8892.       { value1 = NIL; mv_count=1; } # ja -> NIL als Wert
  8893.       else
  8894.       { terpri(&STACK_0); # nein -> neue Zeile
  8895.         value1 = T; mv_count=1; # und T als Wert
  8896.       }
  8897.     skipSTACK(1);
  8898.   }
  8899.  
  8900. LISPFUN(finish_output,0,1,norest,nokey,0,NIL)
  8901. # (FINISH-OUTPUT [stream]), CLTL S. 384
  8902.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8903.     finish_output(popSTACK()); # Output ans Ziel bringen
  8904.     value1 = NIL; mv_count=1; # NIL als Wert
  8905.   }
  8906.  
  8907. LISPFUN(force_output,0,1,norest,nokey,0,NIL)
  8908. # (FORCE-OUTPUT [stream]), CLTL S. 384
  8909.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8910.     force_output(popSTACK()); # Output ans Ziel bringen
  8911.     value1 = NIL; mv_count=1; # NIL als Wert
  8912.   }
  8913.  
  8914. LISPFUN(clear_output,0,1,norest,nokey,0,NIL)
  8915. # (CLEAR-OUTPUT [stream]), CLTL S. 384
  8916.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8917.     clear_output(popSTACK()); # Output l÷schen
  8918.     value1 = NIL; mv_count=1; # NIL als Wert
  8919.   }
  8920.  
  8921. LISPFUN(write_unreadable,3,0,norest,key,2, (kw(type),kw(identity)) )
  8922. # (SYSTEM::WRITE-UNREADABLE function object stream [:type] [:identity]),
  8923. # vgl. CLtL2 S. 580
  8924.   { var reg2 boolean flag_fun = FALSE;
  8925.     var reg4 boolean flag_type = FALSE;
  8926.     var reg3 boolean flag_id = FALSE;
  8927.     { var reg1 object arg = popSTACK(); # :identity - Argument
  8928.       if (!(eq(arg,unbound) || nullp(arg))) { flag_id = TRUE; }
  8929.     }
  8930.     { var reg1 object arg = popSTACK(); # :type - Argument
  8931.       if (!(eq(arg,unbound) || nullp(arg))) { flag_type = TRUE; }
  8932.     }
  8933.     if (!nullp(STACK_2)) { flag_fun = TRUE; }
  8934.     test_ostream(); # Output-Stream ⁿberprⁿfen
  8935.     if (test_value(S(print_readably))) { fehler_print_readably(STACK_1); }
  8936.    {var reg1 object* stream_ = &STACK_0;
  8937.     write_schar(stream_,'#'); write_schar(stream_,'<');
  8938.     INDENT_START(2); # um 2 Zeichen einrⁿcken, wegen '#<'
  8939.     JUSTIFY_START;
  8940.     if (flag_type)
  8941.       { # (TYPE-OF object) ausgeben:
  8942.         pushSTACK(*(stream_ STACKop 1)); funcall(L(type_of),1);
  8943.         prin1(stream_,value1);
  8944.         if (flag_fun || flag_id) { JUSTIFY_SPACE; }
  8945.       }
  8946.     if (flag_fun)
  8947.       { funcall(*(stream_ STACKop 2),0); } # (FUNCALL function)
  8948.     if (flag_id)
  8949.       { if (flag_fun) { JUSTIFY_SPACE; }
  8950.         pr_hex6(stream_,*(stream_ STACKop 1));
  8951.       }
  8952.     JUSTIFY_END_ENG;
  8953.     INDENT_END;
  8954.     write_schar(stream_,'>');
  8955.     skipSTACK(3);
  8956.     value1 = NIL; mv_count=1;
  8957.   }}
  8958.  
  8959. LISPFUN(line_position,0,1,norest,nokey,0,NIL)
  8960. # (SYS::LINE-POSITION [stream]), Hilfsfunktion fⁿr FORMAT ~T,
  8961. # liefert die Position eines (Output-)Streams in der momentanen Zeile.
  8962.   { test_ostream(); # Output-Stream ⁿberprⁿfen
  8963.     value1 = get_line_position(popSTACK()); mv_count=1; # Line-Position als Wert
  8964.   }
  8965.  
  8966.