home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / io.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  391.4 KB  |  9,157 lines
  1. # Ein-/Ausgabe für CLISP
  2. # Bruno Haible 14.6.1995
  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.     #ifdef IBMPC_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.       set_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.       //: DEUTSCH "Der Wert von ~ war keine Readtable, mußte zurückgesetzt werden."
  295.       //: ENGLISH "The value of ~ was not a readtable. It has been reset."
  296.       //: FRANCAIS "La valeur de ~ n'était pas un «readtable» et fut remise à la valeur standard."
  297.       fehler(type_error, GETTEXT("The value of ~ was not a readtable. It has been reset."));
  298.     }
  299.  
  300. # Macro: Holt die aktuelle Readtable.
  301. # get_readtable(readtable =);
  302. # < readtable : die aktuelle Readtable
  303.   #if 0
  304.     #define get_readtable(zuweisung)  \
  305.       { if (!sym_readtablep(S(readtablestern))) { fehler_bad_readtable(); }            \
  306.         zuweisung Symbol_value(S(readtablestern));                                     \
  307.       }
  308.   #else # oder (optimierter):
  309.     #define get_readtable(zuweisung)  \
  310.       { if (!(sym_orecordp(S(readtablestern))                                                            \
  311.               && (TheRecord( zuweisung Symbol_value(S(readtablestern)) )->rectype == Rectype_Readtable)  \
  312.            ) )                                                                                           \
  313.           { fehler_bad_readtable(); }                                                                    \
  314.       }
  315.   #endif
  316.  
  317.  
  318. # =============================================================================
  319. # Initialisierung
  320. # =============================================================================
  321.  
  322. # UP: Initialisiert den Reader.
  323. # init_reader();
  324. # kann GC auslösen
  325.   global void init_reader (void);
  326.   global void init_reader()
  327.     { # *READ-BASE* initialisieren:
  328.         define_variable(S(read_base),fixnum(10)); # *READ-BASE* := 10
  329.       # *READ-SUPPRESS* initialisieren:
  330.         define_variable(S(read_suppress),NIL);          # *READ-SUPPRESS* := NIL
  331.       # *READTABLE* initialisieren:
  332.       { var reg1 object readtable = orig_readtable();
  333.         O(standard_readtable) = readtable; # Das ist die Standard-Readtable,
  334.         readtable = copy_readtable(readtable); # eine Kopie von ihr
  335.         define_variable(S(readtablestern),readtable);   # =: *READTABLE*
  336.       }
  337.       # token_buff_1 und token_buff_2 initialisieren:
  338.         O(token_buff_1) = NIL;
  339.         # token_buff_1 und token_buff_2 werden beim ersten Aufruf von
  340.         # get_buffers (s.u.) mit zwei Semi-Simple-Strings initialisiert.
  341.       # Displaced-String initialisieren:
  342.         # neuer Array (mit Datenvektor NIL), Displaced, Rang=1
  343.         O(displaced_string) =
  344.           allocate_array(bit(arrayflags_displaced_bit)|bit(arrayflags_dispoffset_bit)|
  345.                          bit(arrayflags_notbytep_bit)|Atype_String_Char,
  346.                          1,
  347.                          string_type
  348.                         );
  349.     }
  350.  
  351.  
  352. # =============================================================================
  353. # LISP - Funktionen für Readtables
  354. # =============================================================================
  355.  
  356. # Fehler, wenn Argument keine Readtable ist.
  357. # fehler_readtable(obj);
  358. # > obj: fehlerhaftes Argument
  359. # > subr_self: Aufrufer (ein SUBR)
  360.   nonreturning_function(local, fehler_readtable, (object obj));
  361.   local void fehler_readtable(obj)
  362.     var reg1 object obj;
  363.     { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  364.       pushSTACK(S(readtable)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  365.       pushSTACK(obj);
  366.       pushSTACK(TheSubr(subr_self)->name);
  367.       //: DEUTSCH "~: Argument ~ ist keine Readtable."
  368.       //: ENGLISH "~: argument ~ is not a readtable"
  369.       //: FRANCAIS "~ : L'argument ~ n'est pas un «readtable»."
  370.       fehler(type_error, GETTEXT("~: argument ~ is not a readtable"));
  371.     }
  372.  
  373. LISPFUN(copy_readtable,0,2,norest,nokey,0,NIL)
  374. # (COPY-READTABLE [from-readtable [to-readtable]]), CLTL S. 361
  375.   { var reg1 object from_readtable = STACK_1;
  376.     if (eq(from_readtable,unbound))
  377.       # gar keine Argumente angegeben
  378.       { get_readtable(from_readtable=); # aktuelle Readtable
  379.         value1 = copy_readtable(from_readtable); # kopieren
  380.       }
  381.       else
  382.       { if (nullp(from_readtable))
  383.           # statt NIL nimm die Standard-Readtable
  384.           { from_readtable = O(standard_readtable); }
  385.           else
  386.           # from-readtable überprüfen:
  387.           { if (!readtablep(from_readtable)) { fehler_readtable(from_readtable); } }
  388.         # from-readtable ist OK
  389.        {var reg2 object to_readtable = STACK_0;
  390.         if (eq(to_readtable,unbound) || nullp(to_readtable))
  391.           # kopiere from-readtable, ohne to-readtable
  392.           { value1 = copy_readtable(from_readtable); }
  393.           else
  394.           # to-readtable überprüfen und umkopieren:
  395.           { if (!readtablep(to_readtable)) { fehler_readtable(to_readtable); }
  396.             value1 = copy_readtable_contents(from_readtable,to_readtable);
  397.           }
  398.       }}
  399.     mv_count=1; skipSTACK(2);
  400.   }
  401.  
  402. LISPFUN(set_syntax_from_char,2,2,norest,nokey,0,NIL)
  403. # (SET-SYNTAX-FROM-CHAR to-char from-char [to-readtable [from-readtable]]),
  404. # CLTL S. 361
  405.   { var reg3 object to_char = STACK_3;
  406.     var reg4 object from_char = STACK_2;
  407.     var reg2 object to_readtable = STACK_1;
  408.     var reg1 object from_readtable = STACK_0;
  409.     skipSTACK(4);
  410.     # to-char überprüfen:
  411.     if (!string_char_p(to_char)) { fehler_string_char(to_char); } # muß ein String-Char sein
  412.     # from-char überprüfen:
  413.     if (!string_char_p(from_char)) { fehler_string_char(from_char); } # muß ein String-Char sein
  414.     # to-readtable überprüfen:
  415.     if (eq(to_readtable,unbound))
  416.       { get_readtable(to_readtable=); } # Default ist die aktuelle Readtable
  417.       else
  418.       { if (!readtablep(to_readtable)) { fehler_readtable(to_readtable); } }
  419.     # from-readtable überprüfen:
  420.     if (eq(from_readtable,unbound) || nullp(from_readtable))
  421.       { from_readtable = O(standard_readtable); } # Default ist die Standard-Readtable
  422.       else
  423.       { if (!readtablep(from_readtable)) { fehler_readtable(from_readtable); } }
  424.     # Nun sind to_char, from_char, to_readtable, from_readtable OK.
  425.     { var reg5 uintL to_c = char_code(to_char);
  426.       var reg6 uintL from_c = char_code(from_char);
  427.       # Syntaxcode kopieren:
  428.       TheSbvector(TheReadtable(to_readtable)->readtable_syntax_table)->data[to_c] =
  429.         TheSbvector(TheReadtable(from_readtable)->readtable_syntax_table)->data[from_c];
  430.       # Macro-Funktion/Vektor kopieren:
  431.      {var reg1 object entry =
  432.         TheSvector(TheReadtable(from_readtable)->readtable_macro_table)->data[from_c];
  433.       if (simple_vector_p(entry))
  434.         # Ist entry ein Simple-Vector, so muß er kopiert werden:
  435.         { pushSTACK(to_readtable);
  436.           entry = copy_svector(entry);
  437.           to_readtable = popSTACK();
  438.         }
  439.       TheSvector(TheReadtable(to_readtable)->readtable_macro_table)->data[to_c] =
  440.         entry;
  441.     }}
  442.     value1 = T; mv_count=1; # Wert T
  443.   }
  444.  
  445. # UP: Überprüft ein optionales Readtable-Argument,
  446. # mit Default = Current Readtable.
  447. # > STACK_0: Argument
  448. # > subr_self: Aufrufer (ein SUBR)
  449. # < STACK: um 1 erhöht
  450. # < ergebnis: readtable
  451.   local object test_readtable_arg (void);
  452.   local object test_readtable_arg()
  453.     { var reg1 object readtable = popSTACK();
  454.       if (eq(readtable,unbound))
  455.         { get_readtable(readtable=); } # Default ist die aktuelle Readtable
  456.         else
  457.         { if (!readtablep(readtable)) { fehler_readtable(readtable); } } # überprüfen
  458.       return readtable;
  459.     }
  460.  
  461. # UP: Überprüft ein optionales Readtable-Argument,
  462. # mit Default = Current Readtable, NIL = Standard-Readtable.
  463. # > STACK_0: Argument
  464. # > subr_self: Aufrufer (ein SUBR)
  465. # < STACK: um 1 erhöht
  466. # < ergebnis: readtable
  467.   local object test_readtable_null_arg (void);
  468.   local object test_readtable_null_arg()
  469.     { var reg1 object readtable = popSTACK();
  470.       if (eq(readtable,unbound))
  471.         { get_readtable(readtable=); } # Default ist die aktuelle Readtable
  472.       elif (nullp(readtable))
  473.         { readtable = O(standard_readtable); } # bzw. die Standard-Readtable
  474.       else
  475.         { if (!readtablep(readtable)) { fehler_readtable(readtable); } } # überprüfen
  476.       return readtable;
  477.     }
  478.  
  479. # UP: Überprüft das vorletzte optionale Argument von
  480. # SET-MACRO-CHARACTER und MAKE-DISPATCH-MACRO-CHARACTER.
  481. # > STACK_0: non-terminating-p - Argument
  482. # > subr_self: Aufrufer (ein SUBR)
  483. # < STACK: um 1 erhöht
  484. # < ergebnis: neuer Syntaxcode
  485.   local uintB test_nontermp_arg (void);
  486.   local uintB test_nontermp_arg()
  487.     { var reg1 object arg = popSTACK();
  488.       if (eq(arg,unbound) || nullp(arg))
  489.         { return syntax_t_macro; } # Default ist terminating
  490.         else
  491.         { return syntax_nt_macro; } # non-terminating-p angegeben und /= NIL
  492.     }
  493.  
  494. LISPFUN(set_macro_character,2,2,norest,nokey,0,NIL)
  495. # (SET-MACRO-CHARACTER char function [non-terminating-p [readtable]]),
  496. # CLTL S. 362
  497.   { # char überprüfen:
  498.     { var reg1 object ch = STACK_3;
  499.       if (!string_char_p(ch)) { fehler_string_char(ch); }
  500.     }
  501.     # function überprüfen und in ein Objekt vom Typ FUNCTION umwandeln:
  502.     STACK_2 = coerce_function(STACK_2);
  503.    {var reg1 object readtable = test_readtable_arg(); # Readtable
  504.     var reg4 uintB syntaxcode = test_nontermp_arg(); # neuer Syntaxcode
  505.     var reg3 object function = popSTACK();
  506.     var reg2 uintL c = char_code(popSTACK());
  507.     # Syntaxcode setzen:
  508.     TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[c] =
  509.       syntaxcode;
  510.     # Macrodefinition eintragen:
  511.     TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[c] =
  512.       function;
  513.     value1 = T; mv_count=1; # 1 Wert T
  514.   }}
  515.  
  516. LISPFUN(get_macro_character,1,1,norest,nokey,0,NIL)
  517. # (GET-MACRO-CHARACTER char [readtable]), CLTL S. 362
  518.   { # char überprüfen:
  519.     { var reg1 object ch = STACK_1;
  520.       if (!string_char_p(ch)) { fehler_string_char(ch); }
  521.     }
  522.    {var reg1 object readtable = test_readtable_null_arg(); # Readtable
  523.     var reg4 object ch = popSTACK();
  524.     var reg2 uintL c = char_code(ch);
  525.     # Teste den Syntaxcode:
  526.     var reg3 object nontermp = NIL; # non-terminating-p Flag
  527.     switch (TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[c])
  528.       { case syntax_nt_macro: nontermp = T;
  529.         case syntax_t_macro: # nontermp = NIL;
  530.           # c ist ein Macro-Character.
  531.           { var reg1 object entry =
  532.               TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[c];
  533.             if (simple_vector_p(entry))
  534.               # c ist ein Dispatch-Macro-Character.
  535.               { pushSTACK(ch);
  536.                 pushSTACK(TheSubr(subr_self)->name);
  537.                 //: DEUTSCH "~: ~ ist ein Dispatch-Macro-Zeichen."
  538.                 //: ENGLISH "~: ~ is a dispatch macro character"
  539.                 //: FRANCAIS "~ : ~ est un caractère de «macro-dispatch»."
  540.                 fehler(error, GETTEXT("~: ~ is a dispatch macro character"));
  541.               }
  542.               # Besser wäre es, eine Funktion zurückzugeben, die den Vektor
  543.               # mit den Dispatch-Macro-Zeichen-Definitionen enthält, und bei
  544.               # SET-MACRO-CHARACTER auf eine solche Funktion zu testen. ??
  545.               else
  546.               { value1 = entry; break; }
  547.           }
  548.         default: # nontermp = NIL;
  549.           value1 = NIL; break;
  550.       }
  551.     value2 = nontermp; mv_count=2; # nontermp als 2. Wert
  552.   }}
  553.  
  554. LISPFUN(make_dispatch_macro_character,1,2,norest,nokey,0,NIL)
  555. # (MAKE-DISPATCH-MACRO-CHARACTER char [non-terminating-p [readtable]]),
  556. # CLTL S. 363
  557.   { var reg1 object readtable = test_readtable_arg(); # Readtable
  558.     var reg5 uintB syntaxcode = test_nontermp_arg(); # neuer Syntaxcode
  559.     # char überprüfen:
  560.     var reg3 object ch = popSTACK();
  561.     if (!string_char_p(ch)) { fehler_string_char(ch); }
  562.    {var reg2 uintL c = char_code(ch);
  563.     # neue (leere) Dispatch-Macro-Tabelle holen:
  564.     pushSTACK(readtable);
  565.     {var reg4 object dm_table = allocate_vector(DRM_anzahl); # Vektor, mit NIL gefüllt
  566.      readtable = popSTACK();
  567.     # alles in der Readtable ablegen:
  568.      # Syntaxcode in die Syntax-Table:
  569.      TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[c] =
  570.        syntaxcode;
  571.      # neue Dispatch-Macro-Tabelle in die Macrodefinitionen-Tabelle:
  572.      TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[c] =
  573.        dm_table;
  574.     }
  575.     value1 = T; mv_count=1; # 1 Wert T
  576.   }}
  577.  
  578. # UP: Überprüft die Argumente disp-char und sub-char.
  579. # > STACK: STACK_1 = disp-char, STACK_0 = sub-char
  580. # > readtable: Readtable
  581. # > subr_self: Aufrufer (ein SUBR)
  582. # < STACK: um 2 erhöht (außer wenn sub-char eine Ziffer ist)
  583. # < ergebnis: Pointer auf den zu sub-char gehörenden Eintrag in der
  584. #             Dispatch-Macro-Tabelle zu disp-char,
  585. #             NULL falls sub-char eine Ziffer ist.
  586.   local object* test_disp_sub_char (object readtable);
  587.   local object* test_disp_sub_char(readtable)
  588.     var reg1 object readtable;
  589.     { var reg6 object sub_ch = popSTACK(); # sub-char
  590.       var reg5 object disp_ch = popSTACK(); # disp-char
  591.       if (!string_char_p(disp_ch)) { fehler_string_char(disp_ch); } # disp-char muß ein String-Char sein
  592.       if (!string_char_p(sub_ch)) { fehler_string_char(sub_ch); } # sub-char muß ein String-Char sein
  593.      {var reg4 uintL disp_c = char_code(disp_ch);
  594.       var reg2 object entry = TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[disp_c];
  595.       if (!simple_vector_p(entry))
  596.         { pushSTACK(disp_ch);
  597.           pushSTACK(TheSubr(subr_self)->name);
  598.           //: DEUTSCH "~: ~ ist kein Dispatch-Macro-Zeichen."
  599.           //: ENGLISH "~: ~ is not a dispatch macro character"
  600.           //: FRANCAIS "~ : ~ n'est pas un caractère de «macro-dispatch»."
  601.           fehler(error, GETTEXT("~: ~ is not a dispatch macro character"));
  602.         }
  603.       # disp-char ist ein Dispatching-Macro-Character, entry der Vektor.
  604.       {var reg3 uintB sub_c = up_case(char_code(sub_ch)); # sub-char in Großbuchstaben umwandeln
  605.        if ((sub_c >= '0') && (sub_c <= '9'))
  606.          # Ziffer
  607.          { pushSTACK(sub_ch); return (object*)NULL; }
  608.          else
  609.          # gültiges sub-char
  610.          { return &TheSvector(entry)->data[(uintP)sub_c]; }
  611.     }}}
  612.  
  613. LISPFUN(set_dispatch_macro_character,3,1,norest,nokey,0,NIL)
  614. # (SET-DISPATCH-MACRO-CHARACTER disp-char sub-char function [readtable]),
  615. # CLTL S. 364
  616.   { # function überprüfen und in ein Objekt vom Typ FUNCTION umwandeln:
  617.     STACK_1 = coerce_function(STACK_1);
  618.     subr_self = L(set_dispatch_macro_character);
  619.    {var reg2 object readtable = test_readtable_arg(); # Readtable
  620.     var reg3 object function = popSTACK(); # function
  621.     var reg1 object* ptr = test_disp_sub_char(readtable);
  622.     if (ptr == (object*)NULL)
  623.       { # STACK_0 = sub-char, Wert für Slot DATUM von TYPE-ERROR
  624.         pushSTACK(O(type_not_digit)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  625.         pushSTACK(STACK_1);
  626.         pushSTACK(TheSubr(subr_self)->name);
  627.         //: DEUTSCH "~: Ziffer $ als sub-char nicht erlaubt."
  628.         //: ENGLISH "~: digit $ not allowed as sub-char"
  629.         //: FRANCAIS "~ : Un chiffre $ n'est pas permis comme sous-caractère."
  630.         fehler(type_error, GETTEXT("~: digit $ not allowed as sub-char"));
  631.       }
  632.       else
  633.       { *ptr = function; # Funktion in die Dispatch-Macro-Tabelle eintragen
  634.         value1 = T; mv_count=1; # 1 Wert T
  635.       }
  636.   }}
  637.  
  638. LISPFUN(get_dispatch_macro_character,2,1,norest,nokey,0,NIL)
  639. # (GET-DISPATCH-MACRO-CHARACTER disp-char sub-char [readtable]), CLTL S. 364
  640.   { var reg2 object readtable = test_readtable_null_arg(); # Readtable
  641.     var reg1 object* ptr = test_disp_sub_char(readtable);
  642.     value1 = (ptr == (object*)NULL ? NIL : *ptr); mv_count=1; # NIL oder Funktion als Wert
  643.   }
  644.  
  645. LISPFUNN(readtable_case,1)
  646. # (READTABLE-CASE readtable), CLTL2 S. 549
  647.   { var reg1 object readtable = popSTACK(); # Readtable
  648.     if (!readtablep(readtable)) { fehler_readtable(readtable); } # überprüfen
  649.     value1 = (&O(rtcase_0))[(uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case)];
  650.     mv_count=1;
  651.   }
  652.  
  653. LISPFUNN(set_readtable_case,2)
  654. # (SYSTEM::SET-READTABLE-CASE readtable value), CLTL2 S. 549
  655.   { var reg4 object value = popSTACK();
  656.     var reg5 object readtable = popSTACK(); # Readtable
  657.     if (!readtablep(readtable)) { fehler_readtable(readtable); } # überprüfen
  658.     # Symbol value in einen Index umwandeln durch Suche in der Tabelle O(rtcase..):
  659.    {var reg1 object* ptr = &O(rtcase_0);
  660.     var reg3 object rtcase = Fixnum_0;
  661.     var reg2 uintC count;
  662.     dotimesC(count,3,
  663.       { if (eq(*ptr,value)) goto found;
  664.         ptr++; rtcase = fixnum_inc(rtcase,1);
  665.       });
  666.     # kein gültiger Wert
  667.     pushSTACK(value); # Wert für Slot DATUM von TYPE-ERROR
  668.     pushSTACK(O(type_rtcase)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  669.     pushSTACK(O(rtcase_2)); pushSTACK(O(rtcase_1)); pushSTACK(O(rtcase_0));
  670.     pushSTACK(value);
  671.     pushSTACK(S(set_readtable_case));
  672.     //: DEUTSCH "~: neuer Wert ~ sollte ~, ~ oder ~ sein."
  673.     //: ENGLISH "~: new value ~ should be ~, ~ or ~."
  674.     //: FRANCAIS "~ : La nouvelle valeur ~ devrait être ~, ~ ou ~."
  675.     fehler(type_error, GETTEXT("~: new value ~ should be ~, ~ or ~."));
  676.     found: # in der Tabelle gefunden
  677.     TheReadtable(readtable)->readtable_case = rtcase;
  678.     value1 = value; mv_count=1;
  679.   }}
  680.  
  681. # =============================================================================
  682. # Einige Hilfsroutinen und Macros für READ und PRINT
  683. # =============================================================================
  684.  
  685. # Testet den dynamischen Wert eines Symbols auf /=NIL
  686. # < TRUE, wenn /= NIL
  687. # #define test_value(sym)  (!sym_nullp(sym))
  688.   #define test_value(sym)  (!eq(NIL,Symbol_symvalue(sym)))
  689.  
  690. # UP: Holt den Wert eines Symbols. Muß Fixnum >=2, <=36 sein.
  691. # get_base(symbol)
  692. # > symbol: Symbol
  693. # < ergebnis: Wert des Symbols, >=2, <=36.
  694.   local uintL get_base (object symbol);
  695.   local uintL get_base(symbol)
  696.     var reg3 object symbol;
  697.     { var reg2 object value = Symbol_value(symbol);
  698.       var reg1 uintL wert;
  699.       if (posfixnump(value) &&
  700.           (wert = posfixnum_to_L(value), ((wert >= 2) && (wert <= 36)))
  701.          )
  702.         { return wert; }
  703.         else
  704.         { pushSTACK(value); # Wert für Slot DATUM von TYPE-ERROR
  705.           pushSTACK(O(type_radix)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  706.           pushSTACK(value);
  707.           pushSTACK(symbol);
  708.           set_Symbol_value(symbol,fixnum(10)); # Wert auf 10 setzen
  709.           { const char *msg1,*msg2;
  710.             //: DEUTSCH "Der Wert von ~ sollte eine ganze Zahl zwischen 2 und 36 sein, nicht ~." 
  711.             //: ENGLISH "The value of ~ should be an integer between 2 and 36, not ~."
  712.             //: FRANCAIS "La valeur de ~ doit être un nombre entier entre 2 et 36 et non ~."
  713.             msg1 = GETTEXT("The value of ~ should be an integer between 2 and 36, not ~.");
  714.             //: DEUTSCH "Er wird auf 10 gesetzt."
  715.             //: ENGLISH "It has been reset to 10."
  716.             //: FRANCAIS "Elle a été mise à 10."
  717.             msg2 = GETTEXT("It has been reset to 10.");
  718.             fehler3(type_error,msg1,NLstring,msg2);
  719.           }
  720.         }
  721.     }
  722.  
  723. # UP: Holt den Wert von *PRINT-BASE*
  724. # get_print_base()
  725. # < uintL ergebnis: >=2, <=36
  726.   #define get_print_base()  \
  727.     (test_value(S(print_readably)) ? 10 : get_base(S(print_base)))
  728.  
  729. # UP: Holt den Wert von *READ-BASE*
  730. # get_read_base()
  731. # < uintL ergebnis: >=2, <=36
  732.   #define get_read_base()  get_base(S(read_base))
  733.  
  734.  
  735. # =============================================================================
  736. #                              R E A D
  737. # =============================================================================
  738.  
  739. # Es werden einzelne Characters gelesen.
  740. # Mit Hilfe der Readtable werden Syntaxcodes (vgl. CLTL Table 22-1) gebildet.
  741. # Bei Syntaxcode = constituent wird ein (Extended) Token angefangen.
  742. # Mit Hilfe der Attributtabelle (vgl. CLTL Table 22-3) wird jedem Character
  743. # im Token ein Attribut a_xxxx zugeordnet.
  744. # O(token_buff_1) ist ein Semi-Simple-String, der die Characters des
  745. # gerade eingelesenen Extended-Tokens enthält.
  746. # O(token_buff_2) ist ein Semi-Simple-String, der die Attribute des
  747. # gerade eingelesenen Extended-Tokens enthält.
  748. # Beide haben dieselbe Länge.
  749.  
  750. # Spezielle Objekte, die bei READ als Ergebnis kommen können:
  751. #   eof_value: spezielles Objekt, das EOF anzeigt
  752. #   dot_value: Hilfswert zum Erkennen einzelner Dots
  753.  
  754. # ------------------------ READ auf Character-Ebene ---------------------------
  755.  
  756. # Fehler, wenn Zeichen kein String-Char ist:
  757. # fehler_charread(ch,&stream);
  758.   nonreturning_function(local, fehler_charread, (object ch, object* stream_));
  759.   local void fehler_charread(ch,stream_)
  760.     var reg2 object ch;
  761.     var reg1 object* stream_;
  762.     { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  763.       pushSTACK(ch); # Character
  764.       pushSTACK(*stream_); # Stream
  765.       pushSTACK(S(read));
  766.       //: DEUTSCH "~ von ~: Gelesenes Zeichen ist kein String-Char: ~"
  767.       //: ENGLISH "~ from ~: character read should be a string-char: ~"
  768.       //: FRANCAIS "~ de ~ : le caractère lu n'est pas de type STRING-CHAR."
  769.       fehler(stream_error, GETTEXT("~ from ~: character read should be a string-char: ~"));
  770.     }
  771.  
  772. # UP: Liest ein Zeichen und berechnet seinen Syntaxcode.
  773. # read_char_syntax(ch=,scode=,&stream);
  774. # > stream: Stream
  775. # < stream: Stream
  776. # < object ch: String-Char oder eof_value
  777. # < uintWL scode: Syntaxcode (aus der aktuellen Readtable) bzw. syntax_eof
  778. # kann GC auslösen
  779.   #define read_char_syntax(ch_zuweisung,scode_zuweisung,stream_)  \
  780.     { var reg1 object ch0 = read_char(stream_); # Character lesen      \
  781.       ch_zuweisung ch0;                                                \
  782.       if (eq(ch0,eof_value)) # EOF ?                                   \
  783.         { scode_zuweisung syntax_eof; }                                \
  784.         else                                                           \
  785.         # sonst Character.                                             \
  786.         { # Auf String-Char überprüfen:                                \
  787.           if (!string_char_p(ch0)) { fehler_charread(ch0,stream_); }   \
  788.          {var reg2 object readtable;                                   \
  789.           get_readtable(readtable = );                                 \
  790.           scode_zuweisung # Syntaxcode aus Tabelle holen               \
  791.             TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[(uintP)char_code(ch0)]; \
  792.         }}                                                             \
  793.     }
  794.  
  795. # Case-Konversion:
  796.   typedef uintB case_converter (uintB c);
  797.   local uintB preserve_case (uintB c);
  798.   local uintB preserve_case(c)
  799.     var reg1 uintB c;
  800.     { return c; }
  801.  
  802. # Fehlermeldung bei EOF außerhalb von Objekten
  803. # fehler_eof_aussen(&stream);
  804. # > stream: Stream
  805.   nonreturning_function(local, fehler_eof_aussen, (object* stream_));
  806.   local void fehler_eof_aussen(stream_)
  807.     var reg1 object* stream_;
  808.     { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  809.       pushSTACK(*stream_); # Stream
  810.       pushSTACK(S(read));
  811.       //: DEUTSCH "~: Eingabestream ~ ist zu Ende."
  812.       //: ENGLISH "~: input stream ~ has reached its end"
  813.       //: FRANCAIS "~ : Le «stream» d'entrée ~ est épuisé."
  814.       fehler(end_of_file, GETTEXT("~: input stream ~ has reached its end"));
  815.     }
  816.  
  817. # Fehlermeldung bei EOF innerhalb von Objekten
  818. # fehler_eof_innen(&stream);
  819. # > stream: Stream
  820.   nonreturning_function(local, fehler_eof_innen, (object* stream_));
  821.   local void fehler_eof_innen(stream_)
  822.     var reg1 object* stream_;
  823.     { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  824.       if (sym_posfixnump(S(read_line_number))) # SYS::*READ-LINE-NUMBER* abfragen
  825.         { pushSTACK(Symbol_value(S(read_line_number))); # Zeilennummer
  826.           pushSTACK(*stream_); # Stream
  827.           pushSTACK(S(read));
  828.           //: DEUTSCH "~: Eingabestream ~ endet innerhalb eines Objekts. Letzte öffnende Klammer vermutlich in Zeile ~."
  829.           //: ENGLISH "~: input stream ~ ends within an object. Last opening parenthesis probably in line ~."
  830.           //: 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 ~."
  831.           fehler(end_of_file, GETTEXT("~: input stream ~ ends within an object. Last opening parenthesis probably in line ~."));
  832.         }
  833.         else
  834.         { pushSTACK(*stream_); # Stream
  835.           pushSTACK(S(read));
  836.           //: DEUTSCH "~: Eingabestream ~ endet innerhalb eines Objekts."
  837.           //: ENGLISH "~: input stream ~ ends within an object"
  838.           //: FRANCAIS "~ : Le «stream» d'entrée ~ se termine à l'intérieur d'un objet."
  839.           fehler(end_of_file, GETTEXT("~: input stream ~ ends within an object"));
  840.     }   }
  841.  
  842. # Fehlermeldung bei EOF, je nach *READ-RECURSIVE-P*
  843. # fehler_eof(&stream);
  844. # > stream: Stream
  845.   nonreturning_function(local, fehler_eof, (object* stream_));
  846.   local void fehler_eof(stream_)
  847.     var reg1 object* stream_;
  848.     { if (test_value(S(read_recursive_p))) # *READ-RECURSIVE-P* /= NIL ?
  849.         { fehler_eof_innen(stream_); }
  850.         else
  851.         { fehler_eof_aussen(stream_); }
  852.     }
  853.  
  854. # UP: Liest bis zum nächsten non-whitespace-Zeichen, ohne dieses zu
  855. # verbrauchen. Bei EOF Error.
  856. # wpeek_char_syntax(ch=,scode=,&stream);
  857. # > stream: Stream
  858. # < stream: Stream
  859. # < object ch: nächstes String-Char
  860. # < uintWL scode: sein Syntaxcode
  861. # kann GC auslösen
  862.   #define wpeek_char_syntax(ch_zuweisung,scode_zuweisung,stream_)  \
  863.     { loop                                                                 \
  864.         { var reg1 object ch0 = read_char(stream_); # Character lesen      \
  865.           if (eq(ch0,eof_value)) { fehler_eof(stream_); } # EOF -> Error   \
  866.           # sonst Character.                                               \
  867.           # Auf String-Char überprüfen:                                    \
  868.           if (!string_char_p(ch0)) { fehler_charread(ch0,stream_); }       \
  869.           {var reg2 object readtable;                                      \
  870.            get_readtable(readtable = );                                    \
  871.            if (!((scode_zuweisung # Syntaxcode aus Tabelle holen           \
  872.                     TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[(uintP)char_code(ch0)] \
  873.                  )                                                         \
  874.                  == syntax_whitespace                                      \
  875.               ) )                                                          \
  876.              # kein Whitespace -> letztes gelesenes Zeichen zurückschieben \
  877.              { unread_char(stream_,ch0); ch_zuweisung ch0; break; }        \
  878.         } }                                                                \
  879.     }
  880.  
  881. # UP: Liest bis zum nächsten non-whitespace-Zeichen, ohne dieses zu
  882. # verbrauchen.
  883. # wpeek_char_eof(&stream)
  884. # > stream: Stream
  885. # < stream: Stream
  886. # < ergebnis: nächstes String-Char oder eof_value
  887. # kann GC auslösen
  888.   local object wpeek_char_eof (object* stream_);
  889.   local object wpeek_char_eof(stream_)
  890.     var reg3 object* stream_;
  891.     { loop
  892.         { var reg1 object ch = read_char(stream_); # Character lesen
  893.           if (eq(ch,eof_value)) { return ch; } # EOF ?
  894.           # sonst Character.
  895.           # Auf String-Char überprüfen:
  896.           if (!string_char_p(ch)) { fehler_charread(ch,stream_); }
  897.           {var reg2 object readtable;
  898.            get_readtable(readtable = );
  899.            if (!(( # Syntaxcode aus Tabelle holen
  900.                   TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[(uintP)char_code(ch)]
  901.                  )
  902.                  == syntax_whitespace
  903.               ) )
  904.              # kein Whitespace -> letztes gelesenes Zeichen zurückschieben
  905.              { unread_char(stream_,ch); return ch; }
  906.         } }
  907.     }
  908.  
  909. # ------------------------ READ auf Token-Ebene -------------------------------
  910.  
  911. # Bei read_token und test_potential_number_syntax, test_number_syntax werden
  912. # die Attribute gemäß CLTL Table 22-3 gebraucht.
  913. # Während test_potential_number_syntax werden Attribute umgewandelt,
  914. # a_digit teilweise in a_alpha oder a_letter oder a_expo_m.
  915.  
  916. # Bedeutung der Einträge in attribute_table:
  917.   #define a_illg     0   # illegales Constituent
  918.   #define a_pack_m   1   # ':' = Package-marker
  919.   #define a_alpha    2   # Zeichen ohne besondere Eigenschaften (alphabetic)
  920.   #define a_ratio    3   # '/'
  921.   #define a_dot      4   # '.'
  922.   #define a_plus     5   # '+'
  923.   #define a_minus    6   # '-'
  924.   #define a_extens   7   # '_^' extension characters
  925.   #define a_digit    8   # '0123456789'
  926.   #define a_letter   9   # 'A'-'Z','a'-'z', nicht 'esfdlESFDL'
  927.   #define a_expo_m  10   # 'esfdlESFDL'
  928.   #    >= a_letter       #  'A'-'Z','a'-'z'
  929.   #    >= a_digit        # '0123456789','A'-'Z','a'-'z'
  930.   #    >= a_ratio        # woraus eine potential number bestehen muß
  931.  
  932. # Attributtabelle für Constituents, Erstinterpretation:
  933. # Anmerkung: 0-9,A-Z,a-z werden erst als a_digit oder a_expo_m interpretiert,
  934. # dann (falls sich kein Integer aus einem Token ergibt) wird a_digit
  935. # oberhalb von *READ-BASE* als a_alpha (alphabetic) interpretiert.
  936.   local uintB attribute_table[RM_anzahl] = {
  937.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(0) bis chr(7)
  938.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(8) bis chr(15)
  939.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(16) bis chr(23)
  940.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,   # chr(24) bis chr(31)
  941.     a_illg,  a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # ' !"#$%&''
  942.     a_alpha, a_alpha, a_alpha, a_plus,  a_alpha, a_minus, a_dot,   a_ratio,  # '()*+,-./'
  943.     a_digit, a_digit, a_digit, a_digit, a_digit, a_digit, a_digit, a_digit,  # '01234567'
  944.     a_digit, a_digit, a_pack_m,a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '89:;<=>?'
  945.     a_alpha, a_letter,a_letter,a_letter,a_expo_m,a_expo_m,a_expo_m,a_letter, # '@ABCDEFG'
  946.     a_letter,a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter, # 'HIJKLMNO'
  947.     a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter,a_letter, # 'PQRSTUVW'
  948.     a_letter,a_letter,a_letter,a_alpha, a_alpha, a_alpha, a_extens,a_extens, # 'XYZ[\]^_'
  949.     a_alpha, a_letter,a_letter,a_letter,a_expo_m,a_expo_m,a_expo_m,a_letter, # '`abcdefg'
  950.     a_letter,a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter, # 'hijklmno'
  951.     a_letter,a_letter,a_letter,a_expo_m,a_letter,a_letter,a_letter,a_letter, # 'pqrstuvw'
  952.     a_letter,a_letter,a_letter,a_alpha, a_alpha, a_alpha, a_alpha,           # 'xyz{|}~'
  953.     #ifdef IBMPC_CHS
  954.                                                                    a_alpha,  # chr(127)
  955.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'Çüéâäàåç'
  956.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'êëèïîìÄÅ'
  957.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'ÉæÆôöòûù'
  958.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'ÿÖÜ¢£¥ß '
  959.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'áíóúñѪo'
  960.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '¿ ¬½¼¡«»'
  961.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'ãõØø  ÀÃ'
  962.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # 'Õ¨´ ¶©® '
  963.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' hebräische Buchstaben
  964.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' hebräische Buchstaben
  965.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' hebräische Buchstaben
  966.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '     §  ' hebräische Buchstaben und Symbole
  967.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '      µ ' griechische Buchstaben
  968.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '        ' griechische Buchstaben und Symbole
  969.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # ' ±    ÷ ' Symbole
  970.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,  # '°    ²³¯' Symbole
  971.     #elif defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS)
  972.                                                                    a_illg,
  973.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  974.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  975.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  976.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  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,
  981.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  982.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  983.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  984.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  985.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  986.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  987.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  988.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  989.     #elif defined(NEXTSTEP_CHS)
  990.                                                                    a_illg,
  991.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  992.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  993.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  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.     a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha, a_alpha,
  1007.     #else # defined(ASCII_CHS)
  1008.                                                                    a_illg,
  1009.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1010.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1011.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1012.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1013.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1014.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1015.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1016.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1017.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1018.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1019.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1020.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1021.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1022.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1023.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1024.     a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,  a_illg,
  1025.     #endif
  1026.     };
  1027.  
  1028. # Flag. Zeigt an, ob im letztgelesenen Token
  1029. # ein Single-Escape- oder Multiple-Escape-Zeichen vorkam:
  1030.   local boolean token_escape_flag;
  1031.  
  1032. # UP: Liefert zwei Buffer.
  1033. # Falls im Reservoir O(token_buff_1), O(token_buff_2) zwei verfügbar sind,
  1034. # werden sie entnommen. Sonst werden neue alloziert.
  1035. # Werden die Buffer nicht mehr gebraucht, so können sie in
  1036. # O(token_buff_1) und O(token_buff_2) geschrieben werden.
  1037. # < -(STACK),-(STACK): zwei Semi-Simple Strings mit Fill-Pointer 0
  1038. # < STACK: um 2 erniedrigt
  1039. # kann GC auslösen
  1040.   local void get_buffers (void);
  1041.   local void get_buffers()
  1042.     { # Mechanismus:
  1043.       # In O(token_buff_1) und O(token_buff_2) stehen zwei
  1044.       # Semi-Simple-Strings, die bei Bedarf entnommen (und mit
  1045.       # O(token_buff_1) := NIL als entnommen markiert) und nach Gebrauch
  1046.       # wieder hineingesetzt werden können. Reentrant!
  1047.       var reg1 object buff_1 = O(token_buff_1);
  1048.       if (!nullp(buff_1))
  1049.         # Buffer entnehmen und leeren:
  1050.         { TheArray(buff_1)->dims[1] = 0; # Fill-Pointer:=0
  1051.           pushSTACK(buff_1); # 1. Buffer fertig
  1052.          {var reg2 object buff_2 = O(token_buff_2);
  1053.           TheArray(buff_2)->dims[1] = 0; # Fill-Pointer:=0
  1054.           pushSTACK(buff_2); # 2. Buffer fertig
  1055.           O(token_buff_1) = NIL; # Buffer als entnommen markieren
  1056.         }}
  1057.         else
  1058.         # Buffer sind gerade entnommen und müssen neu alloziert werden:
  1059.         { pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String mit Fill-Pointer=0
  1060.           pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String mit Fill-Pointer=0
  1061.         }
  1062.     }
  1063.  
  1064. # UP: Liest ein Extended Token.
  1065. # read_token(&stream);
  1066. # > stream: Stream
  1067. # < stream: Stream
  1068. # < O(token_buff_1): gelesene Characters
  1069. # < O(token_buff_2): ihre Attributcodes
  1070. # < token_escape_flag: Escape-Zeichen-Flag
  1071. # kann GC auslösen
  1072.   local void read_token (object* stream_);
  1073.  
  1074. # UP: Liest ein Extended Token, erstes Zeichen bereits gelesen.
  1075. # read_token_1(&stream,ch,scode);
  1076. # > stream: Stream
  1077. # > ch, scode: erstes Zeichen und sein Syntaxcode
  1078. # < stream: Stream
  1079. # < O(token_buff_1): gelesene Characters
  1080. # < O(token_buff_2): ihre Attributcodes
  1081. # < token_escape_flag: Escape-Zeichen-Flag
  1082. # kann GC auslösen
  1083.   local void read_token_1 (object* stream_, object ch, uintWL scode);
  1084.  
  1085.   local void read_token(stream_)
  1086.     var reg3 object* stream_;
  1087.     { # erstes Zeichen lesen:
  1088.       var reg4 object ch;
  1089.       var reg5 uintWL scode;
  1090.       read_char_syntax(ch = ,scode = ,stream_);
  1091.       # Token aufbauen:
  1092.       read_token_1(stream_,ch,scode);
  1093.     }
  1094.  
  1095.   local void read_token_1(stream_,ch,scode)
  1096.     var reg5 object* stream_;
  1097.     var reg4 object ch;
  1098.     var reg3 uintWL scode;
  1099.     { # leere Token-Buffer holen, auf den STACK:
  1100.       get_buffers(); # (brauche ch nicht zu retten)
  1101.       # Bis zum Ende von read_token_1 liegen die beiden Buffer im Stack.
  1102.       # (So kann read_char rekursiv read aufrufen...)
  1103.       # Danach (während test_potential_number_syntax, test_number_syntax,
  1104.       # test_dots, read_internal bis zum Ende von read_internal) liegen
  1105.       # die Buffer in O(token_buff_1) und O(token_buff_2). Nach dem Ende von
  1106.       # read_internal ist ihr Inhalt wertlos, und sie können für weitere
  1107.       # read-Operationen benutzt werden.
  1108.      {var reg8 boolean multiple_escape_flag = FALSE;
  1109.       var reg9 boolean escape_flag = FALSE;
  1110.       # Funktion zur Case-Umwandlung besorgen:
  1111.       var reg7 case_converter* case_convert;
  1112.       {var reg1 object readtable;
  1113.        get_readtable(readtable = );
  1114.        switch ((uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case))
  1115.          { case case_upcase:   case_convert = &up_case; break;
  1116.            case case_downcase: case_convert = &down_case; break;
  1117.            case case_preserve: case_convert = &preserve_case; break;
  1118.            default: NOTREACHED
  1119.       }  }
  1120.       goto char_read;
  1121.       loop
  1122.         { # Hier wird das Token in STACK_1 (Semi-Simple-String für Characters)
  1123.           # und STACK_0 (Semi-Simple-String für Attributcodes) aufgebaut.
  1124.           # Multiple-Escape-Flag zeigt an, ob man sich zwischen |...| befindet.
  1125.           # Escape-Flag zeigt an, ob ein Escape-Character vorgekommen ist.
  1126.           read_char_syntax(ch = ,scode = ,stream_); # nächstes Zeichen lesen
  1127.           char_read:
  1128.           switch(scode)
  1129.             { case syntax_illegal:
  1130.                 # illegal -> Error melden:
  1131.                 pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1132.                 pushSTACK(ch); # Zeichen
  1133.                 pushSTACK(*stream_); # Stream
  1134.                 pushSTACK(S(read));
  1135.                 //: DEUTSCH "~ von ~: Zeichen ~ ist nicht erlaubt."
  1136.                 //: ENGLISH "~ from ~: illegal character ~"
  1137.                 //: FRANCAIS "~ de ~ : Le caractère ~ n'est pas permis ici."
  1138.                 fehler(stream_error, GETTEXT("~ from ~: illegal character ~"));
  1139.                 break;
  1140.               case syntax_single_esc:
  1141.                 # Single-Escape-Zeichen ->
  1142.                 # nächstes Zeichen lesen und unverändert übernehmen
  1143.                 escape_flag = TRUE;
  1144.                 read_char_syntax(ch = ,scode = ,stream_); # nächstes Zeichen lesen
  1145.                 if (scode==syntax_eof) # EOF erreicht?
  1146.                   { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1147.                     pushSTACK(*stream_);
  1148.                     pushSTACK(S(read));
  1149.                     //: DEUTSCH "~: Eingabestream ~ endet mitten im Token nach Single-Escape-Zeichen."
  1150.                     //: ENGLISH "~: input stream ~ ends within a token after single escape character"
  1151.                     //: FRANCAIS "~ : Le «stream» d'entrée ~ se termine à l'intérieur d'un lexème, suivant un caractère de simple échappement."
  1152.                     fehler(end_of_file, GETTEXT("~: input stream ~ ends within a token after single escape character"));
  1153.                   }
  1154.               escape:
  1155.                 # nach Escape-Zeichen:
  1156.                 # Zeichen unverändert ins Token übernehmen
  1157.                 ssstring_push_extend(STACK_1,char_code(ch));
  1158.                 ssstring_push_extend(STACK_0,a_alpha);
  1159.                 break;
  1160.               case syntax_multi_esc:
  1161.                 # Multiple-Escape-Zeichen
  1162.                 multiple_escape_flag = !multiple_escape_flag;
  1163.                 escape_flag = TRUE;
  1164.                 break;
  1165.               case syntax_constituent:
  1166.               case syntax_nt_macro:
  1167.                 # normales Constituent
  1168.                 if (multiple_escape_flag) # Zwischen Multiple-Escape-Zeichen?
  1169.                   goto escape; # ja -> Zeichen unverändert übernehmen
  1170.                 # als Groß-/Klein-Buchstabe ins Token übernehmen:
  1171.                 {var reg1 uintB c = (*case_convert)(char_code(ch));
  1172.                  ssstring_push_extend(STACK_1,c);
  1173.                  ssstring_push_extend(STACK_0,attribute_table[c]);
  1174.                 }
  1175.                 break;
  1176.               case syntax_whitespace:
  1177.               case syntax_t_macro:
  1178.                 # whitespace oder terminating macro ->
  1179.                 # Token endet wohl vor diesem Character.
  1180.                 if (multiple_escape_flag) # Zwischen Multiple-Escape-Zeichen?
  1181.                   goto escape; # ja -> Zeichen unverändert übernehmen
  1182.                 # Token ist zu Ende.
  1183.                 # Schiebe das Character auf den Stream zurück,
  1184.                 # falls es kein Whitespace ist oder
  1185.                 # es ein Whitespace ist und *READ-PRESERVE-WHITESPACE* /= NIL.
  1186.                 if ((!(scode == syntax_whitespace))
  1187.                     || test_value(S(read_preserve_whitespace))
  1188.                    )
  1189.                   { unread_char(stream_,ch); }
  1190.                 goto ende;
  1191.               case syntax_eof:
  1192.                 # EOF erreicht.
  1193.                 if (multiple_escape_flag) # zwischen Multiple-Escape-Zeichen?
  1194.                   { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1195.                     pushSTACK(*stream_);
  1196.                     pushSTACK(S(read));
  1197.                     //: DEUTSCH "~: Eingabestream ~ endet mitten im Token nach Multiple-Escape-Zeichen."
  1198.                     //: ENGLISH "~: input stream ~ ends within a token after multiple escape character"
  1199.                     //: FRANCAIS "~ : Le «stream» d'entrée se termine au milieu d'un lexème, suivant un caractère de multi-échappement."
  1200.                     fehler(end_of_file, GETTEXT("~: input stream ~ ends within a token after multiple escape character"));
  1201.                   }
  1202.                 # nein -> Token normal zu Ende
  1203.                 goto ende;
  1204.               default: NOTREACHED
  1205.         }   }
  1206.       ende:
  1207.       # Nun ist Token zu Ende, multiple_escape_flag = FALSE.
  1208.       token_escape_flag = escape_flag; # Escape-Flag abspeichern
  1209.       O(token_buff_2) = popSTACK(); # Attributcode-Buffer
  1210.       O(token_buff_1) = popSTACK(); # Character-Buffer
  1211.     }}
  1212.  
  1213. # --------------- READ zwischen Token-Ebene und Objekt-Ebene ------------------
  1214.  
  1215. # UP: Überprüft, ob der Token-Buffer eine potential-number enthält, und
  1216. # wandelt, als Vorbereitung auf Zahl-Lese-Routinen, Attributcodes um.
  1217. # test_potential_number_syntax(&base,&token_info);
  1218. # > O(token_buff_1): gelesene Characters
  1219. # > O(token_buff_2): ihre Attributcodes
  1220. # > base: Ziffernsystembasis (Wert von *READ-BASE* oder *PRINT-BASE*)
  1221. # < base: Ziffernsystembasis (= 10 oder altes base)
  1222. # Innerhalb von O(token_buff_2) wird umgewandelt:
  1223. #   Falls potential number:
  1224. #     >=a_letter oberhalb der Ziffernsystembasis -> a_alpha
  1225. #   Falls nicht potential number:
  1226. #     Unterscheidung zwischen [a_pack_m | a_dot | sonstiges] bleibt erhalten.
  1227. # < ergebnis: TRUE, falls potential number vorliegt
  1228. #             (und dann ist token_info mit {charptr, attrptr, len} gefüllt)
  1229.   typedef struct { uintB* charptr; uintB* attrptr; uintL len; } token_info;
  1230.   local boolean test_potential_number_syntax (uintWL* base_, token_info* info);
  1231.   local boolean test_potential_number_syntax(base_,info)
  1232.     var reg8 uintWL* base_;
  1233.     var reg9 token_info* info;
  1234.     # Ein Token ist potential number, wenn (CLTL, S. 341)
  1235.     # - es ausschließlich aus Ziffern, '+','-','/','^','_','.' und
  1236.     #   Number-Markern besteht. Die Basis für die Ziffern ist dabei vom
  1237.     #   Kontext abhängig, jedoch immer 10, wenn ein Punkt '.' vorkommt.
  1238.     #   Ein Number-Marker ist ein Buchstabe, der keine Ziffer ist und
  1239.     #   nicht neben einem anderen solchen steht.
  1240.     # - es mindestens eine Ziffer enthält,
  1241.     # - es mit einer Ziffer, '+','-','.','^' oder '_' beginnt,
  1242.     # - es nicht mit '+' oder '-' endet.
  1243.     # Überprüfung:
  1244.     # 1. Suche, ob ein Punkt vorkommt. Falls ja, Basis:=10.
  1245.     # 2. Alles >=a_letter (also 'A'-'Z','a'-'z'), was einen Wert <Basis hat,
  1246.     #    wird in a_digit umgewandelt.
  1247.     # (Jetzt wird a_digit als "digit" und >=a_letter als "letter" interpretiert.)
  1248.     # 3. Test, ob nur >=a_ratio vorkommen. Nein -> kein potential number.
  1249.     # 4. Test, ob ein a_digit vorkommt. Nein -> kein potential number.
  1250.     # (Jetzt ist die Länge >0.)
  1251.     # 5. Test, ob nebeneinanderliegende >=a_letter vorkommen.
  1252.     #    Ja -> kein potential number.
  1253.     # 6. Test, ob erstes Zeichenattribut >=a_dot,<=a_digit.
  1254.     #    Nein -> kein potential number.
  1255.     # 7. Test, ob letztes Zeichenattribut =a_plus oder =a_minus.
  1256.     #    Ja -> kein potential number.
  1257.     # 8. Potential number liegt vor.
  1258.     { var reg7 uintB* charptr0; # Pointer auf die Characters
  1259.       var reg5 uintB* attrptr0; # Pointer auf die Attribute
  1260.       var reg6 uintL len; # Länge des Token
  1261.       # initialisieren:
  1262.       { var reg1 object buff = O(token_buff_1); # erster Semi-Simple String
  1263.         len = TheArray(buff)->dims[1]; # Länge = Fill-Pointer
  1264.         buff = TheArray(buff)->data; # Simple-String
  1265.         charptr0 = &TheSstring(buff)->data[0]; # ab hier kommen die Characters
  1266.         buff = O(token_buff_2); # zweiter Semi-Simple String
  1267.         buff = TheArray(buff)->data; # Simple-String
  1268.         attrptr0 = &TheSstring(buff)->data[0]; # ab hier kommen die Attributcodes
  1269.       }
  1270.       # 1. Suche, ob ein Punkt vorkommt:
  1271.       { var reg1 uintB* attrptr = attrptr0;
  1272.         var reg2 uintL count;
  1273.         dotimesL(count,len, { if (*attrptr++ == a_dot) goto dot; } );
  1274.         # kein Punkt -> base unverändert lassen
  1275.         goto no_dot;
  1276.         # Punkt -> base := 10
  1277.         dot: *base_ = 10;
  1278.         no_dot: ;
  1279.       }
  1280.       # 2. Alles >=a_letter mit Wert <Basis in a_digit umwandeln:
  1281.       { var reg2 uintB* attrptr = attrptr0;
  1282.         var reg3 uintB* charptr = charptr0;
  1283.         var reg4 uintL count;
  1284.         dotimesL(count,len,
  1285.           { if (*attrptr >= a_letter)
  1286.               # Attributcode >= a_letter
  1287.               { var reg1 uintB c = *charptr; # Zeichen, muß 'A'-'Z','a'-'Z' sein
  1288.                 if (c >= 'a') { c -= 'a'-'A'; }
  1289.                 if ((c - 'A') + 10 < *base_) # Wert < Basis ?
  1290.                   { *attrptr = a_digit; } # in a_digit umwandeln
  1291.               }
  1292.             attrptr++; charptr++;
  1293.           });
  1294.       }
  1295.       # 3. Teste, ob nur Attributcodes >=a_ratio vorkommen:
  1296.       { var reg1 uintB* attrptr = attrptr0;
  1297.         var reg2 uintL count;
  1298.         dotimesL(count,len,
  1299.           { if (!(*attrptr++ >= a_ratio))
  1300.               { return FALSE; } # nein -> kein potential number
  1301.           });
  1302.       }
  1303.       # 4. Teste, ob ein a_digit vorkommt:
  1304.       { var reg1 uintB* attrptr = attrptr0;
  1305.         var reg2 uintL count;
  1306.         dotimesL(count,len, { if (*attrptr++ == a_digit) goto digit_ok; } );
  1307.         return FALSE; # kein potential number
  1308.         digit_ok: ;
  1309.       }
  1310.       # Länge len>0.
  1311.       # 5. Teste, ob hintereinander zwei Attributcodes >= a_letter kommen:
  1312.       { var reg1 uintB* attrptr = attrptr0;
  1313.         var reg2 uintL count;
  1314.         dotimesL(count,len-1,
  1315.           { if (*attrptr++ >= a_letter)
  1316.               { if (*attrptr >= a_letter)
  1317.                   { return FALSE; }
  1318.               }
  1319.           });
  1320.       }
  1321.       # 6. Teste, ob erster Attributcode >=a_dot, <=a_digit ist:
  1322.       { var reg1 uintB attr = attrptr0[0];
  1323.         if (!((attr >= a_dot) && (attr <= a_digit)))
  1324.           { return FALSE; }
  1325.       }
  1326.       # 7. Teste, ob letzter Attributcode = a_plus oder a_minus ist:
  1327.       { var reg1 uintB attr = attrptr0[len-1];
  1328.         if ((attr == a_plus) || (attr == a_minus))
  1329.           { return FALSE; }
  1330.       }
  1331.       # 8. Potential number liegt vor.
  1332.       info->charptr = charptr0; info->attrptr = attrptr0; info->len = len;
  1333.       return TRUE;
  1334.     }
  1335.  
  1336. # UP: Überprüft, ob der Token-Buffer eine Zahl enthält (Syntax gemäß CLTL
  1337. # Table 22-2), und stellt gegebenenfalls die für die Umwandlung in eine Zahl
  1338. # nötigen Parameter zur Verfügung.
  1339. # test_number_syntax(&base,&string,&info)
  1340. # > O(token_buff_1): gelesene Characters
  1341. # > O(token_buff_2): ihre Attributcodes
  1342. # > token_escape_flag: Escape-Zeichen-Flag
  1343. # > base: Ziffernsystembasis (Wert von *READ-BASE* oder *PRINT-BASE*)
  1344. # < base: Ziffernsystembasis
  1345. # < string: Simple-String mit den Characters
  1346. # < info.sign: Vorzeichen (/=0 falls negativ)
  1347. # < ergebnis: Zahl-Typ
  1348. #     0 : keine Zahl (dann sind auch base,string,info bedeutungslos)
  1349. #     1 : Integer
  1350. #         < index1: Index der ersten Ziffer
  1351. #         < index2: Index nach der letzten Ziffer
  1352. #         (also index2-index1 Ziffern, incl. evtl. Dezimalpunkt am Schluß)
  1353. #     2 : Rational
  1354. #         < index1: Index der ersten Ziffer
  1355. #         < index3: Index von '/'
  1356. #         < index2: Index nach der letzten Ziffer
  1357. #         (also index3-index1 Zähler-Ziffern, index2-index3-1 Nenner-Ziffern)
  1358. #     3 : Float
  1359. #         < index1: Index vom Mantissenanfang (excl. Vorzeichen)
  1360. #         < index4: Index nach dem Mantissenende
  1361. #         < index2: Index beim Ende der Characters
  1362. #         < index3: Index nach dem Dezimalpunkt (=index4 falls keiner da)
  1363. #         (also Mantisse mit index4-index1 Characters: Ziffern und max. 1 '.')
  1364. #         (also index4-index3 Nachkommaziffern)
  1365. #         (also bei index4<index2: index4 = Index des Exponent-Markers,
  1366. #               index4+1 = Index des Exponenten-Vorzeichens oder der ersten
  1367. #               Exponenten-Ziffer)
  1368.   typedef struct { signean sign;
  1369.                    uintL index1;
  1370.                    uintL index2;
  1371.                    uintL index3;
  1372.                    uintL index4;
  1373.                  }
  1374.           zahl_info;
  1375.   local uintWL test_number_syntax (uintWL* base_, object* string_, zahl_info* info);
  1376.   local uintWL test_number_syntax(base_,string_,info)
  1377.     var reg8 uintWL* base_;
  1378.     var reg9 object* string_;
  1379.     var reg8 zahl_info* info;
  1380.     # Methode:
  1381.     # 1. Auf potential number testen.
  1382.     #    Dann kommen nur Attributcodes >= a_ratio vor,
  1383.     #    und bei a_dot ist base=10.
  1384.     # 2. Vorzeichen { a_plus | a_minus | } lesen, merken.
  1385.     # 3. versuchen, das Token als rationale Zahl zu interpretieren:
  1386.     #    Teste, ob die Syntax
  1387.     #    { a_plus | a_minus | }                               # schon gelesen
  1388.     #    { a_digit < base }+ { a_ratio { a_digit < base }+ | }
  1389.     #    vorliegt.
  1390.     # 4. base:=10 setzen, und falls base vorher >10 war, den Characters
  1391.     #    'A'-'Z','a'-'z' (waren früher a_letter oder a_expo_m, sind aber evtl.
  1392.     #    durch test_potential_number_syntax in a_digit umgewandelt worden)
  1393.     #    wieder ihren Attributcode gemäß Tabelle zuordnen (a_letter -> keine
  1394.     #    Zahl oder a_expo_m).
  1395.     # 5. versuchen, das Token als Floating-Point-Zahl oder Dezimal-Integer
  1396.     #    zu interpretieren:
  1397.     #    Teste, ob die Syntax
  1398.     #    { a_plus | a_minus | }                               # schon gelesen
  1399.     #    { a_digit }* { a_dot { a_digit }* | }
  1400.     #    { a_expo_m { a_plus | a_minus | } { a_digit }+ | }
  1401.     #    vorliegt.
  1402.     #    Falls Exponent vorliegt, müssen Vor- oder Nachkommastellen kommen;
  1403.     #      es ist ein Float, Typ wird vom Exponent-Marker (e,E liefern den
  1404.     #      Wert der Variablen *read-default-float-format* als Typ).
  1405.     #    Falls kein Exponent:
  1406.     #      Falls kein Dezimalpunkt da, ist es keine Zahl (hätte schon bei
  1407.     #        Schritt 3 geliefert werden müssen, aber base hatte offenbar
  1408.     #        nicht gepaßt).
  1409.     #      Falls Dezimalpunkt vorhanden:
  1410.     #        Falls Nachkommastellen vorliegen, ist es ein Float (Typ wird
  1411.     #          von der Variablen *read-default-float-format* angegeben).
  1412.     #        Falls keine Nachkommastellen kommen:
  1413.     #          Falls Vorkommastellen da waren, Dezimal-Integer.
  1414.     #          Sonst keine Zahl.
  1415.     {  var reg9 uintB* charptr0; # Pointer auf die Characters
  1416.        var reg9 uintB* attrptr0; # Pointer auf die Attribute
  1417.        var reg6 uintL len; # Länge des Token
  1418.        # 1. Auf potential number testen:
  1419.        { if (token_escape_flag) # Token mit Escape-Zeichen ->
  1420.            { return 0; } # keine potential number -> keine Zahl
  1421.          # Escape-Flag gelöscht.
  1422.         {var token_info info;
  1423.          if (!test_potential_number_syntax(base_,&info)) # potential number ?
  1424.            { return 0; } # nein -> keine Zahl
  1425.          # ja -> Ausgabeparameter von test_potential_number_syntax lesen:
  1426.          charptr0 = info.charptr;
  1427.          attrptr0 = info.attrptr;
  1428.          len = info.len;
  1429.        }}
  1430.        *string_ = TheArray(O(token_buff_1))->data; # Simple-String
  1431.      { var reg9 uintL index0 = 0;
  1432.        # 2. Vorzeichen lesen und merken:
  1433.        { info->sign = 0; # Vorzeichen:=positiv
  1434.          switch (*attrptr0)
  1435.            { case a_minus: info->sign = -1; # Vorzeichen:=negativ
  1436.              case a_plus:
  1437.                # Vorzeichen überlesen:
  1438.                charptr0++; attrptr0++; index0++;
  1439.              default: break;
  1440.            }
  1441.        }
  1442.        info->index1 = index0; # Startindex
  1443.        info->index2 = len; # Endindex
  1444.        # info->sign und info->index1 und info->index2 fertig.
  1445.        # charptr0 und attrptr0 und index0 ab jetzt unverändert.
  1446.       {var reg7 uintB flags = 0; # alle Flags löschen
  1447.        # 3. Rationale Zahl
  1448.        { var reg4 uintB* charptr = charptr0;
  1449.          var reg3 uintB* attrptr = attrptr0;
  1450.          var reg5 uintL index = index0;
  1451.          # flags & bit(0)  zeigt an, ob bereits ein a_digit < base
  1452.          #                 angetroffen ist.
  1453.          # flags & bit(1)  zeigt an, ob bereits ein a_ratio angetroffen ist
  1454.          #                 (und dann ist info->index3 dessen Position)
  1455.          loop
  1456.            { # nächstes Zeichen
  1457.              if (index>=len) break;
  1458.             {var reg2 uintB attr = *attrptr++; # dessen Attributcode
  1459.              if (attr==a_digit)
  1460.                { var reg1 uintB c = *charptr++; # Character (Digit, also '0'-'9','A'-'Z','a'-'z')
  1461.                  # Wert bestimmen:
  1462.                  var reg1 uintB wert = (c<'A' ? c-'0' : c<'a' ? c-'A'+10 : c-'a'+10);
  1463.                  if (wert >= *base_) # Digit mit Wert >=base ?
  1464.                    goto schritt4; # ja -> keine rationale Zahl
  1465.                  # Digit mit Wert <base
  1466.                  flags |= bit(0); # Bit 0 setzen
  1467.                  index++;
  1468.                }
  1469.              elif (attr==a_ratio)
  1470.                { if (flags & bit(1)) # nicht der einzige '/' ?
  1471.                    goto schritt4; # ja -> keine rationale Zahl
  1472.                  flags |= bit(1); # erster '/'
  1473.                  if (!(flags & bit(0))) # keine Ziffern vor dem Bruchstrich?
  1474.                    goto schritt4; # ja -> keine rationale Zahl
  1475.                  flags &= ~bit(0); # Bit 0 löschen, neuer Block fängt an
  1476.                  info->index3 = index; # Index des '/' merken
  1477.                  charptr++; index++;
  1478.                }
  1479.              else
  1480.                # Attributcode /= a_digit, a_ratio -> keine rationale Zahl
  1481.                goto schritt4;
  1482.            }}
  1483.          # Token zu Ende
  1484.          if (!(flags & bit(0))) # keine Ziffern im letzten Block ?
  1485.            goto schritt4; # ja -> keine rationale Zahl
  1486.          # rationale Zahl
  1487.          if (!(flags & bit(1))) # a_ratio aufgetreten?
  1488.            # nein -> Integer liegt vor, info ist fertig.
  1489.            { return 1; }
  1490.            else
  1491.            # ja -> Bruch liegt vor, info ist fertig.
  1492.            { return 2; }
  1493.        }
  1494.        schritt4:
  1495.        # 4. base:=10, mit Eliminierung von 'A'-'Z','a'-'z'
  1496.        if (*base_ > 10)
  1497.          { var reg3 uintB* charptr = charptr0;
  1498.            var reg4 uintB* attrptr = attrptr0;
  1499.            var reg5 uintL count;
  1500.            dotimesL(count,len-index0,
  1501.              { var reg1 uintB c = *charptr++; # nächstes Character
  1502.                if (((c>='A') && (c<='Z')) || ((c>='a') && (c<='z')))
  1503.                  { var reg2 uintB attr = attribute_table[c]; # dessen wahrer Attributcode
  1504.                    if (attr == a_letter) # Ist er = a_letter ?
  1505.                      { return 0; } # ja -> keine Zahl
  1506.                    # sonst (muß a_expo_m sein) eintragen:
  1507.                    *attrptr = attr;
  1508.                  }
  1509.                attrptr++;
  1510.              });
  1511.          }
  1512.        *base_ = 10;
  1513.        # 5. Floating-Point-Zahl oder Dezimal-Integer
  1514.        { var reg2 uintB* attrptr = attrptr0;
  1515.          var reg3 uintL index = index0;
  1516.          # flags & bit(2)  zeigt an, ob bereits ein a_dot angetroffen ist
  1517.          #                 (und dann ist info->index3 die Position danach)
  1518.          # flags & bit(3)  zeigt an, ob im letzten Ziffernblock bereits ein
  1519.          #                 a_digit angetroffen wurde.
  1520.          # flags & bit(4)  zeigt an, ob a_dot vorkam und es Vorkommastellen
  1521.          #                 gab.
  1522.          loop
  1523.            { # nächstes Zeichen
  1524.              if (index>=len) break;
  1525.             {var reg1 uintB attr = *attrptr++; # dessen Attributcode
  1526.              if (attr==a_digit)
  1527.                # Digit ('0'-'9')
  1528.                { flags |= bit(3); index++; }
  1529.              elif (attr==a_dot)
  1530.                { if (flags & bit(2)) # nicht das einzige '.' ?
  1531.                    { return 0; } # ja -> keine Zahl
  1532.                  flags |= bit(2); # erster '.'
  1533.                  if (flags & bit(3)) { flags |= bit(4); } # evtl. mit Vorkommastellen
  1534.                  flags &= ~bit(3); # Flag zurücksetzen
  1535.                  index++;
  1536.                  info->index3 = index; # Index nach dem '.' merken
  1537.                }
  1538.              elif (attr==a_expo_m)
  1539.                { goto expo; } # Nun kommt der Exponent
  1540.              else
  1541.                { return 0; } # sonst kein Float, also keine Zahl
  1542.            }}
  1543.          # Token zu Ende, kein Exponent
  1544.          if (!(flags & bit(2))) # nur Dezimalziffern ohne '.' ?
  1545.            { return 0; } # ja -> keine Zahl
  1546.          info->index4 = index;
  1547.          if (flags & bit(3)) # mit Nachkommastellen?
  1548.            { return 3; } # ja -> Float, info fertig.
  1549.          # nein.
  1550.          if (!(flags & bit(4))) # auch ohne Vorkommastellen?
  1551.            { return 0; } # ja -> nur '.' -> keine Zahl
  1552.          # Nur Vorkomma-, keine Nachkommastellen -> Dezimal-Integer.
  1553.          # Brauche Dot ganz hinten nicht wegzuschneiden (wird überlesen).
  1554.          { return 1; }
  1555.          expo:
  1556.          # Exponent erreicht.
  1557.          info->index4 = index;
  1558.          index++; # Exponent-Marker mitzählen
  1559.          if (!(flags & bit(2))) { info->index3 = info->index4; } # Default für index3
  1560.          if (!(flags & (bit(3)|bit(4)))) # Kamen Vor- oder Nachkommastellen vor?
  1561.            { return 0; } # nein -> keine Zahl
  1562.          # Exponententeil weiter abarbeiten:
  1563.          # flags & bit(5)  zeigt an, ob bereits eine Exponenten-Ziffer da war.
  1564.          if (index>=len) { return 0; } # String zu Ende -> keine Zahl
  1565.          switch (*attrptr)
  1566.            { case a_plus:
  1567.              case a_minus:
  1568.                attrptr++; index++; # Exponenten-Vorzeichen übergehen
  1569.              default: break;
  1570.            }
  1571.          loop
  1572.            { # nächstes Zeichen im Exponenten:
  1573.              if (index>=len) break;
  1574.              # Es dürfen nur noch Digits kennen:
  1575.              if (!(*attrptr++ == a_digit)) { return 0; }
  1576.              flags |= bit(5);
  1577.              index++;
  1578.            }
  1579.          # Token nach Exponent zu Ende
  1580.          if (!(flags & bit(5))) # keine Ziffer im Exponenten?
  1581.            { return 0; } # ja -> keine Zahl
  1582.          return 3; # Float, info fertig.
  1583.        }
  1584.     }}}
  1585.  
  1586. # UP: Überprüft, ob ein Token nur aus Dots besteht.
  1587. # test_dots()
  1588. # > O(token_buff_1): gelesene Characters
  1589. # > O(token_buff_2): ihre Attributcodes
  1590. # < ergebnis: TRUE, falls Token leer ist oder nur aus Dots besteht
  1591.   local boolean test_dots (void);
  1592.   local boolean test_dots()
  1593.     { # Suche nach Attributcode /= a_dot:
  1594.       var reg3 object string = O(token_buff_2); # Semi-Simple-String
  1595.       var reg4 uintL len = TheArray(string)->dims[1]; # Fill-Pointer
  1596.       string = TheArray(string)->data; # Simple-String
  1597.      {var reg1 uintB* attrptr = &TheSstring(string)->data[0];
  1598.       var reg2 uintL count;
  1599.       dotimesL(count,len,
  1600.         { if (!(*attrptr++ == a_dot)) # Attributcode /= a_dot gefunden?
  1601.             { return FALSE; } # ja -> fertig, FALSE
  1602.         });
  1603.       # alles Dots.
  1604.       return TRUE;
  1605.     }}
  1606.  
  1607. # UP: Wandelt ein Zahl-Token in Großbuchstaben um.
  1608. # upcase_token();
  1609. # > O(token_buff_1): gelesene Characters
  1610. # > O(token_buff_2): ihre Attributcodes
  1611.   local void upcase_token (void);
  1612.   local void upcase_token()
  1613.     { var reg3 object string = O(token_buff_1); # Semi-Simple-String
  1614.       var reg2 uintL len = TheArray(string)->dims[1]; # Fill-Pointer
  1615.       string = TheArray(string)->data; # Simple-String
  1616.      {var reg1 uintB* charptr = &TheSstring(string)->data[0];
  1617.       dotimesL(len,len, { *charptr = up_case(*charptr); charptr++; } );
  1618.     }}
  1619.  
  1620. # UP: Behandelt ein Read-Macro-Character:
  1621. # Ruft die zugehörige Macro-Funktion auf, bei Dispatch-Characters erst noch
  1622. # Zahl-Argument und Subchar einlesen.
  1623. # read_macro(ch,&stream)
  1624. # > ch: Macro-Character, ein String-Char
  1625. # > stream: Stream
  1626. # < stream: Stream
  1627. # < mv_count/mv_space: max. 1 Wert
  1628. # kann GC auslösen
  1629.   local Values read_macro (object ch, object* stream_);
  1630.   local Values read_macro(ch,stream_)
  1631.     var reg9 object ch;
  1632.     var reg5 object* stream_;
  1633.     { var reg4 object readtable;
  1634.       get_readtable(readtable = ); # aktuelle Readtable (brauche ch nicht zu retten)
  1635.      {var reg3 object macrodef = # Macro-Definition aus Tabelle holen
  1636.         TheSvector(TheReadtable(readtable)->readtable_macro_table)->data[(uintP)char_code(ch)];
  1637.       if (nullp(macrodef)) # =NIL ?
  1638.         { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1639.           pushSTACK(ch);
  1640.           pushSTACK(*stream_);
  1641.           pushSTACK(S(read));
  1642.           //: DEUTSCH "~ von ~: ~ hat keine Macrozeichendefinition."
  1643.           //: ENGLISH "~ from ~: ~ has no macro character definition"
  1644.           //: FRANCAIS "~ de ~ : ~ n'a pas de définition de macro-caractère."
  1645.           fehler(stream_error, GETTEXT("~ from ~: ~ has no macro character definition"));
  1646.         }
  1647.       if (!simple_vector_p(macrodef)) # ein Simple-Vector?
  1648.         # ch normales Macro-Character, macrodef Funktion
  1649.         { pushSTACK(*stream_); # Stream als 1. Argument
  1650.           pushSTACK(ch); # Character als 2. Argument
  1651.           funcall(macrodef,2); # Funktion aufrufen
  1652.           if (mv_count > 1)
  1653.             { pushSTACK(fixnum(mv_count)); # Wertezahl als Fixnum
  1654.               pushSTACK(ch);
  1655.               pushSTACK(*stream_);
  1656.               pushSTACK(S(read));
  1657.               //: DEUTSCH "~ von ~: Macrozeichendefinition zu ~ darf keine ~ Werte liefern, sondern höchstens einen."
  1658.               //: ENGLISH "~ from ~: macro character definition for ~ may not return ~ values, only one value."
  1659.               //: FRANCAIS "~ de ~ : La définition du macro-caractère ~ ne doit pas retourner ~ valeurs mais au plus une."
  1660.               fehler(error, GETTEXT("~ from ~: macro character definition for ~ may not return ~ values, only one value."));
  1661.             }
  1662.           # höchstens 1 Wert.
  1663.           return; # mv_space/mv_count belassen
  1664.         }
  1665.         else
  1666.         # Dispatch-Macro-Zeichen.
  1667.         { pushSTACK(macrodef); # Vektor retten
  1668.          {var reg8 object arg; # Argument (Integer >=0 oder NIL)
  1669.           var reg7 object subch; # sub-char
  1670.           var reg6 uintB subc; # sub-char
  1671.           # Ziffern des Argumentes lesen:
  1672.           { var reg2 boolean flag = FALSE; # Flag, ob schon eine Ziffer kam
  1673.             pushSTACK(Fixnum_0); # bisheriger Integer := 0
  1674.             loop
  1675.               { var reg1 object nextch = read_char(stream_); # Character lesen
  1676.                 if (eq(nextch,eof_value))
  1677.                   { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1678.                     pushSTACK(ch); # main char
  1679.                     pushSTACK(*stream_); # Stream
  1680.                     pushSTACK(S(read));
  1681.                     //: DEUTSCH "~: Eingabestream ~ endet innerhalb eines Read-Macro zu ~"
  1682.                     //: ENGLISH "~: input stream ~ ends within read macro beginning to ~"
  1683.                     //: FRANCAIS "~ : Le «stream» d'entrée se termine à l'intérieur d'un macro de lecture en ~"
  1684.                     fehler(end_of_file, GETTEXT("~: input stream ~ ends within read macro beginning to ~"));
  1685.                   }
  1686.                 # sonst Character. Auf String-Char überprüfen.
  1687.                 if (!string_char_p(nextch)) { fehler_charread(nextch,stream_); }
  1688.                {var reg1 uintB c = char_code(nextch);
  1689.                 if (!((c>='0') && (c<='9'))) # keine Ziffer -> Schleife fertig
  1690.                   { subc = c; break; }
  1691.                 # Integer mal 10 nehmen und Ziffer addieren:
  1692.                 STACK_0 = mal_10_plus_x(STACK_0,(c-'0'));
  1693.                 flag = TRUE;
  1694.               }}
  1695.             # Argument in STACK_0 fertig (nur falls flag=TRUE).
  1696.             arg = popSTACK();
  1697.             if (!flag) { arg = NIL; } # kam keine Ziffer -> Argument := NIL
  1698.           }
  1699.           # Weiter geht's mit Subchar (String-Char subc)
  1700.           subch = code_char(subc);
  1701.           subc = up_case(subc); # Subchar in Großbuchstaben umwandeln
  1702.           macrodef = popSTACK(); # Vektor zurück
  1703.           macrodef = TheSvector(macrodef)->data[subc]; # Subchar-Funktion oder NIL
  1704.           if (nullp(macrodef))
  1705.             # NIL -> undefiniert
  1706.             { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1707.               pushSTACK(subch); # Subchar
  1708.               pushSTACK(ch); # Mainchar
  1709.               pushSTACK(*stream_); # Stream
  1710.               pushSTACK(S(read));
  1711.               //: DEUTSCH "~ von ~: Nach ~ ist ~ als Dispatch-Macrozeichen undefiniert."
  1712.               //: ENGLISH "~ from ~: After ~ is ~ an undefined dispatch macro character"
  1713.               //: FRANCAIS "~ de ~ : Après ~ ~ n'est plus défini comme macro caractère de «dispatch»."
  1714.               fehler(stream_error, GETTEXT("~ from ~: After ~ is ~ an undefined dispatch macro character"));
  1715.             }
  1716.           pushSTACK(*stream_); # Stream als 1. Argument
  1717.           pushSTACK(subch); # Subchar als 2. Argument
  1718.           pushSTACK(arg); # Argument (NIL oder Integer>=0) als 3. Argument
  1719.           funcall(macrodef,3); # Funktion aufrufen
  1720.           if (mv_count > 1)
  1721.             { pushSTACK(fixnum(mv_count)); # Wertezahl als Fixnum
  1722.               pushSTACK(ch); # Mainchar
  1723.               pushSTACK(subch); # Subchar
  1724.               pushSTACK(*stream_); # Stream
  1725.               pushSTACK(S(read));
  1726.               { var const char *msg1,*msg2;
  1727.                 //: DEUTSCH "~ von ~: Dispatch-Macrozeichen-Definition zu ~ nach ~ darf keine ~ Werte liefern,"
  1728.                 //: ENGLISH "~ from ~: dispatch macro character definition for ~ after ~ may not return ~ values,"
  1729.                 //: FRANCAIS "~ de ~ : La définition de caractère macro de «dispatch» pour ~ après ~ ne doit pas retourner ~ valeurs."
  1730.                 msg1 = GETTEXT("~ from ~: dispatch macro character definition for ~ after ~ may not return ~ values,");
  1731.                 //: DEUTSCH " sondern höchstens einen."
  1732.                 //: ENGLISH " only one value."
  1733.                 //: FRANCAIS ""
  1734.                 msg2 = GETTEXT(" only one value.");
  1735.                fehler3(error,msg1,NLstring,msg2);
  1736.               }
  1737.             }
  1738.           # höchstens 1 Wert.
  1739.           return; # mv_space/mv_count belassen
  1740.         }}
  1741.     }}
  1742.  
  1743. # ------------------------ READ auf Objekt-Ebene ------------------------------
  1744.  
  1745. # UP: Liest ein Objekt ein.
  1746. # Überliest dabei führenden Whitespace und Kommentar.
  1747. # Maßgeblich sind die aktuellen Werte von SYS::*READ-PRESERVE-WHITESPACE*
  1748. # (fürs evtl. Überlesen des ersten Whitespace nach dem Objekt)
  1749. # und SYS::*READ-RECURSIVE-P* (für EOF-Behandlung).
  1750. # read_internal(&stream)
  1751. # > stream: Stream
  1752. # < stream: Stream
  1753. # < ergebnis: gelesenes Objekt (eof_value bei EOF, dot_value bei einzelnem Punkt)
  1754. # kann GC auslösen
  1755.   local object read_internal (object* stream_);
  1756.   local object read_internal(stream_)
  1757.     var reg6 object* stream_;
  1758.     { wloop: # Schleife zum Überlesen von führendem Whitespace/Kommentar:
  1759.        {var reg2 object ch;
  1760.         var reg1 uintWL scode;
  1761.         read_char_syntax(ch = ,scode = ,stream_); # Zeichen lesen
  1762.         switch(scode)
  1763.           { case syntax_whitespace:
  1764.               # Whitespace -> wegwerfen und weiterlesen
  1765.               goto wloop;
  1766.             case syntax_t_macro:
  1767.             case syntax_nt_macro:
  1768.               # Macro-Zeichen am Token-Anfang
  1769.               read_macro(ch,stream_); # Macro-Funktion ausführen
  1770.               if (mv_count==0)
  1771.                 # 0 Werte -> weiterlesen
  1772.                 { goto wloop; }
  1773.                 else
  1774.                 # 1 Wert -> als Ergebnis
  1775.                 { return value1; }
  1776.             case syntax_eof:
  1777.               # EOF am Token-Anfang
  1778.               if (test_value(S(read_recursive_p))) # *READ-RECURSIVE-P* /= NIL ?
  1779.                 # ja -> EOF innerhalb eines Objektes -> Fehler
  1780.                 { fehler_eof_innen(stream_); }
  1781.               # sonst eof_value als Wert:
  1782.               return eof_value;
  1783.             case syntax_illegal:
  1784.               # read_token_1 liefert Error
  1785.             case syntax_single_esc:
  1786.             case syntax_multi_esc:
  1787.             case syntax_constituent:
  1788.               # Token lesen: Mit dem Zeichen ch fängt ein Token an.
  1789.               read_token_1(stream_,ch,scode); # Token zu Ende lesen
  1790.               break;
  1791.             default: NOTREACHED
  1792.        }  }
  1793.       # Token gelesen
  1794.       if (test_value(S(read_suppress))) # *READ-SUPPRESS* /= NIL ?
  1795.         { return NIL; } # ja -> Token nicht interpretieren, NIL als Wert
  1796.       # Token muß interpretiert werden
  1797.       # Der Token liegt in O(token_buff_1), O(token_buff_2), token_escape_flag.
  1798.       if ((!token_escape_flag) && test_dots())
  1799.         # Token ist eine Folge von Dots, ohne Escape-Characters gelesen.
  1800.         # Länge ist damit automatisch >0.
  1801.         { var reg1 uintL len = TheArray(O(token_buff_1))->dims[1]; # Länge des Token
  1802.           if (len > 1)
  1803.             # Länge>1 -> Fehler
  1804.             { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1805.               pushSTACK(*stream_);
  1806.               pushSTACK(S(read));
  1807.               //: DEUTSCH "~ von ~: Ein nur aus Punkten bestehendes Token ist nicht einlesbar."
  1808.               //: ENGLISH "~ from ~: a token consisting only of dots cannot be meaningfully read in"
  1809.               //: FRANCAIS "~ de ~ : Un lexème ne comprenant que des points ne peut pas être lu."
  1810.               fehler(stream_error, GETTEXT("~ from ~: a token consisting only of dots cannot be meaningfully read in"));
  1811.             }
  1812.           # Länge=1 -> dot_value als Wert
  1813.           return dot_value;
  1814.         }
  1815.       # Token ist OK
  1816.       { var uintWL base = get_read_base(); # Wert von *READ-BASE*
  1817.         # Token als Zahl interpretierbar?
  1818.         var object string;
  1819.         var zahl_info info;
  1820.         var reg3 uintWL numtype = test_number_syntax(&base,&string,&info);
  1821.         if (!(numtype==0)) # Zahl?
  1822.           { upcase_token(); # in Großbuchstaben umwandeln
  1823.             switch (numtype)
  1824.               { case 1: # Integer
  1825.                   return read_integer(base,info.sign,string,info.index1,info.index2);
  1826.                 case 2: # Rational
  1827.                   return read_rational(base,info.sign,string,info.index1,info.index3,info.index2);
  1828.                 case 3: # Float
  1829.                   return read_float(base,info.sign,string,info.index1,info.index4,info.index2,info.index3);
  1830.                 default: NOTREACHED
  1831.           }   }
  1832.       }
  1833.       # Token nicht als Zahl interpretierbar.
  1834.       # Wir interpretieren das Token als Symbol (auch dann, wenn das Token
  1835.       # Potential-number-Syntax hat, also ein 'reserved token' (im Sinne
  1836.       # von CLTL S. 341 oben) ist).
  1837.       # Dazu erst einmal die Verteilung der Doppelpunkte (Characters mit
  1838.       # Attributcode a_pack_m) feststellen:
  1839.       # Suche von vorne den ersten Doppelpunkt. Fälle (CLTL S. 343-344):
  1840.       # 1. Kein Doppelpunkt -> aktuelle Package
  1841.       # 2. Ein oder zwei Doppelpunkte am Anfang -> Keyword
  1842.       # 3. Ein Doppelpunkt, nicht am Anfang -> externes Symbol
  1843.       # 4. Zwei Doppelpunkte, nicht am Anfang -> internes Symbol
  1844.       # In den letzten drei Fällen dürfen keine weiteren Doppelpunkte mehr
  1845.       # kommen.
  1846.       # (Daß bei 2. der Namensteil bzw. bei 3. und 4. der Packageteil und
  1847.       # der Namensteil nicht die Syntax einer Zahl haben, kann hier nicht
  1848.       # mehr überprüft werden, weil sich TOKEN_ESCAPE_FLAG auf das ganze
  1849.       # Token bezieht. Vergleiche |USER|:: und |USER|::|| )
  1850.       { var reg5 object buff_2 = O(token_buff_2); # Attributcode-Buffer
  1851.         var reg4 uintL len = TheArray(buff_2)->dims[1]; # Länge = Fill-Pointer
  1852.         var reg2 uintB* attrptr = &TheSstring(TheArray(buff_2)->data)->data[0];
  1853.         var reg3 uintL index = 0;
  1854.         # stets attrptr = &TheSstring(...)->data[index].
  1855.         # Token wird in Packagenamen und Namen zerhackt:
  1856.         var reg7 uintL pack_end_index;
  1857.         var reg8 uintL name_start_index;
  1858.         var reg9 boolean external_internal_flag = FALSE; # vorläufig external
  1859.         loop
  1860.           { if (index>=len) goto current; # kein Doppelpunkt gefunden -> current package
  1861.             if (*attrptr++ == a_pack_m) break;
  1862.             index++;
  1863.           }
  1864.         # erster Doppelpunkt bei Index index gefunden
  1865.         pack_end_index = index; # Packagename endet hier
  1866.         index++;
  1867.         name_start_index = index; # Symbolname fängt (vorläufig) hier an
  1868.         # Tokenende erreicht -> externes Symbol:
  1869.         if (index>=len) goto ex_in_ternal;
  1870.         # Kommt sofort danach ein weiterer Doppelpunkt?
  1871.         index++;
  1872.         if (*attrptr++ == a_pack_m)
  1873.           # zwei Doppelpunkte nebeneinander
  1874.           { name_start_index = index; # Symbolname fängt erst hier an
  1875.             external_internal_flag = TRUE; # internal
  1876.           }
  1877.           else
  1878.           # erster Doppelpunkt war isoliert
  1879.           {} # external
  1880.         # Es dürfen keine weiteren Doppelpunkte kommen:
  1881.         loop
  1882.           { if (index>=len) goto ex_in_ternal; # kein weiterer Doppelpunkt gefunden -> ok
  1883.             if (*attrptr++ == a_pack_m) break;
  1884.             index++;
  1885.           }
  1886.         { # Fehlermeldung
  1887.           pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  1888.           pushSTACK(copy_string(O(token_buff_1))); # Character-Buffer kopieren
  1889.           pushSTACK(*stream_); # Stream
  1890.           pushSTACK(S(read));
  1891.           //: DEUTSCH "~ von ~: Zuviele Doppelpunkte im Token ~"
  1892.           //: ENGLISH "~ from ~: too many colons in token ~"
  1893.           //: FRANCAIS "~ de ~ : Trop de deux-points dans le lexème ~"
  1894.           fehler(stream_error, GETTEXT("~ from ~: too many colons in token ~"));
  1895.         }
  1896.         # Symbol suchen bzw. erzeugen:
  1897.         current: # Symbol in der current package suchen.
  1898.         # Symbolname = O(token_buff_1) = (subseq O(token_buff_1) 0 len)
  1899.         # ist ein nicht-simpler String.
  1900.         { var object sym;
  1901.           # Symbol internieren (und dabei String kopieren, falls das Symbol
  1902.           # neu erzeugt werden muß):
  1903.           intern(O(token_buff_1),get_current_package(),&sym);
  1904.           return sym;
  1905.         }
  1906.         ex_in_ternal: # externes/internes Symbol bilden
  1907.         # Packagename = (subseq O(token_buff_1) 0 pack_end_index),
  1908.         # Symbolname = (subseq O(token_buff_1) name_start_index len).
  1909.         if (pack_end_index==0)
  1910.           # Doppelpunkt(e) am Anfang -> Keyword bilden:
  1911.           { # Symbolname = (subseq O(token_buff_1) name_start_index len).
  1912.             # Hilfs-String adjustieren:
  1913.             var reg1 object hstring = O(displaced_string);
  1914.             TheArray(hstring)->data = O(token_buff_1); # Datenvektor
  1915.             TheArray(hstring)->dims[0] = name_start_index; # Displaced-Offset
  1916.             TheArray(hstring)->totalsize =
  1917.               TheArray(hstring)->dims[1] = len - name_start_index; # Länge
  1918.             # Symbol in die Keyword-Package internieren (und dabei
  1919.             # String kopieren, falls das Symbol neu erzeugt werden muß):
  1920.             return intern_keyword(hstring);
  1921.           }
  1922.         { # Packagename = (subseq O(token_buff_1) 0 pack_end_index).
  1923.           # Hilfs-String adjustieren:
  1924.           var reg1 object hstring = O(displaced_string);
  1925.           TheArray(hstring)->data = O(token_buff_1); # Datenvektor
  1926.           TheArray(hstring)->dims[0] = 0; # Displaced-Offset
  1927.           TheArray(hstring)->totalsize =
  1928.             TheArray(hstring)->dims[1] = pack_end_index; # Länge
  1929.           # Package mit diesem Namen suchen:
  1930.          {var reg2 object pack = find_package(hstring);
  1931.           if (nullp(pack)) # Package nicht gefunden?
  1932.             { pushSTACK(copy_string(hstring)); # Displaced-String kopieren, Wert für Slot PACKAGE von PACKAGE-ERROR
  1933.               pushSTACK(STACK_0);
  1934.               pushSTACK(*stream_); # Stream
  1935.               pushSTACK(S(read));
  1936.               //: DEUTSCH "~ von ~: Eine Package mit dem Namen ~ gibt es nicht."
  1937.               //: ENGLISH "~ from ~: there is no package with name ~"
  1938.               //: FRANCAIS "~ de ~ : Il n'y a pas de paquetage de nom ~."
  1939.               fehler(package_error, GETTEXT("~ from ~: there is no package with name ~"));
  1940.             }
  1941.           # Hilfs-String adjustieren:
  1942.           TheArray(hstring)->dims[0] = name_start_index; # Displaced-Offset
  1943.           TheArray(hstring)->totalsize =
  1944.             TheArray(hstring)->dims[1] = len - name_start_index; # Länge
  1945.           if (external_internal_flag)
  1946.             # internal
  1947.             { # Symbol internieren (und dabei String kopieren,
  1948.               # falls das Symbol neu erzeugt werden muß):
  1949.               var object sym;
  1950.               intern(hstring,pack,&sym);
  1951.               return sym;
  1952.             }
  1953.             else
  1954.             # external
  1955.             { # externes Symbol mit diesem Printnamen suchen:
  1956.               var object sym;
  1957.               if (find_external_symbol(hstring,pack,&sym))
  1958.                 { return sym; } # sym gefunden
  1959.                 else
  1960.                 { pushSTACK(pack); # Wert für Slot PACKAGE von PACKAGE-ERROR
  1961.                   pushSTACK(copy_string(hstring)); # Displaced-String kopieren
  1962.                   pushSTACK(STACK_1); # pack
  1963.                   pushSTACK(*stream_); # Stream
  1964.                   pushSTACK(S(read));
  1965.                   //: DEUTSCH "~ von ~: In ~ gibt es kein externes Symbol mit Namen ~"
  1966.                   //: ENGLISH "~ from ~: ~ has no external symbol with name ~"
  1967.                   //: FRANCAIS "~ de ~ : ~ ne comprend pas de symbole externe de nom ~."
  1968.                   fehler(package_error, GETTEXT("~ from ~: ~ has no external symbol with name ~"));
  1969.             }   }
  1970.         }}
  1971.     } }
  1972.  
  1973. # UP: Liest ein Objekt ein, mit SYS::*READ-RECURSIVE-P* /= NIL
  1974. # (und SYS::*READ-PRESERVE-WHITESPACE* = NIL, vgl. CLTL S. 377 mitte).
  1975. # Meldet bei EOF einen Error.
  1976. # read_recursive(&stream)
  1977. # > stream: Stream
  1978. # < stream: Stream
  1979. # < ergebnis: gelesenes Objekt (dot_value bei einzelnem Punkt)
  1980. # kann GC auslösen
  1981.   local object read_recursive (object* stream_);
  1982.   local object read_recursive(stream_)
  1983.     var reg3 object* stream_;
  1984.     { check_SP(); check_STACK(); # Stacks auf Überlauf testen
  1985.       if (test_value(S(read_recursive_p)))
  1986.         # schon rekursiv
  1987.         { return read_internal(stream_); }
  1988.         else
  1989.         { # SYS::*READ-RECURSIVE-P* an T binden:
  1990.           dynamic_bind(S(read_recursive_p),T);
  1991.           # und SYS::*READ-PRESERVE-WHITESPACE* an NIL binden:
  1992.           dynamic_bind(S(read_preserve_whitespace),NIL);
  1993.           # und Objekt lesen:
  1994.          {var reg4 object ergebnis = read_internal(stream_);
  1995.           dynamic_unbind();
  1996.           dynamic_unbind();
  1997.           return ergebnis;
  1998.         }}
  1999.     }
  2000.  
  2001. # Fehlermeldung wegen unpassendem Dot
  2002. # fehler_dot(stream);
  2003. # > stream: Stream
  2004.   nonreturning_function(local, fehler_dot, (object stream));
  2005.   local void fehler_dot(stream)
  2006.     var reg1 object stream;
  2007.     { pushSTACK(stream); # Wert für Slot STREAM von STREAM-ERROR
  2008.       pushSTACK(stream); # Stream
  2009.       pushSTACK(S(read));
  2010.       //: DEUTSCH "~ von ~: Token \".\" an dieser Stelle nicht erlaubt."
  2011.       //: ENGLISH "~ from ~: token \".\" not allowed here"
  2012.       //: FRANCAIS "~ de ~ : Le lexème \".\" n'est pas permis ici."
  2013.       fehler(stream_error, GETTEXT("~ from ~: token \".\" not allowed here"));
  2014.     }
  2015.  
  2016. # UP: Liest ein Objekt ein, mit SYS::*READ-RECURSIVE-P* /= NIL
  2017. # (und SYS::*READ-PRESERVE-WHITESPACE* = NIL, vgl. CLTL S. 377 mitte).
  2018. # Meldet Error bei EOF oder Token ".".
  2019. # (Das entspricht dem Idiom (read stream t nil t).)
  2020. # read_recursive_no_dot(&stream)
  2021. # > stream: Stream
  2022. # < stream: Stream
  2023. # < ergebnis: gelesenes Objekt
  2024. # kann GC auslösen
  2025.   local object read_recursive_no_dot (object* stream_);
  2026.   local object read_recursive_no_dot(stream_)
  2027.     var reg2 object* stream_;
  2028.     { # READ rekursiv aufrufen:
  2029.       var reg1 object ergebnis = read_recursive(stream_);
  2030.       # und bei "." einen Error melden:
  2031.       if (eq(ergebnis,dot_value)) { fehler_dot(*stream_); }
  2032.       return ergebnis;
  2033.     }
  2034.  
  2035. # UP: Entflicht #n# - Referenzen zu #n= - Markierungen in einem Objekt.
  2036. # > Wert von SYS::*READ-REFERENCE-TABLE*:
  2037. #     Aliste von Paaren (Markierung . markiertes Objekt), wobei
  2038. #     jede Markierung ein Objekt  #<READ-LABEL n>  ist.
  2039. # > obj: Objekt
  2040. # < ergebnis: destruktiv modifiziertes Objekt ohne Referenzen
  2041.   local object make_references (object obj);
  2042.   local object make_references(obj)
  2043.     var reg3 object obj;
  2044.     { var reg2 object alist = Symbol_value(S(read_reference_table));
  2045.       # SYS::*READ-REFERENCE-TABLE* = NIL -> nichts zu tun:
  2046.       if (nullp(alist))
  2047.         { return obj; }
  2048.         else
  2049.         { # Überprüfen, ob SYS::*READ-REFERENCE-TABLE* eine Aliste ist:
  2050.          {var reg1 object alistr = alist; # Liste durchlaufen
  2051.           while (consp(alistr))
  2052.             { # jedes Listenelement muß ein Cons sein:
  2053.               if (!mconsp(Car(alistr))) goto fehler_badtable;
  2054.               alistr = Cdr(alistr);
  2055.             }
  2056.           if (!nullp(alistr))
  2057.             { fehler_badtable:
  2058.               pushSTACK(S(read_reference_table));
  2059.               pushSTACK(S(read));
  2060.               //: DEUTSCH "~: Der Wert von ~ wurde von außen verändert."
  2061.               //: ENGLISH "~: the value of ~ has been arbitrarily altered"
  2062.               //: FRANCAIS "~ : La valeur de ~ fut modifiée extérieurement."
  2063.               fehler(error, GETTEXT("~: the value of ~ has been arbitrarily altered"));
  2064.             }
  2065.          }# Aliste alist ist OK
  2066.           pushSTACK(obj);
  2067.           {var reg1 object bad_reference =
  2068.             subst_circ(&STACK_0,alist); # Referenzen durch Objekte substituieren
  2069.            if (!eq(bad_reference,nullobj))
  2070.              { pushSTACK(unbound); # "Wert" für Slot STREAM von STREAM-ERROR
  2071.                pushSTACK(Symbol_value(S(read_reference_table)));
  2072.                pushSTACK(S(read_reference_table));
  2073.                pushSTACK(obj);
  2074.                pushSTACK(bad_reference);
  2075.                pushSTACK(S(read));
  2076.                //: DEUTSCH "~: ~ aus ~ ist in ~ = ~ nicht aufgeführt."
  2077.                //: ENGLISH "~: no entry for ~ from ~ in ~ = ~"
  2078.                //: FRANCAIS "~ : ~ dans ~ n'est pas énoncé dans ~ = ~."
  2079.                fehler(stream_error, GETTEXT("~: no entry for ~ from ~ in ~ = ~"));
  2080.           }  }
  2081.           return popSTACK();
  2082.         }
  2083.     }
  2084.  
  2085. # UP: Liest ein Objekt ein, mit SYS::*READ-RECURSIVE-P* = NIL .
  2086. # (Top-Level-Aufruf des Readers)
  2087. # read_top(&stream,whitespace-p)
  2088. # > whitespace-p: gibt an, ob danach whitespace zu verbrauchen ist
  2089. # > stream: Stream
  2090. # < stream: Stream
  2091. # < ergebnis: gelesenes Objekt (eof_value bei EOF, dot_value bei einzelnem Punkt)
  2092. # kann GC auslösen
  2093.   local object read_top (object* stream_, object whitespace_p);
  2094.   local object read_top(stream_,whitespace_p)
  2095.     var reg3 object* stream_;
  2096.     var reg4 object whitespace_p;
  2097.     {
  2098.      #if STACKCHECKR
  2099.       var reg6 object* STACKbefore = STACK; # STACK aufheben für später
  2100.      #endif
  2101.       var reg7 object *whitespace_p_ptr;
  2102.       pushSTACK(whitespace_p); whitespace_p_ptr=&STACK_0;
  2103.       # SYS::*READ-RECURSIVE-P* an NIL binden:
  2104.       dynamic_bind(S(read_recursive_p),NIL);
  2105.       # und SYS::*READ-PRESERVE-WHITESPACE* an whitespace_p binden:
  2106.       dynamic_bind(S(read_preserve_whitespace),*whitespace_p_ptr);
  2107.       # SYS::*READ-REFERENCE-TABLE* an die leere Tabelle NIL binden:
  2108.       dynamic_bind(S(read_reference_table),NIL);
  2109.       # SYS::*BACKQUOTE-LEVEL* an NIL binden:
  2110.       dynamic_bind(S(backquote_level),NIL);
  2111.       # Objekt lesen:
  2112.      {var reg5 object obj = read_internal(stream_);
  2113.       # Verweise entflechten:
  2114.       obj = make_references(obj);
  2115.       dynamic_unbind();
  2116.       dynamic_unbind();
  2117.       dynamic_unbind();
  2118.       dynamic_unbind();
  2119.       skipSTACK(1);
  2120.      #if STACKCHECKR
  2121.       # Überprüfen, ob Stack aufgeräumt:
  2122.       if (!(STACK == STACKbefore))
  2123.         { abort(); } # wenn nicht, in den Debugger
  2124.      #endif
  2125.       return obj;
  2126.     }}
  2127.  
  2128. # UP: Liest ein Objekt ein.
  2129. # read(&stream,recursive-p,whitespace-p)
  2130. # > recursive-p: gibt an, ob rekursiver Aufruf von READ, mit Error bei EOF
  2131. # > whitespace-p: gibt an, ob danach whitespace zu verbrauchen ist
  2132. # > stream: Stream
  2133. # < stream: Stream
  2134. # < ergebnis: gelesenes Objekt (eof_value bei EOF, dot_value bei einzelnem Punkt)
  2135. # kann GC auslösen
  2136.   global object read (object* stream_, object recursive_p, object whitespace_p);
  2137.   global object read(stream_,recursive_p,whitespace_p)
  2138.     var reg1 object* stream_;
  2139.     var reg2 object recursive_p;
  2140.     var reg3 object whitespace_p;
  2141.     { if (nullp(recursive_p)) # recursive-p abfragen
  2142.         # nein -> Top-Level-Aufruf
  2143.         { return read_top(stream_,whitespace_p); }
  2144.         else
  2145.         # ja -> rekursiver Aufruf
  2146.         { return read_recursive(stream_); }
  2147.     }
  2148.  
  2149. # ----------------------------- READ-Macros -----------------------------------
  2150.  
  2151. # UP: Liest eine Liste ein.
  2152. # read_delimited_list(&stream,endch,ifdotted)
  2153. # > endch: erwartetes Endzeichen, ein String-Char
  2154. # > ifdotted: #DOT_VALUE falls Dotted List erlaubt, #EOF_VALUE sonst
  2155. # > stream: Stream
  2156. # < stream: Stream
  2157. # < ergebnis: gelesenes Objekt
  2158. # kann GC auslösen
  2159.   local object read_delimited_list (object* stream_, object endch, object ifdotted);
  2160. # Dito mit gesetztem SYS::*READ-RECURSIVE-P* :
  2161.   local object read_delimited_list_recursive (object* stream_, object endch, object ifdotted);
  2162. # Erst die allgemeine Funktion:
  2163.   #ifdef RISCOS_CCBUG
  2164.     #pragma -z0
  2165.   #endif
  2166.   local object read_delimited_list(stream_,endch,ifdotted)
  2167.     var reg1 object* stream_;
  2168.     var reg2 object endch;
  2169.     var reg3 object ifdotted;
  2170.     { var reg4 object ergebnis;
  2171.       var reg5 object *endch_ptr;
  2172.       var reg6 object *ifdotted_ptr;
  2173.       pushSTACK(endch); endch_ptr=&STACK_0;
  2174.       pushSTACK(ifdotted); ifdotted_ptr=&STACK_0;
  2175.       # SYS::*READ-LINE-NUMBER* an (SYS::LINE-NUMBER stream) binden
  2176.       # (für Fehlermeldung, damit man die Zeile der öffnenden Klammer erfährt):
  2177.       pushSTACK(*stream_); C_line_number();
  2178.       dynamic_bind(S(read_line_number),value1);
  2179.       # evtl. zuerst noch SYS::*READ-RECURSIVE-P* an T binden:
  2180.       if (test_value(S(read_recursive_p))) # schon rekursiv?
  2181.         { ergebnis = read_delimited_list_recursive(stream_,*endch_ptr,*ifdotted_ptr); }
  2182.         else
  2183.         # nein -> SYS::*READ-RECURSIVE-P* an T binden:
  2184.         { dynamic_bind(S(read_recursive_p),T);
  2185.           ergebnis = read_delimited_list_recursive(stream_,*endch_ptr,*ifdotted_ptr);
  2186.           dynamic_unbind();
  2187.         }
  2188.       dynamic_unbind();
  2189.       skipSTACK(2);
  2190.       return ergebnis;
  2191.     }
  2192.   #ifdef RISCOS_CCBUG
  2193.     #pragma -z1
  2194.   #endif
  2195. # Dann die speziellere Funktion:
  2196.   local object read_delimited_list_recursive(stream_,endch,ifdotted)
  2197.     var reg1 object* stream_;
  2198.     var reg4 object endch;
  2199.     var reg6 object ifdotted;
  2200.     { # Brauche endch und ifdotted nicht zu retten.
  2201.       { var reg5 object object1; # erstes Listenelement
  2202.         loop # Schleife, um erstes Listenelement zu lesen
  2203.           { # nächstes non-whitespace Character:
  2204.             var reg2 object ch;
  2205.             var reg3 uintWL scode;
  2206.             wpeek_char_syntax(ch = ,scode = ,stream_);
  2207.             if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2208.               # ja -> leere Liste als Ergebnis
  2209.               { read_char(stream_); # Endezeichen verbrauchen
  2210.                 return NIL;
  2211.               }
  2212.             if (scode < syntax_t_macro) # Macro-Character?
  2213.               # nein -> 1. Objekt lesen:
  2214.               { object1 = read_recursive_no_dot(stream_); break; }
  2215.               else
  2216.               # ja -> zugehöriges Zeichen lesen und Macro-Funktion ausführen:
  2217.               { ch = read_char(stream_);
  2218.                 read_macro(ch,stream_);
  2219.                 if (!(mv_count==0)) # Wert zurück?
  2220.                   { object1 = value1; break; } # ja -> als 1. Objekt nehmen
  2221.                   # nein -> überlesen
  2222.               }
  2223.           }
  2224.         # object1 ist das 1. Objekt
  2225.         pushSTACK(object1);
  2226.       }
  2227.       { var reg2 object new_cons = allocate_cons(); # Listenanfang basteln
  2228.         Car(new_cons) = popSTACK(); # new_cons = (cons object1 nil)
  2229.         #ifdef IMMUTABLE_CONS
  2230.         if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2231.           { pushSTACK(make_imm_cons(new_cons)); }
  2232.           else
  2233.         #endif
  2234.           { pushSTACK(new_cons); }
  2235.         pushSTACK(new_cons);
  2236.       }
  2237.       # Stackaufbau: Gesamtliste, (last Gesamtliste).
  2238.       loop # Schleife über weitere Listenelemente
  2239.         { var reg5 object object1; # weiteres Listenelement
  2240.           loop # Schleife, um weiteres Listenelement zu lesen
  2241.             { # nächstes non-whitespace Character:
  2242.               var reg2 object ch;
  2243.               var reg3 uintWL scode;
  2244.               wpeek_char_syntax(ch = ,scode = ,stream_);
  2245.               if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2246.                 # ja -> Liste beenden
  2247.                 { finish_list:
  2248.                   read_char(stream_); # Endezeichen verbrauchen
  2249.                   skipSTACK(1); return popSTACK(); # Gesamtliste als Ergebnis
  2250.                 }
  2251.               if (scode < syntax_t_macro) # Macro-Character?
  2252.                 # nein -> nächstes Objekt lesen:
  2253.                 { object1 = read_recursive(stream_);
  2254.                   if (eq(object1,dot_value)) goto dot;
  2255.                   break;
  2256.                 }
  2257.                 else
  2258.                 # ja -> zugehöriges Zeichen lesen und Macro-Funktion ausführen:
  2259.                 { ch = read_char(stream_);
  2260.                   read_macro(ch,stream_);
  2261.                   if (!(mv_count==0)) # Wert zurück?
  2262.                     { object1 = value1; break; } # ja -> als nächstes Objekt nehmen
  2263.                     # nein -> überlesen
  2264.                 }
  2265.             }
  2266.           # nächstes Objekt in die Liste einhängen:
  2267.           pushSTACK(object1);
  2268.          {var reg2 object new_cons = allocate_cons(); # nächstes Listen-Cons
  2269.           Car(new_cons) = popSTACK(); # (cons object1 nil)
  2270.           #ifdef IMMUTABLE_CONS
  2271.           if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2272.             Cdr(STACK_0) = make_imm_cons(new_cons);
  2273.             else
  2274.           #endif
  2275.             Cdr(STACK_0) = new_cons; # =: (cdr (last Gesamtliste))
  2276.           STACK_0 = new_cons;
  2277.         }}
  2278.       dot: # Dot gelesen
  2279.       if (!eq(ifdotted,dot_value)) # war keiner erlaubt?
  2280.         { fehler_dot(*stream_); }
  2281.       { var reg5 object object1; # letztes Listenelement
  2282.         loop # Schleife, um letztes Listenelement zu lesen
  2283.           { # nächstes non-whitespace Character:
  2284.             var reg2 object ch;
  2285.             var reg3 uintWL scode;
  2286.             wpeek_char_syntax(ch = ,scode = ,stream_);
  2287.             if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2288.               # ja -> Fehler
  2289.               { fehler_dot:
  2290.                 pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2291.                 pushSTACK(*stream_); # Stream
  2292.                 pushSTACK(S(read_delimited_list));
  2293.                 //: DEUTSCH "~ von ~: Kein korrekter Listenabschluß einer Dotted List."
  2294.                 //: ENGLISH "~ from ~: illegal end of dotted list"
  2295.                 //: FRANCAIS "~ de ~ : liste pointée ne se termine pas correctement."
  2296.                 fehler(stream_error, GETTEXT("~ from ~: illegal end of dotted list"));
  2297.               }
  2298.             if (scode < syntax_t_macro) # Macro-Character?
  2299.               # nein -> letztes Objekt lesen:
  2300.               { object1 = read_recursive_no_dot(stream_); break; }
  2301.               else
  2302.               # ja -> zugehöriges Zeichen lesen und Macro-Funktion ausführen:
  2303.               { ch = read_char(stream_);
  2304.                 read_macro(ch,stream_);
  2305.                 if (!(mv_count==0)) # Wert zurück?
  2306.                   { object1 = value1; break; } # ja -> als letztes Objekt nehmen
  2307.                   # nein -> überlesen
  2308.               }
  2309.           }
  2310.         # object1 ist das letzte Objekt
  2311.         # als (cdr (last Gesamtliste)) in die Liste einhängen:
  2312.         Cdr(STACK_0) = object1;
  2313.       }
  2314.       loop # Schleife, um Kommentar nach letztem Listenelement zu lesen
  2315.         { # nächstes non-whitespace Character:
  2316.           var reg2 object ch;
  2317.           var reg3 uintWL scode;
  2318.           wpeek_char_syntax(ch = ,scode = ,stream_);
  2319.           if (eq(ch,endch)) # Ist es das erwartete Endezeichen?
  2320.             { goto finish_list; } # ja -> Liste fertig
  2321.           if (scode < syntax_t_macro) # Macro-Character?
  2322.             # nein -> Dot kam zu früh, Fehler
  2323.             { goto fehler_dot; }
  2324.             else
  2325.             # ja -> zugehöriges Zeichen lesen und Macro-Funktion ausführen:
  2326.             { ch = read_char(stream_);
  2327.               read_macro(ch,stream_);
  2328.               if (!(mv_count==0)) # Wert zurück?
  2329.                 { goto fehler_dot; } # ja -> Dot kam zu früh, Fehler
  2330.                 # nein -> überlesen
  2331.             }
  2332.         }
  2333.     }
  2334.  
  2335. # Macro: Überprüft das Stream-Argument eines SUBRs.
  2336. # stream_ = test_stream_arg(stream);
  2337. # > stream: Stream-Argument im STACK
  2338. # > subr_self: Aufrufer (ein SUBR)
  2339. # < stream_: &stream
  2340.   #define test_stream_arg(stream)  \
  2341.     (!mstreamp(stream) ? (fehler_stream(stream), (object*)NULL) : &(stream))
  2342.  
  2343. # (set-macro-character #\(
  2344. #   #'(lambda (stream char)
  2345. #       (read-delimited-list #\) stream t :dot-allowed t)
  2346. # )   )
  2347. LISPFUNN(lpar_reader,2) # liest (
  2348.   { var reg1 object* stream_ = test_stream_arg(STACK_1);
  2349.     # Liste nach '(' bis ')' lesen, Dot erlaubt:
  2350.     value1 = read_delimited_list(stream_,code_char(')'),dot_value); mv_count=1;
  2351.     skipSTACK(2);
  2352.   }
  2353.  
  2354. # #| ( ( |#
  2355. # (set-macro-character #\)
  2356. #   #'(lambda (stream char)
  2357. #       (error "~ von ~: ~ am Anfang eines Objekts" 'read stream char)
  2358. # )   )
  2359. LISPFUNN(rpar_reader,2) # liest )
  2360.   { var reg1 object* stream_ = test_stream_arg(STACK_1);
  2361.     pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2362.     pushSTACK(STACK_(0+1)); # char
  2363.     pushSTACK(*stream_); # stream
  2364.     pushSTACK(S(read));
  2365.     //: DEUTSCH "~ von ~: ~ am Anfang eines Objekts"
  2366.     //: ENGLISH "~ from ~: an object cannot start with ~"
  2367.     //: FRANCAIS "~ de ~ : un object ne peut pas commencer par ~"
  2368.     fehler(stream_error, GETTEXT("~ from ~: an object cannot start with ~"));
  2369.   }
  2370.  
  2371. # (set-macro-character #\"
  2372. #   #'(lambda (stream char)
  2373. #       (let ((buffer (make-array 50 :element-type 'string-char
  2374. #                                    :adjustable t :fill-pointer 0
  2375. #            ))       )
  2376. #         (loop
  2377. #           (multiple-value-bind (ch sy) (read-char-syntax stream)
  2378. #             (cond ((eq sy 'eof-code)
  2379. #                    (error "~: Eingabestream ~ endet innerhalb eines Strings."
  2380. #                           'read stream
  2381. #                   ))
  2382. #                   ((eql ch char) (return (coerce buffer 'simple-string)))
  2383. #                   ((eq sy 'single-escape)
  2384. #                    (multiple-value-setq (ch sy) (read-char-syntax stream))
  2385. #                    (when (eq sy 'eof-code) (error ...))
  2386. #                    (vector-push-extend ch buffer)
  2387. #                   )
  2388. #                   (t (vector-push-extend ch buffer))
  2389. #         ) ) )
  2390. #         (if *read-suppress* nil (coerce buffer 'simple-string))
  2391. # )   ) )
  2392. LISPFUNN(string_reader,2) # liest "
  2393.   { var reg1 object* stream_ = test_stream_arg(STACK_1);
  2394.     # Stackaufbau: stream, char.
  2395.     if (test_value(S(read_suppress))) # *READ-SUPPRESS* /= NIL ?
  2396.       # ja -> String nur überlesen:
  2397.       { loop
  2398.           { # nächstes Zeichen lesen:
  2399.             var reg2 object ch;
  2400.             var reg3 uintWL scode;
  2401.             read_char_syntax(ch = ,scode = ,stream_);
  2402.             if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2403.             if (eq(ch,STACK_0)) break; # selbes Zeichen wie char -> fertig
  2404.             if (scode == syntax_single_esc) # Single-Escape-Character?
  2405.               # ja -> nochmal ein Zeichen lesen:
  2406.               { read_char_syntax(ch = ,scode = ,stream_);
  2407.                 if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2408.               }
  2409.           }
  2410.         value1 = NIL; # NIL als Wert
  2411.       }
  2412.       else
  2413.       # nein -> String wirklich lesen
  2414.       { get_buffers(); # zwei leere Buffer auf den Stack
  2415.         # Stackaufbau: stream, char, andererBuffer, Buffer.
  2416.         loop
  2417.           { # nächstes Zeichen lesen:
  2418.             var reg2 object ch;
  2419.             var reg3 uintWL scode;
  2420.             read_char_syntax(ch = ,scode = ,stream_);
  2421.             if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2422.             if (eq(ch,STACK_2)) break; # selbes Zeichen wie char -> fertig
  2423.             if (scode == syntax_single_esc) # Single-Escape-Character?
  2424.               # ja -> nochmal ein Zeichen lesen:
  2425.               { read_char_syntax(ch = ,scode = ,stream_);
  2426.                 if (scode == syntax_eof) goto fehler_eof; # EOF -> Fehler
  2427.               }
  2428.             # Zeichen ch in den Buffer schieben:
  2429.             ssstring_push_extend(STACK_0,char_code(ch));
  2430.           }
  2431.         # Buffer kopieren und dabei in Simple-String umwandeln:
  2432.         { var reg2 object string = copy_string(STACK_0);
  2433.           #ifdef IMMUTABLE_ARRAY
  2434.           if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2435.             { string = make_imm_array(string); }
  2436.           #endif
  2437.           value1 = string;
  2438.         }
  2439.         # Buffer zur Wiederverwendung freigeben:
  2440.         O(token_buff_2) = popSTACK(); O(token_buff_1) = popSTACK();
  2441.       }
  2442.     mv_count=1; skipSTACK(2); return;
  2443.     fehler_eof:
  2444.       pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2445.       pushSTACK(*stream_); # Stream
  2446.       pushSTACK(S(read));
  2447.       //: DEUTSCH "~: Eingabestream ~ endet innerhalb eines Strings."
  2448.       //: ENGLISH "~: input stream ~ ends within a string"
  2449.       //: FRANCAIS "~ : Le «stream» d'entrée ~ se termine au milieu d'une chaîne."
  2450.       fehler(end_of_file, GETTEXT("~: input stream ~ ends within a string"));
  2451.   }
  2452.  
  2453. # Liest ein Objekt und bildet eine zweielementige Liste.
  2454. # list2_reader(stream_);
  2455. # > Stackaufbau: stream, symbol.
  2456. # erhöht STACK um 2
  2457. # verändert STACK, kann GC auslösen
  2458.   local Values list2_reader (object* stream_);
  2459.   local Values list2_reader(stream_)
  2460.     var reg3 object* stream_;
  2461.     { var reg4 object obj = read_recursive_no_dot(stream_); # Objekt lesen
  2462.       pushSTACK(obj);
  2463.       pushSTACK(allocate_cons()); # zweites Listencons
  2464.      {var reg1 object new_cons1 = allocate_cons(); # erstes Listencons
  2465.       var reg2 object new_cons2 = popSTACK(); # zweites Listencons
  2466.       Car(new_cons2) = popSTACK(); # new_cons2 = (cons obj nil)
  2467.       #ifdef IMMUTABLE_CONS
  2468.       if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2469.         { new_cons2 = make_imm_cons(new_cons2); }
  2470.       #endif
  2471.       Cdr(new_cons1) = new_cons2; Car(new_cons1) = STACK_0; # new_cons1 = (cons symbol new_cons2)
  2472.       #ifdef IMMUTABLE_CONS
  2473.       if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  2474.         { new_cons1 = make_imm_cons(new_cons1); }
  2475.       #endif
  2476.       value1 = new_cons1; mv_count=1; skipSTACK(2);
  2477.     }}
  2478.  
  2479. # (set-macro-character #\'
  2480. #   #'(lambda (stream char)
  2481. #       (list 'QUOTE (read stream t nil t))
  2482. # )   )
  2483. LISPFUNN(quote_reader,2) # liest '
  2484.   { var reg3 object* stream_ = test_stream_arg(STACK_1);
  2485.     STACK_0 = S(quote); return_Values list2_reader(stream_);
  2486.   }
  2487.  
  2488. # (set-macro-character #\;
  2489. #   #'(lambda (stream char)
  2490. #       (loop
  2491. #         (let ((ch (read-char stream)))
  2492. #           (when (or (eql ch 'eof-code) (eql ch #\Newline)) (return))
  2493. #       ) )
  2494. #       (values)
  2495. # )   )
  2496. LISPFUNN(line_comment_reader,2) # liest ;
  2497.   { var reg2 object* stream_ = test_stream_arg(STACK_1);
  2498.     loop
  2499.       { var reg1 object ch = read_char(stream_); # Zeichen lesen
  2500.         if (eq(ch,eof_value) || eq(ch,code_char(NL))) break;
  2501.       }
  2502.     value1 = NIL; mv_count=0; skipSTACK(2); # keine Werte zurück
  2503.   }
  2504.  
  2505. # ------------------------- READ-Dispatch-Macros ------------------------------
  2506.  
  2507. # Fehlermeldung wegen einer unerlaubten Zahl bei Dispatch-Macros
  2508. # fehler_dispatch_zahl();
  2509. # > STACK_1: Stream
  2510. # > STACK_0: sub-char
  2511.   nonreturning_function(local, fehler_dispatch_zahl, (void));
  2512.   local void fehler_dispatch_zahl()
  2513.     { pushSTACK(STACK_1); # Wert für Slot STREAM von STREAM-ERROR
  2514.       pushSTACK(STACK_(0+1)); # sub-char
  2515.       pushSTACK(code_char('#'));
  2516.       pushSTACK(STACK_(1+3)); # Stream
  2517.       pushSTACK(S(read));
  2518.       //: DEUTSCH "~ von ~: Zwischen $ und $ darf keine Zahl stehen."
  2519.       //: ENGLISH "~ from ~: no number allowed between $ and $"
  2520.       //: FRANCAIS "~ de ~ : il ne faut pas de nombre entre $ et $"
  2521.       fehler(stream_error, GETTEXT("~ from ~: no number allowed between $ and $"));
  2522.     }
  2523.  
  2524. # UP: Überprüft die Abwesenheit eines Infix-Arguments n
  2525. # test_no_infix()
  2526. # > Stackaufbau: Stream, sub-char, n.
  2527. # > subr_self: Aufrufer (ein SUBR)
  2528. # < ergebnis: &stream
  2529. # erhöht STACK um 1
  2530. # verändert STACK
  2531.   local object* test_no_infix (void);
  2532.   local object* test_no_infix()
  2533.     { var reg1 object* stream_ = test_stream_arg(STACK_2);
  2534.       var reg2 object n = popSTACK();
  2535.       if ((!nullp(n)) && (!test_value(S(read_suppress))))
  2536.         # Bei n/=NIL und *READ-SUPPRESS*=NIL : Fehler melden
  2537.         { fehler_dispatch_zahl(); }
  2538.       return stream_;
  2539.     }
  2540.  
  2541. # (set-dispatch-macro-character #\# #\'
  2542. #   #'(lambda (stream sub-char n)
  2543. #       (when n (error ...))
  2544. #       (list 'FUNCTION (read stream t nil t))
  2545. # )   )
  2546. LISPFUNN(function_reader,3) # liest #'
  2547.   { var reg3 object* stream_ = test_no_infix(); # n muß NIL sein
  2548.     STACK_0 = S(function); return_Values list2_reader(stream_);
  2549.   }
  2550.  
  2551. # (set-dispatch-macro-character #\# #\|
  2552. #   #'(lambda (stream sub-char n) ; mit (not (eql sub-char #\#))
  2553. #       (when n (error ...))
  2554. #       (prog ((depth 0) ch)
  2555. #         1
  2556. #         (setq ch (read-char))
  2557. #         2
  2558. #         (case ch
  2559. #           (eof-code (error ...))
  2560. #           (sub-char (case (setq ch (read-char))
  2561. #                       (eof-code (error ...))
  2562. #                       (#\# (when (minusp (decf depth)) (return)))
  2563. #                       (t (go 2))
  2564. #           )         )
  2565. #           (#\# (case (setq ch (read-char))
  2566. #                  (eof-code (error ...))
  2567. #                  (sub-char (incf depth) (go 1))
  2568. #                  (t (go 2))
  2569. #           )    )
  2570. #           (t (go 1))
  2571. #       ) )
  2572. #       (values)
  2573. # )   )
  2574. LISPFUNN(comment_reader,3) # liest #|
  2575.   { var reg1 object* stream_ = test_no_infix(); # n muß NIL sein
  2576.     var reg3 uintL depth = 0;
  2577.     var reg2 object ch;
  2578.     loop1:
  2579.       ch = read_char(stream_);
  2580.     loop2:
  2581.       if (eq(ch,eof_value)) goto fehler_eof; # EOF -> Error
  2582.       elif (eq(ch,STACK_0))
  2583.         # sub-char gelesen
  2584.         { ch = read_char(stream_); # nächstes Zeichen
  2585.           if (eq(ch,eof_value)) goto fehler_eof; # EOF -> Error
  2586.           elif (eq(ch,code_char('#')))
  2587.             # sub-char und '#' gelesen -> depth erniedrigen:
  2588.             { if (depth==0) goto fertig;
  2589.               depth--; goto loop1;
  2590.             }
  2591.           else
  2592.             goto loop2;
  2593.         }
  2594.       elif (eq(ch,code_char('#')))
  2595.         # '#' gelesen
  2596.         { ch = read_char(stream_); # nächstes Zeichen
  2597.           if (eq(ch,eof_value)) goto fehler_eof; # EOF -> Error
  2598.           elif (eq(ch,STACK_0))
  2599.             # '#' und sub-char gelesen -> depth erhöhen:
  2600.             { depth++; goto loop1; }
  2601.           else
  2602.             goto loop2;
  2603.         }
  2604.       else goto loop1;
  2605.     fehler_eof:
  2606.       pushSTACK(STACK_1); # Wert für Slot STREAM von STREAM-ERROR
  2607.       pushSTACK(STACK_(0+1)); # sub-char
  2608.       pushSTACK(STACK_(0+2)); # sub-char
  2609.       pushSTACK(STACK_(1+3)); # Stream
  2610.       pushSTACK(S(read));
  2611.       //: DEUTSCH "~: Eingabestream ~ endet innerhalb eines Kommentars #$ ... $#"
  2612.       //: ENGLISH "~: input stream ~ ends within a comment #$ ... $#"
  2613.       //: FRANCAIS "~ : Le «stream» d'entrée se termine au cours d'un commentaire #$ ... $#"
  2614.       fehler(end_of_file, GETTEXT("~: input stream ~ ends within a comment #$ ... $#"));
  2615.     fertig:
  2616.       value1 = NIL; mv_count=0; skipSTACK(2); # keine Werte zurück
  2617.   }
  2618.  
  2619. # (set-dispatch-macro-character #\# #\\ 
  2620. #   #'(lambda (stream sub-char n)
  2621. #       (let ((token (read-token-1 stream #\\ 'single-escape)))
  2622. #         ; token ist ein String der Länge >=1
  2623. #         (unless *read-suppress*
  2624. #           (if n
  2625. #             (unless (< n char-font-limit) ; sowieso n>=0
  2626. #               (error "~ von ~: Fontnummer ~ für Zeichen ist zu groß (muß <~ sein)."
  2627. #                       'read stream        n                 char-font-limit
  2628. #             ) )
  2629. #             (setq n 0)
  2630. #           )
  2631. #           (let ((pos 0) (bits 0))
  2632. #             (loop
  2633. #               (if (= (+ pos 1) (length token))
  2634. #                 (return (make-char (char token pos) bits n))
  2635. #                 (let ((hyphen (position #\- token :start pos)))
  2636. #                   (if hyphen
  2637. #                     (flet ((equalx (name)
  2638. #                              (or (string-equal token name :start1 pos :end1 hyphen)
  2639. #                                  (string-equal token name :start1 pos :end1 hyphen :end2 1)
  2640. #                           )) )
  2641. #                       (cond ((equalx "CONTROL")
  2642. #                              (setq bits (logior bits char-control-bit)))
  2643. #                             ((equalx "META")
  2644. #                              (setq bits (logior bits char-meta-bit)))
  2645. #                             ((equalx "SUPER")
  2646. #                              (setq bits (logior bits char-super-bit)))
  2647. #                             ((equalx "HYPER")
  2648. #                              (setq bits (logior bits char-hyper-bit)))
  2649. #                             (t (error "~ von ~: Ein Character-Bit mit Namen ~ gibt es nicht."
  2650. #                                        'read stream (subseq token pos hyphen)
  2651. #                       )     )  )
  2652. #                       (setq pos (1+ hyphen))
  2653. #                     )
  2654. #                     (return
  2655. #                       (make-char
  2656. #                         (cond ((and (< (+ pos 4) (length token))
  2657. #                                     (string-equal token "CODE" :start1 pos :end1 (+ pos 4))
  2658. #                                )
  2659. #                                (code-char (parse-integer token :start (+ pos 4) :junk-allowed nil)) ; ohne Vorzeichen!
  2660. #                               )
  2661. #                               ((name-char (subseq token pos)))
  2662. #                               (t (error "~ von ~: Ein Character mit Namen ~ gibt es nicht."
  2663. #                                          'read stream (subseq token pos)
  2664. #                         )     )  )
  2665. #                         bits n
  2666. #                     ) )
  2667. #             ) ) ) )
  2668. # )   ) ) ) )
  2669. LISPFUNN(char_reader,3) # liest #\ 
  2670.   { # Stackaufbau: Stream, sub-char, n.
  2671.     var reg10 object* stream_ = test_stream_arg(STACK_2);
  2672.     # Token lesen, mit Dummy-Character '\' als Token-Anfang:
  2673.     read_token_1(stream_,code_char('\\'),syntax_single_esc);
  2674.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  2675.     if (test_value(S(read_suppress)))
  2676.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  2677.     # Zeichen aufbauen:
  2678.    {var reg9 cint c = 0; # im Aufbau befindliches Zeichen
  2679.     # Font bestimmen:
  2680.     if (!nullp(STACK_0)) # n=NIL -> Default-Font 0
  2681.       { var reg1 uintL font;
  2682.         if (mposfixnump(STACK_0) && ((font = posfixnum_to_L(STACK_0)) < char_font_limit))
  2683.           { c |= (font << char_font_shift_c); } # font einbauen
  2684.           else
  2685.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2686.             pushSTACK(fixnum(char_font_limit)); # char-font-limit
  2687.             pushSTACK(STACK_(0+2)); # n
  2688.             pushSTACK(*stream_); # Stream
  2689.             pushSTACK(S(read));
  2690.             //: DEUTSCH "~ von ~: Fontnummer ~ für Zeichen ist zu groß (muß < ~ sein)"
  2691.             //: ENGLISH "~ from ~: font number ~ for character is too large, should be < ~"
  2692.             //: FRANCAIS "~ de ~ : Le numéro ~ de font de caractère est trop grand (devrait être < ~)."
  2693.             fehler(stream_error, GETTEXT("~ from ~: font number ~ for character is too large, should be < ~"));
  2694.           }
  2695.       }
  2696.     # Font fertig.
  2697.     { var reg5 object token = O(token_buff_1); # gelesenes Token als Semi-Simple-String
  2698.       var reg7 uintL len = TheArray(token)->dims[1]; # Länge = Fill-Pointer
  2699.       var reg6 object hstring = O(displaced_string); # Hilfsstring
  2700.       TheArray(hstring)->data = token; # Datenvektor := O(token_buff_1)
  2701.       token = TheArray(token)->data; # Simple-String mit Token
  2702.      {var reg8 uintL pos = 0; # momentane Position im Token
  2703.       loop # Suche nächstes Hyphen
  2704.         { if (len-pos == 1) goto remains_one; # einbuchstabiger Charactername?
  2705.           { var reg7 uintL hyphen = pos; # hyphen := pos
  2706.             loop
  2707.               { if (hyphen == len) goto no_more_hyphen; # schon Token-Ende?
  2708.                 if (TheSstring(token)->data[hyphen] == '-') break; # Hyphen gefunden?
  2709.                 hyphen++; # nein -> weitersuchen
  2710.               }
  2711.             # Hyphen bei Position hyphen gefunden
  2712.            {var reg10 uintL sub_len = hyphen-pos;
  2713.             TheArray(hstring)->dims[0] = pos; # Displaced-Offset := pos
  2714.             TheArray(hstring)->totalsize =
  2715.               TheArray(hstring)->dims[1] = sub_len; # Länge := hyphen-pos
  2716.             # Jetzt ist hstring = (subseq token pos hyphen)
  2717.             if (sub_len==1)
  2718.               # Länge=1 -> auf Bitnamen-Abkürzungen überprüfen:
  2719.               { var reg4 uintB bitname1 = TheSstring(token)->data[pos]; # (char token pos)
  2720.                 bitname1 = up_case(bitname1); # als Großbuchstabe
  2721.                 # Ist es einer der Anfangsbuchstaben der Bitnamen?
  2722.                {var reg1 object* bitnameptr = &O(bitname_0);
  2723.                 var reg2 uintL bitnr = char_bits_shift_c;
  2724.                 var reg3 uintL count;
  2725.                 dotimesL(count,char_bits_len_c, # alle Bitnamen durchlaufen
  2726.                   { var reg1 object bitname = *bitnameptr++; # nächster Bitname (Simple-String)
  2727.                     if (TheSstring(bitname)->data[0] == bitname1) # mit bitname1 als Anfangsbuchstaben?
  2728.                       { c |= bit(bitnr); goto bit_ok; } # ja -> entsprechendes Bit setzen
  2729.                     bitnr++;
  2730.                   });
  2731.               }}
  2732.             # Ist es einer der Bitnamen selber?
  2733.             {var reg1 object* bitnameptr = &O(bitname_0);
  2734.              var reg2 uintL bitnr = char_bits_shift_c;
  2735.              var reg3 uintL count;
  2736.              dotimesL(count,char_bits_len_c, # alle Bitnamen durchlaufen
  2737.                { var reg1 object bitname = *bitnameptr++; # nächster Bitname (Simple-String)
  2738.                  if (string_equal(hstring,bitname)) # mit hstring vergleichen
  2739.                    { c |= bit(bitnr); goto bit_ok; } # gleich -> entsprechendes Bit setzen
  2740.                  bitnr++;
  2741.                });
  2742.             }
  2743.             # Displaced-String hstring ist kein Bitname -> Error
  2744.             { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2745.               pushSTACK(copy_string(hstring)); # Displaced-String kopieren
  2746.               pushSTACK(*stream_); # Stream
  2747.               pushSTACK(S(read));
  2748.               //: DEUTSCH "~ von ~: Ein Character-Bit mit Namen ~ gibt es nicht."
  2749.               //: ENGLISH "~ from ~: there is no character bit with name ~"
  2750.               //: FRANCAIS "~ de ~ : ~ n'est pas le nom d'un bit de caractère."
  2751.               fehler(stream_error, GETTEXT("~ from ~: there is no character bit with name ~"));
  2752.             }
  2753.             bit_ok: # Bitname gefunden, Bit gesetzt
  2754.             # Mit diesem Bitnamen fertig.
  2755.             pos = hyphen+1; # zum nächsten
  2756.         } }}
  2757.       remains_one: # einbuchstabiger Charactername
  2758.       {var reg1 uintB code = TheSstring(token)->data[pos]; # (char token pos)
  2759.        c |= (code << char_code_shift_c); # Code einbauen
  2760.        value1 = int_char(c); mv_count=1; skipSTACK(3); return;
  2761.       }
  2762.       no_more_hyphen: # kein weiteres Hyphen gefunden.
  2763.       {var reg10 uintL sub_len = len-pos; # Länge des Characternamens
  2764.        TheArray(hstring)->dims[0] = pos; # Displaced-Offset := pos
  2765.        /* TheArray(hstring)->totalsize =          */
  2766.        /*   TheArray(hstring)->dims[1] = sub_len; */ # Länge := len-pos
  2767.        # hstring = (subseq token pos hyphen) = restlicher Charactername
  2768.        # Test auf Characternamen "CODExxxx" (xxxx Dezimalzahl <256):
  2769.        if (sub_len > 4)
  2770.          { TheArray(hstring)->totalsize =
  2771.              TheArray(hstring)->dims[1] = 4;
  2772.            # hstring = (subseq token pos (+ pos 4))
  2773.            if (!string_equal(hstring,O(charname_prefix))) # = "Code" ?
  2774.              goto not_codexxxx; # nein -> weiter
  2775.            # Dezimalzahl entziffern:
  2776.           {var reg2 uintWL code = 0; # bisher gelesenes xxxx (<char_code_limit)
  2777.            var reg4 uintL index = pos+4;
  2778.            var reg3 uintB* charptr = &TheSstring(token)->data[index];
  2779.            loop
  2780.              { if (index == len) break; # Token-Ende erreicht?
  2781.               {var reg1 uintB c = *charptr++; # nächstes Character
  2782.                # soll Ziffer sein:
  2783.                if (!((c>='0') && (c<='9'))) goto not_codexxxx;
  2784.                code = 10*code + (c-'0'); # Ziffer dazunehmen
  2785.                # code soll < char_code_limit bleiben:
  2786.                if (code >= char_code_limit) goto not_codexxxx;
  2787.                index++;
  2788.              }}
  2789.            # Charactername war vom Typ "Codexxxx" mit code = xxxx < char_code_limit
  2790.            c |= ((cint)code << char_code_shift_c); # Code einbauen
  2791.            value1 = int_char(c); mv_count=1; skipSTACK(3); return;
  2792.          }}
  2793.        not_codexxxx:
  2794.        # Test auf Characternamen wie NAME-CHAR:
  2795.        TheArray(hstring)->totalsize =
  2796.          TheArray(hstring)->dims[1] = sub_len; # Länge := len-pos
  2797.        {var reg1 object ch = name_char(hstring); # Character mit diesem Namen suchen
  2798.         if (nullp(ch))
  2799.           # nicht gefunden -> Error
  2800.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2801.             pushSTACK(copy_string(hstring)); # Charactername kopieren
  2802.             pushSTACK(*stream_); # Stream
  2803.             pushSTACK(S(read));
  2804.             //: DEUTSCH "~ von ~: Ein Character mit Namen ~ gibt es nicht."
  2805.             //: ENGLISH "~ from ~: there is no character with name ~"
  2806.             //: FRANCAIS "~ de ~ : ~ n'est pas le nom d'un caractère."
  2807.             fehler(stream_error, GETTEXT("~ from ~: there is no character with name ~"));
  2808.           }
  2809.         # gefunden
  2810.         c |= char_int(ch); # Code einbauen
  2811.         value1 = int_char(c); mv_count=1; skipSTACK(3); return;
  2812.       }}
  2813.   }}}}
  2814.  
  2815. # (defun radix-1 (stream sub-char n base)
  2816. #   (let ((token (read-token stream)))
  2817. #     (unless *read-suppress*
  2818. #       (when n (error ...))
  2819. #       (if (case (test-number-syntax token base)
  2820. #             (integer t) (decimal-integer nil) (rational t) (float nil)
  2821. #           )
  2822. #         (read-number token base)
  2823. #         (error "~ von ~: Das Token ~ nach # ~ läßt sich nicht als rationale Zahl in Basis ~ interpretieren."
  2824. #                 'read stream token sub-char base
  2825. # ) ) ) ) )
  2826.   # UP für #B #O #X #R
  2827.   # radix_2(base)
  2828.   # > base: Basis (>=2, <=36)
  2829.   # > Stackaufbau: Stream, sub-char, base.
  2830.   # > O(token_buff_1), O(token_buff_2), token_escape_flag: gelesenes Token
  2831.   # < STACK: aufgeräumt
  2832.   # < mv_space/mv_count: Werte
  2833.   # kann GC auslösen
  2834.   local Values radix_2 (uintWL base);
  2835.   local Values radix_2(base)
  2836.     var uintWL base;
  2837.     { # Überprüfe, ob das Token eine rationale Zahl darstellt:
  2838.       var object string;
  2839.       var zahl_info info;
  2840.       upcase_token(); # in Großbuchstaben umwandeln
  2841.       switch (test_number_syntax(&base,&string,&info))
  2842.         { case 1: # Integer
  2843.             # letztes Character ein Punkt?
  2844.             if (TheSstring(string)->data[info.index2-1] == '.')
  2845.               # ja -> Dezimal-Integer, nicht in Basis base
  2846.               goto not_rational;
  2847.             # test_number_syntax wurde bereits im Schritt 3 fertig,
  2848.             # also ist base immer noch unverändert.
  2849.             skipSTACK(3);
  2850.             value1 = read_integer(base,info.sign,string,info.index1,info.index2);
  2851.             mv_count=1; return;
  2852.           case 2: # Rational
  2853.             # test_number_syntax wurde bereits im Schritt 3 fertig,
  2854.             # also ist base immer noch unverändert.
  2855.             skipSTACK(3);
  2856.             value1 = read_rational(base,info.sign,string,info.index1,info.index3,info.index2);
  2857.             mv_count=1; return;
  2858.           case 0: # keine Zahl
  2859.           case 3: # Float
  2860.           not_rational: # keine rationale Zahl
  2861.             pushSTACK(STACK_2); # Wert für Slot STREAM von STREAM-ERROR
  2862.             pushSTACK(STACK_(0+1)); # base
  2863.             pushSTACK(STACK_(1+2)); # sub-char
  2864.             pushSTACK(copy_string(O(token_buff_1))); # Token
  2865.             pushSTACK(STACK_(2+4)); # Stream
  2866.             pushSTACK(S(read));
  2867.             //: DEUTSCH "~ von ~: Das Token ~ nach #$ läßt sich nicht als rationale Zahl in Basis ~ interpretieren."
  2868.             //: ENGLISH "~ from ~: token ~ after #$ is not a rational number in base ~"
  2869.             //: FRANCAIS "~ de ~ : Le lexème ~ après ne peut être interprété comme nombre rationnel en base ~."
  2870.             fehler(stream_error, GETTEXT("~ from ~: token ~ after #$ is not a rational number in base ~"));
  2871.           default: NOTREACHED
  2872.         }
  2873.     }
  2874.   # UP für #B #O #X
  2875.   # radix_1(base)
  2876.   # > base: Basis (>=2, <=36)
  2877.   # > Stackaufbau: Stream, sub-char, n.
  2878.   # > subr_self: Aufrufer (ein SUBR)
  2879.   # < STACK: aufgeräumt
  2880.   # < mv_space/mv_count: Werte
  2881.   # kann GC auslösen
  2882.   local Values radix_1 (uintWL base);
  2883.   local Values radix_1(base)
  2884.     var reg2 uintWL base;
  2885.     { var reg1 object* stream_ = test_stream_arg(STACK_2);
  2886.       read_token(stream_); # Token lesen
  2887.       # bei *READ-SUPPRESS* /= NIL sofort fertig:
  2888.       if (test_value(S(read_suppress)))
  2889.         { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  2890.       if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  2891.       pushSTACK(fixnum(base)); # base als Fixnum
  2892.       return_Values radix_2(base);
  2893.     }
  2894.  
  2895. # (set-dispatch-macro-character #\# #\B
  2896. #   #'(lambda (stream sub-char n) (radix-1 stream sub-char n 2))
  2897. # )
  2898. LISPFUNN(binary_reader,3) # liest #B
  2899.   { return_Values radix_1(2); }
  2900.  
  2901. # (set-dispatch-macro-character #\# #\O
  2902. #   #'(lambda (stream sub-char n) (radix-1 stream sub-char n 8))
  2903. # )
  2904. LISPFUNN(octal_reader,3) # liest #O
  2905.   { return_Values radix_1(8); }
  2906.  
  2907. # (set-dispatch-macro-character #\# #\X
  2908. #   #'(lambda (stream sub-char n) (radix-1 stream sub-char n 16))
  2909. # )
  2910. LISPFUNN(hexadecimal_reader,3) # liest #X
  2911.   { return_Values radix_1(16); }
  2912.  
  2913. # (set-dispatch-macro-character #\# #\R
  2914. #   #'(lambda (stream sub-char n)
  2915. #       (if *read-suppress*
  2916. #         (if (and n (<= 2 n 36))
  2917. #           (radix-1 stream sub-char nil n)
  2918. #           (error "~ von ~: Zwischen # und R muß eine Zahlsystembasis zwischen 2 und 36 angegeben werden."
  2919. #                   'read stream
  2920. #         ) )
  2921. #         (progn (read-token stream) nil)
  2922. # )   ) )
  2923. LISPFUNN(radix_reader,3) # liest #R
  2924.   { var reg1 object* stream_ = test_stream_arg(STACK_2);
  2925.     read_token(stream_); # Token lesen
  2926.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  2927.     if (test_value(S(read_suppress)))
  2928.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  2929.     # n überprüfen:
  2930.     if (nullp(STACK_0))
  2931.       { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2932.         pushSTACK(code_char('#'));
  2933.         pushSTACK(*stream_); # Stream
  2934.         pushSTACK(S(read));
  2935.         //: DEUTSCH "~ von ~: Zwischen $ und R muß die Zahlsystembasis angegeben werden."
  2936.         //: ENGLISH "~ from ~: the number base must be given between $ and R"
  2937.         //: FRANCAIS "~ de ~ : La base numérique doit être spécifiée entre $ et R."
  2938.         fehler(stream_error, GETTEXT("~ from ~: the number base must be given between $ and R"));
  2939.       }
  2940.    {var reg2 uintL base;
  2941.     # n muß ein Fixnum zwischen 2 und 36 (inclusive) sein:
  2942.     if (mposfixnump(STACK_0) &&
  2943.         (base = posfixnum_to_L(STACK_0), (base >= 2) && (base <= 36))
  2944.        )
  2945.       { return_Values radix_2(base); } # Token als rationale Zahl interpretieren
  2946.       else
  2947.       { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2948.         pushSTACK(STACK_(0+1)); # n
  2949.         pushSTACK(code_char('#'));
  2950.         pushSTACK(*stream_); # Stream
  2951.         pushSTACK(S(read));
  2952.         //: DEUTSCH "~ von ~: Die zwischen $ und R angegebene Basis ~ liegt nicht zwischen 2 und 36."
  2953.         //: ENGLISH "~ from ~: The base ~ given between $ and R should lie between 2 and 36"
  2954.         //: FRANCAIS "~ de ~ : La base numérique ~ spécifiée entre $ et R doit être entre 2 et 36."
  2955.         fehler(stream_error, GETTEXT("~ from ~: The base ~ given between $ and R should lie between 2 and 36"));
  2956.       }
  2957.   }}
  2958.  
  2959. # (set-dispatch-macro-character #\# #\C
  2960. #   #'(lambda (stream sub-char n)
  2961. #       (declare (ignore sub-char))
  2962. #       (if *read-suppress*
  2963. #         (progn (read stream t nil t) nil)
  2964. #         (if n
  2965. #           (error "~: Zwischen # und C ist keine Zahl erlaubt." 'read)
  2966. #           (let ((h (read stream t nil t)))
  2967. #             (if (and (consp h) (consp (cdr h)) (null (cddr h))
  2968. #                      (numberp (first h)) (not (complexp (first h)))
  2969. #                      (numberp (second h)) (not (complexp (second h)))
  2970. #                 )
  2971. #               (apply #'complex h)
  2972. #               (error "~: Falsche Syntax für komplexe Zahl: #C~" 'read h)
  2973. # )   ) ) ) ) )
  2974. LISPFUNN(complex_reader,3) # liest #C
  2975.   { var reg3 object* stream_ = test_no_infix(); # n muß NIL sein
  2976.     var reg1 object obj = read_recursive_no_dot(stream_); # nächstes Objekt lesen
  2977.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  2978.     if (test_value(S(read_suppress)))
  2979.       { value1 = NIL; mv_count=1; skipSTACK(2); return; } # NIL als Wert
  2980.     obj = make_references(obj); # und Verweise vorzeitig entflechten
  2981.     # Überprüfen, ob dies eine zweielementige Liste von reellen Zahlen ist:
  2982.     if (!consp(obj)) goto bad; # obj muß ein Cons sein !
  2983.    {var reg2 object obj2 = Cdr(obj);
  2984.     if (!consp(obj2)) goto bad; # obj2 muß ein Cons sein !
  2985.     if (!nullp(Cdr(obj2))) goto bad; # mit (cdr obj2) = nil !
  2986.     if_realp(Car(obj), ; , goto bad; ); # und (car obj) eine reelle Zahl !
  2987.     if_realp(Car(obj2), ; , goto bad; ); # und (car obj2) eine reelle Zahl !
  2988.     # (apply #'COMPLEX obj) durchführen:
  2989.     apply(L(complex),0,obj);
  2990.     mv_count=1; skipSTACK(2); return; # value1 als Wert
  2991.    }
  2992.    {bad:
  2993.       pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  2994.       pushSTACK(obj); # Objekt
  2995.       pushSTACK(*stream_); # Stream
  2996.       pushSTACK(S(read));
  2997.       //: DEUTSCH "~ von ~: Falsche Syntax für komplexe Zahl: #C~"
  2998.       //: ENGLISH "~ from ~: bad syntax for complex number: #C~"
  2999.       //: FRANCAIS "~ de ~ : Syntaxe inadmissible pour un nombre complexe: #C~"
  3000.       fehler(stream_error, GETTEXT("~ from ~: bad syntax for complex number: #C~"));
  3001.   }}
  3002.  
  3003. # (set-dispatch-macro-character #\# #\:
  3004. #   #'(lambda (stream sub-char n)
  3005. #       (declare (ignore sub-char))
  3006. #       (if *read-suppress*
  3007. #         (progn (read stream t nil t) nil)
  3008. #         (let ((name (read-token stream))) ; eine Form, die nur ein Token ist
  3009. #           (when n (error ...))
  3010. #           [Überprüfe, ob auch keine Package-Marker im Token vorkommen.]
  3011. #           (make-symbol token)
  3012. # )   ) ) )
  3013. LISPFUNN(uninterned_reader,3) # liest #:
  3014.   { var reg3 object* stream_ = test_stream_arg(STACK_2);
  3015.     # bei *READ-SUPPRESS* /= NIL Form lesen und NIL liefern:
  3016.     if (test_value(S(read_suppress)))
  3017.       { read_recursive(stream_);
  3018.         value1 = NIL; mv_count=1; skipSTACK(3); return;
  3019.       }
  3020.     {# nächstes Zeichen lesen:
  3021.      var reg4 object ch;
  3022.      var reg5 uintWL scode;
  3023.      read_char_syntax(ch = ,scode = ,stream_);
  3024.      if (scode == syntax_eof) { fehler_eof_innen(stream_); } # EOF -> Error
  3025.      if (scode > syntax_constituent)
  3026.        # kein Zeichen, das am Token-Anfang stehen kann -> Error
  3027.        { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3028.          pushSTACK(*stream_); # Stream
  3029.          pushSTACK(S(read));
  3030.          //: DEUTSCH "~ von ~: Nach #: muß ein Token folgen."
  3031.          //: ENGLISH "~ from ~: token expected after #:"
  3032.          //: FRANCAIS "~ de ~ : Il faut un lexème après #:"
  3033.          fehler(stream_error, GETTEXT("~ from ~: token expected after #:"));
  3034.        }
  3035.      # Token zu Ende lesen:
  3036.      read_token_1(stream_,ch,scode);
  3037.     }
  3038.     if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  3039.     {# Token kopieren und dabei in Simple-String umwandeln:
  3040.      var reg5 object string = copy_string(O(token_buff_1));
  3041.      # Auf Package-Marker testen:
  3042.      {var reg3 object buff_2 = O(token_buff_2); # Attributcode-Buffer
  3043.       var reg2 uintL len = TheArray(buff_2)->dims[1]; # Länge = Fill-Pointer
  3044.       var reg1 uintB* attrptr = &TheSstring(TheArray(buff_2)->data)->data[0];
  3045.       # Teste, ob einer der len Attributcodes ab attrptr ein a_pack_m ist:
  3046.       dotimesL(len,len, { if (*attrptr++ == a_pack_m) goto fehler_dopp; } );
  3047.      }
  3048.      # uninterniertes Symbol mit diesem Namen bauen:
  3049.      value1 = make_symbol(string); mv_count=1; skipSTACK(2); return;
  3050.      fehler_dopp:
  3051.        pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3052.        pushSTACK(string); # Token
  3053.        pushSTACK(*stream_); # Stream
  3054.        pushSTACK(S(read));
  3055.        //: DEUTSCH "~ von ~: Das Token ~ nach #: darf keine Doppelpunkte enthalten."
  3056.        //: ENGLISH "~ from ~: token ~ after #: should contain no colon"
  3057.        //: FRANCAIS "~ de ~ : Le lexème ~ après ne doit pas contenir de deux-points."
  3058.        fehler(stream_error, GETTEXT("~ from ~: token ~ after #: should contain no colon"));
  3059.   } }
  3060.  
  3061. # (set-dispatch-macro-character #\# #\*
  3062. #   #'(lambda (stream sub-char n)
  3063. #       (declare (ignore sub-char))
  3064. #       (let* ((token (read-token stream)))
  3065. #         (unless *read-suppress*
  3066. #           (unless (or [Escape-Zeichen im Token verwendet]
  3067. #                       (every #'(lambda (ch) (member ch '(#\0 #\1))) token))
  3068. #             (error "~ von ~: Nach #* dürfen nur Nullen und Einsen kommen."
  3069. #                     'read stream
  3070. #           ) )
  3071. #           (let ((l (length token)))
  3072. #             (if n
  3073. #               (cond ((< n l)
  3074. #                      (error "~ von ~: Bit-Vektor länger als angegebene Länge ~."
  3075. #                              'read stream n
  3076. #                     ))
  3077. #                     ((and (plusp n) (zerop l))
  3078. #                      (error "~ von ~: Element für Bit-Vektor der Länge ~ muß spezifiziert werden."
  3079. #                              'read stream n
  3080. #               )     ))
  3081. #               (setq n l)
  3082. #             )
  3083. #             (let ((bv (make-array n :element-type 'bit))
  3084. #                   (i 0)
  3085. #                   b)
  3086. #               (loop
  3087. #                 (when (= i n) (return))
  3088. #                 (when (< i l) (setq b (case (char token i) (#\0 0) (#\1 1))))
  3089. #                 (setf (sbit bv i) b)
  3090. #                 (incf i)
  3091. #               )
  3092. #               bv
  3093. # )   ) ) ) ) )
  3094. LISPFUNN(bit_vector_reader,3) # liest #*
  3095.   { var reg8 object* stream_ = test_stream_arg(STACK_2);
  3096.     read_token(stream_); # Token lesen
  3097.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3098.     if (test_value(S(read_suppress)))
  3099.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  3100.     # Test, ob kein Escape-Zeichen und nur Nullen und Einsen verwendet:
  3101.     if (token_escape_flag)
  3102.       { fehler_nur01:
  3103.         pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3104.         pushSTACK(*stream_); # Stream
  3105.         pushSTACK(S(read));
  3106.         //: DEUTSCH "~ von ~: Nach #* dürfen nur Nullen und Einsen kommen."
  3107.         //: ENGLISH "~ from ~: only zeroes and ones are allowed after #*"
  3108.         //: FRANCAIS "~ de ~ : Seuls 0 et 1 sont permis après #*"
  3109.         fehler(stream_error, GETTEXT("~ from ~: only zeroes and ones are allowed after #*"));
  3110.       }
  3111.    {var reg7 object buff_1 = O(token_buff_1); # Character-Buffer
  3112.     var reg6 uintL len = TheArray(buff_1)->dims[1]; # Länge = Fill-Pointer
  3113.     {var reg2 uintB* charptr = &TheSstring(TheArray(buff_1)->data)->data[0];
  3114.      var reg3 uintL count;
  3115.      dotimesL(count,len,
  3116.        { var reg1 uintB c = *charptr++; # nächstes Character
  3117.          if (!((c=='0') || (c=='1'))) # nur '0' und '1' sind OK
  3118.            goto fehler_nur01;
  3119.        });
  3120.     }
  3121.     # n überprüfen:
  3122.     {var reg5 uintL n; # Länge des Bitvektors
  3123.      if (nullp(STACK_0))
  3124.        { n = len; } # Defaultwert ist die Tokenlänge
  3125.        else
  3126.        { # n angegeben, ein Integer >=0.
  3127.          n = (mposfixnump(STACK_0) ? posfixnum_to_L(STACK_0) # Fixnum -> Wert
  3128.                                    : bitm(oint_data_len)-1 # Bignum -> großer Wert
  3129.              );
  3130.          if (n<len)
  3131.            { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3132.              pushSTACK(STACK_(0+1)); # n
  3133.              pushSTACK(*stream_); # Stream
  3134.              pushSTACK(S(read));
  3135.              //: DEUTSCH "~ von ~: Bit-Vektor länger als angegebene Länge ~."
  3136.              //: ENGLISH "~ from ~: bit vector is longer than the explicitly given length ~"
  3137.              //: FRANCAIS "~ de ~ : Le vecteur de bits est plus long que la longueur explicite ~."
  3138.              fehler(stream_error, GETTEXT("~ from ~: bit vector is longer than the explicitly given length ~"));
  3139.            }
  3140.          if ((n>0) && (len==0))
  3141.            { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3142.              pushSTACK(STACK_(0+1)); # n
  3143.              pushSTACK(*stream_); # Stream
  3144.              pushSTACK(S(read));
  3145.              //: DEUTSCH "~ von ~: Element für Bit-Vektor der Länge ~ muß spezifiziert werden."
  3146.              //: ENGLISH "~ from ~: must specify element of bit vector of length ~"
  3147.              //: FRANCAIS "~ de ~ : Il faut spécifier un élément pour un vecteur de bits de longueur ~."
  3148.              fehler(stream_error, GETTEXT("~ from ~: must specify element of bit vector of length ~"));
  3149.            }
  3150.        }
  3151.      # Erzeuge neuen Bit-Vektor der Länge n:
  3152.      {var reg2 object bv = allocate_bit_vector(n);
  3153.       # und fülle die Bits ein:
  3154.       buff_1 = O(token_buff_1);
  3155.       { var reg4 uintB* charptr = &TheSstring(TheArray(buff_1)->data)->data[0];
  3156.         var reg3 uintB ch; # letztes Zeichen ('0' oder '1')
  3157.         var reg1 uintL index = 0;
  3158.         while (index < n)
  3159.           { if (index < len) { ch = *charptr++; } # evtl. nächstes Character holen
  3160.             if (ch == '0')
  3161.               { sbvector_bclr(bv,index); } # Null -> Bit löschen
  3162.               else
  3163.               { sbvector_bset(bv,index); } # Eins -> Bit setzen
  3164.             index++;
  3165.           }
  3166.       }
  3167.       #ifdef IMMUTABLE_ARRAY
  3168.       if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  3169.         { bv = make_imm_array(bv); }
  3170.       #endif
  3171.       value1 = bv; mv_count=1; skipSTACK(3); # bv als Wert
  3172.   }}}}
  3173.  
  3174. # (set-dispatch-macro-character #\# #\(
  3175. #   #'(lambda (stream sub-char n)
  3176. #       (declare (ignore sub-char))
  3177. #       (let* ((elements (read-delimited-list #\) stream t)))
  3178. #         (unless *read-suppress*
  3179. #           (let ((l (length elements)))
  3180. #             (if n
  3181. #               (cond ((< n l)
  3182. #                      (error "~ von ~: Vektor länger als angegebene Länge ~."
  3183. #                              'read stream n
  3184. #                     ))
  3185. #                     ((and (plusp n) (zerop l))
  3186. #                      (error "~ von ~: Element für Vektor der Länge ~ muß spezifiziert werden."
  3187. #                              'read stream n
  3188. #               )     ))
  3189. #               (setq n l)
  3190. #             )
  3191. #             (let ((v (make-array n))
  3192. #                   (i 0)
  3193. #                   b)
  3194. #               (loop
  3195. #                 (when (= i n) (return))
  3196. #                 (when (< i l) (setq b (pop elements)))
  3197. #                 (setf (svref v i) b)
  3198. #                 (incf i)
  3199. #               )
  3200. #               v
  3201. # )   ) ) ) ) )
  3202. LISPFUNN(vector_reader,3) # liest #(
  3203.   { var reg8 object* stream_ = test_stream_arg(STACK_2);
  3204.     # Liste bis zur Klammer zu lesen, Dot nicht erlaubt:
  3205.     var reg2 object elements = read_delimited_list(stream_,code_char(')'),eof_value);
  3206.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3207.     if (test_value(S(read_suppress)))
  3208.       { value1 = NIL; mv_count=1; skipSTACK(3); return; } # NIL als Wert
  3209.    {var reg6 uintL len = llength(elements); # Listenlänge
  3210.     # n überprüfen:
  3211.     var reg5 uintL n; # Länge des Vektors
  3212.     if (nullp(STACK_0))
  3213.       { n = len; } # Defaultwert ist die Tokenlänge
  3214.       else
  3215.       { # n angegeben, ein Integer >=0.
  3216.         n = (mposfixnump(STACK_0) ? posfixnum_to_L(STACK_0) # Fixnum -> Wert
  3217.                                   : bitm(oint_data_len)-1 # Bignum -> großer Wert
  3218.             );
  3219.         if (n<len)
  3220.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3221.             pushSTACK(STACK_(0+1)); # n
  3222.             pushSTACK(*stream_); # Stream
  3223.             pushSTACK(S(read));
  3224.             //: DEUTSCH "~ von ~: Vektor länger als angegebene Länge ~."
  3225.             //: ENGLISH "~ from ~: vector is longer than the explicitly given length ~"
  3226.             //: FRANCAIS "~ de ~ : Le vecteur est plus long que la longueur explicite ~."
  3227.             fehler(stream_error, GETTEXT("~ from ~: vector is longer than the explicitly given length ~"));
  3228.           }
  3229.         if ((n>0) && (len==0))
  3230.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3231.             pushSTACK(STACK_(0+1)); # n
  3232.             pushSTACK(*stream_); # Stream
  3233.             pushSTACK(S(read));
  3234.             //: DEUTSCH "~ von ~: Element für Vektor der Länge ~ muß spezifiziert werden."
  3235.             //: ENGLISH "~ from ~: must specify element of vector of length ~"
  3236.             //: FRANCAIS "~ de ~ : Il faut spécifier un élément pour un vecteur de longueur ~."
  3237.             fehler(stream_error, GETTEXT("~ from ~: must specify element of vector of length ~"));
  3238.           }
  3239.       }
  3240.     # Erzeuge neuen Vektor der Länge n:
  3241.     pushSTACK(elements); # Liste retten
  3242.     {var reg7 object v = allocate_vector(n);
  3243.      elements = popSTACK(); # Liste zurück
  3244.      # und fülle die Elemente ein:
  3245.      { var reg4 object* vptr = &TheSvector(v)->data[0];
  3246.        var reg3 object el; # letztes Element
  3247.        var reg1 uintL index = 0;
  3248.        while (index < n)
  3249.          { if (index < len) { el = Car(elements); elements = Cdr(elements); } # evtl. nächstes Element holen
  3250.            *vptr++ = el;
  3251.            index++;
  3252.          }
  3253.      }
  3254.      #ifdef IMMUTABLE_ARRAY
  3255.      if (TheStream(*stream_)->strmflags & strmflags_immut_B)
  3256.        { v = make_imm_array(v); }
  3257.      #endif
  3258.      value1 = v; mv_count=1; skipSTACK(3); # v als Wert
  3259.   }}}
  3260.  
  3261. # (set-dispatch-macro-character #\# #\A
  3262. #   #'(lambda (stream sub-char n)
  3263. #       (declare (ignore sub-char))
  3264. #       (if *read-suppress*
  3265. #         (progn (read stream t nil t) nil)
  3266. #         (if (null n)
  3267. #           (let ((h (read stream t nil t)))
  3268. #             (if (and (consp h) (consp (cdr h)) (consp (cddr h)) (null (cdddr h)))
  3269. #               (make-array (second h) :element-type (first h) :initial-contents (third h))
  3270. #               (error "~: Falsche Syntax für Array: #A~" 'read h)
  3271. #           ) )
  3272. #           (let* ((rank n)
  3273. #                  (cont (let ((*backquote-level* nil)) (read stream t nil t)))
  3274. #                  (dims '())
  3275. #                  (eltype 't))
  3276. #             (when (plusp rank)
  3277. #               (let ((subcont cont) (i 0))
  3278. #                 (loop
  3279. #                   (let ((l (length subcont)))
  3280. #                     (push l dims)
  3281. #                     (incf i) (when (>= i rank) (return))
  3282. #                     (when (plusp l) (setq subcont (elt subcont 0)))
  3283. #                 ) )
  3284. #                 (cond ((stringp subcont) (setq eltype 'string-char))
  3285. #                       ((bit-vector-p subcont) (setq eltype 'bit))
  3286. #             ) ) )
  3287. #             (make-array (nreverse dims) :element-type eltype :initial-contents cont)
  3288. # )   ) ) ) )
  3289. LISPFUNN(array_reader,3) # liest #A
  3290.   { var reg2 object* stream_ = test_stream_arg(STACK_2);
  3291.     # Stackaufbau: stream, sub-char, n.
  3292.     if (test_value(S(read_suppress))) # *READ-SUPPRESS* /= NIL ?
  3293.       # ja -> nächstes Objekt überlesen:
  3294.       { read_recursive_no_dot(stream_);
  3295.         value1 = NIL; mv_count=1; skipSTACK(3); return;
  3296.       }
  3297.    {
  3298.     #ifdef IMMUTABLE_ARRAY
  3299.     var reg5 uintB flags = TheStream(*stream_)->strmflags;
  3300.     #endif
  3301.     if (nullp(STACK_0)) # n nicht angegeben?
  3302.       # ja -> Liste (eltype dims contents) lesen:
  3303.       { var reg1 object obj = read_recursive_no_dot(stream_); # Liste lesen
  3304.         obj = make_references(obj); # Verweise entflechten
  3305.         # (Das ist ungefährlich, da wir diese #A-Syntax für Arrays mit
  3306.         # Elementtyp T nicht benutzen, und Byte-Arrays enthalten keine Verweise.)
  3307.         if (!consp(obj)) goto bad;
  3308.         { var reg3 object obj2 = Cdr(obj);
  3309.           if (!consp(obj2)) goto bad;
  3310.          {var reg4 object obj3 = Cdr(obj2);
  3311.           if (!consp(obj3)) goto bad;
  3312.           if (!nullp(Cdr(obj3))) goto bad;
  3313.           # (MAKE-ARRAY dims :element-type eltype :initial-contents contents) aufrufen:
  3314.           STACK_2 = Car(obj2); STACK_1 = S(Kelement_type); STACK_0 = Car(obj);
  3315.           pushSTACK(S(Kinitial_contents)); pushSTACK(Car(obj3));
  3316.           goto call_make_array;
  3317.         }}
  3318.         bad:
  3319.           pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3320.           pushSTACK(obj); # Objekt
  3321.           pushSTACK(*stream_); # Stream
  3322.           pushSTACK(S(read));
  3323.           //: DEUTSCH "~ von ~: Falsche Syntax für Array: #A~"
  3324.           //: ENGLISH "~ from ~: bad syntax for array: #A~"
  3325.           //: FRANCAIS "~ de ~ : Syntaxe inadmissible pour une matrice: #A~"
  3326.           fehler(stream_error, GETTEXT("~ from ~: bad syntax for array: #A~"));
  3327.       }
  3328.     # n gibt den Rang des Arrays an.
  3329.     # Inhalt lesen:
  3330.     { dynamic_bind(S(backquote_level),NIL); # SYS::*BACKQUOTE-LEVEL* an NIL binden
  3331.      {var reg1 object contents = read_recursive_no_dot(stream_);
  3332.       dynamic_unbind();
  3333.       pushSTACK(contents); pushSTACK(contents);
  3334.     }}
  3335.     STACK_4 = NIL; # dims := '()
  3336.     # Stackaufbau: dims, -, rank, subcontents, contents.
  3337.     # Dimensionen und Elementtyp bestimmen:
  3338.     if (eq(STACK_2,Fixnum_0)) # rank=0 ?
  3339.       { STACK_2 = S(t); } # ja -> eltype := 'T
  3340.       else
  3341.       { var reg3 object i = Fixnum_0; # bisherige Verschachtelungstiefe
  3342.         loop
  3343.           { pushSTACK(STACK_1); funcall(L(length),1); # (LENGTH subcontents)
  3344.             # auf dims pushen:
  3345.             STACK_3 = value1;
  3346.             {var reg1 object new_cons = allocate_cons();
  3347.              Car(new_cons) = STACK_3; Cdr(new_cons) = STACK_4;
  3348.              STACK_4 = new_cons;
  3349.             }
  3350.             # Tiefe erhöhen:
  3351.             i = fixnum_inc(i,1); if (eql(i,STACK_2)) break;
  3352.             # erstes Element von subcontents für die weiteren Dimensionen:
  3353.             if (!eq(STACK_3,Fixnum_0)) # (nur falls (length subcontents) >0)
  3354.               { pushSTACK(STACK_1); pushSTACK(Fixnum_0); funcall(L(elt),2);
  3355.                 STACK_1 = value1; # subcontents := (ELT subcontents 0)
  3356.               }
  3357.           }
  3358.         nreverse(STACK_4); # Liste dims umdrehen
  3359.         # eltype bestimmen je nach innerstem subcontents:
  3360.         STACK_2 = (mstringp(STACK_1) ? S(string_char) : # String: STRING-CHAR
  3361.                    m_bit_vector_p(STACK_1) ? S(bit) : # Bitvektor: BIT
  3362.                    S(t)                               # sonst (Liste): T
  3363.                   );
  3364.       }
  3365.     # Stackaufbau: dims, -, eltype, -, contents.
  3366.     # MAKE-ARRAY aufrufen:
  3367.     STACK_3 = S(Kelement_type); STACK_1 = S(Kinitial_contents);
  3368.     call_make_array:
  3369.     funcall(L(make_array),5);
  3370.     #ifdef IMMUTABLE_ARRAY
  3371.     if (flags & strmflags_immut_B)
  3372.       { # Ergebnis-Array value1 immutabel machen:
  3373.         if (!array_simplep(value1))
  3374.           { var reg1 object dv = TheArray(value1)->data; # Datenvektor: Simple-Array
  3375.             if (!array_simplep(dv)) # Simple-Byte-Vektor?
  3376.               { TheArray(dv)->data = make_imm_array(TheArray(dv)->data); }
  3377.             TheArray(value1)->data = make_imm_array(dv);
  3378.           }
  3379.         value1 = make_imm_array(value1);
  3380.       }
  3381.     #endif
  3382.     mv_count=1; return;
  3383.   }}
  3384.  
  3385. # (set-dispatch-macro-character #\# #\.
  3386. #   #'(lambda (stream sub-char n)
  3387. #       (declare (ignore sub-char))
  3388. #       (let ((h (read stream t nil t)))
  3389. #         (unless *read-suppress*
  3390. #           (if n
  3391. #             (error "~ von ~: Zwischen # und . ist keine Zahl erlaubt."
  3392. #                     'read stream
  3393. #             )
  3394. #             (eval h)
  3395. # )   ) ) ) )
  3396. LISPFUNN(read_eval_reader,3) # liest #.
  3397.   { var reg2 object* stream_ = test_stream_arg(STACK_2);
  3398.     var reg1 object obj = read_recursive_no_dot(stream_); # Form lesen
  3399.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3400.     if (test_value(S(read_suppress)))
  3401.       { value1 = NIL; mv_count=1; skipSTACK(3); return; }
  3402.     if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  3403.     obj = make_references(obj); # Verweise entflechten
  3404.     eval_noenv(obj); # Form auswerten
  3405.     mv_count=1; skipSTACK(2); # nur 1 Wert zurück
  3406.   }
  3407.  
  3408. # (set-dispatch-macro-character #\# #\,
  3409. #   #'(lambda (stream sub-char n)
  3410. #       (declare (ignore sub-char))
  3411. #       (let ((h (read stream t nil t)))
  3412. #         (unless *read-suppress*
  3413. #           (if n
  3414. #             (error "~ von ~: Zwischen # und , ist keine Zahl erlaubt."
  3415. #                     'read stream
  3416. #             )
  3417. #             (if sys::*compiling* (make-load-time-eval h) (eval h))
  3418. # )   ) ) ) )
  3419. LISPFUNN(load_eval_reader,3) # liest #,
  3420.   { var reg2 object* stream_ = test_stream_arg(STACK_2);
  3421.     var reg1 object obj = read_recursive_no_dot(stream_); # Form lesen
  3422.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3423.     if (test_value(S(read_suppress)))
  3424.       { value1 = NIL; mv_count=1; skipSTACK(3); return; }
  3425.     if (!nullp(popSTACK())) { fehler_dispatch_zahl(); } # n/=NIL -> Error
  3426.     obj = make_references(obj); # Verweise entflechten
  3427.     if (test_value(S(compiling)))
  3428.       # Im Compiler:
  3429.       { pushSTACK(obj);
  3430.        {var reg3 object new = allocate_loadtimeeval(); # Load-time-Eval-Objekt
  3431.         TheLoadtimeeval(new)->loadtimeeval_form = popSTACK(); # mit obj als Form
  3432.         value1 = new;
  3433.       }}
  3434.       else
  3435.       # Im Interpreter:
  3436.       { eval_noenv(obj); } # Form auswerten
  3437.     mv_count=1; skipSTACK(2); # nur 1 Wert zurück
  3438.   }
  3439.  
  3440. # (set-dispatch-macro-character #\# #\=
  3441. #   #'(lambda (stream sub-char n)
  3442. #       (if *read-suppress*
  3443. #         (if n
  3444. #           (if (sys::fixnump n)
  3445. #             (let* ((label (make-internal-label n))
  3446. #                    (h (assoc label sys::*read-reference-table* :test #'eq)))
  3447. #               (if (consp h)
  3448. #                 (error "~ von ~: Label #~= darf nicht zweimal definiert werden." 'read stream n)
  3449. #                 (progn
  3450. #                   (push (setq h (cons label label)) sys::*read-reference-table*)
  3451. #                   (let ((obj (read stream t nil t)))
  3452. #                     (if (eq obj label)
  3453. #                       (error "~ von ~: #~= #~# ist nicht erlaubt." 'read stream n n)
  3454. #                       (setf (cdr h) obj)
  3455. #             ) ) ) ) )
  3456. #             (error "~ von ~: Label #~= zu groß" 'read stream n)
  3457. #           )
  3458. #           (error "~ von ~: Zwischen # und = muß eine Zahl angegeben werden." 'read stream)
  3459. #         )
  3460. #         (values) ; keine Werte (Kommentar)
  3461. # )   ) )
  3462.  
  3463. # (set-dispatch-macro-character #\# #\#
  3464. #   #'(lambda (stream sub-char n)
  3465. #       (unless *read-suppress*
  3466. #         (if n
  3467. #           (if (sys::fixnump n)
  3468. #             (let* ((label (make-internal-label n))
  3469. #                    (h (assoc label sys::*read-reference-table* :test #'eq)))
  3470. #               (if (consp h)
  3471. #                 label ; wird später entflochten
  3472. #                 ; (man könnte auch (cdr h) zurückliefern)
  3473. #                 (error "~ von ~: Label #~= ist nicht definiert." 'read stream n)
  3474. #               )
  3475. #             (error "~ von ~: Label #~# zu groß" 'read stream n)
  3476. #           )
  3477. #           (error "~ von ~: Zwischen # und # muß eine Zahl angegeben werden." 'read stream)
  3478. # )   ) ) )
  3479.  
  3480. # UP: Bildet ein internes Label und sucht es in der *READ-REFERENCE-TABLE* auf.
  3481. # lookup_label()
  3482. # > Stackaufbau: Stream, sub-char, n.
  3483. # < ergebnis: (or (assoc label sys::*read-reference-table* :test #'eq) label)
  3484.   local object lookup_label (void);
  3485.   local object lookup_label()
  3486.     { var reg4 object n = STACK_0;
  3487.       if (nullp(n)) # nicht angegeben?
  3488.         { pushSTACK(STACK_2); # Wert für Slot STREAM von STREAM-ERROR
  3489.           pushSTACK(STACK_(1+1)); # sub-char
  3490.           pushSTACK(code_char('#'));
  3491.           pushSTACK(STACK_(2+3)); # Stream
  3492.           pushSTACK(S(read));
  3493.           //: DEUTSCH "~ von ~: Zwischen $ und $ muß eine Zahl angegeben werden."
  3494.           //: ENGLISH "~ from ~: a number must be given between $ and $"
  3495.           //: FRANCAIS "~ de ~ : Un nombre doit être spécifié entre $ et $"
  3496.           fehler(stream_error, GETTEXT("~ from ~: a number must be given between $ and $"));
  3497.         }
  3498.       # n ist ein Integer >=0
  3499.       if (!(posfixnump(n) && (posfixnum_to_L(n) < bit(oint_data_len-2))))
  3500.         # n ist zu groß
  3501.         { pushSTACK(STACK_2); # Wert für Slot STREAM von STREAM-ERROR
  3502.           pushSTACK(STACK_(1+1)); # sub-char
  3503.           pushSTACK(STACK_(0+2)); # n
  3504.           pushSTACK(STACK_(2+3)); # Stream
  3505.           pushSTACK(S(read));
  3506.           //: DEUTSCH "~ von ~: Label #~? zu groß"
  3507.           //: ENGLISH "~ from ~: label #~? too large"
  3508.           //: FRANCAIS "~ de ~ : La marque #~? est trop grande."
  3509.           fehler(stream_error, GETTEXT("~ from ~: label #~? too large"));
  3510.         }
  3511.      {var reg3 object label = # Internal-Label mit Nummer n
  3512.         type_data_object(system_type, bit(0) + (posfixnum_to_L(n)<<1) );
  3513.       var reg2 object alist = # Wert von SYS::*READ-REFERENCE-TABLE*
  3514.         Symbol_value(S(read_reference_table));
  3515.       # (assoc label alist :test #'eq) ausführen:
  3516.       while (consp(alist))
  3517.         { var reg1 object acons = Car(alist); # Listenelement
  3518.           if (!consp(acons)) goto bad_reftab; # muß ein Cons sein !
  3519.           if (eq(Car(acons),label)) # dessen CAR = label ?
  3520.             { return acons; } # ja -> fertig
  3521.           alist = Cdr(alist);
  3522.         }
  3523.       if (nullp(alist)) # Listenende mit NIL ?
  3524.         { return label; } # ja -> (assoc ...) = NIL -> fertig mit label
  3525.       bad_reftab: # Wert von SYS::*READ-REFERENCE-TABLE* ist keine Aliste
  3526.         pushSTACK(Symbol_value(S(read_reference_table))); # Wert von SYS::*READ-REFERENCE-TABLE*
  3527.         pushSTACK(S(read_reference_table)); # SYS::*READ-REFERENCE-TABLE*
  3528.         pushSTACK(STACK_(2+2)); # Stream
  3529.         pushSTACK(S(read));
  3530.         //: DEUTSCH "~ von ~: Der Wert von ~ wurde von außen verändert, er ist keine A-Liste: ~"
  3531.         //: ENGLISH "~ from ~: the value of ~ has been altered arbitrarily, it is not an alist: ~"
  3532.         //: FRANCAIS "~ de ~ : La valeur de ~ a été modifiée extérieurement, elle n'est plus une aliste: ~"
  3533.         fehler(error, GETTEXT("~ from ~: the value of ~ has been altered arbitrarily, it is not an alist: ~"));
  3534.     }}
  3535.  
  3536. LISPFUNN(label_definition_reader,3) # liest #=
  3537.   { # bei *READ-SUPPRESS* /= NIL wird #n= als Kommentar behandelt:
  3538.     if (test_value(S(read_suppress)))
  3539.       { value1 = NIL; mv_count=0; skipSTACK(3); return; } # keine Werte
  3540.     # Label bilden und in der Tabelle aufsuchen:
  3541.    {var reg4 object lookup = lookup_label();
  3542.     if (consp(lookup))
  3543.       # gefunden -> war schon da -> Fehler:
  3544.       { pushSTACK(STACK_2); # Wert für Slot STREAM von STREAM-ERROR
  3545.         pushSTACK(STACK_(0+1)); # n
  3546.         pushSTACK(STACK_(2+2)); # Stream
  3547.         pushSTACK(S(read));
  3548.         //: DEUTSCH "~ von ~: Label #~= darf nicht zweimal definiert werden."
  3549.         //: ENGLISH "~ from ~: label #~= may not be defined twice"
  3550.         //: FRANCAIS "~ de ~ : La marque #~= ne peut pas être définie deux fois."
  3551.         fehler(stream_error, GETTEXT("~ from ~: label #~= may not be defined twice"));
  3552.       }
  3553.       else
  3554.       # lookup = label, nicht GC-gefährdet.
  3555.       # (push (setq h (cons label label)) sys::*read-reference-table*) :
  3556.       {var reg3 object* stream_ = test_stream_arg(STACK_2);
  3557.        {var reg1 object new_cons = allocate_cons();
  3558.         Car(new_cons) = Cdr(new_cons) = lookup; # h = (cons label label)
  3559.         pushSTACK(new_cons); # h retten
  3560.        }
  3561.        {var reg1 object new_cons = allocate_cons(); # neues Listen-Cons
  3562.         Car(new_cons) = STACK_0;
  3563.         Cdr(new_cons) = Symbol_value(S(read_reference_table));
  3564.         set_Symbol_value(S(read_reference_table),new_cons);
  3565.        }
  3566.        {var reg2 object obj = read_recursive_no_dot(stream_); # Objekt lesen
  3567.         var reg1 object h = popSTACK();
  3568.         if (eq(obj,Car(h))) # gelesenes Objekt = (car h) = label ?
  3569.           # ja -> zyklische Definition -> Error
  3570.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3571.             pushSTACK(code_char('#'));
  3572.             pushSTACK(STACK_(0+2)); # n
  3573.             pushSTACK(STACK_(0+3)); # n
  3574.             pushSTACK(*stream_); # Stream
  3575.             pushSTACK(S(read));
  3576.             //: DEUTSCH "~ von ~: #~= #~$ ist nicht erlaubt."
  3577.             //: ENGLISH "~ from ~: #~= #~$ is illegal"
  3578.             //: FRANCAIS "~ de ~ : #~= #~$ n'est pas permis."
  3579.             fehler(stream_error, GETTEXT("~ from ~: #~= #~$ is illegal"));
  3580.           }
  3581.         # gelesenes Objekt als (cdr h) eintragen:
  3582.         Cdr(h) = obj;
  3583.         value1 = obj; mv_count=1; skipSTACK(3); # obj als Wert
  3584.       }}
  3585.   }}
  3586.  
  3587. LISPFUNN(label_reference_reader,3) # liest ##
  3588.   { # bei *READ-SUPPRESS* /= NIL sofort fertig:
  3589.     if (test_value(S(read_suppress)))
  3590.       { value1 = NIL; mv_count=1; skipSTACK(3); return; }
  3591.     # Label bilden und in der Tabelle aufsuchen:
  3592.    {var reg1 object lookup = lookup_label();
  3593.     if (consp(lookup))
  3594.       # gefunden -> Label als gelesenes Objekt zurück:
  3595.       { value1 = Car(lookup); mv_count=1; skipSTACK(3); }
  3596.       else
  3597.       # nicht gefunden
  3598.       { pushSTACK(STACK_2); # Wert für Slot STREAM von STREAM-ERROR
  3599.         pushSTACK(code_char('#'));
  3600.         pushSTACK(STACK_(0+2)); # n
  3601.         pushSTACK(STACK_(2+3)); # Stream
  3602.         pushSTACK(S(read));
  3603.         //: DEUTSCH "~ von ~: Label #~$ ist nicht definiert."
  3604.         //: ENGLISH "~ from ~: undefined label #~$"
  3605.         //: FRANCAIS "~ de ~ : La marque #~$ n'est pas définie."
  3606.         fehler(stream_error, GETTEXT("~ from ~: undefined label #~$"));
  3607.       }
  3608.   }}
  3609.  
  3610. # (set-dispatch-macro-character #\# #\<
  3611. #   #'(lambda (stream sub-char n)
  3612. #       (error "~ von ~: Als #<...> ausgegebene Objekte sind nicht mehr einlesbar."
  3613. #               'read stream
  3614. # )   ) )
  3615. LISPFUNN(not_readable_reader,3) # liest #<
  3616.   { var reg1 object* stream_ = test_stream_arg(STACK_2);
  3617.     pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3618.     pushSTACK(*stream_); # Stream
  3619.     pushSTACK(S(read));
  3620.     //: DEUTSCH "~ von ~: Als #<...> ausgegebene Objekte sind nicht mehr einlesbar."
  3621.     //: ENGLISH "~ from ~: objects printed as #<...> cannot be read back in"
  3622.     //: FRANCAIS "~ de ~ : Des objets qui ont été imprimés en forme #<...> ne peuvent servir d'entrée."
  3623.     fehler(stream_error, GETTEXT("~ from ~: objects printed as #<...> cannot be read back in"));
  3624.   }
  3625.  
  3626. # (dolist (ch '(#\) #\Space #\Newline #\Linefeed #\Backspace #\Rubout #\Tab #\Return #\Page))
  3627. #   (set-dispatch-macro-character #\# ch
  3628. #     #'(lambda (stream sub-char n)
  3629. #         (error "~ von ~: Wegen ~ als # ausgegebene Objekte sind nicht mehr einlesbar."
  3630. #                 'read stream '*print-level*
  3631. # ) )   ) )
  3632. LISPFUNN(syntax_error_reader,3) # liest #) und #whitespace
  3633.   { var reg1 object* stream_ = test_stream_arg(STACK_2);
  3634.     pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3635.     pushSTACK(code_char('#'));
  3636.     pushSTACK(S(print_level));
  3637.     pushSTACK(*stream_); # Stream
  3638.     pushSTACK(S(read));
  3639.     //: DEUTSCH "~ von ~: Wegen ~ als $ ausgegebene Objekte sind nicht mehr einlesbar."
  3640.     //: ENGLISH "~ from ~: objects printed as $ in view of ~ cannot be read back in"
  3641.     //: FRANCAIS "~ de ~ : Des objets qui ont été imprimés en $ à cause de ~ ne peuvent servir d'entrée."
  3642.     fehler(stream_error, GETTEXT("~ from ~: objects printed as $ in view of ~ cannot be read back in"));
  3643.   }
  3644.  
  3645. # Hilfsfunktion für #+ und #- :
  3646. # (defun interpret-feature (feature)
  3647. #   (flet ((eqs (x y) (and (symbolp x) (symbolp y)
  3648. #                          (string= (symbol-name x) (symbol-name y))
  3649. #         ))          )
  3650. #     (cond ((symbolp feature) (member feature *features* :test #'eqs))
  3651. #           ((atom feature)
  3652. #            (error "~: Als Feature ist ~ nicht erlaubt." 'read feature)
  3653. #           )
  3654. #           ((eqs (car feature) 'and)
  3655. #            (every #'interpret-feature (cdr feature))
  3656. #           )
  3657. #           ((eqs (car feature) 'or)
  3658. #            (some #'interpret-feature (cdr feature))
  3659. #           )
  3660. #           ((eqs (car feature) 'not)
  3661. #            (not (interpret-feature (second feature)))
  3662. #           )
  3663. #           (t (error "~: Als Feature ist ~ nicht erlaubt." 'read feature))
  3664. # ) ) )
  3665.  
  3666. # UP: Stellt das Erfülltsein eines Feature-Ausdruckes fest.
  3667. # interpret_feature(expr)
  3668. # > expr: ein Feature-Ausdruck
  3669. # > STACK_1: Stream
  3670. # < ergebnis: Wahrheitswert: 0 falls erfüllt, ~0 falls nicht erfüllt.
  3671.   local uintWL interpret_feature (object expr);
  3672.   local uintWL interpret_feature(expr)
  3673.     var reg3 object expr;
  3674.     { check_SP();
  3675.       if (symbolp(expr))
  3676.         # expr Symbol, in *FEATURES* suchen:
  3677.         { var reg2 object pname = Symbol_name(expr); # dem Namen nach suchen
  3678.           var reg1 object list = Symbol_value(S(features)); # Wert von *FEATURES*
  3679.           while (consp(list))
  3680.             { if (msymbolp(Car(list))
  3681.                   && string_gleich(Symbol_name(Car(list)),pname)
  3682.                  )
  3683.                 goto ja;
  3684.               list = Cdr(list);
  3685.             }
  3686.           goto nein;
  3687.         }
  3688.       elif (consp(expr) && msymbolp(Car(expr)))
  3689.         { var reg5 object opname = Symbol_name(Car(expr));
  3690.           var reg4 uintWL and_or_flag;
  3691.           if (string_gleich(opname,Symbol_name(S(and))))
  3692.             # expr = (AND ...)
  3693.             { and_or_flag = 0; goto and_or; }
  3694.           elif (string_gleich(opname,Symbol_name(S(or))))
  3695.             # expr = (OR ...)
  3696.             { and_or_flag = ~0;
  3697.               and_or:
  3698.               # Listenelemente von expr so lange abinterpretieren, bis ein
  3699.               # Ergebnis /=and_or_flag kommt. Default ist and_or_flag.
  3700.               { var reg1 object list = Cdr(expr);
  3701.                 while (consp(list))
  3702.                   { # Listenelement abinterpretieren:
  3703.                     var reg3 uintWL sub_erg = interpret_feature(Car(list));
  3704.                     if (!(sub_erg == and_or_flag)) { return sub_erg; }
  3705.                     list = Cdr(list);
  3706.                   }
  3707.                 if (nullp(list)) { return and_or_flag; }
  3708.                 # expr war eine Dotted List -> Fehler
  3709.             } }
  3710.           elif (string_gleich(opname,Symbol_name(S(not))))
  3711.             { # expr = (NOT ...) soll die Gestalt (NOT obj) haben:
  3712.               var reg1 object opargs = Cdr(expr);
  3713.               if (consp(opargs) && nullp(Cdr(opargs)))
  3714.                 { return ~interpret_feature(Car(opargs)); }
  3715.               # expr hat keine korrekte Gestalt -> Fehler
  3716.             }
  3717.           # falscher (car expr) -> Fehler
  3718.         }
  3719.       bad: # Falscher Aufbau eines Feature-Ausdrucks
  3720.         pushSTACK(STACK_1); # Wert für Slot STREAM von STREAM-ERROR
  3721.         pushSTACK(expr); # Feature-Ausdruck
  3722.         pushSTACK(STACK_(1+2)); # Stream
  3723.         pushSTACK(S(read));
  3724.         //: DEUTSCH "~ von ~: Als Feature ist ~ nicht erlaubt."
  3725.         //: ENGLISH "~ from ~: illegal feature ~"
  3726.         //: FRANCAIS "~ de ~ : Feature ~ n'est pas permis."
  3727.         fehler(stream_error, GETTEXT("~ from ~: illegal feature ~"));
  3728.       ja: return 0; # expr ist erfüllt
  3729.       nein: return ~0; # expr ist nicht erfüllt
  3730.     }
  3731.  
  3732. # UP für #+ und #-
  3733. # feature(sollwert)
  3734. # > sollwert: gewünschter Wahrheitswert des Feature-Ausdrucks
  3735. # > Stackaufbau: Stream, sub-char, n.
  3736. # > subr_self: Aufrufer (ein SUBR)
  3737. # < STACK: um 3 erhöht
  3738. # < mv_space/mv_count: Werte
  3739. # kann GC auslösen
  3740.   local Values feature (uintWL sollwert);
  3741.   local Values feature(sollwert)
  3742.     var reg3 uintWL sollwert;
  3743.     { var reg2 object* stream_ = test_no_infix(); # n muß NIL sein
  3744.       dynamic_bind(S(read_suppress),NIL); # *READ-SUPPRESS* an NIL binden
  3745.      {var reg1 object expr = read_recursive_no_dot(stream_); # Feature-Ausdruck lesen
  3746.       dynamic_unbind();
  3747.       # Feature-Ausdruck interpretieren:
  3748.       expr = make_references(expr); # zuvor Verweise entflechten
  3749.       if (interpret_feature(expr) == sollwert)
  3750.         # Wahrheitswert "wahr"
  3751.         { # nächstes Objekt lesen und als Wert:
  3752.           value1 = read_recursive_no_dot(stream_); mv_count=1;
  3753.         }
  3754.         else
  3755.         # Wahrheitswert "falsch"
  3756.         { # *READ-SUPPRESS* an T binden, Objekt lesen, Kommentar
  3757.           dynamic_bind(S(read_suppress),T);
  3758.           read_recursive_no_dot(stream_);
  3759.           dynamic_unbind();
  3760.           value1 = NIL; mv_count=0; # keine Werte
  3761.         }
  3762.       skipSTACK(2);
  3763.     }}
  3764.  
  3765. # (set-dispatch-macro-character #\# #\+
  3766. #   #'(lambda (stream sub-char n)
  3767. #       (declare (ignore sub-char))
  3768. #       (if n
  3769. #         (error "~ von ~: Zwischen # und + darf keine Zahl kommen" 'read stream)
  3770. #         (let ((feature (let ((*read-suppress* nil)) (read stream t nil t))))
  3771. #           (if (interpret-feature feature)
  3772. #             (read stream t nil t)
  3773. #             (let ((*read-suppress* t))
  3774. #               (read stream t nil t)
  3775. #               (values)
  3776. # )   ) ) ) ) )
  3777. LISPFUNN(feature_reader,3) # liest #+
  3778.   { return_Values feature(0); }
  3779.  
  3780. # (set-dispatch-macro-character #\# #\-
  3781. #   #'(lambda (stream sub-char n)
  3782. #       (declare (ignore sub-char))
  3783. #       (if n
  3784. #         (error "~ von ~: Zwischen # und - darf keine Zahl kommen" 'read stream)
  3785. #         (let ((feature (let ((*read-suppress* nil)) (read stream t nil t))))
  3786. #           (if (interpret-feature feature)
  3787. #             (let ((*read-suppress* t))
  3788. #               (read stream t nil t)
  3789. #               (values)
  3790. #             )
  3791. #             (read stream t nil t)
  3792. # )   ) ) ) )
  3793. LISPFUNN(not_feature_reader,3) # liest #-
  3794.   { return_Values feature(~0); }
  3795.  
  3796. # (set-dispatch-macro-character #\# #\S
  3797. #   #'(lambda (stream char n)
  3798. #       (declare (ignore char))
  3799. #       (if *read-suppress*
  3800. #         (progn (read stream t nil t) nil)
  3801. #         (if n
  3802. #           (error "~: Zwischen # und S ist keine Zahl erlaubt." 'read)
  3803. #           (let ((args (let ((*backquote-level* nil)) (read stream t nil t))))
  3804. #             (if (consp args)
  3805. #               (let ((name (first args)))
  3806. #                 (if (symbolp name)
  3807. #                   (let ((desc (get name 'DEFSTRUCT-DESCRIPTION)))
  3808. #                     (if desc
  3809. #                       (if (svref desc 2)
  3810. #                         (values
  3811. #                           (apply (svref desc 2) ; der Konstruktor
  3812. #                                  (structure-arglist-expand name (cdr args))
  3813. #                         ) )
  3814. #                         (error "~: Structures des Typs ~ können nicht eingelesen werden (Konstruktorfunktion unbekannt)"
  3815. #                                'read name
  3816. #                       ) )
  3817. #                       (error "~: Es ist noch keine Structure des Typs ~ definiert worden"
  3818. #                              'read name
  3819. #                   ) ) )
  3820. #                   (error "~: Der Typ einer Structure muß ein Symbol sein, nicht ~"
  3821. #                          'read name
  3822. #               ) ) )
  3823. #               (error "~: Nach #S muß, in Klammern, der Typ und der Inhalt der Structure kommen, nicht ~"
  3824. #                      'read args
  3825. # )   ) ) ) ) ) )
  3826. # (defun structure-arglist-expand (name args)
  3827. #   (cond ((null args) nil)
  3828. #         ((atom args) (error "~: Eine Structure ~ darf keine Komponente . enthalten" 'read name))
  3829. #         ((not (symbolp (car args)))
  3830. #          (error "~: ~ ist kein Symbol und daher kein Slot der Structure ~" 'read (car args) name)
  3831. #         )
  3832. #         ((null (cdr args)) (error "~: Wert der Komponente ~ in der Structure ~ fehlt" 'read (car args) name))
  3833. #         ((atom (cdr args)) (error "~: Eine Structure ~ darf keine Komponente . enthalten" 'read name))
  3834. #         (t (let ((kw (intern (symbol-name (car args)) (find-package "KEYWORD"))))
  3835. #              (list* kw (cadr args) (structure-arglist-expand name (cddr args)))
  3836. # ) )     )  )
  3837. LISPFUNN(structure_reader,3) # liest #S
  3838.   { var reg2 object* stream_ = test_no_infix(); # n muß NIL sein
  3839.     # bei *READ-SUPPRESS* /= NIL nur ein Objekt lesen:
  3840.     if (test_value(S(read_suppress)))
  3841.       { read_recursive_no_dot(stream_); # Objekt lesen und wegwerfen,
  3842.         value1 = NIL; mv_count=1; skipSTACK(2); return; # NIL als Wert
  3843.       }
  3844.     # SYS::*BACKQUOTE-LEVEL* an NIL binden und Objekt lesen:
  3845.     dynamic_bind(S(backquote_level),NIL);
  3846.    {var reg1 object args = read_recursive_no_dot(stream_);
  3847.     dynamic_unbind();
  3848.     # gelesene Liste überprüfen:
  3849.     if (atomp(args))
  3850.       { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3851.         pushSTACK(args); # Argumente
  3852.         pushSTACK(*stream_); # Stream
  3853.         pushSTACK(S(read));
  3854.         //: DEUTSCH "~ von ~: Nach #S muß, in Klammern, der Typ und der Inhalt der Structure kommen, nicht ~"
  3855.         //: ENGLISH "~ from ~: #S must be followed by the type and the contents of the structure, not ~"
  3856.         //: FRANCAIS "~ de ~ : Après #S on s'attend au type et au contenu de la structure, entre parenthèses, et pas à ~"
  3857.         fehler(stream_error, GETTEXT("~ from ~: #S must be followed by the type and the contents of the structure, not ~"));
  3858.       }
  3859.     {var reg5 object name = Car(args); # Typ der Structure
  3860.      STACK_0 = args = Cdr(args); # Restliste retten
  3861.      # Stackaufbau: Stream, restl.Args.
  3862.      if (!symbolp(name)) # Typ muß ein Symbol sein !
  3863.        { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3864.          pushSTACK(name);
  3865.          pushSTACK(*stream_); # Stream
  3866.          pushSTACK(S(read));
  3867.          //: DEUTSCH "~ von ~: Der Typ einer Structure muß ein Symbol sein, nicht ~"
  3868.          //: ENGLISH "~ from ~: the type of a structure should be a symbol, not ~"
  3869.          //: FRANCAIS "~ de ~ : Le type d'une structure doit être un symbole et non ~"
  3870.          fehler(stream_error, GETTEXT("~ from ~: the type of a structure should be a symbol, not ~"));
  3871.        }
  3872.      pushSTACK(name);
  3873.      # Stackaufbau: Stream, restl.Args, name.
  3874.      if (eq(name,S(hash_table))) # Symbol HASH-TABLE ?
  3875.        # ja -> speziell behandeln, keine Structure:
  3876.        { # Hash-Tabelle
  3877.          # Restliche Argumentliste muß ein Cons sein:
  3878.          if (!consp(args))
  3879.            { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3880.              pushSTACK(name);
  3881.              pushSTACK(*stream_); # Stream
  3882.              pushSTACK(S(read));
  3883.              //: DEUTSCH "~ von ~: Fehlerhafte ~."
  3884.              //: ENGLISH "~ from ~: bad ~"
  3885.              //: FRANCAIS "~ de ~ : ~ inadmissible."
  3886.              fehler(stream_error, GETTEXT("~ from ~: bad ~"));
  3887.            }
  3888.          # (MAKE-HASH-TABLE :TEST (car args) :INITIAL-CONTENTS (cdr args))
  3889.          pushSTACK(S(Ktest)); # :TEST
  3890.          pushSTACK(Car(args)); # Test (Symbol)
  3891.          pushSTACK(S(Kinitial_contents)); # :INITIAL-CONTENTS
  3892.          pushSTACK(Cdr(args)); # Aliste ((Key_1 . Value_1) ... (Key_n . Value_n))
  3893.          funcall(L(make_hash_table),4); # Hash-Tabelle bauen
  3894.          mv_count=1; # value1 als Wert
  3895.          skipSTACK(3); return;
  3896.        }
  3897.      if (eq(name,S(random_state))) # Symbol RANDOM-STATE ?
  3898.        # ja -> speziell behandeln, keine Structure:
  3899.        { # Random-State
  3900.          # Restliche Argumentliste muß ein Cons mit NIL als CDR und
  3901.          # einem Simple-Bit-Vektor der Länge 64 als CAR sein:
  3902.          if (!(consp(args)
  3903.                && nullp(Cdr(args))
  3904.                && m_simple_bit_vector_p(Car(args))
  3905.                && (TheSbvector(Car(args))->length == 64)
  3906.             ) )
  3907.            { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3908.              pushSTACK(name);
  3909.              pushSTACK(*stream_); # Stream
  3910.              pushSTACK(S(read));
  3911.              //: DEUTSCH "~ von ~: Fehlerhafter ~."
  3912.              //: ENGLISH "~ from ~: bad ~"
  3913.              //: FRANCAIS "~ de ~ : ~ inadmissible."
  3914.              fehler(stream_error, GETTEXT("~ from ~: bad ~"));
  3915.            }
  3916.          STACK_0 = Car(args); # Simple-Bit-Vektor retten
  3917.         {var reg3 object ergebnis = allocate_random_state(); # neuer Random-State
  3918.          The_Random_state(ergebnis)->random_state_seed = popSTACK(); # füllen
  3919.          value1 = ergebnis; mv_count=1; skipSTACK(2); return;
  3920.        }}
  3921.      if (eq(name,S(pathname))) # Symbol PATHNAME ?
  3922.        # ja -> speziell behandeln, keine Structure:
  3923.        { STACK_1 = make_references(args); pushSTACK(L(make_pathname)); }
  3924.      #ifdef LOGICAL_PATHNAMES
  3925.      elif (eq(name,S(logical_pathname))) # Symbol LOGICAL-PATHNAME ?
  3926.        # ja -> speziell behandeln, keine Structure:
  3927.        { STACK_1 = make_references(args); pushSTACK(L(make_logical_pathname)); }
  3928.      #endif
  3929.      elif (eq(name,S(byte))) # Symbol BYTE ?
  3930.        # ja -> speziell behandeln, keine Structure:
  3931.        { pushSTACK(S(make_byte)); }
  3932.      else
  3933.        # (GET name 'SYS::DEFSTRUCT-DESCRIPTION) ausführen:
  3934.        {var reg4 object description = get(name,S(defstruct_description));
  3935.         if (eq(description,unbound)) # nichts gefunden?
  3936.           # Structure dieses Typs undefiniert
  3937.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3938.             pushSTACK(name);
  3939.             pushSTACK(*stream_); # Stream
  3940.             pushSTACK(S(read));
  3941.             //: DEUTSCH "~ von ~: Es ist noch keine Structure des Typs ~ definiert worden."
  3942.             //: ENGLISH "~ from ~: no structure of type ~ has been defined"
  3943.             //: FRANCAIS "~ de ~ : Aucune structure de type ~ n'est définie."
  3944.             fehler(stream_error, GETTEXT("~ from ~: no structure of type ~ has been defined"));
  3945.           }
  3946.         # description muß ein Simple-Vector der Länge >=4 sein:
  3947.         if (!(simple_vector_p(description) && (TheSvector(description)->length >= 4)))
  3948.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3949.             pushSTACK(name);
  3950.             pushSTACK(S(defstruct_description));
  3951.             pushSTACK(*stream_); # Stream
  3952.             pushSTACK(S(read));
  3953.             //: DEUTSCH "~ von ~: Schlecht aufgebaute ~ zu ~"
  3954.             //: ENGLISH "~ from ~: bad ~ for ~"
  3955.             //: FRANCAIS "~ de ~ : Mauvaise ~ appartenante à ~"
  3956.             fehler(stream_error, GETTEXT("~ from ~: bad ~ for ~"));
  3957.           }
  3958.         # Konstruktorfunktion holen:
  3959.         {var reg6 object constructor = # (svref description 2)
  3960.            TheSvector(description)->data[2];
  3961.          if (nullp(constructor))
  3962.            { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3963.              pushSTACK(name);
  3964.              pushSTACK(*stream_); # Stream
  3965.              pushSTACK(S(read));
  3966.              //: DEUTSCH "~ von ~: Structures des Typs ~ können nicht eingelesen werden (Konstruktorfunktion unbekannt)"
  3967.              //: ENGLISH "~ from ~: structures of type ~ cannot be read in, missing constructor function"
  3968.              //: FRANCAIS "~ de ~ : Des structures de type ~ ne peuvent être entrées car la fonction constructeur est inconnue."
  3969.              fehler(stream_error, GETTEXT("~ from ~: structures of type ~ cannot be read in, missing constructor function"));
  3970.            }
  3971.     # Konstruktorfunktion mit angepaßter Argumentliste aufrufen:
  3972.          pushSTACK(constructor);
  3973.     }  }}# Stackaufbau: Stream, restl.Args, name, Konstruktor.
  3974.     {var reg5 uintC argcount = 0; # Zahl der Argumente für den Konstruktor
  3975.      loop # restliche Argumentliste durchlaufen,
  3976.           # Argumente für den Konstruktor auf den STACK legen:
  3977.        { check_STACK();
  3978.          args = *(stream_ STACKop -1); # restliche Args
  3979.          if (nullp(args)) break; # keine mehr -> Argumente im STACK fertig
  3980.          if (atomp(args))
  3981.            { dotted:
  3982.              pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3983.              pushSTACK(*(stream_ STACKop -2)); # name
  3984.              pushSTACK(*stream_); # Stream
  3985.              pushSTACK(S(read));
  3986.              //: DEUTSCH "~ von ~: Eine Structure ~ darf keine Komponente \".\" enthalten."
  3987.              //: ENGLISH "~ from ~: a structure ~ may not contain a component \".\""
  3988.              //: FRANCAIS "~ de ~ : Une structure ~ ne doit pas contenir un composant \".\""
  3989.              fehler(stream_error, GETTEXT("~ from ~: a structure ~ may not contain a component \".\""));
  3990.            }
  3991.          {var reg4 object slot = Car(args);
  3992.           if (!symbolp(slot))
  3993.             { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  3994.               pushSTACK(*(stream_ STACKop -2)); # name
  3995.               pushSTACK(slot);
  3996.               pushSTACK(*stream_); # Stream
  3997.               pushSTACK(S(read));
  3998.               //: DEUTSCH "~ von ~: ~ ist kein Symbol und daher kein Slot der Structure ~."
  3999.               //: ENGLISH "~ from ~: ~ is not a symbol, not a slot name of structure ~"
  4000.               //: FRANCAIS "~ de ~ : ~ n'est pas un symbole, donc pas le nom d'un composant de la structure ~."
  4001.               fehler(stream_error, GETTEXT("~ from ~: ~ is not a symbol, not a slot name of structure ~"));
  4002.             }
  4003.           if (nullp(Cdr(args)))
  4004.             { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  4005.               pushSTACK(*(stream_ STACKop -2)); # name
  4006.               pushSTACK(slot);
  4007.               pushSTACK(*stream_); # Stream
  4008.               pushSTACK(S(read));
  4009.               //: DEUTSCH "~ von ~: Wert der Komponente ~ in der Structure ~ fehlt."
  4010.               //: ENGLISH "~ from ~: missing value of slot ~ in structure ~"
  4011.               //: FRANCAIS "~ de ~ : La valeur du composant ~ dans la structure ~ manque."
  4012.               fehler(stream_error, GETTEXT("~ from ~: missing value of slot ~ in structure ~"));
  4013.             }
  4014.           if (matomp(Cdr(args))) goto dotted;
  4015.           {var reg3 object kw = intern_keyword(Symbol_name(slot)); # Slotname als Keyword
  4016.            pushSTACK(kw); # Keyword in den STACK
  4017.           }
  4018.           args = *(stream_ STACKop -1); # wieder dieselben restlichen Args
  4019.           args = Cdr(args);
  4020.           pushSTACK(Car(args)); # Slot-value in den STACK
  4021.           *(stream_ STACKop -1) = Cdr(args); # Argliste verkürzen
  4022.          }
  4023.          argcount += 2; # und mitzählen
  4024.          if (argcount == 0)
  4025.            # Argumentezähler zu groß geworden
  4026.            { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  4027.              pushSTACK(*(stream_ STACKop -2)); # name
  4028.              pushSTACK(*stream_); # Stream
  4029.              pushSTACK(S(read));
  4030.              //: DEUTSCH "~ von ~: Zu viele Komponenten für Structure ~."
  4031.              //: ENGLISH "~ from ~: too many slots for structure ~"
  4032.              //: FRANCAIS "~ de ~ : Trop de composants pour une structure ~."
  4033.              fehler(stream_error, GETTEXT("~ from ~: too many slots for structure ~"));
  4034.            }
  4035.        }
  4036.      funcall(*(stream_ STACKop -3),argcount); # Konstruktor aufrufen
  4037.      mv_count=1; skipSTACK(4); return; # value1 als Wert
  4038.     }
  4039.   }}
  4040.  
  4041. # (set-dispatch-macro-character #\# #\Y
  4042. #   #'(lambda (stream sub-char arg)
  4043. #       (declare (ignore sub-char))
  4044. #       (if arg
  4045. #         ; Codevector lesen
  4046. #         (let ((obj (let ((*read-base* 16.)) (read stream t nil t))))
  4047. #           (unless *read-suppress*
  4048. #             (unless (= (length obj) arg)
  4049. #               (error "Falsche Länge eines Closure-Vektors: ~S" arg)
  4050. #             )
  4051. #             (make-code-vector obj) ; Simple-Bit-Vektor, Inhalt: arg Bytes
  4052. #         ) )
  4053. #         ; Closure lesen
  4054. #         (let ((obj (read stream t nil t)))
  4055. #           (unless *read-suppress*
  4056. #             (%make-closure (first obj) (second obj) (cddr obj))
  4057. # )   ) ) ) )
  4058.   # Fehlermeldung wegen falscher Syntax eines Code-Vektors
  4059.   # fehler_closure_badchar();
  4060.   # > Stackaufbau: stream, sub-char, arg.
  4061.     nonreturning_function(local, fehler_closure_badchar, (void));
  4062.     local void fehler_closure_badchar()
  4063.       { pushSTACK(STACK_2); # Wert für Slot STREAM von STREAM-ERROR
  4064.         pushSTACK(STACK_(0+1)); # n
  4065.         pushSTACK(STACK_(2+2)); # Stream
  4066.         pushSTACK(S(read));
  4067.         //: DEUTSCH "~ von ~: Falsche Syntax nach #~Y für Codevektor einer Closure"
  4068.         //: ENGLISH "~ from ~: illegal syntax of closure code vector after #~Y"
  4069.         //: FRANCAIS "~ de ~ : Mauvaise syntaxe de vecteur pour le code d'une «closure» après #~Y"
  4070.         fehler(stream_error, GETTEXT("~ from ~: illegal syntax of closure code vector after #~Y"));
  4071.       }
  4072.   # UP: Überprüft, ob String-Char ch mit Syntaxcode scode eine
  4073.   # Hexadezimal-Ziffer ist, und liefert ihren Wert.
  4074.   # hexziffer(ch,scode)
  4075.   # > ch, scode: String-Char (oder eof_value) und sein Syntaxcode
  4076.   # > Stackaufbau: stream, sub-char, arg.
  4077.   # < ergebnis: Wert (>=0, <16) der Hexziffer
  4078.     local uintB hexziffer (object ch, uintWL scode);
  4079.     local uintB hexziffer(ch,scode)
  4080.       var reg2 object ch;
  4081.       var reg3 uintWL scode;
  4082.       { if (scode == syntax_eof) { fehler_eof_innen(&STACK_2); }
  4083.         # ch ist ein String-Char
  4084.        {var reg1 uintB c = char_code(ch);
  4085.         if (c<'0') goto badchar; if (c<='9') { return (c-'0'); } # '0'..'9'
  4086.         if (c<'A') goto badchar; if (c<='F') { return (c-'A'+10); } # 'A'..'F'
  4087.         if (c<'a') goto badchar; if (c<='f') { return (c-'a'+10); } # 'a'..'f'
  4088.         badchar: fehler_closure_badchar();
  4089.       }}
  4090. LISPFUNN(closure_reader,3) # liest #Y
  4091.   { var reg3 object* stream_ = test_stream_arg(STACK_2);
  4092.     # bei *READ-SUPPRESS* /= NIL nur ein Objekt lesen:
  4093.     if (test_value(S(read_suppress)))
  4094.       { read_recursive_no_dot(stream_); # Objekt lesen, wegwerfen
  4095.         value1 = NIL; mv_count=1; skipSTACK(3); return; # NIL als Wert
  4096.       }
  4097.     # je nach n :
  4098.     if (nullp(STACK_0))
  4099.       # n=NIL -> Closure lesen:
  4100.       { var reg1 object obj = read_recursive_no_dot(stream_); # Objekt lesen
  4101.         if (!(consp(obj) && mconsp(Cdr(obj)))) # Länge >=2 ?
  4102.           { pushSTACK(*stream_); # Wert für Slot STREAM von STREAM-ERROR
  4103.             pushSTACK(obj);
  4104.             pushSTACK(*stream_); # Stream
  4105.             pushSTACK(S(read));
  4106.             //: DEUTSCH "~ von ~: Objekt #Y~ hat nicht die Syntax einer compilierten Closure."
  4107.             //: ENGLISH "~ from ~: object #Y~ has not the syntax of a compiled closure"
  4108.             //: FRANCAIS "~ de ~ : L'objet #Y~ n'a pas la syntaxe d'une «closure» compilée."
  4109.             fehler(stream_error, GETTEXT("~ from ~: object #Y~ has not the syntax of a compiled closure"));
  4110.           }
  4111.         skipSTACK(3);
  4112.         # (SYS::%MAKE-CLOSURE (first obj) (second obj) (cddr obj)) ausführen:
  4113.         pushSTACK(Car(obj)); obj = Cdr(obj); # 1. Argument
  4114.         pushSTACK(Car(obj)); obj = Cdr(obj); # 2. Argument
  4115.         pushSTACK(obj); # 3. Argument
  4116.         funcall(L(make_closure),3);
  4117.         mv_count=1; # value1 als Wert
  4118.       }
  4119.       else
  4120.       # n angegeben -> Codevektor lesen:
  4121.       # Syntax: #nY(b1 ... bn), wo n ein Fixnum >=0 und b1,...,bn
  4122.       # Fixnums >=0, <256 in Basis 16 sind (jeweils ein- oder zweistellig).
  4123.       # Beispielsweise #9Y(0 4 F CD 6B8FD1e4 5)
  4124.       { # n ist ein Integer >=0.
  4125.         var reg6 uintL n =
  4126.           (mposfixnump(STACK_0) ? posfixnum_to_L(STACK_0) # Fixnum -> Wert
  4127.                                 : bitm(oint_data_len)-1 # Bignum -> großer Wert
  4128.           );
  4129.         # neuen Bit-Vektor mit n Bytes besorgen:
  4130.         STACK_1 = allocate_bit_vector(8*n);
  4131.         # Stackaufbau: Stream, Codevektor, n.
  4132.        {var reg2 object ch;
  4133.         var reg1 uintWL scode;
  4134.         # Whitespace überlesen:
  4135.         do { read_char_syntax(ch = ,scode = ,stream_); } # Zeichen lesen
  4136.            until (!(scode == syntax_whitespace));
  4137.         # Es muß ein '(' folgen:
  4138.         if (!eq(ch,code_char('('))) { fehler_closure_badchar(); }
  4139.         {var reg5 uintL index = 0;
  4140.          until (index==n)
  4141.            { # Whitespace überlesen:
  4142.              do { read_char_syntax(ch = ,scode = ,stream_); } # Zeichen lesen
  4143.                 until (!(scode == syntax_whitespace));
  4144.             {# es muß eine Hex-Ziffer folgen:
  4145.              var reg4 uintB zif = hexziffer(ch,scode);
  4146.              # nächstes Character lesen:
  4147.              read_char_syntax(ch = ,scode = ,stream_);
  4148.              if (scode == syntax_eof) { fehler_eof_innen(stream_); } # EOF -> Error
  4149.              if ((scode == syntax_whitespace) || eq(ch,code_char(')')))
  4150.                # Whitespace oder Klammer zu
  4151.                { # wird auf den Stream zurückgeschoben:
  4152.                  unread_char(stream_,ch);
  4153.                }
  4154.                else
  4155.                { # es muß eine zweite Hex-Ziffer sein
  4156.                  zif = 16*zif + hexziffer(ch,scode); # zur ersten Hex-Ziffer dazu
  4157.                  # (Nach der zweiten Hex-Ziffer wird kein Whitespace verlangt.)
  4158.                }
  4159.              # zif = gelesenes Byte. In den Codevektor eintragen:
  4160.              TheSbvector(STACK_1)->data[index] = zif;
  4161.              index++;
  4162.            }}
  4163.         }
  4164.         # Whitespace überlesen:
  4165.         do { read_char_syntax(ch = ,scode = ,stream_); } # Zeichen lesen
  4166.            until (!(scode == syntax_whitespace));
  4167.         # Es muß ein ')' folgen:
  4168.         if (!eq(ch,code_char(')'))) { fehler_closure_badchar(); }
  4169.         # Codevektor als Wert:
  4170.         value1 = STACK_1; mv_count=1; skipSTACK(3);
  4171.       }}
  4172.   }
  4173.  
  4174. # (set-dispatch-macro-character #\# #\"
  4175. #   #'(lambda (stream sub-char n)
  4176. #       (unless *read-suppress*
  4177. #         (if n
  4178. #           (error "~ von ~: Zwischen # und " ist keine Zahl erlaubt."
  4179. #                  'read stream
  4180. #       ) ) )
  4181. #       (unread-char sub-char stream)
  4182. #       (let ((obj (read stream t nil t))) ; String lesen
  4183. #         (unless *read-suppress* (pathname obj))
  4184. # )   ) )
  4185. LISPFUNN(pathname_reader,3) # liest #"
  4186.   { test_no_infix(); # n muß NIL sein
  4187.     # Stackaufbau: Stream, sub-char #\".
  4188.    {var reg1 object string = # String lesen, der mit " anfängt
  4189.       (funcall(L(string_reader),2),value1);
  4190.     # bei *READ-SUPPRESS* /= NIL sofort fertig:
  4191.     if (test_value(S(read_suppress)))
  4192.       { value1 = NIL; mv_count=1; return; } # NIL als Wert
  4193.     # Bilde (pathname string) = (values (parse-namestring string)) :
  4194.     { var reg2 object *string_;
  4195.       pushSTACK(string);
  4196.       string_ = &STACK_0;
  4197.       dynamic_bind(S(read_pathname_p),T);
  4198.       pushSTACK(*string_);
  4199.       funcall(L(parse_namestring),1); # (PARSE-NAMESTRING-FOR-READER string)
  4200.       dynamic_unbind();
  4201.       skipSTACK(1);
  4202.     }
  4203.     mv_count=1; # nur 1 Wert
  4204.   }}
  4205.  
  4206. # ------------------------ LISP-Funktionen des Readers ------------------------
  4207.  
  4208. # UP: Überprüft ein Input-Stream-Argument.
  4209. # Default ist der Wert von *STANDARD-INPUT*.
  4210. # test_istream(&stream);
  4211. # > subr_self: Aufrufer (ein SUBR)
  4212. # > stream: Input-Stream-Argument
  4213. # < stream: Input-Stream (ein Stream)
  4214.   local void test_istream (object* stream_);
  4215.   local void test_istream(stream_)
  4216.     var reg2 object* stream_;
  4217.     { var reg1 object stream = *stream_;
  4218.       if (eq(stream,unbound) || nullp(stream))
  4219.         # statt #<UNBOUND> oder NIL: Wert von *STANDARD-INPUT*
  4220.         { *stream_ = var_stream(S(standard_input),strmflags_rd_ch_B); }
  4221.       elif (eq(stream,T))
  4222.         # statt T: Wert von *TERMINAL-IO*
  4223.         { *stream_ = var_stream(S(terminal_io),strmflags_rd_ch_B); }
  4224.       else
  4225.         { if (!streamp(stream)) { fehler_stream(stream); } }
  4226.     }
  4227.  
  4228. # EOF-Handling, beendet Reader-Funktionen.
  4229. # eof_handling()
  4230. # > STACK_3: Input-Stream
  4231. # > STACK_2: eof-error-p
  4232. # > STACK_1: eof-value
  4233. # > STACK_0: recursive-p
  4234. # < mv_space/mv_count: Werte
  4235.   local Values eof_handling (void);
  4236.   local Values eof_handling()
  4237.     { if (!nullp(STACK_2)) # eof-error-p /= NIL (z.B. = #<UNBOUND>) ?
  4238.         # Error melden:
  4239.         { var reg1 object recursive_p = STACK_0;
  4240.           if (eq(recursive_p,unbound) || nullp(recursive_p))
  4241.             { fehler_eof_aussen(&STACK_3); } # EOF melden
  4242.             else
  4243.             { fehler_eof_innen(&STACK_3); } # EOF innerhalb Objekt melden
  4244.         }
  4245.         else
  4246.         # EOF verarzten:
  4247.         { var reg1 object eofval = STACK_1;
  4248.           if (eq(eofval,unbound)) { eofval = eof_value; } # Default ist #<EOF>
  4249.           value1 = eofval; mv_count=1; skipSTACK(4); # eofval als Wert
  4250.         }
  4251.     }
  4252.  
  4253. # UP für READ und READ-PRESERVING-WHITESPACE
  4254. # read_w(whitespace-p)
  4255. # > whitespace-p: gibt an, ob danach whitespace zu verbrauchen ist
  4256. # > Stackaufbau: input-stream, eof-error-p, eof-value, recursive-p.
  4257. # > subr_self: Aufrufer (ein SUBR) (unnötig, falls input-stream ein Stream ist)
  4258. # < STACK: aufgeräumt
  4259. # < mv_space/mv_count: Werte
  4260.   local Values read_w (object whitespace_p);
  4261.   local Values read_w(whitespace_p)
  4262.     var reg3 object whitespace_p;
  4263.     { # input-stream überprüfen:
  4264.       test_istream(&STACK_3);
  4265.       # recursive-p-Argument abfragen:
  4266.      {var reg2 object recursive_p = STACK_0;
  4267.       if (eq(recursive_p,unbound) || nullp(recursive_p))
  4268.         # nicht-rekursiver Aufruf
  4269.         { var reg1 object obj = read_top(&STACK_3,whitespace_p);
  4270.           if (eq(obj,dot_value)) { fehler_dot(STACK_3); } # Dot -> Error
  4271.           if (eq(obj,eof_value))
  4272.             { return_Values eof_handling(); } # EOF-Behandlung
  4273.             else
  4274.             { value1 = obj; mv_count=1; skipSTACK(4); } # obj als Wert
  4275.         }
  4276.         else
  4277.         # rekursiver Aufruf
  4278.         { value1 = read_recursive_no_dot(&STACK_3); mv_count=1; skipSTACK(4); }
  4279.     }}
  4280.  
  4281. LISPFUN(read,0,4,norest,nokey,0,NIL)
  4282. # (READ [input-stream [eof-error-p [eof-value [recursive-p]]]]), CLTL S. 375
  4283.   { return_Values read_w(NIL); } # whitespace-p := NIL
  4284.  
  4285. LISPFUN(read_preserving_whitespace,0,4,norest,nokey,0,NIL)
  4286. # (READ-PRESERVING-WHITESPACE [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4287. # CLTL S. 376
  4288.   { return_Values read_w(T); } # whitespace-p := T
  4289.  
  4290. LISPFUN(read_delimited_list,1,2,norest,nokey,0,NIL)
  4291. # (READ-DELIMITED-LIST char [input-stream [recursive-p]]), CLTL S. 377
  4292.   { # char überprüfen:
  4293.     var reg3 object ch = STACK_2;
  4294.     if (!string_char_p(ch)) { fehler_string_char(ch); }
  4295.     # input-stream überprüfen:
  4296.     test_istream(&STACK_1);
  4297.     # recursive-p-Argument abfragen:
  4298.    {var reg2 object recursive_p = popSTACK();
  4299.     # Stackaufbau: char, input-stream.
  4300.     if (eq(recursive_p,unbound) || nullp(recursive_p))
  4301.       # nicht-rekursiver Aufruf
  4302.       { var reg4 object* stream_ = &STACK_0;
  4303.         var reg5 object* ch_ptr;
  4304.         pushSTACK(ch); ch_ptr=&STACK_0;
  4305.         # SYS::*READ-REFERENCE-TABLE* an die leere Tabelle NIL binden:
  4306.         dynamic_bind(S(read_reference_table),NIL);
  4307.         # SYS::*BACKQUOTE-LEVEL* an NIL binden:
  4308.         dynamic_bind(S(backquote_level),NIL);
  4309.        {var reg1 object obj = read_delimited_list(stream_,*ch_ptr,eof_value); # Liste lesen
  4310.         obj = make_references(obj); # Verweise entflechten
  4311.         dynamic_unbind();
  4312.         dynamic_unbind();
  4313.         skipSTACK(1);
  4314.         value1 = obj; # Liste als Wert
  4315.       }}
  4316.       else
  4317.       # rekursiver Aufruf
  4318.       { value1 = read_delimited_list(&STACK_0,ch,eof_value); }
  4319.     # (Beide Male Liste gelesen, keine Dotted List zugelassen.)
  4320.     mv_count=1; skipSTACK(2);
  4321.   }}
  4322.  
  4323. LISPFUN(read_line,0,4,norest,nokey,0,NIL)
  4324. # (READ-LINE [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4325. # CLTL S. 378
  4326.   { # input-stream überprüfen:
  4327.     var reg2 object* stream_ = &STACK_3;
  4328.     test_istream(stream_);
  4329.     get_buffers(); # zwei leere Buffer auf den Stack
  4330.     loop
  4331.       { var reg1 object ch = read_char(stream_); # nächstes Zeichen lesen
  4332.         if (eq(ch,eof_value)) goto eof; # EOF ?
  4333.         # sonst Character. Auf String-Char überprüfen:
  4334.         if (!string_char_p(ch)) { subr_self = L(read_line); fehler_string_char(ch); }
  4335.         if (eq(ch,code_char(NL))) goto eol; # NL -> End of Line
  4336.         # sonstiges Character in den Buffer schreiben:
  4337.         ssstring_push_extend(STACK_0,char_code(ch));
  4338.       }
  4339.     eol: # End of Line
  4340.     { # Buffer kopieren und dabei in Simple-String umwandeln:
  4341.       value1 = copy_string(STACK_0);
  4342.       # Buffer zur Wiederverwendung freigeben:
  4343.       O(token_buff_2) = popSTACK(); O(token_buff_1) = popSTACK();
  4344.       value2 = NIL; mv_count=2; # NIL als 2. Wert
  4345.       skipSTACK(4); return;
  4346.     }
  4347.     eof: # End of File
  4348.     { var reg1 object buff = STACK_0; # Buffer
  4349.       # Buffer zur Wiederverwendung freigeben:
  4350.       O(token_buff_2) = popSTACK(); O(token_buff_1) = popSTACK();
  4351.       # Buffer leer ?
  4352.       if (TheArray(buff)->dims[1] == 0) # Länge (Fill-Pointer) = 0 ?
  4353.         { return_Values eof_handling(); } # ja -> EOF speziell behandeln
  4354.         else
  4355.         { # Buffer kopieren und dabei in Simple-String umwandeln:
  4356.           value1 = copy_string(buff);
  4357.           value2 = T; mv_count=2; # T als 2. Wert
  4358.           skipSTACK(4); return;
  4359.     }   }
  4360.   }
  4361.  
  4362. LISPFUN(read_char,0,4,norest,nokey,0,NIL)
  4363. # (READ-CHAR [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4364. # CLTL S. 379
  4365.   { # input-stream überprüfen:
  4366.     var reg2 object* stream_ = &STACK_3;
  4367.     test_istream(stream_);
  4368.    {var reg1 object ch = read_char(stream_); # Character lesen
  4369.     if (eq(ch,eof_value))
  4370.       { return_Values eof_handling(); }
  4371.       else
  4372.       { value1 = ch; mv_count=1; skipSTACK(4); return; } # ch als Wert
  4373.   }}
  4374.  
  4375. LISPFUN(unread_char,1,1,norest,nokey,0,NIL)
  4376. # (UNREAD-CHAR char [input-stream]), CLTL S. 379
  4377.   { # input-stream überprüfen:
  4378.     var reg2 object* stream_ = &STACK_0;
  4379.     test_istream(stream_);
  4380.    {var reg1 object ch = STACK_1; # char
  4381.     if (!charp(ch)) # muß ein Character sein !
  4382.       { pushSTACK(ch); # Wert für Slot DATUM von TYPE-ERROR
  4383.         pushSTACK(S(character)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  4384.         pushSTACK(ch);
  4385.         pushSTACK(TheSubr(subr_self)->name);
  4386.         //: DEUTSCH "~: ~ ist kein Character."
  4387.         //: ENGLISH "~: ~ is not a character"
  4388.         //: FRANCAIS "~ : ~ n'est pas un caractère."
  4389.         fehler(type_error, GETTEXT("~: ~ is not a character"));
  4390.       }
  4391.     unread_char(stream_,ch); # char auf Stream zurückschieben
  4392.     value1 = NIL; mv_count=1; skipSTACK(2); # NIL als Wert
  4393.   }}
  4394.  
  4395. LISPFUN(peek_char,0,5,norest,nokey,0,NIL)
  4396. # (PEEK-CHAR [peek-type [input-stream [eof-error-p [eof-value [recursive-p]]]]]),
  4397. # CLTL S. 379
  4398.   { # input-stream überprüfen:
  4399.     var reg2 object* stream_ = &STACK_3;
  4400.     test_istream(stream_);
  4401.     # Fallunterscheidung nach peek-type:
  4402.    {var reg3 object peek_type = STACK_4;
  4403.     if (eq(peek_type,unbound) || nullp(peek_type))
  4404.       # Default NIL: 1 Zeichen peeken
  4405.       { var reg1 object ch = peek_char(stream_);
  4406.         if (eq(ch,eof_value)) goto eof;
  4407.         value1 = ch; mv_count=1; skipSTACK(5); return; # ch als Wert
  4408.       }
  4409.     elif (eq(peek_type,T))
  4410.       # T: Whitespace-Peek
  4411.       { var reg1 object ch = wpeek_char_eof(stream_);
  4412.         if (eq(ch,eof_value)) goto eof;
  4413.         value1 = ch; mv_count=1; skipSTACK(5); return; # ch als Wert
  4414.       }
  4415.     elif (charp(peek_type))
  4416.       # peek-type ist ein Character
  4417.       { var reg1 object ch;
  4418.         loop
  4419.           { ch = read_char(stream_); # Zeichen lesen
  4420.             if (eq(ch,eof_value)) goto eof;
  4421.             if (eq(ch,peek_type)) break; # das vorgegebene Ende-Zeichen?
  4422.           }
  4423.         unread_char(stream_,ch); # Zeichen zurückschieben
  4424.         value1 = ch; mv_count=1; skipSTACK(5); return; # ch als Wert
  4425.       }
  4426.     else
  4427.       { pushSTACK(peek_type); # Wert für Slot DATUM von TYPE-ERROR
  4428.         pushSTACK(O(type_peektype)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  4429.         pushSTACK(peek_type);
  4430.         pushSTACK(TheSubr(subr_self)->name);
  4431.         //: DEUTSCH "~: Peek-Type muß NIL oder T oder ein Character sein, nicht ~"
  4432.         //: ENGLISH "~: peek type should be NIL or T or a character, not ~"
  4433.         //: FRANCAIS "~ : Le mode de PEEK doit être NIL ou T ou un caractère et non ~"
  4434.         fehler(type_error, GETTEXT("~: peek type should be NIL or T or a character, not ~"));
  4435.       }
  4436.     eof: # EOF liegt vor
  4437.       eof_handling(); skipSTACK(1); return;
  4438.   }}
  4439.  
  4440. LISPFUN(listen,0,1,norest,nokey,0,NIL)
  4441. # (LISTEN [input-stream]), CLTL S. 380
  4442.   { test_istream(&STACK_0); # input-stream überprüfen
  4443.     if (stream_listen(popSTACK()) == 0) # Zeichen verfügbar?
  4444.       { value1 = T; mv_count=1; } # Wert T
  4445.       else
  4446.       { value1 = NIL; mv_count=1; } # Wert NIL
  4447.   }
  4448.  
  4449. LISPFUN(read_char_no_hang,0,4,norest,nokey,0,NIL)
  4450. # (READ-CHAR-NO-HANG [input-stream [eof-error-p [eof-value [recursive-p]]]]),
  4451. # CLTL S. 380
  4452.   { # input-stream überprüfen:
  4453.     var reg3 object* stream_ = &STACK_3;
  4454.     test_istream(stream_);
  4455.    {var reg2 object stream = *stream_;
  4456.     if (!(TheStream(stream)->strmflags & bit(strmflags_rd_ch_bit_B)))
  4457.       { fehler_illegal_streamop(S(read_char_no_hang),stream); }
  4458.     { var reg1 signean status = stream_listen(stream);
  4459.       if (status < 0) # EOF ?
  4460.         { return_Values eof_handling(); }
  4461.       elif (status == 0) # Zeichen verfügbar
  4462.         { var reg3 object ch = read_char(stream_); # Character lesen
  4463.           if (eq(ch,eof_value)) # sicherheitshalber nochmals auf EOF abfragen
  4464.             { return_Values eof_handling(); }
  4465.             else
  4466.             { value1 = ch; mv_count=1; skipSTACK(4); return; } # ch als Wert
  4467.         }
  4468.       else # (status > 0) # kein Zeichen verfügbar
  4469.         # statt zu warten, sofort NIL als Wert:
  4470.         { value1 = NIL; mv_count=1; skipSTACK(4); return; }
  4471.   }}}
  4472.  
  4473. LISPFUN(clear_input,0,1,norest,nokey,0,NIL)
  4474. # (CLEAR-INPUT [input-stream]), CLTL S. 380
  4475.   { test_istream(&STACK_0); # input-stream überprüfen
  4476.     clear_input(popSTACK());
  4477.     value1 = NIL; mv_count=1; # Wert NIL
  4478.   }
  4479.  
  4480. LISPFUN(read_from_string,1,2,norest,key,3,\
  4481.         (kw(preserve_whitespace),kw(start),kw(end)) )
  4482. # (READ-FROM-STRING string [eof-error-p [eof-value [:preserve-whitespace] [:start] [:end]]]),
  4483. # CLTL S. 380
  4484. # Methode:
  4485. # (defun read-from-string (string &optional (eof-error-p t) (eof-value nil)
  4486. #                          &key (start 0) (end nil) (preserve-whitespace nil)
  4487. #                          &aux index)
  4488. #   (values
  4489. #     (with-input-from-string (stream string :start start :end end :index index)
  4490. #       (funcall (if preserve-whitespace #'read-preserving-whitespace #'read)
  4491. #                stream eof-error-p eof-value nil
  4492. #     ) )
  4493. #     index
  4494. # ) )
  4495. # oder macroexpandiert:
  4496. # (defun read-from-string (string &optional (eof-error-p t) (eof-value nil)
  4497. #                          &key (start 0) (end nil) (preserve-whitespace nil))
  4498. #   (let ((stream (make-string-input-stream string start end)))
  4499. #     (values
  4500. #       (unwind-protect
  4501. #         (funcall (if preserve-whitespace #'read-preserving-whitespace #'read)
  4502. #                  stream eof-error-p eof-value nil
  4503. #         )
  4504. #         (close stream)
  4505. #       )
  4506. #       (system::string-input-stream-index stream)
  4507. # ) ) )
  4508. # oder vereinfacht:
  4509. # (defun read-from-string (string &optional (eof-error-p t) (eof-value nil)
  4510. #                          &key (start 0) (end nil) (preserve-whitespace nil))
  4511. #   (let ((stream (make-string-input-stream string start end)))
  4512. #     (values
  4513. #       (funcall (if preserve-whitespace #'read-preserving-whitespace #'read)
  4514. #                stream eof-error-p eof-value nil
  4515. #       )
  4516. #       (system::string-input-stream-index stream)
  4517. # ) ) )
  4518.   { # Stackaufbau: string, eof-error-p, eof-value, preserve-whitespace, start, end.
  4519.     # :preserve-whitespace-Argument verarbeiten:
  4520.     var reg1 object preserve_whitespace = STACK_2;
  4521.     if (eq(preserve_whitespace,unbound)) { preserve_whitespace = NIL; }
  4522.     # MAKE-STRING-INPUT-STREAM mit Argumenten string, start, end aufrufen:
  4523.     STACK_2 = STACK_5; # string
  4524.     if (eq(STACK_1,unbound)) { STACK_1 = Fixnum_0; } # start hat Default 0
  4525.     if (eq(STACK_0,unbound)) { STACK_0 = NIL; } # end hat Default NIL
  4526.     STACK_5 = preserve_whitespace;
  4527.     funcall(L(make_string_input_stream),3);
  4528.     # Stackaufbau: preserve-whitespace, eof-error-p, eof-value.
  4529.     pushSTACK(STACK_1); pushSTACK(STACK_1);
  4530.     STACK_3 = STACK_2 = value1;
  4531.     # Stackaufbau: preserve-whitespace, stream, stream, eof-error-p, eof-value.
  4532.     pushSTACK(NIL); read_w(STACK_5); # READ bzw. READ-PRESERVE-WHITESPACE
  4533.     # Stackaufbau: preserve-whitespace, stream.
  4534.     STACK_1 = value1; # gelesenes Objekt
  4535.     funcall(L(string_input_stream_index),1); # (SYS::STRING-INPUT-STREAM-INDEX stream)
  4536.     value2 = value1; value1 = popSTACK(); # Index als 2., Objekt als 1. Wert
  4537.     mv_count=2;
  4538.   }
  4539.  
  4540. LISPFUN(parse_integer,1,0,norest,key,4,\
  4541.         (kw(start),kw(end),kw(radix),kw(junk_allowed)) )
  4542. # (PARSE-INTEGER string [:start] [:end] [:radix] [:junk-allowed]), CLTL S. 381
  4543.   { # :junk-allowed-Argument verarbeiten:
  4544.     var reg7 boolean junk_allowed;
  4545.     {var reg1 object arg = popSTACK();
  4546.      if (eq(arg,unbound) || nullp(arg))
  4547.        { junk_allowed = FALSE; }
  4548.        else
  4549.        { junk_allowed = TRUE; }
  4550.     }
  4551.     # junk_allowed = Wert des :junk-allowed-Arguments.
  4552.     # :radix-Argument verarbeiten:
  4553.    {var reg5 uintL base;
  4554.     {var reg1 object arg = popSTACK();
  4555.      if (eq(arg,unbound))
  4556.        { base = 10; } # Default 10
  4557.        else
  4558.        { if (posfixnump(arg) &&
  4559.              (base = posfixnum_to_L(arg), ((base >= 2) && (base <= 36)))
  4560.             )
  4561.            {} # OK
  4562.            else
  4563.            { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  4564.              pushSTACK(O(type_radix)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  4565.              pushSTACK(arg); # base
  4566.              pushSTACK(S(Kradix));
  4567.              pushSTACK(TheSubr(subr_self)->name);
  4568.              //: DEUTSCH "~: ~-Argument muß ein Integer zwischen 2 und 36 sein, nicht ~"
  4569.              //: ENGLISH "~: ~ argument should be an integer between 2 and 36, not ~"
  4570.              //: FRANCAIS "~ : L'argument ~ doit être un entier entre 2 et 36, pas ~"
  4571.              fehler(type_error, GETTEXT("~: ~ argument should be an integer between 2 and 36, not ~"));
  4572.     }  }   }
  4573.     # base = Wert des :radix-Arguments.
  4574.     { # string, :start und :end überprüfen:
  4575.       var object string; # String
  4576.       var uintL start; # Wert des :start-Arguments
  4577.       var uintL len; # Anzahl der angesprochenen Characters
  4578.       var reg2 uintB* charptr = test_string_limits(&string,&start,&len);
  4579.       # STACK jetzt aufgeräumt.
  4580.       # Datenvektor holen:
  4581.       var uintL start_offset = 0;
  4582.       var reg9 object sstring = array_displace_check(string,len,&start_offset);
  4583.       var reg8 uintL end_offset = start_offset; # Offset vom String zum Datenvektor
  4584.       # Schleifenvariablen:
  4585.       var reg4 uintL index = start;
  4586.       var reg3 uintL count = len;
  4587.       # Ab jetzt:
  4588.       #   string : der String,
  4589.       #   sstring : sein Datenvektor (ein Simple-String),
  4590.       #   start : Index des ersten Characters im String,
  4591.       #   charptr : Pointer in den Datenvektor auf das nächste Character,
  4592.       #   index : Index in den String,
  4593.       #   count : verbleibende Anzahl Characters.
  4594.       var reg6 signean sign; # Vorzeichen
  4595.      {var reg1 uintB c; # letztes gelesenes Character
  4596.       # 1. Schritt: Whitespace übergehen
  4597.       loop
  4598.         { if (count==0) goto badsyntax; # Stringstück schon zu Ende ?
  4599.           c = *charptr; # nächstes Character
  4600.           if (!(orig_syntax_table[c] == syntax_whitespace)) # kein Whitespace?
  4601.             break;
  4602.           charptr++; index++; count--; # Whitespacezeichen übergehen
  4603.         }
  4604.       # 2. Schritt: Vorzeichen lesen
  4605.       sign = 0; # Vorzeichen := positiv
  4606.       switch (c)
  4607.         { case '-': sign = -1; # Vorzeichen := negativ
  4608.           case '+': # Vorzeichen angetroffen
  4609.             charptr++; index++; count--; # übergehen
  4610.             if (count==0) goto badsyntax; # Stringstück schon zu Ende ?
  4611.           default: break;
  4612.         }
  4613.      }# Vorzeichen fertig, es kommt noch was (count>0).
  4614.       start_offset = start_offset + index;
  4615.       # Ab jetzt:  start_offset = Offset der ersten Ziffer im Datenvektor.
  4616.       # 3. Schritt: Ziffern lesen
  4617.       loop
  4618.         { var reg1 uintB c = *charptr; # nächstes Character
  4619.           # Test auf Ziffer: (digit-char-p (code-char c) base) ?
  4620.           # (vgl. DIGIT-CHAR-P in CHARSTRG.D)
  4621.           if (c > 'z') break; # zu groß -> nein
  4622.           if (c >= 'a') { c -= 'a'-'A'; } # Character >='a',<='z' in Großbuchstaben wandeln
  4623.           # Nun ist $00 <= c <= $60.
  4624.           if (c < '0') break;
  4625.           # $30 <= c <= $60 in Zahlwert umwandeln:
  4626.           if (c <= '9') { c = c - '0'; }
  4627.           else if (c >= 'A') { c = c - 'A' + 10; }
  4628.           else break;
  4629.           # Nun ist c der Zahlwert der Ziffer, >=0, <=41.
  4630.           if (c >= (uintB)base) break; # nur gültig, falls 0 <= c < base.
  4631.           # *charptr ist eine gültige Ziffer.
  4632.           charptr++; index++; count--; # übergehen
  4633.           if (count==0) break;
  4634.         }
  4635.       # Ziffern fertig.
  4636.       end_offset = end_offset + index;
  4637.       # Ab jetzt:  end_offset = Offset nach der letzten Ziffer im Datenvektor.
  4638.       if (start_offset == end_offset) # gab es keine Ziffern?
  4639.         goto badsyntax;
  4640.       # 4. Schritt: evtl. Whitespace am Schluß übergehen
  4641.       if (!junk_allowed) # (falls junk_allowed, ist nichts zu tun)
  4642.         { while (!(count==0))
  4643.             { var reg1 uintB c = *charptr; # nächstes Character
  4644.               if (!(orig_syntax_table[c] == syntax_whitespace)) # kein Whitespace?
  4645.                 goto badsyntax;
  4646.               charptr++; index++; count--; # Whitespacezeichen übergehen
  4647.             }
  4648.         }
  4649.       # 5. Schritt: Ziffernfolge in Zahl umwandeln
  4650.       value1 = read_integer(base,sign,sstring,start_offset,end_offset);
  4651.       value2 = fixnum(index); # Index als 2. Wert
  4652.       mv_count=2; return;
  4653.       badsyntax: # Illegales Zeichen
  4654.       if (!junk_allowed)
  4655.         # Error melden:
  4656.         { pushSTACK(unbound); # "Wert" für Slot STREAM von STREAM-ERROR
  4657.           pushSTACK(string);
  4658.           pushSTACK(TheSubr(subr_self)->name);
  4659.           //: DEUTSCH "~: String ~ hat nicht die Syntax eines Integers."
  4660.           //: ENGLISH "~: string ~ hasn't integer syntax"
  4661.           //: FRANCAIS "~ : La chaîne ~ n'a pas la syntaxe d'un nombre entier."
  4662.           fehler(stream_error, GETTEXT("~: string ~ hasn't integer syntax"));
  4663.         }
  4664.       value1 = NIL; # NIL als 1. Wert
  4665.       value2 = fixnum(index); # Index als 2. Wert
  4666.       mv_count=2; return;
  4667.   }}}
  4668.  
  4669.  
  4670. # =============================================================================
  4671. #                              P R I N T
  4672. # =============================================================================
  4673.  
  4674. # Grundidee des Printers:
  4675. # Vom Datentyp abhängig, wird die externe Repräsentation des Objekts auf den
  4676. # Stream ausgegeben, rekursiv. Der Unterschied zwischen PRINT und PPRINT
  4677. # besteht darin, daß an einigen Stellen statt einem Space ein Newline und
  4678. # einige Spaces ausgegeben werden. Um dies zu bewerkstelligen, wird die
  4679. # externe Repräsentation der Teil-Objekte auf einen Pretty-Printer-Hilfs-
  4680. # (PPHELP-)Stream ausgegeben, dann überprüft, ob man mehrere Zeilen braucht
  4681. # oder eine ausreicht, und schließlich (davon abhängig) Whitespace eingefügt.
  4682. # Die genauere Spezifikation der prin_object-Routine:
  4683. # > Stream,
  4684. # > Zeilenlänge L,
  4685. # > Linker Rand für Einzeiler L1,
  4686. # > Linker Rand für Mehrzeiler LM,
  4687. # > Anzahl der auf der letzten Zeile am Schluß noch zu schließenden Klammern
  4688. #   K (Fixnum >=0) und Flag, ob bei Mehrzeilern die letzten schließenden
  4689. #   Klammern in einer eigenen Zeile, justiert unterhalb der entsprechenden
  4690. #   öffnenden Klammern, erscheinen sollen.
  4691. #   [Der Einfachheit halber ist hier stets K=0 und Flag=True, d.h. alle
  4692. #   schließenden Klammern von Mehrzeilern erscheinen in einer eigenen Zeile.]
  4693. # < Stream, auf den das Objekt ausgegeben wurde,
  4694. #   entweder als Einzeiler (der Länge <=L-L1-K)
  4695. #   oder als Mehrzeiler (mit Newline und LM Spaces statt Space zwischen
  4696. #   Teilobjekten), jede Zeile (wenn's geht) der Länge <=L, letzte Zeile
  4697. #   (wenn's geht) der Länge <=L-K.
  4698. # < Falls der Stream ein PPHELP-Stream ist, enthält er den Modus und eine
  4699. #   nichtleere Liste der ausgegebenen Zeilen (in umgekehrter Reihenfolge).
  4700.  
  4701. # ---------------------- allgemeine Unterprogramme ----------------------------
  4702.  
  4703. # UP: Gibt ein unsigned Integer mit max. 32 Bit dezimal auf einen Stream aus.
  4704. # pr_uint(&stream,uint);
  4705. # > uint: Unsigned Integer
  4706. # > stream: Stream
  4707. # < stream: Stream
  4708. # kann GC auslösen
  4709.   local void pr_uint (object* stream_, uintL x);
  4710.   local void pr_uint(stream_,x)
  4711.     var reg5 object* stream_;
  4712.     var reg1 uintL x;
  4713.     { var uintB ziffern[10]; # max. 10 Ziffern, da 0 <= x < 2^32 <= 10^10
  4714.       var reg3 uintB* ziffptr = &ziffern[0];
  4715.       var reg4 uintC ziffcount = 0; # Anzahl der Ziffern
  4716.       # Ziffern produzieren:
  4717.       do { var reg2 uintB zif;
  4718.            divu_3216_3216(x,10,x=,zif=); # x := floor(x/10), zif := Rest
  4719.            *ziffptr++ = zif; ziffcount++; # Ziffer abspeichern
  4720.          }
  4721.          until (x==0);
  4722.       # Ziffern in umgekehrter Reihenfolge ausgeben:
  4723.       dotimespC(ziffcount,ziffcount,
  4724.         { write_schar(stream_,'0' + *--ziffptr); }
  4725.         );
  4726.     }
  4727.  
  4728. # UP: Gibt ein Nibble hexadezimal (mit 1 Hex-Ziffer) auf einen Stream aus.
  4729. # pr_hex1(&stream,x);
  4730. # > x: Nibble (>=0,<16)
  4731. # > stream: Stream
  4732. # < stream: Stream
  4733. # kann GC auslösen
  4734.   local void pr_hex1 (object* stream_, uint4 x);
  4735.   local void pr_hex1(stream_,x)
  4736.     var reg2 object* stream_;
  4737.     var reg1 uint4 x;
  4738.     { write_schar(stream_, ( x<10 ? '0'+(uintB)x : 'A'+(uintB)x-10 ) ); }
  4739.  
  4740. # UP: Gibt ein Byte hexadezimal (mit 2 Hex-Ziffern) auf einen Stream aus.
  4741. # pr_hex2(&stream,x);
  4742. # > x: Byte
  4743. # > stream: Stream
  4744. # < stream: Stream
  4745. # kann GC auslösen
  4746.   local void pr_hex2 (object* stream_, uint8 x);
  4747.   local void pr_hex2(stream_,x)
  4748.     var reg2 object* stream_;
  4749.     var reg1 uint8 x;
  4750.     { pr_hex1(stream_,(uint4)(x>>4)); # Bits 7..4 ausgeben
  4751.       pr_hex1(stream_,(uint4)(x & (bit(4)-1))); # Bits 3..0 ausgeben
  4752.     }
  4753.  
  4754. # UP: Gibt eine Adresse mit 24 Bit hexadezimal (mit 6 Hex-Ziffern)
  4755. # auf einen Stream aus.
  4756. # pr_hex6(&stream,obj);
  4757. # > Adressbits von obj: Unsigned Integer
  4758. # > stream: Stream
  4759. # < stream: Stream
  4760. # kann GC auslösen
  4761.   local void pr_hex6 (object* stream_, object obj);
  4762.   local void pr_hex6(stream_,obj)
  4763.     var reg2 object* stream_;
  4764.     var reg3 object obj;
  4765.     { var reg1 oint x = (as_oint(obj) >> oint_addr_shift) << addr_shift;
  4766.       write_schar(stream_,'#'); write_schar(stream_,'x'); # Präfix für "Hexadezimal"
  4767.       #define pr_hexpart(k)  # Bits k+7..k ausgeben:  \
  4768.         if (((oint_addr_mask>>oint_addr_shift)<<addr_shift) & minus_wbit(k)) \
  4769.           { pr_hex2(stream_,(uint8)(x >> k) & (((oint_addr_mask>>oint_addr_shift)<<addr_shift) >> k) & 0xFF); }
  4770.       #ifdef WIDE_HARD
  4771.       pr_hexpart(56);
  4772.       pr_hexpart(48);
  4773.       pr_hexpart(40);
  4774.       pr_hexpart(32);
  4775.       #endif
  4776.       pr_hexpart(24);
  4777.       pr_hexpart(16);
  4778.       pr_hexpart(8);
  4779.       pr_hexpart(0);
  4780.       #undef pr_hexpart
  4781.     }
  4782.  
  4783. #ifdef FOREIGN
  4784. # UP: Gibt eine Adresse mit 32 Bit hexadezimal (mit 8 Hex-Ziffern)
  4785. # auf einen Stream aus.
  4786. # pr_hex8(&stream,x);
  4787. # > x: Adresse
  4788. # > stream: Stream
  4789. # < stream: Stream
  4790. # kann GC auslösen
  4791.   local void pr_hex8 (object* stream_, uintP x);
  4792.   local void pr_hex8(stream_,x)
  4793.     var reg3 object* stream_;
  4794.     var reg1 uintP x;
  4795.     { write_schar(stream_,'#'); write_schar(stream_,'x'); # Präfix für "Hexadezimal"
  4796.      {var reg2 sintC k = (sizeof(uintP)-1)*8;
  4797.       do { pr_hex2(stream_,(uint8)(x >> k)); } while ((k -= 8) >= 0);
  4798.     }}
  4799. #endif
  4800.  
  4801. # *PRINT-READABLY* /= NIL bewirkt u.a. implizit dasselbe wie
  4802. # *PRINT-ESCAPE* = T, *PRINT-BASE* = 10, *PRINT-RADIX* = T,
  4803. # *PRINT-CIRCLE* = T, *PRINT-LEVEL* = NIL, *PRINT-LENGTH* = NIL,
  4804. # *PRINT-GENSYM* = T, *PRINT-ARRAY* = T, *PRINT-CLOSURE* = T.
  4805.  
  4806. # Fehlermeldung bei *PRINT-READABLY* /= NIL.
  4807. # fehler_print_readably(obj);
  4808.   nonreturning_function(local, fehler_print_readably, (object obj));
  4809.   local void fehler_print_readably(obj)
  4810.     var reg1 object obj;
  4811.     # (error-of-type 'print-not-readable
  4812.     #        "~: Trotz ~ kann ~ nicht wiedereinlesbar ausgegeben werden."
  4813.     #        'print '*print-readably* obj
  4814.     # )
  4815.     { var reg1 object *obj_;
  4816.       pushSTACK(obj);
  4817.       obj_=&STACK_0;
  4818.       dynamic_bind(S(print_readably),NIL); # *PRINT-READABLY* an NIL binden
  4819.       pushSTACK(*obj_); # Wert für Slot OBJECT von PRINT-NOT-READABLE
  4820.       pushSTACK(*obj_);
  4821.       pushSTACK(S(print_readably));
  4822.       pushSTACK(S(print));
  4823.       //: DEUTSCH "~: Trotz ~ kann ~ nicht wiedereinlesbar ausgegeben werden."
  4824.       //: ENGLISH "~: Despite of ~, ~ cannot be printed readably."
  4825.       //: FRANCAIS "~ : Malgré ~, ~ ne peut pas être imprimé de façon lisible."
  4826.       fehler(print_not_readable, GETTEXT("~: Despite of ~, ~ cannot be printed readably."));
  4827.     }
  4828.  
  4829. # Fehlermeldung bei unzulässigem Wert von *PRINT-CASE*.
  4830. # fehler_print_case();
  4831.   nonreturning_function(local, fehler_print_case, (void));
  4832.   local void fehler_print_case()
  4833.     # (error "~: Der Wert ~ von ~ ist weder ~ noch ~ noch ~.
  4834.     #         Er wird auf ~ gesetzt."
  4835.     #        'print *print-case* '*print-case* ':upcase ':downcase ':capitalize
  4836.     #        ':upcase
  4837.     # )
  4838.     { var reg1 object print_case = S(print_case);
  4839.       pushSTACK(Symbol_value(print_case)); # Wert für Slot DATUM von TYPE-ERROR
  4840.       pushSTACK(O(type_printcase)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  4841.       pushSTACK(S(Kupcase)); # :UPCASE
  4842.       pushSTACK(S(Kcapitalize)); # :CAPITALIZE
  4843.       pushSTACK(S(Kdowncase)); # :DOWNCASE
  4844.       pushSTACK(S(Kupcase)); # :UPCASE
  4845.       pushSTACK(print_case);
  4846.       pushSTACK(Symbol_value(print_case));
  4847.       pushSTACK(S(print));
  4848.       set_Symbol_value(print_case,S(Kupcase)); # (setq *PRINT-CASE* ':UPCASE)
  4849.       { var const char *msg1,*msg2;
  4850.         //: DEUTSCH "~: Der Wert ~ von ~ ist weder ~ noch ~ noch ~."
  4851.         //: ENGLISH "~: the value ~ of ~ is neither ~ nor ~ nor ~."  
  4852.         //: FRANCAIS "~ : La valeur ~ de ~ n'est ni ~ ni ~ ni ~."
  4853.         msg1 = GETTEXT("~: the value ~ of ~ is neither ~ nor ~ nor ~.");
  4854.         //: DEUTSCH "Er wird auf ~ gesetzt."
  4855.         //: ENGLISH "It is reset to ~."
  4856.         //: FRANCAIS "Elle est remplacée par ~."
  4857.         msg2 = GETTEXT("It is reset to ~.");
  4858.         fehler3(type_error,msg1,NLstring,msg2);
  4859.       }
  4860.     }
  4861.  
  4862. # Macro: Fragt den Wert von *PRINT-CASE* ab und verzweigt je nachdem.
  4863. # switch_print_case(upcase_statement,downcase_statement,capitalize_statement);
  4864.   #define switch_print_case(upcase_statement,downcase_statement,capitalize_statement)  \
  4865.     {var reg3 object print_case = Symbol_value(S(print_case)); # Wert von *PRINT-CASE* \
  4866.      if (eq(print_case,S(Kupcase))) # = :UPCASE ?            \
  4867.        { upcase_statement }                                  \
  4868.      elif (eq(print_case,S(Kdowncase))) # = :DOWNCASE ?      \
  4869.        { downcase_statement }                                \
  4870.      elif (eq(print_case,S(Kcapitalize))) # = :CAPITALIZE ?  \
  4871.        { capitalize_statement }                              \
  4872.      else # keines der drei -> Error                         \
  4873.        { fehler_print_case(); }                              \
  4874.     }
  4875.  
  4876. # UP: Gibt einen Teil eines Simple-String elementweise auf einen Stream aus.
  4877. # write_sstring_ab(&stream,string,start,len);
  4878. # > string: Simple-String
  4879. # > start: Startindex
  4880. # > len: Anzahl der auszugebenden Zeichen
  4881. # > stream: Stream
  4882. # < stream: Stream
  4883. # kann GC auslösen
  4884.   #ifndef STRM_WR_SS
  4885.   local void write_sstring_ab (object* stream_, object string, uintL start, uintL len);
  4886.   local void write_sstring_ab(stream_,string,start,len)
  4887.     var reg3 object* stream_;
  4888.     var reg5 object string;
  4889.     var reg4 uintL start;
  4890.     var reg2 uintL len;
  4891.     { var reg1 uintL index = start;
  4892.       pushSTACK(string); # Simple-String retten
  4893.       dotimesL(len,len,
  4894.         { write_schar(stream_,TheSstring(STACK_0)->data[index]);
  4895.           index++;
  4896.         });
  4897.       skipSTACK(1);
  4898.     }
  4899.   #else
  4900.     typedef void (* wr_ss_Pseudofun) (object* stream_, object string, uintL start, uintL len);
  4901.     #define wr_ss(strm)  (*(wr_ss_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ss)))
  4902.     #define write_sstring_ab(stream_,string,start,len)  \
  4903.       wr_ss(*stream_)(stream_,string,start,len)
  4904.   #endif
  4905.  
  4906. # UP: Gibt einen Simple-String elementweise auf einen Stream aus.
  4907. # write_sstring(&stream,string);
  4908. # > string: Simple-String
  4909. # > stream: Stream
  4910. # < stream: Stream
  4911. # kann GC auslösen
  4912.   global void write_sstring (object* stream_, object string);
  4913.   global void write_sstring(stream_,string)
  4914.     var reg2 object* stream_;
  4915.     var reg1 object string;
  4916.     { write_sstring_ab(stream_,string,0,TheSstring(string)->length); }
  4917.  
  4918. # UP: Gibt einen String elementweise auf einen Stream aus.
  4919. # write_string(&stream,string);
  4920. # > string: String
  4921. # > stream: Stream
  4922. # < stream: Stream
  4923. # kann GC auslösen
  4924.   global void write_string (object* stream_, object string);
  4925.   global void write_string(stream_,string)
  4926.     var reg2 object* stream_;
  4927.     var reg1 object string;
  4928.     { if (simple_string_p(string))
  4929.         # Simple-String
  4930.         { write_sstring(stream_,string); }
  4931.         else
  4932.         # nicht-simpler String
  4933.         { var reg3 uintL len = vector_length(string); # Länge
  4934.           var uintL offset = 0; # Offset vom String in den Datenvektor
  4935.           var reg4 object sstring = array1_displace_check(string,len,&offset); # Datenvektor
  4936.           write_sstring_ab(stream_,sstring,offset,len);
  4937.         }
  4938.     }
  4939.  
  4940. # UP: Gibt einen Simple-String je nach (READTABLE-CASE *READTABLE*) und
  4941. # *PRINT-CASE* auf einen Stream aus.
  4942. # write_sstring_case(&stream,string);
  4943. # > string: Simple-String
  4944. # > stream: Stream
  4945. # < stream: Stream
  4946. # kann GC auslösen
  4947.   local void write_sstring_case (object* stream_, object string);
  4948.   local void write_sstring_case(stream_,string)
  4949.     var reg6 object* stream_;
  4950.     var reg7 object string;
  4951.     { # (READTABLE-CASE *READTABLE*) abfragen:
  4952.       var reg1 object readtable;
  4953.       get_readtable(readtable = ); # aktuelle Readtable
  4954.       switch ((uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case))
  4955.         { case case_upcase:
  4956.             # *PRINT-CASE* abfragen. Danach richtet sich, wie Großbuchstaben
  4957.             # ausgegeben werden. Kleinbuchstaben werden immer klein ausgegeben.
  4958.             switch_print_case(
  4959.               # :UPCASE -> Großbuchstaben in Upcase ausgeben:
  4960.               { write_sstring(stream_,string); },
  4961.               # :DOWNCASE -> Großbuchstaben in Downcase ausgeben:
  4962.               { var reg1 uintL index = 0;
  4963.                 var reg2 uintL count;
  4964.                 pushSTACK(string); # Simple-String retten
  4965.                 dotimesL(count,TheSstring(string)->length,
  4966.                   { write_schar(stream_,down_case(TheSstring(STACK_0)->data[index]));
  4967.                     index++;
  4968.                   });
  4969.                 skipSTACK(1);
  4970.               },
  4971.               # :CAPITALIZE -> jeweils den ersten Großbuchstaben eines Wortes
  4972.               # als Großbuchstaben, alle anderen als Kleinbuchstaben ausgeben.
  4973.               # (Vgl. NSTRING_CAPITALIZE in CHARSTRG.D)
  4974.               # Erste Version:
  4975.               #   (lambda (s &aux (l (length s)))
  4976.               #     (prog ((i 0) c)
  4977.               #       1 ; Suche ab hier den nächsten Wortanfang
  4978.               #         (if (= i l) (return))
  4979.               #         (setq c (char s i))
  4980.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  4981.               #       ; Wortanfang gefunden
  4982.               #       (write-char c) (incf i) ; Großbuchstaben als Großbuchstaben ausgeben
  4983.               #       2 ; mitten im Wort
  4984.               #         (if (= i l) (return))
  4985.               #         (setq c (char s i))
  4986.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  4987.               #         (write-char (char-downcase c)) ; Großbuchstaben klein ausgeben
  4988.               #         (incf i) (go 2)
  4989.               #   ) )
  4990.               # Es werden also genau die Zeichen mit char-downcase ausgegeben, vor
  4991.               # denen ein alphanumerisches Zeichen auftrat und die selber
  4992.               # alphanumerisch sind.
  4993.               # [Da alle Uppercase-Characters (nach CLTL S. 236 oben) alphabetisch
  4994.               # und damit auch alphanumerisch sind und auf den anderen Characters
  4995.               # char-downcase nichts tut: Es werden genau die Zeichen mit
  4996.               # char-downcase ausgegeben, vor denen ein alphanumerisches Zeichen
  4997.               # auftrat. Wir benutzen dies aber nicht.]
  4998.               # Zweite Version:
  4999.               #   (lambda (s &aux (l (length s)))
  5000.               #     (prog ((i 0) c (flag nil))
  5001.               #       1 (if (= i l) (return))
  5002.               #         (setq c (char s i))
  5003.               #         (let ((newflag (alphanumericp c)))
  5004.               #           (when (and flag newflag) (setq c (char-downcase c)))
  5005.               #           (setq flag newflag)
  5006.               #         )
  5007.               #         (write-char c) (incf i) (go 1)
  5008.               #   ) )
  5009.               # Dritte Version:
  5010.               #   (lambda (s &aux (l (length s)))
  5011.               #     (prog ((i 0) c (flag nil))
  5012.               #       1 (if (= i l) (return))
  5013.               #         (setq c (char s i))
  5014.               #         (when (and (shiftf flag (alphanumericp c)) flag)
  5015.               #           (setq c (char-downcase c))
  5016.               #         )
  5017.               #         (write-char c) (incf i) (go 1)
  5018.               #   ) )
  5019.               { var reg3 boolean flag = FALSE;
  5020.                 var reg4 uintL index = 0;
  5021.                 var reg5 uintL count;
  5022.                 pushSTACK(string); # Simple-String retten
  5023.                 dotimesL(count,TheSstring(string)->length,
  5024.                   { # flag zeigt an, ob gerade innerhalb eines Wortes
  5025.                     var reg2 boolean oldflag = flag;
  5026.                     var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nächstes Zeichen
  5027.                     if ((flag = alphanumericp(c)) && oldflag)
  5028.                       # alphanumerisches Zeichen im Wort:
  5029.                       { c = down_case(c); } # Groß- in Kleinbuchstaben umwandeln
  5030.                     write_schar(stream_,c); # und ausgeben
  5031.                     index++;
  5032.                   });
  5033.                 skipSTACK(1);
  5034.               }
  5035.               );
  5036.             break;
  5037.           case case_downcase:
  5038.             # *PRINT-CASE* abfragen. Danach richtet sich, wie Kleinbuchstaben
  5039.             # ausgegeben werden. Großbuchstaben werden immer groß ausgegeben.
  5040.             switch_print_case(
  5041.               # :UPCASE -> Kleinbuchstaben in Upcase ausgeben:
  5042.               { var reg1 uintL index = 0;
  5043.                 var reg2 uintL count;
  5044.                 pushSTACK(string); # Simple-String retten
  5045.                 dotimesL(count,TheSstring(string)->length,
  5046.                   { write_schar(stream_,up_case(TheSstring(STACK_0)->data[index]));
  5047.                     index++;
  5048.                   });
  5049.                 skipSTACK(1);
  5050.               },
  5051.               # :DOWNCASE -> Kleinbuchstaben in Downcase ausgeben:
  5052.               { write_sstring(stream_,string); },
  5053.               # :CAPITALIZE -> jeweils den ersten Kleinbuchstaben eines Wortes
  5054.               # als Großbuchstaben, alle anderen als Kleinbuchstaben ausgeben.
  5055.               # (Vgl. NSTRING_CAPITALIZE in CHARSTRG.D)
  5056.               # Erste Version:
  5057.               #   (lambda (s &aux (l (length s)))
  5058.               #     (prog ((i 0) c)
  5059.               #       1 ; Suche ab hier den nächsten Wortanfang
  5060.               #         (if (= i l) (return))
  5061.               #         (setq c (char s i))
  5062.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  5063.               #       ; Wortanfang gefunden
  5064.               #       (write-char (char-upcase c)) ; Kleinbuchstaben groß ausgeben
  5065.               #       (incf i)
  5066.               #       2 ; mitten im Wort
  5067.               #         (if (= i l) (return))
  5068.               #         (setq c (char s i))
  5069.               #         (unless (alphanumericp c) (write-char c) (incf i) (go 1))
  5070.               #         (write-char c) ; Kleinbuchstaben klein ausgeben
  5071.               #         (incf i) (go 2)
  5072.               #   ) )
  5073.               # Es werden also genau die Zeichen mit char-upcase ausgegeben, vor
  5074.               # denen kein alphanumerisches Zeichen auftrat und die aber selber
  5075.               # alphanumerisch sind.
  5076.               # Zweite Version:
  5077.               #   (lambda (s &aux (l (length s)))
  5078.               #     (prog ((i 0) c (flag nil))
  5079.               #       1 (if (= i l) (return))
  5080.               #         (setq c (char s i))
  5081.               #         (when (and (not (shiftf flag (alphanumericp c))) flag)
  5082.               #           (setq c (char-upcase c))
  5083.               #         )
  5084.               #         (write-char c) (incf i) (go 1)
  5085.               #   ) )
  5086.               { var reg3 boolean flag = FALSE;
  5087.                 var reg4 uintL index = 0;
  5088.                 var reg5 uintL count;
  5089.                 pushSTACK(string); # Simple-String retten
  5090.                 dotimesL(count,TheSstring(string)->length,
  5091.                   { # flag zeigt an, ob gerade innerhalb eines Wortes
  5092.                     var reg2 boolean oldflag = flag;
  5093.                     var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nächstes Zeichen
  5094.                     if ((flag = alphanumericp(c)) && !oldflag)
  5095.                       # alphanumerisches Zeichen am Wortanfang:
  5096.                       { c = up_case(c); } # Klein- in Großbuchstaben umwandeln
  5097.                     write_schar(stream_,c); # und ausgeben
  5098.                     index++;
  5099.                   });
  5100.                 skipSTACK(1);
  5101.               }
  5102.               );
  5103.             break;
  5104.           case case_preserve:
  5105.             # *PRINT-CASE* ignorieren.
  5106.             write_sstring(stream_,string);
  5107.             break;
  5108.           default: NOTREACHED
  5109.     }   }
  5110.  
  5111. # UP: Gibt eine Anzahl Spaces auf einen Stream aus.
  5112. # spaces(&stream,anzahl);
  5113. # > anzahl: Anzahl Spaces (Fixnum>=0)
  5114. # > stream: Stream
  5115. # < stream: Stream
  5116. # kann GC auslösen
  5117.   local void spaces (object* stream_, object anzahl);
  5118.   local void spaces(stream_,anzahl)
  5119.     var reg1 object* stream_;
  5120.     var reg3 object anzahl;
  5121.     { var reg2 uintL count;
  5122.       dotimesL(count,posfixnum_to_L(anzahl), { write_schar(stream_,' '); } );
  5123.     }
  5124.  
  5125. # ------------------- Unterprogramme für Pretty-Print -------------------------
  5126.  
  5127. # Variablen:
  5128. # ==========
  5129.  
  5130. # Zeilenlänge L                  Wert von SYS::*PRIN-LINELENGTH*,
  5131. #                                  Fixnum>=0 oder NIL
  5132. # Zeilenposition                 im PPHELP-Stream, Fixnum>=0
  5133. # Linker Rand L1 für Einzeiler   Wert von SYS::*PRIN-L1*, Fixnum>=0
  5134. # Linker Rand LM für Mehrzeiler  Wert von SYS::*PRIN-LM*, Fixnum>=0
  5135. # Modus                          im PPHELP-Stream: NIL für Einzeiler,
  5136. #                                                  T für Mehrzeiler
  5137.   #define einzeiler NIL
  5138.   #define mehrzeiler T
  5139.  
  5140. # Komponenten eines Pretty-Print-Hilfs-Streams:
  5141. #   strm_pphelp_lpos     Line Position (Fixnum>=0)
  5142. #   strm_pphelp_strings  nichtleere Liste von Semi-Simple-Strings. Sie
  5143. #                        enthalten den bisherigen Output (in umgekehrter
  5144. #                        Reihenfolge: letzte Zeile als CAR).
  5145. #   strm_pphelp_modus    Modus: Einzeiler, falls nur 1 String vorkommt und
  5146. #                        dieser kein NL enthält, sonst Mehrzeiler.
  5147. # WRITE-CHAR schiebt sein Character immer nur auf die letzte Zeile
  5148. # und aktualisiert lpos und modus.
  5149.  
  5150. # während Justify:
  5151. # voriger Inhalt des Streams     Werte von SYS::*PRIN-JBSTRINGS*,
  5152. #                                  SYS::*PRIN-JBMODUS*, SYS::*PRIN-JBLPOS*
  5153. # bisherige Blöcke (Liste von Blöcken,
  5154. # mehrzeiliger Block = nichtleere Liste von Semi-Simple-Strings,
  5155. # einzeiliger Block = Semi-Simple-String)
  5156. #                                Wert von SYS::*PRIN-JBLOCKS*
  5157.  
  5158. # für Einhaltung von *PRINT-LEVEL*:
  5159. # SYS::*PRIN-LEVEL*              aktuelle Ausgabetiefe (Fixnum>=0)
  5160.  
  5161. # für Wiedereinlesbarkeit von Backquote-Expressions:
  5162. # SYS::*PRIN-BQLEVEL*            aktuelle Backquote-Tiefe (Fixnum>=0)
  5163.  
  5164. # wenn der Printer nach außen verlassen wird:
  5165. # SYS::*PRIN-STREAM*             aktueller Stream (Default: NIL),
  5166. # um ein rekursives PRINT oder WRITE zu erkennen.
  5167.  
  5168. # für Einhaltung von *PRINT-LENGTH*:
  5169. # Längenbegrenzung (uintL >=0 oder ~0)      lokal
  5170. # bisherige Länge (uintL >=0)               lokal
  5171.  
  5172. # für schöne Ausgabe von Klammern:
  5173. # *PRINT-RPARS* (T oder NIL) zeigt an, ob Klammern zu in einer extra Zeile
  5174. # als "   ) ) )" ausgegeben werden sollen oder nicht.
  5175. # SYS::*PRIN-RPAR* = Position der letzten geöffneten Klammer (Fixnum>=0,
  5176. #                    oder NIL falls die schließende Klammer ans Zeilenende
  5177. #                    und nicht unter die öffnende Klammer soll)
  5178.  
  5179. # Unterprogramme:
  5180. # ===============
  5181.  
  5182. # Sie arbeiten auf dem Stream und sind korrekt zu schachteln,
  5183. # da sie den STACK verändern können.
  5184.  
  5185. # UP: Fängt in PPHELP-Stream A5 eine neue Zeile an.
  5186. # pphelp_newline(&stream);
  5187. # > stream: Stream
  5188. # < stream: Stream
  5189. # kann GC auslösen
  5190.   local void pphelp_newline (object* stream_);
  5191.   local void pphelp_newline(stream_)
  5192.     var reg3 object* stream_;
  5193.     {  # (push (make-ssstring 50) (strm-pphelp-strings stream)) :
  5194.        pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String
  5195.      { var reg2 object new_cons = allocate_cons(); # neues Cons
  5196.        Car(new_cons) = popSTACK();
  5197.       {var reg1 object stream = *stream_;
  5198.        Cdr(new_cons) = TheStream(stream)->strm_pphelp_strings;
  5199.        TheStream(stream)->strm_pphelp_strings = new_cons;
  5200.        # Line-Position := 0, Modus := Mehrzeiler :
  5201.        TheStream(stream)->strm_pphelp_lpos = Fixnum_0;
  5202.        TheStream(stream)->strm_pphelp_modus = mehrzeiler;
  5203.     }}}
  5204.  
  5205. # Klammer auf und Klammer zu
  5206. # --------------------------
  5207. # Korrekt zu schachteln.
  5208.   #define KLAMMER_AUF  klammer_auf(stream_);
  5209.   #define KLAMMER_ZU   klammer_zu(stream_);
  5210.  
  5211. # UP: Gibt eine Klammer '(' auf den Stream aus und merkt sich eventuell
  5212. # die Position.
  5213. # klammer_auf(&stream);
  5214. # > stream: Stream
  5215. # < stream: Stream
  5216. # verändert STACK
  5217. # kann GC auslösen
  5218.   local void klammer_auf (object* stream_);
  5219.   local void klammer_auf(stream_)
  5220.     var reg3 object* stream_;
  5221.     { var reg1 object stream = *stream_;
  5222.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5223.         # normaler Stream
  5224.         { write_schar(stream_,'('); }
  5225.         else
  5226.         # Pretty-Print-Hilfs-Stream
  5227.         { var reg2 object pos = # Position für die Klammer zu
  5228.             (test_value(S(print_rpars)) # *PRINT-RPARS* /= NIL ?
  5229.               ? TheStream(stream)->strm_pphelp_lpos # ja -> aktuelle Position (Fixnum>=0)
  5230.               : NIL                                 # nein -> NIL
  5231.             );
  5232.           dynamic_bind(S(prin_rpar),pos); # SYS::*PRIN-RPAR* daran binden
  5233.           write_schar(stream_,'(');
  5234.         }
  5235.     }
  5236.  
  5237. # UP: Gibt eine Klammer ')' auf den Stream aus, evtl. an der gemerkten
  5238. # Position.
  5239. # klammer_zu(&stream);
  5240. # > stream: Stream
  5241. # < stream: Stream
  5242. # verändert STACK
  5243. # kann GC auslösen
  5244.   local void klammer_zu (object* stream_);
  5245.   local void klammer_zu(stream_)
  5246.     var reg10 object* stream_;
  5247.     { var reg4 object stream = *stream_;
  5248.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5249.         # normaler Stream
  5250.         { write_schar(stream_,')'); }
  5251.         else
  5252.         # Pretty-Print-Hilfs-Stream
  5253.         { # gewünschte Position der Klammer zu holen:
  5254.           var reg9 object pos = Symbol_value(S(prin_rpar)); # SYS::*PRIN-RPAR*
  5255.           if (nullp(pos)) goto hinten; # keine -> Klammer hinten ausgeben
  5256.           # Klammer an Position pos ausgeben:
  5257.           if (eq(TheStream(stream)->strm_pphelp_modus,mehrzeiler)
  5258.               && !nullp(Cdr(TheStream(stream)->strm_pphelp_strings))
  5259.              )
  5260.             # Mehrzeiler mit mehr als einer Zeile ("echter" Mehrzeiler)
  5261.             {  # Klammer an die gewünschte Position ausgeben.
  5262.                # Dazu Test, ob die letzte Zeile im Stream
  5263.                # 1. bis zur gewünschten Position (einschließlich) nur Spaces
  5264.                # und
  5265.                # 2. sonst nur Spaces und ')' enthält.
  5266.                # Wenn ja, Klammer an die gewünschte Position setzen.
  5267.                # Wenn nein, neue Zeile anfangen, Spaces und die Klammer ausgeben.
  5268.                var reg8 object lastline = # letzte Zeile
  5269.                  Car(TheStream(stream)->strm_pphelp_strings);
  5270.                var reg7 uintL len = TheArray(lastline)->dims[1]; # Länge = Fill-Pointer der Zeile
  5271.                var reg6 uintL need = posfixnum_to_L(pos) + 1; # nötige Anzahl Spaces
  5272.                if (len < need) # Zeile zu kurz ?
  5273.                  goto new_line; # ja -> neue Zeile anfangen
  5274.                lastline = TheArray(lastline)->data; # letzte Zeile, Simple-String
  5275.              { var reg2 uintB* charptr = &TheSstring(lastline)->data[0];
  5276.                # Teste, ob need Spaces kommen:
  5277.                {var reg3 uintL count;
  5278.                 dotimesL(count,need,
  5279.                   { if (!(*charptr++ == ' ')) # Space ?
  5280.                       goto new_line; # nein -> neue Zeile anfangen
  5281.                   });
  5282.                }
  5283.               {var reg5 uintB* charptr1 = charptr; # Position merken
  5284.                # Teste, ob len-need mal Space oder ')' kommt:
  5285.                {var reg3 uintL count;
  5286.                 dotimesL(count,len-need,
  5287.                   { var reg1 uintB c = *charptr++;
  5288.                     if (!((c == ' ') || (c == ')'))) # Space oder ')' ?
  5289.                       goto new_line; # nein -> neue Zeile anfangen
  5290.                   });
  5291.                }
  5292.                # Klammer an die gewünschte Position pos = need-1 setzen:
  5293.                *--charptr1 = ')';
  5294.             }}}
  5295.             else
  5296.             # Einzeiler.
  5297.             { # Klammer muß wohl hinten ausgegeben werden.
  5298.               # Ausnahme: Wenn Line-Position = SYS::*PRIN-LINELENGTH* ist,
  5299.               #           würde über die Zeile hinausgeschrieben;
  5300.               #           stattdessen wird eine neue Zeile angefangen.
  5301.               if (eq(Symbol_value(S(prin_linelength)), # Wert von SYS::*PRIN-LINELENGTH*
  5302.                      TheStream(stream)->strm_pphelp_lpos # = Line-Position ?
  5303.                  )  )
  5304.                 { new_line: # neue Zeile anfangen
  5305.                   pphelp_newline(stream_); spaces(stream_,pos);
  5306.                 }
  5307.               hinten: # Klammer hinten ausgeben
  5308.               write_schar(stream_,')');
  5309.             }
  5310.           # Bindung von SYS::*PRIN-RPAR* auflösen:
  5311.           dynamic_unbind();
  5312.     }   }
  5313.  
  5314. # Justify
  5315. # -------
  5316. # Korrekt zu schachteln,
  5317. # jeweils 1 mal JUSTIFY_START,
  5318. # dann beliebige Ausgaben, durch JUSTIFY_SPACE getrennt,
  5319. # dann 1 mal entweder
  5320. #     JUSTIFY_END_ENG (faßt auch in Mehrzeilern kurze Blöcke in eine Zeile)
  5321. #     oder
  5322. #     JUSTIFY_END_WEIT (in Mehrzeilern belegt jeder Block eine eigene Zeile).
  5323.   #define JUSTIFY_START     justify_start(stream_);
  5324.   #define JUSTIFY_SPACE     justify_space(stream_);
  5325.   #define JUSTIFY_END_ENG   justify_end_eng(stream_);
  5326.   #define JUSTIFY_END_WEIT  justify_end_weit(stream_);
  5327.  
  5328. # UP: Leert einen Pretty-Print-Hilfsstream.
  5329. # justify_empty_1(&stream);
  5330. # > stream: Stream
  5331. # < stream: Stream
  5332. # kann GC auslösen
  5333.   local void justify_empty_1 (object* stream_);
  5334.   local void justify_empty_1(stream_)
  5335.     var reg3 object* stream_;
  5336.     {  pushSTACK(make_ssstring(50)); # neuer Semi-Simple-String
  5337.      { var reg2 object new_cons = allocate_cons(); # neues Cons
  5338.        Car(new_cons) = popSTACK();
  5339.        # new_cons = (list (make-ssstring 50))
  5340.       {var reg1 object stream = *stream_;
  5341.        TheStream(stream)->strm_pphelp_strings = new_cons; # neue, leere Zeile
  5342.        TheStream(stream)->strm_pphelp_modus = einzeiler; # Modus := Einzeiler
  5343.     }}}
  5344.  
  5345. # UP: Beginnt einen Justify-Block.
  5346. # justify_start(&stream);
  5347. # > stream: Stream
  5348. # < stream: Stream
  5349. # verändert STACK
  5350.   local void justify_start (object* stream_);
  5351.   local void justify_start(stream_)
  5352.     var reg2 object* stream_;
  5353.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5354.         {} # normaler Stream -> nichts zu tun
  5355.         else
  5356.         # Pretty-Print-Hilfs-Stream
  5357.         { # SYS::*PRIN-JBSTRINGS* an den Inhalt des Streams binden:
  5358.           dynamic_bind(S(prin_jbstrings),TheStream(*stream_)->strm_pphelp_strings);
  5359.           # SYS::*PRIN-JBMODUS* an den Modus des Streams binden:
  5360.           dynamic_bind(S(prin_jbmodus),TheStream(*stream_)->strm_pphelp_modus);
  5361.           # SYS::*PRIN-JBLPOS* an die Line-Position des Streams binden:
  5362.           dynamic_bind(S(prin_jblpos),TheStream(*stream_)->strm_pphelp_lpos);
  5363.           # SYS::*PRIN-JBLOCKS* an () binden:
  5364.           dynamic_bind(S(prin_jblocks),NIL);
  5365.           # Stream leeren:
  5366.           justify_empty_1(stream_);
  5367.         }
  5368.     }
  5369.  
  5370. # UP: Leert Inhalt eines Pretty-Print-Hilfsstream aus in die Variable
  5371. # SYS::*PRIN-JBLOCKS*.
  5372. # justify_empty_2(&stream);
  5373. # > stream: Stream
  5374. # < stream: Stream
  5375. # kann GC auslösen
  5376.   local void justify_empty_2 (object* stream_);
  5377.   local void justify_empty_2(stream_)
  5378.     var reg3 object* stream_;
  5379.     { var reg1 object stream = *stream_;
  5380.       var reg2 object new_cons;
  5381.       # SYS::*PRIN-JBLOCKS* um den Inhalt des Streams erweitern:
  5382.       if (eq(TheStream(stream)->strm_pphelp_modus,mehrzeiler))
  5383.         # Mehrzeiler.
  5384.         { # (push strings SYS::*PRIN-JBLOCKS*)
  5385.           new_cons = allocate_cons(); # neues Cons
  5386.           Car(new_cons) = TheStream(*stream_)->strm_pphelp_strings;
  5387.         }
  5388.         else
  5389.         # Einzeiler.
  5390.         { # (push (first strings) SYS::*PRIN-JBLOCKS*), oder kürzer:
  5391.           # (setq SYS::*PRIN-JBLOCKS* (rplacd strings SYS::*PRIN-JBLOCKS*))
  5392.           new_cons = TheStream(stream)->strm_pphelp_strings;
  5393.         }
  5394.       Cdr(new_cons) = Symbol_value(S(prin_jblocks));
  5395.       set_Symbol_value(S(prin_jblocks),new_cons);
  5396.     }
  5397.  
  5398. # UP: Gibt einen Zwischenraum aus, der bei Justify gedehnt werden kann.
  5399. # justify_space(&stream);
  5400. # > stream: Stream
  5401. # < stream: Stream
  5402. # kann GC auslösen
  5403.   local void justify_space (object* stream_);
  5404.   local void justify_space(stream_)
  5405.     var reg1 object* stream_;
  5406.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5407.         # normaler Stream -> nur ein Space
  5408.         { write_schar(stream_,' '); }
  5409.         else
  5410.         # Pretty-Print-Hilfs-Stream
  5411.         { justify_empty_2(stream_); # Streaminhalt retten
  5412.           justify_empty_1(stream_); # Stream leeren
  5413.           # Line-Position := SYS::*PRIN-LM* (Fixnum>=0)
  5414.           TheStream(*stream_)->strm_pphelp_lpos = Symbol_value(S(prin_lm));
  5415.         }
  5416.     }
  5417.  
  5418. # UP: Beendet einen Justify-Block, bestimmt die Gestalt des Blockes und
  5419. # gibt seinen Inhalt auf den alten Stream aus.
  5420. # justify_end_eng(&stream);
  5421. # > stream: Stream
  5422. # < stream: Stream
  5423. # kann GC auslösen
  5424.   local void justify_end_eng (object* stream_);
  5425.   local void justify_end_eng(stream_)
  5426.     var reg2 object* stream_;
  5427.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5428.         {} # normaler Stream -> nichts zu tun
  5429.         else
  5430.         # Pretty-Print-Hilfs-Stream
  5431.         { justify_empty_2(stream_); # Streaminhalt retten
  5432.           # Streaminhalt restaurieren, d.h. Werte von SYS::*PRIN-JBSTRINGS*,
  5433.           # SYS::*PRIN-JBMODUS*, SYS::*PRIN-JBLPOS* in den Stream zurück:
  5434.          {var reg1 object stream = *stream_;
  5435.           # jetzige Line-Position retten:
  5436.           pushSTACK(TheStream(stream)->strm_pphelp_lpos);
  5437.           # alten Streaminhalt wiederherstellen:
  5438.           TheStream(stream)->strm_pphelp_strings = Symbol_value(S(prin_jbstrings));
  5439.           TheStream(stream)->strm_pphelp_modus = Symbol_value(S(prin_jbmodus));
  5440.           TheStream(stream)->strm_pphelp_lpos = Symbol_value(S(prin_jblpos));
  5441.           # (nichtleere) Liste von Blöcken auf den Stream ausgeben:
  5442.           pushSTACK(nreverse(Symbol_value(S(prin_jblocks)))); # (nreverse SYS::*PRIN-JBLOCKS*)
  5443.           # Die Blöcke werden einzeln ausgegeben. Mehrzeiler werden
  5444.           # voneinander und von den Einzeilern durch Newline getrennt.
  5445.           # Es werden jedoch möglichst viele aufeinanderfolgende Einzeiler
  5446.           # (durch Space getrennt) in eine Zeile gepackt.
  5447.           loop # Blockliste STACK_0 durchlaufen:
  5448.             { var reg3 object block = Car(STACK_0); # nächster Block
  5449.               STACK_0 = Cdr(STACK_0); # Blockliste verkürzen
  5450.               if (consp(block))
  5451.                 # Mehrzeiliger Teilblock
  5452.                 { # Zeilen in die richtige Reihenfolge bringen:
  5453.                   block = nreverse(block);
  5454.                   # erste Zeile auf den PPHELP-Stream ausgeben:
  5455.                   pushSTACK(block);
  5456.                   write_string(stream_,Car(block));
  5457.                   block = popSTACK();
  5458.                   # restliche Zeilen an die Zeilen im Stream vorne dranhängen:
  5459.                   stream = *stream_;
  5460.                   TheStream(stream)->strm_pphelp_strings =
  5461.                     nreconc(Cdr(block),TheStream(stream)->strm_pphelp_strings);
  5462.                   # Modus := Mehrzeiler:
  5463.                   TheStream(stream)->strm_pphelp_modus = mehrzeiler;
  5464.                   if (matomp(STACK_0)) # Restliste leer?
  5465.                     # ja -> Line-Position zurück, fertig
  5466.                     { TheStream(stream)->strm_pphelp_lpos = STACK_1;
  5467.                       break;
  5468.                     }
  5469.                   # neue Zeile anfangen und weiter:
  5470.                   goto new_line;
  5471.                 }
  5472.                 else
  5473.                 # Einzeiliger Teilblock
  5474.                 { # auf den PPHELP-Stream ausgeben:
  5475.                   write_string(stream_,block);
  5476.                   if (matomp(STACK_0)) # Restliste leer?
  5477.                     break; # ja -> fertig
  5478.                   # nächster Block ein Mehrzeiler?
  5479.                   block = Car(STACK_0); # nächster Block
  5480.                   if (atomp(block)) # ein Mehrzeiler oder Einzeiler?
  5481.                     # Es ist ein Einzeiler.
  5482.                     # Paßt er noch auf dieselbe Zeile,
  5483.                     # d.h. ist  Line-Position + 1 + length(Einzeiler) <= L ?
  5484.                     { var reg4 object linelength = Symbol_value(S(prin_linelength)); # L = SYS::*PRIN-LINELENGTH*
  5485.                       if (nullp(linelength) # =NIL -> paßt
  5486.                           || (posfixnum_to_L(TheStream(*stream_)->strm_pphelp_lpos) # Line-Position
  5487.                               + TheArray(block)->dims[1] # Länge = Fill-Pointer des Einzeilers
  5488.                               < posfixnum_to_L(linelength) # < linelength ?
  5489.                          )   )
  5490.                         # Paßt noch.
  5491.                         { # Space statt Newline ausgeben:
  5492.                           write_schar(stream_,' ');
  5493.                         }
  5494.                         else
  5495.                         # Paßt nicht mehr.
  5496.                         goto new_line;
  5497.                     }
  5498.                     else
  5499.                     # Mehrzeiler -> neue Zeile und weiter
  5500.                     { new_line: # neue Zeile anfangen
  5501.                       pphelp_newline(stream_); # neue Zeile, dabei Modus:=Mehrzeiler
  5502.                       spaces(stream_,Symbol_value(S(prin_lm))); # SYS::*PRIN-LM* Spaces
  5503.                     }
  5504.                 }
  5505.             }
  5506.           skipSTACK(2); # leere Restliste und alte Line-Position vergessen
  5507.           # Bindungen von JUSTIFY_START rückgängig machen:
  5508.           dynamic_unbind();
  5509.           dynamic_unbind();
  5510.           dynamic_unbind();
  5511.           dynamic_unbind();
  5512.         }}
  5513.     }
  5514.  
  5515. # UP: Beendet einen Justify-Block, bestimmt die Gestalt des Blockes und
  5516. # gibt seinen Inhalt auf den alten Stream aus.
  5517. # justify_end_weit(&stream);
  5518. # > stream: Stream
  5519. # < stream: Stream
  5520. # kann GC auslösen
  5521.   local void justify_end_weit (object* stream_);
  5522.   local void justify_end_weit(stream_)
  5523.     var reg2 object* stream_;
  5524.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5525.         {} # normaler Stream -> nichts zu tun
  5526.         else
  5527.         # Pretty-Print-Hilfs-Stream
  5528.         { justify_empty_2(stream_); # Streaminhalt retten
  5529.           # Streaminhalt restaurieren, d.h. Werte von SYS::*PRIN-JBSTRINGS*,
  5530.           # SYS::*PRIN-JBMODUS*, SYS::*PRIN-JBLPOS* in den Stream zurück:
  5531.          {var reg1 object stream = *stream_;
  5532.           # jetzige Line-Position retten:
  5533.           pushSTACK(TheStream(stream)->strm_pphelp_lpos);
  5534.           # alten Streaminhalt wiederherstellen:
  5535.           TheStream(stream)->strm_pphelp_strings = Symbol_value(S(prin_jbstrings));
  5536.           TheStream(stream)->strm_pphelp_modus = Symbol_value(S(prin_jbmodus));
  5537.           TheStream(stream)->strm_pphelp_lpos = Symbol_value(S(prin_jblpos));
  5538.           # Prüfe, ob die Blöcke in SYS::*PRIN-JBLOCKS* alle Einzeiler sind:
  5539.           {var reg3 object blocks = Symbol_value(S(prin_jblocks)); # SYS::*PRIN-JBLOCKS*
  5540.            do # (nichtleere) Blockliste durchgehen:
  5541.               { if (mconsp(Car(blocks))) # ein Teilblock Mehrzeiler ?
  5542.                   goto gesamt_mehrzeiler; # ja -> insgesamt ein Mehrzeiler
  5543.                 blocks = Cdr(blocks);
  5544.               }
  5545.               while (consp(blocks));
  5546.           }
  5547.           # Prüfe, ob die Blöcke in SYS::*PRIN-JBLOCKS*
  5548.           # (jeder Block Einzeiler) zusammen einen Einzeiler ergeben können:
  5549.           # Ist L=NIL (keine Randbeschränkung) oder
  5550.           # L1 + (Gesamtlänge der Blöcke) + (Anzahl der Blöcke-1) <= L ?
  5551.           { var reg5 object linelength = Symbol_value(S(prin_linelength)); # L = SYS::*PRIN-LINELENGTH*
  5552.             if (nullp(linelength)) goto gesamt_einzeiler; # =NIL -> Einzeiler
  5553.            {var reg4 uintL totalneed = posfixnum_to_L(Symbol_value(S(prin_l1))); # Summe := L1 = SYS::*PRIN-L1*
  5554.             var reg3 object blocks = Symbol_value(S(prin_jblocks)); # SYS::*PRIN-JBLOCKS*
  5555.             do # (nichtleere) Blockliste durchgehen:
  5556.                { var reg1 object block = Car(blocks); # Block (Einzeiler)
  5557.                  totalneed += TheArray(block)->dims[1] + 1; # dessen Länge+1 dazu
  5558.                  blocks = Cdr(blocks);
  5559.                }
  5560.                while (consp(blocks));
  5561.             # totalneed = L1 + (Gesamtlänge der Blöcke) + (Anzahl der Blöcke)
  5562.             # Vergleiche dies mit linelength + 1 :
  5563.             if (totalneed <= posfixnum_to_L(linelength)+1)
  5564.               { goto gesamt_einzeiler; }
  5565.               else
  5566.               { goto gesamt_mehrzeiler; }
  5567.           }}
  5568.           gesamt_einzeiler: # Insgesamt ein Einzeiler.
  5569.           # Blöcke einzeln, durch Spaces getrennt, auf den Stream ausgeben:
  5570.           { pushSTACK(nreverse(Symbol_value(S(prin_jblocks)))); # (nreverse SYS::*PRIN-JBLOCKS*)
  5571.             loop # (nichtleere) Blockliste STACK_0 durchlaufen:
  5572.               { var reg3 object block = Car(STACK_0); # nächster Block
  5573.                 # (ein Einzeiler, String ohne #\Newline)
  5574.                 STACK_0 = Cdr(STACK_0); # Blockliste verkürzen
  5575.                 write_string(stream_,block); # Block auf den Stream ausgeben
  5576.                 if (matomp(STACK_0)) break; # Restliste leer -> fertig
  5577.                 write_schar(stream_,' '); # #\Space ausgeben
  5578.               }
  5579.             goto fertig;
  5580.           }
  5581.           gesamt_mehrzeiler: # Insgesamt ein Mehrzeiler.
  5582.           # Blöcke einzeln, durch Newline getrennt, auf den Stream ausgeben:
  5583.           { pushSTACK(nreverse(Symbol_value(S(prin_jblocks)))); # (nreverse SYS::*PRIN-JBLOCKS*)
  5584.             loop # (nichtleere) Blockliste STACK_0 durchlaufen:
  5585.               { var reg3 object block = Car(STACK_0); # nächster Block
  5586.                 STACK_0 = Cdr(STACK_0); # Blockliste verkürzen
  5587.                 if (consp(block))
  5588.                   # Mehrzeiliger Teilblock
  5589.                   { # Zeilen in die richtige Reihenfolge bringen:
  5590.                     block = nreverse(block);
  5591.                     # erste Zeile auf den PPHELP-Stream ausgeben:
  5592.                     pushSTACK(block);
  5593.                     write_string(stream_,Car(block));
  5594.                     block = popSTACK();
  5595.                     # restliche Zeilen an die Zeilen im Stream vorne dranhängen:
  5596.                     stream = *stream_;
  5597.                     TheStream(stream)->strm_pphelp_strings =
  5598.                       nreconc(Cdr(block),TheStream(stream)->strm_pphelp_strings);
  5599.                   }
  5600.                   else
  5601.                   # Einzeiliger Teilblock
  5602.                   { # auf den PPHELP-Stream ausgeben:
  5603.                     write_string(stream_,block);
  5604.                   }
  5605.                 if (matomp(STACK_0)) break; # Restliste leer?
  5606.                 pphelp_newline(stream_); # neue Zeile anfangen
  5607.                 spaces(stream_,Symbol_value(S(prin_lm))); # SYS::*PRIN-LM* Spaces
  5608.               }
  5609.             stream = *stream_;
  5610.             # Line-Position zurück:
  5611.             TheStream(stream)->strm_pphelp_lpos = STACK_1;
  5612.             # GesamtModus := Mehrzeiler:
  5613.             TheStream(stream)->strm_pphelp_modus = mehrzeiler;
  5614.             goto fertig;
  5615.           }
  5616.           fertig: # Line-Position stimmt nun.
  5617.           skipSTACK(2); # leere Restliste und alte Line-Position vergessen
  5618.           # Bindungen von JUSTIFY_START rückgängig machen:
  5619.           dynamic_unbind();
  5620.           dynamic_unbind();
  5621.           dynamic_unbind();
  5622.           dynamic_unbind();
  5623.         }}
  5624.     }
  5625.  
  5626. # Indent
  5627. # ------
  5628. # Korrekt zu schachteln, jeweils 1 mal INDENT_START und 1 mal INDENT_END.
  5629.   #define INDENT_START(delta)  indent_start(stream_,delta);
  5630.   #define INDENT_END           indent_end(stream_);
  5631.  
  5632. # UP: Bindet die linken Ränder SYS::*PRIN-L1* und SYS::*PRIN-LM* an um
  5633. # delta höhere Werte.
  5634. # indent_start(&stream,delta);
  5635. # > delta: Einrückungswert
  5636. # > stream: Stream
  5637. # < stream: Stream
  5638. # verändert STACK
  5639.   local void indent_start (object* stream_, uintL delta);
  5640.   local void indent_start(stream_,delta)
  5641.     var reg1 object* stream_;
  5642.     var reg2 uintL delta;
  5643.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5644.         {} # normaler Stream -> nichts zu tun
  5645.         else
  5646.         # Pretty-Print-Hilfs-Stream
  5647.         { # SYS::*PRIN-L1* binden:
  5648.           {var reg3 object new_L1 = fixnum_inc(Symbol_value(S(prin_l1)),delta);
  5649.            dynamic_bind(S(prin_l1),new_L1);
  5650.           }
  5651.           # SYS::*PRIN-LM* binden:
  5652.           {var reg3 object new_LM = fixnum_inc(Symbol_value(S(prin_lm)),delta);
  5653.            dynamic_bind(S(prin_lm),new_LM);
  5654.           }
  5655.     }   }
  5656.  
  5657. # UP: Beendet einen Indent-Block.
  5658. # indent_end(&stream);
  5659. # > stream: Stream
  5660. # < stream: Stream
  5661. # verändert STACK
  5662.   local void indent_end (object* stream_);
  5663.   local void indent_end(stream_)
  5664.     var reg1 object* stream_;
  5665.     { if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  5666.         {} # normaler Stream -> nichts zu tun
  5667.         else
  5668.         # Pretty-Print-Hilfs-Stream
  5669.         { # die beiden Bindungen von INDENT_START auflösen:
  5670.           dynamic_unbind();
  5671.           dynamic_unbind();
  5672.     }   }
  5673.  
  5674. # Indent Preparation
  5675. # ------------------
  5676. # Dient dazu, um eine variable Zeichenzahl einzurücken.
  5677. # Korrekt zu schachteln,
  5678. #   erst 1 mal INDENTPREP_START,
  5679. #   dann einige Zeichen (kein #\Newline!)
  5680. #   und dann 1 mal INDENTPREP_END.
  5681. # Danach kann sofort mit INDENT_START fortgefahren werden.
  5682.   #define INDENTPREP_START  indentprep_start(stream_);
  5683.   #define INDENTPREP_END    indentprep_end(stream_);
  5684.  
  5685. # UP: Merkt sich die augenblickliche Position.
  5686. # indentprep_start(&stream);
  5687. # > stream: Stream
  5688. # < stream: Stream
  5689. # verändert STACK
  5690.   local void indentprep_start (object* stream_);
  5691.   local void indentprep_start(stream_)
  5692.     var reg2 object* stream_;
  5693.     { var reg1 object stream = *stream_;
  5694.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5695.         {} # normaler Stream -> nichts zu tun
  5696.         else
  5697.         # Pretty-Print-Hilfs-Stream
  5698.         { # Line-Position merken:
  5699.           pushSTACK(TheStream(stream)->strm_pphelp_lpos);
  5700.     }   }
  5701.  
  5702. # UP: Subtrahiert die Positionen, liefert die Einrückungsbreite.
  5703. # indentprep_end(&stream)
  5704. # > stream: Stream
  5705. # < stream: Stream
  5706. # < ergebnis: Einrückungsbreite
  5707. # verändert STACK
  5708.   local uintL indentprep_end (object* stream_);
  5709.   local uintL indentprep_end(stream_)
  5710.     var reg2 object* stream_;
  5711.     { var reg1 object stream = *stream_;
  5712.       if (!(TheStream(stream)->strmtype == strmtype_pphelp))
  5713.         { return 0; } # normaler Stream -> nichts zu tun
  5714.         else
  5715.         # Pretty-Print-Hilfs-Stream
  5716.         { var reg3 uintL lpos_now = # jetzige Line-Position
  5717.             posfixnum_to_L(TheStream(stream)->strm_pphelp_lpos);
  5718.           var reg4 uintL lpos_before = # gemerkte Line-Position
  5719.             posfixnum_to_L(popSTACK());
  5720.           return (lpos_now>=lpos_before ? lpos_now-lpos_before : 0);
  5721.     }   }
  5722.  
  5723. # Level
  5724. # -----
  5725. # Korrekt zu schachteln,
  5726. # jeweils 1 mal LEVEL_CHECK am Anfang einer pr_xxx-Routine
  5727. #     und 1 mal LEVEL_END am Ende.
  5728.   #define LEVEL_CHECK(cnt)  { if (level_check(stream_)) { skipSTACK(cnt); return; } }
  5729.   #define LEVEL_END    level_end(stream_)
  5730.   #define LEVEL_CHECK1(item1) \
  5731.       { var auto object *item1_ptr;           \
  5732.         pushSTACK(item1); item1_ptr=&STACK_0; \
  5733.         LEVEL_CHECK(1);                       \
  5734.         item1=*item1_ptr;                     \
  5735.       }
  5736.   #define LEVEL_CHECK3(item1,item2,item3) \
  5737.       { var auto object *item1_ptr;           \
  5738.         var auto object *item2_ptr;           \
  5739.         var auto object *item3_ptr;           \
  5740.         pushSTACK(item1); item1_ptr=&STACK_0; \
  5741.         pushSTACK(item2); item2_ptr=&STACK_0; \
  5742.         pushSTACK(item3); item3_ptr=&STACK_0; \
  5743.         LEVEL_CHECK(3);                       \
  5744.         item1=*item1_ptr;                     \
  5745.         item2=*item2_ptr;                     \
  5746.         item3=*item3_ptr;                     \
  5747.       }
  5748.   #define LEVEL_END1 { LEVEL_END; skipSTACK(1); }
  5749.   #define LEVEL_END3 { LEVEL_END; skipSTACK(3); }
  5750.  
  5751.  
  5752. # UP: Gibt die Darstellung eines LISP-Objektes bei Überschreitung von
  5753. # *PRINT-LEVEL* aus.
  5754. # pr_level(&stream);
  5755. # > stream: Stream
  5756. # < stream: Stream
  5757. # kann GC auslösen
  5758.   local void pr_level (object* stream_);
  5759.   local void pr_level(stream_)
  5760.     var reg1 object* stream_;
  5761.     { write_schar(stream_,'#'); }
  5762.  
  5763. # UP: Testet, ob SYS::*PRIN-LEVEL* den Wert von *PRINT-LEVEL* erreicht hat.
  5764. # Wenn ja, nur '#' ausgeben und Rücksprung aus dem aufrufenden UP (!).
  5765. # Wenn nein, wird SYS::*PRIN-LEVEL* incrementiert gebunden.
  5766. # if (level_check(&stream)) return;
  5767. # > stream: Stream
  5768. # < stream: Stream
  5769. # Wenn ja: kann GC auslösen
  5770. # Wenn nein: verändert STACK
  5771.   local boolean level_check (object* stream_);
  5772.   local boolean level_check(stream_)
  5773.     var reg3 object* stream_;
  5774.     { var reg2 object level = Symbol_value(S(prin_level)); # SYS::*PRIN-LEVEL*, ein Fixnum >=0
  5775.       var reg1 object limit = Symbol_value(S(print_level)); # *PRINT-LEVEL*
  5776.       if (!test_value(S(print_readably))
  5777.           && posfixnump(limit) # Beschränkung vorhanden?
  5778.           && (posfixnum_to_L(level) >= posfixnum_to_L(limit)) # und erreicht oder überschritten?
  5779.          )
  5780.         # ja -> '#' ausgeben und herausspringen:
  5781.         { pr_level(stream_); return TRUE; }
  5782.         else
  5783.         # nein -> *PRINT-LEVEL* noch unerreicht.
  5784.         { # binde SYS::*PRIN-LEVEL* an (1+ SYS::*PRIN-LEVEL*) :
  5785.           level = fixnum_inc(level,1); # (incf level)
  5786.           dynamic_bind(S(prin_level),level);
  5787.           return FALSE;
  5788.     }   }
  5789.  
  5790. # UP: Beendet einen Block mit erhöhtem SYS::*PRIN-LEVEL*.
  5791. # level_end(&stream);
  5792. # > stream: Stream
  5793. # < stream: Stream
  5794. # verändert STACK
  5795.   local void level_end (object* stream_);
  5796.   local void level_end(stream_)
  5797.     var reg1 object* stream_;
  5798.     { dynamic_unbind(); }
  5799.  
  5800. # Length
  5801. # ------
  5802.  
  5803. # UP: Liefert die Längengrenze für strukturierte Objekte wie z.B. Listen.
  5804. # get_print_length()
  5805. # < ergebnis: Längengrenze
  5806.   local uintL get_print_length (void);
  5807.   local uintL get_print_length()
  5808.     { var reg1 object limit = Symbol_value(S(print_length)); # *PRINT-LENGTH*
  5809.       return (!test_value(S(print_readably))
  5810.               && posfixnump(limit) # ein Fixnum >=0 ?
  5811.               ? posfixnum_to_L(limit) # ja
  5812.               : ~(uintL)0             # nein -> Grenze "unendlich"
  5813.              );
  5814.     }
  5815.  
  5816.  
  5817. # ------------------------ Haupt-PRINT-Routine --------------------------------
  5818.  
  5819. # UP: Stellt fest, ob ein Objekt wegen *PRINT-CIRCLE* in #n= oder #n# -
  5820. # Schreibweise ausgegeben werden muß.
  5821. # circle_p(obj)
  5822. # > obj: Objekt
  5823. # < ergebnis: NULL, falls obj normal auszugeben ist
  5824. #      sonst: ergebnis->flag: TRUE, falls obj als #n=... auszugeben ist
  5825. #                             FALSE, falls obj als #n# auszugeben ist
  5826. #             ergebnis->n: n
  5827. #             ergebnis->ptr: Im Fall #n=... ist vor der Ausgabe
  5828. #                            das Fixnum *ptr zu incrementieren.
  5829.   typedef struct { boolean flag; uintL n; object* ptr; }  circle_info;
  5830.   local circle_info* circle_p (object obj);
  5831.   local circle_info* circle_p(obj)
  5832.     var reg3 object obj;
  5833.     { # *PRINT-CIRCLE* abfragen:
  5834.       if (test_value(S(print_circle)))
  5835.         { var reg5 object table = Symbol_value(S(print_circle_table)); # SYS::*PRINT-CIRCLE-TABLE*
  5836.           if (!simple_vector_p(table)) # sollte ein Simple-Vector sein !
  5837.             { bad_table:
  5838.               dynamic_bind(S(print_circle),NIL); # *PRINT-CIRCLE* an NIL binden
  5839.               pushSTACK(S(print_circle_table)); # SYS::*PRINT-CIRCLE-TABLE*
  5840.               pushSTACK(S(print));
  5841.               //: DEUTSCH "~: Der Wert von ~ wurde von außen verändert."
  5842.               //: ENGLISH "~: the value of ~ has been arbitrarily altered"
  5843.               //: FRANCAIS "~ : La valeur de ~ fut modifiée extérieurement."
  5844.               fehler(error, GETTEXT("~: the value of ~ has been arbitrarily altered"));
  5845.             }
  5846.           # Durch den Vektor table = #(i ...) mit m+1 (0<=i<=m) Elementen
  5847.           # durchlaufen:
  5848.           # Kommt obj unter den Elementen 1,...,i vor -> Fall FALSE, n:=Index.
  5849.           # Kommt obj unter den Elementen i+1,...,m vor -> bringe
  5850.           #   obj an die Stelle i+1, Fall TRUE, n:=i+1, nachher i:=i+1.
  5851.           # Sonst Fall NULL.
  5852.           { local circle_info info; # Platz für die Rückgabe der Werte
  5853.             var reg4 uintL m1 = TheSvector(table)->length; # Länge m+1
  5854.             if (m1==0) goto bad_table; # sollte >0 sein!
  5855.            {var reg1 object* ptr = &TheSvector(table)->data[0]; # Pointer in den Vektor
  5856.             var reg6 uintL i = posfixnum_to_L(*ptr++); # erstes Element i
  5857.             var reg2 uintL index = 1;
  5858.             until (index == m1) # Schleife m mal durchlaufen
  5859.               { if (eq(*ptr++,obj)) # obj mit nächstem Vektor-Element vergleichen
  5860.                   goto found;
  5861.                 index++;
  5862.               }
  5863.             # nicht gefunden -> fertig
  5864.             goto normal;
  5865.             found: # obj als Vektor-Element index gefunden, 1 <= index <= m,
  5866.                    # ptr = &TheSvector(table)->data[index+1] .
  5867.             if (index <= i)
  5868.               # obj ist als #n# auszugeben, n=index.
  5869.               { info.flag = FALSE; info.n = index; return &info; }
  5870.               else
  5871.               # obj an Position i+1 bringen:
  5872.               { i = i+1;
  5873.                 # (rotatef (svref Vektor i) (svref Vektor index)) :
  5874.                 { var reg7 object* ptr_i = &TheSvector(table)->data[i];
  5875.                   *--ptr = *ptr_i; *ptr_i = obj;
  5876.                 }
  5877.                 # obj ist als #n=... auszugeben, n=i.
  5878.                 info.flag = TRUE; info.n = i;
  5879.                 info.ptr = &TheSvector(table)->data[0]; # nachher i im Vektor erhöhen
  5880.                 return &info;
  5881.               }
  5882.         } }}
  5883.       normal: # obj ist normal auszugeben
  5884.         return (circle_info*)NULL;
  5885.     }
  5886.  
  5887. # Eine pr_xxx-Routine bekommt &stream und obj übergeben:
  5888.   typedef void pr_routine (object* stream_, object obj);
  5889.  
  5890. # UP: Überprüft, ob ein Objekt eine Zirkularität ist, und gibt es in
  5891. # diesem Falle als #n# oder mit #n=-Präfix (und sonst normal) aus.
  5892. # pr_circle_(&stream,obj_,&pr_xxx);
  5893. # > obj: Objekt
  5894. # > pr_xxx: Ausgabe-Routine, die &stream und obj übergeben bekommt
  5895. # > stream: Stream
  5896. # < stream: Stream
  5897. # kann GC auslösen
  5898.   local void pr_circle_ (object* stream_, object *obj_, pr_routine* pr_xxx);
  5899.   local void pr_circle_(stream_,obj_,pr_xxx)
  5900.     var reg1 object* stream_;
  5901.     var reg3 object *obj_;
  5902.     var reg4 pr_routine* pr_xxx;
  5903.     { # Feststellen, ob Zirkularität:
  5904.       var reg2 circle_info* info;
  5905.       info = circle_p(*obj_);
  5906.       if (info == (circle_info*)NULL)
  5907.         # keine Zirkularität, obj normal ausgeben:
  5908.         { (*pr_xxx)(stream_,*obj_); }
  5909.         else
  5910.         # Zirkularität
  5911.         if (info->flag)
  5912.           # obj als #n=... ausgeben:
  5913.           { # erst noch für circle_p das Fixnum im Vektor incrementieren:
  5914.             { var reg1 object* ptr = info->ptr;
  5915.               *ptr = fixnum_inc(*ptr,1);
  5916.             }
  5917.             { var reg5 uintL n = info->n;
  5918.               pushSTACK(*obj_); # obj retten
  5919.               # Präfix ausgeben und Einrückungstiefe berechnen:
  5920.               INDENTPREP_START;
  5921.               write_schar(stream_,'#');
  5922.               pr_uint(stream_,n);
  5923.               write_schar(stream_,'=');
  5924.             }
  5925.             { var reg5 uintL indent = INDENTPREP_END;
  5926.               # obj (eingerückt) ausgeben:
  5927.               skipSTACK(1);
  5928.               INDENT_START(indent);
  5929.               (*pr_xxx)(stream_,*obj_);
  5930.               INDENT_END;
  5931.           } }
  5932.           else
  5933.           # obj als #n# ausgeben:
  5934.           { var reg5 uintL n = info->n;
  5935.             write_schar(stream_,'#');
  5936.             pr_uint(stream_,n);
  5937.             write_schar(stream_,'#');
  5938.           }
  5939.     }
  5940.  
  5941. # Nun kommen die einzelnen pr_xxx-Routinen:
  5942.   local_function pr_routine prin_object;
  5943.   local_function pr_routine prin_object_dispatch;
  5944.   local_function pr_routine pr_symbol;
  5945.   local_function pr_routine pr_symbol_part;
  5946.   local_function pr_routine pr_like_symbol;
  5947.   local_function pr_routine pr_character;
  5948.   local_function pr_routine pr_string;
  5949.   local_function pr_routine pr_list;
  5950.   local_function pr_routine pr_cons;
  5951.   local_function pr_routine pr_list_quote;
  5952.   local_function pr_routine pr_list_function;
  5953.   local_function pr_routine pr_list_backquote;
  5954.   local_function pr_routine pr_list_splice;
  5955.   local_function pr_routine pr_list_nsplice;
  5956.   local_function pr_routine pr_list_unquote;
  5957.   local_function pr_routine pr_real_number;
  5958.   local_function pr_routine pr_number;
  5959.   local_function pr_routine pr_array_nil;
  5960.   local_function pr_routine pr_bvector;
  5961.   local_function pr_routine pr_vector;
  5962.   local_function pr_routine pr_array;
  5963.   local_function pr_routine pr_structure;
  5964.   local_function pr_routine pr_machine;
  5965.   local_function pr_routine pr_system;
  5966.   local_function pr_routine pr_orecord;
  5967.   local_function pr_routine pr_subr;
  5968.   local_function pr_routine pr_fsubr;
  5969.   local_function pr_routine pr_closure;
  5970.   local_function pr_routine pr_cclosure;
  5971.   local_function pr_routine pr_cclosure_lang;
  5972.   local_function pr_routine pr_cclosure_codevector;
  5973.   local_function pr_routine pr_stream;
  5974.   local_function pr_routine pr_instance;
  5975.  
  5976. # UP: Gibt ein Objekt auf einen Stream aus.
  5977. # prin_object_(&stream,obj_);
  5978. # > obj_: &Objekt
  5979. # > stream: Stream
  5980. # < stream: Stream
  5981. # kann GC auslösen
  5982.   local void prin_object_ (object *stream_,object *obj_);
  5983.   local void prin_object_(stream_,obj_)
  5984.     var reg2 object* stream_;
  5985.     var reg1 object* obj_;
  5986.     { restart_it:
  5987.       # Auf Tastatur-Interrupt testen:
  5988.       interruptp(
  5989.         { pushSTACK(S(print)); tast_break(); # PRINT ruft Break-Schleife auf
  5990.           goto restart_it;
  5991.         }
  5992.         );
  5993.       # auf Stacküberlauf testen:
  5994.       check_SP(); check_STACK();
  5995.       # Zirkularität behandeln:
  5996.       pr_circle_(stream_,obj_,&prin_object_dispatch);
  5997.     }
  5998.  
  5999. # UP: Gibt ein Objekt auf einen Stream aus.
  6000. # prin_object(&stream,obj);
  6001. # > obj: Objekt
  6002. # > stream: Stream
  6003. # < stream: Stream
  6004. # kann GC auslösen
  6005.   local void prin_object (object *stream_,object obj);
  6006.   local void prin_object(stream_,obj)
  6007.     var reg2 object* stream_;
  6008.     var reg1 object obj;
  6009.     {
  6010.       pushSTACK(obj);
  6011.       prin_object_(stream_,&STACK_0);
  6012.       skipSTACK(1);
  6013.     }
  6014.  
  6015.   local void prin_object_dispatch (object *stream_,object obj);
  6016.   local void prin_object_dispatch(stream_,obj)
  6017.     var reg2 object* stream_;
  6018.     var reg1 object obj;
  6019.     { # Nach der Typinfo verzweigen:
  6020.       switch (typecode(obj))
  6021.         { case_machine: # Maschinenpointer
  6022.             pr_machine(stream_,obj); break;
  6023.           case_obvector: # Bit/Byte-Vektor
  6024.             if (!((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_Bit))
  6025.               { pr_vector(stream_,obj); break; } # Byte-Vektor
  6026.           case_sbvector: # Bit-Vektor
  6027.             pr_bvector(stream_,obj); break;
  6028.           case_string: # String
  6029.             pr_string(stream_,obj); break;
  6030.           case_vector: # (vector t)
  6031.             pr_vector(stream_,obj); break;
  6032.           case_array1: # allgemeiner Array
  6033.             pr_array(stream_,obj); break;
  6034.           case_closure: # Closure
  6035.             pr_closure(stream_,obj); break;
  6036.           case_instance: # CLOS-Instanz
  6037.             pr_instance(stream_,obj); break;
  6038.           #ifdef case_structure
  6039.           case_structure: # Structure
  6040.             pr_structure(stream_,obj); break;
  6041.           #endif
  6042.           #ifdef case_stream
  6043.           case_stream: # Stream
  6044.             pr_stream(stream_,obj); break;
  6045.           #endif
  6046.           case_orecord: # OtherRecord
  6047.             pr_orecord(stream_,obj); break;
  6048.           case_char: # Character
  6049.             pr_character(stream_,obj); break;
  6050.           case_subr: # SUBR
  6051.             pr_subr(stream_,obj); break;
  6052.           case_system: # Frame-Pointer, Read-Label, System
  6053.             pr_system(stream_,obj); break;
  6054.           case_number: # Zahl
  6055.             pr_number(stream_,obj); break;
  6056.           case_symbol: # Symbol
  6057.             pr_symbol(stream_,obj); break;
  6058.           case_cons: # Cons
  6059.             pr_cons(stream_,obj); break;
  6060.           default: NOTREACHED
  6061.         }
  6062.     }
  6063.  
  6064.  
  6065. # ------------- PRINT-Routinen für verschiedene Datentypen --------------------
  6066.  
  6067. #                      -------- Symbole --------
  6068.  
  6069. # UP: Gibt ein Symbol auf einen Stream aus.
  6070. # pr_symbol(&stream,sym);
  6071. # > sym: Symbol
  6072. # > stream: Stream
  6073. # < stream: Stream
  6074. # kann GC auslösen
  6075.   local void pr_symbol (object *stream_,object sym);
  6076.   local void pr_symbol(stream_,sym)
  6077.     var reg2 object* stream_;
  6078.     var reg1 object sym;
  6079.     { # *PRINT-ESCAPE* abfragen:
  6080.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6081.         # mit Escape-Zeichen und evtl. Packagenamen:
  6082.         { if (!accessiblep(sym,get_current_package()))
  6083.             # Falls Symbol accessible und nicht verdeckt,
  6084.             # keinen Packagenamen und keine Packagemarker ausgeben.
  6085.             # Sonst:
  6086.             { var reg3 object home;
  6087.               pushSTACK(sym); # Symbol retten
  6088.               if (keywordp(sym)) # Keyword ?
  6089.                 goto one_marker; # ja -> nur 1 Packagemarker ausgeben
  6090.               home = Symbol_package(sym); # Home-package des Symbols
  6091.               if (nullp(home))
  6092.                 # uninterniertes Symbol ausgeben
  6093.                 { # *PRINT-GENSYM* abfragen:
  6094.                   if (test_value(S(print_gensym)) || test_value(S(print_readably)))
  6095.                     # Syntax #:name verwenden
  6096.                     { write_schar(stream_,'#'); goto one_marker; }
  6097.                     # sonst ohne Präfix ausgeben
  6098.                 }
  6099.                 else
  6100.                 # Symbol mit Packagenamen und 1 oder 2 Packagemarkern ausgeben
  6101.                 { pushSTACK(home); # Home-Package retten
  6102.                   pr_symbol_part(stream_,ThePackage(home)->pack_name); # Packagenamen ausgeben
  6103.                   home = popSTACK(); # Home-Package zurück
  6104.                   # Symbol extern in seiner Home-Package?
  6105.                   if (externalp(STACK_0,home))
  6106.                     goto one_marker; # ja -> 1 Packagemarker
  6107.                   write_schar(stream_,':'); # sonst 2 Packagemarker
  6108.                   one_marker:
  6109.                   write_schar(stream_,':');
  6110.                 }
  6111.               sym = popSTACK(); # sym zurück
  6112.             }
  6113.           pr_symbol_part(stream_,Symbol_name(sym)); # Symbolnamen ausgeben
  6114.         }
  6115.         else
  6116.         # Symbol ohne Escape-Zeichen ausgeben:
  6117.         # nur den Symbolnamen unter Kontrolle von *PRINT-CASE* ausgeben
  6118.         { write_sstring_case(stream_,Symbol_name(sym)); }
  6119.     }
  6120.  
  6121. # UP: Gibt einen Symbol-Teil (Packagename oder Symbolname) mit Escape-Zeichen
  6122. # aus.
  6123. # pr_symbol_part(&stream,string);
  6124. # > string: Simple-String
  6125. # > stream: Stream
  6126. # < stream: Stream
  6127. # kann GC auslösen
  6128.   local void pr_symbol_part (object *stream_,object string);
  6129.   local void pr_symbol_part(stream_,string)
  6130.     var reg7 object* stream_;
  6131.     var reg8 object string;
  6132.     { # Feststellen, ob der Name ohne |...| außenrum ausgegeben werden kann:
  6133.       # Dies kann er dann, wenn er:
  6134.       # 1. nicht leer ist und
  6135.       # 2. mit einem Character mit Syntaxcode Constituent anfängt und
  6136.       # 3. nur aus Characters mit Syntaxcode Constituent oder
  6137.       #    Nonterminating Macro besteht und
  6138.       # 4. keine Klein-/Großbuchstaben (je nach readtable_case)
  6139.       #    und keine Doppelpunkte enthält und
  6140.       # 5. nicht Potential-Number Syntax (mit *PRINT-BASE* als Basis) hat.
  6141.       var reg4 uintL len = TheSstring(string)->length; # Länge
  6142.       # Bedingung 1 überprüfen:
  6143.       if (len==0) goto surround; # Länge=0 -> muß |...| verwenden
  6144.       # Bedingungen 2-4 überprüfen:
  6145.       { # Brauche die Attributcodetabelle und die aktuelle Syntaxcodetabelle:
  6146.         var reg5 uintB* syntax_table; # Syntaxcodetabelle, RM_anzahl Elemente
  6147.         var reg6 uintW rtcase; # readtable-case
  6148.         { var reg1 object readtable;
  6149.           get_readtable(readtable = ); # aktuelle Readtable
  6150.           syntax_table = &TheSbvector(TheReadtable(readtable)->readtable_syntax_table)->data[0];
  6151.           rtcase = posfixnum_to_L(TheReadtable(readtable)->readtable_case);
  6152.         }
  6153.         # String durchlaufen:
  6154.         { var reg2 uintB* charptr = &TheSstring(string)->data[0];
  6155.           var reg3 uintL count = len;
  6156.           var reg1 uintB c = *charptr++; # erstes Character
  6157.           # sein Syntaxcode soll Constituent sein:
  6158.           if (!(syntax_table[c] == syntax_constituent))
  6159.             goto surround; # nein -> muß |...| verwenden
  6160.           loop
  6161.             { if (attribute_table[c] == a_pack_m) # Attributcode Package-Marker ?
  6162.                 goto surround; # ja -> muß |...| verwenden
  6163.               switch (rtcase)
  6164.                 { case case_upcase:
  6165.                     if (!(c == up_case(c))) # war c ein Kleinbuchstabe?
  6166.                       goto surround; # ja -> muß |...| verwenden
  6167.                     break;
  6168.                   case case_downcase:
  6169.                     if (!(c == down_case(c))) # war c ein Großbuchstabe?
  6170.                       goto surround; # ja -> muß |...| verwenden
  6171.                     break;
  6172.                   case case_preserve:
  6173.                     break;
  6174.                   default: NOTREACHED
  6175.                 }
  6176.               count--; if (count == 0) break; # String zu Ende -> Schleifenende
  6177.               c = *charptr++; # nächstes Character
  6178.               switch (syntax_table[c]) # sein Syntaxcode
  6179.                 { case syntax_constituent:
  6180.                   case syntax_nt_macro:
  6181.                     break;
  6182.                   default: # Syntaxcode /= Constituent, Nonterminating Macro
  6183.                     goto surround; # -> muß |...| verwenden
  6184.                 }
  6185.             }
  6186.       } }
  6187.       # Bedingung 5 überprüfen:
  6188.       { pushSTACK(string); # String retten
  6189.         get_buffers(); # zwei Buffer allozieren, in den STACK
  6190.         # und füllen:
  6191.         { var reg2 uintL index = 0;
  6192.           until (index == len)
  6193.             { var reg1 uintB c = TheSstring(STACK_2)->data[index]; # nächstes Character
  6194.               ssstring_push_extend(STACK_1,c); # in den Character-Buffer
  6195.               ssstring_push_extend(STACK_0,attribute_table[c]); # und in den Attributcode-Buffer
  6196.               index++;
  6197.         }   }
  6198.         O(token_buff_2) = popSTACK(); # Attributcode-Buffer
  6199.         O(token_buff_1) = popSTACK(); # Character-Buffer
  6200.         string = popSTACK(); # String zurück
  6201.         if (test_dots()) goto surround; # nur Punkte -> muß |...| verwenden
  6202.         # Potential-Number-Syntax?
  6203.         { var uintWL base = get_print_base(); # Wert von *PRINT-BASE*
  6204.           var token_info info;
  6205.           if (test_potential_number_syntax(&base,&info))
  6206.             goto surround; # ja -> muß |...| verwenden
  6207.       } }
  6208.       # Name kann ohne Escape-Characters ausgegeben werden.
  6209.       # Dabei jedoch *PRINT-CASE* beachten:
  6210.       write_sstring_case(stream_,string);
  6211.       return;
  6212.       surround: # Namen unter Verwendung der Escape-Character |...| ausgeben:
  6213.       { # Syntaxcodetabelle holen:
  6214.         { var reg1 object readtable;
  6215.           get_readtable(readtable = ); # aktuelle Readtable
  6216.           pushSTACK(TheReadtable(readtable)->readtable_syntax_table);
  6217.         }
  6218.         pushSTACK(string);
  6219.         # Stackaufbau: syntax_table, string.
  6220.         write_schar(stream_,'|');
  6221.         { var reg2 uintL index = 0;
  6222.           until (index == len)
  6223.             { var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nächstes Character
  6224.               switch (TheSbvector(STACK_1)->data[c]) # dessen Syntaxcode
  6225.                 { case syntax_single_esc:
  6226.                   case syntax_multi_esc:
  6227.                     # Dem Escape-Character c wird ein '\' vorangestellt:
  6228.                     write_schar(stream_,'\\');
  6229.                   default: ;
  6230.                 }
  6231.               write_schar(stream_,c); # Character ausgeben
  6232.               index++;
  6233.         }   }
  6234.         write_schar(stream_,'|');
  6235.         skipSTACK(2);
  6236.       }
  6237.     }
  6238.  
  6239. # UP: Gibt einen Simple-String wie einen Symbol-Teil aus.
  6240. # pr_like_symbol(&stream,string);
  6241. # > string: Simple-String
  6242. # > stream: Stream
  6243. # < stream: Stream
  6244. # kann GC auslösen
  6245.   local void pr_like_symbol (object *stream_,object string);
  6246.   local void pr_like_symbol(stream_,string)
  6247.     var reg1 object* stream_;
  6248.     var reg2 object string;
  6249.     { # *PRINT-ESCAPE* abfragen:
  6250.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6251.         { pr_symbol_part(stream_,string); } # mit Escape-Zeichen ausgeben
  6252.         else
  6253.         { write_sstring_case(stream_,string); } # ohne Escape-Zeichen ausgeben
  6254.     }
  6255.  
  6256. #                      -------- Characters --------
  6257.  
  6258. # UP: Gibt ein Character auf einen Stream aus.
  6259. # pr_character(&stream,ch);
  6260. # > ch: Character
  6261. # > stream: Stream
  6262. # < stream: Stream
  6263. # kann GC auslösen
  6264.   local void pr_character (object *stream_,object ch);
  6265.   local void pr_character(stream_,ch)
  6266.     var reg4 object* stream_;
  6267.     var reg6 object ch;
  6268.     { # *PRINT-ESCAPE* abfragen:
  6269.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6270.         # Character mit Escape-Zeichen ausgeben.
  6271.         # Syntax:  # [font] \ char
  6272.         # bzw.     # [font] \ charname
  6273.         # bzw.     # [font] \ bitname - ... - bitname - [\] char
  6274.         # bzw.     # [font] \ bitname - ... - bitname - charname
  6275.         { var reg2 cint c = char_int(ch);
  6276.           write_schar(stream_,'#');
  6277.          {var reg1 cint font = (c >> char_font_shift_c) & (char_font_limit-1); # Font
  6278.           if (!(font==0)) # Falls font /=0 :
  6279.             { pr_uint(stream_,font); } # Fontnummer dezimal ausgeben
  6280.          }
  6281.           write_schar(stream_,'\\');
  6282.          {var reg1 cint bits = (c >> char_bits_shift_c) & (char_bits_limit-1); # Bits
  6283.           if (bits==0)
  6284.             # keine Bits auszugeben ->
  6285.             # Syntax  # [font] \ char  oder  # [font] \ charname
  6286.             { var reg3 uintB code = (c >> char_code_shift_c) & (char_code_limit-1); # Code
  6287.               var reg5 object charname = char_name(code); # Name des Characters
  6288.               if (nullp(charname))
  6289.                 # kein Name vorhanden
  6290.                 { write_schar(stream_,code); }
  6291.                 else
  6292.                 # Namen (Simple-String) ausgeben
  6293.                 { write_sstring_case(stream_,charname); }
  6294.             }
  6295.             else
  6296.             # Es sind Bits auszugeben
  6297.             { # Bitnamen ausgeben:
  6298.               { var reg3 object* bitnameptr = &O(bitname_0);
  6299.                 var reg5 uintC count;
  6300.                 dotimesC(count,char_bits_len_c, # alle Bits und Bitnamen durchgehen
  6301.                   { if (bits & bit(0))
  6302.                       # Bit war gesetzt -> Bitnamen *bitnameptr ausgeben:
  6303.                       { write_sstring_case(stream_,*bitnameptr);
  6304.                         write_schar(stream_,'-');
  6305.                       }
  6306.                     bits = bits >> 1;
  6307.                     bitnameptr++;
  6308.                   });
  6309.               }
  6310.               # Noch auszugeben:  charname  oder  [\]char
  6311.               { var reg3 uintB code = (c >> char_code_shift_c) & (char_code_limit-1); # Code
  6312.                 var reg5 object charname = char_name(code); # Name des Characters
  6313.                 if (nullp(charname))
  6314.                   # kein Name vorhanden
  6315.                   { # code selbst ausgeben.
  6316.                     # Falls es
  6317.                     # - den Syntaxcode Constituent oder Nonterminating Macro hat und
  6318.                     # - in der Groß-/Klein-Schreibung zur readtable-case paßt,
  6319.                     # kann man sich den '\' sparen:
  6320.                     { var reg7 object readtable;
  6321.                       get_readtable(readtable = ); # aktuelle Readtable
  6322.                       switch ((uintW)posfixnum_to_L(TheReadtable(readtable)->readtable_case))
  6323.                         { case case_upcase:
  6324.                             if (!(code == up_case(code))) # code ein Kleinbuchstabe?
  6325.                               goto backslash; # ja -> Backslash nötig
  6326.                             break;
  6327.                           case case_downcase:
  6328.                             if (!(code == down_case(code))) # code ein Großbuchstabe?
  6329.                               goto backslash; # ja -> Backslash nötig
  6330.                             break;
  6331.                           case case_preserve:
  6332.                             break;
  6333.                           default: NOTREACHED
  6334.                         }
  6335.                       # Syntaxcode-Tabelle holen:
  6336.                      {var reg8 object syntax_table = TheReadtable(readtable)->readtable_syntax_table; # Syntaxcode-Tabelle
  6337.                       switch (TheSbvector(syntax_table)->data[code]) # Syntaxcode
  6338.                         { case syntax_constituent:
  6339.                           case syntax_nt_macro:
  6340.                             # Syntaxcode Constituent oder Nonterminating Macro
  6341.                             goto no_backslash; # kein '\' nötig
  6342.                           default: ;
  6343.                     }}  }
  6344.                     backslash:
  6345.                     write_schar(stream_,'\\');
  6346.                     no_backslash:
  6347.                     write_schar(stream_,code);
  6348.                   }
  6349.                   else
  6350.                   # Namen (Simple-String) ausgeben
  6351.                   { write_sstring_case(stream_,charname); }
  6352.             } }
  6353.         }}
  6354.         else
  6355.         # Character ohne Escape-Zeichen ausgeben
  6356.         { write_char(stream_,ch); } # ch selbst ausgeben
  6357.     }
  6358.  
  6359. #                      -------- Strings --------
  6360.  
  6361. # UP: Gibt einen Teil eines Simple-String auf einen Stream aus.
  6362. # pr_sstring_ab(&stream,string,start,len);
  6363. # > string: Simple-String
  6364. # > start: Startindex
  6365. # > len: Anzahl der auszugebenden Zeichen
  6366. # > stream: Stream
  6367. # < stream: Stream
  6368. # kann GC auslösen
  6369.   local void pr_sstring_ab (object* stream_, object string, uintL start, uintL len);
  6370.   local void pr_sstring_ab(stream_,string,start,len)
  6371.     var reg4 object* stream_;
  6372.     var reg6 object string;
  6373.     var reg5 uintL start;
  6374.     var reg3 uintL len;
  6375.     { # *PRINT-ESCAPE* abfragen:
  6376.       if (test_value(S(print_escape)) || test_value(S(print_readably)))
  6377.         # mit Escape-Zeichen:
  6378.         { var reg2 uintL index = start;
  6379.           pushSTACK(string); # Simple-String retten
  6380.           write_schar(stream_,'"'); # vorher ein Anführungszeichen
  6381.           #ifndef STRM_WR_SS
  6382.           dotimesL(len,len,
  6383.             { var reg1 uintB c = TheSstring(STACK_0)->data[index]; # nächstes Zeichen
  6384.               # bei c = #\" oder c = #\\ erst noch ein '\' ausgeben:
  6385.               if ((c=='"') || (c=='\\')) { write_schar(stream_,'\\'); }
  6386.               write_schar(stream_,c);
  6387.               index++;
  6388.             });
  6389.           #else # dasselbe, etwas optimiert
  6390.           { var reg5 uintL index0 = index;
  6391.             loop
  6392.               { # Suche den nächsten #\" oder #\\ :
  6393.                 string = STACK_0;
  6394.                 while (len > 0)
  6395.                   { var reg1 uintB c = TheSstring(string)->data[index];
  6396.                     if ((c=='"') || (c=='\\')) break;
  6397.                     index++; len--;
  6398.                   }
  6399.                 if (!(index==index0))
  6400.                   { write_sstring_ab(stream_,string,index0,index-index0); }
  6401.                 if (len==0) break;
  6402.                 write_schar(stream_,'\\');
  6403.                 index0 = index; index++; len--;
  6404.           }   }
  6405.           #endif
  6406.           write_schar(stream_,'"'); # nachher ein Anführungszeichen
  6407.           skipSTACK(1);
  6408.         }
  6409.         else
  6410.         # ohne Escape-Zeichen: nur write_sstring_ab
  6411.         { write_sstring_ab(stream_,string,start,len); }
  6412.     }
  6413.  
  6414. # UP: Gibt einen String auf einen Stream aus.
  6415. # pr_string(&stream,string);
  6416. # > string: String
  6417. # > stream: Stream
  6418. # < stream: Stream
  6419. # kann GC auslösen
  6420.   local void pr_string (object *stream_,object string);
  6421.   local void pr_string(stream_,string)
  6422.     var reg2 object* stream_;
  6423.     var reg1 object string;
  6424.     { var reg3 uintL len = vector_length(string); # Länge
  6425.       var uintL offset = 0; # Offset vom String in den Datenvektor
  6426.       var reg4 object sstring = array_displace_check(string,len,&offset); # Datenvektor
  6427.       pr_sstring_ab(stream_,sstring,offset,len);
  6428.     }
  6429.  
  6430. #                    -------- Conses, Listen --------
  6431.  
  6432. # UP: Stellt fest, ob ein Cons auf eine spezielle Art und Weise auszugeben
  6433. # ist.
  6434. # special_list_p(obj)
  6435. # > obj: Objekt, ein Cons
  6436. # < ergebnis: Adresse der entsprechenden pr_list_xxx-Routine, falls ja,
  6437. #             NULL, falls nein.
  6438.   local pr_routine* special_list_p (object obj);
  6439.   local pr_routine* special_list_p(obj)
  6440.     var reg2 object obj;
  6441.     { # Spezielle Listen sind die der Form
  6442.       # (QUOTE a), (FUNCTION a), (SYS::BACKQUOTE a [b]) und
  6443.       # (SYS::SPLICE a), (SYS::NSPLICE a), (SYS::UNQUOTE a)
  6444.       # falls SYS::*PRIN-BQLEVEL* > 0
  6445.       var reg1 object head = Car(obj);
  6446.       var reg3 pr_routine* pr_xxx;
  6447.       if (eq(head,S(quote))) # QUOTE
  6448.         { pr_xxx = &pr_list_quote; goto test2; }
  6449.       elif (eq(head,S(function))) # FUNCTION
  6450.         { pr_xxx = &pr_list_function; goto test2; }
  6451.       elif (eq(head,S(backquote))) # SYS::BACKQUOTE
  6452.         { pr_xxx = &pr_list_backquote;
  6453.           # Teste noch, ob obj eine Liste der Länge 2 oder 3 ist.
  6454.           obj = Cdr(obj); # Der CDR
  6455.           if (consp(obj) && # muß ein Cons sein,
  6456.               (obj = Cdr(obj), # der CDDR
  6457.                (atomp(obj) ? nullp(obj) : nullp(Cdr(obj))) # NIL oder eine einelementige Liste
  6458.              ))
  6459.             { return pr_xxx; }
  6460.             else
  6461.             { return (pr_routine*)NULL; }
  6462.         }
  6463.       elif (eq(head,S(splice))) # SYS::SPLICE
  6464.         { pr_xxx = &pr_list_splice; goto test2bq; }
  6465.       elif (eq(head,S(nsplice))) # SYS::NSPLICE
  6466.         { pr_xxx = &pr_list_nsplice; goto test2bq; }
  6467.       elif (eq(head,S(unquote))) # SYS::UNQUOTE
  6468.         { pr_xxx = &pr_list_unquote; goto test2bq; }
  6469.       else
  6470.         { return (pr_routine*)NULL; }
  6471.       test2bq: # Teste noch, ob SYS::*PRIN-BQLEVEL* > 0 und
  6472.                # obj eine Liste der Länge 2 ist.
  6473.         { var reg4 object bqlevel = Symbol_value(S(prin_bqlevel));
  6474.           if (!(posfixnump(bqlevel) && !eq(bqlevel,Fixnum_0)))
  6475.             { return (pr_routine*)NULL; }
  6476.         }
  6477.       test2: # Teste noch, ob obj eine Liste der Länge 2 ist.
  6478.         if (mconsp(Cdr(obj)) && nullp(Cdr(Cdr(obj))))
  6479.           { return pr_xxx; }
  6480.           else
  6481.           { return (pr_routine*)NULL; }
  6482.     }
  6483.  
  6484. # UP: Liefert den Wert des Fixnums *PRINT-INDENT-LISTS*.
  6485. # get_indent_lists()
  6486. # < ergebnis: Fixnum > 0
  6487.   local uintL get_indent_lists (void);
  6488.   local uintL get_indent_lists()
  6489.     { var reg1 object obj = Symbol_value(S(print_indent_lists));
  6490.       if (posfixnump(obj))
  6491.         { var reg2 uintL indent = posfixnum_to_L(obj);
  6492.           if (indent > 0)
  6493.             { return indent; }
  6494.         }
  6495.       # Defaultwert ist 1.
  6496.       return 1;
  6497.     }
  6498.  
  6499. # UP: Gibt eine Liste auf einen Stream aus, NIL als ().
  6500. # pr_list(&stream,list);
  6501. # > list: Liste
  6502. # > stream: Stream
  6503. # < stream: Stream
  6504. # kann GC auslösen
  6505.   local void pr_list (object *stream_,object list);
  6506.   local void pr_list(stream_,list)
  6507.     var reg2 object* stream_;
  6508.     var reg1 object list;
  6509.     { if (nullp(list))
  6510.         # NIL als () ausgeben:
  6511.         { write_schar(stream_,'('); write_schar(stream_,')'); }
  6512.         else
  6513.         # ein Cons
  6514.         { pr_cons(stream_,list); }
  6515.     }
  6516.  
  6517. # UP: Gibt ein Cons auf einen Stream aus.
  6518. # pr_cons(&stream,list);
  6519. # > list: Cons
  6520. # > stream: Stream
  6521. # < stream: Stream
  6522. # kann GC auslösen
  6523.   local void pr_cons (object *stream_,object list);
  6524.   local void pr_cons(stream_,list)
  6525.     var reg2 object* stream_;
  6526.     var reg3 object list;
  6527.     { # Spezialfälle abfangen:
  6528.       { var reg1 pr_routine* special = special_list_p(list);
  6529.         if (!(special == (pr_routine*)NULL))
  6530.           { (*special)(stream_,list); # spezielle pr_list_xxx-Routine aufrufen
  6531.             return;
  6532.       }   }
  6533.       LEVEL_CHECK1(list);
  6534.       { var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  6535.         var reg4 uintL length = 0; # bisherige Länge := 0
  6536.         pushSTACK(list);
  6537.        {var reg1 object *list_ = &STACK_0;
  6538.         KLAMMER_AUF; # '('
  6539.         INDENT_START(get_indent_lists()); # um 1 Zeichen einrücken, wegen '('
  6540.         JUSTIFY_START;
  6541.         # auf Erreichen von *PRINT-LENGTH* prüfen:
  6542.         if (length_limit==0) goto dots;
  6543.         loop
  6544.           { # ab hier den CAR ausgeben
  6545.             list = *list_; *list_ = Cdr(list); # Liste verkürzen
  6546.             prin_object(stream_,Car(list)); # den CAR ausgeben
  6547.             length++; # Länge incrementieren
  6548.             # ab hier den Listenrest ausgeben
  6549.             if (nullp(*list_)) goto end_of_list; # Listenrest=NIL -> Listenende
  6550.             JUSTIFY_SPACE; # ein Space ausgeben
  6551.             if (matomp(*list_)) goto dotted_list; # Dotted List ?
  6552.             # auf Erreichen von *PRINT-LENGTH* prüfen:
  6553.             if (length >= length_limit) goto dots;
  6554.             # Prüfen, ob Dotted-List-Schreibweise nötig:
  6555.             list = *list_;
  6556.             if (!(circle_p(list) == (circle_info*)NULL)) # wegen Zirkularität nötig?
  6557.               goto dotted_list;
  6558.             if (!(special_list_p(list) == (pr_routine*)NULL)) # wegen QUOTE o.ä. nötig?
  6559.               goto dotted_list;
  6560.           }
  6561.         dotted_list: # Listenrest in Dotted-List-Schreibweise ausgeben:
  6562.           write_schar(stream_,'.');
  6563.           JUSTIFY_SPACE;
  6564.           prin_object_(stream_,list_);
  6565.           goto end_of_list;
  6566.         dots: # Listenrest durch '...' abkürzen:
  6567.           write_schar(stream_,'.');
  6568.           write_schar(stream_,'.');
  6569.           write_schar(stream_,'.');
  6570.           goto end_of_list;
  6571.         end_of_list: # Listeninhalt ausgegeben.
  6572.         JUSTIFY_END_ENG;
  6573.         INDENT_END;
  6574.         KLAMMER_ZU;
  6575.         skipSTACK(1);
  6576.       }}
  6577.       LEVEL_END1;
  6578.     }
  6579.  
  6580. # Ausgabe von ...                              als ...
  6581. # (quote object)                               'object
  6582. # (function object)                            #'object
  6583. # (backquote original-form [expanded-form])    `original-form
  6584. # (splice (unquote form))                      ,@form
  6585. # (splice form)                                ,@'form
  6586. # (nsplice (unquote form))                     ,.form
  6587. # (nsplice form)                               ,.'form
  6588. # (unquote form)                               ,form
  6589.  
  6590.   local void pr_list_quote (object *stream_,object list);
  6591.   local void pr_list_quote(stream_,list) # list = (QUOTE object)
  6592.     var reg2 object* stream_;
  6593.     var reg1 object list;
  6594.     { var reg3 object *list_;
  6595.       pushSTACK(Car(Cdr(list))); # (second list) retten
  6596.       write_schar(stream_,'\''); # "'" ausgeben
  6597.       list_ = &STACK_0;
  6598.       INDENT_START(1); # um 1 Zeichen einrücken wegen "'"
  6599.       prin_object_(stream_,list_); # object ausgeben
  6600.       INDENT_END;
  6601.       skipSTACK(1);
  6602.     }
  6603.  
  6604.   local void pr_list_function (object *stream_,object list);
  6605.   local void pr_list_function(stream_,list) # list = (FUNCTION object)
  6606.     var reg2 object* stream_;
  6607.     var reg1 object list;
  6608.     { var reg3 object *list_;
  6609.       pushSTACK(Car(Cdr(list))); # (second list) retten
  6610.       write_schar(stream_,'#'); # "#" ausgeben
  6611.       write_schar(stream_,'\''); # "'" ausgeben
  6612.       list_ = &STACK_0;
  6613.       INDENT_START(2); # um 2 Zeichen einrücken wegen "#'"
  6614.       prin_object_(stream_,list_); # object ausgeben
  6615.       INDENT_END;
  6616.       skipSTACK(1);
  6617.     }
  6618.  
  6619.   local void pr_list_backquote (object *stream_,object list);
  6620.   local void pr_list_backquote(stream_,list) # list = (BACKQUOTE original-form [expanded-form])
  6621.     var reg2 object* stream_;
  6622.     var reg1 object list;
  6623.     { var reg3 object *list_;
  6624.       pushSTACK(Car(Cdr(list))); # (second list) retten
  6625.       write_schar(stream_,'`'); # '`' ausgeben
  6626.       list_ = &STACK_0;
  6627.       # SYS::*PRIN-BQLEVEL* um 1 erhöhen:
  6628.       {var reg3 object bqlevel = Symbol_value(S(prin_bqlevel));
  6629.        if (!posfixnump(bqlevel)) { bqlevel = Fixnum_0; }
  6630.        dynamic_bind(S(prin_bqlevel),fixnum_inc(bqlevel,1));
  6631.       }
  6632.       INDENT_START(1); # um 1 Zeichen einrücken wegen '`'
  6633.       prin_object_(stream_,list_); # original-form ausgeben
  6634.       INDENT_END;
  6635.       dynamic_unbind();
  6636.       skipSTACK(1);
  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.     { var reg4 object *list_;
  6647.       pushSTACK(Car(Cdr(list))); # (second list) retten
  6648.       write_schar(stream_,','); # Komma ausgeben
  6649.       write_char(stream_,ch); # '@' bzw. '.' ausgeben
  6650.       list_ = &STACK_0;
  6651.       # SYS::*PRIN-BQLEVEL* um 1 verringern:
  6652.       dynamic_bind(S(prin_bqlevel),fixnum_inc(Symbol_value(S(prin_bqlevel)),-1));
  6653.       # Ist dies von der Form (UNQUOTE form) ?
  6654.       if (consp(*list_) && eq(Car(*list_),S(unquote))
  6655.           && mconsp(Cdr(*list_)) && nullp(Cdr(Cdr(*list_)))
  6656.          )
  6657.         # ja -> noch die Form ausgeben:
  6658.         { INDENT_START(2); # um 2 Zeichen einrücken wegen ",@" bzw. ",."
  6659.           prin_object(stream_,Car(Cdr(*list_))); # Form ausgeben
  6660.           INDENT_END;
  6661.         }
  6662.         else
  6663.         # nein -> noch ein Quote und object ausgeben:
  6664.         { write_schar(stream_,'\''); # "'" ausgeben
  6665.           INDENT_START(3); # um 3 Zeichen einrücken wegen ",@'" bzw. ",.'"
  6666.           prin_object_(stream_,list_); # object ausgeben
  6667.           INDENT_END;
  6668.           skipSTACK(1);
  6669.         }
  6670.       dynamic_unbind();
  6671.       skipSTACK(1);
  6672.     }
  6673.  
  6674.   local void pr_list_splice (object *stream_,object list);
  6675.   local void pr_list_splice(stream_,list) # list = (SPLICE object)
  6676.     var reg2 object* stream_;
  6677.     var reg1 object list;
  6678.     { pr_list_bothsplice(stream_,list,code_char('@')); }
  6679.  
  6680.   local void pr_list_nsplice (object *stream_,object list);
  6681.   local void pr_list_nsplice(stream_,list) # list = (NSPLICE object)
  6682.     var reg2 object* stream_;
  6683.     var reg1 object list;
  6684.     { pr_list_bothsplice(stream_,list,code_char('.')); }
  6685.  
  6686.   local void pr_list_unquote (object *stream_,object list);
  6687.   local void pr_list_unquote(stream_,list) # list = (UNQUOTE object)
  6688.     var reg2 object* stream_;
  6689.     var reg1 object list;
  6690.     { var reg3 object *list_;
  6691.       pushSTACK(Car(Cdr(list))); # (second list) retten
  6692.       write_schar(stream_,','); # ',' ausgeben
  6693.       list_ = &STACK_0;
  6694.       # SYS::*PRIN-BQLEVEL* um 1 verringern:
  6695.       dynamic_bind(S(prin_bqlevel),fixnum_inc(Symbol_value(S(prin_bqlevel)),-1));
  6696.       INDENT_START(1); # um 1 Zeichen einrücken wegen ','
  6697.       prin_object_(stream_,list_); # object ausgeben
  6698.       INDENT_END;
  6699.       dynamic_unbind();
  6700.       skipSTACK(1);
  6701.     }
  6702.  
  6703. #                      -------- Zahlen --------
  6704.  
  6705. # UP: Gibt eine reelle Zahl auf einen Stream aus.
  6706. # pr_real_number(&stream,number);
  6707. # > number: reelle Zahl
  6708. # > stream: Stream
  6709. # < stream: Stream
  6710. # kann GC auslösen
  6711.   local void pr_real_number (object *stream,object number);
  6712.   local void pr_real_number(stream_,number)
  6713.     var reg2 object* stream_;
  6714.     var reg1 object number;
  6715.     { if (R_rationalp(number))
  6716.         # rationale Zahl
  6717.         { var reg3 uintWL base = get_print_base(); # Wert von *PRINT-BASE*
  6718.           # *PRINT-RADIX* abfragen:
  6719.           if (test_value(S(print_radix)) || test_value(S(print_readably)))
  6720.             # Radix-Specifier ausgeben:
  6721.             { pushSTACK(number); # number retten
  6722.               switch (base)
  6723.                 { case 2: # Basis 2
  6724.                     write_schar(stream_,'#'); write_schar(stream_,'b'); break;
  6725.                   case 8: # Basis 8
  6726.                     write_schar(stream_,'#'); write_schar(stream_,'o'); break;
  6727.                   case 16: # Basis 16
  6728.                     write_schar(stream_,'#'); write_schar(stream_,'x'); break;
  6729.                   case 10: # Basis 10
  6730.                     if (RA_integerp(number))
  6731.                       { # Basis 10 bei Integers durch nachgestellten Punkt
  6732.                         # kennzeichnen:
  6733.                         skipSTACK(1);
  6734.                         print_integer(number,base,stream_);
  6735.                         write_schar(stream_,'.');
  6736.                         return;
  6737.                       }
  6738.                   default: # Basis in #nR-Schreibweise ausgeben:
  6739.                     write_schar(stream_,'#');
  6740.                     pr_uint(stream_,base);
  6741.                     write_schar(stream_,'r');
  6742.                     break;
  6743.                 }
  6744.               number = popSTACK();
  6745.             }
  6746.           if (RA_integerp(number))
  6747.             # Integer in Basis base ausgeben:
  6748.             { print_integer(number,base,stream_); }
  6749.             else
  6750.             # Ratio in Basis base ausgeben:
  6751.             { pushSTACK(TheRatio(number)->rt_den); # Nenner retten
  6752.               print_integer(TheRatio(number)->rt_num,base,stream_); # Zähler ausgeben
  6753.               write_schar(stream_,'/'); # Bruchstrich
  6754.               print_integer(popSTACK(),base,stream_); # Nenner ausgeben
  6755.             }
  6756.         }
  6757.         else
  6758.         # Float
  6759.         { print_float(number,stream_); }
  6760.     }
  6761.  
  6762. # UP: Gibt eine Zahl auf einen Stream aus.
  6763. # pr_number(&stream,number);
  6764. # > number: Zahl
  6765. # > stream: Stream
  6766. # < stream: Stream
  6767. # kann GC auslösen
  6768.   local void pr_number (object *stream_,object number);
  6769.   local void pr_number(stream_,number)
  6770.     var reg3 object* stream_;
  6771.     var reg2 object number;
  6772.     { if (N_realp(number))
  6773.         # reelle Zahl
  6774.         { pr_real_number(stream_,number); }
  6775.         else
  6776.         # komplexe Zahl
  6777.         { pushSTACK(number); # Zahl retten
  6778.          {var reg1 object* number_ = &STACK_0; # und merken, wo sie sitzt
  6779.           write_schar(stream_,'#'); write_schar(stream_,'C');
  6780.           KLAMMER_AUF;
  6781.           INDENT_START(3); # um 3 Zeichen einrücken, wegen '#C('
  6782.           JUSTIFY_START;
  6783.           pr_real_number(stream_,TheComplex(*number_)->c_real); # Realteil ausgeben
  6784.           JUSTIFY_SPACE;
  6785.           pr_real_number(stream_,TheComplex(*number_)->c_imag); # Imaginärteil ausgeben
  6786.           JUSTIFY_END_ENG;
  6787.           INDENT_END;
  6788.           KLAMMER_ZU;
  6789.           skipSTACK(1);
  6790.         }}
  6791.     }
  6792.  
  6793. #            -------- Arrays bei *PRINT-ARRAY*=NIL --------
  6794.  
  6795. # UP: Gibt einen Array in Kurzform auf einen Stream aus.
  6796. # pr_array_nil(&stream,obj);
  6797. # > obj: Array
  6798. # > stream: Stream
  6799. # < stream: Stream
  6800. # kann GC auslösen
  6801.   local void pr_array_nil (object *stream,object obj);
  6802.   local void pr_array_nil(stream_,obj)
  6803.     var reg2 object* stream_;
  6804.     var reg3 object obj;
  6805.     { pushSTACK(obj); # Array retten
  6806.      {var reg1 object* obj_ = &STACK_0; # und merken, wo er sitzt
  6807.       write_schar(stream_,'#'); write_schar(stream_,'<');
  6808.       INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  6809.       JUSTIFY_START;
  6810.       write_sstring_case(stream_,O(printstring_array)); # "ARRAY" ausgeben
  6811.       JUSTIFY_SPACE;
  6812.       prin_object_dispatch(stream_,array_element_type(*obj_)); # Elementtyp (Symbol oder Liste) ausgeben
  6813.       JUSTIFY_SPACE;
  6814.       pr_list(stream_,array_dimensions(*obj_)); # Dimensionsliste ausgeben
  6815.       if (array_has_fill_pointer_p(*obj_))
  6816.         # Array mit Fill-Pointer -> auch den Fill-Pointer ausgeben:
  6817.         { JUSTIFY_SPACE;
  6818.           write_sstring_case(stream_,O(printstring_fill_pointer)); # "FILL-POINTER=" ausgeben
  6819.           pr_uint(stream_,vector_length(*obj_)); # Länge (=Fill-Pointer) ausgeben
  6820.         }
  6821.       JUSTIFY_END_ENG;
  6822.       INDENT_END;
  6823.       write_schar(stream_,'>');
  6824.       skipSTACK(1);
  6825.     }}
  6826.  
  6827. #                    -------- Bit-Vektoren --------
  6828.  
  6829. # UP: Gibt einen Teil eines Simple-Bit-Vektors auf einen Stream aus.
  6830. # pr_sbvector_ab(&stream,bv,start,len);
  6831. # > bv: Simple-Bit-Vektor
  6832. # > start: Startindex
  6833. # > len: Anzahl der auszugebenden Bits
  6834. # > stream: Stream
  6835. # < stream: Stream
  6836. # kann GC auslösen
  6837.   local void pr_sbvector_ab (object* stream_, object bv, uintL start, uintL len);
  6838.   local void pr_sbvector_ab(stream_,bv,start,len)
  6839.     var reg3 object* stream_;
  6840.     var reg5 object bv;
  6841.     var reg4 uintL start;
  6842.     var reg2 uintL len;
  6843.     { var reg1 uintL index = start;
  6844.       pushSTACK(bv); # Simple-Bit-Vektor retten
  6845.       write_schar(stream_,'#'); write_schar(stream_,'*');
  6846.       dotimesL(len,len,
  6847.         { write_char(stream_,
  6848.                      (sbvector_btst(STACK_0,index) ? code_char('1') : code_char('0'))
  6849.                     );
  6850.           index++;
  6851.         });
  6852.       skipSTACK(1);
  6853.     }
  6854.  
  6855. # UP: Gibt einen Bit-Vektor auf einen Stream aus.
  6856. # pr_bvector(&stream,bv);
  6857. # > bv: Bit-Vektor
  6858. # > stream: Stream
  6859. # < stream: Stream
  6860. # kann GC auslösen
  6861.   local void pr_bvector (object *stream_,object bv);
  6862.   local void pr_bvector(stream_,bv)
  6863.     var reg2 object* stream_;
  6864.     var reg1 object bv;
  6865.     { # *PRINT-ARRAY* abfragen:
  6866.       if (test_value(S(print_array)) || test_value(S(print_readably)))
  6867.         # bv elementweise ausgeben:
  6868.         { var reg3 uintL len = vector_length(bv); # Länge
  6869.           var uintL offset = 0; # Offset vom Bit-Vektor in den Datenvektor
  6870.           var reg4 object sbv = array_displace_check(bv,len,&offset); # Datenvektor
  6871.           pr_sbvector_ab(stream_,sbv,offset,len);
  6872.         }
  6873.         else
  6874.         # *PRINT-ARRAY* = NIL -> in Kurzform ausgeben:
  6875.         { pr_array_nil(stream_,bv); }
  6876.     }
  6877.  
  6878. #                -------- Allgemeine Vektoren --------
  6879.  
  6880. # UP: Gibt einen allgemeinen Vektor auf einen Stream aus.
  6881. # pr_vector(&stream,v);
  6882. # > v: allgemeiner Vektor
  6883. # > stream: Stream
  6884. # < stream: Stream
  6885. # kann GC auslösen
  6886.   local void pr_vector (object *stream,object v);
  6887.   local void pr_vector(stream_,v)
  6888.     var reg4 object* stream_;
  6889.     var reg7 object v;
  6890.     { # *PRINT-ARRAY* abfragen:
  6891.       if (test_value(S(print_array)) || test_value(S(print_readably)))
  6892.         # v elementweise ausgeben:
  6893.         { LEVEL_CHECK1(v);
  6894.           { var reg8 boolean readable = # Flag, ob Länge und Typ mit ausgegeben werden
  6895.               (test_value(S(print_readably)) && !general_vector_p(v) ? TRUE : FALSE);
  6896.             var reg6 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  6897.             var reg5 uintL length = 0; # bisherige Länge := 0
  6898.             # Vektor elementweise abarbeiten:
  6899.             var reg3 uintL len = vector_length(v); # Vektor-Länge
  6900.             var uintL offset = 0; # Offset vom Vektor in den Datenvektor
  6901.             {var reg1 object sv = array_displace_check(v,len,&offset); # Datenvektor
  6902.              pushSTACK(sv); # Simple-Vektor retten
  6903.             }
  6904.            {var reg1 object* sv_ = &STACK_0; # und merken, wo er sitzt
  6905.             var reg2 uintL index = 0 + offset; # Startindex = 0 im Vektor
  6906.             if (readable)
  6907.               { write_schar(stream_,'#'); write_schar(stream_,'A');
  6908.                 KLAMMER_AUF; # '(' ausgeben
  6909.                 INDENT_START(3); # um 3 Zeichen einrücken, wegen '#A('
  6910.                 JUSTIFY_START;
  6911.                 prin_object_dispatch(stream_,array_element_type(*sv_)); # Elementtyp ausgeben
  6912.                 JUSTIFY_SPACE;
  6913.                 pushSTACK(fixnum(len));
  6914.                 pr_list(stream_,listof(1)); # Liste mit der Länge ausgeben
  6915.                 JUSTIFY_SPACE;
  6916.                 KLAMMER_AUF; # '('
  6917.                 INDENT_START(1); # um 1 Zeichen einrücken, wegen '('
  6918.               }
  6919.               else
  6920.               { write_schar(stream_,'#');
  6921.                 KLAMMER_AUF; # '('
  6922.                 INDENT_START(2); # um 2 Zeichen einrücken, wegen '#('
  6923.               }
  6924.             JUSTIFY_START;
  6925.             dotimesL(len,len,
  6926.               { # (außer vorm ersten Element) Space ausgeben:
  6927.                 if (!(length==0)) { JUSTIFY_SPACE; }
  6928.                 # auf Erreichen von *PRINT-LENGTH* prüfen:
  6929.                 if (length >= length_limit)
  6930.                   { # Rest durch '...' abkürzen:
  6931.                     write_schar(stream_,'.');
  6932.                     write_schar(stream_,'.');
  6933.                     write_schar(stream_,'.');
  6934.                     break;
  6935.                   }
  6936.                 # Vektorelement ausgeben:
  6937.                 prin_object(stream_,datenvektor_aref(*sv_,index));
  6938.                 length++; # Länge incrementieren
  6939.                 index++; # dann zum nächsten Vektor-Element
  6940.               });
  6941.             JUSTIFY_END_ENG;
  6942.             INDENT_END;
  6943.             KLAMMER_ZU;
  6944.             if (readable)
  6945.               { JUSTIFY_END_ENG;
  6946.                 INDENT_END;
  6947.                 KLAMMER_ZU;
  6948.               }
  6949.             skipSTACK(1);
  6950.           }}
  6951.           LEVEL_END1;
  6952.         }
  6953.         else
  6954.         # *PRINT-ARRAY* = NIL -> in Kurzform ausgeben:
  6955.         { pr_array_nil(stream_,v); }
  6956.     }
  6957.  
  6958. #               -------- Mehrdimensionale Arrays --------
  6959.  
  6960. # (defun %print-array (array stream)
  6961. #   (let ((rank (array-rank array))
  6962. #         (dims (array-dimensions array))
  6963. #         (eltype (array-element-type array)))
  6964. #     (write-char #\# stream)
  6965. #     (if (zerop (array-total-size array))
  6966. #       ; wiedereinlesbare Ausgabe von leeren mehrdimensionalen Arrays
  6967. #       (progn
  6968. #         (write-char #\A stream)
  6969. #         (prin1 dims stream)
  6970. #       )
  6971. #       (progn
  6972. #         (let ((*print-base* 10.)) (prin1 rank stream))
  6973. #         (write-char #\A stream)
  6974. #         (if (and (plusp rank)
  6975. #                  (or (eq eltype 'bit) (eq eltype 'string-char))
  6976. #                  (or (null *print-length*) (>= *print-length* (array-dimension array (1- rank))))
  6977. #             )
  6978. #           ; kürzere Ausgabe von mehrdimensionalen Bit- und String-Char-Arrays
  6979. #           (let* ((lastdim (array-dimension array (1- rank)))
  6980. #                  (offset 0)
  6981. #                  (sub-array (make-array 0 :element-type eltype :adjustable t)))
  6982. #             (labels ((help (dimsr)
  6983. #                        (if (null dimsr)
  6984. #                          (progn
  6985. #                            (prin1
  6986. #                              (adjust-array sub-array lastdim :displaced-to array
  6987. #                                            :displaced-index-offset offset
  6988. #                              )
  6989. #                              stream
  6990. #                            )
  6991. #                            (setq offset (+ offset lastdim))
  6992. #                          )
  6993. #                          (let ((dimsrr (rest dimsr)))
  6994. #                            (write-char #\( stream)
  6995. #                            (dotimes (i (first dimsr))
  6996. #                              (unless (zerop i) (write-char #\space stream))
  6997. #                              (help dimsrr)
  6998. #                            )
  6999. #                            (write-char #\) stream)
  7000. #                     )) ) )
  7001. #               (help (nbutlast dims))
  7002. #           ) )
  7003. #           ; normale Ausgabe von mehrdimensionalen Arrays
  7004. #           (let ((indices (make-list rank))) ; Liste von rank Indizes
  7005. #             (labels ((help (dimsr indicesr)
  7006. #                        (if (null dimsr)
  7007. #                          (prin1 (apply #'aref array indices) stream)
  7008. #                          (let ((dimsrr (rest dimsr)) (indicesrr (rest indicesr)))
  7009. #                            (write-char #\( stream)
  7010. #                            (dotimes (i (first dimsr))
  7011. #                              (unless (zerop i) (write-char #\space stream))
  7012. #                              (rplaca indicesr i)
  7013. #                              (help dimsrr indicesrr)
  7014. #                            )
  7015. #                            (write-char #\) stream)
  7016. #                     )) ) )
  7017. #               (help dims indices)
  7018. #           ) )
  7019. #       ) )
  7020. # ) ) )
  7021.  
  7022. # UP's zur Ausgabe eines Elements bzw. eines Teil-Arrays:
  7023. # pr_array_elt_xxx(&stream,obj,&info);
  7024. # > obj: Datenvektor
  7025. # > info.index: Index des ersten auszugebenden Elements
  7026. # > info.count: Anzahl der auszugebenden Elemente
  7027. # > stream: Stream
  7028. # < stream: Stream
  7029. # < info.index: um info.count erhöht
  7030. # kann GC auslösen
  7031.   typedef struct { uintL index; uintL count; }  pr_array_info;
  7032.   typedef void pr_array_elt_routine (object* stream_, object obj, pr_array_info* info);
  7033. # UP zur Ausgabe eines Elements:
  7034. # Bei ihr ist info.count = 1.
  7035.   local_function pr_array_elt_routine pr_array_elt_t;
  7036. # Zwei UPs zur Ausgabe eines Teil-Arrays:
  7037.   local_function pr_array_elt_routine pr_array_elt_bvector; # Teilarray ist Bit-Vektor
  7038.   local_function pr_array_elt_routine pr_array_elt_string; # Teilarray ist String
  7039.  
  7040.   local void pr_array_elt_t (object *stream_,object obj,pr_array_info *info);
  7041.   local void pr_array_elt_t(stream_,obj,info)
  7042.     var reg3 object* stream_;
  7043.     var reg1 object obj; # Simple-Vektor
  7044.     var reg2 pr_array_info* info;
  7045.     { # Element von allgemeinem Typ holen und ausgeben:
  7046.       prin_object(stream_,datenvektor_aref(obj,info->index));
  7047.       info->index++;
  7048.     }
  7049.  
  7050.   local void pr_array_elt_bvector (object *stream_,object obj,pr_array_info *info);
  7051.   local void pr_array_elt_bvector(stream_,obj,info)
  7052.     var reg3 object* stream_;
  7053.     var reg2 object obj; # Simple-Bit-Vektor
  7054.     var reg1 pr_array_info* info;
  7055.     { # Teil-Bit-Vektor ausgeben:
  7056.       pr_sbvector_ab(stream_,obj,info->index,info->count);
  7057.       info->index += info->count;
  7058.     }
  7059.  
  7060.   local void pr_array_elt_string (object *stream_,object obj,pr_array_info *info);
  7061.   local void pr_array_elt_string(stream_,obj,info)
  7062.     var reg3 object* stream_;
  7063.     var reg2 object obj; # Simple-String
  7064.     var reg1 pr_array_info* info;
  7065.     { # Teil-String ausgeben:
  7066.       pr_sstring_ab(stream_,obj,info->index,info->count);
  7067.       info->index += info->count;
  7068.     }
  7069.  
  7070. # UP: Gibt einen Teil eines Arrays aus.
  7071. # pr_array_rekursion(locals,depth);
  7072. # > depth: Rekursionstiefe
  7073. # > locals: Variablen:
  7074. #     *(locals->stream_) :   Stream
  7075. #     *(locals->obj_) :      Datenvektor
  7076. #     locals->dims_sizes:    Adresse der Tabelle der Dimensionen des Arrays
  7077. #                            und ihrer Teilprodukte
  7078. #     *(locals->pr_one_elt): Funktion zur Ausgabe eines Elements/Teil-Arrays
  7079. #     locals->info:          Parameter für diese Funktion
  7080. #     locals->info.index:    Start-Index im Datenvektor
  7081. #     locals->length_limit:  Längenbegrenzung
  7082. # < locals->info.index: End-Index im Datenvektor
  7083. # kann GC auslösen
  7084.   typedef struct { object* stream_;
  7085.                    object* obj_;
  7086.                    array_dim_size* dims_sizes;
  7087.                    pr_array_elt_routine* pr_one_elt;
  7088.                    pr_array_info info;
  7089.                    uintL length_limit;
  7090.                  }
  7091.           pr_array_locals;
  7092.   local void pr_array_rekursion (pr_array_locals* locals, uintL depth);
  7093.   local void pr_array_rekursion(locals,depth)
  7094.     var reg1 pr_array_locals* locals;
  7095.     var reg5 uintL depth;
  7096.     { check_SP(); check_STACK();
  7097.       if (depth==0)
  7098.         # Rekursionstiefe 0 -> Rekursionsbasis
  7099.         { (*(locals->pr_one_elt)) # Funktion pr_one_elt aufrufen, mit
  7100.             (locals->stream_, # Streamadresse,
  7101.              *(locals->obj_), # Datenvektor obj,
  7102.              &(locals->info) # Infopointer
  7103.             ); # als Argumenten
  7104.           # Diese Funktion erhöht locals->info.index selbst.
  7105.         }
  7106.         else
  7107.         { depth--; # Rekursionstiefe verkleinern (noch >=0)
  7108.          {var reg2 object* stream_ = locals->stream_;
  7109.           var reg3 uintL length = 0; # bisherige Länge := 0
  7110.           var reg6 uintL endindex = locals->info.index # Start-Index im Datenvektor
  7111.                                     + locals->dims_sizes[depth].dimprod # + Dimensionenprodukt
  7112.                                     ; # liefert den End-Index dieses Teil-Arrays
  7113.           var reg4 uintL count = locals->dims_sizes[depth].dim;
  7114.           KLAMMER_AUF; # '(' ausgeben
  7115.           INDENT_START(1); # um 1 Zeichen einrücken, wegen '('
  7116.           JUSTIFY_START;
  7117.           # Schleife über Dimension (r-depth): jeweils einen Teil-Array ausgeben
  7118.           dotimesL(count,count,
  7119.             { # (außer vorm ersten Teil-Array) Space ausgeben:
  7120.               if (!(length==0)) { JUSTIFY_SPACE; }
  7121.               # auf Erreichen von *PRINT-LENGTH* prüfen:
  7122.               if (length >= locals->length_limit)
  7123.                 { # Rest durch '...' abkürzen:
  7124.                   write_schar(stream_,'.');
  7125.                   write_schar(stream_,'.');
  7126.                   write_schar(stream_,'.');
  7127.                   break;
  7128.                 }
  7129.               # Teil-Array ausgeben:
  7130.               # (rekursiv, mit verkleinerter depth, und locals->info.index
  7131.               # wird ohne weiteres Zutun von einem Aufruf zum nächsten
  7132.               # weitergereicht)
  7133.               pr_array_rekursion(locals,depth);
  7134.               length++; # Länge incrementieren
  7135.               # locals->info.index ist schon incrementiert
  7136.             });
  7137.           JUSTIFY_END_WEIT;
  7138.           INDENT_END;
  7139.           KLAMMER_ZU; # ')' ausgeben
  7140.           locals->info.index = endindex; # jetzt am End-Index angelangt
  7141.         }}
  7142.     }
  7143.  
  7144. # UP: Gibt einen mehrdimensionalen Array auf einen Stream aus.
  7145. # pr_array(&stream,obj);
  7146. # > obj: mehrdimensionaler Array
  7147. # > stream: Stream
  7148. # < stream: Stream
  7149. # kann GC auslösen
  7150.   local void pr_array (object *stream_,object obj);
  7151.   local void pr_array(stream_,obj)
  7152.     var reg3 object* stream_;
  7153.     var reg2 object obj;
  7154.     { # *PRINT-ARRAY* abfragen:
  7155.       if (test_value(S(print_array)) || test_value(S(print_readably)))
  7156.         # obj elementweise ausgeben:
  7157.         {   LEVEL_CHECK1(obj);
  7158.          {  # Rang bestimmen und Dimensionen und Teilprodukte holen:
  7159.             var reg4 uintL r = (uintL)(TheArray(obj)->rank); # Rang
  7160.             var DYNAMIC_ARRAY(reg7,dims_sizes,array_dim_size,r); # dynamisch allozierter Array
  7161.             array_dims_sizes(obj,dims_sizes); # füllen
  7162.           { var reg5 uintL depth = r; # Tiefe der Rekursion
  7163.             var pr_array_locals locals; # lokale Variablen
  7164.             var reg9 boolean readable = TRUE; # Flag, ob Dimensionen und Typ mit ausgegeben werden
  7165.             locals.stream_ = stream_;
  7166.             locals.dims_sizes = dims_sizes;
  7167.             locals.length_limit = get_print_length(); # Längenbegrenzung
  7168.             # Entscheidung über zu verwendende Routine:
  7169.             {var reg1 uintB atype = TheArray(obj)->flags & arrayflags_atype_mask;
  7170.              if ((r>0) && (locals.length_limit >= dims_sizes[0].dim))
  7171.                { switch (atype)
  7172.                    { case Atype_Bit:
  7173.                        # ganze Bitvektoren statt einzelnen Bits ausgeben
  7174.                        locals.pr_one_elt = &pr_array_elt_bvector;
  7175.                        goto nicht_einzeln;
  7176.                      case Atype_String_Char:
  7177.                        # ganze Strings statt einzelnen Characters ausgeben
  7178.                        locals.pr_one_elt = &pr_array_elt_string;
  7179.                      nicht_einzeln:
  7180.                        # Nicht einzelne Elemente, sondern eindimensionale
  7181.                        # Teil-Arrays ausgeben.
  7182.                        depth--; # dafür depth := r-1
  7183.                        locals.info.count = dims_sizes[0].dim; # Dim_r als "Elementarlänge"
  7184.                        locals.dims_sizes++; # betrachte nur noch Dim_1, ..., Dim_(r-1)
  7185.                        readable = FALSE; # automatisch wiedereinlesbar
  7186.                        goto routine_ok;
  7187.                      default: ;
  7188.                }   }
  7189.              locals.pr_one_elt = &pr_array_elt_t;
  7190.              locals.info.count = 1; # 1 als "Elementarlänge"
  7191.              if (atype==Atype_T)
  7192.                { readable = FALSE; } # automatisch wiedereinlesbar
  7193.              routine_ok:
  7194.              locals.info.index = 0; # Start-Index ist 0
  7195.             }
  7196.             if (!test_value(S(print_readably)))
  7197.               { readable = FALSE; } # braucht nicht wiedereinlesbar zu sein
  7198.             pushSTACK(obj); # Array retten
  7199.            {var reg8 object* obj_ = &STACK_0; # und merken, wo er sitzt
  7200.             # Datenvektor holen:
  7201.             var reg6 uintL size = TheArray(obj)->totalsize;
  7202.             if (size == 0)
  7203.               { readable = TRUE; } # sonst weiß man nicht einmal die Dimensionen
  7204.             obj = array1_displace_check(obj,size,&locals.info.index); # Datenvektor
  7205.             # locals.info.index = Offset vom Array in den Datenvektor
  7206.             pushSTACK(obj); locals.obj_ = &STACK_0; # obj im Stack unterbringen
  7207.             # Los geht's.
  7208.             if (readable)
  7209.               { write_schar(stream_,'#'); write_schar(stream_,'A');
  7210.                 KLAMMER_AUF; # '(' ausgeben
  7211.                 INDENT_START(3); # um 3 Zeichen einrücken, wegen '#A('
  7212.                 JUSTIFY_START;
  7213.                 prin_object_dispatch(stream_,array_element_type(*obj_)); # Elementtyp (Symbol oder Liste) ausgeben
  7214.                 JUSTIFY_SPACE;
  7215.                 pr_list(stream_,array_dimensions(*obj_)); # Dimensionsliste ausgeben
  7216.                 JUSTIFY_SPACE;
  7217.                 pr_array_rekursion(&locals,depth); # Array-Elemente ausgeben
  7218.                 JUSTIFY_END_ENG;
  7219.                 INDENT_END;
  7220.                 KLAMMER_ZU; # ')' ausgeben
  7221.               }
  7222.               else
  7223.               { # Erst Präfix #nA ausgeben:
  7224.                 INDENTPREP_START;
  7225.                 write_schar(stream_,'#');
  7226.                 pr_uint(stream_,r); # Rang dezimal ausgeben
  7227.                 write_schar(stream_,'A');
  7228.                 {var reg1 uintL indent = INDENTPREP_END;
  7229.                 # Dann die Array-Elemente ausgeben:
  7230.                  INDENT_START(indent);
  7231.                 }
  7232.                 pr_array_rekursion(&locals,depth);
  7233.                 INDENT_END;
  7234.               }
  7235.             skipSTACK(2);
  7236.             FREE_DYNAMIC_ARRAY(dims_sizes);
  7237.             LEVEL_END1;
  7238.         }}}}
  7239.         else
  7240.         # *PRINT-ARRAY* = NIL -> in Kurzform ausgeben:
  7241.         { pr_array_nil(stream_,obj); }
  7242.     }
  7243.  
  7244. #                     -------- Structures --------
  7245.  
  7246. # (defun %print-structure (structure stream)
  7247. #   (let ((name (type-of structure)))
  7248. #     (let ((fun (get name 'STRUCTURE-PRINT)))
  7249. #       (if fun
  7250. #         (funcall fun structure stream *PRIN-LEVEL*)
  7251. #         (let ((description (get name 'DEFSTRUCT-DESCRIPTION)))
  7252. #           (if description
  7253. #             (let ((readable (svref description 2)))
  7254. #               (write-string (if readable "#S(" "#<") stream)
  7255. #               (prin1 name stream)
  7256. #               (dolist (slot (svref description 3))
  7257. #                 (when (first slot)
  7258. #                   (write-char #\space stream)
  7259. #                   (prin1 (intern (symbol-name (first slot)) *KEYWORD-PACKAGE*) stream)
  7260. #                   (write-char #\space stream)
  7261. #                   (prin1 (%structure-ref name structure (second slot)) stream)
  7262. #               ) )
  7263. #               (write-string (if readable ")" ">") stream)
  7264. #             )
  7265. #             (progn
  7266. #               (write-string "#<" stream)
  7267. #               (prin1 name stream)
  7268. #               (do ((l (%record-length structure))
  7269. #                    (i 1 (1+ i)))
  7270. #                   ((>= i l))
  7271. #                 (write-char #\space stream)
  7272. #                 (prin1 (%structure-ref name structure i) stream)
  7273. #               )
  7274. #               (write-string ">" stream)
  7275. # ) ) ) ) ) ) )
  7276.  
  7277. # Vorbereitung des Aufrufs einer externen Print-Funktion
  7278. # pr_external_1(stream)
  7279. # > stream: Stream
  7280. # < ergebnis: Anzahl dynamische Bindungen, die aufzulösen sind.
  7281.   local uintC pr_external_1 (object stream);
  7282.   local uintC pr_external_1(stream)
  7283.     var reg3 object stream;
  7284.     { var reg2 uintC count = 1;
  7285.       # SYS::*PRIN-STREAM* an stream binden:
  7286.       dynamic_bind(S(prin_stream),stream);
  7287.       if (test_value(S(print_readably)))
  7288.         { # Damit die benutzerdefinierten Print-Funktionen, die noch nichts
  7289.           # von *PRINT-READABLY* wissen, sich trotzdem danach benehmen,
  7290.           # binden wir die anderen Printer-Variablen passend:
  7291.           # *PRINT-READABLY* erzwingt *PRINT-ESCAPE* = T :
  7292.           if (!test_value(S(print_escape)))
  7293.             { dynamic_bind(S(print_escape),T); count++; }
  7294.           # *PRINT-READABLY* erzwingt *PRINT-BASE* = 10 :
  7295.           if (!eq(Symbol_value(S(print_base)),fixnum(10)))
  7296.             { dynamic_bind(S(print_base),fixnum(10)); count++; }
  7297.           # *PRINT-READABLY* erzwingt *PRINT-RADIX* = T :
  7298.           if (!test_value(S(print_radix)))
  7299.             { dynamic_bind(S(print_radix),T); count++; }
  7300.           # *PRINT-READABLY* erzwingt *PRINT-CIRCLE* = T :
  7301.           if (!test_value(S(print_circle)))
  7302.             { dynamic_bind(S(print_circle),T); count++; }
  7303.           # *PRINT-READABLY* erzwingt *PRINT-LEVEL* = NIL :
  7304.           if (test_value(S(print_level)))
  7305.             { dynamic_bind(S(print_level),NIL); count++; }
  7306.           # *PRINT-READABLY* erzwingt *PRINT-LENGTH* = NIL :
  7307.           if (test_value(S(print_length)))
  7308.             { dynamic_bind(S(print_length),NIL); count++; }
  7309.           # *PRINT-READABLY* erzwingt *PRINT-GENSYM* = T :
  7310.           if (!test_value(S(print_gensym)))
  7311.             { dynamic_bind(S(print_gensym),T); count++; }
  7312.           # *PRINT-READABLY* erzwingt *PRINT-ARRAY* = T :
  7313.           if (!test_value(S(print_array)))
  7314.             { dynamic_bind(S(print_array),T); count++; }
  7315.           # *PRINT-READABLY* erzwingt *PRINT-CLOSURE* = T :
  7316.           if (!test_value(S(print_closure)))
  7317.             { dynamic_bind(S(print_closure),T); count++; }
  7318.         }
  7319.       return count;
  7320.     }
  7321.  
  7322. # Nachbereitung des Aufrufs einer externen Print-Funktion
  7323. # pr_external_2(count);
  7324. # > count: Anzahl dynamische Bindungen, die aufzulösen sind.
  7325.   #define pr_external_2(countvar)  \
  7326.     dotimespC(countvar,countvar, { dynamic_unbind(); } );
  7327.  
  7328. # UP: Aufruf einer (externen) Print-Funktion für Structures
  7329. # pr_structure_external(&stream,structure,function);
  7330. # > stream: Stream
  7331. # > structure: Structure
  7332. # > function: Print-Funktion für Structures dieses Typs
  7333. # kann GC auslösen
  7334.   local void pr_structure_external (object* stream_, object structure, object function);
  7335.   local void pr_structure_external(stream_,structure,function)
  7336.     var reg3 object* stream_;
  7337.     var reg4 object structure;
  7338.     var reg5 object function;
  7339.     { var reg1 uintC count = pr_external_1(*stream_); # Bindungen erstellen
  7340.       # (funcall fun Structure Stream SYS::*PRIN-LEVEL*) :
  7341.       pushSTACK(structure); # Structure als 1. Argument
  7342.       pushSTACK(*stream_); # Stream als 2. Argument
  7343.       pushSTACK(Symbol_value(S(prin_level))); # Wert von SYS::*PRIN-LEVEL* als 3. Argument
  7344.       funcall(function,3);
  7345.       pr_external_2(count); # Bindungen auflösen
  7346.     }
  7347.  
  7348. # UP: Gibt eine Structure auf einen Stream aus.
  7349. # pr_structure(&stream,structure);
  7350. # > structure: Structure
  7351. # > stream: Stream
  7352. # < stream: Stream
  7353. # kann GC auslösen
  7354.   local void pr_structure (object *stream_,object structure);
  7355.   local void pr_structure(stream_,structure)
  7356.     var reg3 object* stream_;
  7357.     var reg10 object structure;
  7358.     { LEVEL_CHECK1(structure);
  7359.       # Typ der Structure bestimmen (vgl. TYPE-OF):
  7360.       { var reg10 object name = Car(TheStructure(structure)->structure_types);
  7361.         # name = (car '(name_1 ... name_i-1 name_i)) = name_1.
  7362.         pushSTACK(structure);
  7363.         pushSTACK(name);
  7364.       # Stackaufbau: structure, name.
  7365.       # (GET name 'SYS::STRUCTURE-PRINT) ausführen:
  7366.        {var reg10 object fun = get(name,S(structure_print));
  7367.         if (!eq(fun,unbound))
  7368.           # vorgegebene Print-Funktion aufrufen:
  7369.           { structure = STACK_1;
  7370.             # Dabei *PRINT-CIRCLE* beachten:
  7371.             # *PRINT-CIRCLE* = NIL ->
  7372.             # Für den Fall, daß *PRINT-CIRCLE* an T gebunden werden wird,
  7373.             # muß SYS::*PRINT-CIRCLE-TABLE* an #<UNBOUND> gebunden werden
  7374.             # (es sei denn, es ist bereits = #<UNBOUND>).
  7375.             if ((!test_value(S(print_circle)))
  7376.                 && (!eq(Symbol_value(S(print_circle_table)),unbound))
  7377.                )
  7378.               { var reg1 object *fun_;
  7379.                 var reg2 object *structure_;
  7380.                 pushSTACK(fun); fun_=&STACK_0;
  7381.                 pushSTACK(structure); structure_=&STACK_0;
  7382.                 dynamic_bind(S(print_circle_table),unbound);
  7383.                 pr_structure_external(stream_,*structure_,*fun_);
  7384.                 dynamic_unbind();
  7385.                 skipSTACK(2);
  7386.               }
  7387.               else
  7388.               { pr_structure_external(stream_,structure,fun); }
  7389.             skipSTACK(2);
  7390.           }
  7391.           else
  7392.           # keine vorgegebene Print-Funktion gefunden.
  7393.           { # Stackaufbau: structure, name.
  7394.             var reg4 object* structure_ = &STACK_1;
  7395.             # Es ist *(structure_ STACKop 0) = structure
  7396.             # und    *(structure_ STACKop -1) = name .
  7397.             # (GET name 'SYS::DEFSTRUCT-DESCRIPTION) ausführen:
  7398.             var reg8 object description = get(name,S(defstruct_description));
  7399.             if (!eq(description,unbound))
  7400.               # Structure mit Slot-Namen ausgeben:
  7401.               { pushSTACK(description);
  7402.                 # Stackaufbau: structure, name, description.
  7403.                 # description muß ein Simple-Vector der Länge >=4 sein !
  7404.                 if (!(simple_vector_p(description)
  7405.                       && (TheSvector(description)->length >= 4)
  7406.                    ) )
  7407.                   { bad_description:
  7408.                     pushSTACK(S(defstruct_description));
  7409.                     pushSTACK(S(print));
  7410.                     //: DEUTSCH "~: Schlecht aufgebaute ~"
  7411.                     //: ENGLISH "~: bad ~"
  7412.                     //: FRANCAIS "~ : Mauvaise ~"
  7413.                     fehler(error, GETTEXT("~: bad ~"));
  7414.                   }
  7415.                {var reg9 boolean readable = # TRUE falls (svref description 2) /= NIL
  7416.                   !nullp(TheSvector(description)->data[2]);
  7417.                 if (readable)
  7418.                   # Structure wiedereinlesbar ausgeben:
  7419.                   { write_schar(stream_,'#'); write_schar(stream_,'S');
  7420.                     KLAMMER_AUF;
  7421.                     INDENT_START(3); # um 3 Zeichen einrücken, wegen '#S('
  7422.                   }
  7423.                   else
  7424.                   # Structure nicht wiedereinlesbar ausgeben:
  7425.                   { if (test_value(S(print_readably))) { fehler_print_readably(*structure_); }
  7426.                     write_schar(stream_,'#'); write_schar(stream_,'<');
  7427.                     INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  7428.                   }
  7429.                 JUSTIFY_START;
  7430.                 prin_object(stream_,*(structure_ STACKop -1)); # name ausgeben
  7431.                 pushSTACK(TheSvector(*(structure_ STACKop -2))->data[3]);
  7432.                 # Slot-Liste STACK_0 = (svref description 3) durchlaufen:
  7433.                 { var reg7 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7434.                   var reg6 uintL length = 0; # bisherige Länge := 0
  7435.                   while (mconsp(STACK_0))
  7436.                     { var reg5 object slot = STACK_0;
  7437.                       STACK_0 = Cdr(slot); # Liste verkürzen
  7438.                       slot = Car(slot); # ein einzelner slot
  7439.                       if (!consp(slot)) goto bad_description; # sollte ein Cons sein
  7440.                       if (!nullp(Car(slot))) # Slot (NIL ...) übergehen
  7441.                         { pushSTACK(slot); # Slot retten
  7442.                           JUSTIFY_SPACE; # Space ausgeben
  7443.                           # auf Erreichen von *PRINT-LENGTH* prüfen:
  7444.                           if (length >= length_limit)
  7445.                             { # Rest durch '...' abkürzen:
  7446.                               write_schar(stream_,'.');
  7447.                               write_schar(stream_,'.');
  7448.                               write_schar(stream_,'.');
  7449.                               skipSTACK(1); # slot vergessen
  7450.                               break;
  7451.                             }
  7452.                          {var reg1 object* slot_ = &STACK_0; # da sitzt der Slot
  7453.                           JUSTIFY_START;
  7454.                           write_schar(stream_,':'); # Keyword-Kennzeichen
  7455.                           {var reg4 object obj = Car(*slot_); # (first slot)
  7456.                            if (!symbolp(obj)) goto bad_description; # sollte ein Symbol sein
  7457.                            pr_like_symbol(stream_,Symbol_name(obj)); # Symbolnamen der Komponente ausgeben
  7458.                           }
  7459.                           JUSTIFY_SPACE;
  7460.                           {var reg4 object obj = Cdr(*slot_); # (cdr slot)
  7461.                            if (!consp(obj)) goto bad_description; # sollte ein Cons sein
  7462.                            # (SYS::%STRUCTURE-REF name Structure (second slot)) ausführen:
  7463.                            pushSTACK(*(structure_ STACKop -1)); # name als 1. Argument
  7464.                            pushSTACK(*(structure_ STACKop 0)); # Structure als 2. Argument
  7465.                            pushSTACK(Car(obj)); # (second slot) als 3. Argument
  7466.                            funcall(L(structure_ref),3);
  7467.                           }
  7468.                           prin_object(stream_,value1); # Komponente ausgeben
  7469.                           JUSTIFY_END_ENG;
  7470.                           skipSTACK(1); # slot vergessen
  7471.                     }   }}
  7472.                 }
  7473.                 skipSTACK(1);
  7474.                 JUSTIFY_END_ENG;
  7475.                 if (readable) # Beendung der Fallunterscheidung von oben
  7476.                   { INDENT_END;
  7477.                     KLAMMER_ZU;
  7478.                   }
  7479.                   else
  7480.                   { INDENT_END;
  7481.                     write_schar(stream_,'>');
  7482.                   }
  7483.                 skipSTACK(3);
  7484.               }}
  7485.               else
  7486.               # Structure elementweise, ohne Komponenten-Namen ausgeben.
  7487.               { if (test_value(S(print_readably))) { fehler_print_readably(*structure_); }
  7488.                 write_schar(stream_,'#'); write_schar(stream_,'<');
  7489.                 INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  7490.                 JUSTIFY_START;
  7491.                 prin_object(stream_,*(structure_ STACKop -1)); # name ausgeben
  7492.                {var reg1 uintC len = TheStructure(*structure_)->reclength; # Länge der Structure (>=1)
  7493.                 var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7494.                 var reg4 uintL length = 0; # Index = bisherige Länge := 0
  7495.                 dotimesC(len,len-1,
  7496.                   { JUSTIFY_SPACE; # Space ausgeben
  7497.                     # auf Erreichen von *PRINT-LENGTH* prüfen:
  7498.                     if (length >= length_limit)
  7499.                       { # Rest durch '...' abkürzen:
  7500.                         write_schar(stream_,'.');
  7501.                         write_schar(stream_,'.');
  7502.                         write_schar(stream_,'.');
  7503.                         break;
  7504.                       }
  7505.                     length++; # Index erhöhen
  7506.                     # Komponente ausgeben:
  7507.                     prin_object(stream_,TheStructure(*structure_)->recdata[length]);
  7508.                   });
  7509.                 JUSTIFY_END_ENG;
  7510.                 INDENT_END;
  7511.                 write_schar(stream_,'>');
  7512.                 skipSTACK(2);
  7513.               }}
  7514.           }
  7515.       }}
  7516.       LEVEL_END1;
  7517.     }
  7518.  
  7519. #                 -------- Maschinenpointer --------
  7520.  
  7521. # UP: Gibt einen Objekt #<BLABLA #x......> auf einen Stream aus.
  7522. # pr_hex6_obj(&stream,obj,string);
  7523. # > obj: Objekt
  7524. # > string: Simple-String "BLABLA"
  7525. # > stream: Stream
  7526. # < stream: Stream
  7527. # kann GC auslösen
  7528.   local void pr_hex6_obj (object* stream_, object obj, object string);
  7529.   local void pr_hex6_obj(stream_,obj,string)
  7530.     var reg1 object* stream_;
  7531.     var reg4 object obj;
  7532.     var reg3 object string;
  7533.     { pushSTACK(string); # String retten
  7534.      {var reg2 object* string_ = &STACK_0; # und merken, wo er sitzt
  7535.       write_schar(stream_,'#'); write_schar(stream_,'<');
  7536.       INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  7537.       JUSTIFY_START;
  7538.       write_sstring_case(stream_,*string_); # String ausgeben
  7539.       JUSTIFY_SPACE;
  7540.       pr_hex6(stream_,obj); # obj als Adresse ausgeben
  7541.       JUSTIFY_END_ENG;
  7542.       INDENT_END;
  7543.       write_schar(stream_,'>');
  7544.       skipSTACK(1);
  7545.     }}
  7546.  
  7547. # UP: Gibt einen Maschinenpointer auf einen Stream aus.
  7548. # pr_machine(&stream,obj);
  7549. # > obj: Maschinenpointer
  7550. # > stream: Stream
  7551. # < stream: Stream
  7552. # kann GC auslösen
  7553.   local void pr_machine (object *stream_,object obj);
  7554.   local void pr_machine(stream_,obj)
  7555.     var reg1 object* stream_;
  7556.     var reg2 object obj;
  7557.     { # #<ADDRESS #x...>
  7558.       if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7559.       pr_hex6_obj(stream_,obj,O(printstring_address));
  7560.     }
  7561.  
  7562. #        -------- Frame-Pointer, Read-Label, System --------
  7563.  
  7564. # UP: Gibt einen Systempointer auf einen Stream aus.
  7565. # pr_system(&stream,obj);
  7566. # > obj: Systempointer
  7567. # > stream: Stream
  7568. # < stream: Stream
  7569. # kann GC auslösen
  7570.   local void pr_system (object* stream_,object obj);
  7571.   local void pr_system(stream_,obj)
  7572.     var reg2 object* stream_;
  7573.     var reg1 object obj;
  7574.     { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7575.       if (as_oint(obj) & wbit(0 + oint_addr_shift))
  7576.         if (as_oint(obj) & wbit(oint_data_len-1 + oint_addr_shift))
  7577.           # System-Pointer
  7578.           { if (eq(obj,unbound)) # #<UNBOUND>
  7579.               { write_sstring_case(stream_,O(printstring_unbound)); }
  7580.             elif (eq(obj,specdecl)) # #<SPECIAL REFERENCE>
  7581.               { write_sstring_case(stream_,O(printstring_special_reference)); }
  7582.             elif (eq(obj,disabled)) # #<DISABLED POINTER>
  7583.               { write_sstring_case(stream_,O(printstring_disabled_pointer)); }
  7584.             elif (eq(obj,dot_value)) # #<DOT>
  7585.               { write_sstring_case(stream_,O(printstring_dot)); }
  7586.             elif (eq(obj,eof_value)) # #<END OF FILE>
  7587.               { write_sstring_case(stream_,O(printstring_eof)); }
  7588.             else # #<SYSTEM-POINTER #x...>
  7589.               { pr_hex6_obj(stream_,obj,O(printstring_system)); }
  7590.           }
  7591.           else
  7592.           # Read-Label
  7593.           { # #<READ-LABEL ...>
  7594.             write_schar(stream_,'#'); write_schar(stream_,'<');
  7595.             INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  7596.             JUSTIFY_START;
  7597.             write_sstring_case(stream_,O(printstring_read_label)); # "READ-LABEL"
  7598.             JUSTIFY_SPACE;
  7599.             pr_uint(stream_,(as_oint(obj) >> (oint_addr_shift+1)) & (bit(oint_data_len-2)-1)); # Bits 21..0 dezimal ausgeben
  7600.             JUSTIFY_END_ENG;
  7601.             INDENT_END;
  7602.             write_schar(stream_,'>');
  7603.           }
  7604.         else
  7605.         # Frame-Pointer
  7606.         { # #<FRAME-POINTER #x...>
  7607.           pr_hex6_obj(stream_,obj,O(printstring_frame_pointer));
  7608.         }
  7609.     }
  7610.  
  7611. #                        -------- Records --------
  7612.  
  7613. # UP: Gibt den Rest eines Record aus. Nur innerhalb eines JUSTIFY-Blocks!
  7614. # Die Ausgabe fängt im Normalfall mit einem JUSTIFY_SPACE an.
  7615. # pr_record_ab(&stream,&obj,start,now);
  7616. # > obj: Record
  7617. # > start: Startindex
  7618. # > now: Anzahl der bereits ausgegebenen Items (für *PRINT-LENGTH*)
  7619. # > stream: Stream
  7620. # < stream: Stream
  7621. # kann GC auslösen
  7622.   local void pr_record_ab (object* stream_, object* obj_, uintL index, uintL length);
  7623.   local void pr_record_ab(stream_,obj_,index,length)
  7624.     var reg2 object* stream_;
  7625.     var reg1 object* obj_;
  7626.     var reg3 uintL index;
  7627.     var reg4 uintL length;
  7628.     { var reg5 uintL len = Record_length(*obj_); # Länge des Record
  7629.       var reg6 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7630.       loop
  7631.         { if (index >= len) break; # Index >= Recordlänge -> fertig
  7632.           JUSTIFY_SPACE; # Space ausgeben
  7633.           # auf Erreichen von *PRINT-LENGTH* prüfen:
  7634.           if (length >= length_limit)
  7635.             { # Rest durch '...' abkürzen:
  7636.               write_schar(stream_,'.');
  7637.               write_schar(stream_,'.');
  7638.               write_schar(stream_,'.');
  7639.               break;
  7640.             }
  7641.           # Komponente ausgeben:
  7642.           prin_object(stream_,TheRecord(*obj_)->recdata[index]);
  7643.           length++; # bisherige Länge erhöhen
  7644.           index++; # zur nächsten Komponente
  7645.         }
  7646.     }
  7647.  
  7648. # UP: Gibt eine Liste als Rest eines Record aus.
  7649. # Nur innerhalb eines JUSTIFY-Blocks!
  7650. # Die Ausgabe fängt im Normalfall mit einem JUSTIFY_SPACE an.
  7651. # pr_record_rest(&stream,obj,now);
  7652. # > obj: Liste
  7653. # > now: Anzahl der bereits ausgegebenen Items (für *PRINT-LENGTH*)
  7654. # > stream: Stream
  7655. # < stream: Stream
  7656. # kann GC auslösen
  7657.   local void pr_record_rest (object* stream_, object obj, uintL length);
  7658.   local void pr_record_rest(stream_,obj,length)
  7659.     var reg2 object* stream_;
  7660.     var reg5 object obj;
  7661.     var reg3 uintL length;
  7662.     { var reg4 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7663.       pushSTACK(obj);
  7664.       while (mconsp(STACK_0))
  7665.         { JUSTIFY_SPACE; # Space ausgeben
  7666.           # auf Erreichen von *PRINT-LENGTH* prüfen:
  7667.           if (length >= length_limit)
  7668.             { # Rest durch '...' abkürzen:
  7669.               write_schar(stream_,'.');
  7670.               write_schar(stream_,'.');
  7671.               write_schar(stream_,'.');
  7672.               break;
  7673.             }
  7674.           {var reg1 object list = STACK_0;
  7675.            STACK_0 = Cdr(list); # Liste verkürzen
  7676.            prin_object(stream_,Car(list)); # Element der Liste ausgeben
  7677.           }
  7678.           length++; # Länge incrementieren
  7679.         }
  7680.       skipSTACK(1);
  7681.     }
  7682.  
  7683. # UP: Gibt einen OtherRecord mit Slotnamen auf einen Stream aus.
  7684. # pr_record_descr(&stream,obj,name,readable,slotlist);
  7685. # > obj: OtherRecord
  7686. # > name: Struktur-Name
  7687. # > readable: Flag, ob wiedereinlesbar auszugeben
  7688. # > slotlist: Liste ((slotname . accessor) ...)
  7689. # > stream: Stream
  7690. # < stream: Stream
  7691. # kann GC auslösen
  7692.   local void pr_record_descr (object* stream_, object obj, object name, boolean readable, object slotlist);
  7693.   local void pr_record_descr(stream_,obj,name,readable,slotlist)
  7694.     var reg2 object* stream_;
  7695.     var reg7 object obj;
  7696.     var reg8 object name;
  7697.     var reg8 boolean readable;
  7698.     var reg9 object slotlist;
  7699.     { LEVEL_CHECK3(obj,name,slotlist);
  7700.       pushSTACK(obj);
  7701.       pushSTACK(name);
  7702.       pushSTACK(slotlist);
  7703.       # Stackaufbau: obj, name, slotlist.
  7704.      {var reg3 object* obj_ = &STACK_2;
  7705.       # Es ist *(obj_ STACKop 0) = obj
  7706.       # und    *(obj_ STACKop -1) = name
  7707.       # und    *(obj_ STACKop -2) = slotlist .
  7708.       if (readable)
  7709.         # obj wiedereinlesbar ausgeben:
  7710.         { write_schar(stream_,'#'); write_schar(stream_,'S');
  7711.           KLAMMER_AUF;
  7712.           INDENT_START(3); # um 3 Zeichen einrücken, wegen '#S('
  7713.         }
  7714.         else
  7715.         # obj nicht wiedereinlesbar ausgeben:
  7716.         { if (test_value(S(print_readably))) { fehler_print_readably(STACK_2); }
  7717.           write_schar(stream_,'#'); write_schar(stream_,'<');
  7718.           INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  7719.         }
  7720.       JUSTIFY_START;
  7721.       prin_object(stream_,*(obj_ STACKop -1)); # name ausgeben
  7722.       pushSTACK(*(obj_ STACKop -2));
  7723.       # Slot-Liste STACK_0 = (svref description 3) durchlaufen:
  7724.       { var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7725.         var reg4 uintL length = 0; # bisherige Länge := 0
  7726.         while (mconsp(STACK_0))
  7727.           { {var reg1 object slotlistr = STACK_0;
  7728.              STACK_0 = Cdr(slotlistr); # Liste verkürzen
  7729.              pushSTACK(Car(slotlistr)); # ein einzelner slot
  7730.             }
  7731.             JUSTIFY_SPACE; # Space ausgeben
  7732.             # auf Erreichen von *PRINT-LENGTH* prüfen:
  7733.             if (length >= length_limit)
  7734.               { # Rest durch '...' abkürzen:
  7735.                 write_schar(stream_,'.');
  7736.                 write_schar(stream_,'.');
  7737.                 write_schar(stream_,'.');
  7738.                 skipSTACK(1); # slot vergessen
  7739.                 break;
  7740.               }
  7741.            {var reg1 object* slot_ = &STACK_0; # da sitzt der Slot
  7742.             JUSTIFY_START;
  7743.             write_schar(stream_,':'); # Keyword-Kennzeichen
  7744.             # (first slot) sollte ein Symbol sein
  7745.             pr_like_symbol(stream_,Symbol_name(Car(*slot_))); # Symbolnamen der Komponente ausgeben
  7746.             JUSTIFY_SPACE;
  7747.             pushSTACK(*(obj_ STACKop 0)); # obj als Argument
  7748.             funcall(Cdr(*slot_),1); # accessor aufrufen
  7749.             prin_object(stream_,value1); # Komponente ausgeben
  7750.             JUSTIFY_END_ENG;
  7751.             skipSTACK(1); # slot vergessen
  7752.       }   }}
  7753.       skipSTACK(1);
  7754.       JUSTIFY_END_ENG;
  7755.       if (readable) # Beendung der Fallunterscheidung von oben
  7756.         { INDENT_END;
  7757.           KLAMMER_ZU;
  7758.         }
  7759.         else
  7760.         { INDENT_END;
  7761.           write_schar(stream_,'>');
  7762.         }
  7763.       skipSTACK(3);
  7764.       LEVEL_END3;
  7765.     }}
  7766.  
  7767. # UP: Gibt einen OtherRecord auf einen Stream aus.
  7768. # pr_orecord(&stream,obj);
  7769. # > obj: OtherRecord
  7770. # > stream: Stream
  7771. # < stream: Stream
  7772. # kann GC auslösen
  7773.   local void pr_orecord (object *stream_,object obj);
  7774.   local void pr_orecord(stream_,obj)
  7775.     var reg2 object* stream_;
  7776.     var reg3 object obj;
  7777.     { switch (TheRecord(obj)->rectype)
  7778.         { case Rectype_Hashtable:
  7779.             # je nach *PRINT-ARRAY* :
  7780.             # #<HASH-TABLE #x...> oder
  7781.             # #S(HASH-TABLE test (Key_1 . Value_1) ... (Key_n . Value_n))
  7782.             if (test_value(S(print_array)) || test_value(S(print_readably)))
  7783.               { LEVEL_CHECK1(obj);
  7784.                 pushSTACK(obj); # Hash-Tabelle retten
  7785.                {var reg7 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  7786.                 write_schar(stream_,'#'); write_schar(stream_,'S');
  7787.                 KLAMMER_AUF;
  7788.                 INDENT_START(3); # um 3 Zeichen einrücken, wegen '#S('
  7789.                 JUSTIFY_START;
  7790.                 prin_object(stream_,S(hash_table)); # Symbol HASH-TABLE ausgeben
  7791.                 obj = *obj_;
  7792.                 { var reg1 uintL index = # Index in den Key-Value-Vektor
  7793.                     2*posfixnum_to_L(TheHashtable(obj)->ht_maxcount);
  7794.                   pushSTACK(TheHashtable(obj)->ht_kvtable); # Key-Value-Vektor
  7795.                  {var reg6 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  7796.                   var reg5 uintL length = 0; # bisherige Länge := 0
  7797.                   JUSTIFY_SPACE; # Space ausgeben
  7798.                   # auf Erreichen von *PRINT-LENGTH* prüfen:
  7799.                   if (length >= length_limit) goto dots;
  7800.                   # Hash-Test ausgeben:
  7801.                   { var reg4 uintB flags = TheHashtable(*obj_)->recflags;
  7802.                     var reg7 object test = # Test-Symbol EQ/EQL/EQUAL
  7803.                       (flags & bit(0) ? S(eq) :
  7804.                        flags & bit(1) ? S(eql) :
  7805.                        flags & bit(2) ? S(equal) :
  7806.                                         NIL # (Default-Symbol)
  7807.                       );
  7808.                     prin_object(stream_,test);
  7809.                   }
  7810.                   loop
  7811.                     { length++; # bisherige Länge erhöhen
  7812.                       # nächstes auszugebendes Key-Value-Paar suchen:
  7813.                       loop
  7814.                         { if (index==0) goto kvtable_end; # kvtable zu Ende?
  7815.                           index -= 2; # Index verringern
  7816.                           if (!eq(TheSvector(STACK_0)->data[index+0],unbound)) # Key /= "leer" ?
  7817.                             break;
  7818.                         }
  7819.                       JUSTIFY_SPACE; # Space ausgeben
  7820.                       # auf Erreichen von *PRINT-LENGTH* prüfen:
  7821.                       if (length >= length_limit)
  7822.                         { dots:
  7823.                           # Rest durch '...' abkürzen:
  7824.                           write_schar(stream_,'.');
  7825.                           write_schar(stream_,'.');
  7826.                           write_schar(stream_,'.');
  7827.                           break;
  7828.                         }
  7829.                       # Cons (Key . Value) bilden und ausgeben:
  7830.                       obj = allocate_cons();
  7831.                       { var reg4 object* ptr = &TheSvector(STACK_0)->data[index];
  7832.                         Car(obj) = ptr[0]; # Key
  7833.                         Cdr(obj) = ptr[1]; # Value
  7834.                       }
  7835.                       prin_object(stream_,obj);
  7836.                     }
  7837.                   kvtable_end: # Ende der Ausgabe der Key-Value-Paare
  7838.                   skipSTACK(1);
  7839.                 }}
  7840.                 JUSTIFY_END_ENG;
  7841.                 INDENT_END;
  7842.                 KLAMMER_ZU;
  7843.                 skipSTACK(1);
  7844.                 LEVEL_END1;
  7845.               }}
  7846.               else
  7847.               { pr_hex6_obj(stream_,obj,O(printstring_hash_table)); }
  7848.             break;
  7849.           case Rectype_Package:
  7850.             # je nach *PRINT-READABLY*:
  7851.             # #<PACKAGE name> oder #.(SYSTEM::%FIND-PACKAGE "name")
  7852.             { pushSTACK(obj); # Package retten
  7853.              {var reg1 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  7854.               if (!test_value(S(print_readably)))
  7855.                 { write_schar(stream_,'#'); write_schar(stream_,'<');
  7856.                   INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  7857.                   JUSTIFY_START;
  7858.                   if (pack_deletedp(*obj_))
  7859.                     { write_sstring_case(stream_,O(printstring_deleted)); } # "DELETED "
  7860.                   write_sstring_case(stream_,O(printstring_package)); # "PACKAGE"
  7861.                   JUSTIFY_SPACE;
  7862.                   pr_like_symbol(stream_,ThePackage(*obj_)->pack_name); # Name ausgeben
  7863.                   JUSTIFY_END_ENG;
  7864.                   INDENT_END;
  7865.                   write_schar(stream_,'>');
  7866.                 }
  7867.                 else
  7868.                 { if (pack_deletedp(*obj_)) { fehler_print_readably(*obj_); }
  7869.                   write_schar(stream_,'#'); write_schar(stream_,'.');
  7870.                   KLAMMER_AUF; # '('
  7871.                   INDENT_START(3); # um 3 Zeichen einrücken, wegen '#.('
  7872.                   JUSTIFY_START;
  7873.                   pr_symbol(stream_,S(pfind_package)); # SYSTEM::%FIND-PACKAGE
  7874.                   JUSTIFY_SPACE;
  7875.                   pr_string(stream_,ThePackage(*obj_)->pack_name); # Name ausgeben
  7876.                   JUSTIFY_END_ENG;
  7877.                   INDENT_END;
  7878.                   KLAMMER_ZU;
  7879.                 }
  7880.               skipSTACK(1);
  7881.             }}break;
  7882.           case Rectype_Readtable:
  7883.             # #<READTABLE #x...>
  7884.             if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7885.             pr_hex6_obj(stream_,obj,O(printstring_readtable));
  7886.             break;
  7887.           case Rectype_Pathname:
  7888.             {
  7889.               #ifdef PATHNAME_NOEXT
  7890.               # nur bei *PRINT-ESCAPE* /= NIL (sonst s.u.)
  7891.               if (test_value(S(print_escape)) || test_value(S(print_readably)))
  7892.                 # Pathnames, deren Namestring als ein anderer Pathname interpretiert
  7893.                 # würde, geben wir anders aus. Wegen der Regel der Aufspaltung in
  7894.                 # Name und Typ am letzten Punkt sind dies folgende Fälle:
  7895.                 # - Typ = NIL, und der Name enthält Punkte,
  7896.                 # - Typ enthält Punkte.
  7897.                 { var reg5 object part = ThePathname(obj)->pathname_type;
  7898.                   if (nullp(part)) { part = ThePathname(obj)->pathname_name; }
  7899.                   if (simple_string_p(part))
  7900.                     # Feststellung, ob part Punkte enthält:
  7901.                     { var reg4 uintL count = TheSstring(part)->length;
  7902.                       var reg1 uintB* ptr = &TheSstring(part)->data[0];
  7903.                       dotimesL(count,count, { if (*ptr++ == '.') goto pathname_nonstring; } );
  7904.                 }   }
  7905.               #endif
  7906.               # Bei *PRINT-READABLY* komponentenweise ausgeben (sicher ist sicher):
  7907.               if (test_value(S(print_readably))) goto pathname_nonstring;
  7908.               pushSTACK(obj); # Pathname retten
  7909.               # (NAMESTRING pathname) ausführen:
  7910.               pushSTACK(obj); funcall(L(namestring),1);
  7911.               obj = value1;
  7912.               if (stringp(obj)) # sollte einen String liefern (liefert z.Zt. sogar immer einen Simple-String)
  7913.                 # Syntax #"namestring"
  7914.                 { # *PRINT-ESCAPE* abfragen:
  7915.                   if (test_value(S(print_escape)) || test_value(S(print_readably)))
  7916.                     { STACK_0 = obj; # String retten
  7917.                       write_schar(stream_,'#'); # '#' ausgeben
  7918.                       pr_string(stream_,STACK_0); # String (in Anführungszeichen) ausgeben
  7919.                     }
  7920.                     else
  7921.                     # keine Anführungszeichen -> auch kein '#' ausgeben:
  7922.                     { write_string(stream_,obj); }
  7923.                   skipSTACK(1);
  7924.                 }
  7925.                 else
  7926.                 # Falls NAMESTRING keinen String lieferte:
  7927.                 { obj = popSTACK(); # Pathname zurück
  7928.                   pathname_nonstring:
  7929.                   # #S(PATHNAME :DEVICE device :DIRECTORY directory :NAME name :TYPE type)
  7930.                   pr_record_descr(stream_,obj,S(pathname),TRUE,O(pathname_slotlist));
  7931.                 }
  7932.             }
  7933.             break;
  7934.           #ifdef LOGICAL_PATHNAMES
  7935.           case Rectype_Logpathname:
  7936.             # #S(LOGICAL-PATHNAME :HOST host :DIRECTORY directory :NAME name :TYPE type :VERSION version)
  7937.             pr_record_descr(stream_,obj,S(logical_pathname),TRUE,O(pathname_slotlist));
  7938.             break;
  7939.           #endif
  7940.           case Rectype_Random_State:
  7941.             # #S(RANDOM-STATE seed)
  7942.             { LEVEL_CHECK1(obj);
  7943.               pushSTACK(obj); # Random-State retten
  7944.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  7945.               write_schar(stream_,'#'); write_schar(stream_,'S');
  7946.               KLAMMER_AUF;
  7947.               INDENT_START(3); # um 3 Zeichen einrücken, wegen '#S('
  7948.               JUSTIFY_START;
  7949.               prin_object(stream_,S(random_state)); # Symbol RANDOM-STATE ausgeben
  7950.               pr_record_ab(stream_,obj_,0,0); # Komponente ausgeben
  7951.               JUSTIFY_END_ENG;
  7952.               INDENT_END;
  7953.               KLAMMER_ZU;
  7954.               skipSTACK(1);
  7955.               LEVEL_END1;
  7956.             }}break;
  7957.           #ifndef case_structure
  7958.           case Rectype_Structure: # Structure
  7959.             pr_structure(stream_,obj); break;
  7960.           #endif
  7961.           #ifndef case_stream
  7962.           case Rectype_Stream: # Stream
  7963.             pr_stream(stream_,obj); break;
  7964.           #endif
  7965.           case Rectype_Byte:
  7966.             #if 0
  7967.             # #<BYTE size position>
  7968.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  7969.               LEVEL_CHECK1(obj);
  7970.               pushSTACK(obj); # Byte retten
  7971.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  7972.               write_schar(stream_,'#'); write_schar(stream_,'<');
  7973.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  7974.               JUSTIFY_START;
  7975.               write_sstring_case(stream_,O(printstring_byte)); # "BYTE"
  7976.               pr_record_ab(stream_,obj_,0,0); # Komponenten ausgeben
  7977.               JUSTIFY_END_ENG;
  7978.               INDENT_END;
  7979.               write_schar(stream_,'>');
  7980.               skipSTACK(1);
  7981.               LEVEL_END1;
  7982.             }}
  7983.             #else
  7984.             # #S(BYTE :SIZE size :POSITION position)
  7985.             pr_record_descr(stream_,obj,S(byte),TRUE,O(byte_slotlist));
  7986.             #endif
  7987.             break;
  7988.           case Rectype_Fsubr: # Fsubr
  7989.             pr_fsubr(stream_,obj);
  7990.             break;
  7991.           case Rectype_Loadtimeeval:
  7992.             # #.form
  7993.             { var reg1 object* obj_; 
  7994.               pushSTACK(TheLoadtimeeval(obj)->loadtimeeval_form); # form retten
  7995.               obj_ = &STACK_0;
  7996.               write_schar(stream_,'#'); write_schar(stream_,'.');
  7997.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#.'
  7998.               prin_object_(stream_,obj_); # form ausgeben
  7999.               INDENT_END;
  8000.               skipSTACK(1);
  8001.             } break;
  8002.           case Rectype_Symbolmacro:
  8003.             # #<SYMBOL-MACRO expansion>
  8004.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8005.               LEVEL_CHECK1(obj);
  8006.               pushSTACK(obj); # Symbol-Macro retten
  8007.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8008.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8009.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8010.               JUSTIFY_START;
  8011.               write_sstring_case(stream_,O(printstring_symbolmacro)); # "SYMBOL-MACRO"
  8012.               pr_record_ab(stream_,obj_,0,0); # Komponente ausgeben
  8013.               JUSTIFY_END_ENG;
  8014.               INDENT_END;
  8015.               write_schar(stream_,'>');
  8016.               skipSTACK(1);
  8017.               LEVEL_END1;
  8018.             }}
  8019.             break;
  8020.           #ifdef FOREIGN
  8021.           case Rectype_Fpointer:
  8022.             # #<FOREIGN-POINTER address>
  8023.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8024.               LEVEL_CHECK1(obj);
  8025.              {var reg6 boolean validp = fp_validp(TheFpointer(obj));
  8026.               var reg1 uintP val = (uintP)(TheFpointer(obj)->fp_pointer); # Wert holen
  8027.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8028.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8029.               JUSTIFY_START;
  8030.               if (!validp)
  8031.                 { write_sstring_case(stream_,O(printstring_invalid)); } # "INVALID "
  8032.               write_sstring_case(stream_,O(printstring_fpointer)); # "FOREIGN-POINTER"
  8033.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*
  8034.                var reg4 uintL length = 0; # bisherige Länge := 0
  8035.                # auf Erreichen von *PRINT-LENGTH* prüfen:
  8036.                if (length >= length_limit) goto fpointer_end;
  8037.                JUSTIFY_SPACE; # Space ausgeben
  8038.                # Adresse ausgeben:
  8039.                pr_hex8(stream_,val);
  8040.                length++; # bisherige Länge erhöhen
  8041.               }
  8042.               fpointer_end:
  8043.               JUSTIFY_END_ENG;
  8044.               INDENT_END;
  8045.               write_schar(stream_,'>');
  8046.               LEVEL_END1;
  8047.             }}break;
  8048.           #endif
  8049.           #ifdef DYNAMIC_FFI
  8050.           case Rectype_Faddress:
  8051.             # #<FOREIGN-ADDRESS #x...>
  8052.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8053.               LEVEL_CHECK1(obj);
  8054.               pushSTACK(obj); # retten
  8055.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8056.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8057.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8058.               JUSTIFY_START;
  8059.               if (!fp_validp(TheFpointer(TheFaddress(*obj_)->fa_base)))
  8060.                 { write_sstring_case(stream_,O(printstring_invalid)); } # "INVALID "
  8061.               write_sstring_case(stream_,O(printstring_faddress)); # "FOREIGN-ADDRESS"
  8062.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*
  8063.                var reg4 uintL length = 0; # bisherige Länge := 0
  8064.                # auf Erreichen von *PRINT-LENGTH* prüfen:
  8065.                if (length >= length_limit) goto faddress_end;
  8066.                JUSTIFY_SPACE; # Space ausgeben
  8067.                # Adresse ausgeben, vgl. Macro Faddress_value():
  8068.                pr_hex8(stream_,(uintP)TheFpointer(TheFaddress(*obj_)->fa_base)->fp_pointer
  8069.                                +  TheFaddress(*obj_)->fa_offset
  8070.                       );
  8071.                length++; # bisherige Länge erhöhen
  8072.               }
  8073.               faddress_end:
  8074.               JUSTIFY_END_ENG;
  8075.               INDENT_END;
  8076.               write_schar(stream_,'>');
  8077.               skipSTACK(1);
  8078.               LEVEL_END1;
  8079.             }}break;
  8080.           case Rectype_Fvariable:
  8081.             # #<FOREIGN-VARIABLE name #x...>
  8082.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8083.               LEVEL_CHECK1(obj);
  8084.               pushSTACK(obj); # retten
  8085.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8086.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8087.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8088.               JUSTIFY_START;
  8089.               write_sstring_case(stream_,O(printstring_fvariable)); # "FOREIGN-VARIABLE"
  8090.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*
  8091.                var reg4 uintL length = 0; # bisherige Länge := 0
  8092.                # auf Erreichen von *PRINT-LENGTH* prüfen:
  8093.                if (length >= length_limit) goto fvariable_end;
  8094.                JUSTIFY_SPACE; # Space ausgeben
  8095.                # Name ausgeben:
  8096.                if (!nullp(TheFvariable(*obj_)->fv_name))
  8097.                  { prin_object(stream_,TheFvariable(*obj_)->fv_name);
  8098.                    length++; # bisherige Länge erhöhen
  8099.                    if (length >= length_limit) goto fvariable_end;
  8100.                    JUSTIFY_SPACE; # Space ausgeben
  8101.                  }
  8102.                # Adresse ausgeben:
  8103.                pr_hex8(stream_,(uintP)Faddress_value(TheFvariable(*obj_)->fv_address));
  8104.                length++; # bisherige Länge erhöhen
  8105.               }
  8106.               fvariable_end:
  8107.               JUSTIFY_END_ENG;
  8108.               INDENT_END;
  8109.               write_schar(stream_,'>');
  8110.               skipSTACK(1);
  8111.               LEVEL_END1;
  8112.             }}break;
  8113.           case Rectype_Ffunction:
  8114.             # #<FOREIGN-FUNCTION name #x...>
  8115.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8116.               LEVEL_CHECK1(obj);
  8117.               pushSTACK(obj); # retten
  8118.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8119.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8120.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8121.               JUSTIFY_START;
  8122.               write_sstring_case(stream_,O(printstring_ffunction)); # "FOREIGN-FUNCTION"
  8123.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*
  8124.                var reg4 uintL length = 0; # bisherige Länge := 0
  8125.                # auf Erreichen von *PRINT-LENGTH* prüfen:
  8126.                if (length >= length_limit) goto ffunction_end;
  8127.                JUSTIFY_SPACE; # Space ausgeben
  8128.                # Name ausgeben:
  8129.                if (!nullp(TheFfunction(*obj_)->ff_name))
  8130.                  { prin_object(stream_,TheFfunction(*obj_)->ff_name);
  8131.                    length++; # bisherige Länge erhöhen
  8132.                    if (length >= length_limit) goto ffunction_end;
  8133.                    JUSTIFY_SPACE; # Space ausgeben
  8134.                  }
  8135.                # Adresse ausgeben:
  8136.                pr_hex8(stream_,(uintP)Faddress_value(TheFfunction(*obj_)->ff_address));
  8137.                length++; # bisherige Länge erhöhen
  8138.               }
  8139.               ffunction_end:
  8140.               JUSTIFY_END_ENG;
  8141.               INDENT_END;
  8142.               write_schar(stream_,'>');
  8143.               skipSTACK(1);
  8144.               LEVEL_END1;
  8145.             }}break;
  8146.           #endif
  8147.           case Rectype_Finalizer:
  8148.             # #<FINALIZER>
  8149.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8150.               write_sstring_case(stream_,O(printstring_finalizer));
  8151.             } break;
  8152.           #ifdef SOCKET_STREAMS
  8153.           case Rectype_Socket_Server:
  8154.             # #<SOCKET-SERVER port>
  8155.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8156.               LEVEL_CHECK1(obj);
  8157.               pushSTACK(obj); # Socket-Server retten
  8158.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8159.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8160.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8161.               JUSTIFY_START;
  8162.               write_sstring_case(stream_,O(printstring_socket_server));
  8163.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  8164.                var reg4 uintL length = 0; # bisherige Länge := 0
  8165.                # auf Erreichen von *PRINT-LENGTH* prüfen:
  8166.                if (length >= length_limit) goto socket_server_end;
  8167.                JUSTIFY_SPACE; # Space ausgeben
  8168.                prin_object(stream_,TheSocketServer(*obj_)->port);
  8169.                length++; # bisherige Länge erhöhen
  8170.               }
  8171.               socket_server_end:
  8172.               JUSTIFY_END_ENG;
  8173.               INDENT_END;
  8174.               write_schar(stream_,'>');
  8175.               skipSTACK(1);
  8176.               LEVEL_END1;
  8177.             }}break;
  8178.           #endif
  8179.           #ifdef YET_ANOTHER_RECORD
  8180.           case Rectype_Yetanother:
  8181.             # #<YET-ANOTHER address>
  8182.             { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8183.               LEVEL_CHECK1(obj);
  8184.               pushSTACK(obj); # Yetanother retten
  8185.              {var reg1 object* obj_ = &STACK_0; # und merken, wo es sitzt
  8186.               write_schar(stream_,'#'); write_schar(stream_,'<');
  8187.               INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8188.               JUSTIFY_START;
  8189.               write_sstring_case(stream_,O(printstring_yetanother)); # "YET-ANOTHER"
  8190.               {var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  8191.                var reg4 uintL length = 0; # bisherige Länge := 0
  8192.                # auf Erreichen von *PRINT-LENGTH* prüfen:
  8193.                if (length >= length_limit) goto yetanother_end;
  8194.                JUSTIFY_SPACE; # Space ausgeben
  8195.                # x ausgeben:
  8196.                pr_hex6(stream_,TheYetanother(*obj_)->yetanother_x);
  8197.                length++; # bisherige Länge erhöhen
  8198.               }
  8199.               yetanother_end:
  8200.               JUSTIFY_END_ENG;
  8201.               INDENT_END;
  8202.               write_schar(stream_,'>');
  8203.               skipSTACK(1);
  8204.               LEVEL_END1;
  8205.             }}break;
  8206.           #endif
  8207.           default:
  8208.             pushSTACK(S(print));
  8209.             //: DEUTSCH "~: Record unbekannten Typs ist aufgetaucht!"
  8210.             //: ENGLISH "~: an unknown record type has been generated!"
  8211.             //: FRANCAIS "~ : Un objet composé de type inconnu a été rencontré!"
  8212.             fehler(serious_condition, GETTEXT("~: an unknown record type has been generated!"));
  8213.     }   }
  8214.  
  8215. #                    -------- SUBRs, FSUBRs --------
  8216.  
  8217. # UP: Gibt ein Objekt in Form #<BLABLA other> auf einen Stream aus.
  8218. # pr_other_obj(&stream,other,string);
  8219. # > other: Objekt
  8220. # > string: Simple-String "BLABLA"
  8221. # > stream: Stream
  8222. # < stream: Stream
  8223. # kann GC auslösen
  8224.   local void pr_other_obj (object* stream_, object other, object string);
  8225.   local void pr_other_obj(stream_,other,string)
  8226.     var reg1 object* stream_;
  8227.     var reg4 object other;
  8228.     var reg3 object string;
  8229.     { pushSTACK(other); # other retten
  8230.       pushSTACK(string); # String retten
  8231.      {var reg2 object* string_ = &STACK_0; # und merken, wo beides sitzt
  8232.       write_schar(stream_,'#'); write_schar(stream_,'<');
  8233.       INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8234.       JUSTIFY_START;
  8235.       write_sstring_case(stream_,*string_); # String ausgeben
  8236.       JUSTIFY_SPACE;
  8237.       prin_object(stream_,*(string_ STACKop 1)); # other ausgeben
  8238.       JUSTIFY_END_ENG;
  8239.       INDENT_END;
  8240.       write_schar(stream_,'>');
  8241.       skipSTACK(2);
  8242.     }}
  8243.  
  8244. # UP: Gibt ein SUBR auf einen Stream aus.
  8245. # pr_subr(&stream,obj);
  8246. # > obj: SUBR
  8247. # > stream: Stream
  8248. # < stream: Stream
  8249. # kann GC auslösen
  8250.   local void pr_subr (object *stream_,object obj);
  8251.   local void pr_subr(stream_,obj)
  8252.     var reg2 object* stream_;
  8253.     var reg1 object obj;
  8254.     { # #<SYSTEM-FUNCTION name> bzw. #<ADD-ON-SYSTEM-FUNCTION name>
  8255.       if (test_value(S(print_readably)))
  8256.         { 
  8257.           pushSTACK(obj); # save object
  8258.          {var reg3 object* obj_ = &STACK_0;
  8259.           write_schar(stream_,'#'); write_schar(stream_,'.');
  8260.           KLAMMER_AUF; # '('
  8261.           INDENT_START(3); # um 3 Zeichen einrücken, wegen '#.('
  8262.           JUSTIFY_START;
  8263.           pr_symbol(stream_,S(find_subr)); # SYSTEM::%FIND-SUBR
  8264.           JUSTIFY_SPACE;
  8265.           write_schar(stream_,'\'');
  8266.           pr_symbol(stream_,TheSubr(*obj_)->name); # Name ausgeben
  8267.           JUSTIFY_END_ENG;
  8268.           INDENT_END;
  8269.           KLAMMER_ZU;
  8270.           skipSTACK(1);
  8271.         }}
  8272.       else
  8273.         { pr_other_obj(stream_,TheSubr(obj)->name,
  8274.                        ((as_oint(subr_tab_ptr_as_object(&subr_tab)) <= as_oint(obj))
  8275.                         && (as_oint(obj) < as_oint(subr_tab_ptr_as_object(&subr_tab+1)))
  8276.                        ) ? O(printstring_subr) : O(printstring_addon_subr)
  8277.                       );
  8278.         }
  8279.     }
  8280.  
  8281. # UP: Gibt ein FSUBR auf einen Stream aus.
  8282. # pr_fsubr(&stream,obj);
  8283. # > obj: FSUBR
  8284. # > stream: Stream
  8285. # < stream: Stream
  8286. # kann GC auslösen
  8287.   local void pr_fsubr (object *stream_,object obj);
  8288.   local void pr_fsubr(stream_,obj)
  8289.     var reg2 object* stream_;
  8290.     var reg1 object obj;
  8291.     { # #<SPECIAL-FORM name>
  8292.       if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8293.       pr_other_obj(stream_,TheFsubr(obj)->name,O(printstring_fsubr));
  8294.     }
  8295.  
  8296. #                       -------- Closures --------
  8297.  
  8298. # UP: Gibt eine Closure auf einen Stream aus.
  8299. # pr_closure(&stream,obj);
  8300. # > obj: Closure
  8301. # > stream: Stream
  8302. # < stream: Stream
  8303. # kann GC auslösen
  8304.   local void pr_closure (object *stream_,object obj);
  8305.   local void pr_closure(stream_,obj)
  8306.     var reg1 object* stream_;
  8307.     var reg4 object obj;
  8308.     { if (m_simple_bit_vector_p(TheClosure(obj)->clos_codevec))
  8309.         # compilierte Closure
  8310.         { pr_cclosure(stream_,obj); }
  8311.         else
  8312.         # interpretierte Closure ausgeben: #<CLOSURE ...>
  8313.         { # Falls *PRINT-CLOSURE* /= NIL, alles, sonst den Namen und
  8314.           # (falls noch vorhanden) Lambdaliste und Formen, ausgeben:
  8315.           if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8316.           LEVEL_CHECK1(obj);
  8317.           pushSTACK(obj); # Closure retten
  8318.          {var reg2 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  8319.           write_schar(stream_,'#'); write_schar(stream_,'<');
  8320.           INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8321.           JUSTIFY_START;
  8322.           write_sstring_case(stream_,O(printstring_closure));
  8323.           if (test_value(S(print_closure))) # *PRINT-CLOSURE* abfragen
  8324.             # *PRINT-CLOSURE* /= NIL -> #<CLOSURE komponente1 ...> ausgeben:
  8325.             { pr_record_ab(stream_,obj_,0,0); } # alle weiteren Komponenten ausgeben
  8326.             else
  8327.             # *PRINT-CLOSURE* = NIL -> #<CLOSURE name . form> ausgeben:
  8328.             { JUSTIFY_SPACE;
  8329.               prin_object(stream_,TheIclosure(*obj_)->clos_name); # Name ausgeben
  8330.               # Formenliste elementweise ausgeben:
  8331.               pr_record_rest(stream_,TheIclosure(*obj_)->clos_form,1);
  8332.             }
  8333.           JUSTIFY_END_ENG;
  8334.           INDENT_END;
  8335.           write_schar(stream_,'>');
  8336.           skipSTACK(1);
  8337.           LEVEL_END1;
  8338.         }}
  8339.     }
  8340.  
  8341. # UP: Gibt eine compilierte Closure auf einen Stream aus.
  8342. # pr_cclosure(&stream,obj);
  8343. # > obj: compilierte Closure
  8344. # > stream: Stream
  8345. # < stream: Stream
  8346. # kann GC auslösen
  8347.   local void pr_cclosure (object *stream_,object obj);
  8348.   local void pr_cclosure(stream_,obj)
  8349.     var reg2 object* stream_;
  8350.     var reg1 object obj;
  8351.     { # *PRINT-CLOSURE* abfragen:
  8352.       if (test_value(S(print_closure)) || test_value(S(print_readably)))
  8353.         # *PRINT-CLOSURE /= NIL -> in wiedereinlesbarer Form #Y(...) ausgeben
  8354.         { pr_cclosure_lang(stream_,obj); }
  8355.         else
  8356.         # *PRINT-CLOSURE* = NIL ->
  8357.         # nur #<GENERIC-FUNCTION name> bzw. #<COMPILED-CLOSURE name> ausgeben:
  8358.         { pr_other_obj(stream_,TheClosure(obj)->clos_name,
  8359.                        (TheSbvector(TheClosure(obj)->clos_codevec)->data[CCHD+4] & bit(4) # generische Funktion?
  8360.                         ? O(printstring_generic_function)
  8361.                         : O(printstring_compiled_closure)
  8362.                       ));
  8363.         }
  8364.     }
  8365.  
  8366. # compilierte Closure in wiedereinlesbarer Form ausgeben:
  8367. # (defun %print-cclosure (closure)
  8368. #   (princ "#Y(")
  8369. #   (prin1 (closure-name closure))
  8370. #   (princ " #")
  8371. #   (let ((L (closure-codevec closure)))
  8372. #     (let ((*print-base* 10.)) (prin1 (length L)))
  8373. #     (princ "Y(")
  8374. #     (let ((*print-base* 16.))
  8375. #       (do ((i 0 (1- i))
  8376. #            (x L (cdr x)))
  8377. #           ((endp x))
  8378. #         (when (zerop i) (terpri) (setq i 25))
  8379. #         (princ " ")
  8380. #         (prin1 (car x))
  8381. #     ) )
  8382. #     (princ ")")
  8383. #   )
  8384. #   (terpri)
  8385. #   (dolist (x (closure-consts closure))
  8386. #     (princ " ")
  8387. #     (prin1 x)
  8388. #   )
  8389. #   (princ ")")
  8390. # )
  8391. # UP: Gibt eine compilierte Closure in wiedereinlesbarer Form
  8392. # auf einen Stream aus.
  8393. # pr_cclosure_lang(&stream,obj);
  8394. # > obj: compilierte Closure
  8395. # > stream: Stream
  8396. # < stream: Stream
  8397. # kann GC auslösen
  8398.   local void pr_cclosure_lang (object *stream_,object obj);
  8399.   local void pr_cclosure_lang(stream_,obj)
  8400.     var reg2 object* stream_;
  8401.     var reg3 object obj;
  8402.     { LEVEL_CHECK1(obj);
  8403.       pushSTACK(obj); # Closure retten
  8404.      {var reg1 object* obj_ = &STACK_0; # und merken, wo sie sitzt
  8405.       write_schar(stream_,'#'); write_schar(stream_,'Y');
  8406.       KLAMMER_AUF;
  8407.       INDENT_START(3); # um 3 Zeichen einrücken, wegen '#Y('
  8408.       JUSTIFY_START;
  8409.       prin_object(stream_,TheClosure(*obj_)->clos_name); # Name ausgeben
  8410.       JUSTIFY_SPACE;
  8411.       # Codevektor byteweise ausgeben, dabei Zirkularität behandeln:
  8412.       pr_circle_(stream_,&TheClosure(*obj_)->clos_codevec,&pr_cclosure_codevector);
  8413.       pr_record_ab(stream_,obj_,2,2); # restliche Komponenten ausgeben
  8414.       JUSTIFY_END_ENG;
  8415.       INDENT_END;
  8416.       KLAMMER_ZU;
  8417.       skipSTACK(1);
  8418.       LEVEL_END1;
  8419.     }}
  8420.  
  8421. # UP: Gibt einen Closure-Codevektor in #nY(...)-Schreibweise
  8422. # auf einen Stream aus.
  8423. # pr_cclosure_codevector(&stream,codevec);
  8424. # > codevec: ein Simple-Bit-Vektor
  8425. # > stream: Stream
  8426. # < stream: Stream
  8427. # kann GC auslösen
  8428.   local void pr_cclosure_codevector (object *stream_,object codevec);
  8429.   local void pr_cclosure_codevector(stream_,codevec)
  8430.     var reg2 object* stream_;
  8431.     var reg6 object codevec;
  8432.     { LEVEL_CHECK1(codevec);
  8433.       pushSTACK(codevec); # Codevektor retten
  8434.      {var reg1 object* codevec_ = &STACK_0; # und merken, wo er sitzt
  8435.       var reg3 uintL len = (TheSbvector(codevec)->length)/8; # Länge in Bytes
  8436.       # Präfix ausgeben:
  8437.       INDENTPREP_START;
  8438.       write_schar(stream_,'#');
  8439.       pr_uint(stream_,len); # Länge dezimal ausgeben
  8440.       write_schar(stream_,'Y');
  8441.       {var reg1 uintL indent = INDENTPREP_END;
  8442.       # Hauptteil ausgeben:
  8443.        INDENT_START(indent); # einrücken
  8444.       }
  8445.       KLAMMER_AUF;
  8446.       INDENT_START(1); # um 1 Zeichen einrücken, wegen '('
  8447.       JUSTIFY_START;
  8448.       { var reg5 uintL length_limit = get_print_length(); # *PRINT-LENGTH*-Begrenzung
  8449.         var reg4 uintL length = 0; # Index = bisherige Länge := 0
  8450.         dotimesL(len,len,
  8451.           { # (außer vorm ersten Element) Space ausgeben:
  8452.             if (!(length==0)) { JUSTIFY_SPACE; }
  8453.             # auf Erreichen von *PRINT-LENGTH* prüfen:
  8454.             if (length >= length_limit)
  8455.               { # Rest durch '...' abkürzen:
  8456.                 write_schar(stream_,'.');
  8457.                 write_schar(stream_,'.');
  8458.                 write_schar(stream_,'.');
  8459.                 break;
  8460.               }
  8461.             # Byte ausgeben:
  8462.             pr_hex2(stream_,TheSbvector(*codevec_)->data[length]);
  8463.             length++; # Index erhöhen
  8464.           });
  8465.       }
  8466.       JUSTIFY_END_ENG;
  8467.       INDENT_END;
  8468.       KLAMMER_ZU;
  8469.       INDENT_END;
  8470.       skipSTACK(1);
  8471.       LEVEL_END1;
  8472.     }}
  8473.  
  8474. #                       -------- Streams --------
  8475.  
  8476. # UP: Gibt einen Stream auf einen Stream aus.
  8477. # pr_stream(&stream,obj);
  8478. # > obj: auszugebender Stream
  8479. # > stream: Stream
  8480. # < stream: Stream
  8481. # kann GC auslösen
  8482.   local void pr_stream (object *stream_,object obj);
  8483.   local void pr_stream(stream_,obj)
  8484.     var reg2 object* stream_;
  8485.     var reg4 object obj;
  8486.     { if (test_value(S(print_readably))) { fehler_print_readably(obj); }
  8487.       pushSTACK(obj); # Stream retten
  8488.      {var reg1 object* obj_ = &STACK_0; # und merken, wo er sitzt
  8489.       write_schar(stream_,'#'); write_schar(stream_,'<');
  8490.       INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  8491.       JUSTIFY_START;
  8492.       # falls Stream geschlossen, "CLOSED " ausgeben:
  8493.       if ((TheStream(*obj_)->strmflags & strmflags_open_B) == 0)
  8494.         { write_sstring_case(stream_,O(printstring_closed)); }
  8495.       # Streamtyp ausgeben:
  8496.       { var reg4 uintL type = TheStream(*obj_)->strmtype;
  8497.        {var reg3 object* stringtable = &O(printstring_closed) + 1;
  8498.         write_sstring_case(stream_,stringtable[type]); # String aus Tabelle holen
  8499.        }
  8500.       # "-STREAM" ausgeben:
  8501.         write_sstring_case(stream_,O(printstring_stream));
  8502.       # Streamspezifische Zusatzinformation:
  8503.         switch (type)
  8504.           { case strmtype_sch_file:
  8505.             case strmtype_ch_file:
  8506.             case strmtype_iu_file:
  8507.             case strmtype_is_file:
  8508.             #ifdef HANDLES
  8509.             case strmtype_handle:
  8510.             #endif
  8511.               # File-Stream
  8512.               JUSTIFY_SPACE;
  8513.               prin_object(stream_,TheStream(*obj_)->strm_file_name); # Filename ausgeben
  8514.               break;
  8515.             case strmtype_synonym:
  8516.               # Synonym-Stream
  8517.               JUSTIFY_SPACE;
  8518.               prin_object(stream_,TheStream(*obj_)->strm_synonym_symbol); # Symbol ausgeben
  8519.               break;
  8520.             case strmtype_broad:
  8521.               # Broadcast-Stream
  8522.               pr_record_rest(stream_,TheStream(*obj_)->strm_broad_list,0); # Streams ausgeben
  8523.               break;
  8524.             case strmtype_concat:
  8525.               # Concatenated-Stream
  8526.               pr_record_rest(stream_,TheStream(*obj_)->strm_concat_list,0); # Streams ausgeben
  8527.               break;
  8528.             case strmtype_buff_in:
  8529.               # Buffered-Input-Stream
  8530.               JUSTIFY_SPACE;
  8531.               prin_object(stream_,TheStream(*obj_)->strm_buff_in_fun); # Funktion ausgeben
  8532.               break;
  8533.             case strmtype_buff_out:
  8534.               # Buffered-Output-Stream
  8535.               JUSTIFY_SPACE;
  8536.               prin_object(stream_,TheStream(*obj_)->strm_buff_out_fun); # Funktion ausgeben
  8537.               break;
  8538.             #ifdef PIPES
  8539.             case strmtype_pipe_in:
  8540.             case strmtype_pipe_out:
  8541.               # Pipe-In/Out-Stream
  8542.               JUSTIFY_SPACE;
  8543.               pr_uint(stream_,posfixnum_to_L(TheStream(*obj_)->strm_pipe_pid)); # Prozeß-Id ausgeben
  8544.               break;
  8545.             #endif
  8546.             #ifdef XSOCKETS
  8547.             case strmtype_xsocket:
  8548.               # Socket-Stream
  8549.               JUSTIFY_SPACE;
  8550.               prin_object(stream_,TheStream(*obj_)->strm_xsocket_connect); # Verbindungsziel ausgeben
  8551.               break;
  8552.             #endif
  8553.             #ifdef GENERIC_STREAMS
  8554.             case strmtype_generic:
  8555.               # Generic Streams
  8556.               JUSTIFY_SPACE;
  8557.               prin_object(stream_,TheStream(*obj_)->strm_controller_object); # Controller ausgeben
  8558.               break;
  8559.             #endif
  8560.             #ifdef SOCKET_STREAMS
  8561.             case strmtype_socket:
  8562.               # Socket-Stream
  8563.               JUSTIFY_SPACE;
  8564.               { var object host=TheStream(*obj_)->strm_socket_host;
  8565.                 if (!nullp(host))
  8566.                   prin_object(stream_,host);
  8567.                 write_schar(stream_,':');
  8568.                 prin_object(stream_,TheStream(*obj_)->strm_socket_port);
  8569.               }
  8570.               break;
  8571.             #endif
  8572.             default:
  8573.               # sonst keine Zusatzinformation
  8574.               break;
  8575.           }
  8576.         if (type==strmtype_sch_file)
  8577.           { JUSTIFY_SPACE;
  8578.             # Zeilennummer ausgeben, in der sich der Stream gerade befindet:
  8579.             write_schar(stream_,'@');
  8580.             pr_number(stream_,TheStream(*obj_)->strm_sch_file_lineno);
  8581.           }
  8582.       }
  8583.       JUSTIFY_END_ENG;
  8584.       INDENT_END;
  8585.       write_schar(stream_,'>');
  8586.       skipSTACK(1);
  8587.     }}
  8588.  
  8589. #                    -------- CLOS-Instanzen --------
  8590.  
  8591. # UP: Gibt eine CLOS-Instanz auf einen Stream aus.
  8592. # pr_instance(&stream,obj);
  8593. # > obj: auszugebende CLOS-Instanz
  8594. # > stream: Stream
  8595. # < stream: Stream
  8596. # kann GC auslösen
  8597.   local void pr_instance (object *stream_,object obj);
  8598.   local void pr_instance(stream_,obj)
  8599.     var reg3 object* stream_;
  8600.     var reg4 object obj;
  8601.     { var reg1 uintC count = pr_external_1(*stream_); # Bindungen erstellen
  8602.       # (CLOS:PRINT-OBJECT obj stream) ausführen:
  8603.       pushSTACK(obj); pushSTACK(*stream_); funcall(S(print_object),2);
  8604.       pr_external_2(count); # Bindungen auflösen
  8605.     }
  8606.  
  8607.  
  8608. # ---------------------- Top-Level-Aufruf des Printers ------------------------
  8609.  
  8610. # UP: Gibt ein Objekt auf einen Stream aus.
  8611. # prin1(&stream,obj);
  8612. # > obj: Objekt
  8613. # > stream: Stream
  8614. # < stream: Stream
  8615. # kann GC auslösen
  8616.   # UP: dasselbe mit Behandlung von *PRINT-PRETTY* :
  8617.   local void prin1a (object* stream_, object* obj_);
  8618.   local void prin1a(stream_,obj_)
  8619.     var reg2 object* stream_;
  8620.     var reg3 object* obj_;
  8621.     { # Streamtyp (PPHELP-Stream oder nicht) muß zu *PRINT-PRETTY* passen.
  8622.  
  8623.       if (test_value(S(print_pretty)))
  8624.         # *PRINT-PRETTY* /= NIL.
  8625.         { # Falls *stream_ kein PPHELP-Stream ist,
  8626.           # muß er durch einen PPHELP-Stream ersetzt werden:
  8627.           if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  8628.             # noch ein normaler Stream
  8629.             { dynamic_bind(S(prin_l1),Fixnum_0); # SYS::*PRIN-L1* an 0 binden
  8630.               dynamic_bind(S(prin_lm),Fixnum_0); # SYS::*PRIN-LM* an 0 binden
  8631.               # SYS::*PRIN-L1* auf dessen Line-Position setzen:
  8632.               set_Symbol_value(S(prin_l1),get_line_position(*stream_));
  8633.               pushSTACK(make_pphelp_stream()); # neuer PPHELP-Stream, Line-Position = 0
  8634.               # Objekt auf den neuen Stream ausgeben:
  8635.               prin_object_(&STACK_0,obj_);
  8636.               # Inhalt des neuen Streams auf den alten Stream ausgeben:
  8637.               {var reg1 object ppstream = popSTACK(); # der neue Stream
  8638.                STACK_0 = nreverse(TheStream(ppstream)->strm_pphelp_strings); # Liste von Output-Zeilen
  8639.                # Falls es ein Mehrzeiler wurde und die alte Line-Position >0
  8640.                # ist, zuerst noch ein Newline auf den alten Stream ausgeben:
  8641.                if (eq(TheStream(ppstream)->strm_pphelp_modus,einzeiler) # Einzeiler ?
  8642.                    || eq(Symbol_value(S(prin_l1)),Fixnum_0) # oder Mehrzeiler, aber ab Position 0 ?
  8643.                   )
  8644.                  goto skip_first_NL; # in die Schleife
  8645.               }
  8646.               do { write_schar(stream_,NL); # #\Newline als Trennzeichen zwischen den Zeilen
  8647.                    skip_first_NL:
  8648.                    # nichtleere Stringliste STACK_0 auf den Stream ausgeben:
  8649.                   {var reg1 object list = STACK_0;
  8650.                    STACK_0 = Cdr(list);
  8651.                    write_string(stream_,Car(list)); # einzelnen String ausgeben
  8652.                  }}
  8653.                  while (mconsp(STACK_0));
  8654.               dynamic_unbind();
  8655.               dynamic_unbind();
  8656.             }
  8657.             else
  8658.             # schon ein PPHELP-Stream
  8659.             { prin_object_(stream_,obj_); }
  8660.         }
  8661.         else
  8662.         # *PRINT-PRETTY* = NIL.
  8663.         { # Falls *stream_ ein PPHELP-Stream ist, muß er durch einen
  8664.           # einelementigen Broadcast-Stream ersetzt werden:
  8665.           if (!(TheStream(*stream_)->strmtype == strmtype_pphelp))
  8666.             # normaler Stream
  8667.             { prin_object_(stream_,obj_); }
  8668.             else
  8669.             # ein PPHELP-Stream
  8670.             { pushSTACK(make_broadcast1_stream(*stream_)); # Broadcast-Stream auf den Stream *stream_
  8671.               prin_object_(&STACK_0,obj_);
  8672.             }
  8673.         }
  8674.     }
  8675.   # UP: dasselbe mit Behandlung von *PRINT-CIRCLE* und *PRINT-PRETTY* :
  8676.   local void prin1b (object* stream_, object *obj_);
  8677.   local void prin1b(stream_,obj_)
  8678.     var reg3 object* stream_;
  8679.     var reg2 object* obj_;
  8680.     { # Falls *PRINT-CIRCLE* /= NIL, in obj nach Zirkularitäten suchen.
  8681.       if (test_value(S(print_circle)) || test_value(S(print_readably)))
  8682.         # Zirkularitäten suchen:
  8683.         { 
  8684.          {var reg1 object circularities = # Zirkularitätentabelle
  8685.             get_circularities(*obj_,
  8686.                               test_value(S(print_array)) || test_value(S(print_readably)), # /= 0 genau dann wenn *PRINT-ARRAY* /= NIL
  8687.                               test_value(S(print_closure)) || test_value(S(print_readably)) # /= 0 genau dann wenn *PRINT-CLOSURE* /= NIL
  8688.                              );
  8689.           if (nullp(circularities))
  8690.             # Keine Zirkularitäten festgestellt.
  8691.             { 
  8692.               # Kann *PRINT-CIRCLE* an NIL binden.
  8693.               dynamic_bind(S(print_circle),NIL);
  8694.               prin1a(stream_,obj_);
  8695.               dynamic_unbind();
  8696.             }
  8697.           elif (eq(circularities,T))
  8698.             # Stacküberlauf trat auf
  8699.             { # Überlauf der GET_CIRCULARITIES-Routine behandeln:
  8700.               dynamic_bind(S(print_circle),NIL); # *PRINT-CIRCLE* an NIL binden
  8701.               pushSTACK(S(print));
  8702.               //: DEUTSCH "~: Stack reicht nicht zum Feststellen der Zirkularitäten."
  8703.               //: ENGLISH "~: not enough stack space for carrying out circularity analysis"
  8704.               //: FRANCAIS "~ : La pile n'est pas suffisante pour analyser les liaisons circulaires."
  8705.               fehler(storage_condition, GETTEXT("~: not enough stack space for carrying out circularity analysis"));
  8706.             }
  8707.           else
  8708.             # Zirkularitätenvektor
  8709.             { # Binde SYS::*PRINT-CIRCLE-TABLE* an den Simple-Vector:
  8710.               dynamic_bind(S(print_circle_table),circularities);
  8711.               if (!test_value(S(print_circle)))
  8712.                 # *PRINT-READABLY* erzwingt *PRINT-CIRCLE* = T
  8713.                 { dynamic_bind(S(print_circle),T);
  8714.                   prin1a(stream_,obj_);
  8715.                   dynamic_unbind();
  8716.                 }
  8717.                 else
  8718.                 { prin1a(stream_,obj_); }
  8719.               dynamic_unbind();
  8720.             }
  8721.         }}
  8722.         else
  8723.         { prin1a(stream_,obj_); }
  8724.     }
  8725.   # UP: dasselbe mit Behandlung von *PRINT-CIRCLE* und *PRINT-PRETTY*
  8726.   # und SYS::*PRIN-STREAM* :
  8727.   local void prin1_ (object* stream_, object* obj_);
  8728.   local void prin1_(stream_,obj_)
  8729.     var reg1 object* stream_;
  8730.     var reg2 object* obj_;
  8731.     { # Wert von SYS::*PRIN-STREAM* = dieser Stream ?
  8732.       if (eq(Symbol_value(S(prin_stream)),*stream_))
  8733.         # ja -> rekursiver Aufruf
  8734.         { # Falls SYS::*PRINT-CIRCLE-TABLE* = #<UNBOUND> (was bedeutet, daß
  8735.           # *PRINT-CIRCLE* vorher NIL war) und jetzt *PRINT-CIRCLE* /= NIL
  8736.           # ist, muß Objekt obj nach Zirkularitäten abgesucht werden.
  8737.           if (eq(Symbol_value(S(print_circle_table)),unbound))
  8738.             { prin1b(stream_,obj_); }
  8739.             else
  8740.             { prin1a(stream_,obj_); }
  8741.         }
  8742.         else
  8743.         # nein -> nichtrekursiver Aufruf
  8744.         { 
  8745.          #if STACKCHECKP
  8746.           var reg3 object* STACKbefore = STACK; # STACK aufheben für später
  8747.          #endif
  8748.           dynamic_bind(S(prin_level),Fixnum_0); # SYS::*PRIN-LEVEL* an 0 binden
  8749.           dynamic_bind(S(prin_bqlevel),Fixnum_0); # SYS::*PRIN-BQLEVEL* an 0 binden
  8750.           dynamic_bind(S(prin_l1),Fixnum_0); # SYS::*PRIN-L1* an 0 binden (für Pretty-Print)
  8751.           dynamic_bind(S(prin_lm),Fixnum_0); # SYS::*PRIN-LM* an 0 binden (für Pretty-Print)
  8752.           prin1b(stream_,obj_);
  8753.           dynamic_unbind();
  8754.           dynamic_unbind();
  8755.           dynamic_unbind();
  8756.           dynamic_unbind();
  8757.          #if STACKCHECKP
  8758.           # Überprüfen, ob Stack aufgeräumt:
  8759.           if (!(STACK == STACKbefore))
  8760.             { abort(); } # wenn nicht, in den Debugger
  8761.          #endif
  8762.         }
  8763.     }
  8764.  
  8765.   global void prin1 (object* stream_, object obj);
  8766.   global void prin1(stream_,obj)
  8767.     var reg1 object* stream_;
  8768.     var reg2 object obj;
  8769.     {
  8770.       pushSTACK(obj);
  8771.       prin1_(stream_,&STACK_0);
  8772.       skipSTACK(1);
  8773.     }
  8774.  
  8775. # UP: Gibt erst Newline, dann ein Objekt auf einen Stream aus.
  8776. # print(&stream,obj);
  8777. # > obj: Objekt
  8778. # > stream: Stream
  8779. # < stream: Stream
  8780. # kann GC auslösen
  8781.   global void print (object* stream_, object obj);
  8782.   global void print(stream_,obj)
  8783.     var reg2 object* stream_;
  8784.     var reg1 object obj;
  8785.     { pushSTACK(obj); # Objekt retten
  8786.       write_schar(stream_,NL); # #\Newline ausgeben
  8787.       prin1_(stream_,&STACK_0); # Objekt ausgeben
  8788.       skipSTACK(1);
  8789.     }
  8790.  
  8791.  
  8792. # ----------------------- LISP-Funktionen des Printers ------------------------
  8793.  
  8794. # UP: Überprüft ein Output-Stream-Argument.
  8795. # Default ist der Wert von *STANDARD-OUTPUT*.
  8796. # test_ostream();
  8797. # > subr_self: Aufrufer (ein SUBR)
  8798. # > STACK_0: Output-Stream-Argument
  8799. # < STACK_0: Output-Stream (ein Stream)
  8800.   local void test_ostream (void);
  8801.   local void test_ostream()
  8802.     { var reg1 object stream = STACK_0; # Output-Stream-Argument
  8803.       if (eq(stream,unbound) || nullp(stream))
  8804.         # #<UNBOUND> oder NIL -> Wert von *STANDARD-OUTPUT*
  8805.         { STACK_0 = var_stream(S(standard_output),strmflags_wr_ch_B); }
  8806.       elif (eq(stream,T))
  8807.         # T -> Wert von *TERMINAL-IO*
  8808.         { STACK_0 = var_stream(S(terminal_io),strmflags_wr_ch_B); }
  8809.       else
  8810.         # sollte ein Stream sein
  8811.         { if (!streamp(stream)) { fehler_stream(stream); } }
  8812.     }
  8813.  
  8814. # Print-Variablen (siehe CONSTSYM.D):
  8815. #   *PRINT-CASE*     --+
  8816. #   *PRINT-LEVEL*      |
  8817. #   *PRINT-LENGTH*     |
  8818. #   *PRINT-GENSYM*     |
  8819. #   *PRINT-ESCAPE*     | Reihenfolge fest!
  8820. #   *PRINT-RADIX*      | Dieselbe Reihenfolge in CONSTSYM.D
  8821. #   *PRINT-BASE*       | und bei den SUBRs WRITE, WRITE-TO-STRING
  8822. #   *PRINT-ARRAY*      |
  8823. #   *PRINT-CIRCLE*     |
  8824. #   *PRINT-PRETTY*     |
  8825. #   *PRINT-CLOSURE*    |
  8826. #   *PRINT-READABLY* --+
  8827. # erste Print-Variable:
  8828.   #define first_print_var  S(print_case)
  8829. # Anzahl der Print-Variablen:
  8830.   #define print_vars_anz  12
  8831.  
  8832. # UP für WRITE und WRITE-TO-STRING
  8833. # > STACK_(print_vars_anz+1): Objekt
  8834. # > STACK_(print_vars_anz)..STACK_(1): Argumente zu den Print-Variablen
  8835. # > STACK_0: Stream
  8836.   local void write_up (void);
  8837.   local void write_up()
  8838.     { var reg2 object* argptr = args_end_pointer STACKop (1+print_vars_anz+1); # Pointer über die Keyword-Argumente
  8839.       var reg5 object* obj_ = &NEXT(argptr);
  8840.       # die angegebenen Variablen binden:
  8841.       var reg4 uintC bindcount = 0; # Anzahl der Bindungen
  8842.       {var reg1 object sym = first_print_var; # durchläuft die Symbole
  8843.        var reg3 uintC count;
  8844.        # sym won't move, because these are constant symbols
  8845.        dotimesC(count,print_vars_anz,
  8846.          { var reg1 object arg = NEXT(argptr); # nächstes Keyword-Argument
  8847.            if (!eq(arg,unbound)) # angegeben?
  8848.              { dynamic_bind(sym,arg); bindcount++; } # ja -> Variable daran binden
  8849.            sym = objectplus(sym,(soint)sizeof(*TheSymbol(sym))<<(oint_addr_shift-addr_shift)); # zum nächsten Symbol
  8850.          });
  8851.       }
  8852.       {var reg1 object* stream_ = &NEXT(argptr); # nächstes Argument ist der Stream
  8853.        prin1_(stream_,obj_); # Objekt ausgeben
  8854.       }
  8855.       # Bindungen auflösen:
  8856.       dotimesC(bindcount,bindcount, { dynamic_unbind(); } );
  8857.     }
  8858.  
  8859. LISPFUN(write,1,0,norest,key,13,\
  8860.         (kw(case),kw(level),kw(length),kw(gensym),kw(escape),kw(radix),\
  8861.          kw(base),kw(array),kw(circle),kw(pretty),kw(closure),kw(readably),\
  8862.          kw(stream)) )
  8863. # (WRITE object [:stream] [:escape] [:radix] [:base] [:circle] [:pretty]
  8864. #               [:level] [:length] [:case] [:gensym] [:array] [:closure]
  8865. #               [:readably]),
  8866. # CLTL S. 382
  8867.   { # Stackaufbau: object, Print-Variablen-Argumente, Stream-Argument.
  8868.     test_ostream(); # Output-Stream überprüfen
  8869.     write_up(); # WRITE durchführen
  8870.     skipSTACK(print_vars_anz+1);
  8871.     value1 = popSTACK(); mv_count=1; # object als Wert
  8872.   }
  8873.  
  8874. # (defun prin1 (object &optional stream)
  8875. #   (test-output-stream stream)
  8876. #   (let ((*print-escape* t))
  8877. #     (prin object stream)
  8878. #   )
  8879. #   object
  8880. # )
  8881.  
  8882. # UP für PRIN1 und PRINT und PRIN1-TO-STRING
  8883. # > STACK_1: Objekt
  8884. # > STACK_0: Stream
  8885.   local void prin1_up (void);
  8886.   local void prin1_up()
  8887.     { var reg2 object* obj_ = &STACK_1;
  8888.       var reg1 object* stream_ = &STACK_0;
  8889.       dynamic_bind(S(print_escape),T); # *PRINT-ESCAPE* an T binden
  8890.       prin1_(stream_,obj_); # object ausgeben
  8891.       dynamic_unbind();
  8892.     }
  8893.  
  8894. LISPFUN(prin1,1,1,norest,nokey,0,NIL)
  8895. # (PRIN1 object [stream]), CLTL S. 383
  8896.   { test_ostream(); # Output-Stream überprüfen
  8897.     prin1_up(); # PRIN1 durchführen
  8898.     skipSTACK(1);
  8899.     value1 = popSTACK(); mv_count=1; # object als Wert
  8900.   }
  8901.  
  8902. # (defun print (object &optional stream)
  8903. #   (test-output-stream stream)
  8904. #   (terpri stream)
  8905. #   (let ((*print-escape* t))
  8906. #     (prin object stream)
  8907. #   )
  8908. #   (write-char #\Space stream)
  8909. #   object
  8910. # )
  8911. LISPFUN(print,1,1,norest,nokey,0,NIL)
  8912. # (PRINT object [stream]), CLTL S. 383
  8913.   { test_ostream(); # Output-Stream überprüfen
  8914.     terpri(&STACK_0); # neue Zeile
  8915.     prin1_up(); # PRIN1 durchführen
  8916.     write_schar(&STACK_0,' '); # Space danach
  8917.     skipSTACK(1);
  8918.     value1 = popSTACK(); mv_count=1; # object als Wert
  8919.   }
  8920.  
  8921. # (defun pprint (object &optional stream)
  8922. #   (test-output-stream stream)
  8923. #   (terpri stream)
  8924. #   (let ((*print-escape* t) (*print-pretty* t))
  8925. #     (prin object stream)
  8926. #   )
  8927. #   (values)
  8928. # )
  8929. LISPFUN(pprint,1,1,norest,nokey,0,NIL)
  8930. # (PPRINT object [stream]), CLTL S. 383
  8931.   { test_ostream(); # Output-Stream überprüfen
  8932.     terpri(&STACK_0); # neue Zeile
  8933.    {var reg2 object* obj_ = &STACK_1;
  8934.     var reg1 object* stream_ = &STACK_0;
  8935.     dynamic_bind(S(print_pretty),T); # *PRINT-PRETTY* an T binden
  8936.     dynamic_bind(S(print_escape),T); # *PRINT-ESCAPE* an T binden
  8937.     prin1_(stream_,obj_); # object ausgeben
  8938.     dynamic_unbind();
  8939.     dynamic_unbind();
  8940.     skipSTACK(2);
  8941.     value1 = NIL; mv_count=0; # keine Werte
  8942.   }}
  8943.  
  8944. # (defun princ (object &optional stream)
  8945. #   (test-output-stream stream)
  8946. #   (let ((*print-escape* nil))
  8947. #     (prin object stream)
  8948. #   )
  8949. #   object
  8950. # )
  8951.  
  8952. # UP für PRINC und PRINC-TO-STRING
  8953. # > STACK_1: Objekt
  8954. # > STACK_0: Stream
  8955.   local void princ_up (void);
  8956.   local void princ_up()
  8957.     { var reg2 object* obj_ = &STACK_1;
  8958.       var reg1 object* stream_ = &STACK_0;
  8959.       dynamic_bind(S(print_escape),NIL); # *PRINT-ESCAPE* an NIL binden
  8960.       prin1_(stream_,obj_); # object ausgeben
  8961.       dynamic_unbind();
  8962.     }
  8963.  
  8964. LISPFUN(princ,1,1,norest,nokey,0,NIL)
  8965. # (PRINC object [stream]), CLTL S. 383
  8966.   { test_ostream(); # Output-Stream überprüfen
  8967.     princ_up(); # PRINC durchführen
  8968.     skipSTACK(1);
  8969.     value1 = popSTACK(); mv_count=1; # object als Wert
  8970.   }
  8971.  
  8972. # (defun write-to-string (object &rest args
  8973. #                                &key escape radix base circle pretty level
  8974. #                                     length case gensym array closure readably)
  8975. #   (with-output-to-string (stream)
  8976. #     (apply #'write object :stream stream args)
  8977. # ) )
  8978. LISPFUN(write_to_string,1,0,norest,key,12,\
  8979.         (kw(case),kw(level),kw(length),kw(gensym),kw(escape),kw(radix),\
  8980.          kw(base),kw(array),kw(circle),kw(pretty),kw(closure),kw(readably)) )
  8981. # (WRITE-TO-STRING object [:escape] [:radix] [:base] [:circle] [:pretty]
  8982. #                         [:level] [:length] [:case] [:gensym] [:array]
  8983. #                         [:closure] [:readably]),
  8984. # CLTL S. 383
  8985.   { pushSTACK(make_string_output_stream()); # String-Output-Stream
  8986.     write_up(); # WRITE durchführen
  8987.     value1 = get_output_stream_string(&STACK_0); mv_count=1; # Ergebnis-String als Wert
  8988.     skipSTACK(1+print_vars_anz+1);
  8989.   }
  8990.  
  8991. # (defun prin1-to-string (object)
  8992. #   (with-output-to-string (stream) (prin1 object stream))
  8993. # )
  8994. LISPFUNN(prin1_to_string,1)
  8995. # (PRIN1-TO-STRING object), CLTL S. 383
  8996.   { pushSTACK(make_string_output_stream()); # String-Output-Stream
  8997.     prin1_up(); # PRIN1 durchführen
  8998.     value1 = get_output_stream_string(&STACK_0); mv_count=1; # Ergebnis-String als Wert
  8999.     skipSTACK(2);
  9000.   }
  9001.  
  9002. # (defun princ-to-string (object)
  9003. #   (with-output-to-string (stream) (princ object stream))
  9004. # )
  9005. LISPFUNN(princ_to_string,1)
  9006. # (PRINC-TO-STRING object), CLTL S. 383
  9007.   { pushSTACK(make_string_output_stream()); # String-Output-Stream
  9008.     princ_up(); # PRINC durchführen
  9009.     value1 = get_output_stream_string(&STACK_0); mv_count=1; # Ergebnis-String als Wert
  9010.     skipSTACK(2);
  9011.   }
  9012.  
  9013. LISPFUN(write_char,1,1,norest,nokey,0,NIL)
  9014. # (WRITE-CHAR character [stream]), CLTL S. 384
  9015.   { test_ostream(); # Output-Stream überprüfen
  9016.    {var reg1 object ch = STACK_1; # character-Argument
  9017.     if (!charp(ch))
  9018.       { pushSTACK(ch); # Wert für Slot DATUM von TYPE-ERROR
  9019.         pushSTACK(S(character)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  9020.         pushSTACK(ch);
  9021.         pushSTACK(TheSubr(subr_self)->name);
  9022.         //: DEUTSCH "~: ~ ist kein Character."
  9023.         //: ENGLISH "~: ~ is not a character"
  9024.         //: FRANCAIS "~ : ~ n'est pas un caractère."
  9025.         fehler(type_error, GETTEXT("~: ~ is not a character"));
  9026.       }
  9027.     write_char(&STACK_0,ch);
  9028.     value1 = ch; mv_count=1; # ch (nicht GC-gefährdet) als Wert
  9029.     skipSTACK(2);
  9030.   }}
  9031.  
  9032. # UP für WRITE-STRING und WRITE-LINE:
  9033. # Überprüft die Argumente und gibt einen String-Teil auf einen Stream aus.
  9034. # > subr_self: Aufrufer (ein SUBR)
  9035. # > Stackaufbau: String-Argument, Stream-Argument, :START-Argument, :END-Argument.
  9036. # < Stackaufbau: Stream, String.
  9037. # kann GC auslösen
  9038.   local void write_string_up (void);
  9039.   local void write_string_up()
  9040.     {{ pushSTACK(STACK_2); # Stream ans STACK-Ende
  9041.        test_ostream(); # überprüfen
  9042.        STACK_(2+1) = STACK_(3+1);
  9043.        STACK_(3+1) = STACK_0;
  9044.        skipSTACK(1);
  9045.      }# Stackaufbau: stream, string, :START-Argument, :END-Argument.
  9046.       # Grenzen überprüfen:
  9047.       { var object string;
  9048.         var uintL start;
  9049.         var uintL len;
  9050.         test_string_limits(&string,&start,&len);
  9051.         pushSTACK(string);
  9052.         # Stackaufbau: stream, string.
  9053.        {var reg1 object sstring = array_displace_check(string,len,&start); # Datenvektor
  9054.         # start = Startindex im Datenvektor sstring
  9055.         write_sstring_ab(&STACK_1,sstring,start,len); # angesprochene Characters ausgeben
  9056.       }}
  9057.     }
  9058.  
  9059. LISPFUN(write_string,1,1,norest,key,2, (kw(start),kw(end)) )
  9060. # (WRITE-STRING string [stream] [:start] [:end]), CLTL S. 384
  9061.   { write_string_up(); # überprüfen und ausgeben
  9062.     value1 = popSTACK(); mv_count=1; skipSTACK(1); # string als Wert
  9063.   }
  9064.  
  9065. LISPFUN(write_line,1,1,norest,key,2, (kw(start),kw(end)) )
  9066. # (WRITE-LINE string [stream] [:start] [:end]), CLTL S. 384
  9067.   { write_string_up(); # überprüfen und ausgeben
  9068.     terpri(&STACK_1); # neue Zeile
  9069.     value1 = popSTACK(); mv_count=1; skipSTACK(1); # string als Wert
  9070.   }
  9071.  
  9072. LISPFUN(terpri,0,1,norest,nokey,0,NIL)
  9073. # (TERPRI [stream]), CLTL S. 384
  9074.   { test_ostream(); # Output-Stream überprüfen
  9075.     terpri(&STACK_0); # neue Zeile
  9076.     value1 = NIL; mv_count=1; skipSTACK(1); # NIL als Wert
  9077.   }
  9078.  
  9079. LISPFUN(fresh_line,0,1,norest,nokey,0,NIL)
  9080. # (FRESH-LINE [stream]), CLTL S. 384
  9081.   { test_ostream(); # Output-Stream überprüfen
  9082.     if (eq(get_line_position(STACK_0),Fixnum_0)) # Line-Position = 0 ?
  9083.       { value1 = NIL; mv_count=1; } # ja -> NIL als Wert
  9084.       else
  9085.       { terpri(&STACK_0); # nein -> neue Zeile
  9086.         value1 = T; mv_count=1; # und T als Wert
  9087.       }
  9088.     skipSTACK(1);
  9089.   }
  9090.  
  9091. LISPFUN(finish_output,0,1,norest,nokey,0,NIL)
  9092. # (FINISH-OUTPUT [stream]), CLTL S. 384
  9093.   { test_ostream(); # Output-Stream überprüfen
  9094.     finish_output(popSTACK()); # Output ans Ziel bringen
  9095.     value1 = NIL; mv_count=1; # NIL als Wert
  9096.   }
  9097.  
  9098. LISPFUN(force_output,0,1,norest,nokey,0,NIL)
  9099. # (FORCE-OUTPUT [stream]), CLTL S. 384
  9100.   { test_ostream(); # Output-Stream überprüfen
  9101.     force_output(popSTACK()); # Output ans Ziel bringen
  9102.     value1 = NIL; mv_count=1; # NIL als Wert
  9103.   }
  9104.  
  9105. LISPFUN(clear_output,0,1,norest,nokey,0,NIL)
  9106. # (CLEAR-OUTPUT [stream]), CLTL S. 384
  9107.   { test_ostream(); # Output-Stream überprüfen
  9108.     clear_output(popSTACK()); # Output löschen
  9109.     value1 = NIL; mv_count=1; # NIL als Wert
  9110.   }
  9111.  
  9112. LISPFUN(write_unreadable,3,0,norest,key,2, (kw(type),kw(identity)) )
  9113. # (SYSTEM::WRITE-UNREADABLE function object stream [:type] [:identity]),
  9114. # vgl. CLtL2 S. 580
  9115.   { var reg2 boolean flag_fun = FALSE;
  9116.     var reg4 boolean flag_type = FALSE;
  9117.     var reg3 boolean flag_id = FALSE;
  9118.     { var reg1 object arg = popSTACK(); # :identity - Argument
  9119.       if (!(eq(arg,unbound) || nullp(arg))) { flag_id = TRUE; }
  9120.     }
  9121.     { var reg1 object arg = popSTACK(); # :type - Argument
  9122.       if (!(eq(arg,unbound) || nullp(arg))) { flag_type = TRUE; }
  9123.     }
  9124.     if (!nullp(STACK_2)) { flag_fun = TRUE; }
  9125.     test_ostream(); # Output-Stream überprüfen
  9126.     if (test_value(S(print_readably))) { fehler_print_readably(STACK_1); }
  9127.    {var reg1 object* stream_ = &STACK_0;
  9128.     write_schar(stream_,'#'); write_schar(stream_,'<');
  9129.     INDENT_START(2); # um 2 Zeichen einrücken, wegen '#<'
  9130.     JUSTIFY_START;
  9131.     if (flag_type)
  9132.       { # (TYPE-OF object) ausgeben:
  9133.         pushSTACK(*(stream_ STACKop 1)); funcall(L(type_of),1);
  9134.         prin1(stream_,value1);
  9135.         if (flag_fun || flag_id) { JUSTIFY_SPACE; }
  9136.       }
  9137.     if (flag_fun)
  9138.       { funcall(*(stream_ STACKop 2),0); } # (FUNCALL function)
  9139.     if (flag_id)
  9140.       { if (flag_fun) { JUSTIFY_SPACE; }
  9141.         pr_hex6(stream_,*(stream_ STACKop 1));
  9142.       }
  9143.     JUSTIFY_END_ENG;
  9144.     INDENT_END;
  9145.     write_schar(stream_,'>');
  9146.     skipSTACK(3);
  9147.     value1 = NIL; mv_count=1;
  9148.   }}
  9149.  
  9150. LISPFUN(line_position,0,1,norest,nokey,0,NIL)
  9151. # (SYS::LINE-POSITION [stream]), Hilfsfunktion für FORMAT ~T,
  9152. # liefert die Position eines (Output-)Streams in der momentanen Zeile.
  9153.   { test_ostream(); # Output-Stream überprüfen
  9154.     value1 = get_line_position(popSTACK()); mv_count=1; # Line-Position als Wert
  9155.   }
  9156.  
  9157.