home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / stream.d < prev    next >
Encoding:
Text File  |  1996-06-13  |  508.9 KB  |  13,263 lines
  1. # Streams für CLISP
  2. # Bruno Haible 23.6.1995
  3. # Generic Streams: Marcus Daniels 8.4.1994
  4.  
  5. #include "lispbibl.c"
  6. #include "arilev0.c" # für R_sign
  7.  
  8. #ifdef GNU_READLINE
  9.   #define READLINE_LIBRARY # Hinweis, wo die Include-Files gesucht werden müssen
  10.   #include "readline.h"
  11.   #include "history.h"
  12.   #undef READLINE_LIBRARY
  13.   #ifdef STDC_HEADERS
  14.     #include <string.h>  # deklariert strcpy()
  15.   #endif
  16. #endif
  17.  
  18.  
  19. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  20.   # Betriebssystem-Funktion read sichtbar machen:
  21.     #undef read
  22. #endif
  23.  
  24.  
  25. # Nochmals zum Aufbau von Streams:
  26. # strmflags = Flags
  27.   # Bits in den Flags:
  28.   #                             0,1 # gesetzt, falls Integer-Stream
  29.   #define strmflags_raw_bit_B    2  # gesetzt, falls im Raw-Modus
  30.   #define strmflags_immut_bit_B  3  # gesetzt, falls gelesene Objekte immutabel sind
  31.   #define strmflags_rd_by_bit_B  4  # gesetzt, falls READ-BYTE möglich ist
  32.   #define strmflags_wr_by_bit_B  5  # gesetzt, falls WRITE-BYTE möglich ist
  33.   # define strmflags_rd_ch_bit_B 6  # gesetzt, falls READ-CHAR möglich ist
  34.   # define strmflags_wr_ch_bit_B 7  # gesetzt, falls WRITE-CHAR möglich ist
  35.   # Bitmasken in den Flags:
  36.   #define strmflags_i_B      (bit(1)|bit(0))  # benutzt bei Integer-Streams
  37.   #define strmflags_ia_B     (       bit(0))  # Integer-Stream der Art a
  38.   #define strmflags_ib_B     (bit(1)       )  # Integer-Stream der Art b
  39.   #define strmflags_ic_B     (bit(1)|bit(0))  # Integer-Stream der Art c
  40.   #define strmflags_raw_B    bit(strmflags_raw_bit_B)
  41.   # define strmflags_immut_B bit(strmflags_immut_bit_B)
  42.   #define strmflags_rd_by_B  bit(strmflags_rd_by_bit_B)
  43.   #define strmflags_wr_by_B  bit(strmflags_wr_by_bit_B)
  44.   # define strmflags_rd_ch_B bit(strmflags_rd_ch_bit_B)
  45.   # define strmflags_wr_ch_B bit(strmflags_wr_ch_bit_B)
  46.   #define strmflags_rd_B  (strmflags_rd_by_B | strmflags_rd_ch_B)
  47.   #define strmflags_wr_B  (strmflags_wr_by_B | strmflags_wr_ch_B)
  48.   #define strmflags_by_B  (strmflags_rd_by_B | strmflags_wr_by_B)
  49.   #define strmflags_ch_B  (strmflags_rd_ch_B | strmflags_wr_ch_B)
  50.   # strmflags_open_B: die 4 oberen Bits
  51. # strmtype = Nähere Typinfo. Siehe LISPBIBL.D.
  52.  
  53. # einzelne Komponenten:
  54.   # strm_rd_by       Pseudofunktion für READ-BYTE
  55.   # strm_wr_by       Pseudofunktion für WRITE-BYTE
  56.   # strm_rd_ch       Pseudofunktion für READ-CHAR
  57.   # strm_rd_ch_last  letztes von READ-CHAR gelesenes Zeichen
  58.   #                  (bzw. als Fixnum nach UNREAD-CHAR bzw. NIL sonst)
  59.   # strm_wr_ch       Pseudofunktion für WRITE-CHAR
  60.   # strm_wr_ch_lpos  Line-Position in der Zeile nach dem letzten WRITE-CHAR
  61.   #ifdef STRM_WR_SS
  62.   # strm_wr_ss       Pseudofunktion für WRITE-SIMPLE-STRING
  63.   #endif
  64. # weitere (typspezifische) Komponenten:
  65.   # siehe in LISPBIBL.D und bei den einzelnen Stream-Typen.
  66.  
  67.  
  68. # ==============================================================================
  69. #                           S T R E A M S
  70.  
  71. # Da MAKE-TWO-WAY-STREAM eventuell einen Stream liefern kann, der z.B.
  72. # Character-Input und Byte-Output ist, und damit insbesondere alle
  73. # READ-/WRITE-Operationen effizient laufen, werden Streams folgendermaßen
  74. # aufgebaut:
  75. #    - Typ des Streams,
  76. #    - Komponenten für READ-BYTE,
  77. #    - Komponenten für WRITE-BYTE,
  78. #    - Komponenten für READ-CHAR,
  79. #    - Komponenten für WRITE-CHAR,
  80. #    - vom Typ des Streams abhängige Komponenten.
  81.  
  82. # Feste Komponenten
  83. # -----------------
  84. # für READ-BYTE:
  85. #     RD_BY          Pseudofunktion zum Lesen eines Bytes
  86. # für WRITE-BYTE:
  87. #     WR_BY          Pseudofunktion zum Schreiben eines Bytes
  88. # für READ-CHAR:
  89. #     RD_CH          Pseudofunktion zum Lesen eines Characters
  90. #     RD_CH_LAST     letztes gelesenes Zeichen und Flag
  91. #                    (NIL zu Beginn, eof_value nach End-of-File,
  92. #                    sonst: letztes gelesenes Zeichen, als Fixnum,
  93. #                    falls es mit UNREAD zurückgeschoben wurde)
  94. # für WRITE-CHAR:
  95. #     WR_CH          Pseudofunktion zum Schreiben eines Characters
  96. #     WR_CH_LPOS     Position in der Zeile (Fixnum >=0) (für FORMAT ~T)
  97.  
  98. # Pseudofunktionen sind Adressen von C-Funktionen, die direkt angesprungen
  99. # werden können, mit dem Stream als erstem Argument, und ein Objekt
  100. # als Ergebnis liefern.
  101.   #define P(fun)  (type_constpointer_object(machine_type,(Pseudofun)&(fun)))
  102.  
  103. # Spezifikation der vier Typen von Pseudofunktionen:
  104.   #
  105.   # Spezifikation für READ-BYTE - Pseudofunktion:
  106.   # fun(stream)
  107.   # > stream: Stream
  108.   # < ergebnis: gelesener Integer (eof_value bei EOF)
  109.   # kann GC auslösen
  110.     typedef object (* rd_by_Pseudofun) (object stream);
  111.   #
  112.   # Spezifikation für WRITE-BYTE - Pseudofunktion:
  113.   # fun(stream,obj)
  114.   # > stream: Stream
  115.   # > obj: auszugebender Integer
  116.   # kann GC auslösen
  117.     typedef void (* wr_by_Pseudofun) (object stream, object obj);
  118.   #
  119.   # Spezifikation für READ-CHAR - Pseudofunktion:
  120.   # fun(&stream)
  121.   # > stream: Stream
  122.   # < stream: Stream
  123.   # < ergebnis: gelesenes Character (eof_value bei EOF)
  124.   # kann GC auslösen
  125.     typedef object (* rd_ch_Pseudofun) (object* stream_);
  126.   #
  127.   # Spezifikation für WRITE-CHAR - Pseudofunktion:
  128.   # fun(&stream,obj)
  129.   # > stream: Stream
  130.   # < stream: Stream
  131.   # > obj: auszugebendes Character
  132.   # kann GC auslösen
  133.     typedef void (* wr_ch_Pseudofun) (object* stream_, object obj);
  134.   #
  135.   #ifdef STRM_WR_SS
  136.   # Spezifikation für WRITE-SIMPLE-STRING - Pseudofunktion:
  137.   # fun(&stream,string,start,len)
  138.   # > string: Simple-String
  139.   # > start: Startindex
  140.   # > len: Anzahl der auszugebenden Zeichen
  141.   # > stream: Stream
  142.   # < stream: Stream
  143.   # kann GC auslösen
  144.     typedef void (* wr_ss_Pseudofun) (object* stream_, object string, uintL start, uintL len);
  145.   #endif
  146.  
  147. # Pseudofunktionen aus einem Stream herausgreifen:
  148.   #define rd_by(strm)  (*(rd_by_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_by)))
  149.   #define wr_by(strm)  (*(wr_by_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_by)))
  150.   #define rd_ch(strm)  (*(rd_ch_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_ch)))
  151.   #define wr_ch(strm)  (*(wr_ch_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ch)))
  152.   #ifdef STRM_WR_SS
  153.   #define wr_ss(strm)  (*(wr_ss_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ss)))
  154.   #endif
  155.  
  156. #  Mögliche Typen von Streams                 Zusatzkomponenten
  157. #  --------------------------                 -----------------
  158. #  0. Keyboard-Stream
  159. #  1. Interaktiver Terminalstream             Eingabebuffer, Zeichenzähler
  160. #  2. File-Stream für String-Chars            Handle, Pathname, File-Position,
  161. #     (Input, Output, I/O, Closed=Probe)      Buffer
  162. #  3. File-Stream für Characters              Handle, Pathname, File-Position,
  163. #     (Input, Output, I/O, Closed=Probe)      Buffer
  164. #  4. File-Stream für Unsigned-Bytes          Handle, Pathname, File-Position,
  165. #     (Input, Output, I/O, Closed=Probe)      Buffer, Bit-Buffer
  166. #  5. File-Stream für Signed-Bytes            Handle, Pathname, File-Position,
  167. #     (Input, Output, I/O, Closed=Probe)      Buffer, Bit-Buffer
  168. #  6. Synonym-Stream                          Symbol
  169. #  7. Broadcast-(Output-)Stream               Liste von Streams
  170. #  8. Concatenated-(Input-)Stream             Liste von Streams
  171. #  9. Two-Way-Stream                          Stream für Input, Stream für Output
  172. # 10. Echo-Stream                             Stream für Input, Stream für Output
  173. # 11. String-Input-Stream                     Gesamtstring, Zeichenzähler
  174. # 12. String-Output-Stream                    Buffer (Semi-Simple-String)
  175. # 13. String-Push-Stream                      String mit Fill-Pointer
  176. # 14. Pretty-Printer-Hilfs-Stream             Liste von Buffers, Modus
  177. # 15. Buffered-Input-Stream                   fun, mode, String, Zeichenzähler
  178. # 16. Buffered-Output-Stream                  fun, Buffer (Semi-Simple-String)
  179. # 17. Window-Stream                           ---
  180. #ifdef PRINTER
  181. # 18. Printer-Stream
  182. #endif
  183. #ifdef HANDLES
  184. # 19. File-Handle-Stream                      Handle, Pathname
  185. #endif
  186. #ifdef PIPES
  187. # 20. Pipe-Input-Stream                       Pid, Handle
  188. # 21. Pipe-Output-Stream                      Pid, Handle
  189. #endif
  190. #ifdef XSOCKETS
  191. # 22. X-Socket-Stream                         Info, Handle
  192. #endif
  193. #ifdef GENERIC_STREAMS
  194. # 23. Generic-Stream                          Private Controller Object
  195. #endif
  196. #ifdef SOCKET_STREAMS
  197. # 24. Socket-Stream
  198. #endif
  199.  
  200. # Zusätzlich wird (sicherheitshalber) eine Liste aller offenen File-Streams
  201. # geführt.
  202.  
  203. # Fehlermeldung, wenn eine Stream-Operation auf einem Stream nicht erlaubt ist.
  204. # fehler_illegal_streamop(caller,stream);
  205. # > caller: Aufrufer (ein Symbol)
  206. # > stream: Stream
  207.   nonreturning_function(global, fehler_illegal_streamop, (object caller, object stream));
  208.   global void fehler_illegal_streamop(caller,stream)
  209.     var reg1 object caller;
  210.     var reg2 object stream;
  211.     { pushSTACK(stream); # Wert für Slot STREAM von STREAM-ERROR
  212.       pushSTACK(stream);
  213.       pushSTACK(caller);
  214.       //: DEUTSCH "~ auf ~ ist unzulässig."
  215.       //: ENGLISH "~ on ~ is illegal"
  216.       //: FRANCAIS "~ de/sur ~ est impossible."
  217.       fehler(stream_error,GETTEXT("~ on ~ is illegal"));
  218.     }
  219.  
  220. # Dummy-Pseudo-Funktionen, die Errors liefern:
  221.   local object rd_by_dummy (object stream);
  222.   local object rd_by_dummy(stream)
  223.     var reg1 object stream;
  224.     { fehler_illegal_streamop(S(read_byte),stream); }
  225.   local void wr_by_dummy (object stream, object obj);
  226.   local void wr_by_dummy(stream,obj)
  227.     var reg1 object stream;
  228.     var reg2 object obj;
  229.     { fehler_illegal_streamop(S(write_byte),stream); }
  230.   local object rd_ch_dummy (object* stream_);
  231.   local object rd_ch_dummy(stream_)
  232.     var reg1 object* stream_;
  233.     { fehler_illegal_streamop(S(read_char),*stream_); }
  234.   local void wr_ch_dummy (object* stream_, object obj);
  235.   local void wr_ch_dummy(stream_,obj)
  236.     var reg1 object* stream_;
  237.     var reg2 object obj;
  238.     { fehler_illegal_streamop(S(write_char),*stream_); }
  239.   #ifdef STRM_WR_SS
  240.   local void wr_ss_dummy (object* stream_, object string, uintL start, uintL len);
  241.   local void wr_ss_dummy(stream_,string,start,len)
  242.     var reg3 object* stream_;
  243.     var reg5 object string;
  244.     var reg4 uintL start;
  245.     var reg2 uintL len;
  246.     { if (len==0) return;
  247.      {var reg1 uintL index = start;
  248.       pushSTACK(string); # Simple-String retten
  249.       dotimespL(len,len,
  250.         { write_schar(stream_,TheSstring(STACK_0)->data[index]);
  251.           index++;
  252.         });
  253.       skipSTACK(1);
  254.     }}
  255.   # Dasselbe, wenn write_char auf diesem Stream keine GC auslösen kann:
  256.   local void wr_ss_dummy_nogc (object* stream_, object string, uintL start, uintL len);
  257.   local void wr_ss_dummy_nogc(stream_,string,start,len)
  258.     var reg3 object* stream_;
  259.     var reg5 object string;
  260.     var reg4 uintL start;
  261.     var reg2 uintL len;
  262.     { if (len==0) return;
  263.      {var reg1 uintB* ptr = &TheSstring(string)->data[start];
  264.       dotimespL(len,len, { write_schar(stream_,*ptr++); } );
  265.     }}
  266.   #endif
  267.   # Am Ende eines wr_ss die Line-Position aktualisieren:
  268.   # wr_ss_lpos(stream,ptr,len);
  269.   # > stream: Stream, nicht der Terminal-Stream
  270.   # > ptr: Pointer ans Ende(!) der bereits auf den Stream ausgegebenen Zeichen
  271.   # > len: Anzahl der Zeichen, >0
  272.   # < ergebnis: TRUE, falls ein NL unter den Zeichen ist, FALSE sonst
  273.   local boolean wr_ss_lpos (object stream, uintB* ptr, uintL len);
  274.   local boolean wr_ss_lpos(stream,ptr,len)
  275.     var reg5 object stream;
  276.     var reg1 uintB* ptr;
  277.     var reg6 uintL len;
  278.     {
  279.       #ifdef TERMINAL_USES_KEYBOARD
  280.       if (TheStream(stream)->strmtype == strmtype_terminal)
  281.         return FALSE;
  282.       #endif
  283.       # Zähle die Zahl der Zeichen seit dem letzten NL:
  284.      {var reg7 boolean result;
  285.       var reg3 uintL pos = 0;
  286.       var reg2 uintL count;
  287.       dotimespL(count,len, { if (*--ptr == NL) goto found_NL; pos++; } );
  288.       if (FALSE)
  289.         found_NL: # pos Zeichen seit dem letzten NL
  290.         { ptr++; len = pos; pos = 0; result = TRUE; }
  291.         else /* pos==len */
  292.         { pos = posfixnum_to_L(TheStream(stream)->strm_wr_ch_lpos); result = FALSE; }
  293.       # Es gab len Zeichen ab ptr, pos ist die Position dort.
  294.       #ifndef TERMINAL_USES_KEYBOARD
  295.       if (TheStream(stream)->strmtype == strmtype_terminal)
  296.         { dotimesL(count,len,
  297.             { var reg4 uintB c = *ptr++;
  298.               # Wie wirken sich die Steuerzeichen in der Position aus?
  299.               if (graphic_char_p(c))
  300.                 # normales druckendes Zeichen -> Line Position incrementieren:
  301.                 { pos++; }
  302.               elif (c == BS)
  303.                 # Backspace -> Line Position, wenn möglich, decrementieren:
  304.                 { if (pos > 0) { pos--; } }
  305.             });
  306.         }
  307.         else
  308.       #endif
  309.         { pos += len; }
  310.       TheStream(stream)->strm_wr_ch_lpos = fixnum(pos);
  311.       return result;
  312.     }}
  313.  
  314. # Liest ein Byte von einem Stream.
  315. # read_byte(stream)
  316. # > stream: Stream
  317. # < ergebnis: gelesener Integer (eof_value bei EOF)
  318. # kann GC auslösen
  319.   global object read_byte (object stream);
  320.   global object read_byte(stream)
  321.     var reg1 object stream;
  322.     { return rd_by(stream)(stream); }
  323.  
  324. # Schreibt ein Byte auf einen Stream.
  325. # write_byte(stream,byte);
  326. # > stream: Stream
  327. # > byte: auszugebender Integer
  328. # kann GC auslösen
  329.   global void write_byte(object stream, object byte);
  330.   global void write_byte(stream,byte)
  331.     var reg1 object stream;
  332.     var reg2 object byte;
  333.     { wr_by(stream)(stream,byte); }
  334.  
  335. # Liest ein Character von einem Stream.
  336. # read_char(&stream)
  337. # > stream: Stream
  338. # < stream: Stream
  339. # < ergebnis: gelesenes Character (eof_value bei EOF)
  340. # kann GC auslösen
  341.   global object read_char (object* stream_);
  342.   global object read_char(stream_)
  343.     var reg1 object* stream_;
  344.     { var reg2 object stream = *stream_;
  345.       if (!mposfixnump(TheStream(stream)->strm_rd_ch_last)) # Char nach UNREAD ?
  346.         # nein -> neues Zeichen holen:
  347.         { var reg3 object newch = rd_ch(stream)(stream_);
  348.           TheStream(*stream_)->strm_rd_ch_last = newch; # und abspeichern
  349.           return newch;
  350.         }
  351.         else
  352.         # ja -> Flagbit löschen und letztes Zeichen holen:
  353.         { return TheStream(stream)->strm_rd_ch_last =
  354.                    fixnum_to_char(TheStream(stream)->strm_rd_ch_last);
  355.     }   }
  356.  
  357. # Schiebt das letzte gelesene Character auf einen Stream zurück.
  358. # unread_char(&stream,ch);
  359. # > ch: letztes gelesenes Character
  360. # > stream: Stream
  361. # < stream: Stream
  362.   global void unread_char (object* stream_, object ch);
  363.   global void unread_char(stream_,ch)
  364.     var reg1 object* stream_;
  365.     var reg3 object ch;
  366.     { var reg2 object stream = *stream_;
  367.       if (eq(TheStream(stream)->strm_rd_ch_last,ch))
  368.         { TheStream(stream)->strm_rd_ch_last =
  369.             char_to_fixnum(TheStream(stream)->strm_rd_ch_last); # Flagbit setzen
  370.         }
  371.         else
  372.         { if (mcharp(TheStream(stream)->strm_rd_ch_last))
  373.             { pushSTACK(stream); # Wert für Slot STREAM von STREAM-ERROR
  374.               pushSTACK(ch);
  375.               pushSTACK(stream);
  376.               pushSTACK(S(unread_char));
  377.               //: DEUTSCH "~: Das letzte von ~ gelesene Zeichen war nicht ~."
  378.               //: ENGLISH "~: the last character read from ~ was not ~"
  379.               //: FRANCAIS "~ : Le dernier caractère lu dans ~ n'était pas ~."
  380.               fehler(stream_error,GETTEXT("~: the last character read from ~ was not ~"));
  381.             }
  382.             else
  383.             { pushSTACK(stream); # Wert für Slot STREAM von STREAM-ERROR
  384.               pushSTACK(S(read_char));
  385.               pushSTACK(stream);
  386.               pushSTACK(S(unread_char));
  387.               //: DEUTSCH "~ von ~ ohne vorheriges ~."
  388.               //: ENGLISH "~ from ~ without ~ before it"
  389.               //: FRANCAIS "~ de ~ sans précédent ~."
  390.               fehler(stream_error,GETTEXT("~ from ~ without ~ before it"));
  391.             }
  392.     }   }
  393.  
  394. # Liest ein Character von einem Stream, ohne es zu verbrauchen.
  395. # peek_char(&stream)
  396. # > stream: Stream
  397. # < stream: Stream
  398. # < ergebnis: gelesenes Character (eof_value bei EOF)
  399. # kann GC auslösen
  400.   global object peek_char (object* stream_);
  401.   global object peek_char(stream_)
  402.     var reg1 object* stream_;
  403.     { var reg2 object stream = *stream_;
  404.       if (!mposfixnump(TheStream(stream)->strm_rd_ch_last)) # Char nach UNREAD ?
  405.         # nein -> neues Zeichen holen:
  406.         { var reg3 object newch = rd_ch(stream)(stream_);
  407.           # und abspeichern:
  408.           TheStream(*stream_)->strm_rd_ch_last =
  409.             (eq(newch,eof_value) ? newch : char_to_fixnum(newch));
  410.           return newch;
  411.         }
  412.         else
  413.         # ja -> letztes Zeichen holen:
  414.         { return fixnum_to_char(TheStream(stream)->strm_rd_ch_last); }
  415.     }
  416.  
  417. # Schreibt ein Character auf einen Stream.
  418. # write_char(&stream,ch);
  419. # > ch: auszugebendes Character
  420. # > stream: Stream
  421. # < stream: Stream
  422. # kann GC auslösen
  423.   global void write_char (object* stream_, object ch);
  424.   global void write_char(stream_,ch)
  425.     var reg1 object* stream_;
  426.     var reg4 object ch;
  427.     { var reg3 cint c = char_int(ch);
  428.       # Char schreiben:
  429.       wr_ch(*stream_)(stream_,ch);
  430.       # Line Position aktualisieren:
  431.      {var reg2 object stream = *stream_;
  432.       if (!(TheStream(stream)->strmtype == strmtype_terminal))
  433.         # nicht der Terminal-Stream
  434.         { if (c == NL)
  435.             # Nach Newline: Line Position := 0
  436.             { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; }
  437.             else
  438.             # Line Position incrementieren:
  439.             { TheStream(stream)->strm_wr_ch_lpos =
  440.                 fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,1);
  441.         }   }
  442.         else
  443.         # es ist der Terminal-Stream
  444.         #ifdef TERMINAL_USES_KEYBOARD
  445.         { ; }
  446.         #else
  447.         # Wie wirken sich die Steuerzeichen in der Position aus?
  448.         { if (graphic_char_p(c))
  449.             # normales druckendes Zeichen -> Line Position incrementieren:
  450.             { TheStream(stream)->strm_wr_ch_lpos =
  451.                 fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,1);
  452.             }
  453.           elif (c == NL)
  454.             # Newline -> Line Position := 0
  455.             { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; }
  456.           elif (c == BS)
  457.             # Backspace -> Line Position, wenn möglich, decrementieren:
  458.             { if (!eq(TheStream(stream)->strm_wr_ch_lpos,Fixnum_0))
  459.                 { TheStream(stream)->strm_wr_ch_lpos =
  460.                     fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,-1);
  461.             }   }
  462.         }
  463.         #endif
  464.     }}
  465.  
  466. # UP: Füllt beim Schließen eines Streams die Dummy-Pseudofunktionen ein.
  467. # close_dummys(stream);
  468. # > stream: Stream
  469.   local void close_dummys (object stream);
  470.   local void close_dummys(stream)
  471.     var reg1 object stream;
  472.     { TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  473.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  474.       TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  475.       TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL
  476.       TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  477.       #ifdef STRM_WR_SS
  478.       TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  479.       #endif
  480.       TheStream(stream)->strmflags &= ~strmflags_open_B; # Fähigkeiten-Flags löschen
  481.     }
  482.  
  483. # Liefert Fehlermeldung, wenn der Wert des Symbols sym kein Stream ist.
  484.   nonreturning_function(local, fehler_value_stream, (object sym));
  485.   # siehe unten
  486.  
  487. # UP: Liefert den Stream, der der Wert einer Variablen ist.
  488. # var_stream(sym,strmflags)
  489. # > sym: Variable (Symbol)
  490. # > strmflags: Menge von Operationen, die auf dem Stream möglich sein sollen
  491. # < ergebnis: Stream
  492.   global object var_stream (object sym, uintB strmflags);
  493.   global object var_stream(sym,strmflags)
  494.     var reg2 object sym;
  495.     var reg3 uintB strmflags;
  496.     { var reg1 object stream;
  497.       recurse:
  498.         stream = Symbol_value(sym);
  499.         if (!streamp(stream)) { fehler_value_stream(sym); }
  500.         if (strmflags & ~ TheStream(stream)->strmflags) { fehler_value_stream(sym); }
  501.         if (TheStream(stream)->strmtype == strmtype_synonym)
  502.           { sym = TheStream(stream)->strm_synonym_symbol; goto recurse; }
  503.       return stream;
  504.     }
  505.  
  506. # (SYSTEM::SYMBOL-STREAM symbol [direction])
  507. # liefert den Stream, der der Wert des Symbols ist, und überprüft, ob es ein
  508. # offener Stream der Richtung direction (:PROBE, :INPUT, :OUTPUT oder :IO) ist.
  509. LISPFUN(symbol_stream,1,1,norest,nokey,0,NIL)
  510.   { var reg1 object direction = popSTACK();
  511.     var reg2 object symbol = popSTACK();
  512.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  513.     value1 = var_stream(symbol,
  514.                         eq(direction,S(Kinput)) ? strmflags_rd_ch_B : # :INPUT
  515.                         eq(direction,S(Koutput)) ? strmflags_wr_ch_B : # :OUTPUT
  516.                         eq(direction,S(Kio)) ? strmflags_rd_ch_B | strmflags_wr_ch_B : # :IO
  517.                         0 # :PROBE oder nicht angegeben
  518.                        );
  519.     mv_count=1;
  520.   }
  521.  
  522. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  523. # Fehler, wenn aus einem obskuren Grunde ein WRITE nicht gehen sollte:
  524.   nonreturning_function(local, fehler_unwritable, (object caller, object stream));
  525.   local void fehler_unwritable(caller,stream)
  526.     var reg1 object caller;
  527.     var reg2 object stream;
  528.     { pushSTACK(stream); # Wert für Slot PATHNAME von FILE-ERROR
  529.       pushSTACK(stream);
  530.       pushSTACK(caller);
  531.       //: DEUTSCH "~: Kann nichts auf ~ ausgeben."
  532.       //: ENGLISH "~: cannot output to ~"
  533.       //: FRANCAIS "~ : Ne peux rien écrire sur ~."
  534.       fehler(file_error,GETTEXT("~: cannot output to ~"));
  535.     }
  536. #endif
  537.  
  538. # Fehler, wenn ein Objekt kein Character ist:
  539. # fehler_wr_char(stream,obj);
  540.   nonreturning_function(local, fehler_wr_char, (object stream, object obj));
  541.   local void fehler_wr_char(stream,obj)
  542.     var reg1 object stream;
  543.     var reg2 object obj;
  544.     { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  545.       pushSTACK(S(character)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  546.       pushSTACK(stream);
  547.       pushSTACK(obj);
  548.       //: DEUTSCH "~ ist kein Character und kann daher nicht auf ~ ausgegeben werden."
  549.       //: ENGLISH "~ is not a character, cannot be output onto ~"
  550.       //: FRANCAIS "~, n'étant pas de type CHARACTER, ne peut pas être écrit dans ~."
  551.       fehler(type_error,GETTEXT("~ is not a character, cannot be output onto ~"));
  552.     }
  553.  
  554. # Fehler, wenn ein Character kein String-Char ist:
  555. # fehler_wr_string_char(stream,ch);
  556.   nonreturning_function(local, fehler_wr_string_char, (object stream, object ch));
  557.   local void fehler_wr_string_char(stream,ch)
  558.     var reg1 object stream;
  559.     var reg2 object ch;
  560.     { pushSTACK(ch); # Wert für Slot DATUM von TYPE-ERROR
  561.       pushSTACK(S(string_char)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  562.       pushSTACK(stream);
  563.       pushSTACK(ch);
  564.       //: DEUTSCH "Character ~ ist kein String-Char und kann daher nicht auf ~ ausgegeben werden."
  565.       //: ENGLISH "character ~ is not a string-char, cannot be output onto ~"
  566.       //: FRANCAIS "Le caractère ~, n'étant pas de type STRING-CHAR, ne peut pas être écrit dans ~."
  567.       fehler(type_error,GETTEXT("character ~ is not a string-char, cannot be output onto ~"));
  568.     }
  569.  
  570. # Fehler, wenn ein Objekt kein Integer ist:
  571. # fehler_wr_integer(stream,obj);
  572.   nonreturning_function(local, fehler_wr_integer, (object stream, object obj));
  573.   local void fehler_wr_integer(stream,obj)
  574.     var reg1 object stream;
  575.     var reg2 object obj;
  576.     { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  577.       pushSTACK(S(integer)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  578.       pushSTACK(stream);
  579.       pushSTACK(obj);
  580.       //: DEUTSCH "~ ist kein Integer und kann daher nicht auf ~ ausgegeben werden."
  581.       //: ENGLISH "~ is not an integer, cannot be output onto ~"
  582.       //: FRANCAIS "~, n'étant pas un entier, ne peut pas être écrit dans ~."
  583.       fehler(type_error,GETTEXT("~ is not an integer, cannot be output onto ~"));
  584.     }
  585.  
  586. # Fehler, wenn ein Integer nicht im passenden Bereich ist:
  587. # fehler_bad_integer(stream,obj);
  588.   nonreturning_function(local, fehler_bad_integer, (object stream, object obj));
  589.   local void fehler_bad_integer(stream,obj)
  590.     var reg1 object stream;
  591.     var reg2 object obj;
  592.     { pushSTACK(stream);
  593.       pushSTACK(obj);
  594.       //: DEUTSCH "Integer ~ ist zu groß oder zu klein und kann daher nicht auf ~ ausgegeben werden."
  595.       //: ENGLISH "integer ~ is out of range, cannot be output onto ~"
  596.       //: FRANCAIS "L'entier ~, n'étant pas dans l'intervalle souhaité, ne peut pas être écrit dans ~."
  597.       fehler(error,GETTEXT("integer ~ is out of range, cannot be output onto ~"));
  598.     }
  599.  
  600. # Fehler, wenn ein Argument kein Fixnum >=0 ist:
  601. # fehler_bad_lpos();
  602. # > STACK_0: lpos
  603.   nonreturning_function(local, fehler_bad_lpos, (void));
  604.   local void fehler_bad_lpos()
  605.     { # line-position in STACK_0
  606.       pushSTACK(STACK_0); # Wert für Slot DATUM von TYPE-ERROR
  607.       pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  608.       pushSTACK(STACK_(0+2));
  609.       pushSTACK(TheSubr(subr_self)->name);
  610.       //: DEUTSCH "~: Argument muß ein Fixnum >=0 sein, nicht ~"
  611.       //: ENGLISH "~: argument ~ should be a nonnegative fixnum"
  612.       //: FRANCAIS "~ : L'argument doit être de type FIXNUM positif ou zéro et non pas ~."
  613.       fehler(type_error,GETTEXT("~: argument ~ should be a nonnegative fixnum"));
  614.     }
  615.  
  616. # UP: Überprüft Argumente, ob sie Streams sind.
  617. # test_stream_args(args_pointer,argcount);
  618. # > args_pointer: Pointer über die Argumente
  619. # > argcount: Anzahl der Argumente
  620. # > subr_self: Aufrufer (ein SUBR)
  621.   local void test_stream_args (object* args_pointer, uintC argcount);
  622.   local void test_stream_args(args_pointer, argcount)
  623.     var reg1 object* args_pointer;
  624.     var reg2 uintC argcount;
  625.     { dotimesC(argcount,argcount,
  626.         { var reg3 object next_arg = NEXT(args_pointer);
  627.           if (!streamp(next_arg)) { fehler_stream(next_arg); }
  628.         });
  629.     }
  630.  
  631.  
  632. #if defined(UNIX) || defined(EMUNIX) || defined(DJUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  633.  
  634. # UP: Löscht bereits eingegebenen interaktiven Input von einem Handle.
  635.   local void clear_tty_input (Handle handle);
  636.   #if !(defined(DJUNIX) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS))
  637.   local void clear_tty_input(handle)
  638.     var reg1 Handle handle;
  639.     { # Methode 1: tcflush TCIFLUSH, siehe TERMIOS(3V)
  640.       # Methode 2: ioctl TCFLSH TCIFLUSH, siehe TERMIO(4)
  641.       # Methode 3: ioctl TIOCFLUSH FREAD, siehe TTCOMPAT(4)
  642.       begin_system_call();
  643.       #ifdef UNIX_TERM_TERMIOS
  644.       if (!( TCFLUSH(handle,TCIFLUSH) ==0))
  645.         { if (!((errno==ENOTTY)||(errno==EINVAL))) # kein TTY: OK
  646.             { local boolean flag = FALSE;
  647.               if (!flag) { flag = TRUE; OS_error(); } # sonstigen Error melden, aber nur einmal
  648.         }   }
  649.       #endif
  650.       #ifdef UNIX_TERM_TERMIO
  651.       #ifdef TCIFLUSH # !RISCOS
  652.       if (!( ioctl(handle,TCFLSH,(CADDR_T)TCIFLUSH) ==0))
  653.         { if (!(errno==ENOTTY)) # kein TTY: OK
  654.             { local boolean flag = FALSE;
  655.               if (!flag) { flag = TRUE; OS_error(); } # sonstigen Error melden, aber nur einmal
  656.         }   }
  657.       #endif
  658.       #endif
  659.       #ifdef UNIX_TERM_SGTTY
  660.       #ifdef FREAD # !UNIX_MINT
  661.       { var int arg = FREAD;
  662.         if (!( ioctl(handle,TIOCFLUSH,&arg) ==0))
  663.           { if (!(errno==ENOTTY)) # kein TTY: OK
  664.               { local boolean flag = FALSE;
  665.                 if (!flag) { flag = TRUE; OS_error(); } # sonstigen Error melden, aber nur einmal
  666.       }   }   }
  667.       #endif
  668.       #endif
  669.       #ifdef EMUNIX
  670.       # Eberhard Mattes sagt, das funktioniert nur, wenn IDEFAULT nicht
  671.       # gesetzt ist. ??
  672.       if (!( ioctl(handle,TCFLSH,0) ==0))
  673.         { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Erro
  674.       #endif
  675.       end_system_call();
  676.     }
  677.   #else
  678.     #define clear_tty_input(handle)
  679.   #endif
  680.  
  681. # UP: Bringt den wartenden Output eines Handles ans Ziel.
  682.   local void finish_tty_output (Handle handle);
  683.   #if !(defined(DJUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS))
  684.   local void finish_tty_output(handle)
  685.     var reg1 Handle handle;
  686.     { # Methode 1: fsync, siehe FSYNC(2)
  687.       # Methode 2: tcdrain, siehe TERMIOS(3V)
  688.       # Methode 3: ioctl TCSBRK 1, siehe TERMIO(4)
  689.       # evtl. Methode 3: ioctl TCGETS/TCSETSW, siehe TERMIO(4)
  690.       # oder (fast äquivalent) ioctl TIOCGETP/TIOCSETP, siehe TTCOMPAT(4)
  691.       begin_system_call();
  692.       #if !(defined(UNIX) && !defined(HAVE_FSYNC))
  693.       if (!( fsync(handle) ==0))
  694.         #ifdef EMUNIX_NEW_8e
  695.         #ifdef EMUNIX_NEW_9a
  696.         if (!(errno==ENOSYS))
  697.         #else
  698.         if (!(errno==EMSDOS))
  699.         #endif
  700.         #endif
  701.         if (!(errno==EINVAL)) { OS_error(); }
  702.       #endif
  703.       #ifdef UNIX_TERM_TERMIOS
  704.       if (!( TCDRAIN(handle) ==0))
  705.         { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } # kein TTY: OK, sonstigen Error melden
  706.       #endif
  707.       #ifdef UNIX_TERM_TERMIO
  708.       if (!( ioctl(handle,TCSBRK,(CADDR_T)1) ==0))
  709.         { if (!(errno==ENOTTY)) { OS_error(); } }
  710.       #endif
  711.       #if defined(UNIX_TERM_TERMIOS) && defined(TCGETS) && defined(TCSETSW)
  712.       {var struct termios term_parameters;
  713.        if (!(   ( ioctl(handle,TCGETS,&term_parameters) ==0)
  714.              && ( ioctl(handle,TCSETSW,&term_parameters) ==0)
  715.           ) )
  716.          { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } # kein TTY: OK, sonstigen Error melden
  717.       }
  718.       #endif
  719.       #ifdef EMUNIX
  720.       {var struct termio term_parameters;
  721.        if (!(   ( ioctl(handle,TCGETA,&term_parameters) ==0)
  722.              && ( ioctl(handle,TCSETAW,&term_parameters) ==0)
  723.           ) )
  724.          { if (!(errno==ENOTTY)) { OS_error(); } }
  725.       }
  726.       #endif
  727.       #if 0 # Vorsicht: das müßte FINISH-OUTPUT und CLEAR-INPUT bewirken!
  728.       {var struct sgttyb tty_parameters;
  729.        if (!(   ( ioctl(handle,TIOCGETP,&tty_parameters) ==0)
  730.              && ( ioctl(handle,TIOCSETP,&tty_parameters) ==0)
  731.           ) )
  732.          { if (!(errno==ENOTTY)) { OS_error(); } }
  733.       }
  734.       #endif
  735.       end_system_call();
  736.     }
  737.   #else
  738.     #define finish_tty_output(handle)
  739.   #endif
  740.  
  741. # UP: Bringt den wartenden Output eines Handles ans Ziel.
  742.   local void force_tty_output (Handle handle);
  743.   #if !(defined(DJUNIX) || defined(WATCOM) || (defined(UNIX) && !defined(HAVE_FSYNC)) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS))
  744.   local void force_tty_output(handle)
  745.     var reg1 Handle handle;
  746.     { # Methode: fsync, siehe FSYNC(2)
  747.       begin_system_call();
  748.       if (!( fsync(handle) ==0))
  749.         #ifdef EMUNIX_NEW_8e
  750.         #ifdef EMUNIX_NEW_9a
  751.         if (!(errno==ENOSYS))
  752.         #else
  753.         if (!(errno==EMSDOS))
  754.         #endif
  755.         #endif
  756.         if (!(errno==EINVAL)) { OS_error(); }
  757.       end_system_call();
  758.     }
  759.   #else
  760.     #define force_tty_output(handle)
  761.   #endif
  762.  
  763. # UP: Löscht den wartenden Output eines Handles.
  764.   local void clear_tty_output (Handle handle);
  765.   #if !(defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS))
  766.   local void clear_tty_output(handle)
  767.     var reg1 Handle handle;
  768.     { # Methode 1: tcflush TCOFLUSH, siehe TERMIOS(3V)
  769.       # Methode 2: ioctl TCFLSH TCOFLUSH, siehe TERMIO(4)
  770.       # Methode 3: ioctl TIOCFLUSH FWRITE, siehe TTCOMPAT(4)
  771.       begin_system_call();
  772.       #ifdef UNIX_TERM_TERMIOS
  773.       if (!( TCFLUSH(handle,TCOFLUSH) ==0))
  774.         { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } # kein TTY: OK, sonstigen Error melden
  775.       #endif
  776.       #ifdef UNIX_TERM_TERMIO
  777.       #ifdef TCOFLUSH # !RISCOS
  778.       if (!( ioctl(handle,TCFLSH,(CADDR_T)TCOFLUSH) ==0))
  779.         { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Error melden
  780.       #endif
  781.       #endif
  782.       #ifdef UNIX_TERM_SGTTY
  783.       #ifdef FWRITE # !UNIX_MINT
  784.       {var int arg = FWRITE;
  785.        if (!( ioctl(handle,TIOCFLUSH,&arg) ==0))
  786.          { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Error melden
  787.       }
  788.       #endif
  789.       #endif
  790.       end_system_call();
  791.     }
  792.   #else
  793.     #define clear_tty_output(handle)
  794.   #endif
  795.  
  796. #endif
  797.  
  798. #if defined(AMIGAOS)
  799.  
  800. # UP: Bringt den wartenden Output eines Handles ans Ziel.
  801.   local void finish_tty_output (Handle handle);
  802.   # Wir können nichts tun, da wir handle nicht schließen dürfen und
  803.   # kein fsync() haben.
  804.   #define finish_tty_output(handle)
  805.  
  806. # UP: Bringt den wartenden Output eines Handles ans Ziel.
  807.   local void force_tty_output (Handle handle);
  808.   #define force_tty_output(handle)  finish_tty_output(handle)
  809.  
  810. # UP: Löscht den wartenden Output eines Handles.
  811.   local void clear_tty_output (Handle handle);
  812.   # Nichts zu tun.
  813.   #define clear_tty_output(handle)
  814.  
  815. #endif
  816.  
  817.  
  818. #if (defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)) && (!defined(TERMINAL_USES_KEYBOARD) || defined(HANDLES) || defined(PIPES) || defined(XSOCKETS) || defined(SOCKET_STREAMS))
  819. #define XHANDLES
  820.  
  821. # Handle-Streams
  822. # ==============
  823.  
  824. # sind ein gemeinsamer Rahmen für Streams, deren Input/Output ungebuffert
  825. # über ein Handle des Betriebssystems abgewickelt wird. Umfaßt:
  826. # Input: Terminal-Stream, File-Handle-Stream, Pipe-Input-Stream, Socket-Stream.
  827. # Output: File-Handle-Stream, Pipe-Output-Stream, Socket-Stream.
  828.  
  829. #define strm_isatty   strm_other[0]  # Flag, ob das Input-Handle ein TTY ist
  830. #define strm_ihandle  strm_other[1]  # Input-Handle immer als zweite Komponente
  831. #define strm_ohandle  strm_other[2]  # Output-Handle immer als dritte Komponente
  832.  
  833. # Daß beim Input EOF erreicht ist, erkennt man an
  834. # TheStream(stream)->strm_rd_ch_last = eof_value.
  835.  
  836. # READ-CHAR - Pseudofunktion für Handle-Streams:
  837.   local object rd_ch_handle (object* stream_);
  838.   local object rd_ch_handle(stream_)
  839.     var reg4 object* stream_;
  840.     {   restart_it:
  841.      {  var reg2 object stream = *stream_;
  842.         if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF?
  843.           { return eof_value; }
  844.       { var reg3 Handle handle = TheHandle(TheStream(stream)->strm_ihandle);
  845.         var uintB c;
  846.         #if defined(AMIGAOS)
  847.         interruptp({ pushSTACK(S(read_char)); tast_break(); # Ctrl-C -> Break-Schleife aufrufen
  848.                      return read_char(stream_);
  849.                    });
  850.         #endif
  851.         run_time_stop(); # Run-Time-Stoppuhr anhalten
  852.         #ifdef GRAPHICS_SWITCH
  853.         if (handle == stdin_handle) switch_text_mode();
  854.         #endif
  855.         begin_system_call();
  856.        {
  857.         #if !defined(AMIGAOS)
  858.         var reg1 int ergebnis = read(handle,&c,1); # Zeichen lesen versuchen
  859.         #else # defined(AMIGAOS)
  860.         var reg1 long ergebnis = Read(handle,&c,1L); # Zeichen lesen versuchen
  861.         #endif
  862.         end_system_call();
  863.         run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  864.         if (ergebnis<0)
  865.           {
  866.             #if !defined(AMIGAOS)
  867.             if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  868.               { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen
  869.                 goto restart_it;
  870.               }
  871.             #endif
  872.             OS_error();
  873.           }
  874.         if (ergebnis==0)
  875.           # kein Zeichen verfügbar -> muß EOF sein
  876.           { return eof_value; }
  877.           else
  878.           {
  879.             #if defined(AMIGAOS)
  880.             # Ctrl-C wird meist während des Read()-Aufrufs festgestellt, und
  881.             # Read() liefert dann "unschuldig" ein Zeichen ab. Wir behandeln
  882.             # das Ctrl-C jetzt. Damit das Zeichen nicht verlorengeht, wird
  883.             # es wie durch unread_char() zurückgelegt.
  884.             interruptp(
  885.               { TheStream(stream)->strm_rd_ch_last = fixnum(c);
  886.                 pushSTACK(S(read_char)); tast_break(); # Break-Schleife aufrufen
  887.                 return read_char(stream_);
  888.               });
  889.             #endif
  890.             return code_char(c);
  891.           }
  892.     }}}}
  893.  
  894. # Stellt fest, ob ein Handle-Stream ein Zeichen verfügbar hat.
  895. # listen_handle(stream)
  896. # > stream: Handle-Stream
  897. # < ergebnis:  0 falls Zeichen verfügbar,
  898. #             -1 falls bei EOF angelangt,
  899. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  900.   local signean listen_handle (object stream);
  901.   local signean listen_handle(stream)
  902.     var reg2 object stream;
  903.     { if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ?
  904.         { return signean_minus; }
  905.       # Methode 1: select, siehe SELECT(2)
  906.       # Methode 2: ioctl FIONREAD, siehe FILIO(4)
  907.       # Methode 3: kurzzeitig auf non-blocking I/O schalten und read versuchen,
  908.       #            siehe READ(2V) und FILIO(4), bzw.
  909.       #            siehe READ(2V), FCNTL(2V) und FCNTL(5)
  910.      {var reg3 Handle handle = TheHandle(TheStream(stream)->strm_ihandle);
  911.       #if defined(MSDOS) && !defined(EMUNIX_PORTABEL) && !defined(WIN32_DOS)
  912.       { var reg2 uintB status;
  913.         begin_system_call();
  914.         get_handle_input_status(handle,status);
  915.         end_system_call();
  916.         if (status) { return signean_null; } # Zeichen verfügbar
  917.       }
  918.       if (!nullp(TheStream(stream)->strm_isatty))
  919.         # Terminal
  920.         { return signean_plus; } # kein Zeichen verfügbar
  921.         else
  922.         # File
  923.         # kein Zeichen verfügbar -> EOF erkennen
  924.         { TheStream(stream)->strm_rd_ch_last = eof_value;
  925.           return signean_minus;
  926.         }
  927.       #elif defined(EMUNIX_PORTABEL)
  928.       { var struct termio oldtermio;
  929.         var struct termio newtermio;
  930.         begin_system_call();
  931.         if (!( ioctl(handle,TCGETA,&oldtermio) ==0))
  932.           { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } }
  933.         newtermio = oldtermio;
  934.         newtermio.c_lflag &= ~IDEFAULT & ~ICANON;
  935.         if (!( ioctl(handle,TCSETA,&newtermio) ==0))
  936.           { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } }
  937.        {var unsigned long chars_ready = 0;
  938.         var int result = ioctl(handle,FIONREAD,&chars_ready); # abfragen
  939.         # (Bei EMUNIX_NEW_8f könnte man das auch mit select() machen.)
  940.         if (!( ioctl(handle,TCSETA,&oldtermio) ==0))
  941.           { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } }
  942.         end_system_call();
  943.         if (result == 0)
  944.           # Abfrage gelungen
  945.           { if (chars_ready > 0) { return signean_null; } } # welche verfügbar?
  946.         #ifdef EMUNIX_NEW_8e
  947.         begin_system_call();
  948.         if (!isatty(handle))
  949.           { result = eof(handle);
  950.             if (result<0)
  951.               { if (!(errno==ESPIPE)) { OS_error(); } } # "Illegal seek error" ist OK
  952.               else
  953.               { end_system_call();
  954.                 if (result>0) # EOF erreicht?
  955.                   { return signean_minus; }
  956.                   else
  957.                   { return signean_null; }
  958.           }   }
  959.         end_system_call();
  960.         #endif
  961.         return signean_plus; # offenbar kein Zeichen verfügbar
  962.       }}
  963.       #elif !defined(AMIGAOS)
  964.       #ifdef HAVE_SELECT
  965.       { # Verwende select mit readfds = einelementige Menge {handle}
  966.         # und timeout = Null-Zeitintervall.
  967.         var fd_set handle_menge; # Menge von Handles := {handle}
  968.         var struct timeval zero_time; # Zeitintervall := 0
  969.         FD_ZERO(&handle_menge); FD_SET(handle,&handle_menge);
  970.         restart_select:
  971.         zero_time.tv_sec = 0; zero_time.tv_usec = 0;
  972.         begin_system_call();
  973.        {var reg1 int ergebnis;
  974.         ergebnis = select(FD_SETSIZE,&handle_menge,NULL,NULL,&zero_time);
  975.         end_system_call();
  976.         if (ergebnis<0)
  977.           { if (errno==EINTR) goto restart_select;
  978.             if (!(errno==EBADF)) { OS_error(); } # UNIX_LINUX liefert bei Files EBADF !
  979.           }
  980.           else
  981.           { # ergebnis = number of handles in handle_menge, for which
  982.             # read() would return immediately.
  983.             if (ergebnis==0)
  984.               { return signean_plus; } # no character available
  985.             # ergebnis=1
  986.             # If read() returns immediately, this can also be EOF!
  987.             # (For example: Linux and pipes.) We are therefore clever
  988.             # enough not to execute a  { return signean_null; }.
  989.             # Instead, we now try methods 2 and 3.
  990.       }}  }
  991.       #endif
  992.       #ifdef HAVE_FIONREAD
  993.       # versuche die Zahl der verfügbaren Zeichen abzufragen:
  994.       begin_system_call();
  995.       {var unsigned long chars_ready;
  996.        if ( ioctl(handle,FIONREAD,&chars_ready) <0) # abfragen
  997.          # Abfrage mißlungen, war wohl kein File
  998.          { if (!((errno == ENOTTY)||(errno == EINVAL)
  999.                #ifdef ENOSYS 
  1000.                ||(errno==ENOSYS)
  1001.                #endif
  1002.               )) { OS_error(); }
  1003.            end_system_call();
  1004.          }
  1005.          else
  1006.          # Abfrage gelungen, also war's ein File
  1007.          { end_system_call();
  1008.            if (chars_ready > 0) { return signean_null; } # welche verfügbar?
  1009.            #ifdef HAVE_RELIABLE_FIONREAD
  1010.            # sonst EOF des File erkennen:
  1011.            TheStream(stream)->strm_rd_ch_last = eof_value;
  1012.            return signean_minus;
  1013.            #endif
  1014.          }
  1015.       }
  1016.       #endif
  1017.       #ifdef GRAPHICS_SWITCH
  1018.       if (handle == stdin_handle) switch_text_mode();
  1019.       #endif
  1020.       #ifndef HAVE_SELECT
  1021.       if (!nullp(TheStream(stream)->strm_isatty))
  1022.         # Terminal
  1023.         { # in Non-blocking-Modus umschalten, dann read() versuchen:
  1024.           var uintB c;
  1025.           var int ergebnis;
  1026.           begin_system_call();
  1027.           restart_read_tty:
  1028.           #ifdef FIONBIO # non-blocking I/O à la BSD 4.2
  1029.           { var int non_blocking_io;
  1030.             non_blocking_io = 1;
  1031.             if (!( ioctl(handle,FIONBIO,&non_blocking_io) ==0))
  1032.               { OS_error(); }
  1033.             ergebnis = read(handle,&c,1); # Zeichen lesen versuchen
  1034.             non_blocking_io = 0;
  1035.             if (!( ioctl(handle,FIONBIO,&non_blocking_io) ==0))
  1036.               { OS_error(); }
  1037.           }
  1038.           #else # non-blocking I/O à la SYSV
  1039.           { var reg2 int fcntl_flags;
  1040.             if (( fcntl_flags = fcntl(handle,F_GETFL,0) )<0) { OS_error(); }
  1041.             if ( fcntl(handle,F_SETFL,fcntl_flags|O_NDELAY) <0) { OS_error(); }
  1042.             ergebnis = read(handle,&c,1); # Zeichen lesen versuchen
  1043.             if ( fcntl(handle,F_SETFL,fcntl_flags) <0) { OS_error(); }
  1044.           }
  1045.           #endif
  1046.           if (ergebnis < 0)
  1047.             { if (errno==EINTR) goto restart_read_tty;
  1048.               #ifdef FIONBIO
  1049.               if (errno==EWOULDBLOCK) # BSD 4.2 Error-Code
  1050.               #else
  1051.               if ((errno==EAGAIN) # Posix Error-Code
  1052.                   #ifdef EWOULDBLOCK
  1053.                   || (errno==EWOULDBLOCK)
  1054.                   #endif
  1055.                  )
  1056.               #endif
  1057.                 { return signean_plus; } # kein Zeichen verfügbar
  1058.               OS_error();
  1059.             }
  1060.           end_system_call();
  1061.           if (ergebnis==0)
  1062.             # kein Zeichen verfügbar
  1063.             { return signean_plus; }
  1064.             else
  1065.             # Zeichen verfügbar
  1066.             { TheStream(stream)->strm_rd_ch_last = fixnum(c);
  1067.               return signean_null;
  1068.             }
  1069.           # Sollte das nicht gehen, einen Timer von 1/10 sec verwenden??
  1070.         }
  1071.         else
  1072.       #endif
  1073.         # File (oder Pipe)
  1074.         { # ein Zeichen lesen versuchen (wie bei peek_char):
  1075.           begin_system_call();
  1076.           restart_read_other:
  1077.          {var uintB c;
  1078.           var reg1 int ergebnis = read(handle,&c,1); # Zeichen lesen versuchen
  1079.           if (ergebnis<0)
  1080.             { if (errno==EINTR) goto restart_read_other;
  1081.               OS_error();
  1082.             }
  1083.           end_system_call();
  1084.           if (ergebnis==0)
  1085.             # kein Zeichen verfügbar -> EOF erkennen
  1086.             { TheStream(stream)->strm_rd_ch_last = eof_value;
  1087.               return signean_minus;
  1088.             }
  1089.             else # Zeichen verfügbar
  1090.             { TheStream(stream)->strm_rd_ch_last = fixnum(c);
  1091.               return signean_null;
  1092.             }
  1093.         }}
  1094.       #else # defined(AMIGAOS)
  1095.       begin_system_call();
  1096.       if (!nullp(TheStream(stream)->strm_isatty))
  1097.         # interaktiv
  1098.         { if (WaitForChar(handle,0L)) # 0 usec auf ein Zeichen warten
  1099.             { end_system_call(); return signean_null; } # eins da
  1100.             else
  1101.             { end_system_call(); return signean_plus; } # keins da
  1102.         }
  1103.         else
  1104.         # nicht interaktiv
  1105.         { # ein Zeichen lesen versuchen (wie bei peek_char):
  1106.           var uintB c;
  1107.           var reg1 long ergebnis = Read(handle,&c,1L); # Zeichen lesen versuchen
  1108.           end_system_call();
  1109.           if (ergebnis<0) { OS_error(); }
  1110.           if (ergebnis==0)
  1111.             # kein Zeichen verfügbar -> EOF erkennen
  1112.             { TheStream(stream)->strm_rd_ch_last = eof_value;
  1113.               return signean_minus;
  1114.             }
  1115.             else # Zeichen verfügbar
  1116.             { TheStream(stream)->strm_rd_ch_last = fixnum(c);
  1117.               return signean_null;
  1118.             }
  1119.         }
  1120.       #endif
  1121.     }}
  1122.  
  1123. # UP: Löscht bereits eingegebenen interaktiven Input von einem Handle-Stream.
  1124. # clear_input_handle(stream);
  1125. # > stream: Handle-Stream
  1126. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  1127.   local boolean clear_input_handle (object stream);
  1128.   local boolean clear_input_handle(stream)
  1129.     var reg1 object stream;
  1130.     { var reg1 Handle handle = TheHandle(TheStream(stream)->strm_ihandle);
  1131.       if (nullp(TheStream(stream)->strm_isatty))
  1132.         # File -> nichts tun
  1133.         { return FALSE; }
  1134.       #if !defined(AMIGAOS)
  1135.       # Terminal
  1136.       TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen
  1137.       clear_tty_input(handle);
  1138.       # Für den Fall, das das nicht funktionierte:
  1139.       # Zeichen lesen, solange listen_handle() 0 liefert.
  1140.       pushSTACK(stream);
  1141.       while (listen_handle(STACK_0) == 0) { read_char(&STACK_0); }
  1142.       skipSTACK(1);
  1143.       return TRUE;
  1144.       #else # defined(AMIGAOS)
  1145.       # interaktiv
  1146.       { begin_system_call();
  1147.         loop
  1148.           { if (!WaitForChar(handle,0L)) # 0 usec auf ein Zeichen warten
  1149.               break; # keins mehr da -> fertig
  1150.            {var uintB c;
  1151.             var reg1 long ergebnis = Read(handle,&c,1L); # Zeichen lesen versuchen
  1152.             if (ergebnis<0) { OS_error(); }
  1153.           }}
  1154.         end_system_call();
  1155.         return TRUE;
  1156.       }
  1157.       #endif
  1158.     }
  1159.  
  1160. # WRITE-CHAR - Pseudofunktion für Handle-Streams:
  1161.   local void wr_ch_handle (object* stream_, object ch);
  1162.   local void wr_ch_handle(stream_,ch)
  1163.     var reg3 object* stream_;
  1164.     var reg1 object ch;
  1165.     { var reg2 Handle handle = TheHandle(TheStream(*stream_)->strm_ohandle);
  1166.       # ch sollte String-Char sein:
  1167.       if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); }
  1168.      {var uintB c = char_code(ch); # Code des Zeichens
  1169.       restart_it:
  1170.       #ifdef GRAPHICS_SWITCH
  1171.       if (handle == stdout_handle) switch_text_mode();
  1172.       #endif
  1173.       begin_system_call();
  1174.       {
  1175.        #if !defined(AMIGAOS)
  1176.        var reg4 int ergebnis = write(handle,&c,1); # Zeichen auszugeben versuchen
  1177.        end_system_call();
  1178.        if (ergebnis<0)
  1179.          { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  1180.              { interruptp({ pushSTACK(S(write_char)); tast_break(); }); # Break-Schleife aufrufen
  1181.                goto restart_it;
  1182.              }
  1183.            OS_error(); # Error melden
  1184.          }
  1185.        #else # defined(AMIGAOS)
  1186.        var reg4 long ergebnis = Write(handle,&c,1L); # Zeichen auszugeben versuchen
  1187.        end_system_call();
  1188.        if (ergebnis<0) { OS_error(); } # Error melden
  1189.        interruptp({ pushSTACK(S(write_char)); tast_break(); }); # Ctrl-C -> Break-Schleife aufrufen
  1190.        #endif
  1191.        if (ergebnis==0) # nicht erfolgreich?
  1192.          { fehler_unwritable(S(write_char),*stream_); }
  1193.       }
  1194.     }}
  1195.  
  1196. # WRITE-CHAR-SEQUENCE für Handle-Streams:
  1197.   local uintB* write_schar_array_handle (object stream, uintB* ptr, uintL len);
  1198.   local uintB* write_schar_array_handle(stream,ptr,len)
  1199.     var reg5 object stream;
  1200.     var reg1 uintB* ptr;
  1201.     var reg6 uintL len;
  1202.     { var reg4 Handle handle = TheHandle(TheStream(stream)->strm_ohandle);
  1203.       var reg2 uintL remaining = len;
  1204.       #ifdef GRAPHICS_SWITCH
  1205.       if (handle == stdout_handle) switch_text_mode();
  1206.       #endif
  1207.       begin_system_call();
  1208.       restart_it:
  1209.       loop
  1210.         {
  1211.           #if !defined(AMIGAOS)
  1212.           var reg3 int ergebnis = full_write(handle,ptr,remaining); # Zeichen auszugeben versuchen
  1213.           if (ergebnis<0)
  1214.             { if (errno==EINTR) goto restart_it;
  1215.               OS_error(); # Error melden
  1216.             }
  1217.           #else # defined(AMIGAOS)
  1218.           var reg3 long ergebnis = Write(handle,ptr,remaining); # Zeichen auszugeben versuchen
  1219.           if (ergebnis<0) { OS_error(); } # Error melden
  1220.           #endif
  1221.           if (ergebnis==0) # nicht erfolgreich?
  1222.             { fehler_unwritable(S(write_string),stream); }
  1223.           ptr += ergebnis; remaining -= ergebnis;
  1224.           if (remaining==0) break; # fertig?
  1225.         }
  1226.       end_system_call();
  1227.       wr_ss_lpos(stream,ptr,len); # Line-Position aktualisieren
  1228.       return ptr;
  1229.     }
  1230.  
  1231. #ifdef STRM_WR_SS
  1232. # WRITE-SIMPLE-STRING - Pseudofunktion für Handle-Streams:
  1233.   local void wr_ss_handle (object* stream_, object string, uintL start, uintL len);
  1234.   local void wr_ss_handle(stream_,string,start,len)
  1235.     var reg1 object* stream_;
  1236.     var reg2 object string;
  1237.     var reg4 uintL start;
  1238.     var reg3 uintL len;
  1239.     { if (len==0) return;
  1240.       write_schar_array_handle(*stream_,&TheSstring(string)->data[start],len);
  1241.     }
  1242. #endif
  1243.  
  1244. #if defined(MSDOS)
  1245. # WRITE-CHAR - Pseudofunktion für Handle-Streams, mit NL -> CR/LF - Umwandlung:
  1246.   local void wr_ch_handle_x (object* stream_, object ch);
  1247.   local void wr_ch_handle_x(stream_,ch)
  1248.     var reg2 object* stream_;
  1249.     var reg1 object ch;
  1250.     { if (eq(ch,code_char(NL)))
  1251.         # Newline als CR/LF ausgeben
  1252.         { wr_ch_handle(stream_,code_char(CR));
  1253.           wr_ch_handle(stream_,code_char(LF));
  1254.         }
  1255.         else
  1256.         # alle anderen Zeichen unverändert ausgeben
  1257.         { wr_ch_handle(stream_,ch); }
  1258.     }
  1259.   #define wr_ss_handle_x wr_ss_dummy
  1260. #else
  1261.   #define wr_ch_handle_x wr_ch_handle
  1262.   #define wr_ss_handle_x wr_ss_handle
  1263. #endif
  1264.  
  1265. # UP: Bringt den wartenden Output eines Handle-Stream ans Ziel.
  1266. # finish_output_handle(stream);
  1267. # > stream: Handle-Stream
  1268. # kann GC auslösen
  1269.   local void finish_output_handle (object stream);
  1270.   local void finish_output_handle(stream)
  1271.     var reg1 object stream;
  1272.     { finish_tty_output(TheHandle(TheStream(stream)->strm_ohandle)); }
  1273.  
  1274. # UP: Bringt den wartenden Output eines Handle-Stream ans Ziel.
  1275. # force_output_handle(stream);
  1276. # > stream: Handle-Stream
  1277. # kann GC auslösen
  1278.   local void force_output_handle (object stream);
  1279.   local void force_output_handle(stream)
  1280.     var reg1 object stream;
  1281.     { force_tty_output(TheHandle(TheStream(stream)->strm_ohandle)); }
  1282.  
  1283. # UP: Löscht den wartenden Output eines Handle-Stream.
  1284. # clear_output_handle(stream);
  1285. # > stream: Handle-Stream
  1286. # kann GC auslösen
  1287.   local void clear_output_handle (object stream);
  1288.   local void clear_output_handle(stream)
  1289.     var reg1 object stream;
  1290.     { clear_tty_output(TheHandle(TheStream(stream)->strm_ohandle)); }
  1291.  
  1292. #if defined(HANDLES) || defined(XSOCKETS) || defined(SOCKET_STREAMS)
  1293.  
  1294. # READ-BYTE - Pseudofunktion für Handle-Streams:
  1295.   local object rd_by_handle (object stream);
  1296.   local object rd_by_handle(stream)
  1297.     var reg1 object stream;
  1298.     { pushSTACK(stream);
  1299.      {var reg1 object obj = read_char(&STACK_0);
  1300.       skipSTACK(1);
  1301.       if (!eq(obj,eof_value)) { obj = char_to_fixnum(obj); }
  1302.       return obj;
  1303.     }}
  1304.  
  1305. # WRITE-BYTE - Pseudofunktion für Handle-Streams:
  1306.   local void wr_by_handle (object stream, object obj);
  1307.   local void wr_by_handle(stream,obj)
  1308.     var reg1 object stream;
  1309.     var reg2 object obj;
  1310.     { # obj überprüfen:
  1311.       if (!integerp(obj)) { fehler_wr_integer(stream,obj); }
  1312.       if (!(posfixnump(obj) && (posfixnum_to_L(obj) < char_code_limit)))
  1313.         { fehler_bad_integer(stream,obj); }
  1314.       pushSTACK(stream);
  1315.       wr_ch_handle(&STACK_0,fixnum_to_char(obj));
  1316.       skipSTACK(1);
  1317.     }
  1318.  
  1319. #endif
  1320.  
  1321. #if defined(HANDLES) || (defined(PIPES) && defined(UNIX)) || defined(XSOCKETS) || defined(SOCKET_STREAMS)
  1322.  
  1323. # Schließt einen Handle-Stream.
  1324. # close_ihandle(stream);
  1325. # close_ohandle(stream);
  1326. # > stream : Handle-Stream
  1327.   local void close_ihandle (object stream);
  1328.   local void close_ohandle (object stream);
  1329.   local void close_ihandle(stream)
  1330.     var reg1 object stream;
  1331.     { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_ihandle);
  1332.       begin_system_call();
  1333.       if (!( CLOSE(handle) ==0)) { OS_error(); }
  1334.       end_system_call();
  1335.     }
  1336.   local void close_ohandle(stream)
  1337.     var reg1 object stream;
  1338.     { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_ohandle);
  1339.       begin_system_call();
  1340.       if (!( CLOSE(handle) ==0)) { OS_error(); }
  1341.       end_system_call();
  1342.     }
  1343.  
  1344. #endif
  1345.  
  1346. #if defined(HANDLES)
  1347.  
  1348. #define close_handle  close_ihandle
  1349.  
  1350. # UP: erzeugt ein File-Handle-Stream
  1351. # make_handle_stream(handle,direction)
  1352. # > handle: Handle des geöffneten Files
  1353. # > STACK_1: Filename, ein Pathname
  1354. # > STACK_0: Truename, ein Pathname
  1355. # > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE)
  1356. # < ergebnis: File-Handle-Stream
  1357. # < STACK: aufgeräumt
  1358. # kann GC auslösen
  1359.   local object make_handle_stream (object handle, uintB direction);
  1360.   local object make_handle_stream(handle,direction)
  1361.     var reg4 object handle;
  1362.     var reg2 uintB direction;
  1363.     { # Flags:
  1364.       var reg3 uintB flags =
  1365.           ((direction & bit(0)) ? strmflags_rd_B : 0) # evtl. READ-CHAR, READ-BYTE erlaubt
  1366.         | ((direction & bit(2)) ? strmflags_wr_B : 0) # evtl. WRITE-CHAR, WRITE-BYTE erlaubt
  1367.         #ifdef IMMUTABLE
  1368.         | ((direction & bit(1)) ? strmflags_immut_B : 0) # evtl. immutable Objekte
  1369.         #endif
  1370.         ;
  1371.       #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT
  1372.       pushSTACK(handle); # Handle retten
  1373.       #endif
  1374.      {# Stream allozieren:
  1375.       var reg1 object stream = allocate_stream(flags,strmtype_handle,strm_len+5);
  1376.       # und füllen:
  1377.       if (direction & bit(0))
  1378.         { TheStream(stream)->strm_rd_by = P(rd_by_handle);
  1379.           TheStream(stream)->strm_rd_ch = P(rd_ch_handle);
  1380.         }
  1381.         else
  1382.         { TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  1383.           TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  1384.         }
  1385.       if (direction & bit(2))
  1386.         { TheStream(stream)->strm_wr_by = P(wr_by_handle);
  1387.           TheStream(stream)->strm_wr_ch = P(wr_ch_handle_x);
  1388.           #ifdef STRM_WR_SS
  1389.           TheStream(stream)->strm_wr_ss = P(wr_ss_handle_x);
  1390.           #endif
  1391.         }
  1392.         else
  1393.         { TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  1394.           TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  1395.           #ifdef STRM_WR_SS
  1396.           TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  1397.           #endif
  1398.         }
  1399.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  1400.       #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT
  1401.       handle = popSTACK(); # Handle zurück
  1402.       #endif
  1403.       TheStream(stream)->strm_ihandle =
  1404.       TheStream(stream)->strm_ohandle = handle; # Handle eintragen
  1405.       # Flag isatty = (handle_tty ? T : NIL) bestimmen:
  1406.       begin_system_call();
  1407.       #if !defined(AMIGAOS)
  1408.       TheStream(stream)->strm_isatty = (isatty(TheHandle(handle)) ? T : NIL);
  1409.       #else # defined(AMIGAOS)
  1410.       TheStream(stream)->strm_isatty = (IsInteractive(TheHandle(handle)) ? T : NIL);
  1411.       #endif
  1412.       end_system_call();
  1413.       # File-Handle-Streams werden für Pathname-Zwecke wie File-Streams behandelt.
  1414.       # Daher ist (vgl. file_write_date) strm_file_handle == strm_ohandle,
  1415.       # und wir tragen nun die Pathnames ein:
  1416.       TheStream(stream)->strm_file_truename = popSTACK(); # Truename eintragen
  1417.       TheStream(stream)->strm_file_name = popSTACK(); # Filename eintragen
  1418.       # Liste der offenen Streams um stream erweitern:
  1419.       pushSTACK(stream);
  1420.       {var reg2 object new_cons = allocate_cons();
  1421.        Car(new_cons) = stream = popSTACK();
  1422.        Cdr(new_cons) = O(open_files);
  1423.        O(open_files) = new_cons;
  1424.       }
  1425.       return stream;
  1426.     }}
  1427.  
  1428. #endif
  1429.  
  1430. #endif # (UNIX || DJUNIX || EMUNIX || WATCOM || AMIGAOS || RISCOS) && (brauche Handle-Streams)
  1431.  
  1432.  
  1433. #ifdef KEYBOARD
  1434.  
  1435. # Keyboard-Stream
  1436. # ===============
  1437.  
  1438. # Funktionsweise:
  1439. # Liest ein Zeichen von Tastatur.
  1440. # Liefert ein Character mit Font=0 und folgenden Bits:
  1441. #   HYPER      falls Sondertaste.
  1442. #              Zu den Sondertasten zählen die Non-Standard-Tasten.
  1443. #              MSDOS:
  1444. #                Funktionstasten, Cursorblöcke, Ziffernblock.
  1445. #   CHAR-CODE  Bei normalen Tasten der Ascii-Code,
  1446. #              bei Sondertasten:
  1447. #              MSDOS:
  1448. #                F1 -> #\F1, ..., F10 -> #\F10, F11 -> #\F11, F12 -> #\F12,
  1449. #                Insert -> #\Insert, Delete -> #\Delete,
  1450. #                Home -> #\Home, End -> #\End, PgUp -> #\PgUp, PgDn -> #\PgDn,
  1451. #                Pfeiltasten -> #\Up, #\Down, #\Left, #\Right.
  1452. #   SUPER      falls mit Shift-Taste(n) gedrückt und sich ohne Shift
  1453. #              ein anderer Code ergeben hätte,
  1454. #   CONTROL    falls mit Control-Taste gedrückt,
  1455. #   META       falls mit Alternate-Taste gedrückt.
  1456.  
  1457. #if (defined(UNIX) && !defined(NEXTAPP)) || defined(RISCOS)
  1458.   # Zusätzliche Komponenten:
  1459.   #define strm_keyboard_isatty  strm_isatty   # Flag, ob stdin ein Terminal ist
  1460.   #define strm_keyboard_handle  strm_ihandle  # Handle für listen_handle()
  1461.   #define strm_keyboard_buffer  strm_other[2] # Liste der noch zu liefernden Zeichen
  1462.   #define strm_keyboard_keytab  strm_other[3] # Liste aller Tastenzuordnungen
  1463.                                               # jeweils (char1 ... charn . result)
  1464.   #define strm_keyboard_len  4
  1465. #else
  1466.   # Keine zusätzlichen Komponenten.
  1467.   #define strm_keyboard_len  0
  1468. #endif
  1469.  
  1470. #if defined(MSDOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  1471.  
  1472. #ifdef WINDOWS
  1473.  
  1474. # Tastaturabfrage im Haupt-Fenster
  1475. #define kbhit  win_main_kbhit
  1476. #define getch  win_main_getch
  1477.  
  1478. #elif defined(WIN32_UNIX) || defined(WIN32_DOS)
  1479.  
  1480.   local boolean win32_kbhit (void);
  1481.   local boolean win32_kbhit()
  1482.     {
  1483.       DWORD lpcRead;
  1484.       INPUT_RECORD irec;
  1485.       BOOL success;
  1486.  
  1487.       begin_system_call();
  1488.       success = PeekConsoleInput(GetStdHandle(STD_INPUT_HANDLE),&irec,1,&lpcRead); 
  1489.       #if 0
  1490.       if (success == FALSE)
  1491.         { asciz_out("win32_kbhit PeekConsoleInput failed with error: ");
  1492.           dez_out(GetLastError());
  1493.           asciz_out("\n");
  1494.           abort();
  1495.         }
  1496.       #endif
  1497.       end_system_call();
  1498.       return (success == TRUE && lpcRead == 1 && irec.EventType == KEY_EVENT);
  1499.     }
  1500.  
  1501.   local uintW win32_getch (void);
  1502.   local uintW win32_getch()
  1503.     {
  1504.       var DWORD lpcRead;
  1505.       var char buf[2];
  1506.       var BOOL success;
  1507.  
  1508.       begin_system_call();
  1509.       success = ReadConsole(GetStdHandle(STD_INPUT_HANDLE),&buf,1,&lpcRead,NULL);
  1510.       end_system_call();
  1511.       if (success == FALSE)
  1512.         { asciz_out("win32_getch ReadConsole failed with error: ");
  1513.           dez_out(GetLastError());
  1514.           asciz_out("\n");
  1515.           abort();
  1516.         }
  1517.       return buf[0];
  1518.     }  
  1519.  
  1520. #define kbhit win32_kbhit
  1521. #define getch win32_getch
  1522.  
  1523. #else # !(defined(WINDOWS) || defined(WIN32_UNIX) || defined(WIN32_DOS))
  1524.  
  1525. # Für Tastaturabfrage unter DOS:
  1526. #
  1527. # INT 16 documentation:
  1528. #   INT 16,00 - Wait for keystroke and read
  1529. #   INT 16,01 - Get keystroke status
  1530. #   INT 16,02 - Get shift status
  1531. #   INT 16,03 - Set keyboard typematic rate (AT+)
  1532. #   INT 16,04 - Keyboard click adjustment (AT+)
  1533. #   INT 16,05 - Keyboard buffer write  (AT,PS/2 enhanced keyboards)
  1534. #   INT 16,10 - Wait for keystroke and read  (AT,PS/2 enhanced keyboards)
  1535. #   INT 16,11 - Get keystroke status  (AT,PS/2 enhanced keyboards)
  1536. #   INT 16,12 - Get shift status  (AT,PS/2 enhanced keyboards)
  1537. #
  1538. # INT 16,00 - Wait for Keypress and Read Character
  1539. #     AH = 00
  1540. #     on return:
  1541. #     AH = keyboard scan code
  1542. #     AL = ASCII character or zero if special function key
  1543. #     - halts program until key with a scancode is pressed
  1544. #     - see  SCAN CODES
  1545. #
  1546. # INT 16,01 - Get Keyboard Status
  1547. #     AH = 01
  1548. #     on return:
  1549. #     ZF = 0 if a key pressed (even Ctrl-Break)
  1550. #     AX = 0 if no scan code is available
  1551. #     AH = scan code
  1552. #     AL = ASCII character or zero if special function key
  1553. #     - data code is not removed from buffer
  1554. #     - Ctrl-Break places a zero word in the keyboard buffer but does
  1555. #       register a keypress.
  1556. #
  1557. # INT 16,10 - Extended Wait for Keypress and Read Character  (AT+)
  1558. #     AH = 10h
  1559. #     on return:
  1560. #     AH = scan code
  1561. #     AL = ASCII character or zero if special function key
  1562. #     - available on AT and PS/2 machines with extended keyboard support
  1563. #     - similar to INT 16,00
  1564. #
  1565. # INT 16,11 - Extended Get Keyboard Status  (AT+)
  1566. #       AH = 11h
  1567. #       on return:
  1568. #       ZF = 0 if key pressed (data waiting)
  1569. #       AX = 0 if no scan code is available
  1570. #       AH = scan code
  1571. #       AL = ASCII character or zero if special function key
  1572. #       - available on AT and PS/2 machines with extended keyboard support
  1573. #       - data is not removed from buffer
  1574. #       - similar to INT 16,01
  1575. #
  1576.  
  1577. #if defined(DJUNIX) || defined(WATCOM)
  1578.  
  1579.   # Liefert den nächsten Tastendruck incl. Scan-Code:
  1580.   # high byte = Scan-Code oder 0, low byte = Ascii-Code oder 0 oder 0xE0.
  1581.   local boolean kbhit()
  1582.     { var union REGS in;
  1583.       var union REGS out;
  1584.       in.regB.ah = 0x11;
  1585.       int86(0x16,&in,&out);
  1586.       return ((out.reg_flags & 0x40) == 0); # Zero-Flag abfragen
  1587.     }
  1588.   local uintW getch()
  1589.     { var union REGS in;
  1590.       var union REGS out;
  1591.       in.regB.ah = 0x10;
  1592.       int86(0x16,&in,&out);
  1593.       return out.regW.ax;
  1594.     }
  1595.  
  1596. #endif
  1597.  
  1598. #ifdef EMUNIX
  1599.  
  1600.   # Unter DOS:
  1601.   #   Bis emx 0.8e ist uns der INT 16,10 offenbar versperrt.
  1602.   #   Wir bekommen keine Extended-Keystrokes, können aber immerhin die Return-
  1603.   #   von der Enter-Taste unterscheiden.
  1604.   # Unter OS/2:
  1605.   #   INT 16 funktioniert nicht, dafür geht _read_kbd() präziser als unter DOS.
  1606.  
  1607.   # Liefert unter DOS den nächsten Tastendruck incl. Scan-Code:
  1608.   # high byte = Scan-Code oder 0, low byte = Ascii-Code oder 0 oder 0xE0.
  1609.   #ifdef EMUNIX_OLD_8e
  1610.     #define int16_wait "0x00"
  1611.     #define int16_stat "0x01"
  1612.   #else # EMUNIX_NEW_8f
  1613.     #define int16_wait "0x10"
  1614.     #define int16_stat "0x11"
  1615.   #endif
  1616.   local boolean kbhit()
  1617.     { var reg1 boolean result;
  1618.       __asm__ __volatile__ ("movb $"int16_stat",%%ah ; .byte 0xcd ; .byte 0x16 ; "
  1619.                             "movl $0,%%eax ; jz 1f ; incl %%eax ; 1: "
  1620.                             : "=a" /* %eax */ (result) /* OUT */
  1621.                             :                          /* IN */
  1622.                             : "bx","cx","dx","si","di" /* %ebx,%ecx,%edx,%esi,%edi */ /* CLOBBER */
  1623.                            );
  1624.       return result;
  1625.     }
  1626.   local uintW getch()
  1627.     { var reg1 uintW ch;
  1628.       __asm__ __volatile__ ("movb $"int16_wait",%%ah ; .byte 0xcd ; .byte 0x16"
  1629.                             : "=a" /* %ax */ (ch)      /* OUT */
  1630.                             :                          /* IN */
  1631.                             : "bx","cx","dx","si","di" /* %ebx,%ecx,%edx,%esi,%edi */ /* CLOBBER */
  1632.                            );
  1633.       return ch;
  1634.     }
  1635.  
  1636. #endif
  1637.  
  1638.   # Tabelle der Characters, die den Scan-Codes 0..166 (als Sondertasten)
  1639.   # entsprechen:
  1640.   local cint scancode_table [167] =
  1641.     { 0,
  1642.       ESC | char_meta_c, # 1 -> Alt-Escape
  1643.       '1' | char_control_c, # [2 = Ctrl-1 -> #\CONTROL-1]
  1644.       '2' | char_control_c, # 3 = Ctrl-2 -> #\CONTROL-2
  1645.       '3' | char_control_c, # [4 = Ctrl-3 -> #\CONTROL-3]
  1646.       '4' | char_control_c, # [5 = Ctrl-4 -> #\CONTROL-4]
  1647.       '5' | char_control_c, # [6 = Ctrl-5 -> #\CONTROL-5]
  1648.       '6' | char_control_c, # 7 = Ctrl-6 -> #\CONTROL-6
  1649.       '7' | char_control_c, # [8 = Ctrl-7 -> #\CONTROL-7]
  1650.       '8' | char_control_c, # [9 = Ctrl-8 -> #\CONTROL-8]
  1651.       '9' | char_control_c, # [10 = Ctrl-9 -> #\CONTROL-9]
  1652.       '0' | char_control_c, # [11 = Ctrl-0 -> #\CONTROL-0]
  1653.       '-' | char_meta_c, # [12 = Ctrl-- -> #\CONTROL-- # nicht international portabel]
  1654.       '=' | char_meta_c, # [13 = Ctrl-= -> #\CONTROL-= # nicht international portabel]
  1655.        BS | char_meta_c, # 14 -> Alt-Backspace
  1656.         9 | char_super_c, # 15 -> Shift-Tab
  1657.       'Q' | char_meta_c, # 16 -> Alt-Q
  1658.       'W' | char_meta_c, # 17 -> Alt-W
  1659.       'E' | char_meta_c, # 18 -> Alt-E
  1660.       'R' | char_meta_c, # 19 -> Alt-R
  1661.       'T' | char_meta_c, # 20 -> Alt-T
  1662.       'Y' | char_meta_c, # 21 -> Alt-Y
  1663.       'U' | char_meta_c, # 22 -> Alt-U
  1664.       'I' | char_meta_c, # 23 -> Alt-I
  1665.       'O' | char_meta_c, # 24 -> Alt-O
  1666.       'P' | char_meta_c, # 25 -> Alt-P
  1667.       '[' | char_meta_c, # 26 -> Alt-[ # nicht international portabel
  1668.       ']' | char_meta_c, # 27 -> Alt-] # nicht international portabel
  1669.        CR | char_meta_c, # 28 = Alt-Return -> #\META-Return
  1670.       0,
  1671.       'A' | char_meta_c, # 30 -> Alt-A
  1672.       'S' | char_meta_c, # 31 -> Alt-S
  1673.       'D' | char_meta_c, # 32 -> Alt-D
  1674.       'F' | char_meta_c, # 33 -> Alt-F
  1675.       'G' | char_meta_c, # 34 -> Alt-G
  1676.       'H' | char_meta_c, # 35 -> Alt-H
  1677.       'J' | char_meta_c, # 36 -> Alt-J
  1678.       'K' | char_meta_c, # 37 -> Alt-K
  1679.       'L' | char_meta_c, # 38 -> Alt-L oder Alt-\ ??
  1680.       ';' | char_meta_c, # 39 -> Alt-; # nicht international portabel
  1681.       '\''| char_meta_c, # 40 -> Alt-' # nicht international portabel
  1682.       '`' | char_meta_c, # 41 -> Alt-` # nicht international portabel
  1683.       0,
  1684.       '\\'| char_meta_c, # 43 -> Alt-\ # nicht international portabel
  1685.       'Z' | char_meta_c, # 44 -> Alt-Z
  1686.       'X' | char_meta_c, # 45 -> Alt-X
  1687.       'C' | char_meta_c, # 46 -> Alt-C
  1688.       'V' | char_meta_c, # 47 -> Alt-V
  1689.       'B' | char_meta_c, # 48 -> Alt-B
  1690.       'N' | char_meta_c, # 49 -> Alt-N
  1691.       'M' | char_meta_c, # 50 -> Alt-M
  1692.       ',' | char_meta_c, # 51 = Alt-, -> #\META-',' # nicht international portabel
  1693.       '.' | char_meta_c, # 52 = Alt-. -> #\META-'.' # nicht international portabel
  1694.       '/' | char_meta_c, # 53 = Alt-/ -> #\META-'/' # nicht international portabel
  1695.       0,
  1696.       '*' | char_meta_c | char_hyper_c, # 55 = Alt-* -> #\META-HYPER-'*'
  1697.       0,
  1698.       ' ' | char_meta_c, # 57 = Alt-Space -> #\META-Space
  1699.       0,
  1700.       'A' | char_hyper_c, #  59 = F1 -> #\F1 = #\HYPER-A
  1701.       'B' | char_hyper_c, #  60 = F2 -> #\F2 = #\HYPER-B
  1702.       'C' | char_hyper_c, #  61 = F3 -> #\F3 = #\HYPER-C
  1703.       'D' | char_hyper_c, #  62 = F4 -> #\F4 = #\HYPER-D
  1704.       'E' | char_hyper_c, #  63 = F5 -> #\F5 = #\HYPER-E
  1705.       'F' | char_hyper_c, #  64 = F6 -> #\F6 = #\HYPER-F
  1706.       'G' | char_hyper_c, #  65 = F7 -> #\F7 = #\HYPER-G
  1707.       'H' | char_hyper_c, #  66 = F8 -> #\F8 = #\HYPER-H
  1708.       'I' | char_hyper_c, #  67 = F9 -> #\F9 = #\HYPER-I
  1709.       'J' | char_hyper_c, #  68 = F10 -> #\F10 = #\HYPER-J
  1710.       'K' | char_hyper_c, # [69 = F11 -> #\F11 = #\HYPER-K]
  1711.       'L' | char_hyper_c, # [70 = F12 -> #\F12 = #\HYPER-L]
  1712.        23 | char_hyper_c, #  71 = Home -> #\Home = #\HYPER-Code23
  1713.        24 | char_hyper_c, #  72 = Up -> #\Up = #\HYPER-Code24
  1714.        25 | char_hyper_c, #  73 = PgUp -> #\PgUp = #\HYPER-Code25
  1715.       '-' | char_meta_c | char_hyper_c, #  74 = Alt-- -> #\META-HYPER--
  1716.        20 | char_hyper_c, #  75 = Left -> #\Left = #\HYPER-Code20
  1717.        21 | char_hyper_c, # [76 -> #\HYPER-Code21]
  1718.        22 | char_hyper_c, #  77 = Right -> #\Right = #\HYPER-Code22
  1719.       '+' | char_meta_c | char_hyper_c, #  78 = Alt-+ -> #\META-HYPER-+
  1720.        17 | char_hyper_c, #  79 = End -> #\End = #\HYPER-Code17
  1721.        18 | char_hyper_c, #  80 = Down -> #\Down = #\HYPER-Code18
  1722.        19 | char_hyper_c, #  81 = PgDn -> #\PgDn = #\HYPER-Code19
  1723.        16 | char_hyper_c, #  82 = Insert -> #\Insert = #\HYPER-Code16
  1724.       127 | char_hyper_c, #  83 = Delete -> #\Delete = #\HYPER-Code127
  1725.       'A' | char_super_c | char_hyper_c, #  84 = Shift-F1 -> #\S-F1 = #\SUPER-HYPER-A
  1726.       'B' | char_super_c | char_hyper_c, #  85 = Shift-F2 -> #\S-F2 = #\SUPER-HYPER-B
  1727.       'C' | char_super_c | char_hyper_c, #  86 = Shift-F3 -> #\S-F3 = #\SUPER-HYPER-C
  1728.       'D' | char_super_c | char_hyper_c, #  87 = Shift-F4 -> #\S-F4 = #\SUPER-HYPER-D
  1729.       'E' | char_super_c | char_hyper_c, #  88 = Shift-F5 -> #\S-F5 = #\SUPER-HYPER-E
  1730.       'F' | char_super_c | char_hyper_c, #  89 = Shift-F6 -> #\S-F6 = #\SUPER-HYPER-F
  1731.       'G' | char_super_c | char_hyper_c, #  90 = Shift-F7 -> #\S-F7 = #\SUPER-HYPER-G
  1732.       'H' | char_super_c | char_hyper_c, #  91 = Shift-F8 -> #\S-F8 = #\SUPER-HYPER-H
  1733.       'I' | char_super_c | char_hyper_c, #  92 = Shift-F9 -> #\S-F9 = #\SUPER-HYPER-I
  1734.       'J' | char_super_c | char_hyper_c, #  93 = Shift-F10 -> #\S-F10 = #\SUPER-HYPER-J
  1735.       'A' | char_control_c | char_hyper_c, #  94 = Control-F1 -> #\C-F1 = #\CONTROL-HYPER-A
  1736.       'B' | char_control_c | char_hyper_c, #  95 = Control-F2 -> #\C-F2 = #\CONTROL-HYPER-B
  1737.       'C' | char_control_c | char_hyper_c, #  96 = Control-F3 -> #\C-F3 = #\CONTROL-HYPER-C
  1738.       'D' | char_control_c | char_hyper_c, #  97 = Control-F4 -> #\C-F4 = #\CONTROL-HYPER-D
  1739.       'E' | char_control_c | char_hyper_c, #  98 = Control-F5 -> #\C-F5 = #\CONTROL-HYPER-E
  1740.       'F' | char_control_c | char_hyper_c, #  99 = Control-F6 -> #\C-F6 = #\CONTROL-HYPER-F
  1741.       'G' | char_control_c | char_hyper_c, #  100 = Control-F7 -> #\C-F7 = #\CONTROL-HYPER-G
  1742.       'H' | char_control_c | char_hyper_c, #  101 = Control-F8 -> #\C-F8 = #\CONTROL-HYPER-H
  1743.       'I' | char_control_c | char_hyper_c, #  102 = Control-F9 -> #\C-F9 = #\CONTROL-HYPER-I
  1744.       'J' | char_control_c | char_hyper_c, #  103 = Control-F10 -> #\C-F10 = #\CONTROL-HYPER-J
  1745.       'A' | char_meta_c | char_hyper_c, #  104 = Alt-F1 -> #\M-F1 = #\META-HYPER-A
  1746.       'B' | char_meta_c | char_hyper_c, #  105 = Alt-F2 -> #\M-F2 = #\META-HYPER-B
  1747.       'C' | char_meta_c | char_hyper_c, #  106 = Alt-F3 -> #\M-F3 = #\META-HYPER-C
  1748.       'D' | char_meta_c | char_hyper_c, #  107 = Alt-F4 -> #\M-F4 = #\META-HYPER-D
  1749.       'E' | char_meta_c | char_hyper_c, #  108 = Alt-F5 -> #\M-F5 = #\META-HYPER-E
  1750.       'F' | char_meta_c | char_hyper_c, #  109 = Alt-F6 -> #\M-F6 = #\META-HYPER-F
  1751.       'G' | char_meta_c | char_hyper_c, #  110 = Alt-F7 -> #\M-F7 = #\META-HYPER-G
  1752.       'H' | char_meta_c | char_hyper_c, #  111 = Alt-F8 -> #\M-F8 = #\META-HYPER-H
  1753.       'I' | char_meta_c | char_hyper_c, #  112 = Alt-F9 -> #\M-F9 = #\META-HYPER-I
  1754.       'J' | char_meta_c | char_hyper_c, #  113 = Alt-F10 -> #\M-F10 = #\META-HYPER-J
  1755.        29 | char_control_c | char_hyper_c, # 114 = Control-PrtScr -> #\CONTROL-HYPER-Code29
  1756.        20 | char_control_c | char_hyper_c, # 115 = Control-Left -> #\C-Left = #\CONTROL-HYPER-Code20
  1757.        22 | char_control_c | char_hyper_c, # 116 = Control-Right -> #\C-Right = #\CONTROL-HYPER-Code22
  1758.        17 | char_control_c | char_hyper_c, # 117 = Control-End -> #\C-End = #\CONTROL-HYPER-Code17
  1759.        19 | char_control_c | char_hyper_c, # 118 = Control-PgDn -> #\C-PgDn = #\CONTROL-HYPER-Code19
  1760.        23 | char_control_c | char_hyper_c, # 119 = Control-Home -> #\C-Home = #\CONTROL-HYPER-Code23
  1761.       '1' | char_meta_c, #  120 = Alt-1 -> #\META-1
  1762.       '2' | char_meta_c, #  121 = Alt-2 -> #\META-2
  1763.       '3' | char_meta_c, #  122 = Alt-3 -> #\META-3
  1764.       '4' | char_meta_c, #  123 = Alt-4 -> #\META-4
  1765.       '5' | char_meta_c, #  124 = Alt-5 -> #\META-5
  1766.       '6' | char_meta_c, #  125 = Alt-6 -> #\META-6
  1767.       '7' | char_meta_c, #  126 = Alt-7 -> #\META-7
  1768.       '8' | char_meta_c, #  127 = Alt-8 -> #\META-8
  1769.       '9' | char_meta_c, #  128 = Alt-9 -> #\META-9
  1770.       '0' | char_meta_c, #  129 = Alt-0 -> #\META-0
  1771.       '-' | char_meta_c, #  130 = Alt-- -> #\META-- # nicht international portabel
  1772.       '=' | char_meta_c, #  131 = Alt-= -> #\META-= # nicht international portabel
  1773.        25 | char_control_c | char_hyper_c, # 132 = Control-PgUp -> #\C-PgUp = #\CONTROL-HYPER-Code25
  1774.       'K' | char_hyper_c, #  133 = F11 -> #\F11 = #\HYPER-K
  1775.       'L' | char_hyper_c, #  134 = F12 -> #\F12 = #\HYPER-L
  1776.       'K' | char_super_c | char_hyper_c, #  135 = Shift-F11 -> #\S-F11 = #\SUPER-HYPER-K
  1777.       'L' | char_super_c | char_hyper_c, #  136 = Shift-F12 -> #\S-F12 = #\SUPER-HYPER-L
  1778.       'K' | char_control_c | char_hyper_c, #  137 = Control-F11 -> #\C-F11 = #\CONTROL-HYPER-K
  1779.       'L' | char_control_c | char_hyper_c, #  138 = Control-F12 -> #\C-F12 = #\CONTROL-HYPER-L
  1780.       'K' | char_meta_c | char_hyper_c, #  139 = Alt-F1 -> #\M-F11 = #\META-HYPER-K
  1781.       'L' | char_meta_c | char_hyper_c, #  140 = Alt-F2 -> #\M-F12 = #\META-HYPER-L
  1782.        24 | char_control_c | char_hyper_c, # 141 = Control-Up -> #\C-Up = #\CONTROL-HYPER-Code24
  1783.       '-' | char_control_c | char_hyper_c, # 142 = Control-- -> #\CONTROL-HYPER--
  1784.        21 | char_control_c | char_hyper_c, # 143 = Control-Keypad5 -> #\CONTROL-HYPER-Code21
  1785.       '+' | char_control_c | char_hyper_c, # 142 = Control-+ -> #\CONTROL-HYPER-+
  1786.        18 | char_control_c | char_hyper_c, # 145 = Control-Down -> #\C-Down = #\CONTROL-HYPER-Code18
  1787.        16 | char_control_c | char_hyper_c, # 146 = Control-Insert -> #\C-Insert = #\CONTROL-HYPER-Code16
  1788.       127 | char_control_c | char_hyper_c, # 147 = Control-Delete -> #\CONTROL-HYPER-Delete
  1789.         9 | char_control_c, # 148 = Control-Tab -> #\CONTROL-Tab
  1790.       '/' | char_control_c | char_hyper_c, # 149 = Control-/ -> #\CONTROL-HYPER-'/'
  1791.       '*' | char_control_c | char_hyper_c, # 150 = Control-* -> #\CONTROL-HYPER-'*'
  1792.        23 | char_meta_c | char_hyper_c, # 151 = Alt-Home -> #\M-Home = #\META-HYPER-Code23
  1793.        24 | char_meta_c | char_hyper_c, # 152 = Alt-Up -> #\M-Up = #\META-HYPER-Code24
  1794.        25 | char_meta_c | char_hyper_c, # 153 = Alt-PgUp -> #\M-PgUp = #\META-HYPER-Code25
  1795.       0,
  1796.        20 | char_meta_c | char_hyper_c, # 155 = Alt-Left -> #\M-Left = #\META-HYPER-Code20
  1797.        21 | char_meta_c | char_hyper_c, # [156 -> #\META-HYPER-Code21]
  1798.        22 | char_meta_c | char_hyper_c, # 157 = Alt-Right -> #\M-Right = #\META-HYPER-Code22
  1799.       0,
  1800.        17 | char_meta_c | char_hyper_c, # 159 = Alt-End -> #\M-End = #\META-HYPER-Code17
  1801.        18 | char_meta_c | char_hyper_c, # 160 = Alt-Down -> #\M-Down = #\META-HYPER-Code18
  1802.        19 | char_meta_c | char_hyper_c, # 161 = Alt-PgDn -> #\M-PgDn = #\META-HYPER-Code19
  1803.        16 | char_meta_c | char_hyper_c, # 162 = Alt-Insert -> #\M-Insert = #\META-HYPER-Code16
  1804.       127 | char_meta_c | char_hyper_c, # 163 = Alt-Delete -> #\META-HYPER-Delete
  1805.       '/' | char_meta_c | char_hyper_c, # 164 = Alt-/ -> #\META-HYPER-'/'
  1806.         9 | char_meta_c, # 165 = Alt-Tab -> #\META-Tab
  1807.        CR | char_meta_c | char_hyper_c, # 166 = Alt-Enter -> #\META-HYPER-Return
  1808.     };
  1809.  
  1810. #ifdef EMUNIX_PORTABEL
  1811.  
  1812. # Wir haben, um portabel zu bleiben, nur die Funktion _read_kbd zur Verfügung.
  1813. # Diese erkennt unter DOS aber nur recht wenige Sondertasten: nur die mit
  1814. # Scan-Codes 3, 7, 15-25, 30-38, 44-50, 59-131 (ungefähr).
  1815. # Insbesondere fehlen F11, F12, Ctrl-Up, Ctrl-Down, und man kann
  1816. # Enter von Return, Tab von Ctrl-I, Backspace von Ctrl-H nicht unterscheiden.
  1817. # Trotzdem!
  1818. #ifdef EMUNIX_NEW_8f
  1819. # Da INT 16,10 unter DOS nun endlich befriedigend funktioniert, verwenden wir
  1820. # dieses. Zur Laufzeit wird _osmode abgefragt.
  1821. #endif
  1822.  
  1823. #endif # EMUNIX_PORTABEL
  1824.  
  1825. #endif # !(WINDOWS || WIN32_UNIX || WIN32_DOS)
  1826.  
  1827. #endif # MSDOS || WIN32_UNIX || WIN32_DOS
  1828.  
  1829. # Stellt fest, ob der Keyboard-Stream ein Zeichen verfügbar hat.
  1830. # listen_keyboard(stream)
  1831. # > stream: Stream
  1832. # < ergebnis:  0 falls Zeichen verfügbar,
  1833. #             -1 falls bei EOF angelangt,
  1834. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  1835.   local signean listen_keyboard (object stream);
  1836.   #if defined(MSDOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  1837.     local signean listen_keyboard(stream)
  1838.       var reg1 object stream;
  1839.       {
  1840.         #ifdef EMUNIX_PORTABEL
  1841.         if (!(_osmode == DOS_MODE))
  1842.           # OS/2
  1843.           { var reg2 int ch = _read_kbd(FALSE,FALSE,FALSE);
  1844.             if (ch < 0) { return signean_plus; } # nein
  1845.            {var reg2 cint c =
  1846.               (ch==0 ? scancode_table[(uintB)_read_kbd(FALSE,TRUE,FALSE)]
  1847.                      : (ch <= 26) && !(ch == BS) && !(ch == CR) && !(ch == TAB)
  1848.                        ? # Ctrl-A bis Ctrl-Z -> Buchstabe mit CONTROL-Bit draus machen:
  1849.                          ((cint)(ch==LF ? CR : (ch | bit(6))) << char_code_shift_c) | char_control_c
  1850.                        : (cint)(uintB)ch << char_code_shift_c
  1851.               );
  1852.             /* asciz_out("{"); hex_out(ch); asciz_out("}"); _sleep2(500); */ # Test
  1853.             TheStream(stream)->strm_rd_ch_last = char_to_fixnum(int_char(c));
  1854.             return signean_null;
  1855.           }}
  1856.           else
  1857.         #endif
  1858.         # DOS
  1859.         if (kbhit()) # inzwischen wieder Tasten gedrückt?
  1860.           { return signean_null; } # ja
  1861.           else
  1862.           { return signean_plus; } # nein
  1863.       }
  1864.   #endif
  1865.   #if (defined(UNIX) && !defined(NEXTAPP)) || defined(RISCOS)
  1866.     #define listen_keyboard  listen_handle
  1867.   #endif
  1868.   #if defined(NEXTAPP)
  1869.     #define listen_keyboard(stream)  (stream, signean_minus)
  1870.   #endif
  1871.  
  1872. # UP: Löscht bereits eingegebenen interaktiven Input vom Keyboard-Stream.
  1873. # clear_input_keyboard(stream);
  1874. # > stream: Stream
  1875. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  1876.   local boolean clear_input_keyboard (object stream);
  1877.   local boolean clear_input_keyboard(stream)
  1878.     var reg1 object stream;
  1879.     {
  1880.       #if defined(MSDOS) || defined(WIN32_UNIX)
  1881.         #ifdef EMUNIX_PORTABEL
  1882.         if (!(_osmode == DOS_MODE))
  1883.           # OS/2
  1884.            { while (listen_keyboard(stream)) { /* das Zeichen wurde schon geholt! */ } }
  1885.           else
  1886.         #endif
  1887.         # DOS
  1888.         while (kbhit()) { getch(); }
  1889.       #endif
  1890.       #if (defined(UNIX) && !defined(NEXTAPP)) || defined(RISCOS)
  1891.         if (nullp(TheStream(stream)->strm_keyboard_isatty))
  1892.           # File -> nichts tun
  1893.           { return FALSE; }
  1894.         # Terminal
  1895.         TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen
  1896.         clear_tty_input(stdin_handle);
  1897.         pushSTACK(stream);
  1898.         while (listen_keyboard(STACK_0) == 0) { read_char(&STACK_0); }
  1899.         skipSTACK(1);
  1900.       #endif
  1901.       return TRUE;
  1902.     }
  1903.  
  1904. # Lesen eines Zeichens vom Keyboard:
  1905.   local object rd_ch_keyboard (object* stream_);
  1906.  
  1907.   #if defined(MSDOS) || defined(WIN32_UNIX)
  1908.   local object rd_ch_keyboard(stream_)
  1909.     var reg7 object* stream_;
  1910.     {
  1911.       #ifdef EMUNIX_PORTABEL
  1912.       if (!(_osmode == DOS_MODE))
  1913.         # OS/2
  1914.         { run_time_stop(); # Run-Time-Stoppuhr anhalten
  1915.          {var reg1 int ch = _read_kbd(FALSE,TRUE,FALSE);
  1916.           var reg2 cint c =
  1917.             (ch==0 ? scancode_table[(uintB)_read_kbd(FALSE,TRUE,FALSE)]
  1918.                    : (ch <= 26) && !(ch == BS) && !(ch == CR) && !(ch == TAB)
  1919.                      ? # Ctrl-A bis Ctrl-Z -> Buchstabe mit CONTROL-Bit draus machen:
  1920.                        ((cint)(ch==LF ? CR : (ch | bit(6))) << char_code_shift_c) | char_control_c
  1921.                      : (cint)(uintB)ch << char_code_shift_c
  1922.             );
  1923.           # noch zu behandeln: ??
  1924.           # Ctrl-2 -> #\Control-2, Ctrl-6 -> #\Code30, Ctrl-ß -> #\Code28,
  1925.           # Ctrl-+ -> #\Code29, Ctrl-ü -> #\Code27 = #\Escape
  1926.           /* asciz_out("{"); hex_out(ch); asciz_out("}"); _sleep2(500); */ # Test
  1927.           run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  1928.           return int_char(c);
  1929.         }}
  1930.         else
  1931.       #endif
  1932.       # DOS
  1933.      {var reg6 object ch;
  1934.       run_time_stop(); # Run-Time-Stoppuhr anhalten
  1935.       { # Tastendruck abwarten, nichts ausgeben:
  1936.         var reg5 uintW erg = getch();
  1937.         #if defined(WINDOWS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  1938.         var reg1 cint c = erg;
  1939.         #else
  1940.         var reg4 uintB code = (uintB)erg; # Ascii-Code
  1941.         var reg3 uintB scancode = (uintB)(erg>>8); # Scan-Code
  1942.         var reg1 cint c = 0; # neues Character
  1943.         if (scancode == 0)
  1944.           # Multikey-Event, z.B. accent+space oder Alt xyz
  1945.           { c = (cint)code << char_code_shift_c; }
  1946.         else
  1947.           { if ((code == 0) || (code == 0xE0))
  1948.               # Sondertaste
  1949.               { c = (scancode < 167 ? scancode_table[scancode] : 0); }
  1950.               else
  1951.               { if (((scancode >= 71) && (scancode < 84)) || (scancode == 55)
  1952.                     || ((scancode == 0xE0) && (code >= 32))
  1953.                    )
  1954.                   # Ziffernblocktaste außer Enter (auch nicht F1 bis F12 !)
  1955.                   { c = ((cint)code << char_code_shift_c) | char_hyper_c; }
  1956.                 elif ((scancode == 14) || (scancode == 28)
  1957.                       || ((scancode == 0xE0) && (code < 32))
  1958.                      )
  1959.                   # Backspace-Taste, Return-Taste, Enter-Taste
  1960.                   { var reg5 uintB defaultcode = (scancode==14 ? BS : CR);
  1961.                     c = (cint)defaultcode << char_code_shift_c;
  1962.                     if (scancode == 0xE0) { c |= char_hyper_c; }
  1963.                     if (!(code == defaultcode)) { c |= char_control_c; }
  1964.                   }
  1965.                 else
  1966.                   { if ((code < 32) && ((scancode >= 16) && (scancode <= 53)))
  1967.                       # Ctrl-A bis Ctrl-Z -> Buchstabe mit CONTROL-Bit draus machen:
  1968.                       { c = ((cint)(code | bit(6)) << char_code_shift_c) | char_control_c; }
  1969.                     else
  1970.                       # normales Zeichen
  1971.                       { c = (cint)code << char_code_shift_c; }
  1972.           }   }   }
  1973.         # noch zu behandeln: ??
  1974.         # Ctrl-2          0300
  1975.         # Ctrl-6          071E
  1976.         # Ctrl-ß          0C1C
  1977.         # Ctrl--          0C1F
  1978.         #endif
  1979.         ch = int_char(c);
  1980.       }
  1981.       run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  1982.       return ch;
  1983.     }}
  1984.   #endif
  1985.  
  1986.   #if (defined(UNIX) && !defined(NEXTAPP)) || defined(RISCOS)
  1987.  
  1988.   # vgl. rd_ch_handle() :
  1989.   local object rd_ch_keyboard(stream_)
  1990.     var reg3 object* stream_;
  1991.     { restart_it:
  1992.      {var reg2 object stream = *stream_;
  1993.       if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF?
  1994.         { return eof_value; }
  1995.       # Noch etwas im Buffer?
  1996.       if (mconsp(TheStream(stream)->strm_keyboard_buffer))
  1997.         goto empty_buffer;
  1998.       # Ein Zeichen lesen:
  1999.       { var uintB c;
  2000.         read_next_char:
  2001.         {run_time_stop(); # Run-Time-Stoppuhr anhalten
  2002.          begin_system_call();
  2003.          {var reg1 int ergebnis = read(stdin_handle,&c,1); # Zeichen lesen versuchen
  2004.           end_system_call();
  2005.           run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  2006.           if (ergebnis<0)
  2007.             { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  2008.                 { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen
  2009.                   goto restart_it;
  2010.                 }
  2011.               OS_error();
  2012.             }
  2013.           if (ergebnis==0)
  2014.             # kein Zeichen verfügbar -> EOF erkennen
  2015.             { TheStream(stream)->strm_rd_ch_last = eof_value; return eof_value; }
  2016.         }}
  2017.         next_char_is_read:
  2018.         # Es verlängert den Buffer:
  2019.         {var reg4 object new_cons = allocate_cons();
  2020.          Car(new_cons) = code_char(c);
  2021.          stream = *stream_;
  2022.          {var reg1 object* last_ = &TheStream(stream)->strm_keyboard_buffer;
  2023.           while (mconsp(*last_)) { last_ = &Cdr(*last_); }
  2024.           *last_ = new_cons;
  2025.         }}
  2026.         # Ist der Buffer eine vollständige Zeichenfolge zu einer Taste,
  2027.         # so liefern wir diese Taste. Ist der Buffer ein echtes Anfangsstück
  2028.         # einer Zeichenfolge zu einer Taste, so warten wir noch ein wenig.
  2029.         # Ansonsten fangen wir an, den Buffer Zeichen für Zeichen zu leeren.
  2030.         { var reg4 object keytab = TheStream(stream)->strm_keyboard_keytab;
  2031.           while (consp(keytab))
  2032.             { var reg1 object L1 = Car(keytab);
  2033.               keytab = Cdr(keytab);
  2034.              {var reg1 object L2 = TheStream(stream)->strm_keyboard_buffer;
  2035.               while (consp(L1) && consp(L2) && eq(Car(L1),Car(L2)))
  2036.                 { L1 = Cdr(L1); L2 = Cdr(L2); }
  2037.               if (atomp(L2))
  2038.                 { if (atomp(L1))
  2039.                     # vollständige Zeichenfolge
  2040.                     { TheStream(stream)->strm_keyboard_buffer = NIL;
  2041.                       return L1;
  2042.         }   }}  }   }
  2043.         { var reg4 object keytab = TheStream(stream)->strm_keyboard_keytab;
  2044.           while (consp(keytab))
  2045.             { var reg1 object L1 = Car(keytab);
  2046.               keytab = Cdr(keytab);
  2047.              {var reg1 object L2 = TheStream(stream)->strm_keyboard_buffer;
  2048.               while (consp(L1) && consp(L2) && eq(Car(L1),Car(L2)))
  2049.                 { L1 = Cdr(L1); L2 = Cdr(L2); }
  2050.               if (atomp(L2))
  2051.                 # Da consp(L1), liegt ein Anfangsstück einer Zeichenfolge vor.
  2052.                 goto wait_for_another;
  2053.         }   }}
  2054.         goto empty_buffer;
  2055.         wait_for_another:
  2056.         #ifdef HAVE_SELECT
  2057.         { # Verwende select mit readfds = einelementige Menge {stdin_handle}
  2058.           # und timeout = kleines Zeitintervall.
  2059.           var fd_set handle_menge; # Menge von Handles := {stdin_handle}
  2060.           var struct timeval small_time; # Zeitintervall := 0
  2061.           FD_ZERO(&handle_menge); FD_SET(stdin_handle,&handle_menge);
  2062.           restart_select:
  2063.           small_time.tv_sec = 0; small_time.tv_usec = 1000000/10; # 1/10 sec
  2064.           run_time_stop(); # Run-Time-Stoppuhr anhalten
  2065.           begin_system_call();
  2066.          {var reg1 int ergebnis;
  2067.           ergebnis = select(FD_SETSIZE,&handle_menge,NULL,NULL,&small_time);
  2068.           end_system_call();
  2069.           run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  2070.           if (ergebnis<0)
  2071.             { if (errno==EINTR) goto restart_select;
  2072.               if (!(errno == EBADF)) { OS_error(); }
  2073.             }
  2074.             else
  2075.             { # ergebnis = Anzahl der Handles in handle_menge, bei denen read
  2076.               # sofort ein Ergebnis liefern würde.
  2077.               if (ergebnis==0)
  2078.                 goto empty_buffer; # kein Zeichen verfügbar
  2079.               # ergebnis=1 -> Zeichen verfügbar
  2080.         }}  }
  2081.         #else
  2082.         #if defined(UNIX_TERM_TERMIOS) || defined(UNIX_TERM_TERMIO)
  2083.         { # Verwende die Termio-Elemente VMIN und VTIME.
  2084.           #ifdef UNIX_TERM_TERMIOS
  2085.           var struct termios oldtermio;
  2086.           var struct termios newtermio;
  2087.           #else # UNIX_TERM_TERMIO
  2088.           var struct termio oldtermio;
  2089.           var struct termio newtermio;
  2090.           #endif
  2091.           run_time_stop(); # Run-Time-Stoppuhr anhalten
  2092.           begin_system_call();
  2093.           #ifdef UNIX_TERM_TERMIOS
  2094.           if (!( tcgetattr(stdin_handle,&oldtermio) ==0))
  2095.             { if (!(errno==ENOTTY)) { OS_error(); } }
  2096.           #else
  2097.           if (!( ioctl(stdin_handle,TCGETA,&oldtermio) ==0))
  2098.             { if (!(errno==ENOTTY)) { OS_error(); } }
  2099.           #endif
  2100.           # Wir gehen nun davon aus, daß oldtermio nun mit dem newtermio aus
  2101.           # term_raw() (s.u.) identisch ist. Das ist dann gewährleistet, wenn
  2102.           # 1. (SYS::TERMINAL-RAW T) aufgerufen wurde und
  2103.           # 2. stdin_handle und stdout_handle beide dasselbe Terminal sind. ??
  2104.           newtermio = oldtermio;
  2105.           newtermio.c_cc[VMIN] = 0;
  2106.           newtermio.c_cc[VTIME] = 1; # 1/10 Sekunde Timeout
  2107.           #ifdef UNIX_TERM_TERMIOS
  2108.           if (!( TCSETATTR(stdin_handle,TCSANOW,&newtermio) ==0))
  2109.             { if (!(errno==ENOTTY)) { OS_error(); } }
  2110.           #else
  2111.           if (!( ioctl(stdin_handle,TCSETA,&newtermio) ==0))
  2112.             { if (!(errno==ENOTTY)) { OS_error(); } }
  2113.           #endif
  2114.          {var reg1 int ergebnis = read(stdin_handle,&c,1); # Zeichen lesen versuchen, mit Timeout
  2115.           #ifdef UNIX_TERM_TERMIOS
  2116.           if (!( TCSETATTR(stdin_handle,TCSANOW,&oldtermio) ==0))
  2117.             { if (!(errno==ENOTTY)) { OS_error(); } }
  2118.           #else
  2119.           if (!( ioctl(stdin_handle,TCSETA,&oldtermio) ==0))
  2120.             { if (!(errno==ENOTTY)) { OS_error(); } }
  2121.           #endif
  2122.           end_system_call();
  2123.           run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  2124.           if (ergebnis<0)
  2125.             { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  2126.                 { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen
  2127.                   goto restart_it;
  2128.                 }
  2129.               OS_error();
  2130.             }
  2131.           if (ergebnis==0)
  2132.             goto empty_buffer; # kein Zeichen verfügbar
  2133.           goto next_char_is_read; # ergebnis=1 -> Zeichen verfügbar
  2134.         }}
  2135.         #else
  2136.         # Man könnte hier fcntl(stdin_handle,F_SETFL,...|FASYNC) verwenden
  2137.         # und auf Signal SIGIO warten. Allerdings funktioniert das auf so
  2138.         # wenigen Systemen (siehe Emacs), daß es sich wohl nicht lohnt.
  2139.         #endif
  2140.         #endif
  2141.         goto read_next_char;
  2142.       }
  2143.       # Buffer Zeichen für Zeichen liefern:
  2144.       empty_buffer:
  2145.       { var reg1 object l = TheStream(stream)->strm_keyboard_buffer;
  2146.         TheStream(stream)->strm_keyboard_buffer = Cdr(l);
  2147.        {var reg1 uintB c = char_code(Car(l));
  2148.         if ((c >= ' ') || (c == ESC) || (c == TAB) || (c == CR) || (c == BS))
  2149.           { return code_char(c); }
  2150.           else
  2151.           # Taste vermutlich mit Ctrl getippt
  2152.           { return int_char(((64 | c) << char_code_shift_c) | char_control_c); }
  2153.       }}
  2154.     }}
  2155.  
  2156.   # UP: Erweitert die Liste STACK_0 um eine Tastenzuordnung.
  2157.   # kann GC auslösen
  2158.     local void keybinding (char* cap, cint key);
  2159.     local void keybinding(cap,key)
  2160.       var reg4 char* cap;
  2161.       var reg3 cint key;
  2162.       { var reg1 uintB* ptr = (uintB*)cap;
  2163.         if (*ptr=='\0') return; # leere Tastenfolge vermeiden
  2164.         pushSTACK(allocate_cons());
  2165.         # Liste (char1 ... charn . key) bilden:
  2166.         {var reg2 uintC count = 0;
  2167.          do { pushSTACK(code_char(*ptr)); ptr++; count++; } until (*ptr=='\0');
  2168.          pushSTACK(int_char(key)); count++;
  2169.          funcall(L(liststern),count);
  2170.         }
  2171.         # und auf STACK_0 pushen:
  2172.         {var reg2 object l = popSTACK();
  2173.          Car(l) = value1; Cdr(l) = STACK_0; STACK_0 = l;
  2174.       } }
  2175.  
  2176.   #endif
  2177.  
  2178.   #ifdef NEXTAPP
  2179.     #define rd_ch_keyboard  rd_ch_dummy
  2180.   #endif
  2181.  
  2182. # Liefert einen Keyboard-Stream.
  2183. # make_keyboard_stream()
  2184. # kann GC auslösen
  2185.   local object make_keyboard_stream (void);
  2186.   local object make_keyboard_stream()
  2187.     {
  2188.      #if (defined(UNIX) && !defined(NEXTAPP)) || defined(RISCOS)
  2189.       # Tabelle aller Zuordnungen Zeichenfolge -> Taste bilden:
  2190.       pushSTACK(NIL);
  2191.       # Terminal-Typ abfragen:
  2192.       begin_system_call();
  2193.      {var reg3 char* s = getenv("TERM");
  2194.       if (s==NULL)
  2195.         { end_system_call(); }
  2196.         else
  2197.         { var char tbuf[4096]; # interner Buffer für die Termcap-Routinen
  2198.           if (!(tgetent(tbuf,s)==1))
  2199.             { end_system_call(); }
  2200.             else
  2201.             { var char tentry[4096]; # Buffer für von mir benötigte Capabilities und Pointer da hinein
  2202.               var char* tp = &tentry[0];
  2203.               var reg1 char* cap;
  2204.               end_system_call();
  2205.               # Backspace:
  2206.               begin_system_call(); cap = tgetstr("kb",&tp); end_system_call();
  2207.               if (cap) { keybinding(cap,BS); } # #\Backspace
  2208.               # Insert, Delete:
  2209.               begin_system_call(); cap = tgetstr("kI",&tp); end_system_call();
  2210.               if (cap) { keybinding(cap,16 | char_hyper_c); } # #\Insert
  2211.               begin_system_call(); cap = tgetstr("kD",&tp); end_system_call();
  2212.               if (cap) { keybinding(cap,127); } # #\Delete
  2213.               # Pfeiltasten:
  2214.               begin_system_call(); cap = tgetstr("ku",&tp); end_system_call();
  2215.               if (cap) { keybinding(cap,24 | char_hyper_c); } # #\Up
  2216.               if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'A') && (cap[3] == '\0'))
  2217.                 { keybinding(ESCstring"[A",24 | char_hyper_c); } # #\Up
  2218.               begin_system_call(); cap = tgetstr("kd",&tp); end_system_call();
  2219.               if (cap) { keybinding(cap,18 | char_hyper_c); } # #\Down
  2220.               if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'B') && (cap[3] == '\0'))
  2221.                 { keybinding(ESCstring"[B",18 | char_hyper_c); } # #\Down
  2222.               begin_system_call(); cap = tgetstr("kr",&tp); end_system_call();
  2223.               if (cap) { keybinding(cap,22 | char_hyper_c); } # #\Right
  2224.               if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'C') && (cap[3] == '\0'))
  2225.                 { keybinding(ESCstring"[C",22 | char_hyper_c); } # #\Right
  2226.               begin_system_call(); cap = tgetstr("kl",&tp); end_system_call();
  2227.               if (cap) { keybinding(cap,20 | char_hyper_c); } # #\Left
  2228.               if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'D') && (cap[3] == '\0'))
  2229.                 { keybinding(ESCstring"[D",20 | char_hyper_c); } # #\Left
  2230.               # sonstige Cursorblock-Tasten:
  2231.               begin_system_call(); cap = tgetstr("kh",&tp); end_system_call();
  2232.               if (cap) { keybinding(cap,23 | char_hyper_c); } # #\Home
  2233.               begin_system_call(); cap = tgetstr("K1",&tp); end_system_call();
  2234.               if (cap) { keybinding(cap,23 | char_hyper_c); } # #\Home
  2235.               begin_system_call(); cap = tgetstr("KH",&tp); end_system_call();
  2236.               if (cap) { keybinding(cap,17 | char_hyper_c); } # #\End
  2237.               begin_system_call(); cap = tgetstr("K4",&tp); end_system_call();
  2238.               if (cap) { keybinding(cap,17 | char_hyper_c); } # #\End
  2239.               begin_system_call(); cap = tgetstr("kP",&tp); end_system_call();
  2240.               if (cap) { keybinding(cap,25 | char_hyper_c); } # #\PgUp
  2241.               begin_system_call(); cap = tgetstr("K3",&tp); end_system_call();
  2242.               if (cap) { keybinding(cap,25 | char_hyper_c); } # #\PgUp
  2243.               begin_system_call(); cap = tgetstr("kN",&tp); end_system_call();
  2244.               if (cap) { keybinding(cap,19 | char_hyper_c); } # #\PgDn
  2245.               begin_system_call(); cap = tgetstr("K5",&tp); end_system_call();
  2246.               if (cap) { keybinding(cap,19 | char_hyper_c); } # #\PgDn
  2247.               begin_system_call(); cap = tgetstr("K2",&tp); end_system_call();
  2248.               if (cap) { keybinding(cap,21 | char_hyper_c); } # #\Center
  2249.               # Funktionstasten:
  2250.               { typedef struct { char* capname; cint key; } funkey;
  2251.                 local var funkey funkey_tab[] = {
  2252.                   { "k1", 'A' | char_hyper_c }, # #\F1
  2253.                   { "k2", 'B' | char_hyper_c }, # #\F2
  2254.                   { "k3", 'C' | char_hyper_c }, # #\F3
  2255.                   { "k4", 'D' | char_hyper_c }, # #\F4
  2256.                   { "k5", 'E' | char_hyper_c }, # #\F5
  2257.                   { "k6", 'F' | char_hyper_c }, # #\F6
  2258.                   { "k7", 'G' | char_hyper_c }, # #\F7
  2259.                   { "k8", 'H' | char_hyper_c }, # #\F8
  2260.                   { "k9", 'I' | char_hyper_c }, # #\F9
  2261.                   { "k0", 'J' | char_hyper_c }, # #\F10
  2262.                   { "k;", 'J' | char_hyper_c }, # #\F10
  2263.                   { "F1", 'K' | char_hyper_c }, # #\F11
  2264.                   { "F2", 'L' | char_hyper_c }, # #\F12
  2265.                   };
  2266.                 var reg2 uintL i;
  2267.                 for (i=0; i < sizeof(funkey_tab)/sizeof(funkey); i++)
  2268.                   { begin_system_call();
  2269.                     cap = tgetstr(funkey_tab[i].capname,&tp);
  2270.                     end_system_call();
  2271.                     if (cap) { keybinding(cap,funkey_tab[i].key); }
  2272.               }   }
  2273.               # Spezielle xterm-Behandlung:
  2274.               begin_system_call();
  2275.               cap = tgetstr("ku",&tp);
  2276.               if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'A') && (cap[3] == '\0')))
  2277.                 goto not_xterm;
  2278.               cap = tgetstr("kd",&tp);
  2279.               if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'B') && (cap[3] == '\0')))
  2280.                 goto not_xterm;
  2281.               cap = tgetstr("kr",&tp);
  2282.               if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'C') && (cap[3] == '\0')))
  2283.                 goto not_xterm;
  2284.               cap = tgetstr("kl",&tp);
  2285.               if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'D') && (cap[3] == '\0')))
  2286.                 goto not_xterm;
  2287.               if (!tgetflag("km"))
  2288.                 goto not_xterm;
  2289.               end_system_call();
  2290.               { # Insert, Delete:
  2291.                 keybinding(ESCstring"[2~",16 | char_hyper_c); # #\Insert
  2292.                 keybinding(ESCstring"[3~",127); # #\Delete
  2293.               }
  2294.               { # Application Keypad: ESC O M -> Return,
  2295.                 # ESC O k -> +, ESC O m -> -, ESC O j -> *, ESC O o -> /
  2296.                 # (ohne Hyper-Bit, da das zu Terminal-abhängig würde)
  2297.                 var char cap[4];
  2298.                 cap[0] = ESC; cap[1] = 'O'; cap[3] = '\0';
  2299.                {var reg1 uintB c;
  2300.                 for (c='E'; c<='z'; c++) { cap[2] = c; keybinding(&!cap,c-64); }
  2301.               }}
  2302.               begin_system_call();
  2303.               if (!(tgetnum("kn")==4))
  2304.                 goto not_xterm;
  2305.               end_system_call();
  2306.               xterm:
  2307.               { # Pfeiltasten s.o.
  2308.                 # sonstige Cursorblock-Tasten:
  2309.                 keybinding(ESCstring"[5~",25 | char_hyper_c); # #\PgUp
  2310.                 keybinding(ESCstring"[6~",19 | char_hyper_c); # #\PgDn
  2311.                 keybinding(ESCstring"[7~",23 | char_hyper_c); # #\Home
  2312.                 keybinding(ESCstring"[8~",17 | char_hyper_c); # #\End
  2313.                 # Funktionstasten:
  2314.                 keybinding(ESCstring"[11~",'A' | char_hyper_c); # #\F1
  2315.                 keybinding(ESCstring"[12~",'B' | char_hyper_c); # #\F2
  2316.                 keybinding(ESCstring"[13~",'C' | char_hyper_c); # #\F3
  2317.                 keybinding(ESCstring"[14~",'D' | char_hyper_c); # #\F4
  2318.                 keybinding(ESCstring"[15~",'E' | char_hyper_c); # #\F5
  2319.                 keybinding(ESCstring"[17~",'F' | char_hyper_c); # #\F6
  2320.                 keybinding(ESCstring"[18~",'G' | char_hyper_c); # #\F7
  2321.                 keybinding(ESCstring"[19~",'H' | char_hyper_c); # #\F8
  2322.                 keybinding(ESCstring"[20~",'I' | char_hyper_c); # #\F9
  2323.                 keybinding(ESCstring"[21~",'J' | char_hyper_c); # #\F10
  2324.                 keybinding(ESCstring"[23~",'K' | char_hyper_c); # #\F11
  2325.                 keybinding(ESCstring"[24~",'L' | char_hyper_c); # #\F12
  2326.               }
  2327.               not_xterm:
  2328.               end_system_call();
  2329.      }  }   }
  2330.      #endif
  2331.      {# neuen Stream allozieren:
  2332.       var reg2 object stream =
  2333.         allocate_stream(strmflags_rd_ch_B,strmtype_keyboard,strm_len+strm_keyboard_len);
  2334.         # Flags: nur READ-CHAR erlaubt
  2335.       # und füllen:
  2336.       var reg1 Stream s = TheStream(stream);
  2337.         s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  2338.         s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  2339.         s->strm_rd_ch = P(rd_ch_keyboard); # READ-CHAR-Pseudofunktion
  2340.         s->strm_rd_ch_last = NIL; # Lastchar := NIL
  2341.         s->strm_wr_ch = P(wr_ch_dummy); # WRITE-CHAR unmöglich
  2342.         s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  2343.         #ifdef STRM_WR_SS
  2344.         s->strm_wr_ss = P(wr_ss_dummy);
  2345.         #endif
  2346.         #if (defined(UNIX) && !defined(NEXTAPP)) || defined(RISCOS)
  2347.         # Flag isatty = (stdin_tty ? T : NIL) bestimmen:
  2348.         begin_system_call();
  2349.         s->strm_keyboard_isatty = (isatty(stdin_handle) ? T : NIL);
  2350.         end_system_call();
  2351.         s->strm_keyboard_handle = allocate_handle(stdin_handle);
  2352.         s->strm_keyboard_buffer = NIL;
  2353.         s->strm_keyboard_keytab = popSTACK();
  2354.         #endif
  2355.       return stream;
  2356.     }}
  2357.  
  2358. #endif # KEYBOARD
  2359.  
  2360.  
  2361. # Interaktiver Terminalstream
  2362. # ===========================
  2363.  
  2364. #if defined(GNU_READLINE) || defined(NEXTAPP)
  2365. # Vervollständigung von Lisp-Symbolen
  2366.   global char** lisp_completion (char* text, int start, int end);
  2367.   global char** lisp_completion(text,start,end)
  2368.     var reg7 char* text; # text[0..end-start-1] = the_line[start..end-1]
  2369.     var reg8 int start;
  2370.     var reg9 int end;
  2371.     { # (SYS::COMPLETION text start end) aufrufen:
  2372.       pushSTACK(asciz_to_string(text));
  2373.       pushSTACK(fixnum((uintL)start));
  2374.       pushSTACK(fixnum((uintL)end));
  2375.       funcall(S(completion),3);
  2376.       end_callback();
  2377.      {var reg4 object mlist = value1; # Liste der Möglichkeiten
  2378.       # Liste von Simple-Strings in mallozierten Array von mallozierten
  2379.       # Asciz-Strings umbauen:
  2380.       if (nullp(mlist)) { return NULL; }
  2381.       {var reg6 char** array = malloc((llength(mlist)+1)*sizeof(char*));
  2382.        if (array==NULL) { return NULL; }
  2383.        {var reg5 char** ptr = array;
  2384.         while (consp(mlist))
  2385.           { var reg3 uintC count = TheSstring(Car(mlist))->length;
  2386.             var reg2 uintB* ptr1 = &TheSstring(Car(mlist))->data[0];
  2387.             var reg1 char* ptr2 = malloc((count+1)*sizeof(char));
  2388.             if (ptr2==NULL) # malloc scheitert -> alles zurückgeben
  2389.               { until (ptr==array) { free(*--ptr); }
  2390.                 free(array);
  2391.                 return NULL;
  2392.               }
  2393.             *ptr++ = ptr2;
  2394.             dotimesC(count,count, { *ptr2++ = *ptr1++; });
  2395.             *ptr2 = '\0';
  2396.             mlist = Cdr(mlist);
  2397.           }
  2398.         *ptr = NULL;
  2399.        }
  2400.        return array;
  2401.     }}}
  2402. #endif
  2403.  
  2404. #ifdef WINDOWS
  2405.  
  2406. # Benutze die Eingabefunktionen aus wintext.d.
  2407. # Output:
  2408. extern void winterm_writechar (mywindow w, uintB c);
  2409. # Input:
  2410. extern signean winterm_listen (mywindow w);
  2411. extern boolean winterm_clear_input (mywindow w);
  2412. extern cint winterm_readchar (mywindow w);
  2413.  
  2414. # Stellt fest, ob ein Terminal-Stream ein Zeichen verfügbar hat.
  2415. # listen_terminal(stream)
  2416. # > stream: Terminal-Stream
  2417. # < ergebnis:  0 falls Zeichen verfügbar,
  2418. #             -1 falls bei EOF angelangt,
  2419. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  2420.   local signean listen_terminal (object stream);
  2421.   local signean listen_terminal(stream)
  2422.     var reg1 object stream;
  2423.     { return winterm_listen(main_window); }
  2424.  
  2425. # UP: Löscht bereits eingegebenen interaktiven Input von einem Terminal-Stream.
  2426. # clear_input_terminal(stream);
  2427. # > stream: Terminal-Stream
  2428. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  2429.   local boolean clear_input_terminal (object stream);
  2430.   local boolean clear_input_terminal(stream)
  2431.     var reg1 object stream;
  2432.     { return winterm_clear_input(main_window); }
  2433.  
  2434. # UP: Ein Zeichen auf einen Terminal-Stream ausgeben.
  2435. # wr_ch_terminal(&stream,ch);
  2436. # > stream: Terminal-Stream
  2437. # > ch: auszugebendes Zeichen
  2438.   local void wr_ch_terminal (object* stream_, object ch);
  2439.   local void wr_ch_terminal(stream_,ch)
  2440.     var reg2 object* stream_;
  2441.     var reg1 object ch;
  2442.     { var reg3 object stream = *stream_;
  2443.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # ch sollte String-Char sein
  2444.       winterm_writechar(main_window,char_code(ch));
  2445.     }
  2446.  
  2447. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  2448. # finish_output_terminal(stream);
  2449. # > stream: Terminal-Stream
  2450. # kann GC auslösen
  2451.   #define finish_output_terminal(stream)
  2452.  
  2453. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  2454. # force_output_terminal(stream);
  2455. # > stream: Terminal-Stream
  2456. # kann GC auslösen
  2457.   #define force_output_terminal(stream)
  2458.  
  2459. # UP: Ein Zeichen von einem Terminal-Stream lesen.
  2460. # rd_ch_terminal(&stream)
  2461. # > stream: Terminal-Stream
  2462. # < object ch: eingegebenes Zeichen
  2463.   local object rd_ch_terminal (object* stream_);
  2464.   local object rd_ch_terminal(stream_)
  2465.     var reg1 object* stream_;
  2466.     { return int_char(winterm_readchar(main_window)); }
  2467.  
  2468. # Liefert einen interaktiven Terminal-Stream.
  2469. # kann GC auslösen
  2470.   local object make_terminal_stream_ (void);
  2471.   local object make_terminal_stream_()
  2472.     { # neuen Stream allozieren:
  2473.       var reg2 object stream =
  2474.         allocate_stream(strmflags_ch_B,strmtype_terminal,strm_len+0);
  2475.         # Flags: nur READ-CHAR und WRITE-CHAR erlaubt
  2476.       # und füllen:
  2477.       var reg1 Stream s = TheStream(stream);
  2478.         s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  2479.         s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  2480.         s->strm_rd_ch = P(rd_ch_terminal); # READ-CHAR-Pseudofunktion
  2481.         s->strm_rd_ch_last = NIL; # Lastchar := NIL
  2482.         s->strm_wr_ch = P(wr_ch_terminal); # WRITE-CHAR-Pseudofunktion
  2483.         s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  2484.         #ifdef STRM_WR_SS
  2485.         s->strm_wr_ss = P(wr_ss_dummy);
  2486.         #endif
  2487.       return stream;
  2488.     }
  2489.  
  2490. #endif # WINDOWS
  2491.  
  2492. #ifdef WIN32_WINDOWS
  2493. # Stellt fest, ob ein Terminal-Stream ein Zeichen verfügbar hat.
  2494. # listen_terminal(stream)
  2495. # > stream: Terminal-Stream
  2496. # < ergebnis:  0 falls Zeichen verfügbar,
  2497. #             -1 falls bei EOF angelangt,
  2498. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  2499.   local signean listen_terminal (object stream);
  2500.   local signean listen_terminal(stream)
  2501.     var reg1 object stream;
  2502.     {
  2503.       INPUT_RECORD irec;
  2504.       DWORD lpcRead;
  2505.       BOOL success;
  2506.  
  2507.       begin_system_call();
  2508.       success = PeekConsoleInput(GetStdHandle(STD_INPUT_HANDLE),&irec,1,&lpcRead); 
  2509.       end_system_call();
  2510.       if (success == TRUE) 
  2511.         { if (lpcRead == 1 && irec.EventType == KEY_EVENT)
  2512.             { if (irec.Event.KeyEvent.AsciiChar == 26) return signean_minus;
  2513.               return signean_null;
  2514.             }
  2515.           return signean_plus;
  2516.         }
  2517.       return signean_minus;
  2518.     }
  2519.  
  2520. # UP: Löscht bereits eingegebenen interaktiven Input von einem Terminal-Stream.
  2521. # clear_input_terminal(stream);
  2522. # > stream: Terminal-Stream
  2523. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  2524.   local boolean clear_input_terminal (object stream);
  2525.   local boolean clear_input_terminal(stream)
  2526.     var reg1 object stream;
  2527.     { 
  2528.       var INPUT_RECORD irec;
  2529.       var DWORD lpcRead;
  2530.       var BOOL success;
  2531.       var char buf[2];
  2532.  
  2533.       begin_system_call();
  2534.       success = PeekConsoleInput(GetStdHandle(STD_INPUT_HANDLE),&irec,1,&lpcRead); 
  2535.       end_system_call();
  2536.       if (success == TRUE && lpcRead == 1 && irec.EventType == KEY_EVENT)
  2537.         { begin_system_call();
  2538.           success = ReadConsole(GetStdHandle(STD_INPUT_HANDLE),buf,1,&lpcRead,NULL);
  2539.           end_system_call();
  2540.           if (success == FALSE)
  2541.             { asciz_out("clear_input_terminal ReadConsole failed with error: ");
  2542.               dez_out(GetLastError());
  2543.               asciz_out("\n");
  2544.               abort();
  2545.             }
  2546.         }
  2547.       return TRUE;
  2548.     }
  2549.  
  2550. # UP: Ein Zeichen auf einen Terminal-Stream ausgeben.
  2551. # wr_ch_terminal(&stream,ch);
  2552. # > stream: Terminal-Stream
  2553. # > ch: auszugebendes Zeichen
  2554.   local void wr_ch_terminal (object* stream_, object ch);
  2555.   local void wr_ch_terminal(stream_,ch)
  2556.     var reg2 object* stream_;
  2557.     var reg1 object ch;
  2558.     { var reg3 object stream = *stream_;
  2559.       var char buf[2];
  2560.       var DWORD chWritten;
  2561.       var BOOL success;
  2562.  
  2563.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # ch sollte String-Char sein
  2564.       buf[0]=char_code(ch);
  2565.       buf[1]='\0';
  2566.       begin_system_call();
  2567.       success = WriteConsole(GetStdHandle(STD_OUTPUT_HANDLE),buf,1,&chWritten,NULL);
  2568.       end_system_call();
  2569.       if (success == FALSE)
  2570.         { asciz_out("wr_ch_terminal WriteConsole failed with error: ");
  2571.           dez_out(GetLastError());
  2572.           asciz_out("\n");
  2573.           abort();
  2574.         }
  2575.     }
  2576.  
  2577. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  2578. # finish_output_terminal(stream);
  2579. # > stream: Terminal-Stream
  2580. # kann GC auslösen
  2581.   #define finish_output_terminal(stream)
  2582.  
  2583. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  2584. # force_output_terminal(stream);
  2585. # > stream: Terminal-Stream
  2586. # kann GC auslösen
  2587.   #define force_output_terminal(stream)
  2588.  
  2589. # UP: Ein Zeichen von einem Terminal-Stream lesen.
  2590. # rd_ch_terminal(&stream)
  2591. # > stream: Terminal-Stream
  2592. # < object ch: eingegebenes Zeichen
  2593.   local object rd_ch_terminal (object* stream_);
  2594.   local object rd_ch_terminal(stream_)
  2595.     var reg1 object* stream_;
  2596.     { 
  2597.       var DWORD lpcRead;
  2598.       var BOOL success;
  2599.       var char buf[2];
  2600.  
  2601.       begin_system_call();
  2602.       success = ReadConsole(GetStdHandle(STD_INPUT_HANDLE),buf,1,&lpcRead,NULL);
  2603.       end_system_call();
  2604.       if (success == FALSE)
  2605.         { asciz_out("rd_ch_terminal ReadConsole failed with error: ");
  2606.           dez_out(GetLastError());
  2607.           asciz_out("\n");
  2608.           abort();
  2609.         }
  2610.       return buf[0]==26 ? eof_value : int_char(buf[0]);
  2611.     }
  2612.  
  2613. # Liefert einen interaktiven Terminal-Stream.
  2614. # kann GC auslösen
  2615.   local object make_terminal_stream_ (void);
  2616.   local object make_terminal_stream_()
  2617.     { # neuen Stream allozieren:
  2618.       var reg2 object stream =
  2619.         allocate_stream(strmflags_ch_B,strmtype_terminal,strm_len+0);
  2620.         # Flags: nur READ-CHAR und WRITE-CHAR erlaubt
  2621.       # und füllen:
  2622.       var reg1 Stream s = TheStream(stream);
  2623.         s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  2624.         s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  2625.         s->strm_rd_ch = P(rd_ch_terminal); # READ-CHAR-Pseudofunktion
  2626.         s->strm_rd_ch_last = NIL; # Lastchar := NIL
  2627.         s->strm_wr_ch = P(wr_ch_terminal); # WRITE-CHAR-Pseudofunktion
  2628.         s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  2629.         #ifdef STRM_WR_SS
  2630.         s->strm_wr_ss = P(wr_ss_dummy);
  2631.         #endif
  2632.       return stream;
  2633.     }
  2634.  
  2635. #endif
  2636.  
  2637. #ifdef NEXTAPP
  2638.  
  2639. # Benutze das von nxterminal.m zur Verfügung gestellte Interface, siehe unix.d.
  2640.  
  2641. # UP: Ein Zeichen von einem Terminal-Stream lesen.
  2642. # rd_ch_terminal(&stream)
  2643. # > stream: Terminal-Stream
  2644. # < object ch: eingegebenes Zeichen
  2645.   local object rd_ch_terminal (object* stream_);
  2646.   local object rd_ch_terminal(stream_)
  2647.     var reg1 object* stream_;
  2648.     { var int linepos;
  2649.       var reg2 uintB ch;
  2650.       begin_call();
  2651.       ch = nxterminal_read_char(&linepos);
  2652.       end_call();
  2653.       TheStream(*stream_)->strm_wr_ch_lpos = fixnum(linepos);
  2654.       return code_char(ch);
  2655.     }
  2656.  
  2657. # Stellt fest, ob ein Terminal-Stream ein Zeichen verfügbar hat.
  2658. # listen_terminal(stream)
  2659. # > stream: Terminal-Stream
  2660. # < ergebnis:  0 falls Zeichen verfügbar,
  2661. #             -1 falls bei EOF angelangt,
  2662. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  2663.   local signean listen_terminal (object stream);
  2664.   local signean listen_terminal(stream)
  2665.     var reg2 object stream;
  2666.     { var reg1 signean result;
  2667.       begin_call();
  2668.       result = (nxterminal_listen() ? signean_null : signean_plus);
  2669.       end_call();
  2670.       return result;
  2671.     }
  2672.  
  2673. # UP: Löscht bereits eingegebenen interaktiven Input von einem Terminal-Stream.
  2674. # clear_input_terminal(stream);
  2675. # > stream: Terminal-Stream
  2676. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  2677.   local boolean clear_input_terminal (object stream);
  2678.   local boolean clear_input_terminal(stream)
  2679.     var reg1 object stream;
  2680.     { # Wir wollen im Eingabefenster nichts löschen.
  2681.       return FALSE;
  2682.     }
  2683.  
  2684. # UP: Ein Zeichen auf einen Terminal-Stream ausgeben.
  2685. # wr_ch_terminal(&stream,ch);
  2686. # > stream: Terminal-Stream
  2687. # > ch: auszugebendes Zeichen
  2688.   local void wr_ch_terminal (object* stream_, object ch);
  2689.   local void wr_ch_terminal(stream_,ch)
  2690.     var reg2 object* stream_;
  2691.     var reg1 object ch;
  2692.     { var reg3 object stream = *stream_;
  2693.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # ch sollte String-Char sein
  2694.       begin_call();
  2695.       nxterminal_write_char(char_code(ch));
  2696.       end_call();
  2697.     }
  2698.  
  2699. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  2700. # finish_output_terminal(stream);
  2701. # > stream: Terminal-Stream
  2702. # kann GC auslösen
  2703.   local void finish_output_terminal (object stream);
  2704.   local void finish_output_terminal(stream)
  2705.     var reg1 object stream;
  2706.     { begin_call();
  2707.       nxterminal_send_output();
  2708.       end_call();
  2709.     }
  2710.  
  2711. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  2712. # force_output_terminal(stream);
  2713. # > stream: Terminal-Stream
  2714. # kann GC auslösen
  2715.   #define force_output_terminal(stream)  finish_output_terminal(stream)
  2716.  
  2717. # Liefert einen interaktiven Terminal-Stream.
  2718. # kann GC auslösen
  2719.   local object make_terminal_stream_ (void);
  2720.   local object make_terminal_stream_()
  2721.     { # neuen Stream allozieren:
  2722.       var reg2 object stream =
  2723.         allocate_stream(strmflags_ch_B,strmtype_terminal,strm_len+0);
  2724.         # Flags: nur READ-CHAR und WRITE-CHAR erlaubt
  2725.       # und füllen:
  2726.       var reg1 Stream s = TheStream(stream);
  2727.         s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  2728.         s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  2729.         s->strm_rd_ch = P(rd_ch_terminal); # READ-CHAR-Pseudofunktion
  2730.         s->strm_rd_ch_last = NIL; # Lastchar := NIL
  2731.         s->strm_wr_ch = P(wr_ch_terminal); # WRITE-CHAR-Pseudofunktion
  2732.         s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  2733.         #ifdef STRM_WR_SS
  2734.         s->strm_wr_ss = P(wr_ss_dummy_nogc);
  2735.         #endif
  2736.       return stream;
  2737.     }
  2738.  
  2739. #endif # NEXTAPP
  2740.  
  2741. #if (defined(UNIX) && !defined(NEXTAPP)) || (defined(MSDOS) && !defined(WINDOWS) && !defined(WIN32_WINDOWS)) || defined(AMIGAOS) || defined(RISCOS)
  2742.  
  2743. # Funktionsweise:
  2744. # Es wird auf Standard-Input und Standard-Output zugegriffen.
  2745. # Wegen Umleite-Möglichkeit müssen manche Funktionen unterscheiden, ob es
  2746. # sich bei Standard-Input um ein Terminal handelt oder nicht.
  2747. # Ob Standard-Output ein Terminal ist oder nicht, ist hier irrelevant.
  2748. # Relevant ist nur, ob Standard-Input und Standard-Output dasselbe Terminal
  2749. # sind; in diesem Falle nehmen wir an, daß nach Beendigung einer Eingabezeile
  2750. # (durch NL) von Standard-Input der Cursor von Standard-Output in Spalte 0
  2751. # steht, und in diesem Falle können wir auch die GNU readline()-Library
  2752. # benutzen.
  2753.  
  2754. # Es gibt drei mögliche Varianten des Terminal-Streams:
  2755. # Wenn Standard-Input und Standard-Output nicht dasselbe Terminal sind:
  2756. #   * terminal1 normalerweise,
  2757. #   * terminal2 mit zeilenweiser Bufferung der Eingabe,
  2758. # Wenn Standard-Input und Standard-Output dasselbe Terminal sind:
  2759. #   * terminal3 benutzt readline()-Library, mit zeilenweiser Bufferung der
  2760. #     Eingabe und der Ausgabe.
  2761.  
  2762. #define HAVE_TERMINAL1
  2763.   # define TERMINAL_LINEBUFFERED  0
  2764.   # define TERMINAL_OUTBUFFERED   0
  2765.  
  2766. #ifdef MSDOS
  2767.   # Bei Eingabe einer Zeile von Tastatur wird das <Enter> am Ende der Zeile als
  2768.   # CR/LF ausgegeben. Jedoch: Das CR sofort, das LF jedoch erst dann, wenn das
  2769.   # <Enter> mit read() gelesen wird - das ist bei uns manchmal erst viel später.
  2770.   # [Wer diesen Schwachsinn programmiert hat - im DOS vermutlich -
  2771.   # gehört an die Wand gestellt und erschossen! :-(]
  2772.   # Aus diesem Grund müssen wir den Terminal-Stream auf der Input-Seite
  2773.   # zeilengepuffert machen.
  2774. #define HAVE_TERMINAL2
  2775.   # define TERMINAL_LINEBUFFERED  1
  2776.   # define TERMINAL_OUTBUFFERED   0
  2777. #endif
  2778.  
  2779. #ifdef GNU_READLINE
  2780.   # Wir benutzen die GNU Readline-Library. Sie liefert den Input zeilenweise,
  2781.   # mit Editiermöglichkeit, Vervollständigung und History. Leider müssen wir
  2782.   # den Output zeilenweise zwischenspeichern, um die letzte angefangene Zeile
  2783.   # als "Prompt" verwenden zu können.
  2784. #define HAVE_TERMINAL3
  2785.   # define TERMINAL_LINEBUFFERED  1
  2786.   # define TERMINAL_OUTBUFFERED   1
  2787. #endif
  2788.  
  2789. # Zusätzliche Komponenten:
  2790.   # ISATTY : Flag, ob stdin ein TTY ist und ob stdin und stdout dasselbe sind:
  2791.   #          NIL: stdin ein File o.ä.
  2792.   #          T, EQUAL: stdin ein Terminal
  2793.   #          EQUAL: stdin und stdout dasselbe Terminal
  2794.   #define strm_terminal_isatty   strm_isatty
  2795.   #define strm_terminal_ihandle  strm_ihandle
  2796.   #define strm_terminal_ohandle  strm_ohandle
  2797. #if defined(HAVE_TERMINAL2) || defined(HAVE_TERMINAL3)
  2798.   # Komponenten wegen TERMINAL_LINEBUFFERED:
  2799.   # INBUFF : Eingabebuffer, ein Semi-Simple-String
  2800.   #define strm_terminal_inbuff  strm_other[3]
  2801.   # COUNT = sein Fill-Pointer : Anzahl der Zeichen im Eingabebuffer
  2802.   # INDEX : Anzahl der bereits verbrauchten Zeichen
  2803.   #define strm_terminal_index   strm_other[4]
  2804. #endif
  2805. #ifdef HAVE_TERMINAL3
  2806.   # Komponenten wegen TERMINAL_OUTBUFFERED:
  2807.   # OUTBUFF : Ausgabebuffer, ein Semi-Simple-String
  2808.   #define strm_terminal_outbuff strm_other[5]
  2809. #endif
  2810.  
  2811. # Längen der unterschiedlichen Terminal-Streams:
  2812.   #define strm_terminal1_len  (strm_len+3)
  2813.   #define strm_terminal2_len  (strm_len+5)
  2814.   #define strm_terminal3_len  (strm_len+6)
  2815.  
  2816. # Unterscheidung nach Art des Terminal-Streams:
  2817. # terminalcase(stream, statement1,statement2,statement3);
  2818.   #if defined(HAVE_TERMINAL2) && defined(HAVE_TERMINAL3)
  2819.     #define terminalcase(stream,statement1,statement2,statement3)  \
  2820.       switch (TheStream(stream)->reclength)          \
  2821.         { case strm_terminal1_len: statement1 break; \
  2822.           case strm_terminal2_len: statement2 break; \
  2823.           case strm_terminal3_len: statement3 break; \
  2824.           default: NOTREACHED                        \
  2825.         }
  2826.   #elif defined(HAVE_TERMINAL2)
  2827.     #define terminalcase(stream,statement1,statement2,statement3)  \
  2828.       if (TheStream(stream)->reclength == strm_terminal2_len) { statement2 } else { statement1 }
  2829.   #elif defined(HAVE_TERMINAL3)
  2830.     #define terminalcase(stream,statement1,statement2,statement3)  \
  2831.       if (TheStream(stream)->reclength == strm_terminal3_len) { statement3 } else { statement1 }
  2832.   #else
  2833.     #define terminalcase(stream,statement1,statement2,statement3)  \
  2834.       statement1
  2835.   #endif
  2836.  
  2837. #ifdef MSDOS
  2838.  
  2839.   # get_handle_info(handle)
  2840.   # > handle
  2841.   # < ergebnis: Handle-Info (INT 21,44,00)
  2842.   #ifdef DJUNIX
  2843.     #define get_handle_info(handle)  \
  2844.       ({ var reg1 uintW __info;                                                       \
  2845.          __asm__ (# DOS-Funktion 44H, Code 00H                                        \
  2846.                   " movw $0x4400,%%ax ; int $0x21 "                                   \
  2847.                   : "=d" /* %dx */ (__info)                                 # OUT     \
  2848.                   : "b" /* %bx */ ((uintW)(handle))                         # IN      \
  2849.                   : "ax","bx","cx","si","di" /* %eax,%ebx,%ecx,%esi,%edi */ # CLOBBER \
  2850.                  );                                                                   \
  2851.          __info;                                                                      \
  2852.        })
  2853.   #endif
  2854.   #ifdef EMUNIX
  2855.     #define get_handle_info(handle)  __ioctl1(handle,0x00)
  2856.   #endif
  2857.   #ifdef WATCOM
  2858.     local uintW get_handle_info (uintW handle);
  2859.     local uintW get_handle_info(handle)
  2860.       var uintW handle;
  2861.       { var union REGS in;
  2862.         var union REGS out;
  2863.         in.regW.ax = 0x4400; in.regW.bx = handle;
  2864.         intdos(&in,&out);
  2865.         return out.regW.dx;
  2866.       }
  2867.   #endif
  2868.  
  2869. #endif
  2870.  
  2871. #ifdef HAVE_TERMINAL1
  2872.  
  2873. # Lesen eines Zeichens von einem Terminal-Stream.
  2874.   local object rd_ch_terminal1 (object* stream_);
  2875.   local object rd_ch_terminal1(stream_)
  2876.     var reg3 object* stream_;
  2877.     { var reg1 object ch = rd_ch_handle(stream_);
  2878.       # Wenn stdin und stdout beide dasselbe Terminal sind,
  2879.       # und wir lesen ein NL, so können wir davon ausgehen,
  2880.       # daß der Cursor danach in Spalte 0 steht.
  2881.       if (eq(ch,code_char(NL)))
  2882.         { var reg2 object stream = *stream_;
  2883.           if (eq(TheStream(stream)->strm_terminal_isatty,S(equal)))
  2884.             { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; }
  2885.         }
  2886.       return ch;
  2887.     }
  2888.  
  2889. # Stellt fest, ob ein Terminal-Stream ein Zeichen verfügbar hat.
  2890. # listen_terminal1(stream)
  2891. # > stream: Terminal-Stream
  2892. # < ergebnis:  0 falls Zeichen verfügbar,
  2893. #             -1 falls bei EOF angelangt,
  2894. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  2895.   #define listen_terminal1  listen_handle
  2896.  
  2897. # UP: Löscht bereits eingegebenen interaktiven Input von einem Terminal-Stream.
  2898. # clear_input_terminal1(stream);
  2899. # > stream: Terminal-Stream
  2900. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  2901.   #define clear_input_terminal1  clear_input_handle
  2902.  
  2903. # UP: Ein Zeichen auf einen Terminal-Stream ausgeben.
  2904. # wr_ch_terminal1(&stream,ch);
  2905. # > stream: Terminal-Stream
  2906. # > ch: auszugebendes Zeichen
  2907.  #if !defined(AMIGAOS)
  2908.   #define wr_ch_terminal1  wr_ch_handle
  2909.  #else # defined(AMIGAOS)
  2910.   local void wr_ch_terminal1 (object* stream_, object ch);
  2911.   local void wr_ch_terminal1(stream_,ch)
  2912.     var reg6 object* stream_;
  2913.     var reg5 object ch;
  2914.     { # ch sollte ein Character mit höchstens Font, aber ohne Bits sein:
  2915.       if (!((as_oint(ch) & ~(((oint)char_code_mask_c|(oint)char_font_mask_c)<<oint_data_shift)) == as_oint(type_data_object(char_type,0))))
  2916.         { pushSTACK(*stream_);
  2917.           pushSTACK(ch);
  2918.           //: DEUTSCH "Character ~ enthält Bits und kann daher nicht auf ~ ausgegeben werden."
  2919.           //: ENGLISH "character ~ contains bits, cannot be output onto ~"
  2920.           //: FRANCAIS "Le caractère ~ contient des «bits» et ne peut pas être écrit dans ~."
  2921.           fehler(error,GETTEXT("character ~ contains bits, cannot be output onto ~"));
  2922.         }
  2923.      #if (!(char_font_len_c == 4))
  2924.        #error "char_font_len_c neu einstellen oder wr_ch_terminal neu schreiben!"
  2925.      #endif
  2926.      {var uintB outbuffer[14];
  2927.       var reg1 uintB* ptr = &outbuffer[0];
  2928.       var reg3 uintL count = 1;
  2929.       var reg2 uintB f = (char_int(ch) & char_font_mask_c) >> char_font_shift_c; # Font des Zeichens
  2930.       var reg4 uintB c = char_code(ch); # Code des Zeichens
  2931.       if (f==0)
  2932.         { *ptr++ = c; }
  2933.         else
  2934.         { *ptr++ = CSI; # Kontroll-Sequenz zum Umschalten auf den richtigen Font:
  2935.           if (f & bit(0)) { *ptr++ = '1'; *ptr++ = ';'; count += 2; } # Fettschrift ein
  2936.           if (f & bit(1)) { *ptr++ = '3'; *ptr++ = ';'; count += 2; } # Kursiv ein
  2937.           if (f & bit(2)) { *ptr++ = '4'; *ptr++ = ';'; count += 2; } # Unterstreichung ein
  2938.           if (f & bit(3)) { *ptr++ = '7'; *ptr++ = ';'; count += 2; } # Reverse ein
  2939.           *ptr++ = 0x6D;
  2940.           *ptr++ = c; # dann das Zeichen ausgeben
  2941.           *ptr++ = CSI; *ptr++ = '0'; *ptr++ = 0x6D; # Wieder Normalschrift
  2942.           count += 5;
  2943.         }
  2944.       begin_system_call();
  2945.       {var reg1 long ergebnis = Write(Output_handle,&outbuffer[0],count); # Zeichen auszugeben versuchen
  2946.        end_system_call();
  2947.        if (ergebnis<0) { OS_error(); } # Error melden
  2948.        if (ergebnis<count) # nicht erfolgreich?
  2949.          { fehler_unwritable(S(write_char),*stream_); }
  2950.     }}}
  2951.  #endif
  2952.  
  2953. #ifdef STRM_WR_SS
  2954. # UP: Mehrere Zeichen auf einen Terminal-Stream ausgeben.
  2955. # wr_ss_terminal1(&stream,string,start,len);
  2956. # > stream: Terminal-Stream
  2957. # > string: Simple-String
  2958. # > start: Startindex
  2959. # > len: Anzahl der auszugebenden Zeichen
  2960.   #define wr_ss_terminal1  wr_ss_handle
  2961. #endif
  2962.  
  2963. # UP: Löscht den wartenden Output eines Terminal-Stream.
  2964. # clear_output_terminal1(stream);
  2965. # > stream: Terminal-Stream
  2966. # kann GC auslösen
  2967.   #define clear_output_terminal1  clear_output_handle
  2968.  
  2969. #endif # HAVE_TERMINAL1
  2970.  
  2971. #ifdef HAVE_TERMINAL2
  2972.  
  2973. #define TERMINAL_LINEBUFFERED  TRUE
  2974.  
  2975. # Lesen eines Zeichens von einem Terminal-Stream.
  2976.   local object rd_ch_terminal2 (object* stream_);
  2977.   # vgl. rd_ch_handle() :
  2978.   local object rd_ch_terminal2(stream_)
  2979.     var reg3 object* stream_;
  2980.     { restart_it:
  2981.      {var reg2 object stream = *stream_;
  2982.       if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ?
  2983.         { return eof_value; }
  2984.       #if TERMINAL_LINEBUFFERED
  2985.       { var reg4 object inbuff = TheStream(stream)->strm_terminal_inbuff; # Eingabebuffer
  2986.         if (posfixnum_to_L(TheStream(stream)->strm_terminal_index)
  2987.             < TheArray(inbuff)->dims[1]
  2988.            )
  2989.           # index<count -> Es sind noch Zeichen im Buffer
  2990.           { var reg1 uintL index =
  2991.               posfixnum_to_L(TheStream(stream)->strm_terminal_index); # Index
  2992.             TheStream(stream)->strm_terminal_index =
  2993.               fixnum_inc(TheStream(stream)->strm_terminal_index,1); # Index erhöhen
  2994.             return code_char(TheSstring(TheArray(inbuff)->data)->data[index]); # nächstes Character
  2995.           }
  2996.         # index=count -> muß eine ganze Zeile von Tastatur lesen:
  2997.         TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0
  2998.         TheArray(inbuff)->dims[1] = 0; # count := 0
  2999.       }
  3000.       continue_line:
  3001.       #endif
  3002.       {var uintB c;
  3003.        run_time_stop(); # Run-Time-Stoppuhr anhalten
  3004.        #ifdef GRAPHICS_SWITCH
  3005.        switch_text_mode();
  3006.        #endif
  3007.        begin_system_call();
  3008.        {var reg1 int ergebnis = read(stdin_handle,&c,1); # Zeichen lesen versuchen
  3009.         end_system_call();
  3010.         run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  3011.         if (ergebnis<0)
  3012.           { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  3013.               { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen
  3014.                 goto restart_it;
  3015.               }
  3016.             OS_error();
  3017.           }
  3018.         if (ergebnis==0)
  3019.           # kein Zeichen verfügbar -> EOF erkennen
  3020.           #if TERMINAL_LINEBUFFERED
  3021.           if (TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] > 0)
  3022.             goto restart_it; # Zeichen des Buffers liefern, dann erst eof_value liefern
  3023.             else
  3024.           #endif
  3025.             { TheStream(stream)->strm_rd_ch_last = eof_value; return eof_value; }
  3026.        }
  3027.        #if TERMINAL_LINEBUFFERED
  3028.        # Zeichen c zur Eingabezeile dazunehmen, evtl. die Zeile vergrößern:
  3029.        ssstring_push_extend(TheStream(stream)->strm_terminal_inbuff,c);
  3030.        stream = *stream_;
  3031.        #endif
  3032.        # Wenn stdin und stdout beide dasselbe Terminal sind,
  3033.        # und wir lesen ein NL, so können wir davon ausgehen,
  3034.        # daß der Cursor danach in Spalte 0 steht.
  3035.        if (c==NL)
  3036.          { if (eq(TheStream(stream)->strm_terminal_isatty,S(equal)))
  3037.              { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; }
  3038.          }
  3039.        #if TERMINAL_LINEBUFFERED
  3040.          else
  3041.          goto continue_line; # so lang weiterlesen, bis ein NL kommt...
  3042.        # Kam ein NL, so fangen wir an, die Zeichen des Buffers zu liefern:
  3043.        goto restart_it;
  3044.        #endif
  3045.       }
  3046.     }}
  3047.  
  3048. # Stellt fest, ob ein Terminal-Stream ein Zeichen verfügbar hat.
  3049. # listen_terminal2(stream)
  3050. # > stream: Terminal-Stream
  3051. # < ergebnis:  0 falls Zeichen verfügbar,
  3052. #             -1 falls bei EOF angelangt,
  3053. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  3054.   local signean listen_terminal2 (object stream);
  3055.   local signean listen_terminal2(stream)
  3056.     var reg1 object stream;
  3057.     { if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ?
  3058.         { return signean_minus; }
  3059.       if (posfixnum_to_L(TheStream(stream)->strm_terminal_index)
  3060.           < TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1]
  3061.          )
  3062.         # index<count -> Es sind noch Zeichen im Buffer
  3063.         { return signean_null; }
  3064.       return listen_handle(stream);
  3065.     }
  3066.  
  3067. # UP: Löscht bereits eingegebenen interaktiven Input von einem Terminal-Stream.
  3068. # clear_input_terminal2(stream);
  3069. # > stream: Terminal-Stream
  3070. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  3071.   local boolean clear_input_terminal2 (object stream);
  3072.   local boolean clear_input_terminal2(stream)
  3073.     var reg1 object stream;
  3074.     { if (nullp(TheStream(stream)->strm_terminal_isatty))
  3075.         # File -> nichts tun
  3076.         { return FALSE; }
  3077.       # Terminal
  3078.       TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen
  3079.       #if TERMINAL_LINEBUFFERED
  3080.       TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0
  3081.       TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] = 0; # count := 0
  3082.       #endif
  3083.       clear_tty_input(stdin_handle);
  3084.       pushSTACK(stream);
  3085.       while (listen_terminal2(STACK_0) == 0) { read_char(&STACK_0); }
  3086.       skipSTACK(1);
  3087.       return TRUE;
  3088.     }
  3089.  
  3090. # UP: Ein Zeichen auf einen Terminal-Stream ausgeben.
  3091. # wr_ch_terminal2(&stream,ch);
  3092. # > stream: Terminal-Stream
  3093. # > ch: auszugebendes Zeichen
  3094.   #define wr_ch_terminal2  wr_ch_handle
  3095.  
  3096. #ifdef STRM_WR_SS
  3097. # UP: Mehrere Zeichen auf einen Terminal-Stream ausgeben.
  3098. # wr_ss_terminal2(&stream,string,start,len);
  3099. # > stream: Terminal-Stream
  3100. # > string: Simple-String
  3101. # > start: Startindex
  3102. # > len: Anzahl der auszugebenden Zeichen
  3103.   #define wr_ss_terminal2  wr_ss_handle
  3104. #endif
  3105.  
  3106. # UP: Löscht den wartenden Output eines Terminal-Stream.
  3107. # clear_output_terminal2(stream);
  3108. # > stream: Terminal-Stream
  3109. # kann GC auslösen
  3110.   #define clear_output_terminal2  clear_output_handle
  3111.  
  3112. #endif # HAVE_TERMINAL2
  3113.  
  3114. #ifdef HAVE_TERMINAL3
  3115.  
  3116. #define TERMINAL_LINEBUFFERED  TRUE
  3117. #define TERMINAL_OUTBUFFERED   TRUE
  3118.  
  3119. # Unsere eigene Vervollständigungs-Funktion, imitiert completion_matches()
  3120. # aus readline.c.
  3121.   local char** lisp_completion_matches (char* text, int start, int end);
  3122.   local boolean want_filename_completion;
  3123.   extern char* filename_completion_function (char* text, int state); # siehe readline.c
  3124.   local char** lisp_completion_matches(text,start,end)
  3125.     var reg4 char* text; # text[0..end-start-1] = the_line[start..end-1]
  3126.     var reg1 int start;
  3127.     var reg2 int end;
  3128.     { if ((start>=2) && (rl_line_buffer[start-2]=='#') && (rl_line_buffer[start-1]== '\"'))
  3129.         # Vervollständigung nach #" bezieht sich auf Filenamen:
  3130.         { want_filename_completion = TRUE; return NULL; }
  3131.       # Dies ist eine Callback-Funktion, wir müssen den Stack wieder korrekt setzen:
  3132.       begin_callback();
  3133.      {var reg3 char** result = lisp_completion(rl_line_buffer,start,end);
  3134.       want_filename_completion = FALSE;
  3135.       return result;
  3136.     }}
  3137.  
  3138. # Falls obige Funktion NULL (keine Matches) lieferte, wird die folgende
  3139. # Funktion so lange aufgerufen, bis sie ihrerseits NULL liefert.
  3140.   local char* lisp_completion_more (char* text, int state);
  3141.   local char* lisp_completion_more(text,state)
  3142.     var reg2 char* text;
  3143.     var reg1 int state;
  3144.     { if (want_filename_completion)
  3145.         { return filename_completion_function(text,state); }
  3146.         else
  3147.         { return NULL; }
  3148.     }
  3149.  
  3150. # Lesen eines Zeichens von einem Terminal-Stream.
  3151.   local object rd_ch_terminal3 (object* stream_);
  3152.   # vgl. rd_ch_handle() :
  3153.   local object rd_ch_terminal3(stream_)
  3154.     var reg3 object* stream_;
  3155.     { restart_it:
  3156.      {var reg2 object stream = *stream_;
  3157.       if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ?
  3158.         { return eof_value; }
  3159.       #if TERMINAL_LINEBUFFERED
  3160.       { var reg4 object inbuff = TheStream(stream)->strm_terminal_inbuff; # Eingabebuffer
  3161.         if (posfixnum_to_L(TheStream(stream)->strm_terminal_index)
  3162.             < TheArray(inbuff)->dims[1]
  3163.            )
  3164.           # index<count -> Es sind noch Zeichen im Buffer
  3165.           { var reg1 uintL index =
  3166.               posfixnum_to_L(TheStream(stream)->strm_terminal_index); # Index
  3167.             TheStream(stream)->strm_terminal_index =
  3168.               fixnum_inc(TheStream(stream)->strm_terminal_index,1); # Index erhöhen
  3169.             return code_char(TheSstring(TheArray(inbuff)->data)->data[index]); # nächstes Character
  3170.           }
  3171.         # index=count -> muß eine ganze Zeile von Tastatur lesen:
  3172.         TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0
  3173.         TheArray(inbuff)->dims[1] = 0; # count := 0
  3174.       }
  3175.       #endif
  3176.       { var reg5 char* prompt; # Prompt: letzte bisher ausgegebene Zeile
  3177.        {var reg6 object lastline = string_to_asciz(TheStream(*stream_)->strm_terminal_outbuff);
  3178.         prompt = (char*) malloc(TheSstring(lastline)->length+1);
  3179.         if (!(prompt==NULL))
  3180.           { strcpy(prompt,TheAsciz(lastline));
  3181.             # Die readline()-Library arbeitet mit einer anderen Bildschirmbreite,
  3182.             # als sie bei der Ausgabe des Prompts benutzt wurde. Bei Prompts
  3183.             # länger als eine Bildschirmzeile gibt das Probleme. Wir behelfen
  3184.             # uns, indem wir an passender Stelle ein '\n' einfügen.
  3185.             { var reg8 uintL prompt_length = asciz_length(prompt);
  3186.               var reg7 uintL screenwidth = posfixnum_to_L(Symbol_value(S(prin_linelength)))+1;
  3187.               if (prompt_length >= screenwidth)
  3188.                 { var reg4 uintL insertpos = round_down(prompt_length,screenwidth);
  3189.                   var reg1 uintL i;
  3190.                   for (i = prompt_length; i >= insertpos; i--)
  3191.                     { prompt[i+1] = prompt[i]; }
  3192.                   prompt[insertpos] = '\n';
  3193.        }  } }   }
  3194.        # Lexem-trennende Characters: die mit Syntaxcode whsp,tmac,nmac
  3195.        # (siehe IO.D, eigentlich von der Readtable abhängig):
  3196.        rl_basic_word_break_characters = "\t" NLstring " \"#'(),;`";
  3197.        rl_basic_quote_characters = "\"|";
  3198.        rl_completer_quote_characters = "\\|";
  3199.        run_time_stop(); # Run-Time-Stoppuhr anhalten
  3200.        #ifdef GRAPHICS_SWITCH
  3201.        switch_text_mode();
  3202.        #endif
  3203.        begin_call();
  3204.        rl_already_prompted = TRUE;
  3205.        {var reg4 uintB* line = (uintB*)readline(prompt==NULL ? "" : prompt); # Zeile lesen
  3206.         end_call();
  3207.         run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  3208.         if (!(prompt==NULL)) { free(prompt); }
  3209.         if (line==NULL)
  3210.           # EOF (am Zeilenanfang) erkennen
  3211.           { TheStream(stream)->strm_rd_ch_last = eof_value; return eof_value; }
  3212.         # gelesene Zeile zur Eingabezeile dazunehmen:
  3213.         {var reg1 uintB* ptr = line;
  3214.          until (*ptr == '\0')
  3215.            { ssstring_push_extend(TheStream(*stream_)->strm_terminal_inbuff,*ptr++); }
  3216.          ssstring_push_extend(TheStream(*stream_)->strm_terminal_inbuff,NL);
  3217.         }
  3218.         # und in die History übernehmen, falls nicht leer:
  3219.         if (!(line[0]=='\0')) { add_history(line); }
  3220.         # Freigeben müssen wir die Zeile!
  3221.         free(line);
  3222.       }}
  3223.       # Wenn stdin und stdout beide dasselbe Terminal sind, können
  3224.       # wir davon ausgehen, daß der Cursor in Spalte 0 steht.
  3225.       if (eq(TheStream(*stream_)->strm_terminal_isatty,S(equal)))
  3226.         { TheStream(*stream_)->strm_wr_ch_lpos = Fixnum_0;
  3227.           TheArray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0
  3228.         }
  3229.       # Nun fangen wir an, die Zeichen des Buffers zu liefern:
  3230.       goto restart_it;
  3231.     }}
  3232.  
  3233. # Stellt fest, ob ein Terminal-Stream ein Zeichen verfügbar hat.
  3234. # listen_terminal3(stream)
  3235. # > stream: Terminal-Stream
  3236. # < ergebnis:  0 falls Zeichen verfügbar,
  3237. #             -1 falls bei EOF angelangt,
  3238. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  3239.   local signean listen_terminal3 (object stream);
  3240.   local signean listen_terminal3(stream)
  3241.     var reg1 object stream;
  3242.     { if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ?
  3243.         { return signean_minus; }
  3244.       if (posfixnum_to_L(TheStream(stream)->strm_terminal_index)
  3245.           < TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1]
  3246.          )
  3247.         # index<count -> Es sind noch Zeichen im Buffer
  3248.         { return signean_null; }
  3249.       return listen_handle(stream);
  3250.     }
  3251.  
  3252. # UP: Löscht bereits eingegebenen interaktiven Input von einem Terminal-Stream.
  3253. # clear_input_terminal3(stream);
  3254. # > stream: Terminal-Stream
  3255. # < ergebnis: TRUE falls Input gelöscht wurde, FALSE sonst
  3256.   local boolean clear_input_terminal3 (object stream);
  3257.   local boolean clear_input_terminal3(stream)
  3258.     var reg1 object stream;
  3259.     { if (nullp(TheStream(stream)->strm_terminal_isatty))
  3260.         # File -> nichts tun
  3261.         { return FALSE; }
  3262.       # Terminal
  3263.       TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen
  3264.       #if TERMINAL_LINEBUFFERED
  3265.       TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0
  3266.       TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] = 0; # count := 0
  3267.       #endif
  3268.       clear_tty_input(stdin_handle);
  3269.       pushSTACK(stream);
  3270.       while (listen_terminal3(STACK_0) == 0) { read_char(&STACK_0); }
  3271.       skipSTACK(1);
  3272.       return TRUE;
  3273.     }
  3274.  
  3275. # UP: Ein Zeichen auf einen Terminal-Stream ausgeben.
  3276. # wr_ch_terminal3(&stream,ch);
  3277. # > stream: Terminal-Stream
  3278. # > ch: auszugebendes Zeichen
  3279.   local void wr_ch_terminal3 (object* stream_, object ch);
  3280.   local void wr_ch_terminal3(stream_,ch)
  3281.     var reg3 object* stream_;
  3282.     var reg1 object ch;
  3283.     { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein
  3284.      {var uintB c = char_code(ch); # Code des Zeichens
  3285.       #if TERMINAL_OUTBUFFERED
  3286.       if (c==NL)
  3287.         TheArray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0
  3288.         else
  3289.         ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,c);
  3290.       #endif
  3291.       restart_it:
  3292.       #ifdef GRAPHICS_SWITCH
  3293.       switch_text_mode();
  3294.       #endif
  3295.       begin_system_call();
  3296.       {var reg2 int ergebnis = write(stdout_handle,&c,1); # Zeichen auszugeben versuchen
  3297.        end_system_call();
  3298.        if (ergebnis<0)
  3299.          { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  3300.              { interruptp({ pushSTACK(S(write_char)); tast_break(); }); # Break-Schleife aufrufen
  3301.                goto restart_it;
  3302.              }
  3303.            OS_error(); # Error melden
  3304.          }
  3305.        if (ergebnis==0) # nicht erfolgreich?
  3306.          { fehler_unwritable(S(write_char),*stream_); }
  3307.       }
  3308.     }}
  3309.  
  3310. #ifdef STRM_WR_SS
  3311. # UP: Mehrere Zeichen auf einen Terminal-Stream ausgeben.
  3312. # wr_ss_terminal3(&stream,string,start,len);
  3313. # > stream: Terminal-Stream
  3314. # > string: Simple-String
  3315. # > start: Startindex
  3316. # > len: Anzahl der auszugebenden Zeichen
  3317. # kann GC auslösen
  3318.   local void wr_ss_terminal3 (object* stream_, object string, uintL start, uintL len);
  3319.   local void wr_ss_terminal3(stream_,string,start,len)
  3320.     var reg6 object* stream_;
  3321.     var reg4 object string;
  3322.     var reg5 uintL start;
  3323.     var reg7 uintL len;
  3324.     { if (len==0) return;
  3325.       #ifdef GRAPHICS_SWITCH
  3326.       switch_text_mode();
  3327.       #endif
  3328.      {var reg1 uintB* ptr = &TheSstring(string)->data[start];
  3329.       var reg2 uintL remaining = len;
  3330.       loop
  3331.         { restart_it:
  3332.           begin_system_call();
  3333.          {var reg3 int ergebnis = full_write(stdout_handle,ptr,remaining); # Zeichen auszugeben versuchen
  3334.           end_system_call();
  3335.           if (ergebnis<0)
  3336.             { if (errno==EINTR) goto restart_it;
  3337.               OS_error(); # Error melden
  3338.             }
  3339.           if (ergebnis==0) # nicht erfolgreich?
  3340.             { fehler_unwritable(S(write_string),*stream_); }
  3341.           ptr += ergebnis; remaining -= ergebnis;
  3342.           if (remaining==0) break; # fertig?
  3343.         }}
  3344.       #if TERMINAL_OUTBUFFERED
  3345.       # Zeichen seit dem letzten NL in den Buffer:
  3346.       { var reg3 uintL pos = 0; # zähle die Zahl der Zeichen seit dem letzten NL
  3347.         var reg2 uintL count;
  3348.         dotimespL(count,len, { if (*--ptr == NL) goto found_NL; pos++; } );
  3349.         if (FALSE)
  3350.           found_NL: # pos Zeichen seit dem letzten NL
  3351.           { ptr++;
  3352.             TheArray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0
  3353.           }
  3354.         pushSTACK(string);
  3355.         { var reg1 uintL index = len - pos;
  3356.           dotimesL(count,pos,
  3357.             { ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,
  3358.                                    TheSstring(STACK_0)->data[start+index]);
  3359.               index++;
  3360.             });
  3361.         }
  3362.         ptr = &TheSstring(STACK_0)->data[start+len];
  3363.         skipSTACK(1);
  3364.       }
  3365.       #endif
  3366.       wr_ss_lpos(*stream_,ptr,len); # Line-Position aktualisieren
  3367.     }}
  3368. #endif
  3369.  
  3370. # UP: Löscht den wartenden Output eines Terminal-Stream.
  3371. # clear_output_terminal3(stream);
  3372. # > stream: Terminal-Stream
  3373. # kann GC auslösen
  3374.   local void clear_output_terminal3 (object stream);
  3375.   local void clear_output_terminal3(stream)
  3376.     var reg1 object stream;
  3377.     { clear_output_handle(stream);
  3378.       #if TERMINAL_OUTBUFFERED
  3379.       TheArray(TheStream(stream)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0
  3380.       #endif
  3381.     }
  3382.  
  3383. #endif # HAVE_TERMINAL3
  3384.  
  3385. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  3386. # finish_output_terminal(stream);
  3387. # > stream: Terminal-Stream
  3388. # kann GC auslösen
  3389.   #define finish_output_terminal  finish_output_handle
  3390.  
  3391. # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel.
  3392. # force_output_terminal(stream);
  3393. # > stream: Terminal-Stream
  3394. # kann GC auslösen
  3395.   #define force_output_terminal  force_output_handle
  3396.  
  3397. # Liefert einen interaktiven Terminal-Stream.
  3398. # kann GC auslösen
  3399.   local object make_terminal_stream_ (void);
  3400.   local object make_terminal_stream_()
  3401.     {
  3402.      #ifdef AMIGAOS
  3403.       # nur HAVE_TERMINAL1
  3404.       { pushSTACK(allocate_handle(Output_handle));
  3405.         pushSTACK(allocate_handle(Input_handle));
  3406.        {var reg2 object stream =
  3407.           allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal1_len);
  3408.         # Flags: nur READ-CHAR und WRITE-CHAR erlaubt
  3409.         # und füllen:
  3410.         var reg1 Stream s = TheStream(stream);
  3411.           s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  3412.           s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  3413.           s->strm_rd_ch = P(rd_ch_terminal1); # READ-CHAR-Pseudofunktion
  3414.           s->strm_rd_ch_last = NIL; # Lastchar := NIL
  3415.           s->strm_wr_ch = P(wr_ch_terminal1); # WRITE-CHAR-Pseudofunktion
  3416.           s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  3417.           #ifdef STRM_WR_SS
  3418.           s->strm_wr_ss = P(wr_ss_terminal1);
  3419.           #endif
  3420.           begin_system_call();
  3421.           s->strm_terminal_isatty =
  3422.             (IsInteractive(Input_handle)
  3423.               ? (IsInteractive(Output_handle)
  3424.                   ? S(equal) # Input und Output Terminals -> vermutlich dasselbe
  3425.                   : T
  3426.                 )
  3427.               : NIL
  3428.             );
  3429.           end_system_call();
  3430.           s->strm_terminal_ihandle = popSTACK();
  3431.           s->strm_terminal_ohandle = popSTACK();
  3432.         return stream;
  3433.       }}
  3434.      #else
  3435.       { var reg7 int stdin_tty;
  3436.         var reg8 int stdout_tty;
  3437.         var reg6 int same_tty;
  3438.         begin_system_call();
  3439.         stdin_tty = isatty(stdin_handle); # stdin ein Terminal?
  3440.         stdout_tty = isatty(stdout_handle); # stdout ein Terminal?
  3441.         same_tty = FALSE; # vorläufig
  3442.         if (stdin_tty && stdout_tty)
  3443.           # stdin und stdout Terminals.
  3444.           {
  3445.            #if defined(UNIX) || defined(RISCOS)
  3446.             #if 0
  3447.             var reg1 char* ergebnis;
  3448.             var reg2 object filename;
  3449.             ergebnis = ttyname(stdin_handle); # Filename von stdin holen
  3450.             if (!(ergebnis==NULL))
  3451.               { end_system_call();
  3452.                 filename = asciz_to_string(ergebnis);
  3453.                 begin_system_call();
  3454.                 ergebnis = ttyname(stdout_handle); # Filename von stdout holen
  3455.                 if (!(ergebnis==NULL))
  3456.                   { end_system_call();
  3457.                     pushSTACK(filename);
  3458.                     filename = asciz_to_string(ergebnis);
  3459.                     if (string_gleich(popSTACK(),filename)) # gleiche Filenamen?
  3460.                       { same_tty = TRUE; }
  3461.               }   }
  3462.             #else # ttyname() ist recht langsam, fstat() geht schneller.
  3463.             struct stat stdin_stat;
  3464.             struct stat stdout_stat;
  3465.             if ((fstat(stdin_handle,&stdin_stat) >= 0) && (fstat(stdout_handle,&stdout_stat) >= 0))
  3466.               if ((stdin_stat.st_dev == stdout_stat.st_dev) && (stdin_stat.st_ino == stdout_stat.st_ino))
  3467.                 { same_tty = TRUE; }
  3468.             #endif
  3469.            #endif
  3470.            #if defined(MSDOS) && !defined(WIN32_DOS)
  3471.             if (   ((get_handle_info(stdin_handle) & (bit(7)|bit(0))) == (bit(7)|bit(0))) # stdin == console_input ?
  3472.                 && ((get_handle_info(stdout_handle) & (bit(7)|bit(1))) == (bit(7)|bit(1))) # stdout == console_output ?
  3473.                )
  3474.               { same_tty = TRUE; }
  3475.            #endif
  3476.            #if defined(WIN32_UNIX) || defined(WIN32_DOS)
  3477.            same_tty = TRUE;
  3478.            #endif
  3479.           }
  3480.         end_system_call();
  3481.         #ifdef HAVE_TERMINAL3
  3482.         if (rl_present_p && same_tty)
  3483.           # Baue einen TERMINAL3-Stream:
  3484.           { pushSTACK(make_ssstring(80)); # Zeilenbuffer allozieren
  3485.             pushSTACK(make_ssstring(80)); # Zeilenbuffer allozieren
  3486.             # neuen Stream allozieren:
  3487.            {var reg2 object stream =
  3488.               allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal3_len);
  3489.               # Flags: nur READ-CHAR und WRITE-CHAR erlaubt
  3490.             # und füllen:
  3491.             var reg1 Stream s = TheStream(stream);
  3492.               s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  3493.               s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  3494.               s->strm_rd_ch = P(rd_ch_terminal3); # READ-CHAR-Pseudofunktion
  3495.               s->strm_rd_ch_last = NIL; # Lastchar := NIL
  3496.               s->strm_wr_ch = P(wr_ch_terminal3); # WRITE-CHAR-Pseudofunktion
  3497.               s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  3498.               #ifdef STRM_WR_SS
  3499.               s->strm_wr_ss = P(wr_ss_terminal3);
  3500.               #endif
  3501.               s->strm_terminal_isatty = S(equal); # stdout=stdin
  3502.               s->strm_terminal_ihandle = allocate_handle(stdin_handle); # Handle für listen_handle()
  3503.               s->strm_terminal_ohandle = allocate_handle(stdout_handle); # Handle für Output
  3504.               #if 1 # TERMINAL_LINEBUFFERED
  3505.               s->strm_terminal_inbuff = popSTACK(); # Zeilenbuffer eintragen, count := 0
  3506.               s->strm_terminal_index = Fixnum_0; # index := 0
  3507.               #endif
  3508.               #if 1 # TERMINAL_OUTBUFFERED
  3509.               s->strm_terminal_outbuff = popSTACK(); # Zeilenbuffer eintragen
  3510.               #endif
  3511.             return stream;
  3512.           }}
  3513.         #endif
  3514.         #ifdef HAVE_TERMINAL2
  3515.         if (stdin_tty)
  3516.           # Baue einen TERMINAL2-Stream:
  3517.           { pushSTACK(make_ssstring(80)); # Zeilenbuffer allozieren
  3518.             # neuen Stream allozieren:
  3519.            {var reg2 object stream =
  3520.               allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal2_len);
  3521.               # Flags: nur READ-CHAR und WRITE-CHAR erlaubt
  3522.             # und füllen:
  3523.             var reg1 Stream s = TheStream(stream);
  3524.               s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  3525.               s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  3526.               s->strm_rd_ch = P(rd_ch_terminal2); # READ-CHAR-Pseudofunktion
  3527.               s->strm_rd_ch_last = NIL; # Lastchar := NIL
  3528.               s->strm_wr_ch = P(wr_ch_terminal2); # WRITE-CHAR-Pseudofunktion
  3529.               s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  3530.               #ifdef STRM_WR_SS
  3531.               s->strm_wr_ss = P(wr_ss_terminal2);
  3532.               #endif
  3533.               s->strm_terminal_isatty = (stdin_tty ? (same_tty ? S(equal) : T) : NIL);
  3534.               s->strm_terminal_ihandle = allocate_handle(stdin_handle); # Handle für listen_handle()
  3535.               s->strm_terminal_ohandle = allocate_handle(stdout_handle); # Handle für Output
  3536.               #if 1 # TERMINAL_LINEBUFFERED
  3537.               s->strm_terminal_inbuff = popSTACK(); # Zeilenbuffer eintragen, count := 0
  3538.               s->strm_terminal_index = Fixnum_0; # index := 0
  3539.               #endif
  3540.             return stream;
  3541.           }}
  3542.         #endif
  3543.         # Baue einen TERMINAL1-Stream:
  3544.         { # neuen Stream allozieren:
  3545.           var reg2 object stream =
  3546.             allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal1_len);
  3547.             # Flags: nur READ-CHAR und WRITE-CHAR erlaubt
  3548.           # und füllen:
  3549.           var reg1 Stream s = TheStream(stream);
  3550.             s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  3551.             s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  3552.             s->strm_rd_ch = P(rd_ch_terminal1); # READ-CHAR-Pseudofunktion
  3553.             s->strm_rd_ch_last = NIL; # Lastchar := NIL
  3554.             s->strm_wr_ch = P(wr_ch_terminal1); # WRITE-CHAR-Pseudofunktion
  3555.             s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  3556.             #ifdef STRM_WR_SS
  3557.             s->strm_wr_ss = P(wr_ss_terminal1);
  3558.             #endif
  3559.             s->strm_terminal_isatty = (stdin_tty ? (same_tty ? S(equal) : T) : NIL);
  3560.             s->strm_terminal_ihandle = allocate_handle(stdin_handle); # Handle für listen_handle()
  3561.             s->strm_terminal_ohandle = allocate_handle(stdout_handle); # Handle für Output
  3562.           return stream;
  3563.         }
  3564.       }
  3565.      #endif
  3566.     }
  3567.  
  3568. # Fehler, wenn TERMINAL-RAW nicht geht.
  3569.   nonreturning_function(local, fehler_terminal_raw, (object stream));
  3570.   local void fehler_terminal_raw(stream)
  3571.     var reg1 object stream;
  3572.     { pushSTACK(stream);
  3573.       //: DEUTSCH "RAW-Modus wird auf ~ nicht unterstützt."
  3574.       //: ENGLISH "RAW mode not supported on ~"
  3575.       //: FRANCAIS "Le mode «RAW» n'est pas supporté par ~."
  3576.       fehler(error,GETTEXT("RAW mode not supported on ~"));
  3577.     }
  3578.  
  3579. #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  3580.  
  3581. # (SYS::TERMINAL-RAW *terminal-io* flag [errorp])
  3582. # flag /= NIL: versetzt das Terminal in cbreak/noecho-Modus,
  3583. # flag = NIL: versetzt das Terminal in nocbreak/echo-Modus zurück.
  3584. # Wenn es nicht geht und errorp angegeben und /= NIL ist, wird Error gemeldet.
  3585. # Liefert den alten Modus.
  3586.  
  3587. # (SYS::TERMINAL-RAW *terminal-io* t) entspricht im wesentlichen
  3588. # (progn
  3589. #   ; keine Editiermöglichkeiten, kein Echo, keine CR<-->NL-Umwandlungen:
  3590. #   (shell "stty -icanon -echo -icrnl -inlcr")
  3591. #   ; nichts abfangen:
  3592. #   ;              C-S   C-Q      Del     C-U       C-W      C-R      C-O      C-V     C-Y     C-C     C-\      C-Q     C-S    C-D
  3593. #   (shell "stty -ixon -ixoff erase ^- kill ^- werase ^- rprnt ^- flush ^- lnext ^- susp ^- intr ^- quit ^- start ^- stop ^- eof ^-")
  3594. #   ; 1 Zeichen auf einmal verlangen (nicht 4!):
  3595. #   (shell "stty min 1") ; das muß seltsamerweise zuletzt kommen...
  3596. # )
  3597. # (SYS::TERMINAL-RAW *terminal-io* nil) entspricht im wesentlichen
  3598. # (shell "stty sane")
  3599.  
  3600. #if defined(UNIX) || defined(RISCOS)
  3601.  
  3602. local void term_raw (void);
  3603. local void term_unraw (void);
  3604.  
  3605. local boolean oldterm_initialized = FALSE;
  3606.  
  3607. #if defined(UNIX_TERM_TERMIOS)
  3608.   local struct termios oldtermio; # ursprünglicher TTY-Modus
  3609.   local void term_raw()
  3610.     { if (!oldterm_initialized)
  3611.         { if (!( tcgetattr(stdout_handle,&oldtermio) ==0))
  3612.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3613.           oldterm_initialized = TRUE;
  3614.         }
  3615.      {var struct termios newtermio;
  3616.       newtermio = oldtermio;
  3617.       newtermio.c_iflag &= ( /* IXON|IXOFF|IXANY| */ ISTRIP|IGNBRK);
  3618.       /* newtermio.c_oflag &= ~OPOST; */ # Curses stört sich dran!
  3619.       newtermio.c_lflag &= ISIG;
  3620.       { var reg1 uintC i;
  3621.         for (i=0; i<NCCS; i++) { newtermio.c_cc[i] = 0; }
  3622.       }
  3623.       newtermio.c_cc[VMIN] = 1;
  3624.       newtermio.c_cc[VTIME] = 0;
  3625.       if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&newtermio) ==0))
  3626.         { if (!(errno==ENOTTY)) { OS_error(); } }
  3627.     }}
  3628.   local void term_unraw()
  3629.     { if (oldterm_initialized)
  3630.         { if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0))
  3631.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3632.     }   }
  3633.   # Manche machen's so:
  3634.     # define crmode()    (_tty.c_lflag &=~ICANON,_tty.c_cc[VMIN]=1,tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
  3635.     # define nocrmode()  (_tty.c_lflag |= ICANON,_tty.c_cc[VEOF] = CEOF,tcsetattr(_tty_ch, TCSAFLUSH,&_tty))
  3636.     # define echo()      (_tty.c_lflag |= ECHO, tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
  3637.     # define noecho()    (_tty.c_lflag &=~ECHO, tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
  3638.     # define nl()        (_tty.c_iflag |= ICRNL,_tty.c_oflag |= ONLCR,tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
  3639.     # define nonl()      (_tty.c_iflag &=~ICRNL,_tty.c_oflag &=~ONLCR,tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
  3640.     # define savetty()   (tcgetattr(_tty_ch, &_oldtty),tcgetattr(_tty_ch, &_tty))
  3641.     # define resetty()   (tcsetattr(_tty_ch, TCSAFLUSH, &_oldtty))
  3642. #elif defined(UNIX_TERM_TERMIO) || defined(EMUNIX)
  3643.   local struct termio oldtermio; # ursprünglicher TTY-Modus
  3644.   local void term_raw()
  3645.     { if (!oldterm_initialized)
  3646.         { if (!( ioctl(stdout_handle,TCGETA,&oldtermio) ==0))
  3647.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3648.           oldterm_initialized = TRUE;
  3649.         }
  3650.      {var struct termio newtermio;
  3651.       newtermio = oldtermio;
  3652.       newtermio.c_iflag &= ( /* IXON|IXOFF|IXANY| */ ISTRIP|IGNBRK);
  3653.       /* newtermio.c_oflag &= ~OPOST; */ # Curses stört sich dran!
  3654.       newtermio.c_lflag &= ISIG;
  3655.       { var reg1 uintC i;
  3656.         for (i=0; i<NCCS; i++) { newtermio.c_cc[i] = 0; }
  3657.       }
  3658.       newtermio.c_cc[VMIN] = 1;
  3659.       newtermio.c_cc[VTIME] = 0;
  3660.       if (!( ioctl(stdout_handle,TCSETAF,&newtermio) ==0))
  3661.         { if (!(errno==ENOTTY)) { OS_error(); } }
  3662.     }}
  3663.   local void term_unraw()
  3664.     { if (oldterm_initialized)
  3665.         { if (!( ioctl(stdout_handle,TCSETAF,&oldtermio) ==0))
  3666.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3667.     }   }
  3668.   # Manche machen's so:
  3669.     # define crmode()    (_tty.c_lflag &=~ICANON,_tty.c_cc[VMIN] = 1,ioctl(_tty_ch,TCSETAF,&_tty))
  3670.     # define nocrmode()  (_tty.c_lflag |= ICANON,_tty.c_cc[VEOF] = CEOF,stty(_tty_ch,&_tty))
  3671.     # define echo()      (_tty.c_lflag |= ECHO, ioctl(_tty_ch, TCSETA, &_tty))
  3672.     # define noecho()    (_tty.c_lflag &=~ECHO, ioctl(_tty_ch, TCSETA, &_tty))
  3673.     # define nl()        (_tty.c_iflag |= ICRNL,_tty.c_oflag |= ONLCR,ioctl(_tty_ch, TCSETAW, &_tty))
  3674.     # define nonl()      (_tty.c_iflag &=~ICRNL,_tty.c_oflag &=~ONLCR,ioctl(_tty_ch, TCSETAW, &_tty))
  3675. #elif defined(UNIX_TERM_SGTTY)
  3676.   local struct sgttyb oldsgttyb; # ursprünglicher TTY-Modus
  3677.   local struct tchars oldtchars; # ursprüngliche Steuerzeichen
  3678.   #ifdef TIOCSLTC
  3679.   local struct ltchars oldltchars; # ursprüngliche Editierzeichen
  3680.   #endif
  3681.   local void term_raw()
  3682.     { if (!oldterm_initialized)
  3683.         { if (!( ioctl(stdout_handle,TIOCGETP,&oldsgttyb) ==0))
  3684.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3685.           if (!( ioctl(stdout_handle,TIOCGETC,&oldtchars) ==0))
  3686.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3687.           #ifdef TIOCSLTC
  3688.           if (!( ioctl(stdout_handle,TIOCGLTC,&oldltchars) ==0))
  3689.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3690.           #endif
  3691.           oldterm_initialized = TRUE;
  3692.         }
  3693.      {var struct sgttyb newsgttyb;
  3694.       newsgttyb = oldsgttyb;
  3695.       newsgttyb.sg_flags |= CBREAK;
  3696.       newsgttyb.sg_flags &= ~(CRMOD|ECHO|XTABS);
  3697.       if (!( ioctl(stdout_handle,TIOCSETP,&newsgttyb) ==0))
  3698.         { if (!(errno==ENOTTY)) { OS_error(); } }
  3699.      }
  3700.      {var struct tchars newtchars;
  3701.       local var union { char a [sizeof(struct tchars)];
  3702.                         struct tchars b;
  3703.                       }
  3704.                 zero_tchars = {{0,}};
  3705.       newtchars = zero_tchars.b;
  3706.       if (!( ioctl(stdout_handle,TIOCSETC,&newtchars) ==0))
  3707.         { if (!(errno==ENOTTY)) { OS_error(); } }
  3708.      }
  3709.      #ifdef TIOCSLTC
  3710.      {var struct ltchars newltchars;
  3711.       local var union { char a [sizeof(struct ltchars)];
  3712.                         struct ltchars b;
  3713.                       }
  3714.                 zero_ltchars = {{0,}};
  3715.       newltchars = zero_ltchars.b;
  3716.       if (!( ioctl(stdout_handle,TIOCSLTC,&newltchars) ==0))
  3717.         { if (!(errno==ENOTTY)) { OS_error(); } }
  3718.      }
  3719.      #endif
  3720.     }
  3721.   local void term_unraw()
  3722.     { if (oldterm_initialized)
  3723.         { if (!( ioctl(stdout_handle,TIOCSETP,&oldsgttyb) ==0))
  3724.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3725.           if (!( ioctl(stdout_handle,TIOCSETC,&oldtchars) ==0))
  3726.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3727.           #ifdef TIOCSLTC
  3728.           if (!( ioctl(stdout_handle,TIOCSLTC,&oldltchars) ==0))
  3729.             { if (!(errno==ENOTTY)) { OS_error(); } }
  3730.           #endif
  3731.     }   }
  3732.   # Manche machen's so:
  3733.     # define raw()       (_tty.sg_flags|=RAW, stty(_tty_ch,&_tty))
  3734.     # define noraw()     (_tty.sg_flags&=~RAW,stty(_tty_ch,&_tty))
  3735.     # define crmode()    (_tty.sg_flags |= CBREAK, stty(_tty_ch,&_tty))
  3736.     # define nocrmode()  (_tty.sg_flags &= ~CBREAK,stty(_tty_ch,&_tty))
  3737.     # define echo()      (_tty.sg_flags |= ECHO, stty(_tty_ch, &_tty))
  3738.     # define noecho()    (_tty.sg_flags &= ~ECHO, stty(_tty_ch, &_tty))
  3739.     # define nl()        (_tty.sg_flags |= CRMOD,stty(_tty_ch, &_tty))
  3740.     # define nonl()      (_tty.sg_flags &= ~CRMOD, stty(_tty_ch, &_tty))
  3741.     # define savetty()   (gtty(_tty_ch, &_tty), _res_flg = _tty.sg_flags)
  3742.     # define resetty()   (_tty.sg_flags = _res_flg, stty(_tty_ch, &_tty))
  3743. #endif
  3744.  
  3745. # Wir speichern, ob zuletzt term_raw() oder term_unraw() ausgeführt wurde,
  3746. # damit wir bei Programm-Ausstieg zurückschalten können.
  3747. local boolean terminal_raw = FALSE;
  3748.  
  3749. global void terminal_sane (void);
  3750. global void terminal_sane()
  3751.   { if (terminal_raw) { term_unraw(); terminal_raw = FALSE; } }
  3752.  
  3753. LISPFUN(terminal_raw,2,1,norest,nokey,0,NIL)
  3754.   { var reg4 object errorp = popSTACK();
  3755.     var reg2 object flag = popSTACK();
  3756.     var reg1 object stream = popSTACK();
  3757.     if (!streamp(stream)) { fehler_stream(stream); }
  3758.     while (TheStream(stream)->strmtype == strmtype_synonym) # Synonym-Stream verfolgen
  3759.       { var reg3 object sym = TheStream(stream)->strm_synonym_symbol;
  3760.         stream = Symbol_value(sym);
  3761.         if (!streamp(stream)) { fehler_value_stream(sym); }
  3762.       }
  3763.     value1 = NIL;
  3764.     if (TheStream(stream)->strmtype == strmtype_terminal)
  3765.       # der Terminal-Stream
  3766.       { if (!nullp(TheStream(stream)->strm_terminal_isatty))
  3767.           # Terminal
  3768.           { value1 = (terminal_raw ? T : NIL);
  3769.             begin_system_call();
  3770.             if (!nullp(flag))
  3771.               # Umschalten in cbreak/noecho-Modus:
  3772.               { term_raw(); terminal_raw = TRUE; }
  3773.               else
  3774.               # Umschalten in nocbreak/echo-Modus:
  3775.               { term_unraw(); terminal_raw = FALSE; }
  3776.             end_system_call();
  3777.       }   }
  3778.     mv_count=1;
  3779.   }
  3780.  
  3781. #endif # UNIX || RISCOS
  3782.  
  3783. #ifdef AMIGAOS
  3784.  
  3785. # Genauso wie den Terminal-Stream können wir auch beliebige interaktive
  3786. # Handle-Streams (andere Text-Fenster) in den Raw-Modus schalten.
  3787.  
  3788. # Beim Terminal-Stream speichern wir den momentanen Zustand (um so wenig wie
  3789. # möglich umschalten zu müssen), bei den Handle-Streams wird das von screen.lsp
  3790. # übernommen.
  3791. local LONG terminal_mode = 0; # 0 = CON, 1 = RAW
  3792.  
  3793. global void terminal_sane (void);
  3794. global void terminal_sane()
  3795.   { if (!(terminal_mode == 0))
  3796.       { begin_system_call(); SetMode(Input_handle,0); end_system_call();
  3797.         terminal_mode = 0;
  3798.   }   }
  3799.  
  3800. LISPFUN(terminal_raw,2,1,norest,nokey,0,NIL)
  3801.   { var reg5 object errorp = popSTACK();
  3802.     var reg4 object flag = popSTACK();
  3803.     var reg1 object stream = popSTACK();
  3804.     if (!streamp(stream)) { fehler_stream(stream); }
  3805.     while (TheStream(stream)->strmtype == strmtype_synonym) # Synonym-Stream verfolgen
  3806.       { var reg3 object sym = TheStream(stream)->strm_synonym_symbol;
  3807.         stream = Symbol_value(sym);
  3808.         if (!streamp(stream)) { fehler_value_stream(sym); }
  3809.       }
  3810.     if (!(TheStream(stream)->strmflags & strmflags_open_B)) # Stream geschlossen?
  3811.       { fehler_illegal_streamop(S(terminal_raw),stream); }
  3812.     value1 = NIL;
  3813.    {var reg3 LONG new_mode = (nullp(flag) ? 0 : 1);
  3814.     var reg2 LONG success;
  3815.     if ((TheStream(stream)->strmtype == strmtype_terminal) # der Terminal-Stream
  3816.         || (TheStream(stream)->strmtype == strmtype_handle) # ein File-Handle-Stream
  3817.        )
  3818.       { if (!nullp(TheStream(stream)->strm_isatty))
  3819.           { if (TheStream(stream)->strmtype == strmtype_terminal)
  3820.               # Terminal
  3821.               { value1 = (terminal_mode ? T : NIL);
  3822.                 if (new_mode == terminal_mode)
  3823.                   { success = TRUE; }
  3824.                   else
  3825.                   { begin_system_call();
  3826.                     success = SetMode(Input_handle,new_mode);
  3827.                     end_system_call();
  3828.                     terminal_mode = new_mode;
  3829.               }   }
  3830.               else
  3831.               # Handle-Stream
  3832.               { value1 = (TheStream(stream)->strmflags & strmflags_raw_B ? T : NIL);
  3833.                 if (new_mode == ((TheStream(stream)->strmflags >> strmflags_raw_bit_B) & 1))
  3834.                   { success = TRUE; }
  3835.                   else
  3836.                   { begin_system_call();
  3837.                     success = SetMode(TheHandle(TheStream(stream)->strm_ihandle),new_mode);
  3838.                     end_system_call();
  3839.                     if (new_mode)
  3840.                       { TheStream(stream)->strmflags |= strmflags_raw_B; }
  3841.                       else
  3842.                       { TheStream(stream)->strmflags &= ~strmflags_raw_B; }
  3843.               }   }
  3844.           }
  3845.           else
  3846.           { success = TRUE; }
  3847.       }
  3848.       else
  3849.       { success = FALSE; }
  3850.     if (!success && (!eq(errorp,unbound) && !nullp(errorp)))
  3851.       { fehler_terminal_raw(stream); }
  3852.     mv_count=1;
  3853.   }}
  3854.  
  3855. #endif # AMIGAOS
  3856.  
  3857. #endif # UNIX || AMIGAOS || RISCOS
  3858.  
  3859. #endif # (UNIX && !NEXTAPP) || (MSDOS && !WINDOWS && !WIN32_WINDOWS) || AMIGAOS || RISCOS
  3860.  
  3861. #if !((defined(UNIX) && !defined(NEXTAPP)) || defined(AMIGAOS) || defined(RISCOS))
  3862.  
  3863. LISPFUN(terminal_raw,2,1,norest,nokey,0,NIL)
  3864.   { value1 = NIL; mv_count=1; skipSTACK(3); } # Nichts tun
  3865.  
  3866. #endif
  3867.  
  3868. # Liefert einen interaktiven Terminal-Stream.
  3869. # kann GC auslösen
  3870.   local object make_terminal_stream (void);
  3871.   local object make_terminal_stream()
  3872.     { var reg2 object stream = make_terminal_stream_();
  3873.       # Liste der offenen Streams um stream erweitern:
  3874.       pushSTACK(stream);
  3875.       {var reg1 object new_cons = allocate_cons();
  3876.        Car(new_cons) = stream = popSTACK();
  3877.        Cdr(new_cons) = O(open_files);
  3878.        O(open_files) = new_cons;
  3879.       }
  3880.       return stream;
  3881.     }
  3882.  
  3883.  
  3884. # Window-Stream
  3885. # =============
  3886.  
  3887. #ifdef SCREEN
  3888.  
  3889. # Editor-Unterstützung:
  3890. # MSDOS: Übers BIOS.
  3891. # OS/2: Mit der Video-Library von Eberhard Mattes.
  3892. # CURSES: Ein Window-Stream ist im wesentlichen ein Curses-WINDOW.
  3893. #
  3894. # (SCREEN:MAKE-WINDOW)
  3895. #   liefert einen Window-Stream. Solange bis dieser wieder geschlossen wird,
  3896. #   ist das Terminal im cbreak-noecho-Modus; weitere Ein-/Ausgabe über
  3897. #   *terminal-io* sollte in dieser Zeit nicht erfolgen.
  3898. #
  3899. # (SCREEN:WINDOW-SIZE window-stream)
  3900. #   liefert die Größe des Windows,
  3901. #   als 2 Werte: Höhe (= Ymax+1), Breite (= Xmax+1).
  3902. #
  3903. # (SCREEN:WINDOW-CURSOR-POSITION window-stream)
  3904. #   liefert die Position des Cursors im Window
  3905. #   als 2 Werte: Zeile (>=0, <=Ymax, 0=oben), Spalte (>=0, <=Xmax, 0=links).
  3906. #
  3907. # (SCREEN:SET-WINDOW-CURSOR-POSITION window-stream line column)
  3908. #   setzt die Position des Cursors im Window.
  3909. #
  3910. # (SCREEN:CLEAR-WINDOW window-stream)
  3911. #   löscht den Inhalt des Window und setzt den Cursor an die linke obere Ecke
  3912. #
  3913. # (SCREEN:CLEAR-WINDOW-TO-EOT window-stream)
  3914. #   löscht den Inhalt des Window ab Cursor-Position bis Bildschirmende
  3915. #
  3916. # (SCREEN:CLEAR-WINDOW-TO-EOL window-stream)
  3917. #   löscht den Inhalt des Window ab Cursor-Position bis Zeilenende
  3918. #
  3919. # (SCREEN:DELETE-WINDOW-LINE window-stream)
  3920. #   löscht die Cursorzeile, schiebt die Zeilen drunter um 1 nach oben
  3921. #   und löscht die letzte Bildschirmzeile.
  3922. #
  3923. # (SCREEN:INSERT-WINDOW-LINE window-stream)
  3924. #   fügt in der Zeile des Cursors eine neue Zeile ein und schiebt dabei alle
  3925. #   Zeilen ab der Cursorzeile um 1 nach unten.
  3926. #
  3927. # (SCREEN:HIGHLIGHT-ON window-stream)
  3928. #   schaltet "hervorgehobene" Ausgabe ein.
  3929. #
  3930. # (SCREEN:HIGHLIGHT-OFF window-stream)
  3931. #   schaltet "hervorgehobene" Ausgabe wieder aus.
  3932. #
  3933. # (SCREEN:WINDOW-CURSOR-ON window-stream)
  3934. #   macht den Cursor(block) sichtbar.
  3935. #
  3936. # (SCREEN:WINDOW-CURSOR-OFF window-stream)
  3937. #   macht den Cursor(block) wieder unsichtbar.
  3938.  
  3939. # Überprüft, ob das Argument ein Window-Stream ist.
  3940.   local void check_window_stream (object stream);
  3941.   local void check_window_stream(stream)
  3942.     var reg1 object stream;
  3943.     { if (streamp(stream)
  3944.           && (TheStream(stream)->strmtype == strmtype_window)
  3945.          )
  3946.         return;
  3947.       pushSTACK(stream);
  3948.       pushSTACK(TheSubr(subr_self)->name);
  3949.       //: DEUTSCH "~: Argument ~ sollte ein Window-Stream sein."
  3950.       //: ENGLISH "~: argument ~ should be a window stream"
  3951.       //: FRANCAIS "~ : L'argument ~ devrait être un WINDOW-STREAM."
  3952.       fehler(error,GETTEXT("~: argument ~ should be a window stream"));
  3953.     }
  3954.  
  3955. #if defined(MSDOS) && !defined(EMUNIX_PORTABEL) && !defined(WINDOWS) && !defined(WIN32_WINDOWS)
  3956.  
  3957. # Aus der Distribution von ELVIS 1.4, File PC.C :
  3958.  
  3959. # Author:
  3960. #      Guntram Blohm
  3961. #      Buchenstraße 19
  3962. #      W 7904 Erbach
  3963. #      Germany
  3964. #      Tel. ++49-7305-6997
  3965. #      sorry - no regular network connection
  3966.  
  3967. # This file implements the ibm pc bios interface. See IBM documentation
  3968. # for details.
  3969. # If TERM is set upon invocation of CLISP, this code is ignored completely,
  3970. # and the standard termcap functions are used, thus, even not-so-close
  3971. # compatibles can run CLISP. For close compatibles however, bios output
  3972. # is much faster (and permits reverse scrolling, adding and deleting lines,
  3973. # and much more ansi.sys isn't capable of). GB.
  3974.  
  3975. local uintL screentype; # 0 = monochrome, 1 = color
  3976.  
  3977. local uintW screenattr; # screen attribute index
  3978.  
  3979. # Documentation of attributes:
  3980. # bit 7    : foreground character blinking,
  3981. # bit 6..4 : background color,
  3982. # bit 3    : foreground intensity,
  3983. # bit 2..0 : foreground color,
  3984. # color table:
  3985. #   0 black, 1 blue, 2 green, 3 cyan, 4 red, 5 magenta, 6 brown, 7 lightgray,
  3986. # and as foreground color with intensity bit set, it is light:
  3987. #   8 darkgray, ..., E yelloe, F white.
  3988.   #define col_black    0  # schwarz
  3989.   #define col_blue     1  # blau
  3990.   #define col_green    2  # grün
  3991.   #define col_cyan     3  # blaugrün
  3992.   #define col_red      4  # rot
  3993.   #define col_magenta  5  # lila
  3994.   #define col_brown    6  # braun
  3995.   #define col_white    7  # weiß
  3996.   #define col_light(x)  (8 | x)  # hell
  3997.   #define FG(x)  x         # foreground color
  3998.   #define BG(x)  (x << 4)  # background color
  3999. local uintB attr_table[2][5] =
  4000.   { # monochrome:
  4001.     { /* no standout   */  BG(col_black) | FG(col_white),
  4002.       /* standout      */  BG(col_white) | FG(col_black),
  4003.       /* visible bell  */  BG(col_black) | FG(col_light(col_white)),
  4004.       /* underline     */  BG(col_black) | FG(1), # underline
  4005.       /* alt. char set */  BG(col_black) | FG(col_light(col_white)),
  4006.     },
  4007.     # color:
  4008.     { /* no standout   */  BG(col_blue) | FG(col_light(col_white)),
  4009.       /* standout      */  BG(col_blue) | FG(col_light(col_magenta)),
  4010.       /* visible bell  */  BG(col_blue) | FG(col_light(col_brown)),
  4011.       /* underline     */  BG(col_blue) | FG(col_light(col_green)),
  4012.       /* alt. char set */  BG(col_blue) | FG(col_light(col_red)),
  4013.     },
  4014.   };
  4015. local uintB attr; # = attr_table[screentype][screenattr];
  4016.  
  4017. # INT 10 documentation:
  4018. #   INT 10,01 - Set cursor type
  4019. #   INT 10,02 - Set cursor position
  4020. #   INT 10,03 - Read cursor position
  4021. #   INT 10,06 - Scroll active page up
  4022. #   INT 10,07 - Scroll active page down
  4023. #   INT 10,09 - Write character and attribute at cursor
  4024. #   INT 10,0E - Write text in teletype mode
  4025. #   INT 10,0F - Get current video state
  4026. #
  4027. # INT 10,01 - Set Cursor Type
  4028. #     AH = 01
  4029. #     CH = cursor starting scan line (cursor top) (low order 5 bits)
  4030. #     CL = cursor ending scan line (cursor bottom) (low order 5 bits)
  4031. #     returns nothing
  4032. #     - cursor scan lines are zero based
  4033. #     - the following is a list of the cursor scan lines associated with
  4034. #       most common adapters;  screen sizes over 40 lines may differ
  4035. #       depending on adapters.
  4036. #               Line     Starting     Ending      Character
  4037. #       Video   Count    Scan Line    Scan Line   Point Size
  4038. #       CGA      25         06           07           08
  4039. #       MDA      25         0B           0C           0E
  4040. #       EGA      25         06           07           0E
  4041. #       EGA      43       04/06          07           08
  4042. #       VGA      25         0D           0E           10
  4043. #       VGA      40         08           09           0A
  4044. #       VGA      50         06           07           08
  4045. #     - use CX = 2000h to disable cursor
  4046. #
  4047. # INT 10,02 - Set Cursor Position
  4048. #     AH = 02
  4049. #     BH = page number (0 for graphics modes)
  4050. #     DH = row
  4051. #     DL = column
  4052. #     returns nothing
  4053. #     - positions relative to 0,0 origin
  4054. #     - 80x25 uses coordinates 0,0 to 24,79;  40x25 uses 0,0 to 24,39
  4055. #
  4056. # INT 10,03 - Read Cursor Position and Size
  4057. #     AH = 03
  4058. #     BH = video page
  4059. #     on return:
  4060. #     CH = cursor starting scan line (low order 5 bits)
  4061. #     CL = cursor ending scan line (low order 5 bits)
  4062. #     DH = row
  4063. #     DL = column
  4064. #
  4065. # INT 10,06 - Scroll Window Up
  4066. #     AH = 06
  4067. #     AL = number of lines to scroll, previous lines are
  4068. #          blanked, if 0 or AL > screen size, window is blanked
  4069. #     BH = attribute to be used on blank line
  4070. #     CH = row of upper left corner of scroll window
  4071. #     CL = column of upper left corner of scroll window
  4072. #     DH = row of lower right corner of scroll window
  4073. #     DL = column of lower right corner of scroll window
  4074. #     returns nothing
  4075. #     - in video mode 4 (300x200 4 color) on the EGA, MCGA and VGA
  4076. #       this function scrolls page 0 regardless of the current page
  4077. #
  4078. # INT 10,07 - Scroll Window Down
  4079. #     AH = 07
  4080. #     AL = number of lines to scroll, previous lines are
  4081. #          blanked, if 0 or AL > screen size, window is blanked
  4082. #     BH = attribute to be used on blank line
  4083. #     CH = row of upper left corner of scroll window
  4084. #     CL = column of upper left corner of scroll window
  4085. #     DH = row of lower right corner of scroll window
  4086. #     DL = column of lower right corner of scroll window
  4087. #     returns nothing
  4088. #     - in video mode 4 (300x200 4 color) on the EGA, MCGA and VGA
  4089. #       this function scrolls page 0 regardless of the current page
  4090. #
  4091. # INT 10,09 - Write Character and Attribute at Cursor Position
  4092. #     AH = 09
  4093. #     AL = ASCII character to write
  4094. #     BH = display page  (or mode 13h, background pixel value)
  4095. #     BL = character attribute (text) foreground color (graphics)
  4096. #     CX = count of characters to write (CX >= 1)
  4097. #     returns nothing
  4098. #     - does not move the cursor
  4099. #     - in graphics mode (except mode 13h), if BL bit 7=1 then
  4100. #       value of BL is XOR'ed with the background color
  4101. #
  4102. # INT 10,0E - Write Text in Teletype Mode
  4103. #     AH = 0E
  4104. #     AL = ASCII character to write
  4105. #     BH = page number (text modes)
  4106. #     BL = foreground pixel color (graphics modes)
  4107. #     returns nothing
  4108. #     - cursor advances after write
  4109. #     - characters BEL (7), BS (8), LF (A), and CR (D) are
  4110. #       treated as control codes
  4111. #     - for some older BIOS (10/19/81), the BH register must point
  4112. #       to the currently displayed page
  4113. #     - on CGA adapters this function can disable the video signal while
  4114. #       performing the output which causes flitter.
  4115. #
  4116. # INT 10,0F - Get Video State
  4117. #     AH = 0F
  4118. #     on return:
  4119. #     AH = number of screen columns
  4120. #     AL = mode currently set (see ~VIDEO MODES~)
  4121. #     BH = current display page
  4122. #     - video modes greater than 13h on EGA, MCGA and VGA indicate
  4123. #       ~INT 10,0~ was called with the high bit of the mode (AL) set
  4124. #       to 1, meaning the display does not need cleared
  4125.  
  4126. # low-level BIOS interface
  4127.  
  4128. #if defined(DJUNIX) || defined(WATCOM)
  4129.   #define intvideo(in_ptr,out_ptr)  int86(0x10,in_ptr,out_ptr)
  4130. #endif
  4131. #ifdef EMUNIX
  4132.   local void intvideo (union REGS * in_regs, union REGS * out_regs);
  4133.   local void intvideo(in_regs,out_regs)
  4134.     var register union REGS * in_regs;
  4135.     var register union REGS * out_regs;
  4136.     { __asm__ __volatile__ ( "movl 0(%%esi),%%eax ; "
  4137.                              "movl 4(%%esi),%%ebx ; "
  4138.                              "movl 8(%%esi),%%ecx ; "
  4139.                              "movl 12(%%esi),%%edx ; "
  4140.                              "pushl %%edi ; "
  4141.                              ".byte 0xcd ; .byte 0x10 ; "
  4142.                              "popl %%edi ; "
  4143.                              "movl %%eax,0(%%edi) ; "
  4144.                              "movl %%ebx,4(%%edi) ; "
  4145.                              "movl %%ecx,8(%%edi) ; "
  4146.                              "movl %%edx,12(%%edi)"
  4147.                              :                                                         # OUT
  4148.                              : "S" /* %esi */ (in_regs), "D" /* %edi */ (out_regs)     # IN
  4149.                              : "ax","bx","cx","si","di" /* %eax,%ebx,%ecx,%esi,%edi */ # CLOBBER
  4150.                            );
  4151.     }
  4152. #endif
  4153.  
  4154. local void video (uintW ax, uintW* cx, uintW* dx);
  4155. local void video(ax,cx,dx)
  4156.   var reg1 uintW ax;
  4157.   var reg1 uintW* cx;
  4158.   var reg1 uintW* dx;
  4159.   { var union REGS in;
  4160.     var union REGS out;
  4161.     in.regW.ax = ax;
  4162.     { var uintB ah = in.regB.ah;
  4163.       if (ah==0x06 || ah==0x07)
  4164.         { in.regB.bh = attr; }
  4165.         else
  4166.         { in.regB.bh = 0; # "active page"
  4167.           if (ah==0x09 || ah==0x0e) { in.regB.bl = attr; }
  4168.     }   }
  4169.     if (cx) { in.regW.cx = *cx; }
  4170.     if (dx) { in.regW.dx = *dx; }
  4171.     begin_system_call();
  4172.     intvideo(&in,&out);
  4173.     end_system_call();
  4174.     if (dx) { *dx = out.regW.dx; }
  4175.     if (cx) { *cx = out.regW.cx; }
  4176.   }
  4177.  
  4178. global uintW v_cols()
  4179.   { # determine number of screen columns. Also set screentype according
  4180.     # to monochrome/color screen.
  4181.     var union REGS in;
  4182.     var union REGS out;
  4183.     in.regB.ah=0x0f;
  4184.     intvideo(&in,&out); # INT 10,0F : get current video state
  4185.    {var reg1 uintB videomode = out.regB.al & 0x7f;
  4186.     # Text modes are 0,1,2,3,7, and others (depending on the graphics card).
  4187.     # Only modes 0 and 7 are mono. (Well, mode 2 is gray shaded.)
  4188.     screentype = (((videomode==0) || (videomode==7))
  4189.                   ? 0 # monochrome
  4190.                   : 1 # color
  4191.                  );
  4192.     return out.regB.ah;
  4193.   }}
  4194.  
  4195. local uintW v_rows()
  4196.   { # Getting the number of rows is hard. Most screens support 25 only,
  4197.     # EGA/VGA also support 43/50 lines, and some OEM's even more.
  4198.     # Unfortunately, there is no standard bios variable for the number
  4199.     # of lines, and the bios screen memory size is always rounded up
  4200.     # to 0x1000. So, we'll really have to cheat.
  4201.     # When using the screen memory size, keep in mind that each character
  4202.     # byte has an associated attribute byte.
  4203.     # uses:        word at 40:4c contains  memory size
  4204.     #              byte at 40:84           # of rows-1 (sometimes)
  4205.     #              byte at 40:4a           # of columns
  4206.     #if 0 # cannot execute 8086 code!
  4207.     # screen size less then 4K? then we have 25 lines only
  4208.     if (*(uintW far *)(0x0040004CL)<=4096)
  4209.       return 25;
  4210.     # VEGA vga uses the bios byte at 0x40:0x84 for # of rows.
  4211.     # Use that byte, if it makes sense together with memory size.
  4212.     if ((((*(uintB far *)(0x0040004AL)*2*(*(uintB far *)(0x00400084L)+1))
  4213.           +0xfff
  4214.          )
  4215.          &(~0xfff)
  4216.         )
  4217.         == *(uintW far *)(0x0040004CL)
  4218.        )
  4219.       return *(uintB far *)(0x00400084L)+1;
  4220.     #endif
  4221.     # uh oh. Emit LFs until screen starts scrolling.
  4222.     { var uintW line;
  4223.       var uintW oldline = 0;
  4224.       video(0x0200,NULL,&oldline); # INT 10,02 : set cursor position to (0,0)
  4225.       loop
  4226.         { video(0x0e0a,NULL,NULL); # INT 10,0E : write LF in teletype mode
  4227.           video(0x0300,NULL,&line); # INT 10,03 : read cursor position
  4228.           line>>=8;
  4229.           if (oldline==line) { return line+1; }
  4230.           oldline = line;
  4231.   } }   }
  4232.  
  4233. # High-level BIOS interface
  4234.  
  4235. local uintW LINES;
  4236. local uintW COLS;
  4237.  
  4238. void v_up()
  4239.   { # cursor up: determine current position, decrement row, set position
  4240.     var uintW dx;
  4241.     video(0x0300,NULL,&dx); # INT 10,03 : read cursor position
  4242.     dx -= 0x100;
  4243.     video(0x0200,NULL,&dx); # INT 10,02 : set cursor position
  4244.   }
  4245.  
  4246. #if 1
  4247.  
  4248. void v_cb()
  4249.   { # cursor big: set begin scan to end scan - 4
  4250.     var uintW cx;
  4251.     video(0x0300,&cx,NULL); # INT 10,03 : read cursor position
  4252.     cx=((cx&0xff)|(((cx&0xff)-4)<<8));
  4253.     video(0x0100,&cx,NULL); # INT 10,01 : set cursor type
  4254.   }
  4255.  
  4256. void v_cs()
  4257.   { # cursor small: set begin scan to end scan - 1
  4258.     var uintW cx;
  4259.     video(0x0300,&cx,NULL); # INT 10,03 : read cursor position
  4260.     cx=((cx&0xff)|(((cx&0xff)-1)<<8));
  4261.     video(0x0100,&cx,NULL); # INT 10,01 : set cursor type
  4262.   }
  4263.  
  4264. #endif
  4265.  
  4266. void v_ce()
  4267.   { # clear to end: get cursor position and emit the aproppriate number
  4268.     # of spaces, without moving cursor.
  4269.     var uintW cx;
  4270.     var uintW dx;
  4271.     video(0x0300,NULL,&dx); # INT 10,03 : read cursor position
  4272.     cx = COLS - (dx&0xff);
  4273.     video(0x0920,&cx,NULL); # INT 10,09 : write character at cursor, cx times 0x20
  4274.   }
  4275.  
  4276. void v_cl()
  4277.   { # clear screen: clear all and set cursor home
  4278.     var uintW cx = 0;
  4279.     var uintW dx = ((LINES-1)<<8)+(COLS-1);
  4280.     video(0x0600,&cx,&dx); # INT 10,06 : scroll active page up
  4281.     dx = 0;
  4282.     video(0x0200,&cx,&dx); # INT 10,02 : set cursor position
  4283.   }
  4284.  
  4285. void v_cd()
  4286.   { # clear to bottom: get position, clear to eol, clear next line to end
  4287.     var uintW cx;
  4288.     var uintW dx;
  4289.     var uintW dxtmp;
  4290.     video(0x0300,NULL,&dx); # INT 10,03 : read cursor position
  4291.     dxtmp = (dx&0xff00)|(COLS-1);
  4292.     cx = dx;
  4293.     video(0x0600,&cx,&dxtmp); # INT 10,06 : scroll active page up
  4294.     cx = (dx&0xff00)+0x100;
  4295.     dx = ((LINES-1)<<8)+(COLS-1);
  4296.     video(0x0600,&cx,&dx); # INT 10,06 : scroll active page up
  4297.   }
  4298.  
  4299. void v_al()
  4300.   { # add line: scroll rest of screen down
  4301.     var uintW cx;
  4302.     var uintW dx;
  4303.     video(0x0300,NULL,&dx); # INT 10,03 : read cursor position
  4304.     cx = (dx&0xff00);
  4305.     dx = ((LINES-1)<<8)+(COLS-1);
  4306.     video(0x0701,&cx,&dx); # INT 10,06 : scroll active page down
  4307.   }
  4308.  
  4309. void v_dl()
  4310.   { # delete line: scroll rest up
  4311.     var uintW cx;
  4312.     var uintW dx;
  4313.     video(0x0300,NULL,&dx); # INT 10,03 : read cursor position
  4314.     cx = (dx&0xff00) /* + 0x100 */ ;
  4315.     dx = ((LINES-1)<<8)+(COLS-1);
  4316.     video(0x0601,&cx,&dx); # INT 10,06 : scroll active page up
  4317.   }
  4318.  
  4319. void v_sr()
  4320.   { # scroll reverse: scroll whole screen
  4321.     var uintW cx = 0;
  4322.     var uintW dx = ((LINES-1)<<8)+(COLS-1);
  4323.     video(0x0701,&cx,&dx); # INT 10,06 : scroll active page down
  4324.   }
  4325.  
  4326. void v_move(y,x)
  4327.   var uintW y;
  4328.   var uintW x;
  4329.   { # set cursor
  4330.     var uintW dx = (y<<8)+x;
  4331.     video(0x0200,NULL,&dx); # INT 10,02 : set cursor position
  4332.   }
  4333.  
  4334. uintW v_put(ch)
  4335.   var uintW ch;
  4336.   { # put character:
  4337.     # put attribute and char (no scroll!), then update cursor position.
  4338.     var uintW cx=1;
  4339.     ch &= 0xff;
  4340.     if (ch==NL)
  4341.       { video(0x0e00|CR,NULL,NULL); # INT 10,0E : write in teletype mode
  4342.         video(0x0e00|LF,NULL,NULL); # INT 10,0E : write in teletype mode
  4343.       }
  4344.       else
  4345.       { video(0x0900|ch,&cx,NULL); # INT 10,09 : write character at cursor
  4346.        {# cursor right: determine current position, increment column, set position
  4347.         var uintW dx;
  4348.         video(0x0300,NULL,&dx); # INT 10,03 : read cursor position
  4349.         dx += 0x1; # increment column
  4350.         if ((dx & 0xff) == COLS) # at right margin?
  4351.           { dx &= 0xff00; # set column to 0
  4352.             dx += 0x100; # increment row
  4353.             if ((dx >> 8) == LINES) # at bottom margin?
  4354.               goto no_scroll; # do not scroll at right bottom corner!!
  4355.           }
  4356.         video(0x0200,NULL,&dx); # INT 10,02 : set cursor position
  4357.         no_scroll: ;
  4358.       }}
  4359.     return ch;
  4360.   }
  4361.  
  4362. # Lisp-Funktionen:
  4363.  
  4364. # UP: Ein Zeichen auf einen Window-Stream ausgeben.
  4365. # wr_ch_window(&stream,ch);
  4366. # > stream: Window-Stream
  4367. # > ch: auszugebendes Zeichen
  4368.   local void wr_ch_window (object* stream_, object ch);
  4369.   local void wr_ch_window(stream_,ch)
  4370.     var reg2 object* stream_;
  4371.     var reg3 object ch;
  4372.     { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein
  4373.      {var reg1 uintB c = char_code(ch); # Code des Zeichens
  4374.       # Code c übers BIOS auf den Bildschirm ausgeben:
  4375.       v_put(c);
  4376.     }}
  4377.  
  4378. LISPFUNN(make_window,0)
  4379.   { var reg2 object stream =
  4380.       allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+0);
  4381.       # Flags: nur WRITE-CHAR erlaubt
  4382.     # und füllen:
  4383.     var reg1 Stream s = TheStream(stream);
  4384.       s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  4385.       s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  4386.       s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unmöglich
  4387.       s->strm_rd_ch_last = NIL; # Lastchar := NIL
  4388.       s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion
  4389.       s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  4390.       #ifdef STRM_WR_SS
  4391.       s->strm_wr_ss = P(wr_ss_dummy_nogc);
  4392.       #endif
  4393.     LINES = v_rows(); COLS = v_cols();
  4394.     screenattr = 0; attr = attr_table[screentype][screenattr];
  4395.     v_cs();
  4396.     value1 = stream; mv_count=1;
  4397.   }
  4398.  
  4399. # Schließt einen Window-Stream.
  4400.   local void close_window (object stream);
  4401.   local void close_window(stream)
  4402.     var reg1 object stream;
  4403.     { v_cs();
  4404.       attr = BG(col_black) | FG(col_white); v_cl(); # clear screen black
  4405.     }
  4406.  
  4407. LISPFUNN(window_size,1)
  4408.   { check_window_stream(popSTACK());
  4409.     value1 = fixnum(LINES);
  4410.     value2 = fixnum(COLS);
  4411.     mv_count=2;
  4412.   }
  4413.  
  4414. LISPFUNN(window_cursor_position,1)
  4415.   { check_window_stream(popSTACK());
  4416.    {var uintW dx;
  4417.     video(0x0300,NULL,&dx); # INT 10,03 : read cursor position
  4418.     value1 = fixnum(dx>>8);
  4419.     value2 = fixnum(dx&0xff);
  4420.     mv_count=2;
  4421.   }}
  4422.  
  4423. LISPFUNN(set_window_cursor_position,3)
  4424.   { check_window_stream(STACK_2);
  4425.    {var reg2 uintL line = posfixnum_to_L(STACK_1);
  4426.     var reg3 uintL column = posfixnum_to_L(STACK_0);
  4427.     if ((line < (uintL)LINES) && (column < (uintL)COLS))
  4428.       { v_move(line,column); }
  4429.     value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3);
  4430.   }}
  4431.  
  4432. LISPFUNN(clear_window,1)
  4433.   { check_window_stream(popSTACK());
  4434.     v_cl();
  4435.     value1 = NIL; mv_count=0;
  4436.   }
  4437.  
  4438. LISPFUNN(clear_window_to_eot,1)
  4439.   { check_window_stream(popSTACK());
  4440.     v_cd();
  4441.     value1 = NIL; mv_count=0;
  4442.   }
  4443.  
  4444. LISPFUNN(clear_window_to_eol,1)
  4445.   { check_window_stream(popSTACK());
  4446.     v_ce();
  4447.     value1 = NIL; mv_count=0;
  4448.   }
  4449.  
  4450. LISPFUNN(delete_window_line,1)
  4451.   { check_window_stream(popSTACK());
  4452.     v_dl();
  4453.     value1 = NIL; mv_count=0;
  4454.   }
  4455.  
  4456. LISPFUNN(insert_window_line,1)
  4457.   { check_window_stream(popSTACK());
  4458.     v_al();
  4459.     value1 = NIL; mv_count=0;
  4460.   }
  4461.  
  4462. LISPFUNN(highlight_on,1)
  4463.   { check_window_stream(popSTACK());
  4464.     screenattr = 1; attr = attr_table[screentype][screenattr];
  4465.     value1 = NIL; mv_count=0;
  4466.   }
  4467.  
  4468. LISPFUNN(highlight_off,1)
  4469.   { check_window_stream(popSTACK());
  4470.     screenattr = 0; attr = attr_table[screentype][screenattr];
  4471.     value1 = NIL; mv_count=0;
  4472.   }
  4473.  
  4474. LISPFUNN(window_cursor_on,1)
  4475.   { check_window_stream(popSTACK());
  4476.     v_cb();
  4477.     value1 = NIL; mv_count=0;
  4478.   }
  4479.  
  4480. LISPFUNN(window_cursor_off,1)
  4481.   { check_window_stream(popSTACK());
  4482.     v_cs();
  4483.     value1 = NIL; mv_count=0;
  4484.   }
  4485.  
  4486. #endif # MSDOS && !EMUNIX_PORTABEL && !WINDOWS
  4487.  
  4488. #if defined(MSDOS) && (defined(EMUNIX_PORTABEL) && defined(EMUNIX_NEW_8f))
  4489.  
  4490. # Benutze die Video-Library von Eberhard Mattes.
  4491. # Vorzüge:
  4492. # - einfaches Interface,
  4493. # - ruft unter OS/2 die Vio-Funktionen auf, unter DOS wird der Bildschirm-
  4494. #   speicher direkt angesprochen (schnell!), falls einer der Standard-Textmodi
  4495. #   vorliegt, sonst wird das BIOS bemüht (portabel!).
  4496.  
  4497. local uintL screentype; # 0 = monochrome, 1 = color
  4498.  
  4499. local uintB attr_table[2][5] =
  4500.   { # monochrome:
  4501.     { /* no standout   */  BW_NORMAL,
  4502.       /* standout      */  BW_REVERSE,
  4503.       /* visible bell  */  BW_NORMAL | INTENSITY,
  4504.       /* underline     */  BW_UNDERLINE,
  4505.       /* alt. char set */  BW_NORMAL | INTENSITY,
  4506.     },
  4507.     # color:
  4508.     { /* no standout   */  B_BLUE | F_WHITE | INTENSITY,
  4509.       /* standout      */  B_BLUE | F_MAGENTA | INTENSITY,
  4510.       /* visible bell  */  B_BLUE | F_BROWN | INTENSITY,
  4511.       /* underline     */  B_BLUE | F_GREEN | INTENSITY,
  4512.       /* alt. char set */  B_BLUE | F_RED | INTENSITY,
  4513.     },
  4514.   };
  4515.  
  4516. local int cursor_scanlines_start;
  4517. local int cursor_scanlines_end;
  4518.  
  4519. local int LINES; # Anzahl Zeilen
  4520. local int COLS;  # Anzahl Spalten, Anzahl Zeichen pro Zeile
  4521.  
  4522. # UP: Ein Zeichen auf einen Window-Stream ausgeben.
  4523. # wr_ch_window(&stream,ch);
  4524. # > stream: Window-Stream
  4525. # > ch: auszugebendes Zeichen
  4526.   local void wr_ch_window (object* stream_, object ch);
  4527.   local void wr_ch_window(stream_,ch)
  4528.     var reg2 object* stream_;
  4529.     var reg3 object ch;
  4530.     { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein
  4531.      {var reg1 uintB c = char_code(ch); # Code des Zeichens
  4532.       # Code c über die Video-Library auf den Bildschirm ausgeben:
  4533.       if (c==NL)
  4534.         { v_putc(c); }
  4535.         else
  4536.         { var int current_x;
  4537.           var int current_y;
  4538.           v_getxy(¤t_x,¤t_y); # get current cursor position
  4539.           if ((current_x==COLS-1) && (current_y==LINES-1))
  4540.             { v_putn(c,1); } # do not scroll at right bottom corner!!
  4541.             else
  4542.             { v_putc(c); }
  4543.         }
  4544.     }}
  4545.  
  4546. LISPFUNN(make_window,0)
  4547.   { var reg2 object stream =
  4548.       allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+0);
  4549.       # Flags: nur WRITE-CHAR erlaubt
  4550.     # und füllen:
  4551.     var reg1 Stream s = TheStream(stream);
  4552.       s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  4553.       s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  4554.       s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unmöglich
  4555.       s->strm_rd_ch_last = NIL; # Lastchar := NIL
  4556.       s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion
  4557.       s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  4558.       #ifdef STRM_WR_SS
  4559.       s->strm_wr_ss = P(wr_ss_dummy_nogc);
  4560.       #endif
  4561.     v_init(); # Initialisieren
  4562.     #if 1
  4563.     screentype = (v_hardware()==V_MONOCHROME ? 0 : 1); # Bildschirmtyp abfragen
  4564.     #else
  4565.     videomode abfragen wie in vinit.c, dann
  4566.     screentype = (((videomode==0) || (videomode==7))
  4567.                   ? 0 # monochrome
  4568.                   : 1 # color
  4569.                  );
  4570.     #endif
  4571.     v_dimen(&COLS,&LINES); # Bildschirmgröße abfragen
  4572.     v_getctype(&cursor_scanlines_start,&cursor_scanlines_end); # Cursorform abfragen
  4573.     v_attrib(attr_table[screentype][0]); # Highlight off
  4574.     v_ctype(cursor_scanlines_end-1,cursor_scanlines_end); # cursor small
  4575.     value1 = stream; mv_count=1;
  4576.   }
  4577.  
  4578. # Schließt einen Window-Stream.
  4579.   local void close_window (object stream);
  4580.   local void close_window(stream)
  4581.     var reg1 object stream;
  4582.     { v_gotoxy(0,0); # Cursor home
  4583.       v_attrib(screentype==0 ? BW_NORMAL : (B_BLACK | F_WHITE));
  4584.       v_putn(' ',LINES*COLS); # Bildschirm löschen
  4585.       v_ctype(cursor_scanlines_start,cursor_scanlines_end); # Cursorform zurücksetzen
  4586.     }
  4587.  
  4588. LISPFUNN(window_size,1)
  4589.   { check_window_stream(popSTACK());
  4590.     value1 = fixnum((uintW)LINES);
  4591.     value2 = fixnum((uintW)COLS);
  4592.     mv_count=2;
  4593.   }
  4594.  
  4595. LISPFUNN(window_cursor_position,1)
  4596.   { check_window_stream(popSTACK());
  4597.    {var int current_x;
  4598.     var int current_y;
  4599.     v_getxy(¤t_x,¤t_y); # get current cursor position
  4600.     value1 = fixnum((uintW)current_y);
  4601.     value2 = fixnum((uintW)current_x);
  4602.     mv_count=2;
  4603.   }}
  4604.  
  4605. LISPFUNN(set_window_cursor_position,3)
  4606.   { check_window_stream(STACK_2);
  4607.    {var reg2 uintL line = posfixnum_to_L(STACK_1);
  4608.     var reg3 uintL column = posfixnum_to_L(STACK_0);
  4609.     if ((line < (uintL)LINES) && (column < (uintL)COLS))
  4610.       { v_gotoxy((int)column,(int)line); }
  4611.     value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3);
  4612.   }}
  4613.  
  4614. LISPFUNN(clear_window,1)
  4615.   { check_window_stream(popSTACK());
  4616.     v_gotoxy(0,0);
  4617.     #ifdef EMUNIX_NEW_9a
  4618.     v_clear();
  4619.     #else # v_clear() funktioniert bei emx <= 0.8h nicht
  4620.     v_putn(' ',LINES*COLS);
  4621.     #endif
  4622.     value1 = NIL; mv_count=0;
  4623.   }
  4624.  
  4625. LISPFUNN(clear_window_to_eot,1)
  4626.   { check_window_stream(popSTACK());
  4627.    {var int current_x;
  4628.     var int current_y;
  4629.     v_getxy(¤t_x,¤t_y); # get current cursor position
  4630.     v_putn(' ',COLS*(LINES-current_y)-current_x);
  4631.     value1 = NIL; mv_count=0;
  4632.   }}
  4633.  
  4634. LISPFUNN(clear_window_to_eol,1)
  4635.   { check_window_stream(popSTACK());
  4636.     v_clreol();
  4637.     value1 = NIL; mv_count=0;
  4638.   }
  4639.  
  4640. LISPFUNN(delete_window_line,1)
  4641.   { check_window_stream(popSTACK());
  4642.     #ifdef EMUNIX_NEW_8g
  4643.     v_delline(1);
  4644.     #else # Bug in EMX 0.8f umgehen
  4645.     {var int current_x;
  4646.      var int current_y;
  4647.      v_getxy(¤t_x,¤t_y); # get current cursor position
  4648.      v_scroll(0,current_y,COLS-1,LINES-1,1,V_SCROLL_UP);
  4649.     }
  4650.     #endif
  4651.     value1 = NIL; mv_count=0;
  4652.   }
  4653.  
  4654. LISPFUNN(insert_window_line,1)
  4655.   { check_window_stream(popSTACK());
  4656.     v_insline(1);
  4657.     value1 = NIL; mv_count=0;
  4658.   }
  4659.  
  4660. LISPFUNN(highlight_on,1)
  4661.   { check_window_stream(popSTACK());
  4662.     v_attrib(attr_table[screentype][1]);
  4663.     value1 = NIL; mv_count=0;
  4664.   }
  4665.  
  4666. LISPFUNN(highlight_off,1)
  4667.   { check_window_stream(popSTACK());
  4668.     v_attrib(attr_table[screentype][0]);
  4669.     value1 = NIL; mv_count=0;
  4670.   }
  4671.  
  4672. LISPFUNN(window_cursor_on,1)
  4673.   { check_window_stream(popSTACK());
  4674.     # cursor big: set begin scan to end scan - 4
  4675.     v_ctype(cursor_scanlines_end-4,cursor_scanlines_end);
  4676.     value1 = NIL; mv_count=0;
  4677.   }
  4678.  
  4679. LISPFUNN(window_cursor_off,1)
  4680.   { check_window_stream(popSTACK());
  4681.     # cursor small: set begin scan to end scan - 1
  4682.     v_ctype(cursor_scanlines_end-1,cursor_scanlines_end);
  4683.     value1 = NIL; mv_count=0;
  4684.   }
  4685.  
  4686. #endif # MSDOS && (EMUNIX_PORTABEL && EMUNIX_NEW_8f)
  4687.  
  4688. #if defined(MSDOS) && defined(WINDOWS)
  4689.  
  4690. # Benutze ein Text-Fenster, siehe wintext.d.
  4691. extern mywindow text_create (void);
  4692. extern void text_destroy (mywindow w);
  4693. extern void text_cursor_on (mywindow w);
  4694. extern void text_cursor_off (mywindow w);
  4695. extern void get_text_size (mywindow w, int* width, int* height);
  4696. extern void get_text_cursor_position (mywindow w, int* x, int* y);
  4697. extern void set_text_cursor_position (mywindow w, int x, int y);
  4698. extern void text_writechar (mywindow w, char c);
  4699. extern void text_clear (mywindow w);
  4700. extern void text_clear_to_eol (mywindow w);
  4701. extern void text_clear_to_eot (mywindow w);
  4702. extern void text_delete_line (mywindow w);
  4703. extern void text_insert_line (mywindow w);
  4704.  
  4705. #define strm_mywindow  strm_other[0]  # Maschinenpointer auf ein struct mywindow
  4706.  
  4707. # UP: Ein Zeichen auf einen Window-Stream ausgeben.
  4708. # wr_ch_window(&stream,ch);
  4709. # > stream: Window-Stream
  4710. # > ch: auszugebendes Zeichen
  4711.   local void wr_ch_window (object* stream_, object ch);
  4712.   local void wr_ch_window(stream_,ch)
  4713.     var reg2 object* stream_;
  4714.     var reg3 object ch;
  4715.     { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein
  4716.      {var reg1 uintB c = char_code(ch); # Code des Zeichens
  4717.       var reg4 mywindow w = (mywindow)TheMachine(TheStream(*stream_)->strm_mywindow);
  4718.       # Code c auf den Bildschirm ausgeben:
  4719.       if (c=='\t')
  4720.         { var int x,y;
  4721.           do { text_writechar(w,' ');
  4722.                get_text_cursor_position(w,&x,&y);
  4723.              }
  4724.              until ((x % 8) == 0);
  4725.         }
  4726.         else
  4727.         { text_writechar(w,c); }
  4728.     }}
  4729.  
  4730. LISPFUNN(make_window,0)
  4731.   { var reg3 mywindow w = text_create();
  4732.     if (!w)
  4733.       { pushSTACK(TheSubr(subr_self)->name);
  4734.         //: DEUTSCH "~: Kann keinen Window-Stream erzeugen."
  4735.         //: ENGLISH "~: cannot create a window stream"
  4736.         //: FRANCAIS "~ : Ne peux pas établir un WINDOW-STREAM."
  4737.         fehler(error,GETTEXT("~: cannot create a window stream"));
  4738.       }
  4739.    {var reg2 object stream =
  4740.       allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1);
  4741.       # Flags: nur WRITE-CHAR erlaubt
  4742.     # und füllen:
  4743.     var reg1 Stream s = TheStream(stream);
  4744.       s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  4745.       s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  4746.       s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unmöglich
  4747.       s->strm_rd_ch_last = NIL; # Lastchar := NIL
  4748.       s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion
  4749.       s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  4750.       #ifdef STRM_WR_SS
  4751.       s->strm_wr_ss = P(wr_ss_dummy);
  4752.       #endif
  4753.       s->strm_mywindow = type_untype_object(machine_type,w);
  4754.     value1 = stream; mv_count=1;
  4755.   }}
  4756.  
  4757. # Schließt einen Window-Stream.
  4758.   local void close_window (object stream);
  4759.   local void close_window(stream)
  4760.     var reg1 object stream;
  4761.     { var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4762.       text_destroy(w);
  4763.     }
  4764.  
  4765. LISPFUNN(window_size,1)
  4766.   { var reg1 object stream = popSTACK();
  4767.     check_window_stream(stream);
  4768.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4769.     var int current_width;
  4770.     var int current_height;
  4771.     get_text_size(w,¤t_width,¤t_height);
  4772.     value1 = fixnum((uintW)current_height);
  4773.     value2 = fixnum((uintW)current_width);
  4774.     mv_count=2;
  4775.   }}
  4776.  
  4777. LISPFUNN(window_cursor_position,1)
  4778.   { var reg1 object stream = popSTACK();
  4779.     check_window_stream(stream);
  4780.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4781.     var int current_x;
  4782.     var int current_y;
  4783.     get_text_cursor_position(w,¤t_x,¤t_y);
  4784.     value1 = fixnum((uintW)current_y);
  4785.     value2 = fixnum((uintW)current_x);
  4786.     mv_count=2;
  4787.   }}
  4788.  
  4789. LISPFUNN(set_window_cursor_position,3)
  4790.   { var reg1 object stream = STACK_2;
  4791.     check_window_stream(stream);
  4792.    {var reg4 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4793.     var reg2 uintL line = posfixnum_to_L(STACK_1);
  4794.     var reg3 uintL column = posfixnum_to_L(STACK_0);
  4795.     var int current_width;
  4796.     var int current_height;
  4797.     get_text_size(w,¤t_width,¤t_height);
  4798.     if ((line < (uintL)current_height) && (column < (uintL)current_width))
  4799.       { set_text_cursor_position(w,column,line); }
  4800.     value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3);
  4801.   }}
  4802.  
  4803. LISPFUNN(clear_window,1)
  4804.   { var reg1 object stream = popSTACK();
  4805.     check_window_stream(stream);
  4806.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4807.     text_clear(w);
  4808.     value1 = NIL; mv_count=0;
  4809.   }}
  4810.  
  4811. LISPFUNN(clear_window_to_eot,1)
  4812.   { var reg1 object stream = popSTACK();
  4813.     check_window_stream(stream);
  4814.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4815.     text_clear_to_eot(w);
  4816.     value1 = NIL; mv_count=0;
  4817.   }}
  4818.  
  4819. LISPFUNN(clear_window_to_eol,1)
  4820.   { var reg1 object stream = popSTACK();
  4821.     check_window_stream(stream);
  4822.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4823.     text_clear_to_eol(w);
  4824.     value1 = NIL; mv_count=0;
  4825.   }}
  4826.  
  4827. LISPFUNN(delete_window_line,1)
  4828.   { var reg1 object stream = popSTACK();
  4829.     check_window_stream(stream);
  4830.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4831.     text_delete_line(w);
  4832.     value1 = NIL; mv_count=0;
  4833.   }}
  4834.  
  4835. LISPFUNN(insert_window_line,1)
  4836.   { var reg1 object stream = popSTACK();
  4837.     check_window_stream(stream);
  4838.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4839.     text_insert_line(w);
  4840.     value1 = NIL; mv_count=0;
  4841.   }}
  4842.  
  4843. LISPFUNN(highlight_on,1)
  4844.   { check_window_stream(popSTACK());
  4845.     # noch nicht implementiert
  4846.     value1 = NIL; mv_count=0;
  4847.   }
  4848.  
  4849. LISPFUNN(highlight_off,1)
  4850.   { check_window_stream(popSTACK());
  4851.     # noch nicht implementiert
  4852.     value1 = NIL; mv_count=0;
  4853.   }
  4854.  
  4855. LISPFUNN(window_cursor_on,1)
  4856.   { var reg1 object stream = popSTACK();
  4857.     check_window_stream(stream);
  4858.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4859.     text_cursor_on(w);
  4860.     value1 = NIL; mv_count=0;
  4861.   }}
  4862.  
  4863. LISPFUNN(window_cursor_off,1)
  4864.   { var reg1 object stream = popSTACK();
  4865.     check_window_stream(stream);
  4866.    {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow);
  4867.     text_cursor_off(w);
  4868.     value1 = NIL; mv_count=0;
  4869.   }}
  4870.  
  4871. #endif # MSDOS && WINDOWS
  4872.  
  4873. #if defined(WIN32_UNIX) || defined(WIN32_DOS)  || (defined(MAYBE_NEXTAPP) && defined(NEXTAPP))
  4874.  
  4875. # Fehlermeldung.
  4876.   nonreturning_function(local, fehler_screen, (void));
  4877.   local void fehler_screen()
  4878.     { pushSTACK(TheSubr(subr_self)->name);
  4879.       //: DEUTSCH "~: Paket SCREEN ist nicht implementiert."
  4880.       //: ENGLISH "~: package SCREEN is not implemented"
  4881.       //: FRANCAIS "~ : Le paquet SCREEN n'est pas implémenté."
  4882.       fehler(error,GETTEXT("~: package SCREEN is not implemented"));
  4883.     }
  4884. #endif
  4885.  
  4886. #if defined(WIN32_UNIX) || defined(WIN32_DOS)
  4887.  
  4888. LISPFUNN(make_window,0)
  4889.   { fehler_screen(); }
  4890.  
  4891. #define close_window(stream)  fehler_screen()
  4892.  
  4893. LISPFUNN(window_size,1)
  4894.   { fehler_screen(); }
  4895.  
  4896. LISPFUNN(window_cursor_position,1)
  4897.   { fehler_screen(); }
  4898.  
  4899. LISPFUNN(set_window_cursor_position,3)
  4900.   { fehler_screen(); }
  4901.  
  4902. LISPFUNN(clear_window,1)
  4903.   { fehler_screen(); }
  4904.  
  4905. LISPFUNN(clear_window_to_eot,1)
  4906.   { fehler_screen(); }
  4907.  
  4908. LISPFUNN(clear_window_to_eol,1)
  4909.   { fehler_screen(); }
  4910.  
  4911. LISPFUNN(delete_window_line,1)
  4912.   { fehler_screen(); }
  4913.  
  4914. LISPFUNN(insert_window_line,1)
  4915.   { fehler_screen(); }
  4916.  
  4917. LISPFUNN(highlight_on,1)
  4918.   { fehler_screen(); }
  4919.  
  4920. LISPFUNN(highlight_off,1)
  4921.   { fehler_screen(); }
  4922.  
  4923. LISPFUNN(window_cursor_on,1)
  4924.   { fehler_screen(); }
  4925.  
  4926. LISPFUNN(window_cursor_off,1)
  4927.   { fehler_screen(); }
  4928.  
  4929. #endif
  4930.  
  4931. #if (defined(UNIX) && !defined(NEXTAPP)) || (defined(EMUNIX_PORTABEL) && defined(EMUNIX_OLD_8e)) || defined(RISCOS)
  4932.  
  4933. # ------------------------------------------------------------------------------
  4934.  
  4935. # Routinen zur Emulation aller VT100-Features auf normalen Terminals.
  4936. # Idee: Oliver Laumann 1987
  4937.  
  4938. # Benutzt die TERMCAP-Library:
  4939.   # Besorgt die Capability-Informationen zu Terminal-Type name.
  4940.   # Ergebnis: 1 falls OK, 0 falls name unbekannt, -1 bei sonstigem Fehler.
  4941.     extern int tgetent (char* bp, char* name);
  4942.   # Besorgt den Wert einer numerischen Capability (-1 falls nicht vorhanden).
  4943.     extern int tgetnum (char* id);
  4944.   # Besorgt den Wert einer booleschen Capability (1 falls vorhanden, 0 sonst).
  4945.     extern int tgetflag (char* id);
  4946.   # Besorgt den Wert einer String-wertigen Capability und (falls area/=NULL)
  4947.   # kopiert es nach *area und rückt dabei *area weiter.
  4948.     extern char* tgetstr (char* id, char** area);
  4949.   # Besorgt den String, der eine Cursor-Positionierung an Stelle (destcol,destline)
  4950.   # bewirkt. (Nötig, da tgetstr("cm") ein spezielles Format hat!)
  4951.     extern char* tgoto (char* cm, int destcol, int destline);
  4952.   # Führt eine String-Capability aus. Dazu wird für jedes Character die
  4953.   # Ausgabefunktion *outcharfun aufgerufen. (Nötig, da String-Capabilities
  4954.   # Padding-Befehle enthalten können!)
  4955.     extern char* tputs (char* cp, int affcnt, void (*outcharfun)());
  4956.  
  4957. # Einstellbare Wünsche:
  4958.   #define WANT_INSERT  FALSE  # Insert-Modus
  4959.   #define WANT_SAVE    FALSE  # Save/Restore für die Cursor-Position
  4960.   #define WANT_ATTR    TRUE   # Attribute (fett, reverse etc.)
  4961.   #define WANT_CHARSET FALSE  # Fonts = Charsets
  4962.   # zu definierende Funktionen:
  4963.   #define WANT_CURSOR_MOVE         FALSE
  4964.   #define WANT_CURSOR_BACKSPACE    FALSE
  4965.   #define WANT_CURSOR_RETURN       TRUE
  4966.   #define WANT_CURSOR_LINEFEED     TRUE
  4967.   #define WANT_CURSOR_REVLINEFEED  FALSE
  4968.   #define WANT_CLEAR_SCREEN        TRUE
  4969.   #define WANT_CLEAR_FROM_BOS      FALSE
  4970.   #define WANT_CLEAR_TO_EOS        TRUE
  4971.   #define WANT_CLEAR_LINE          FALSE
  4972.   #define WANT_CLEAR_FROM_BOL      FALSE
  4973.   #define WANT_CLEAR_TO_EOL        TRUE
  4974.   #define WANT_INSERT_1CHAR        FALSE
  4975.   #define WANT_INSERT_CHAR         FALSE
  4976.   #define WANT_INSERT_LINE         TRUE
  4977.   #define WANT_DELETE_CHAR         FALSE
  4978.   #define WANT_DELETE_LINE         TRUE
  4979.   #define WANT_OUTPUT_1CHAR        TRUE
  4980.   # kleine Korrekturen:
  4981.   #define WANT_CLEAR_SCREEN        TRUE
  4982.   #if WANT_OUTPUT_1CHAR && WANT_INSERT
  4983.   #define WANT_INSERT_1CHAR        TRUE
  4984.   #endif
  4985.  
  4986. # Ausgabe eines Zeichens, direkt.
  4987.   local void out_char (uintB c);
  4988.   local void out_char(c)
  4989.     var uintB c;
  4990.     {
  4991.       #ifdef GRAPHICS_SWITCH
  4992.       switch_text_mode();
  4993.       #endif
  4994.       begin_system_call();
  4995.       restart_it:
  4996.      {var reg1 int ergebnis = write(stdout_handle,&c,1); # Zeichen auszugeben versuchen
  4997.       if (ergebnis<0)
  4998.         { if (errno==EINTR) goto restart_it;
  4999.           OS_error(); # Error melden
  5000.         }
  5001.       if (ergebnis==0) # nicht erfolgreich?
  5002.         { pushSTACK(var_stream(S(terminal_io),0)); # Wert für Slot PATHNAME von FILE-ERROR
  5003.           //: DEUTSCH "Kann nichts auf Standard-Output ausgeben."
  5004.           //: ENGLISH "cannot output to standard output"
  5005.           //: FRANCAIS "Ne peut rien écrire sur la sortie principale."
  5006.           fehler(file_error,GETTEXT("cannot output to standard output"));
  5007.         }
  5008.       end_system_call();
  5009.     }}
  5010.  
  5011. # Ausgabe eines Capability-Strings.
  5012.   local void out_capstring (char* s);
  5013.   local void out_capstring(s)
  5014.     var reg1 char* s;
  5015.     { if (!(s==NULL)) # Absichern gegen nicht vorhandene Capability
  5016.         { tputs(s,1,(void (*)()) &out_char); }
  5017.     }
  5018.  
  5019. # Ausgabe eines Capability-Strings mit einem Argument.
  5020.   local void out_cap1string (char* s, int arg);
  5021.   local void out_cap1string(s,arg)
  5022.     var reg1 char* s;
  5023.     var reg2 int arg;
  5024.     { if (!(s==NULL)) # Absichern gegen nicht vorhandene Capability
  5025.         { tputs(tgoto(s,0,arg),1,(void (*)()) &out_char); }
  5026.     }
  5027.  
  5028. # Kosten der Ausführung einer Capability:
  5029.   #define EXPENSIVE 1000
  5030.   local uintC cost_counter; # Zähler
  5031.   # Funktion, die nicht ausgibt, sondern nur zählt:
  5032.   local void count_char (char c);
  5033.   local void count_char(c)
  5034.     var reg1 char c;
  5035.     { cost_counter++; }
  5036.   # Berechnet die Kosten der Ausgabe einer Capability:
  5037.   local uintC cap_cost (char* s);
  5038.   local uintC cap_cost(s)
  5039.     var reg1 char* s;
  5040.     { if (s==NULL)
  5041.         { return EXPENSIVE; } # Capability nicht vorhanden
  5042.         else
  5043.         { cost_counter = 0;
  5044.           tputs(s,1,(void (*)()) &count_char);
  5045.           return cost_counter;
  5046.         }
  5047.     }
  5048.  
  5049. # Buffer für von mir benötigte Capabilities und Pointer da hinein:
  5050.   local char tentry[4096];
  5051.   local char* tp = &tentry[0];
  5052. # Einige ausgewählte Capabilities (NULL oder Pointer in tentry hinein):
  5053.   # Insert-Modus:
  5054.   local char* IMcap; # Enter Insert Mode
  5055.   local uintC IMcost;
  5056.   local char* EIcap; # End Insert Mode
  5057.   local uintC EIcost;
  5058.   #if WANT_ATTR
  5059.   # Attribute:
  5060.   local char* SOcap; # Enter standout mode
  5061.   local char* SEcap; # End standout mode
  5062.   local char* UScap; # Enter underline mode
  5063.   local char* UEcap; # End underline mode
  5064.   local char* MBcap; # Turn on blinking
  5065.   local char* MDcap; # Turn on bold (extra-bright) mode
  5066.   local char* MHcap; # Turn on half-bright mode
  5067.   local char* MRcap; # Turn on reverse mode
  5068.   local char* MEcap; # Turn off all attributes
  5069.   #endif
  5070.   #if WANT_CHARSET
  5071.   # Zeichensätze:
  5072.   local boolean ISO2022; # ob Zeichensatzwechsel nach ISO2022 unterstützt wird
  5073.   #endif
  5074.   # Cursor-Bewegung:
  5075.   local char* CMcap; # Cursor motion, allgemeine Cursor-Positionierung
  5076.   local char* TIcap; # Initialize mode where CM is usable
  5077.   local char* TEcap; # Exit mode where CM is usable
  5078.   local char* BCcap; # Backspace Cursor
  5079.   local uintC BCcost;
  5080.   local char* NDcap; # cursor right
  5081.   local uintC NDcost;
  5082.   local char* DOcap; # cursor down
  5083.   local uintC DOcost;
  5084.   local char* UPcap; # cursor up
  5085.   local uintC UPcost;
  5086.   local char* NLcap; # Newline
  5087.   local char* CRcap; # Carriage Return
  5088.   local uintC CRcost;
  5089.   # Scrolling:
  5090.   local char* CScap; # change scroll region
  5091.   #if WANT_DELETE_LINE
  5092.   local char* SFcap; # Scroll (text up)
  5093.   #endif
  5094.   #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
  5095.   local char* SRcap; # Scroll reverse (text down)
  5096.   #endif
  5097.   # Sonstige:
  5098.   local char* IScap; # Terminal Initialization 2
  5099. #  local char* BLcap; # Bell
  5100. #  local char* VBcap; # Visible Bell (Flash)
  5101.   local char* CLcap; # clear screen, cursor home
  5102.   #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL
  5103.   local char* CEcap; # clear to end of line
  5104.   #endif
  5105.   #if WANT_CLEAR_TO_EOS
  5106.   local char* CDcap; # clear to end of screen
  5107.   #endif
  5108.   #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
  5109.   local char* ALcap; # add new blank line
  5110.   #endif
  5111.   #if WANT_DELETE_LINE
  5112.   local char* DLcap; # delete line
  5113.   #endif
  5114.   #if WANT_DELETE_CHAR
  5115.   local char* DCcap; # delete character
  5116.   #endif
  5117.   #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
  5118.   local char* ICcap; # insert character
  5119.   #endif
  5120.   #if WANT_INSERT_CHAR
  5121.   local char* CICcap; # insert count characters
  5122.   #endif
  5123.   #if WANT_INSERT_LINE
  5124.   local char* CALcap; # add count blank lines
  5125.   #endif
  5126.   #if WANT_DELETE_CHAR
  5127.   local char* CDCcap; # delete count chars
  5128.   #endif
  5129.   #if WANT_DELETE_LINE
  5130.   local char* CDLcap; # delete count lines
  5131.   #endif
  5132.   local boolean AM; # automatic margins, ob an rechterer unterer Ecke scrollt
  5133.   local int rows; # Anzahl der Zeilen des Bildschirms, >0
  5134.   local int cols; # Anzahl der Spalten des Bildschirms, >0
  5135.   # Obere Zeile ist Zeile 0, untere Zeile ist Zeile rows-1.
  5136.   # Linke Spalte ist Spalte 0, rechte Spalte ist Spalte cols-1.
  5137.   #if WANT_ATTR || WANT_CHARSET
  5138.   local uintB* null; # Pointer auf cols Nullen
  5139.   #endif
  5140.   local uintB* blank; # Pointer auf cols Blanks
  5141.  
  5142. # Beschreibung einer Terminal-Ausgabe-Einheit:
  5143. typedef struct { uintB** image; # image[y][x] ist das Zeichen an Position (x,y)
  5144.                  #if WANT_ATTR
  5145.                  uintB** attr;  # attr[y][x] ist sein Attribut
  5146.                  uintB curr_attr; # welches Attribut gerade aktuell ist
  5147.                  #endif
  5148.                  #if WANT_CHARSET
  5149.                  uintB** font;  # font[y][x] ist sein Font (Charset)
  5150.                  #define charset_count 4
  5151.                  uintB charsets[charset_count]; # Tabelle von Zeichensätzen
  5152.                  uintC curr_charset; # welcher der Zeichensätze gerade aktuell ist
  5153.                                      # (>=0, <charset_count)
  5154.                  #endif
  5155.                  int x; # Cursorposition (>=0, <=cols)
  5156.                  int y; # Cursorposition (>=0, <rows)
  5157.                         # (Bei x=cols wird der Cursor in Spalte cols-1 dargestellt.)
  5158.                  int top, bot; # Scroll-Region = Zeilen y mit top <= y <= bot,
  5159.                                # es ist 0 <= top <= bot <= rows-1.
  5160.                  #if WANT_INSERT
  5161.                  boolean insert; # ob die Ausgabe-Einheit im Insert-Modus arbeitet
  5162.                                  # (dann ist das Terminal meist im Insert-Modus)
  5163.                  #endif
  5164.                  #if WANT_SAVE
  5165.                  boolean saved;
  5166.                  #if WANT_ATTR
  5167.                  uintB saved_curr_attr;
  5168.                  #endif
  5169.                  #if WANT_CHARSET
  5170.                  uintB saved_charsets[charset_count];
  5171.                  uintC saved_curr_charset;
  5172.                  #endif
  5173.                  int saved_x, saved_y;
  5174.                  #endif
  5175.                }
  5176.         win;
  5177.  
  5178. # aktuelle Ausgabe-Einheit:
  5179.   local win currwin; # es gibt nur eine!
  5180.   #define curr (&currwin)
  5181.  
  5182. #if WANT_INSERT
  5183.  
  5184. # Insert-Modus ein- bzw. ausschalten:
  5185.   # Flag, ob das Terminal im Insert-Modus ist (falls es einen solchen gibt):
  5186.   local boolean insert;
  5187.   local void set_insert_mode (boolean flag);
  5188.   local void set_insert_mode(flag)
  5189.     var reg1 boolean flag;
  5190.     { if (flag)
  5191.         # Einschalten
  5192.         { if (!insert) { out_capstring(IMcap); } }
  5193.         else
  5194.         # Ausschalten
  5195.         { if (insert) { out_capstring(EIcap); } }
  5196.       insert = flag;
  5197.     }
  5198.  
  5199. #endif
  5200.  
  5201. #if WANT_ATTR
  5202.  
  5203. # Ausgabe-Attribute des Terminals umschalten:
  5204.   local uintB term_attr; # aktuelle Attribute des Terminals
  5205.   # mögliche Attribute sind ein ODER aus:
  5206.     #define A_SO    bit(0)  # Standout mode
  5207.     #define A_US    bit(1)  # Underscore mode
  5208.     #define A_BL    bit(2)  # Blinking
  5209.     #define A_BD    bit(3)  # Bold mode
  5210.     #define A_DI    bit(4)  # Dim mode
  5211.     #define A_RV    bit(5)  # Reverse mode
  5212.   local void change_attr (uintB new_attr);
  5213.   local void change_attr(new_attr)
  5214.     var reg1 uintB new_attr;
  5215.     { var reg2 uintB old_attr = term_attr;
  5216.       if (old_attr == new_attr) { return; }
  5217.       if (   ((old_attr & A_SO) && !(new_attr & A_SO))
  5218.           || ((old_attr & A_US) && !(new_attr & A_US))
  5219.           || ((old_attr & A_BL) && !(new_attr & A_BL))
  5220.           || ((old_attr & A_BD) && !(new_attr & A_BD))
  5221.           || ((old_attr & A_DI) && !(new_attr & A_DI))
  5222.           || ((old_attr & A_RV) && !(new_attr & A_RV))
  5223.          )
  5224.         # Muß Attribute ausschalten.
  5225.         { out_capstring(UEcap); # alle aus
  5226.           out_capstring(SEcap);
  5227.           out_capstring(MEcap);
  5228.           if (new_attr & A_SO) out_capstring(SOcap); # und selektiv wieder an
  5229.           if (new_attr & A_US) out_capstring(UScap);
  5230.           if (new_attr & A_BL) out_capstring(MBcap);
  5231.           if (new_attr & A_BD) out_capstring(MDcap);
  5232.           if (new_attr & A_DI) out_capstring(MHcap);
  5233.           if (new_attr & A_RV) out_capstring(MRcap);
  5234.         }
  5235.         else
  5236.         { # selektiv einschalten:
  5237.           if ((new_attr & A_SO) && !(old_attr & A_SO)) out_capstring(SOcap);
  5238.           if ((new_attr & A_US) && !(old_attr & A_US)) out_capstring(UScap);
  5239.           if ((new_attr & A_BL) && !(old_attr & A_BL)) out_capstring(MBcap);
  5240.           if ((new_attr & A_BD) && !(old_attr & A_BD)) out_capstring(MDcap);
  5241.           if ((new_attr & A_DI) && !(old_attr & A_DI)) out_capstring(MHcap);
  5242.           if ((new_attr & A_RV) && !(old_attr & A_RV)) out_capstring(MRcap);
  5243.         }
  5244.       term_attr = new_attr;
  5245.     }
  5246.  
  5247. #endif
  5248.  
  5249. #if WANT_CHARSET
  5250.  
  5251. # Ausgabe-Zeichensatz des Terminals umschalten:
  5252.   local uintB term_charset; # aktueller Zeichensatz des Terminals
  5253.                             # = curr->charsets[curr->curr_charset]
  5254.   #define ASCII 0  # Abkürzung für den Zeichensatz 'B'
  5255.   local void change_charset (uintB new);
  5256.   local void change_charset(new)
  5257.     var reg1 uintB new;
  5258.     { if (term_charset==new) { return; }
  5259.       if (ISO2022)
  5260.         { out_char(ESC); out_char('('); out_char(new==ASCII ? 'B' : new); } /*)*/
  5261.       term_charset = new;
  5262.     }
  5263.   # Charset Nr. n auf c schalten:
  5264.   local void choose_charset (uintB c, uintC n);
  5265.   local void choose_charset(c,n)
  5266.     var reg1 uintB c;
  5267.     var reg2 uintC n;
  5268.     { if (c=='B') { c = ASCII; }
  5269.       if (curr->charsets[n] == c) return;
  5270.       curr->charsets[n] = c;
  5271.       if (curr->curr_charset == n) # der aktuelle?
  5272.         { change_charset(c); }
  5273.     }
  5274.   # Charset Nr. n aktuell machen:
  5275.   local void set_curr_charset (uintC n);
  5276.   local void set_curr_charset(n)
  5277.     var reg1 uintC n;
  5278.     { if (curr->curr_charset == n) return;
  5279.       curr->curr_charset = n;
  5280.       change_charset(curr->charsets[n]);
  5281.     }
  5282.  
  5283. #endif
  5284.  
  5285. # Kosten des Neu-Anzeigens von Zeile y, Zeichen x1..x2-1 berechnen:
  5286. # (0 <= y < rows, 0 <= x1 <= x2 <= cols)
  5287.   local uintC rewrite_cost (int y, int x1, int x2);
  5288.   local uintC rewrite_cost(y,x1,x2)
  5289.     var reg4 int y;
  5290.     var reg6 int x1;
  5291.     var reg5 int x2;
  5292.     { if (AM && (y==rows-1) && (x2==cols)) # rechte untere Ecke kann scrollen?
  5293.         { return EXPENSIVE; }
  5294.      {var reg1 int dx = x2-x1;
  5295.       if (dx==0) { return 0; }
  5296.       #if WANT_ATTR
  5297.       {var reg2 uintB* p = &curr->attr[y][x1];
  5298.        var reg3 uintC count;
  5299.        dotimespC(count,dx,
  5300.          { if (!(*p++ == term_attr)) # Attribut-Wechsel nötig?
  5301.              { return EXPENSIVE; }
  5302.          });
  5303.       }
  5304.       #endif
  5305.       #if WANT_CHARSET
  5306.       {var reg2 uintB* p = &curr->font[y][x1];
  5307.        var reg3 uintC count;
  5308.        dotimespC(count,dx,
  5309.          { if (!(*p++ == term_charset)) # Font-Wechsel nötig?
  5310.              { return EXPENSIVE; }
  5311.          });
  5312.       }
  5313.       #endif
  5314.       {var reg2 uintC cost = dx;
  5315.        #if WANT_INSERT
  5316.        if (curr->insert) { cost += EIcost + IMcost; }
  5317.        #endif
  5318.        return cost;
  5319.     }}}
  5320.  
  5321. # Bewegt den Cursor von Position (y1,x1) an Position (y2,x2).
  5322. # (x1,y1) = (-1,-1) falls aktuelle Position unbekannt.
  5323.   local void gofromto (int y1, int x1, int y2, int x2);
  5324.   local void gofromto(y1,x1,y2,x2)
  5325.     var reg10 int y1;
  5326.     var reg10 int x1;
  5327.     var reg10 int y2;
  5328.     var reg9 int x2;
  5329.     { if (x2==cols) # Cursor an den rechten Rand?
  5330.         { x2--; out_capstring(tgoto(CMcap,x2,y2)); return; } # Bleibt in der letzten Spalte
  5331.       if (x1==cols) # Cursor ist am rechten Rand?
  5332.         { out_capstring(tgoto(CMcap,x2,y2)); return; } # absolut adressieren
  5333.      {var reg4 int dy = y2-y1;
  5334.       var reg5 int dx = x2-x1;
  5335.       if ((dy==0) && (dx==0)) { return; }
  5336.       if ((y1==-1) || (x1==-1) || (y2 > curr->bot) || (y2 < curr->top))
  5337.         { out_capstring(tgoto(CMcap,x2,y2)); return; }
  5338.       { var reg7 enum { MX_NONE, MX_LE, MX_RI, MX_RW, MX_CR } mx = MX_NONE;
  5339.         var reg8 enum { MY_NONE, MY_UP, MY_DO } my = MY_NONE;
  5340.         # Möglichkeit 1: mit CMcap
  5341.         var reg6 uintC CMcost = cap_cost(tgoto(CMcap,x2,y2));
  5342.         # Möglichkeit 2: mit getrennten x- und y-Bewegungen:
  5343.         var reg1 uintC xycost = 0;
  5344.         if (dx > 0)
  5345.           { var reg2 uintC cost1 = rewrite_cost(y1,x1,x2);
  5346.             var reg3 uintC cost2 = dx * NDcost;
  5347.             if (cost1 < cost2)
  5348.               { mx = MX_RW; xycost += cost1; }
  5349.               else
  5350.               { mx = MX_RI; xycost += cost2; }
  5351.           }
  5352.         elif (dx < 0)
  5353.           { mx = MX_LE; xycost += (-dx) * BCcost; }
  5354.         if (!(dx==0))
  5355.           { var reg2 uintC cost1 = CRcost + rewrite_cost(y1,0,x2);
  5356.             if (cost1 < xycost) { mx = MX_CR; xycost = cost1; }
  5357.           }
  5358.         if (dy > 0)
  5359.           { my = MY_DO; xycost += dy * DOcost; }
  5360.         elif (dy < 0)
  5361.           { my = MY_UP; xycost += (-dy) * UPcost; }
  5362.         if (xycost >= CMcost)
  5363.           { out_capstring(tgoto(CMcap,x2,y2)); return; }
  5364.         if (!(mx==MX_NONE))
  5365.           { if ((mx==MX_LE) || (mx==MX_RI))
  5366.               { var reg2 char* s;
  5367.                 if (mx==MX_LE) { dx = -dx; s = BCcap; } else { s = NDcap; }
  5368.                 do { out_capstring(s); } until (--dx == 0);
  5369.               }
  5370.               else
  5371.               { if (mx==MX_CR) { out_capstring(CRcap); x1=0; }
  5372.                 # Hiervon wurden die Kosten mit rewrite_cost berechnet:
  5373.                 if (x1<x2)
  5374.                   {
  5375.                     #if WANT_INSERT
  5376.                     if (curr->insert) { set_insert_mode(FALSE); }
  5377.                     #endif
  5378.                     {var reg2 uintB* ptr = &curr->image[y1][x1];
  5379.                      var reg3 uintC count;
  5380.                      dotimespC(count,x2-x1, { out_char(*ptr++); });
  5381.                     }
  5382.                     #if WANT_INSERT
  5383.                     if (curr->insert) { set_insert_mode(TRUE); }
  5384.                     #endif
  5385.               }   }
  5386.           }
  5387.         if (!(my==MY_NONE))
  5388.           { var reg2 char* s;
  5389.             if (my==MY_UP) { dy = -dy; s = UPcap; } else { s = DOcap; }
  5390.             do { out_capstring(s); } until (--dy == 0);
  5391.           }
  5392.     }}}
  5393.  
  5394. # Redisplay
  5395.   # lokale Variablen:
  5396.   local int last_x;
  5397.   local int last_y;
  5398.   # Eine Zeile neu anzeigen, die sich verändert haben kann:
  5399.     # nur benötigte Parameter wirklich übergeben:
  5400.     #if WANT_ATTR && WANT_CHARSET
  5401.       #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,ofp,nsp,nap,nfp,y,x1,x2)
  5402.       #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,ofp,nsp,nap,nfp,y,x1,x2)
  5403.     #endif
  5404.     #if !WANT_ATTR && WANT_CHARSET
  5405.       #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,ofp,nsp,nfp,y,x1,x2)
  5406.       #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,ofp,nsp,nfp,y,x1,x2,oap,nap)
  5407.     #endif
  5408.     #if WANT_ATTR && !WANT_CHARSET
  5409.       #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,nsp,nap,y,x1,x2)
  5410.       #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,nsp,nap,y,x1,x2,ofp,nfp)
  5411.     #endif
  5412.     #if !WANT_ATTR && !WANT_CHARSET
  5413.       #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,nsp,y,x1,x2)
  5414.       #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,nsp,y,x1,x2,oap,ofp,nap,nfp)
  5415.     #endif
  5416.     #ifdef ANSI
  5417.     #undef RHparms
  5418.     #define RHparms  RHargs  # korrekt deklarieren
  5419.     local void redisplay_help RHparms (uintB* osp, uintB* oap, uintB* ofp, # old
  5420.                                        uintB* nsp, uintB* nap, uintB* nfp, # new
  5421.                                        int y, int x1, int x2); # Zeile y, von x1 bis x2-1
  5422.     #endif
  5423.     local void redisplay_help RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2)
  5424.       var reg6 uintB* osp;
  5425.       var reg4 uintB* oap;
  5426.       var reg5 uintB* ofp;
  5427.       var reg3 uintB* nsp;
  5428.       var reg1 uintB* nap;
  5429.       var reg2 uintB* nfp;
  5430.       var reg9 int y;
  5431.       var reg10 int x1;
  5432.       var reg10 int x2;
  5433.       { if (AM && (y == rows-1) && (x2 == cols)) { x2--; }
  5434.        {
  5435.         #if WANT_ATTR
  5436.         var reg8 uintB a = term_attr; # letztes Attribut
  5437.         #endif
  5438.         #if WANT_CHARSET
  5439.         var reg8 uintB f = term_charset; # letzter Font
  5440.         #endif
  5441.         var reg7 int x = x1;
  5442.         osp = &osp[x1]; nsp = &nsp[x1];
  5443.         #if WANT_ATTR
  5444.         oap = &oap[x1]; nap = &nap[x1];
  5445.         #endif
  5446.         #if WANT_CHARSET
  5447.         ofp = &ofp[x1]; nfp = &nfp[x1];
  5448.         #endif
  5449.         while (x < x2)
  5450.           { if (!((*nsp==*osp)
  5451.                   #if WANT_ATTR
  5452.                   && (*nap==*oap) && (*nap==a)
  5453.                   #endif
  5454.                   #if WANT_CHARSET
  5455.                   && (*nfp==*nap) && (*nfp==f)
  5456.                   #endif
  5457.                ) )
  5458.               { gofromto(last_y,last_x,y,x);
  5459.                 #if WANT_ATTR
  5460.                 a = *nap; if (!(a==term_attr)) { change_attr(a); }
  5461.                 #endif
  5462.                 #if WANT_CHARSET
  5463.                 f = *nfp; if (!(f==term_charset)) { change_charset(f); }
  5464.                 #endif
  5465.                 out_char(*nsp);
  5466.                 last_y = y; last_x = x+1;
  5467.               }
  5468.             x++;
  5469.             osp++; nsp++;
  5470.             #if WANT_ATTR
  5471.             oap++; nap++;
  5472.             #endif
  5473.             #if WANT_CHARSET
  5474.             ofp++; nfp++;
  5475.             #endif
  5476.           }
  5477.       }}
  5478.   #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR
  5479.   # Eine Zeile neu anzeigen:
  5480.     # nur benötigte Parameter wirklich übergeben:
  5481.     #if WANT_ATTR && WANT_CHARSET
  5482.       #define RLargs(osp,oap,ofp,y,x1,x2) (osp,oap,ofp,y,x1,x2)
  5483.       #define RLparms(osp,oap,ofp,y,x1,x2) (osp,oap,ofp,y,x1,x2)
  5484.     #endif
  5485.     #if !WANT_ATTR && WANT_CHARSET
  5486.       #define RLargs(osp,oap,ofp,y,x1,x2) (osp,ofp,y,x1,x2)
  5487.       #define RLparms(osp,oap,ofp,y,x1,x2) (osp,ofp,y,x1,x2,oap)
  5488.     #endif
  5489.     #if WANT_ATTR && !WANT_CHARSET
  5490.       #define RLargs(osp,oap,ofp,y,x1,x2) (osp,oap,y,x1,x2)
  5491.       #define RLparms(osp,oap,ofp,y,x1,x2) (osp,oap,y,x1,x2,ofp)
  5492.     #endif
  5493.     #if !WANT_ATTR && !WANT_CHARSET
  5494.       #define RLargs(osp,oap,ofp,y,x1,x2) (osp,y,x1,x2)
  5495.       #define RLparms(osp,oap,ofp,y,x1,x2) (osp,y,x1,x2,oap,ofp)
  5496.     #endif
  5497.     #ifdef ANSI
  5498.     #undef RHparms
  5499.     #define RHparms  RHargs  # korrekt deklarieren
  5500.     local void redisplay_line RLparms (uintB* osp, uintB* oap, uintB* ofp, # old
  5501.                                        int y, int x1, int x2); # Zeile y, von x1 bis x2-1
  5502.     #endif
  5503.     local void redisplay_line RLparms(osp,oap,ofp,y,x1,x2)
  5504.       var reg4 uintB* osp;
  5505.       var reg5 uintB* oap;
  5506.       var reg6 uintB* ofp;
  5507.       var reg1 int y;
  5508.       var reg2 int x1;
  5509.       var reg3 int x2;
  5510.       {
  5511.         #if WANT_INSERT
  5512.         if (curr->insert) { set_insert_mode(FALSE); }
  5513.         #endif
  5514.         #if WANT_ATTR
  5515.         {var reg4 uintB saved_attr = term_attr; change_attr(0);
  5516.         #endif
  5517.         #if WANT_CHARSET
  5518.         {var reg4 uintB saved_charset = term_charset; change_charset(ASCII);
  5519.         #endif
  5520.         last_y = y; last_x = x1;
  5521.         redisplay_help RHargs(osp,           oap,          ofp,
  5522.                               curr->image[y],curr->attr[y],curr->font[y],
  5523.                               y, x1,x2
  5524.                              );
  5525.         #if WANT_CHARSET
  5526.         change_charset(saved_charset); }
  5527.         #endif
  5528.         #if WANT_ATTR
  5529.         change_attr(saved_attr); }
  5530.         #endif
  5531.         #if WANT_INSERT
  5532.         if (curr->insert) { set_insert_mode(TRUE); }
  5533.         #endif
  5534.       }
  5535.   #endif
  5536.   # Den ganzen Schirm neu anzeigen:
  5537.     local void redisplay (void);
  5538.     local void redisplay()
  5539.       {
  5540.         #if WANT_INSERT
  5541.         set_insert_mode(FALSE);
  5542.         #endif
  5543.         #if WANT_ATTR
  5544.         {var reg2 uintB saved_attr = term_attr; change_attr(0);
  5545.         #endif
  5546.         #if WANT_CHARSET
  5547.         {var reg2 uintB saved_charset = term_charset; change_charset(ASCII);
  5548.         #endif
  5549.         out_capstring(CLcap); last_x = 0; last_y = 0;
  5550.         {var reg1 uintC y = 0;
  5551.          while (y<rows)
  5552.            { redisplay_help RHargs(blank,         null,         null,          # old
  5553.                                    curr->image[y],curr->attr[y],curr->font[y], # new
  5554.                                    y,                                          # Zeile y
  5555.                                    0,cols                                      # alle Spalten
  5556.                                   );
  5557.              y++;
  5558.         }  }
  5559.         #if WANT_CHARSET
  5560.         change_charset(saved_charset); }
  5561.         #endif
  5562.         #if WANT_ATTR
  5563.         change_attr(saved_attr); }
  5564.         #endif
  5565.         #if WANT_INSERT
  5566.         if (curr->insert) { set_insert_mode(TRUE); }
  5567.         #endif
  5568.         gofromto(last_y,last_x,curr->y,curr->x);
  5569.       }
  5570.  
  5571. # Weitere Cursor-Bewegungen:
  5572. #if WANT_CURSOR_MOVE
  5573.  
  5574.   local void cursor_right (int n);
  5575.   local void cursor_right(n)
  5576.     var reg3 int n;
  5577.     { var reg2 int x = curr->x;
  5578.       if (x==cols) { return; }
  5579.      {var reg1 int new_x = x + n;
  5580.       if (new_x > cols) { new_x = cols; }
  5581.       gofromto(curr->y,x,curr->y,curr->x = new_x);
  5582.     }}
  5583.  
  5584.   local void cursor_left (int n);
  5585.   local void cursor_left(n)
  5586.     var reg3 int n;
  5587.     { var reg2 int x = curr->x;
  5588.       var reg1 int new_x = x - n;
  5589.       if (new_x < 0) { new_x = 0; }
  5590.       gofromto(curr->y,x,curr->y,curr->x = new_x);
  5591.     }
  5592.  
  5593.   local void cursor_up (int n);
  5594.   local void cursor_up(n)
  5595.     var reg3 int n;
  5596.     { var reg2 int y = curr->y;
  5597.       var reg1 int new_y = y - n;
  5598.       if (new_y < 0) { new_y = 0; }
  5599.       gofromto(y,curr->x,curr->y = new_y,curr->x);
  5600.     }
  5601.  
  5602.   local void cursor_down (int n);
  5603.   local void cursor_down(n)
  5604.     var reg3 int n;
  5605.     { var reg2 int y = curr->y;
  5606.       var reg1 int new_y = y + n;
  5607.       if (new_y >= rows) { new_y = rows-1; }
  5608.       gofromto(y,curr->x,curr->y = new_y,curr->x);
  5609.     }
  5610.  
  5611. #endif
  5612.  
  5613. # Backspace (Cursor um 1 nach links, innerhalb einer Zeile)
  5614. #if WANT_CURSOR_BACKSPACE
  5615.   local void cursor_backspace (void);
  5616.   local void cursor_backspace()
  5617.     { if (curr->x > 0)
  5618.         { if (curr->x < cols)
  5619.             { if (BCcap)
  5620.                 { out_capstring(BCcap); }
  5621.                 else
  5622.                 { gofromto(curr->y,curr->x,curr->y,curr->x - 1); }
  5623.             }
  5624.           curr->x = curr->x - 1;
  5625.     }   }
  5626. #endif
  5627.  
  5628. # Return (Cursor an den Anfang der Zeile)
  5629. #if WANT_CURSOR_RETURN
  5630.   local void cursor_return (void);
  5631.   local void cursor_return()
  5632.     { if (curr->x > 0) { out_capstring(CRcap); curr->x = 0; } }
  5633. #endif
  5634.  
  5635. # Hilfroutinen zum Scrollen:
  5636. #if WANT_CURSOR_LINEFEED || WANT_DELETE_LINE
  5637.   local void scroll_up_help (uintB** pp, uintB filler);
  5638.   local void scroll_up_help(pp,filler)
  5639.     var reg1 uintB** pp;
  5640.     var reg3 uintB filler;
  5641.     { # pp[top..bot] um eins nach links verschieben,
  5642.       # pp[top] herausnehmen, löschen und als pp[bot] wieder einhängen:
  5643.       pp = &pp[curr->top];
  5644.      {var reg2 uintC count;
  5645.       var reg4 uintB* tmp = *pp;
  5646.       dotimesC(count,curr->bot - curr->top, { pp[0] = pp[1]; pp++; } );
  5647.       {var reg1 uintB* p = tmp;
  5648.        dotimesC(count,cols, { *p++ = filler; } );
  5649.       }
  5650.       *pp = tmp;
  5651.     }}
  5652.   local void scroll_up (void);
  5653.   local void scroll_up()
  5654.     { scroll_up_help(curr->image,' ');
  5655.       #if WANT_ATTR
  5656.       scroll_up_help(curr->attr,0);
  5657.       #endif
  5658.       #if WANT_CHARSET
  5659.       scroll_up_help(curr->font,0);
  5660.       #endif
  5661.     }
  5662. #endif
  5663. #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
  5664.   local void scroll_down_help (uintB** pp, uintB filler);
  5665.   local void scroll_down_help(pp,filler)
  5666.     var reg1 uintB** pp;
  5667.     var reg3 uintB filler;
  5668.     { # pp[top..bot] um eins nach rechts verschieben,
  5669.       # pp[top] herausnehmen, löschen und als pp[bot] wieder einhängen:
  5670.       pp = &pp[curr->bot];
  5671.      {var reg2 uintC count;
  5672.       var reg4 uintB* tmp = *pp;
  5673.       dotimesC(count,curr->bot - curr->top, { pp[0] = pp[-1]; pp--; } );
  5674.       {var reg1 uintB* p = tmp;
  5675.        dotimesC(count,cols, { *p++ = filler; } );
  5676.       }
  5677.       *pp = tmp;
  5678.     }}
  5679.   local void scroll_down (void);
  5680.   local void scroll_down()
  5681.     { scroll_down_help(curr->image,' ');
  5682.       #if WANT_ATTR
  5683.       scroll_down_help(curr->attr,0);
  5684.       #endif
  5685.       #if WANT_CHARSET
  5686.       scroll_down_help(curr->font,0);
  5687.       #endif
  5688.     }
  5689. #endif
  5690.  
  5691. # Linefeed (Cursor um 1 nach unten):
  5692. #if WANT_CURSOR_LINEFEED
  5693.   local void cursor_linefeed (void);
  5694.   local void cursor_linefeed()
  5695.     { if (curr->y == curr->bot) { scroll_up(); }
  5696.       elif (curr->y < rows-1) { curr->y++; }
  5697.       out_capstring(NLcap);
  5698.     }
  5699. #endif
  5700.  
  5701. # Reverse Linefeed (Cursor um 1 nach oben):
  5702. #if WANT_CURSOR_REVLINEFEED
  5703.   local void cursor_revlinefeed (void);
  5704.   local void cursor_revlinefeed()
  5705.     { if (curr->y == curr->top)
  5706.         { scroll_down();
  5707.           if (SRcap)
  5708.             { out_capstring(SRcap); }
  5709.           elif (ALcap)
  5710.             { gofromto(curr->top,curr->x,curr->top,0); # Cursor nach links
  5711.               out_capstring(ALcap);
  5712.               gofromto(curr->top,0,curr->top,curr->x); # Cursor wieder zurück
  5713.             }
  5714.           else
  5715.             { redisplay(); }
  5716.         }
  5717.       elif (curr->y > 0)
  5718.         { cursor_up(1); }
  5719.     }
  5720. #endif
  5721.  
  5722. # Lösch-Operationen:
  5723.  
  5724. # Stück einer Zeile löschen:
  5725. #if WANT_CLEAR_SCREEN || WANT_CLEAR_FROM_BOS
  5726.   local void cleared_linepart (int y, int x1, int x2);
  5727.   local void cleared_linepart(y,x1,x2)
  5728.     var reg5 int y;
  5729.     var reg4 int x1;
  5730.     var reg6 int x2;
  5731.     { var reg3 int n = x2-x1;
  5732.       if (n>0)
  5733.         { {var reg1 uintB* sp = &curr->image[y][x1];
  5734.            var reg2 uintC count;
  5735.            dotimespC(count,n, { *sp++ = ' '; } );
  5736.           }
  5737.           #if WANT_ATTR
  5738.           {var reg1 uintB* ap = &curr->attr[y][x1];
  5739.            var reg2 uintC count;
  5740.            dotimespC(count,n, { *ap++ = 0; } );
  5741.           }
  5742.           #endif
  5743.           #if WANT_CHARSET
  5744.           {var reg1 uintB* fp = &curr->font[y][x1];
  5745.            var reg2 uintC count;
  5746.            dotimespC(count,n, { *fp++ = 0; } );
  5747.           }
  5748.           #endif
  5749.     }   }
  5750. #endif
  5751.  
  5752. # Bildschirm löschen:
  5753. #if WANT_CLEAR_SCREEN
  5754.   local void clear_screen (void);
  5755.   local void clear_screen()
  5756.     { out_capstring(CLcap);
  5757.      {var reg3 uintC y = 0;
  5758.       while (y<rows) { cleared_linepart(y,0,cols); y++; }
  5759.     }}
  5760. #endif
  5761.  
  5762. # Stück einer Zeile löschen:
  5763. #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL
  5764.   local void clear_linepart (int y, int x1, int x2);
  5765.   local void clear_linepart(y,x1,x2)
  5766.     var reg5 int y;
  5767.     var reg4 int x1;
  5768.     var reg6 int x2;
  5769.     { var reg3 int n = x2-x1;
  5770.       if (n>0)
  5771.         { {var reg1 uintB* sp = &curr->image[y][x1];
  5772.            var reg2 uintC count;
  5773.            dotimesC(count,n, { *sp++ = ' '; } );
  5774.           }
  5775.           #if WANT_ATTR
  5776.           {var reg1 uintB* ap = &curr->attr[y][x1];
  5777.            var reg2 uintC count;
  5778.            dotimesC(count,n, { *ap++ = 0; } );
  5779.           }
  5780.           #endif
  5781.           #if WANT_CHARSET
  5782.           {var reg1 uintB* fp = &curr->font[y][x1];
  5783.            var reg2 uintC count;
  5784.            dotimesC(count,n, { *fp++ = 0; } );
  5785.           }
  5786.           #endif
  5787.           if ((x2==cols) && CEcap)
  5788.             { gofromto(curr->y,curr->x,y,x1); curr->y = y; curr->x = x1;
  5789.               out_capstring(CEcap);
  5790.             }
  5791.             else
  5792.             { if ((x2==cols) && (y==rows-1) && AM) { n--; }
  5793.               if (n>0)
  5794.                 {
  5795.                   #if WANT_ATTR
  5796.                   {var reg7 uintB saved_attr = term_attr; change_attr(0);
  5797.                   #endif
  5798.                   #if WANT_CHARSET
  5799.                   {var reg7 uintB saved_charset = term_charset; change_charset(ASCII);
  5800.                   #endif
  5801.                   #if WANT_INSERT
  5802.                   if (curr->insert) { set_insert_mode(FALSE); }
  5803.                   #endif
  5804.                   gofromto(curr->y,curr->x,y,x1);
  5805.                   {var reg1 uintC count;
  5806.                    dotimespC(count,n, { out_char(' '); } );
  5807.                   }
  5808.                   curr->y = y; curr->x = x1+n;
  5809.                   #if WANT_CHARSET
  5810.                   change_charset(saved_charset); }
  5811.                   #endif
  5812.                   #if WANT_ATTR
  5813.                   change_attr(saved_attr); }
  5814.                   #endif
  5815.                   #if WANT_INSERT
  5816.                   if (curr->insert) { set_insert_mode(TRUE); }
  5817.                   #endif
  5818.     }   }   }   }
  5819. #endif
  5820.  
  5821. # Bildschirm bis zum Cursor (ausschließlich) löschen:
  5822. #if WANT_CLEAR_FROM_BOS
  5823.   local void clear_from_BOS (void);
  5824.   local void clear_from_BOS()
  5825.     { var reg2 int y0 = curr->y;
  5826.       var reg3 int x0 = curr->x;
  5827.       var reg1 int y = 0;
  5828.       while (y<y0) { clear_linepart(y,0,cols); y++; }
  5829.       clear_linepart(y0,0,x0);
  5830.       gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
  5831.     }
  5832. #endif
  5833.  
  5834. # Bildschirm ab Cursor (einschließlich) löschen:
  5835. #if WANT_CLEAR_TO_EOS
  5836.   local void clear_to_EOS (void);
  5837.   local void clear_to_EOS()
  5838.     { var reg2 int y0 = curr->y;
  5839.       var reg3 int x0 = curr->x;
  5840.       if (CDcap)
  5841.         { out_capstring(CDcap);
  5842.           cleared_linepart(y0,x0,cols);
  5843.          {var reg1 int y = y0;
  5844.           while (++y < rows) { cleared_linepart(y,0,cols); }
  5845.         }}
  5846.         else
  5847.         { clear_linepart(y0,x0,cols);
  5848.          {var reg1 int y = y0;
  5849.           while (++y < rows) { clear_linepart(y,0,cols); }
  5850.         }}
  5851.       gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
  5852.     }
  5853. #endif
  5854.  
  5855. # Cursorzeile löschen:
  5856. #if WANT_CLEAR_LINE
  5857.   local void clear_line (void);
  5858.   local void clear_line()
  5859.     { var reg1 int y0 = curr->y;
  5860.       var reg2 int x0 = curr->x;
  5861.       clear_linepart(y0,0,cols);
  5862.       gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
  5863.     }
  5864. #endif
  5865.  
  5866. # Cursorzeile bis Cursor (ausschließlich) löschen:
  5867. #if WANT_CLEAR_FROM_BOL
  5868.   local void clear_from_BOL (void);
  5869.   local void clear_from_BOL()
  5870.     { var reg1 int y0 = curr->y;
  5871.       var reg2 int x0 = curr->x;
  5872.       clear_linepart(y0,0,x0);
  5873.       gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
  5874.     }
  5875. #endif
  5876.  
  5877. # Cursorzeile ab Cursor (einschließlich) löschen:
  5878. #if WANT_CLEAR_TO_EOL
  5879.   local void clear_to_EOL (void);
  5880.   local void clear_to_EOL()
  5881.     { var reg1 int y0 = curr->y;
  5882.       var reg2 int x0 = curr->x;
  5883.       clear_linepart(y0,x0,cols);
  5884.       gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
  5885.     }
  5886. #endif
  5887.  
  5888. # Einfüge-Operationen:
  5889.  
  5890. # alter Zeileninhalt:
  5891. #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR
  5892.   local uintB* old_image_y;
  5893.   #if WANT_ATTR
  5894.   local uintB* old_attr_y;
  5895.   #endif
  5896.   #if WANT_CHARSET
  5897.   local uintB* old_font_y;
  5898.   #endif
  5899.   local void save_line_old (int y);
  5900.   local void save_line_old(y)
  5901.     var reg4 int y;
  5902.     { {var reg1 uintB* p1 = &curr->image[y][0];
  5903.        var reg2 uintB* p2 = &old_image_y[0];
  5904.        var reg3 uintC count;
  5905.        dotimesC(count,cols, { *p2++ = *p1++; } );
  5906.       }
  5907.       #if WANT_ATTR
  5908.       {var reg1 uintB* p1 = &curr->attr[y][0];
  5909.        var reg2 uintB* p2 = &old_attr_y[0];
  5910.        var reg3 uintC count;
  5911.        dotimesC(count,cols, { *p2++ = *p1++; } );
  5912.       }
  5913.       #endif
  5914.       #if WANT_CHARSET
  5915.       {var reg1 uintB* p1 = &curr->font[y][0];
  5916.        var reg2 uintB* p2 = &old_font_y[0];
  5917.        var reg3 uintC count;
  5918.        dotimesC(count,cols, { *p2++ = *p1++; } );
  5919.       }
  5920.       #endif
  5921.     }
  5922. #endif
  5923.  
  5924. # Ein Zeichen einfügen:
  5925. #if WANT_INSERT_1CHAR
  5926.   local void insert_1char (uintB c);
  5927.   local void insert_1char(c)
  5928.     var reg6 uintB c;
  5929.     { var reg4 int y = curr->y;
  5930.       var reg5 int x = curr->x;
  5931.       if (x==cols) { x--; } # nicht über den rechten Rand schreiben!
  5932.       if (ICcap || IMcap)
  5933.         { curr->image[y][x] = c;
  5934.           #if WANT_ATTR
  5935.           curr->attr[y][x] = curr->curr_attr;
  5936.           #endif
  5937.           #if WANT_CHARSET
  5938.           curr->font[y][x] = curr->charsets[curr->curr_charset]; # = term_charset
  5939.           #endif
  5940.           #if WANT_INSERT
  5941.           if (!curr->insert)
  5942.           #endif
  5943.             { set_insert_mode(TRUE); }
  5944.           out_capstring(ICcap); out_char(c);
  5945.           #if WANT_INSERT
  5946.           if (!curr->insert)
  5947.           #endif
  5948.             { set_insert_mode(FALSE); }
  5949.           curr->x = x+1;
  5950.         }
  5951.         else
  5952.         { # alten Zeileninhalt retten:
  5953.           save_line_old(y);
  5954.           # neuen Zeileninhalt bilden:
  5955.           {var reg1 uintB* p1 = &curr->image[y][x];
  5956.            var reg2 uintB* p2 = &old_image[x];
  5957.            var reg3 uintC count;
  5958.            *p1++ = c;
  5959.            dotimesC(count,cols-1-x, { *p1++ = *p2++; } );
  5960.           }
  5961.           #if WANT_ATTR
  5962.           {var reg1 uintB* p1 = &curr->attr[y][x];
  5963.            var reg2 uintB* p2 = &old_attr[x];
  5964.            var reg3 uintC count;
  5965.            *p1++ = curr->curr_attr;
  5966.            dotimesC(count,cols-1-x, { *p1++ = *p2++; } );
  5967.           }
  5968.           #endif
  5969.           #if WANT_CHARSET
  5970.           {var reg1 uintB* p1 = &curr->font[y][x];
  5971.            var reg2 uintB* p2 = &old_font[x];
  5972.            var reg3 uintC count;
  5973.            *p1++ = term_charset; # = curr->charsets[curr->curr_charset]
  5974.            dotimesC(count,cols-1-x, { *p1++ = *p2++; } );
  5975.           }
  5976.           #endif
  5977.           # Zeile anzeigen:
  5978.           redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols);
  5979.           x++;
  5980.           gofromto(last_y,last_x,y,x); curr->x = x;
  5981.     }   }
  5982. #endif
  5983.  
  5984. # Platz für n Zeichen machen:
  5985. #if WANT_INSERT_CHAR
  5986.   local void insert_char (uintC n);
  5987.   local void insert_char(n)
  5988.     var reg6 uintC n;
  5989.     { var reg5 int y = curr->y;
  5990.       var reg4 int x = curr->x;
  5991.       if (n > cols-x) { n = cols-x; }
  5992.       if (n==0) return;
  5993.       # alten Zeileninhalt retten:
  5994.       save_line_old(y);
  5995.       # neuen Zeileninhalt bilden:
  5996.       {var reg1 uintB* p1 = &curr->image[y][x];
  5997.        var reg2 uintB* p2 = &old_image[x];
  5998.        var reg3 uintC count;
  5999.        dotimespC(count,n, { *p1++ = ' '; } );
  6000.        dotimesC(count,cols-x-n, { *p1++ = *p2++; } );
  6001.       }
  6002.       #if WANT_ATTR
  6003.       {var reg1 uintB* p1 = &curr->attr[y][x];
  6004.        var reg2 uintB* p2 = &old_attr[x];
  6005.        var reg3 uintC count;
  6006.        dotimespC(count,n, { *p1++ = 0; } );
  6007.        dotimesC(count,cols-x-n, { *p1++ = *p2++; } );
  6008.       }
  6009.       #endif
  6010.       #if WANT_CHARSET
  6011.       {var reg1 uintB* p1 = &curr->font[y][x];
  6012.        var reg2 uintB* p2 = &old_font[x];
  6013.        var reg3 uintC count;
  6014.        dotimespC(count,n, { *p1++ = 0; } );
  6015.        dotimesC(count,cols-x-n, { *p1++ = *p2++; } );
  6016.       }
  6017.       #endif
  6018.       if (CICcap && (n > 1))
  6019.         {
  6020.           #if WANT_INSERT
  6021.           if (curr->insert) { set_insert_mode(FALSE); }
  6022.           #endif
  6023.           out_cap1string(CICcap,n);
  6024.           {var reg1 uintC count;
  6025.            dotimespC(count,n, { out_char(' '); } );
  6026.           }
  6027.           #if WANT_INSERT
  6028.           if (curr->insert) { set_insert_mode(TRUE); }
  6029.           #endif
  6030.           gofromto(y,x+n,y,x);
  6031.         }
  6032.       elif (ICcap || IMcap)
  6033.         {
  6034.           #if WANT_INSERT
  6035.           if (!curr->insert)
  6036.           #endif
  6037.             { set_insert_mode(TRUE); }
  6038.           {var reg1 uintC count;
  6039.            dotimespC(count,n, { out_capstring(ICcap); out_char(' '); } );
  6040.           }
  6041.           #if WANT_INSERT
  6042.           if (!curr->insert)
  6043.           #endif
  6044.             { set_insert_mode(FALSE); }
  6045.           gofromto(y,x+n,y,x);
  6046.         }
  6047.       else
  6048.         { redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols);
  6049.           gofromto(last_y,last_x,y,x);
  6050.         }
  6051.     }
  6052. #endif
  6053.  
  6054. # Zeilen einfügen:
  6055. #if WANT_INSERT_LINE
  6056.   local void insert_line (uintC n);
  6057.   local void insert_line(n)
  6058.     var reg2 uintC n;
  6059.     { if (n > curr->bot - curr->y + 1) { n = curr->bot - curr->y + 1; }
  6060.       if (n==0) return;
  6061.      {var reg3 int oldtop = curr->top;
  6062.       curr->top = curr->y;
  6063.       {var reg1 uintC count;
  6064.        dotimespC(count,n, { scroll_down(); } );
  6065.       }
  6066.       if (ALcap || CALcap)
  6067.         { gofromto(curr->y,curr->x,curr->y,0); # an den Zeilenanfang
  6068.           if ((CALcap && (n>1)) || !ALcap)
  6069.             { out_cap1string(CALcap,n); }
  6070.             else
  6071.             { var reg1 uintC count;
  6072.               dotimespC(count,n, { out_capstring(ALcap); } );
  6073.             }
  6074.           gofromto(curr->y,0,curr->y,curr->x);
  6075.         }
  6076.       elif (CScap && SRcap)
  6077.         { out_capstring(tgoto(CScap,curr->bot,curr->top));
  6078.           gofromto(-1,-1,curr->top,0);
  6079.           {var reg1 uintC count;
  6080.            dotimespC(count,n, { out_capstring(SRcap); } );
  6081.           }
  6082.           out_capstring(tgoto(CScap,curr->bot,oldtop));
  6083.           gofromto(-1,-1,curr->y,curr->x);
  6084.         }
  6085.       else
  6086.         { redisplay(); }
  6087.       curr->top = oldtop;
  6088.     }}
  6089. #endif
  6090.  
  6091. # Lösch-Operationen:
  6092.  
  6093. # Characters löschen:
  6094. #if WANT_DELETE_CHAR
  6095.   local void delete_char (uintC n);
  6096.   local void delete_char(n)
  6097.     var reg6 uintC n;
  6098.     { var reg5 int y = curr->y;
  6099.       var reg4 int x = curr->x;
  6100.       if (n > cols-x) { n = cols-x; }
  6101.       if (n==0) return;
  6102.       # alten Zeileninhalt retten:
  6103.       save_line_old(y);
  6104.       # neuen Zeileninhalt bilden:
  6105.       {var reg1 uintB* p1 = &curr->image[y][x];
  6106.        var reg2 uintB* p2 = &old_image[x];
  6107.        var reg3 uintC count;
  6108.        dotimesC(count,cols-x-n, { *p1++ = *p2++; } );
  6109.        dotimespC(count,n, { *p1++ = ' '; } );
  6110.       }
  6111.       #if WANT_ATTR
  6112.       {var reg1 uintB* p1 = &curr->attr[y][x];
  6113.        var reg2 uintB* p2 = &old_attr[x];
  6114.        var reg3 uintC count;
  6115.        dotimesC(count,cols-x-n, { *p1++ = *p2++; } );
  6116.        dotimespC(count,n, { *p1++ = 0; } );
  6117.       }
  6118.       #endif
  6119.       #if WANT_CHARSET
  6120.       {var reg1 uintB* p1 = &curr->font[y][x];
  6121.        var reg2 uintB* p2 = &old_font[x];
  6122.        var reg3 uintC count;
  6123.        dotimesC(count,cols-x-n, { *p1++ = *p2++; } );
  6124.        dotimespC(count,n, { *p1++ = 0; } );
  6125.       }
  6126.       #endif
  6127.       if (CDCcap && ((n>1) || !DCcap))
  6128.         { out_cap1string(CDCcap,n); }
  6129.       elif (DCcap)
  6130.         { var reg1 uintC count;
  6131.           dotimespC(count,n, { out_capstring(DCcap); } );
  6132.         }
  6133.       else
  6134.         { redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols);
  6135.           gofromto(last_y,last_x,y,x);
  6136.         }
  6137.     }
  6138. #endif
  6139.  
  6140. # Zeilen löschen:
  6141. #if WANT_DELETE_LINE
  6142.   local void delete_line (uintC n);
  6143.   local void delete_line(n)
  6144.     var reg2 uintC n;
  6145.     { if (n > curr->bot - curr->y + 1) { n = curr->bot - curr->y + 1; }
  6146.       if (n==0) return;
  6147.      {var reg3 int oldtop = curr->top;
  6148.       curr->top = curr->y;
  6149.       {var reg1 uintC count;
  6150.        dotimespC(count,n, { scroll_up(); } );
  6151.       }
  6152.       if (DLcap || CDLcap)
  6153.         { gofromto(curr->y,curr->x,curr->y,0); # an den Zeilenanfang
  6154.           if ((CDLcap && (n>1)) || !DLcap)
  6155.             { out_cap1string(CDLcap,n); }
  6156.             else
  6157.             { var reg1 uintC count;
  6158.               dotimespC(count,n, { out_capstring(DLcap); } );
  6159.             }
  6160.           gofromto(curr->y,0,curr->y,curr->x);
  6161.         }
  6162.       elif (CScap)
  6163.         { out_capstring(tgoto(CScap,curr->bot,curr->top));
  6164.           gofromto(-1,-1,curr->bot,0);
  6165.           {var reg1 uintC count;
  6166.            dotimespC(count,n, { out_capstring(SFcap); } );
  6167.           }
  6168.           out_capstring(tgoto(CScap,curr->bot,oldtop));
  6169.           gofromto(-1,-1,curr->y,curr->x);
  6170.         }
  6171.       else
  6172.         { redisplay(); }
  6173.       curr->top = oldtop;
  6174.     }}
  6175. #endif
  6176.  
  6177. # Ein Zeichen ausgeben:
  6178. #if WANT_OUTPUT_1CHAR
  6179.   local void output_1char (uintB c);
  6180.   local void output_1char(c)
  6181.     var reg3 uintB c;
  6182.     {
  6183.       #if WANT_INSERT
  6184.       if (curr->insert)
  6185.         { insert_1char(c); }
  6186.         else
  6187.       #endif
  6188.         { var reg1 int y = curr->y;
  6189.           var reg2 int x = curr->x;
  6190.           if (x==cols) { x--; } # nicht über den rechten Rand schreiben!
  6191.           curr->image[y][x] = c;
  6192.           #if WANT_ATTR
  6193.           curr->attr[y][x] = curr->curr_attr;
  6194.           #endif
  6195.           #if WANT_CHARSET
  6196.           curr->font[y][x] = curr->charsets[curr->curr_charset]; # = term_charset
  6197.           #endif
  6198.           x++;
  6199.           if (!(AM && (x==cols) && (curr->y==curr->bot))) # rechte untere Ecke evtl. freilassen
  6200.             { out_char(c); } # Zeichen ausgeben
  6201.           curr->x = x; # Cursor rückt um eins weiter
  6202.           if (x==cols) # außer wenn er schon ganz rechts war
  6203.             { gofromto(-1,-1,curr->y,curr->x); }
  6204.     }   }
  6205. #endif
  6206.  
  6207. #if WANT_SAVE
  6208.  
  6209. # gespeicherte Cursor-Position:
  6210.   local void save_cursor (void);
  6211.   local void save_cursor()
  6212.     { curr->saved_x = curr->x;
  6213.       curr->saved_y = curr->y;
  6214.       #if WANT_ATTR
  6215.       curr->saved_curr_attr = curr->curr_attr;
  6216.       #endif
  6217.       #if WANT_CHARSET
  6218.       curr->saved_curr_charset = curr->curr_charset;
  6219.       {var reg1 uintC i = 0;
  6220.        while (i<charset_count) { curr->saved_charsets[i] = curr->charsets[i]; i++; }
  6221.       }
  6222.       #endif
  6223.       curr->saved = TRUE;
  6224.     }
  6225.   local void restore_cursor (void);
  6226.   local void restore_cursor()
  6227.     { if (curr->saved)
  6228.         { gofromto(curr->y,curr->x,curr->saved_y,curr->saved_x);
  6229.           curr->y = curr->saved_y; curr->x = curr->saved_x;
  6230.           #if WANT_ATTR
  6231.           curr->curr_attr = curr->saved_curr_attr;
  6232.           change_attr(curr->curr_attr);
  6233.           #endif
  6234.           #if WANT_CHARSET
  6235.           curr->curr_charset = curr->saved_curr_charset;
  6236.           {var reg1 uintC i = 0;
  6237.            while (i<charset_count) { curr->charsets[i] = curr->saved_charsets[i]; i++; }
  6238.           }
  6239.           change_charset(curr->charsets[curr->curr_charset]);
  6240.           #endif
  6241.     }   }
  6242.  
  6243. #endif
  6244.  
  6245. # Initialisiert das Terminal.
  6246. # Liefert NULL falls OK, einen Fehlerstring sonst.
  6247.   local boolean term_initialized = FALSE;
  6248.   local const char* init_term (void);
  6249.   local const char* init_term()
  6250.     { var char tbuf[4096]; # interner Buffer für die Termcap-Routinen
  6251.       if (term_initialized) { return NULL; } # schon initialisiert -> OK
  6252.       # Terminal-Typ abfragen:
  6253.       begin_system_call();
  6254.       { var reg1 char* s = getenv("TERM");
  6255.         if (s==NULL)
  6256.           { end_system_call();
  6257.             //: DEUTSCH "Environment enthält keine TERM-Variable."
  6258.             //: ENGLISH "environment has no TERM variable"
  6259.             //: FRANCAIS "L'environnment ne contient pas de variable TERM."
  6260.             return (GETTEXT("environment has no TERM variable"));
  6261.           }
  6262.         if (!(tgetent(tbuf,s)==1))
  6263.           { end_system_call();
  6264.             pushSTACK(asciz_to_string(s));
  6265.             //: DEUTSCH "TERMCAP kennt Terminal-Typ ~ nicht."
  6266.             //: ENGLISH "terminal type ~ unknown to termcap"
  6267.             //: FRANCAIS "TERMCAP ne connait pas le type d'écran ~."
  6268.             return (GETTEXT("terminal type ~ unknown to termcap"));
  6269.           }
  6270.       }
  6271.       { var reg1 int i = tgetnum("co");
  6272.         cols = (i>0 ? i : 80);
  6273.       }
  6274.       { var reg1 int i = tgetnum("li");
  6275.         rows = (i>0 ? i : 24);
  6276.       }
  6277.       #ifdef EMUNIX
  6278.       # Obwohl das eigentlich unsauber ist, holen wir uns die aktuelle Bildschirm-
  6279.       # größe mit _scrsize().
  6280.       #ifdef EMUNIX_OLD_8d
  6281.       if (!(_osmode == DOS_MODE))
  6282.       #endif
  6283.       { var int scrsize[2];
  6284.         _scrsize(&!scrsize);
  6285.         if (scrsize[0] > 0) { cols = scrsize[0]; }
  6286.         if (scrsize[1] > 0) { rows = scrsize[1]; }
  6287.       }
  6288.       #endif
  6289.       if (tgetflag("hc"))
  6290.         { end_system_call();
  6291.           //: DEUTSCH "Unzureichendes Terminal: Hardcopy-Terminal."
  6292.           //: ENGLISH "insufficient terminal: hardcopy terminal"
  6293.           //: FRANCAIS "Terminal insuffisant : imprimante au lieu d'écran."
  6294.           return (GETTEXT("insufficient terminal: hardcopy terminal"));
  6295.         }
  6296.       if (tgetflag("os"))
  6297.         { end_system_call();
  6298.           //: DEUTSCH "Unzureichendes Terminal: Kann Ausgegebenes nicht mehr löschen."
  6299.           //: ENGLISH "insufficient terminal: overstrikes, cannot clear output"
  6300.           //: FRANCAIS "Terminal insuffisant : ne peut rien effacer."
  6301.           return (GETTEXT("insufficient terminal: overstrikes, cannot clear output"));
  6302.         }
  6303.       if (tgetflag("ns"))
  6304.         { end_system_call();
  6305.           //: DEUTSCH "Unzureichendes Terminal: Kann nicht scrollen."
  6306.           //: ENGLISH "insufficient terminal: cannot scroll"
  6307.           //: FRANCAIS "Terminal insuffisant : pas de défilement."
  6308.           return (GETTEXT("insufficient terminal: cannot scroll"));
  6309.         }
  6310.       if (!(CLcap = tgetstr("cl",&tp)))
  6311.         { # Könnte CLcap = "\n\n\n\n"; als Default nehmen ('weird HPs')
  6312.           end_system_call();
  6313.           //: DEUTSCH "Unzureichendes Terminal: Kann Bildschirm nicht löschen."
  6314.           //: ENGLISH "insufficient terminal: cannot clear screen"
  6315.           //: FRANCAIS "Terminal insuffisant : ne peut pas effacer l'écran."
  6316.           return (GETTEXT("insufficient terminal: cannot clear screen"));
  6317.         }
  6318.       if (!(CMcap = tgetstr("cm",&tp)))
  6319.         { end_system_call();
  6320.           //: DEUTSCH "Unzureichendes Terminal: Kann Cursor nicht willkürlich positionieren."
  6321.           //: ENGLISH "insufficient terminal: cannot position cursor randomly"
  6322.           //: FRANCAIS "Terminal insuffisant : ne peut pas placer le curseur n'importe où."
  6323.           return (GETTEXT("insufficient terminal: cannot position cursor randomly"));
  6324.         }
  6325.       # Capabilities initialisieren:
  6326.       AM = tgetflag("am"); if (tgetflag("LP")) { AM = FALSE; }
  6327.       TIcap = tgetstr("ti",&tp);
  6328.       TEcap = tgetstr("te",&tp);
  6329.       # BLcap = tgetstr("bl",&tp); if (!BLcap) BLcap = "\007";
  6330.       # VBcap = tgetstr("vb",&tp);
  6331.       BCcap = tgetstr("bc",&tp); if (!BCcap) BCcap = (tgetflag("bs") ? "\b" : tgetstr("le",&tp));
  6332.       CRcap = tgetstr("cr",&tp); if (!CRcap) CRcap = "\r";
  6333.       NLcap = tgetstr("nl",&tp); if (!NLcap) NLcap = "\n";
  6334.       DOcap = tgetstr("do",&tp); if (!DOcap) DOcap = NLcap;
  6335.       UPcap = tgetstr("up",&tp);
  6336.       NDcap = tgetstr("nd",&tp);
  6337.       IScap = tgetstr("is",&tp);
  6338.       #if WANT_ATTR
  6339.       if ((tgetnum("sg") > 0) || (tgetnum("ug") > 0))
  6340.         # Beim Umschalten in Standout-Mode oder beim Umschalten in den
  6341.         # Underline-Mode gibt's Leerstellen -> unbrauchbar!
  6342.         { SOcap = NULL; SEcap = NULL; UScap = NULL; UEcap = NULL;
  6343.           MBcap = NULL; MDcap = NULL; MHcap = NULL; MRcap = NULL; MEcap = NULL;
  6344.         }
  6345.         else
  6346.         { SOcap = tgetstr("so",&tp);
  6347.           SEcap = tgetstr("se",&tp);
  6348.           UScap = tgetstr("us",&tp);
  6349.           UEcap = tgetstr("ue",&tp);
  6350.           if (!UScap && !UEcap) # kein Underline?
  6351.             { UScap = SOcap; UEcap = SEcap; } # nimm Standout als Ersatz
  6352.           MBcap = tgetstr("mb",&tp);
  6353.           MDcap = tgetstr("md",&tp);
  6354.           MHcap = tgetstr("mh",&tp);
  6355.           MRcap = tgetstr("mr",&tp);
  6356.           MEcap = tgetstr("me",&tp);
  6357.           # Does ME also reverse the effect of SO and/or US?  This is not
  6358.           # clearly specified by the termcap manual.
  6359.           # Anyway, we should at least look whether ME/SE/UE are equal:
  6360.           if (UEcap && SEcap && asciz_equal(UEcap,SEcap)) { UEcap = NULL; }
  6361.           if (UEcap && MEcap && asciz_equal(UEcap,MEcap)) { UEcap = NULL; }
  6362.           if (SEcap && MEcap && asciz_equal(SEcap,MEcap)) { SEcap = NULL; }
  6363.           # tgetstr("uc",&tp) liefert ein underline-character. Dann jeweils
  6364.           # in redisplay_help() und output_1char() nach dem out_char() noch
  6365.           # backspace() und out_capstring(UCcap) durchführen.
  6366.           # Für welche Terminals lohnt sich das??
  6367.         }
  6368.       #endif
  6369.       #if WANT_CHARSET
  6370.       ISO2022 = tgetflag("G0");
  6371.       #endif
  6372.       CScap = tgetstr("cs",&tp);
  6373.       #if WANT_DELETE_LINE
  6374.       SFcap = tgetstr("sf",&tp); if (!SFcap) SFcap = NLcap;
  6375.       #endif
  6376.       #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
  6377.       SRcap = tgetstr("sr",&tp);
  6378.       #endif
  6379.       #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL
  6380.       CEcap = tgetstr("ce",&tp);
  6381.       #endif
  6382.       #if WANT_CLEAR_TO_EOS
  6383.       CDcap = tgetstr("cd",&tp);
  6384.       #endif
  6385.       #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
  6386.       ALcap = tgetstr("al",&tp);
  6387.       #endif
  6388.       #if WANT_DELETE_LINE
  6389.       DLcap = tgetstr("dl",&tp);
  6390.       #endif
  6391.       #if WANT_DELETE_CHAR
  6392.       DCcap = tgetstr("dc",&tp);
  6393.       #endif
  6394.       #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
  6395.       ICcap = tgetstr("ic",&tp);
  6396.       #endif
  6397.       #if WANT_INSERT_CHAR
  6398.       CICcap = tgetstr("IC",&tp);
  6399.       #endif
  6400.       #if WANT_INSERT_LINE
  6401.       CALcap = tgetstr("AL",&tp);
  6402.       #endif
  6403.       #if WANT_DELETE_CHAR
  6404.       CDCcap = tgetstr("DC",&tp);
  6405.       #endif
  6406.       #if WANT_DELETE_LINE
  6407.       CDLcap = tgetstr("DL",&tp);
  6408.       #endif
  6409.       IMcap = tgetstr("im",&tp);
  6410.       EIcap = tgetstr("ei",&tp);
  6411.       if (tgetflag ("in")) # Insert-Modus unbrauchbar?
  6412.         { IMcap = NULL; EIcap = NULL;
  6413.           #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
  6414.           ICcap = NULL;
  6415.           #endif
  6416.           #if WANT_INSERT_CHAR
  6417.           CICcap = NULL;
  6418.           #endif
  6419.         }
  6420.       if (IMcap && (IMcap[0]==0)) { IMcap = NULL; } # IMcap leer?
  6421.       if (EIcap && (EIcap[0]==0)) { EIcap = NULL; } # EIcap leer?
  6422.       #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
  6423.       if (ICcap && (ICcap[0]==0)) { ICcap = NULL; } # ICcap leer?
  6424.       #endif
  6425.       # Kosten der Capabilities berechnen:
  6426.       IMcost = cap_cost(IMcap);
  6427.       EIcost = cap_cost(EIcap);
  6428.       BCcost = cap_cost(BCcap);
  6429.       NDcost = cap_cost(NDcap);
  6430.       DOcost = cap_cost(DOcap);
  6431.       #ifndef NL_HACK
  6432.       # Falls DOcap ein LF ausgibt, ist nicht sicher, ob dies auch als solches
  6433.       # (und nicht als CR/LF) beim Terminal ankommt. In diesem Fall erklären
  6434.       # wir DOcap für unbrauchbar. Das erspart uns den NL_HACK.
  6435.       if (DOcap[0]=='\n') { DOcost = EXPENSIVE; }
  6436.       #endif
  6437.       UPcost = cap_cost(UPcap);
  6438.       CRcost = cap_cost(CRcap);
  6439.       # Hilfs-Datenstrukturen bereitstellen:
  6440.       {var reg1 uintB* ptr = malloc(cols*sizeof(uintB));
  6441.        var reg2 uintC count;
  6442.        blank = ptr;
  6443.        dotimespC(count,cols, { *ptr++ = ' '; } );
  6444.       }
  6445.       #if WANT_ATTR || WANT_CHARSET
  6446.       {var reg1 uintB* ptr = malloc(cols*sizeof(uintB));
  6447.        var reg2 uintC count;
  6448.        null = ptr;
  6449.        dotimespC(count,cols, { *ptr++ = 0; } );
  6450.       }
  6451.       #endif
  6452.       #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR
  6453.       old_image_y = malloc(cols*sizeof(uintB));
  6454.       #if WANT_ATTR
  6455.       old_attr_y = malloc(cols*sizeof(uintB));
  6456.       #endif
  6457.       #if WANT_CHARSET
  6458.       old_font_y = malloc(cols*sizeof(uintB));
  6459.       #endif
  6460.       #endif
  6461.       end_system_call();
  6462.       term_initialized = TRUE;
  6463.       return NULL;
  6464.     }
  6465.  
  6466. #ifdef NL_HACK
  6467.  
  6468. # Wenn NLcap = "\n" ist, müssen wir ein "stty -onlcr" durchführen, weil sonst
  6469. # das NL vom Terminal-Driver in ein CR umgewandelt wird, bevor es beim
  6470. # Terminal ankommt.
  6471.   local void term_nlraw (void);
  6472.   local void term_nlunraw (void);
  6473. #if defined(UNIX_TERM_TERMIOS)
  6474.   static unsigned long old_c_oflag = 0;
  6475.   local void term_nlraw()
  6476.     { var struct termios oldtermio;
  6477.       if (!( tcgetattr(stdout_handle,&oldtermio) ==0))
  6478.         { if (!(errno==ENOTTY)) { OS_error(); } }
  6479.       old_c_oflag = oldtermio.c_oflag;
  6480.       oldtermio.c_oflag &= ~ONLCR;
  6481.       if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0))
  6482.         { if (!(errno==ENOTTY)) { OS_error(); } }
  6483.     }
  6484.   local void term_nlunraw()
  6485.     { if (old_c_oflag & ONLCR)
  6486.         { var struct termios oldtermio;
  6487.           if (!( tcgetattr(stdout_handle,&oldtermio) ==0))
  6488.             { if (!(errno==ENOTTY)) { OS_error(); } }
  6489.           oldtermio.c_oflag |= ONLCR;
  6490.           if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0))
  6491.             { if (!(errno==ENOTTY)) { OS_error(); } }
  6492.     }   }
  6493. #elif defined(UNIX_TERM_TERMIO) || defined(EMUNIX)
  6494.   static unsigned long old_c_oflag = 0;
  6495.   local void term_nlraw()
  6496.     { var struct termio oldtermio;
  6497.       if (!( ioctl(stdout_handle,TCGETA,&oldtermio) ==0))
  6498.         { if (!(errno==ENOTTY)) { OS_error(); } }
  6499.       old_c_oflag = oldtermio.c_oflag;
  6500.       oldtermio.c_oflag &= ~ONLCR;
  6501.       if (!( ioctl(stdout_handle,TCSETAF,&oldtermio) ==0))
  6502.         { if (!(errno==ENOTTY)) { OS_error(); } }
  6503.     }
  6504.   local void term_nlunraw()
  6505.     { if (old_c_oflag & ONLCR)
  6506.         { var struct termio oldtermio;
  6507.           if (!( ioctl(stdout_handle,TCGETA,&oldtermio) ==0))
  6508.             { if (!(errno==ENOTTY)) { OS_error(); } }
  6509.           oldtermio.c_oflag |= ONLCR;
  6510.           if (!( ioctl(stdout_handle,TCSETAF,&oldtermio) ==0))
  6511.             { if (!(errno==ENOTTY)) { OS_error(); } }
  6512.     }   }
  6513. #elif defined(UNIX_TERM_SGTTY)
  6514.   static unsigned long old_sg_flags = 0;
  6515.   local void term_nlraw()
  6516.     { var struct sgttyb oldsgttyb;
  6517.       if (!( ioctl(stdout_handle,TIOCGETP,&oldsgttyb) ==0))
  6518.         { if (!(errno==ENOTTY)) { OS_error(); } }
  6519.       old_sg_flags = oldsgttyb.sg_flags;
  6520.       oldsgttyb.sg_flags &= ~CRMOD;
  6521.       if (!( ioctl(stdout_handle,TIOCSETP,&oldsgttyb) ==0))
  6522.         { if (!(errno==ENOTTY)) { OS_error(); } }
  6523.     }
  6524.   local void term_nlunraw()
  6525.     { if (old_sg_flags & CRMOD)
  6526.         { var struct sgttyb oldsgttyb;
  6527.           if (!( ioctl(stdout_handle,TIOCGETP,&oldsgttyb) ==0))
  6528.             { if (!(errno==ENOTTY)) { OS_error(); } }
  6529.           oldsgttyb.sg_flags |= CRMOD;
  6530.           if (!( ioctl(stdout_handle,TIOCSETP,&oldsgttyb) ==0))
  6531.             { if (!(errno==ENOTTY)) { OS_error(); } }
  6532.     }   }
  6533. #endif
  6534.  
  6535. #endif # NL_HACK
  6536.  
  6537. # Beginn des Arbeitens mit diesem Paket:
  6538.   local void start_term (void);
  6539.   local void start_term()
  6540.     {
  6541.       #ifdef NL_HACK
  6542.       if (NLcap[0] == '\n') { term_nlraw(); }
  6543.       #endif
  6544.       out_capstring (IScap);
  6545.       out_capstring (TIcap);
  6546.     }
  6547.  
  6548. # Ende des Arbeitens mit diesem Paket:
  6549.   local void end_term (void);
  6550.   local void end_term()
  6551.     { out_capstring (TEcap);
  6552.       out_capstring (IScap);
  6553.       #ifdef MSDOS # wie testet man auf Farb-ANSI-Terminal??
  6554.       # Auf ANSI-Terminals mit mehreren Farben: TEcap setzt die Farben zurück.
  6555.       out_capstring(CLcap); # Bildschirm löschen, diesmal in der normalen Farbe
  6556.       #endif
  6557.       #ifdef NL_HACK
  6558.       if (NLcap[0] == '\n') { term_nlunraw(); }
  6559.       #endif
  6560.     }
  6561.  
  6562. # Initialisiert das Window curr.
  6563.   local void init_curr (void);
  6564.   local void init_curr()
  6565.     { {var reg1 uintB** ptr = malloc(rows*sizeof(uintB*));
  6566.        var reg2 uintC count;
  6567.        curr->image = ptr;
  6568.        dotimespC(count,rows, { *ptr++ = malloc(cols*sizeof(uintB)); } );
  6569.       }
  6570.       #if WANT_ATTR
  6571.       {var reg1 uintB** ptr = malloc(rows*sizeof(uintB*));
  6572.        var reg2 uintC count;
  6573.        curr->attr = ptr;
  6574.        dotimespC(count,rows, { *ptr++ = malloc(cols*sizeof(uintB)); } );
  6575.       }
  6576.       # Attribute ausschalten:
  6577.       out_capstring(UEcap); # alle aus
  6578.       out_capstring(SEcap);
  6579.       out_capstring(MEcap);
  6580.       term_attr = curr->curr_attr = 0;
  6581.       #endif
  6582.       #if WANT_CHARSET
  6583.       {var reg1 uintB** ptr = malloc(rows*sizeof(uintB*));
  6584.        var reg2 uintC count;
  6585.        curr->font = ptr;
  6586.        dotimespC(count,rows, { *ptr++ = malloc(cols*sizeof(uintB)); } );
  6587.       }
  6588.       {var reg1 uintC i = 0;
  6589.        while (i<charset_count) { curr->charsets[i] = ASCII; i++; }
  6590.       }
  6591.       curr->curr_charset = 0;
  6592.       if (ISO2022) { out_char(ESC); out_char('('); out_char('B'); } /*)*/
  6593.       term_charset = ASCII;
  6594.       #endif
  6595.       curr->x = 0; curr->y = 0;
  6596.       curr->top = 0; curr->bot = rows-1;
  6597.       #if WANT_INSERT
  6598.       curr->insert = FALSE;
  6599.       #endif
  6600.       #if WANT_SAVE
  6601.       curr->saved = FALSE;
  6602.       #endif
  6603.       if (CScap) { out_capstring(tgoto(CScap,curr->bot,curr->top)); }
  6604.       clear_screen();
  6605.     }
  6606.  
  6607. # ------------------------------------------------------------------------------
  6608.  
  6609. # UP: Ein Zeichen auf einen Window-Stream ausgeben.
  6610. # wr_ch_window(&stream,ch);
  6611. # > stream: Window-Stream
  6612. # > ch: auszugebendes Zeichen
  6613.   local void wr_ch_window (object* stream_, object ch);
  6614.   local void wr_ch_window(stream_,ch)
  6615.     var reg2 object* stream_;
  6616.     var reg3 object ch;
  6617.     { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein
  6618.      {var reg1 uintB c = char_code(ch); # Code des Zeichens
  6619.       if (graphic_char_p(c))
  6620.         { if (curr->x == cols) { cursor_return(); cursor_linefeed(); } # Wrap!
  6621.           output_1char(c);
  6622.         }
  6623.       elif (c == NL)
  6624.         { cursor_return(); cursor_linefeed(); }
  6625.       elif (c == BS)
  6626.         { var reg4 int x0 = curr->x;
  6627.           if (x0>0)
  6628.             { var reg5 int y0 = curr->y;
  6629.               clear_linepart(y0,x0-1,x0);
  6630.               gofromto(curr->y,curr->x,y0,x0-1); curr->y = y0; curr->x = x0-1;
  6631.         }   }
  6632.     }}
  6633.  
  6634. LISPFUNN(make_window,0)
  6635.   { var reg2 object stream =
  6636.       allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1);
  6637.       # Flags: nur WRITE-CHAR erlaubt
  6638.     # und füllen:
  6639.     var reg1 Stream s = TheStream(stream);
  6640.       s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  6641.       s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  6642.       s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unmöglich
  6643.       s->strm_rd_ch_last = NIL; # Lastchar := NIL
  6644.       s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion
  6645.       s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  6646.       #ifdef STRM_WR_SS
  6647.       s->strm_wr_ss = P(wr_ss_dummy_nogc);
  6648.       #endif
  6649.     # Initialisieren:
  6650.     {var reg3 char* ergebnis = init_term();
  6651.      if (!(ergebnis==NULL)) { fehler(error,ergebnis); }
  6652.     }
  6653.     start_term();
  6654.     init_curr();
  6655.     value1 = stream; mv_count=1;
  6656.   }
  6657.  
  6658. # Schließt einen Window-Stream.
  6659.   local void close_window (object stream);
  6660.   local void close_window(stream)
  6661.     var reg1 object stream;
  6662.     { end_term(); }
  6663.  
  6664. LISPFUNN(window_size,1)
  6665.   { check_window_stream(popSTACK());
  6666.     value1 = fixnum(rows); # Variablen rows,cols abfragen
  6667.     value2 = fixnum(cols);
  6668.     mv_count=2;
  6669.   }
  6670.  
  6671. LISPFUNN(window_cursor_position,1)
  6672.   { check_window_stream(popSTACK());
  6673.     value1 = fixnum(curr->y);
  6674.     value2 = fixnum(curr->x);
  6675.     mv_count=2;
  6676.   }
  6677.  
  6678. LISPFUNN(set_window_cursor_position,3)
  6679.   { check_window_stream(STACK_2);
  6680.    {var reg1 uintL line = posfixnum_to_L(STACK_1);
  6681.     var reg2 uintL column = posfixnum_to_L(STACK_0);
  6682.     if ((line < rows) && (column < cols))
  6683.       { gofromto(curr->y,curr->x,line,column); # Cursor positionieren
  6684.         curr->y = line; curr->x = column;
  6685.       }
  6686.     value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3);
  6687.   }}
  6688.  
  6689. LISPFUNN(clear_window,1)
  6690.   { check_window_stream(popSTACK());
  6691.     clear_screen();
  6692.     value1 = NIL; mv_count=0;
  6693.   }
  6694.  
  6695. LISPFUNN(clear_window_to_eot,1)
  6696.   { check_window_stream(popSTACK());
  6697.     clear_to_EOS();
  6698.     value1 = NIL; mv_count=0;
  6699.   }
  6700.  
  6701. LISPFUNN(clear_window_to_eol,1)
  6702.   { check_window_stream(popSTACK());
  6703.     clear_to_EOL();
  6704.     value1 = NIL; mv_count=0;
  6705.   }
  6706.  
  6707. LISPFUNN(delete_window_line,1)
  6708.   { check_window_stream(popSTACK());
  6709.     delete_line(1);
  6710.     value1 = NIL; mv_count=0;
  6711.   }
  6712.  
  6713. LISPFUNN(insert_window_line,1)
  6714.   { check_window_stream(popSTACK());
  6715.     insert_line(1);
  6716.     value1 = NIL; mv_count=0;
  6717.   }
  6718.  
  6719. LISPFUNN(highlight_on,1)
  6720.   { check_window_stream(popSTACK());
  6721.     change_attr(curr->curr_attr |= A_US);
  6722.     value1 = NIL; mv_count=0;
  6723.   }
  6724.  
  6725. LISPFUNN(highlight_off,1)
  6726.   { check_window_stream(popSTACK());
  6727.     change_attr(curr->curr_attr &= ~A_US);
  6728.     value1 = NIL; mv_count=0;
  6729.   }
  6730.  
  6731. LISPFUNN(window_cursor_on,1)
  6732.   { check_window_stream(popSTACK());
  6733.     # Cursor ist permanent an!
  6734.     value1 = NIL; mv_count=0;
  6735.   }
  6736.  
  6737. LISPFUNN(window_cursor_off,1)
  6738.   { check_window_stream(popSTACK());
  6739.     # geht nicht, da Cursor permanent an!
  6740.     value1 = NIL; mv_count=0;
  6741.   }
  6742.  
  6743. #endif # (UNIX && !NEXTAPP) || EMUNIX_PORTABEL || RISCOS
  6744.  
  6745. #if defined(MAYBE_NEXTAPP) && defined(NEXTAPP)
  6746.  
  6747. # Alles unimplementiert.
  6748.  
  6749. LISPFUNN(make_window,0)
  6750.   { fehler_screen(); }
  6751.  
  6752. #define close_window(stream)  fehler_screen()
  6753.  
  6754. LISPFUNN(window_size,1)
  6755.   { fehler_screen(); }
  6756.  
  6757. LISPFUNN(window_cursor_position,1)
  6758.   { fehler_screen(); }
  6759.  
  6760. LISPFUNN(set_window_cursor_position,3)
  6761.   { fehler_screen(); }
  6762.  
  6763. LISPFUNN(clear_window,1)
  6764.   { fehler_screen(); }
  6765.  
  6766. LISPFUNN(clear_window_to_eot,1)
  6767.   { fehler_screen(); }
  6768.  
  6769. LISPFUNN(clear_window_to_eol,1)
  6770.   { fehler_screen(); }
  6771.  
  6772. LISPFUNN(delete_window_line,1)
  6773.   { fehler_screen(); }
  6774.  
  6775. LISPFUNN(insert_window_line,1)
  6776.   { fehler_screen(); }
  6777.  
  6778. LISPFUNN(highlight_on,1)
  6779.   { fehler_screen(); }
  6780.  
  6781. LISPFUNN(highlight_off,1)
  6782.   { fehler_screen(); }
  6783.  
  6784. LISPFUNN(window_cursor_on,1)
  6785.   { fehler_screen(); }
  6786.  
  6787. LISPFUNN(window_cursor_off,1)
  6788.   { fehler_screen(); }
  6789.  
  6790. #endif # NEXTAPP
  6791.  
  6792. #if defined(UNIX) && 0
  6793.  
  6794. # Normales CURSES-Paket, wir benutzen nur stdscr.
  6795.  
  6796. #undef BS
  6797. #undef CR
  6798. #undef NL
  6799. #include <curses.h>
  6800. #undef OK
  6801. #define CR  13
  6802. #define NL  10
  6803.  
  6804. # UP: Ein Zeichen auf einen Window-Stream ausgeben.
  6805. # wr_ch_window(&stream,ch);
  6806. # > stream: Window-Stream
  6807. # > ch: auszugebendes Zeichen
  6808.   local void wr_ch_window (object* stream_, object ch);
  6809.   local void wr_ch_window(stream_,ch)
  6810.     var reg2 object* stream_;
  6811.     var reg1 object ch;
  6812.     { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein
  6813.      {var reg1 uintB c = char_code(ch); # Code des Zeichens
  6814.       begin_system_call();
  6815.       if (graphic_char_p(c)) # nur druckbare Zeichen auf den Bildschirm lassen
  6816.         { addch(c); }
  6817.       elif (c == NL) # NL in CR/LF umwandeln
  6818.         { addch(CR); addch(LF); }
  6819.       else # etwas ausgeben, damit die Cursorposition stimmt
  6820.         { addch('?'); }
  6821.       end_system_call();
  6822.     }}
  6823.  
  6824. LISPFUNN(make_window,0)
  6825.   { var reg2 object stream =
  6826.       allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1);
  6827.       # Flags: nur WRITE-CHAR erlaubt
  6828.     # und füllen:
  6829.     var reg1 Stream s = TheStream(stream);
  6830.       s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  6831.       s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  6832.       s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unmöglich
  6833.       s->strm_rd_ch_last = NIL; # Lastchar := NIL
  6834.       s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion
  6835.       s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  6836.       #ifdef STRM_WR_SS
  6837.       s->strm_wr_ss = P(wr_ss_dummy_nogc);
  6838.       #endif
  6839.     begin_system_call();
  6840.     initscr(); # Curses initialisieren # Was ist, wenn das abstürzt?? newterm() benutzen??
  6841.     cbreak(); noecho(); # Input nicht zeilengebuffert, ohne Echo
  6842.     #if defined(SUN3) || defined(SUN4)
  6843.     keypad(stdscr,TRUE); # Funktionstasten-Erkennung einschalten
  6844.     #endif
  6845.     end_system_call();
  6846.     value1 = stream; mv_count=1;
  6847.   }
  6848.  
  6849. # Schließt einen Window-Stream.
  6850.   local void close_window (object stream);
  6851.   local void close_window(stream)
  6852.     var reg1 object stream;
  6853.     { begin_system_call();
  6854.       nocbreak(); echo(); # Input wieder zeilengebuffert, mit Echo
  6855.       #if defined(SUN3) || defined(SUN4)
  6856.       keypad(stdscr,FALSE); # Funktionstasten-Erkennung wieder ausschalten
  6857.       #endif
  6858.       endwin(); # Curses abschalten
  6859.       end_system_call();
  6860.     }
  6861.  
  6862. LISPFUNN(window_size,1)
  6863.   { check_window_stream(popSTACK());
  6864.     value1 = fixnum(LINES); # Curses-Variablen LINES, COLS abfragen
  6865.     value2 = fixnum(COLS);
  6866.     mv_count=2;
  6867.   }
  6868.  
  6869. LISPFUNN(window_cursor_position,1)
  6870.   { check_window_stream(popSTACK());
  6871.    {var reg1 int y;
  6872.     var reg2 int x;
  6873.     begin_system_call();
  6874.     getyx(stdscr,y,x); # (y,x) := cursor position
  6875.     end_system_call();
  6876.     value1 = fixnum(y);
  6877.     value2 = fixnum(x);
  6878.     mv_count=2;
  6879.   }}
  6880.  
  6881. LISPFUNN(set_window_cursor_position,3)
  6882.   { check_window_stream(STACK_2);
  6883.    {var reg1 uintL line = posfixnum_to_L(STACK_1);
  6884.     var reg2 uintL column = posfixnum_to_L(STACK_0);
  6885.     if ((line < LINES) && (column < COLS))
  6886.       { begin_system_call();
  6887.         move(line,column); refresh(); # Cursor positionieren
  6888.         end_system_call();
  6889.       }
  6890.     value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3);
  6891.   }}
  6892.  
  6893. LISPFUNN(clear_window,1)
  6894.   { check_window_stream(popSTACK());
  6895.     begin_system_call();
  6896.     clear(); refresh();
  6897.     end_system_call();
  6898.     value1 = NIL; mv_count=0;
  6899.   }
  6900.  
  6901. LISPFUNN(clear_window_to_eot,1)
  6902.   { check_window_stream(popSTACK());
  6903.     begin_system_call();
  6904.     clrtobot(); refresh();
  6905.     end_system_call();
  6906.     value1 = NIL; mv_count=0;
  6907.   }
  6908.  
  6909. LISPFUNN(clear_window_to_eol,1)
  6910.   { check_window_stream(popSTACK());
  6911.     begin_system_call();
  6912.     clrtoeol(); refresh();
  6913.     end_system_call();
  6914.     value1 = NIL; mv_count=0;
  6915.   }
  6916.  
  6917. LISPFUNN(delete_window_line,1)
  6918.   { check_window_stream(popSTACK());
  6919.     begin_system_call();
  6920.     deleteln(); refresh();
  6921.     end_system_call();
  6922.     value1 = NIL; mv_count=0;
  6923.   }
  6924.  
  6925. LISPFUNN(insert_window_line,1)
  6926.   { check_window_stream(popSTACK());
  6927.     begin_system_call();
  6928.     insertln(); refresh();
  6929.     end_system_call();
  6930.     value1 = NIL; mv_count=0;
  6931.   }
  6932.  
  6933. LISPFUNN(highlight_on,1)
  6934.   { check_window_stream(popSTACK());
  6935.     #ifdef A_STANDOUT # geht nur, wenn Curses Attribute verwaltet
  6936.     begin_system_call();
  6937.     attron(A_STANDOUT); # Attribut A_STANDOUT bei addch() hineinoderieren
  6938.     end_system_call();
  6939.     #endif
  6940.     value1 = NIL; mv_count=0;
  6941.   }
  6942.  
  6943. LISPFUNN(highlight_off,1)
  6944.   { check_window_stream(popSTACK());
  6945.     #ifdef A_STANDOUT # geht nur, wenn Curses Attribute verwaltet
  6946.     begin_system_call();
  6947.     attroff(A_STANDOUT); # kein Attribut mehr bei addch() hineinoderieren
  6948.     end_system_call();
  6949.     #endif
  6950.     value1 = NIL; mv_count=0;
  6951.   }
  6952.  
  6953. LISPFUNN(window_cursor_on,1)
  6954.   { check_window_stream(popSTACK());
  6955.     # Cursor ist permanent an!
  6956.     value1 = NIL; mv_count=0;
  6957.   }
  6958.  
  6959. LISPFUNN(window_cursor_off,1)
  6960.   { check_window_stream(popSTACK());
  6961.     # geht nicht, da Cursor permanent an!
  6962.     value1 = NIL; mv_count=0;
  6963.   }
  6964.  
  6965. #endif # UNIX
  6966.  
  6967. #ifdef AMIGAOS
  6968.  
  6969. # Terminal-Emulation: ANSI-Steuerzeichen, siehe console.doc
  6970.  
  6971. # UP: Ausgabe mehrerer Zeichen auf den Bildschirm
  6972.   local void wr_window (uintB* outbuffer, uintL count);
  6973.   local void wr_window(outbuffer,count)
  6974.     var reg2 uintB* outbuffer;
  6975.     var reg3 uintL count;
  6976.     { set_break_sem_1();
  6977.       begin_system_call();
  6978.      {var reg1 long ergebnis = Write(Output_handle,outbuffer,count);
  6979.       end_system_call();
  6980.       if (ergebnis<0) { OS_error(); } # Error melden
  6981.       if (ergebnis<count) # nicht erfolgreich?
  6982.         { ?? }
  6983.       clr_break_sem_1();
  6984.     }}
  6985.  
  6986. #define WR_WINDOW(characters)  \
  6987.   { local var uintB outbuffer[] = characters; \
  6988.      wr_window(&outbuffer,sizeof(outbuffer)); \
  6989.   }
  6990.  
  6991. # UP: Ein Zeichen auf einen Window-Stream ausgeben.
  6992. # wr_ch_window(&stream,ch);
  6993. # > stream: Window-Stream
  6994. # > ch: auszugebendes Zeichen
  6995.   local void wr_ch_window (object* stream_, object ch);
  6996.   local void wr_ch_window(stream_,ch)
  6997.     var reg2 object* stream_;
  6998.     var reg3 object ch;
  6999.     { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein
  7000.      {var reg1 uintB c = char_code(ch); # Code des Zeichens
  7001.       ??
  7002.     }}
  7003.  
  7004. LISPFUNN(make_window,0)
  7005.   { finish_output_terminal(var_stream(S(terminal_io),strmflags_wr_ch_B)); # evtl. wartendes NL jetzt ausgeben
  7006.    {var reg2 object stream =
  7007.       allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+0);
  7008.       # Flags: nur WRITE-CHAR erlaubt
  7009.     # und füllen:
  7010.     var reg1 Stream s = TheStream(stream);
  7011.       s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unmöglich
  7012.       s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unmöglich
  7013.       s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unmöglich
  7014.       s->strm_rd_ch_last = NIL; # Lastchar := NIL
  7015.       s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion
  7016.       s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  7017.       #ifdef STRM_WR_SS
  7018.       s->strm_wr_ss = P(wr_ss_dummy_nogc);
  7019.       #endif
  7020.     # size: aWSR? aWBR??
  7021.     # Wrap off ?? ASM? AWM?
  7022.     WR_WINDOW({CSI,'0',0x6D}); # Set Graphics Rendition Normal
  7023.     value1 = stream; mv_count=1;
  7024.   }}
  7025.  
  7026. # Schließt einen Window-Stream.
  7027.   local void close_window (object stream);
  7028.   local void close_window(stream)
  7029.     var reg1 object stream;
  7030.     { # Wrap on ?? ASM? AWM?
  7031.       WR_WINDOW({CSI,'0',0x6D}); # Set Graphics Rendition Normal
  7032.     }
  7033.  
  7034. LISPFUNN(window_size,1)
  7035.   { check_window_stream(popSTACK());
  7036.     value1 = fixnum(window_size.y); ??
  7037.     value2 = fixnum(window_size.x); ??
  7038.     mv_count=2;
  7039.   }
  7040.  
  7041. LISPFUNN(window_cursor_position,1)
  7042.   { check_window_stream(popSTACK());
  7043.     # aWSR? CPR??
  7044.     value1 = fixnum(_y); ??
  7045.     value2 = fixnum(_x); ??
  7046.     mv_count=2;
  7047.   }
  7048.  
  7049. LISPFUNN(set_window_cursor_position,3)
  7050.   { check_window_stream(STACK_2);
  7051.    {var reg3 uintL line = posfixnum_to_L(STACK_1);
  7052.     var reg4 uintL column = posfixnum_to_L(STACK_0);
  7053.     if ((line < (uintL)window_size.y) && (column < (uintL)window_size.x))
  7054.       { var uintB outbuffer[23]; # Buffer für  CSI <line> ; <column> H
  7055.         var reg1 uintB* ptr = &outbuffer[sizeof(outbuffer)];
  7056.         var reg2 uintL count = 0;
  7057.         count++; *--ptr = 'H';
  7058.         do { count++; *--ptr = '0'+(column%10); column = floor(column,10); }
  7059.            until (column==0);
  7060.         count++; *--ptr = ';';
  7061.         do { count++; *--ptr = '0'+(line%10); line = floor(line,10); }
  7062.            until (line==0);
  7063.         count++; *--ptr = CSI;
  7064.         wr_window(ptr,count);
  7065.       }
  7066.     value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3);
  7067.   }}
  7068.  
  7069. LISPFUNN(clear_window,1)
  7070.   { check_window_stream(popSTACK());
  7071.     WR_WINDOW({CSI,'0',';','0','H',CSI,'J'});
  7072.     value1 = NIL; mv_count=0;
  7073.   }
  7074.  
  7075. LISPFUNN(clear_window_to_eot,1)
  7076.   { check_window_stream(popSTACK());
  7077.     WR_WINDOW({CSI,'J'});
  7078.     value1 = NIL; mv_count=0;
  7079.   }
  7080.  
  7081. LISPFUNN(clear_window_to_eol,1)
  7082.   { check_window_stream(popSTACK());
  7083.     WR_WINDOW({CSI,'K'});
  7084.     value1 = NIL; mv_count=0;
  7085.   }
  7086.  
  7087. LISPFUNN(delete_window_line,1)
  7088.   { check_window_stream(popSTACK());
  7089.     WR_WINDOW({CSI,'M'});
  7090.     value1 = NIL; mv_count=0;
  7091.   }
  7092.  
  7093. LISPFUNN(insert_window_line,1)
  7094.   { check_window_stream(popSTACK());
  7095.     WR_WINDOW({CSI,'L'});
  7096.     value1 = NIL; mv_count=0;
  7097.   }
  7098.  
  7099. LISPFUNN(highlight_on,1)
  7100.   { check_window_stream(popSTACK());
  7101.     WR_WINDOW({CSI,'1',0x6D}); # Set Graphics Rendition Bold
  7102.     value1 = NIL; mv_count=0;
  7103.   }
  7104.  
  7105. LISPFUNN(highlight_off,1)
  7106.   { check_window_stream(popSTACK());
  7107.     WR_WINDOW({CSI,'0',0x6D}); # Set Graphics Rendition Normal
  7108.     value1 = NIL; mv_count=0;
  7109.   }
  7110.  
  7111. LISPFUNN(window_cursor_on,1)
  7112.   { check_window_stream(popSTACK());
  7113.     # aSCR ??
  7114.     value1 = NIL; mv_count=0;
  7115.   }
  7116.  
  7117. LISPFUNN(window_cursor_off,1)
  7118.   { check_window_stream(popSTACK());
  7119.     # aSCR ??
  7120.     value1 = NIL; mv_count=0;
  7121.   }
  7122.  
  7123. #endif # AMIGAOS
  7124.  
  7125. #endif # SCREEN
  7126.  
  7127.  
  7128. # File-Stream
  7129. # ===========
  7130.  
  7131. # Um nicht für jedes Character das GEMDOS/UNIX/AMIGADOS bemühen zu müssen,
  7132. # wird ein eigener Buffer geführt.
  7133. # (Dies bewirkte z.B. beim Einlesen eines 408 KByte- Files auf dem Atari
  7134. # eine Beschleunigung um einen Faktor 2.7 von 500 sec auf 180 sec.)
  7135.  
  7136. # Zusätzliche Komponenten:
  7137.   # define strm_file_name       strm_other[3] # Filename, ein Pathname
  7138.   # define strm_file_truename   strm_other[4] # Truename, ein Pathname
  7139.   # define strm_file_handle     strm_other[2] # Handle, ein Fixnum >=0, <2^16
  7140.   #define strm_file_buffstart   strm_other[0] # Buffer-Startposition, ein Fixnum >=0
  7141.   #define strm_file_bufflen     4096          # Bufferlänge (Zweierpotenz <2^16)
  7142.   #define strm_file_buffer      strm_other[1] # eigener Buffer,
  7143.                                 # ein Simple-String der Länge strm_file_bufflen
  7144.   #define strm_file_eofindex    strm_other[5] # Index darin, bis wo die
  7145.                                 # Daten gültig sind (für EOF-Erkennung)
  7146.   #define strm_file_index       strm_other[6] # Fixnum mit Index im Buffer
  7147.                                               # (>=0, <=STRM_FILE_BUFFLEN)
  7148.                                               # und Modified-Flag in Bit 16.
  7149.   # eofindex = NIL: Bufferdaten ganz ungültig, index=0.
  7150.   # eofindex Fixnum: 0 <= index <= eofindex <= strm_file_bufflen.
  7151.   # eofindex = T: Bufferdaten ganz gültig, 0 <= index <= strm_file_bufflen.
  7152.   # buffstart = (Nummer des Sectors) * strm_file_bufflen.
  7153.   # Beim Betriebssystem ist das File 'handle' i.a. (aber nicht immer!) ans Ende
  7154.   #   des aktuellen Buffers positioniert:
  7155.   #   bei eofindex = T: buffstart + strm_file_bufflen,
  7156.   #   bei eofindex Fixnum: buffstart + eofindex,
  7157.   #   bei eofindex = NIL: buffstart.
  7158.   # Modified-Flag abfragen und verändern:
  7159.   #define modified_flag(stream)  \
  7160.     (as_oint(TheStream(stream)->strm_file_index) & wbit(16+oint_data_shift))
  7161.   #define set_modified_flag(stream)  \
  7162.     TheStream(stream)->strm_file_index = \
  7163.       as_object(as_oint(TheStream(stream)->strm_file_index) | wbit(16+oint_data_shift))
  7164.   #define reset_modified_flag(stream)  \
  7165.     TheStream(stream)->strm_file_index = \
  7166.       as_object(as_oint(TheStream(stream)->strm_file_index) & ~wbit(16+oint_data_shift))
  7167. # Bis hierher wird ein File aus Bytes à 8 Bits aufgebaut gedacht.
  7168. # Logisch ist es jedoch aus anderen Einheiten aufgebaut:
  7169.   #define strm_file_position    strm_other[7] # Position, ein Fixnum >=0
  7170.   # Bei File-Streams mit element-type = STRING-CHAR (sch_file)
  7171.   #   belegt jedes Character 1 Byte.
  7172.   # define strm_sch_file_lineno strm_other[8] # Zeilennummer beim Lesen, ein Fixnum >0
  7173.   # Bei File-Streams mit element-type = CHARACTER (ch_file)
  7174.   #   belegt jedes Character 2 Bytes.
  7175.   # Bei File-Streams mit element-type = INTEGER ("Byte-Files")
  7176.   #   belegt jeder Integer immer dieselbe Anzahl Bits.
  7177.   #define strm_file_bitsize     strm_other[8] # Anzahl der Bits, ein Fixnum >0 und <intDsize*uintC_max
  7178.   #define strm_file_bitbuffer   strm_other[9] # Buffer, ein Simple-Bit-Vector
  7179.                                               # mit ceiling(bitsize/8)*8 Bits
  7180.   #   Ist diese Anzahl nicht durch 8 teilbar, so ist bitindex der Index
  7181.   #   im aktuellen Byte:
  7182.   #define strm_file_bitindex    strm_other[10] # Index im Byte, ein Fixnum >=0 und <=8
  7183.   #   8*index+bitindex ist die Anzahl der gelesenen Bits des Buffers.
  7184.   #   Die Bits sind in der Reihenfolge Bit0,...,Bit7 angeordnet.
  7185.   #   Ist Bitsize<8, so wird beim Schließen des Files die Länge des Files
  7186.   #   (gemessen in Bits) als .L am Anfang des Files abgelegt, die Daten
  7187.   #   fangen also erst beim 5. Byte an.
  7188.   #define strm_file_eofposition  strm_other[11] # Position des logischen EOF, ein Fixnum >=0
  7189. # Bei geschlossenen File-Streams sind nur die Komponenten name und truename
  7190. # relevant.
  7191.  
  7192. # File-Stream allgemein
  7193. # =====================
  7194.  
  7195. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  7196. # Annahme: Alle von OPEN(2) gelieferten File-Descriptoren (hier Handles
  7197. # genannt) passen in ein uintW.
  7198. # Begründung: Bekanntlich ist 0 <= fd < getdtablesize() .
  7199. #endif
  7200.  
  7201. # Handle positionieren:
  7202. # file_lseek(stream,offset,mode,ergebnis_zuweisung);
  7203. # > mode: Positionierungsmodus:
  7204. #         SEEK_SET  "absolut"
  7205. #         SEEK_CUR  "relativ"
  7206. #         SEEK_END  "ab Ende"
  7207. # < ergebnis: neue Position
  7208.   #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  7209.     #define file_lseek(stream,offset,mode,ergebnis_zuweisung)  \
  7210.       { var reg2 sintL ergebnis =             \
  7211.           lseek(TheHandle(TheStream(stream)->strm_file_handle), # Handle \
  7212.                 offset,                       \
  7213.                 mode                          \
  7214.                );                             \
  7215.         if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? \
  7216.         unused (ergebnis_zuweisung ergebnis); \
  7217.       }
  7218.   #endif
  7219.   #ifdef AMIGAOS
  7220.     #define file_lseek(stream,offset,mode,ergebnis_zuweisung)  \
  7221.       { var reg3 uintL _offset = (offset);                     \
  7222.         var reg2 sintL ergebnis =                              \
  7223.           Seek(TheHandle(TheStream(stream)->strm_file_handle), \
  7224.                _offset,                                        \
  7225.                mode                                            \
  7226.               );                                               \
  7227.         if (ergebnis<0) { OS_error(); } # Fehler aufgetreten?  \
  7228.         if (mode==SEEK_SET) { unused (ergebnis_zuweisung _offset); }     \
  7229.         elif (mode==SEEK_CUR) { unused (ergebnis_zuweisung ergebnis+_offset); } \
  7230.         else /* mode==SEEK_END */                                      \
  7231.           { ergebnis = Seek(TheHandle(TheStream(stream)->strm_file_handle),0,SEEK_CUR); \
  7232.             if (ergebnis<0) { OS_error(); } # Fehler aufgetreten?      \
  7233.             unused (ergebnis_zuweisung ergebnis);                      \
  7234.       }   }
  7235.     #define SEEK_SET  OFFSET_BEGINNING
  7236.     #define SEEK_CUR  OFFSET_CURRENT
  7237.     #define SEEK_END  OFFSET_END
  7238.   #endif
  7239.  
  7240. # UP: Beendet das Zurückschreiben des Buffers.
  7241. # b_file_finish_flush(stream,bufflen);
  7242. # > stream : (offener) Byte-basierter File-Stream.
  7243. # > bufflen : Anzahl der zu schreibenden Bytes
  7244. # < modified_flag von stream : gelöscht
  7245. # verändert in stream: index
  7246.   local void b_file_finish_flush (object stream, uintL bufflen);
  7247.   local void b_file_finish_flush(stream,bufflen)
  7248.     var reg1 object stream;
  7249.     var reg2 uintL bufflen;
  7250.     { begin_system_call();
  7251.      {var reg3 sintL ergebnis = # Buffer hinausschreiben
  7252.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  7253.           full_write(TheHandle(TheStream(stream)->strm_file_handle), # Handle
  7254.                      &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse
  7255.                      bufflen
  7256.                     )
  7257.         #endif
  7258.         #ifdef AMIGAOS
  7259.           Write(TheHandle(TheStream(stream)->strm_file_handle),
  7260.                 &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse
  7261.                 bufflen
  7262.                )
  7263.         #endif
  7264.         ;
  7265.       end_system_call();
  7266.       if (ergebnis==bufflen)
  7267.         # alles korrekt geschrieben
  7268.         { reset_modified_flag(stream); }
  7269.         else
  7270.         # Nicht alles geschrieben
  7271.         {
  7272.           #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  7273.           if (ergebnis<0) # Fehler aufgetreten?
  7274.             #ifdef ENOSPC
  7275.             if (!(errno == ENOSPC))
  7276.             #endif
  7277.             #ifdef EDQUOT
  7278.             if (!(errno == EDQUOT))
  7279.             #endif
  7280.               { OS_error(); }
  7281.           #endif
  7282.           #ifdef AMIGAOS
  7283.           if (ergebnis<0) { OS_error(); } # Fehler aufgetreten?
  7284.           #endif
  7285.           # Nicht alles geschrieben, wohl wegen voller Diskette.
  7286.           # Um Inkonsistenzen zu vermeiden, muß man das File schließen.
  7287.           reset_modified_flag(stream); # Hierbei gehen Daten verloren!
  7288.           pushSTACK(stream);
  7289.           stream_close(&STACK_0); # File schließen
  7290.           clr_break_sem_4(); # keine GEMDOS/UNIX-Operation mehr aktiv
  7291.           # Fehler melden.
  7292.           pushSTACK(TheStream(STACK_0)->strm_file_truename); # Wert für Slot PATHNAME von FILE-ERROR
  7293.           pushSTACK(STACK_(0+1)); # stream
  7294.           //: DEUTSCH "Diskette/Platte voll. Deswegen wurde ~ geschlossen."
  7295.           //: ENGLISH "Closed ~ because disk is full."
  7296.           //: FRANCAIS "Ai fermé ~, parce que le disque est sans doute plein."
  7297.           fehler(file_error,GETTEXT("Closed ~ because disk is full."));
  7298.     }}  }
  7299.  
  7300. # UP: Schreibt den vollen, modifizierten Buffer zurück.
  7301. # b_file_full_flush(stream);
  7302. # > stream : (offener) Byte-basierter File-Stream.
  7303. # < modified_flag von stream : gelöscht
  7304. # verändert in stream: index
  7305.   local void b_file_full_flush (object stream);
  7306.   local void b_file_full_flush(stream)
  7307.     var reg1 object stream;
  7308.     { # erst zurückpositionieren, dann schreiben.
  7309.       begin_system_call();
  7310.       file_lseek(stream,-(long)strm_file_bufflen,SEEK_CUR,_EMA_); # Zurückpositionieren
  7311.       end_system_call();
  7312.       b_file_finish_flush(stream,strm_file_bufflen);
  7313.     }
  7314.  
  7315. # UP: Schreibt den halbvollen, modifizierten Buffer zurück.
  7316. # b_file_full_flush(stream);
  7317. # > stream : (offener) Byte-basierter File-Stream.
  7318. # < modified_flag von stream : gelöscht
  7319. # verändert in stream: index
  7320.   local void b_file_half_flush (object stream);
  7321.   local void b_file_half_flush(stream)
  7322.     var reg1 object stream;
  7323.     { begin_system_call();
  7324.       file_lseek(stream,posfixnum_to_L(TheStream(stream)->strm_file_buffstart),SEEK_SET,_EMA_); # Zurückpositionieren
  7325.       end_system_call();
  7326.       # eofindex Bytes schreiben:
  7327.       b_file_finish_flush(stream,
  7328.                           posfixnum_to_L(TheStream(stream)->strm_file_eofindex)
  7329.                          );
  7330.     }
  7331.  
  7332. # UP: Schreibt den modifizierten Buffer zurück.
  7333. # b_file_flush(stream);
  7334. # > stream : (offener) Byte-basierter File-Stream.
  7335. # < modified_flag von stream : gelöscht
  7336. # verändert in stream: index
  7337.   local void b_file_flush (object stream);
  7338.   local void b_file_flush(stream)
  7339.     var reg1 object stream;
  7340.     { if (eq(TheStream(stream)->strm_file_eofindex,T)) # Buffer ganz gültig ?
  7341.         { b_file_full_flush(stream); }
  7342.         else
  7343.         { b_file_half_flush(stream); }
  7344.     }
  7345.  
  7346. # UP: Positioniert einen Byte-basierten File-Stream so, daß das nächste Byte
  7347. # gelesen oder überschrieben werden kann.
  7348. # b_file_nextbyte(stream)
  7349. # > stream : (offener) Byte-basierter File-Stream.
  7350. # < ergebnis : NULL falls EOF (und dann ist index=eofindex),
  7351. #              sonst: Pointer auf nächstes Byte
  7352. # verändert in stream: index, eofindex, buffstart
  7353.   local uintB* b_file_nextbyte (object stream);
  7354.   local uintB* b_file_nextbyte(stream)
  7355.     var reg1 object stream;
  7356.     { var reg2 object eofindex = TheStream(stream)->strm_file_eofindex;
  7357.       var reg3 object index = TheStream(stream)->strm_file_index;
  7358.       if (!eq(eofindex,T))
  7359.         # Bufferdaten nur halb gültig
  7360.         { if (eq(eofindex,NIL))
  7361.             # Bufferdaten ganz ungültig
  7362.             { goto reread; }
  7363.             else
  7364.             # EOF tritt in diesem Sector auf
  7365.             { goto eofsector; }
  7366.         }
  7367.       # Bufferdaten ganz gültig
  7368.       if (!((uintW)posfixnum_to_L(index) == strm_file_bufflen)) # index = bufflen ?
  7369.         # nein, also 0 <= index < strm_file_bufflen -> OK
  7370.         { return &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(index)]; }
  7371.       # Buffer muß neu gefüllt werden.
  7372.       if (modified_flag(stream))
  7373.         # Zuvor muß der Buffer hinausgeschrieben werden:
  7374.         { b_file_full_flush(stream); }
  7375.       TheStream(stream)->strm_file_buffstart =
  7376.         fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen);
  7377.       reread: # Ab hier den Buffer neu lesen:
  7378.       {
  7379.         begin_system_call();
  7380.        {var reg4 sintL ergebnis = # Buffer füllen
  7381.           #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  7382.             full_read(TheHandle(TheStream(stream)->strm_file_handle), # Handle
  7383.                       &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse
  7384.                       strm_file_bufflen
  7385.                      )
  7386.           #endif
  7387.           #ifdef AMIGAOS
  7388.             Read(TheHandle(TheStream(stream)->strm_file_handle),
  7389.                  &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse
  7390.                  strm_file_bufflen
  7391.                 )
  7392.           #endif
  7393.           ;
  7394.         end_system_call();
  7395.         if (ergebnis==strm_file_bufflen)
  7396.           # der ganze Buffer wurde gefüllt
  7397.           { TheStream(stream)->strm_file_index = Fixnum_0; # Index := 0, Buffer unmodifiziert
  7398.             TheStream(stream)->strm_file_eofindex = T; # eofindex := T
  7399.             return &TheSstring(TheStream(stream)->strm_file_buffer)->data[0];
  7400.           }
  7401.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  7402.         if (ergebnis<0)
  7403.           {
  7404.             # Fehler aufgetreten?
  7405.             OS_error(); 
  7406.           }
  7407.         #endif
  7408.         #ifdef AMIGAOS
  7409.         if (ergebnis<0) { OS_error(); } # Fehler aufgetreten?
  7410.         #endif
  7411.         # Es wurden ergebnis (< strm_file_bufflen) Bytes gelesen.
  7412.         # Nicht der ganze Buffer wurde gefüllt -> EOF ist erreicht.
  7413.         TheStream(stream)->strm_file_index = index = Fixnum_0; # Index := 0, Buffer unmodifiziert
  7414.         TheStream(stream)->strm_file_eofindex = eofindex = fixnum(ergebnis); # eofindex := ergebnis
  7415.       }}
  7416.       eofsector: # eofindex ist ein Fixnum, d.h. EOF tritt in diesem Sector auf.
  7417.       if ((uintW)posfixnum_to_L(index) == (uintW)posfixnum_to_L(eofindex))
  7418.         { return (uintB*)NULL; } # EOF erreicht
  7419.         else
  7420.         { return &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(index)]; }
  7421.     }
  7422.  
  7423. # UP: Bereitet das Schreiben eines Bytes am EOF vor.
  7424. # b_file_eofbyte(stream);
  7425. # > stream : (offener) Byte-basierter File-Stream,
  7426. #            bei dem gerade b_file_nextbyte(stream)==NULL ist.
  7427. # < ergebnis : Pointer auf nächstes (freies) Byte
  7428. # verändert in stream: index, eofindex, buffstart
  7429.   local uintB* b_file_eofbyte (object stream);
  7430.   local uintB* b_file_eofbyte(stream)
  7431.     var reg1 object stream;
  7432.     { # EOF. Es ist eofindex=index.
  7433.       if (eq(TheStream(stream)->strm_file_eofindex,
  7434.              fixnum(strm_file_bufflen)
  7435.          )  )
  7436.         # eofindex = strm_file_bufflen
  7437.         { # Buffer muß neu gefüllt werden. Da nach ihm sowieso EOF kommt,
  7438.           # genügt es, ihn hinauszuschreiben:
  7439.           if (modified_flag(stream)) { b_file_half_flush(stream); }
  7440.           TheStream(stream)->strm_file_buffstart =
  7441.             fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen);
  7442.           TheStream(stream)->strm_file_eofindex = Fixnum_0; # eofindex := 0
  7443.           TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert
  7444.         }
  7445.       # eofindex erhöhen:
  7446.       TheStream(stream)->strm_file_eofindex = fixnum_inc(TheStream(stream)->strm_file_eofindex,1);
  7447.       return &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(TheStream(stream)->strm_file_index)];
  7448.     }
  7449.  
  7450. # UP: Schreibt ein Byte auf einen Byte-basierten File-Stream.
  7451. # b_file_writebyte(stream,b);
  7452. # > stream : (offener) Byteblock-basierter File-Stream.
  7453. # > b : zu schreibendes Byte
  7454. # verändert in stream: index, eofindex, buffstart
  7455.   local void b_file_writebyte (object stream, uintB b);
  7456.   local void b_file_writebyte(stream,b)
  7457.     var reg1 object stream;
  7458.     var reg3 uintB b;
  7459.     { var reg2 uintB* ptr = b_file_nextbyte(stream);
  7460.       if (!(ptr == (uintB*)NULL))
  7461.         { if (*ptr == b) goto no_modification; } # keine wirkliche Modifikation?
  7462.         else
  7463.         { ptr = b_file_eofbyte(stream); } # EOF -> 1 Byte Platz machen
  7464.       # nächstes Byte in den Buffer schreiben:
  7465.       *ptr = b; set_modified_flag(stream);
  7466.       no_modification:
  7467.       # index incrementieren:
  7468.       TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  7469.     }
  7470.  
  7471. # File-Stream, Byte-basiert (b_file)
  7472. # ===========  ============
  7473.  
  7474. # Fehler wegen Positionierung hinter EOF.
  7475. # fehler_position_beyond_EOF(stream);
  7476.   nonreturning_function(local, fehler_position_beyond_EOF, (object stream));
  7477.   local void fehler_position_beyond_EOF(stream)
  7478.     var reg1 object stream;
  7479.     { pushSTACK(TheStream(stream)->strm_file_truename); # Wert für Slot PATHNAME von FILE-ERROR
  7480.       pushSTACK(stream);
  7481.       //: DEUTSCH "Positionierung von ~ hinter EOF unmöglich."
  7482.       //: ENGLISH "cannot position ~ beyond EOF"
  7483.       //: FRANCAIS "Ne peux pas positionner ~ au-delà de la fin du fichier."
  7484.       fehler(file_error,GETTEXT("cannot position ~ beyond EOF"));
  7485.     }
  7486.  
  7487. # UP: Positioniert einen (offenen) Byte-basierten File-Stream an eine
  7488. # gegebene Position.
  7489. # position_b_file(stream,position);
  7490. # > stream : (offener) Byte-basierter File-Stream.
  7491. # > position : neue Position
  7492. # verändert in stream: index, eofindex, buffstart
  7493.   local void position_b_file (object stream, uintL position);
  7494.   local void position_b_file(stream,position)
  7495.     var reg1 object stream;
  7496.     var reg2 uintL position;
  7497.     { # Liegt die neue Position im selben Sector?
  7498.       { var reg3 object eofindex = TheStream(stream)->strm_file_eofindex;
  7499.         var reg4 uintL newindex = position - posfixnum_to_L(TheStream(stream)->strm_file_buffstart);
  7500.         if (newindex
  7501.             <= (eq(eofindex,T) ? strm_file_bufflen :
  7502.                 (!eq(eofindex,NIL)) ? posfixnum_to_L(eofindex) :
  7503.                 0
  7504.            )   )
  7505.           { # ja -> brauche nur index zu verändern:
  7506.             # (Dabei aber das modified_flag erhalten!)
  7507.             TheStream(stream)->strm_file_index =
  7508.               (modified_flag(stream)
  7509.                ? fixnum(bit(16)+newindex)
  7510.                : fixnum(newindex)
  7511.               );
  7512.             return;
  7513.       }   }
  7514.       # evtl. Buffer hinausschreiben:
  7515.       if (modified_flag(stream)) { b_file_flush(stream); }
  7516.       # Nun ist modified_flag gelöscht.
  7517.      {var reg5 uintL oldposition = posfixnum_to_L(TheStream(stream)->strm_file_buffstart)
  7518.                                    + posfixnum_to_L(TheStream(stream)->strm_file_index);
  7519.       # Positionieren:
  7520.       { var reg4 uintL newposition;
  7521.         begin_system_call();
  7522.         file_lseek(stream,floor(position,strm_file_bufflen)*strm_file_bufflen,SEEK_SET,newposition=);
  7523.         end_system_call();
  7524.         TheStream(stream)->strm_file_buffstart = fixnum(newposition);
  7525.       }
  7526.       # Sector lesen:
  7527.       TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL
  7528.       TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert
  7529.       { var reg3 uintL newindex = position % strm_file_bufflen; # gewünschter Index im Sector
  7530.         if (!(newindex==0)) # Position zwischen Sectoren -> brauche nichts zu lesen
  7531.           { b_file_nextbyte(stream);
  7532.             # Jetzt ist index=0.
  7533.             # index auf (position mod bufflen) setzen, vorher überprüfen:
  7534.            {var reg4 object eofindex = TheStream(stream)->strm_file_eofindex;
  7535.             # Es muß entweder eofindex=T oder 0<=newindex<=eofindex sein:
  7536.             if (!(eq(eofindex,T) || (newindex <= posfixnum_to_L(eofindex))))
  7537.               # Fehler. Aber erst an die alte Position zurückpositionieren:
  7538.               { check_SP();
  7539.                 position_b_file(stream,oldposition); # zurückpositionieren
  7540.                 fehler_position_beyond_EOF(stream);
  7541.               }
  7542.             TheStream(stream)->strm_file_index = fixnum(newindex);
  7543.       }   }}
  7544.     }}
  7545.  
  7546. # File-Stream für String-Chars
  7547. # ============================
  7548.  
  7549. # Funktionsweise:
  7550. # Beim Schreiben: Characters werden unverändert durchgereicht, nur NL wird auf
  7551. # MSDOS in CR/LF umgewandelt. Beim Lesen: CR/LF wird in NL umgewandelt.
  7552.  
  7553. # READ-CHAR - Pseudofunktion für File-Streams für String-Chars
  7554.   local object rd_ch_sch_file (object* stream_);
  7555.   local object rd_ch_sch_file(stream_)
  7556.     var reg3 object* stream_;
  7557.     { var reg1 object stream = *stream_;
  7558.       var reg2 uintB* charptr = b_file_nextbyte(stream);
  7559.       if (charptr == (uintB*)NULL) { return eof_value; } # EOF ?
  7560.       # nächstes Zeichen holen:
  7561.      {var reg3 object ch = code_char(*charptr); # Character aus dem Buffer holen
  7562.       # index und position incrementieren:
  7563.       TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  7564.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  7565.       # ch = nächstes Zeichen
  7566.       if (!eq(ch,code_char(CR))) # Ist es CR ?
  7567.         { # nein -> OK
  7568.           if (eq(ch,code_char(NL))) # Ist es NL, dann lineno incrementieren
  7569.             { TheStream(stream)->strm_sch_file_lineno = fixnum_inc(TheStream(stream)->strm_sch_file_lineno,1); }
  7570.           return ch;
  7571.         }
  7572.       # ja -> nächstes Zeichen auf LF untersuchen
  7573.       charptr = b_file_nextbyte(stream);
  7574.       if (charptr == (uintB*)NULL) { return ch; } # EOF -> bleibt CR
  7575.       if (!(*charptr == LF)) { return ch; } # kein LF -> bleibt CR
  7576.       # LF übergehen, index und position incrementieren:
  7577.       TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  7578.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  7579.       # lineno incrementieren:
  7580.       TheStream(stream)->strm_sch_file_lineno = fixnum_inc(TheStream(stream)->strm_sch_file_lineno,1);
  7581.       # NL als Ergebnis:
  7582.       return code_char(NL);
  7583.     }}
  7584.  
  7585. # Stellt fest, ob ein File-Stream ein Zeichen verfügbar hat.
  7586. # listen_sch_file(stream)
  7587. # > stream: File-Stream für String-Chars
  7588. # < ergebnis:  0 falls Zeichen verfügbar,
  7589. #             -1 falls bei EOF angelangt,
  7590. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  7591.   local signean listen_sch_file (object stream);
  7592.   local signean listen_sch_file(stream)
  7593.     var reg1 object stream;
  7594.     { if (b_file_nextbyte(stream) == (uintB*)NULL)
  7595.         { return signean_minus; } # EOF
  7596.         else
  7597.         { return signean_null; }
  7598.     }
  7599.  
  7600. # UP: Schreibt ein Byte auf einen Byte-basierten File-Stream.
  7601. # write_b_file(stream,b);
  7602. # > stream : (offener) Byte-basierter File-Stream.
  7603. # > b : zu schreibendes Byte
  7604. # verändert in stream: index, eofindex, buffstart, position
  7605.   local void write_b_file (object stream, uintB b);
  7606.   local void write_b_file(stream,b)
  7607.     var reg1 object stream;
  7608.     var reg2 uintB b;
  7609.     { b_file_writebyte(stream,b);
  7610.       # position incrementieren:
  7611.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  7612.     }
  7613.  
  7614. # WRITE-CHAR - Pseudofunktion für File-Streams für String-Chars
  7615.   local void wr_ch_sch_file (object* stream_, object obj);
  7616.   local void wr_ch_sch_file(stream_,obj)
  7617.     var reg4 object* stream_;
  7618.     var reg2 object obj;
  7619.     { var reg1 object stream = *stream_;
  7620.       # obj muß ein String-Char sein:
  7621.       if (!string_char_p(obj)) { fehler_wr_string_char(stream,obj); }
  7622.      {var reg3 uintB ch = char_code(obj);
  7623.       #if defined(MSDOS)
  7624.       if (ch==NL)
  7625.         # Newline als CR/LF ausgeben
  7626.         { write_b_file(stream,CR); write_b_file(stream,LF); }
  7627.         else
  7628.         # alle anderen Zeichen unverändert ausgeben
  7629.         { write_b_file(stream,ch); }
  7630.       #else
  7631.       write_b_file(stream,ch); # unverändert ausgeben
  7632.       #endif
  7633.     }}
  7634.  
  7635. # WRITE-CHAR-SEQUENCE für File-Streams für String-Chars:
  7636.   local uintB* write_schar_array_sch_file (object stream, uintB* strptr, uintL len);
  7637.   #if defined(MSDOS)
  7638.   # Wegen NL->CR/LF-Umwandlung keine Optimierung möglich.
  7639.   local inline uintB* write_schar_array_sch_file(stream,strptr,len)
  7640.     var reg3 object stream;
  7641.     var reg4 uintB* strptr;
  7642.     var reg5 uintL len;
  7643.     { var reg1 uintL remaining = len;
  7644.       do { var reg2 uintB ch = *strptr++;
  7645.            if (ch==NL)
  7646.              # Newline als CR/LF ausgeben
  7647.              { write_b_file(stream,CR); write_b_file(stream,LF); }
  7648.              else
  7649.              # alle anderen Zeichen unverändert ausgeben
  7650.              { write_b_file(stream,ch); }
  7651.            remaining--;
  7652.          }
  7653.          until (remaining == 0);
  7654.       wr_ss_lpos(stream,strptr,len); # Line-Position aktualisieren
  7655.       return strptr;
  7656.     }
  7657.   #else
  7658.   local uintB* write_schar_array_sch_file(stream,strptr,len)
  7659.     var reg5 object stream;
  7660.     var reg2 uintB* strptr;
  7661.     var reg9 uintL len;
  7662.     { var reg6 uintL remaining = len;
  7663.       var reg1 uintB* ptr;
  7664.       do # Noch remaining>0 Bytes abzulegen.
  7665.         { ptr = b_file_nextbyte(stream);
  7666.           if (ptr == (uintB*)NULL) goto eof_reached;
  7667.          {var reg8 object eofindex = TheStream(stream)->strm_file_eofindex;
  7668.           var reg7 uintL next = # so viel wie noch in den Buffer oder bis EOF paßt
  7669.             (eq(eofindex,T) ? strm_file_bufflen : posfixnum_to_L(eofindex))
  7670.             - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index); # > 0 !
  7671.           if (next > remaining) { next = remaining; }
  7672.           # next Bytes in den Buffer kopieren:
  7673.           {var reg4 uintL count;
  7674.            dotimespL(count,next,
  7675.              { var reg3 uintB b = *strptr++; # nächstes Byte
  7676.                if (!(*ptr == b)) { *ptr = b; set_modified_flag(stream); } # in den Buffer
  7677.                ptr++;
  7678.              });
  7679.           }
  7680.           remaining = remaining - next;
  7681.           # index incrementieren:
  7682.           TheStream(stream)->strm_file_index =
  7683.             fixnum_inc(TheStream(stream)->strm_file_index,next);
  7684.         }}
  7685.         until (remaining == 0);
  7686.       if (FALSE)
  7687.         eof_reached: # Schreiben am EOF, eofindex = index
  7688.         do # Noch remaining>0 Bytes abzulegen.
  7689.           { var reg7 uintL next = # so viel wie noch Platz im Buffer ist
  7690.               strm_file_bufflen
  7691.               - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index);
  7692.             if (next==0)
  7693.               { # Buffer muß neu gefüllt werden. Da nach ihm sowieso EOF kommt,
  7694.                 # genügt es, ihn hinauszuschreiben:
  7695.                 if (modified_flag(stream)) { b_file_half_flush(stream); }
  7696.                 TheStream(stream)->strm_file_buffstart =
  7697.                   fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen);
  7698.                 TheStream(stream)->strm_file_eofindex = Fixnum_0; # eofindex := 0
  7699.                 TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert
  7700.                 # Dann nochmals versuchen:
  7701.                 next = strm_file_bufflen;
  7702.               }
  7703.             if (next > remaining) { next = remaining; }
  7704.             # next Bytes in den Buffer kopieren:
  7705.             {var reg3 uintL count;
  7706.              ptr = &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(TheStream(stream)->strm_file_index)];
  7707.              dotimespL(count,next, { *ptr++ = *strptr++; } );
  7708.              set_modified_flag(stream);
  7709.             }
  7710.             remaining = remaining - next;
  7711.             # index und eofindex incrementieren:
  7712.             TheStream(stream)->strm_file_index =
  7713.               fixnum_inc(TheStream(stream)->strm_file_index,next);
  7714.             TheStream(stream)->strm_file_eofindex =
  7715.               fixnum_inc(TheStream(stream)->strm_file_eofindex,next);
  7716.           }
  7717.           until (remaining == 0);
  7718.       # position incrementieren:
  7719.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,len);
  7720.       wr_ss_lpos(stream,strptr,len); # Line-Position aktualisieren
  7721.       return strptr;
  7722.     }
  7723.   #endif
  7724.  
  7725. #ifdef STRM_WR_SS
  7726. # WRITE-SIMPLE-STRING - Pseudofunktion für File-Streams für String-Chars
  7727.   local void wr_ss_sch_file (object* stream_, object string, uintL start, uintL len);
  7728.   local void wr_ss_sch_file(stream_,string,start,len)
  7729.     var reg1 object* stream_;
  7730.     var reg2 object string;
  7731.     var reg4 uintL start;
  7732.     var reg3 uintL len;
  7733.     { if (len==0) return;
  7734.       write_schar_array_sch_file(*stream_,&TheSstring(string)->data[start],len);
  7735.     }
  7736. #endif
  7737.  
  7738. # File-Stream für Characters
  7739. # ==========================
  7740.  
  7741. # Funktionsweise:
  7742. # Characters werden incl. Fonts und Bits durchgereicht.
  7743.   #if (!((char_int_len % 8) == 0)) # char_int_len muß durch 8 teilbar sein
  7744.     #error "Charactergröße neu einstellen!"
  7745.   #endif
  7746.   #define char_size  (char_int_len / 8)  # Größe eines Characters in Bytes
  7747.  
  7748. # READ-CHAR - Pseudofunktion für File-Streams für Characters
  7749.   local object rd_ch_ch_file (object* stream_);
  7750.   local object rd_ch_ch_file(stream_)
  7751.     var reg4 object* stream_;
  7752.     { var reg1 object stream = *stream_;
  7753.       var reg3 cint c;
  7754.       var reg2 uintB* ptr = b_file_nextbyte(stream);
  7755.       if (ptr == (uintB*)NULL) goto eof; # EOF ?
  7756.       c = *ptr;
  7757.       # index incrementieren:
  7758.       TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  7759.       doconsttimes(char_size-1,
  7760.         ptr = b_file_nextbyte(stream);
  7761.         if (ptr == (uintB*)NULL) goto eof1; # EOF ?
  7762.         c = (c<<8) | *ptr;
  7763.         # index incrementieren:
  7764.         TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  7765.         );
  7766.       # position incrementieren:
  7767.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  7768.       return int_char(c);
  7769.       eof1:
  7770.         # Wieder zurückpositionieren:
  7771.         position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position) * char_size);
  7772.       eof: # EOF erreicht gewesen
  7773.         return eof_value;
  7774.     }
  7775.  
  7776. # Stellt fest, ob ein File-Stream ein Zeichen verfügbar hat.
  7777. # listen_ch_file(stream)
  7778. # > stream: File-Stream für Characters
  7779. # < ergebnis:  0 falls Zeichen verfügbar,
  7780. #             -1 falls bei EOF angelangt,
  7781. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  7782. # kann GC auslösen
  7783.   local signean listen_ch_file (object stream);
  7784.   local signean listen_ch_file(stream)
  7785.     var reg1 object stream;
  7786.     { var reg2 uintB* ptr = b_file_nextbyte(stream); # erstes Byte da ?
  7787.       if (ptr == (uintB*)NULL) goto eof; # EOF ?
  7788.       doconsttimes(char_size-1,
  7789.         # index incrementieren:
  7790.         TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  7791.         ptr = b_file_nextbyte(stream); # nächstes Byte da ?
  7792.         if (ptr == (uintB*)NULL) goto eof1; # EOF ?
  7793.         );
  7794.       # Wieder zurückpositionieren:
  7795.       position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position) * char_size);
  7796.       return signean_null;
  7797.       eof1:
  7798.         # Wieder zurückpositionieren:
  7799.         position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position) * char_size);
  7800.       eof: # EOF erreicht gewesen
  7801.         return signean_minus;
  7802.     }
  7803.  
  7804. # WRITE-CHAR - Pseudofunktion für File-Streams für Characters
  7805.   local void wr_ch_ch_file (object* stream_, object obj);
  7806.   local void wr_ch_ch_file(stream_,obj)
  7807.     var reg4 object* stream_;
  7808.     var reg2 object obj;
  7809.     { var reg1 object stream = *stream_;
  7810.       # obj muß ein Character sein:
  7811.       if (!charp(obj)) { fehler_wr_char(stream,obj); }
  7812.      {var reg3 cint c = char_int(obj);
  7813.       #define WRITEBYTE(i)  b_file_writebyte(stream,(uintB)(c>>(char_size-1-i)));
  7814.       DOCONSTTIMES(char_size,WRITEBYTE) # WRITEBYTE(0..char_size-1)
  7815.       #undef WRITEBYTE
  7816.       # position incrementieren:
  7817.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  7818.     }}
  7819.  
  7820. # File-Stream, Bit-basiert
  7821. # ========================
  7822.  
  7823. # Davon gibt es insgesamt 6 Arten:
  7824. # Drei Fälle
  7825. #   a - bitsize durch 8 teilbar,
  7826. #   b - bitsize < 8,
  7827. #   c - bitsize nicht durch 8 teilbar und >= 8,
  7828. # jeweils unterschieden durch
  7829. #   s - Elementtyp (signed-byte bitsize),
  7830. #       dazu zählt auch signed-byte = (signed-byte 8)
  7831. #   u - Elementtyp (unsigned-byte bitsize),
  7832. #       dazu zählen auch unsigned-byte = (unsigned-byte 8)
  7833. #       und bit = (unsigned-byte 1)
  7834. #       und (mod n) = (unsigned-byte (integer-length n))
  7835.  
  7836. # UP: Positioniert einen (offenen) Bit-basierten File-Stream an eine
  7837. # gegebene Position.
  7838. # position_i_file(stream,position);
  7839. # > stream : (offener) Byte-basierter File-Stream.
  7840. # > position : neue (logische) Position
  7841. # verändert in stream: index, eofindex, buffstart, bitindex
  7842.   local void position_i_file (object stream, uintL position);
  7843.   local void position_i_file(stream,position)
  7844.     var reg1 object stream;
  7845.     var reg2 uintL position;
  7846.     { var reg5 uintB flags = TheStream(stream)->strmflags;
  7847.       var reg4 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize);
  7848.       var reg3 uintL position_bits = position * bitsize;
  7849.       if ((flags & strmflags_i_B) == strmflags_ib_B)
  7850.         { position_bits += sizeof(uintL)*8; } # Header berücksichtigen
  7851.       # An Bit Nummer position_bits positionieren.
  7852.       position_b_file(stream,floor(position_bits,8)); # Aufs Byte positionieren
  7853.       if ((flags & strmflags_i_B) == strmflags_ia_B) return; # Bei Art a war's das.
  7854.       if (# Liegt die angesprochene Position im ersten Byte nach EOF ?
  7855.           ((!((position_bits%8)==0))
  7856.            && (b_file_nextbyte(stream) == (uintB*)NULL)
  7857.           )
  7858.           ||
  7859.           # Liegt die angesprochene Position im letzten Byte, aber zu weit?
  7860.           (((flags & strmflags_i_B) == strmflags_ib_B)
  7861.            && (position > posfixnum_to_L(TheStream(stream)->strm_file_eofposition))
  7862.          ))
  7863.         # Fehler. Aber erst an die alte Position zurückpositionieren:
  7864.         { var reg6 uintL oldposition = posfixnum_to_L(TheStream(stream)->strm_file_position);
  7865.           check_SP();
  7866.           position_i_file(stream,oldposition); # zurückpositionieren
  7867.           fehler_position_beyond_EOF(stream);
  7868.         }
  7869.       TheStream(stream)->strm_file_bitindex = fixnum(position_bits%8);
  7870.     }
  7871.  
  7872. # UP für READ-BYTE auf File-Streams für Integers, Art u :
  7873. # Liefert die im Bitbuffer enthaltenen bytesize Bytes als Integer >=0.
  7874. # kann GC auslösen
  7875.   local object rd_by_iu_I (object stream, uintL bitsize, uintL bytesize);
  7876.   local object rd_by_iu_I(stream,bitsize,bytesize)
  7877.     var reg6 object stream;
  7878.     var reg7 uintL bitsize;
  7879.     var reg5 uintL bytesize;
  7880.     { var reg4 object bitbuffer = TheStream(stream)->strm_file_bitbuffer;
  7881.       # Zahl im bitbuffer normalisieren:
  7882.       var reg1 uintB* bitbufferptr = &TheSbvector(bitbuffer)->data[0];
  7883.       *bitbufferptr &= (bit(((bitsize-1)%8)+1)-1); # High byte maskieren
  7884.      {var reg2 uintL count = bytesize;
  7885.       while ((!(count==0)) && (*bitbufferptr==0)) { count--; bitbufferptr++; }
  7886.       # Zahl bilden:
  7887.       if # höchstens oint_data_len Bits ?
  7888.          ((count <= floor(oint_data_len,8))
  7889.           || ((count == floor(oint_data_len,8)+1)
  7890.               && (*bitbufferptr < bit(oint_data_len%8))
  7891.          )   )
  7892.         # ja -> Fixnum >=0 bilden:
  7893.         { var reg3 uintL wert = 0;
  7894.           until (count==0) { wert = (wert<<8) | *bitbufferptr++; count--; }
  7895.           return fixnum(wert);
  7896.         }
  7897.         else
  7898.         # nein -> Bignum >0 bilden:
  7899.         { pushSTACK(bitbuffer);
  7900.          {var reg5 uintL digitcount = floor(count,(intDsize/8));
  7901.           if (((count%(intDsize/8)) > 0) || (*bitbufferptr & bit(7)))
  7902.             { digitcount++; }
  7903.           # Da bitsize < intDsize*uintC_max, ist
  7904.           # digitcount <= ceiling((bitsize+1)/intDsize) <= uintC_max .
  7905.           { var reg4 object big = allocate_bignum(digitcount,0); # neues Bignum >0
  7906.             TheBignum(big)->data[0] = 0; # höchstes Digit auf 0 setzen
  7907.             # restliche Digits von rechts füllen, dabei Folge von Bytes in
  7908.             # Folge von uintD übersetzen:
  7909.             bitbuffer = popSTACK();
  7910.             bitbufferptr = &TheSbvector(bitbuffer)->data[bytesize];
  7911.             #if BIG_ENDIAN_P
  7912.             {var reg1 uintB* bigptr = (uintB*)(&TheBignum(big)->data[digitcount]);
  7913.              dotimespL(count,count, { *--bigptr = *--bitbufferptr; } );
  7914.             }
  7915.             #else
  7916.             {var reg1 uintD* bigptr = &TheBignum(big)->data[digitcount];
  7917.              var reg6 uintL count2;
  7918.              #define GET_NEXT_BYTE(i)  \
  7919.                digit |= ((uintD)(*--bitbufferptr) << (8*i));
  7920.              dotimespL(count2,floor(count,intDsize/8),
  7921.                { var reg3 uintD digit = 0;
  7922.                  DOCONSTTIMES(intDsize/8,GET_NEXT_BYTE); # GET_NEXT_BYTE(0..intDsize/8-1)
  7923.                  *--bigptr = digit;
  7924.                });
  7925.              #undef GET_NEXT_BYTE
  7926.              count2 = count % (intDsize/8);
  7927.              if (count2>0)
  7928.                { var reg7 uintL shiftcount = 0;
  7929.                  var reg3 uintD digit = (uintD)(*--bitbufferptr);
  7930.                  dotimesL(count2,count2-1,
  7931.                    { shiftcount += 8;
  7932.                      digit |= ((uintD)(*--bitbufferptr) << shiftcount);
  7933.                    });
  7934.                  *--bigptr = digit;
  7935.                }
  7936.             }
  7937.             #endif
  7938.             # Wegen (intDsize/8)*(digitcount-1) <= count <= (intDsize/8)*digitcount
  7939.             # ist alles gefüllt.
  7940.             return big;
  7941.         }}}
  7942.     }}
  7943.  
  7944. # UP für READ-BYTE auf File-Streams für Integers, Art s :
  7945. # Liefert die im Bitbuffer enthaltenen bytesize Bytes als Integer.
  7946. # kann GC auslösen
  7947.   local object rd_by_is_I (object stream, uintL bitsize, uintL bytesize);
  7948.   local object rd_by_is_I(stream,bitsize,bytesize)
  7949.     var reg6 object stream;
  7950.     var reg7 uintL bitsize;
  7951.     var reg5 uintL bytesize;
  7952.     { var reg4 object bitbuffer = TheStream(stream)->strm_file_bitbuffer;
  7953.       # Zahl im bitbuffer normalisieren:
  7954.       var reg1 uintB* bitbufferptr = &TheSbvector(bitbuffer)->data[0];
  7955.       var reg8 sintD sign;
  7956.       var reg3 uintL signbitnr = (bitsize-1)%8;
  7957.       var reg2 uintL count = bytesize;
  7958.       if (!(*bitbufferptr & bit(signbitnr)))
  7959.         { sign = 0;
  7960.           *bitbufferptr &= (bitm(signbitnr+1)-1); # High byte sign-extenden
  7961.           # normalisieren, höchstes Bit muß 0 bleiben:
  7962.           while ((count>=2) && (*bitbufferptr==0) && !(*(bitbufferptr+1) & bit(7)))
  7963.             { count--; bitbufferptr++; }
  7964.           # Zahl bilden:
  7965.           if # höchstens oint_data_len+1 Bits, Zahl <2^oint_data_len ?
  7966.              ((count <= floor(oint_data_len,8))
  7967.               || ((count == floor(oint_data_len,8)+1)
  7968.                   && (*bitbufferptr < bit(oint_data_len%8))
  7969.              )   )
  7970.             # ja -> Fixnum >=0 bilden:
  7971.             { var reg3 uintL wert = 0;
  7972.               until (count==0) { wert = (wert<<8) | *bitbufferptr++; count--; }
  7973.               return posfixnum(wert);
  7974.             }
  7975.         }
  7976.         else
  7977.         { sign = -1;
  7978.           *bitbufferptr |= minus_bitm(signbitnr+1); # High byte sign-extenden
  7979.           # normalisieren, höchstes Bit muß 1 bleiben:
  7980.           while ((count>=2) && (*bitbufferptr==(uintB)(-1)) && (*(bitbufferptr+1) & bit(7)))
  7981.             { count--; bitbufferptr++; }
  7982.           # Zahl bilden:
  7983.           if # höchstens oint_data_len+1 Bits, Zahl >=-2^oint_data_len ?
  7984.              ((count <= floor(oint_data_len,8))
  7985.               || ((count == floor(oint_data_len,8)+1)
  7986.                   && (*bitbufferptr >= (uintB)(-bit(oint_data_len%8)))
  7987.              )   )
  7988.             # ja -> Fixnum <0 bilden:
  7989.             { var reg3 uintL wert = -1;
  7990.               until (count==0) { wert = (wert<<8) | *bitbufferptr++; count--; }
  7991.               return negfixnum(wbitm(intLsize)+(oint)wert);
  7992.             }
  7993.         }
  7994.       # Bignum bilden:
  7995.       pushSTACK(bitbuffer);
  7996.       { var reg5 uintL digitcount = ceiling(count,(intDsize/8));
  7997.         # Da bitsize < intDsize*uintC_max, ist
  7998.         # digitcount <= ceiling(bitsize/intDsize) <= uintC_max .
  7999.         var reg4 object big = allocate_bignum(digitcount,sign); # neues Bignum
  8000.         TheBignum(big)->data[0] = sign; # höchstes Word auf sign setzen
  8001.         # restliche Digits von rechts füllen, dabei Folge von Bytes in
  8002.         # Folge von uintD übersetzen:
  8003.         bitbuffer = popSTACK();
  8004.         bitbufferptr = &TheSbvector(bitbuffer)->data[bytesize];
  8005.         #if BIG_ENDIAN_P
  8006.         {var reg1 uintB* bigptr = (uintB*)(&TheBignum(big)->data[digitcount]);
  8007.          dotimespL(count,count, { *--bigptr = *--bitbufferptr; } );
  8008.         }
  8009.         #else
  8010.         {var reg1 uintD* bigptr = &TheBignum(big)->data[digitcount];
  8011.          var reg6 uintL count2;
  8012.          #define GET_NEXT_BYTE(i)  \
  8013.            digit |= ((uintD)(*--bitbufferptr) << (8*i));
  8014.          dotimespL(count2,floor(count,intDsize/8),
  8015.            { var reg3 uintD digit = 0;
  8016.              DOCONSTTIMES(intDsize/8,GET_NEXT_BYTE); # GET_NEXT_BYTE(0..intDsize/8-1)
  8017.              *--bigptr = digit;
  8018.            });
  8019.          #undef GET_NEXT_BYTE
  8020.          count2 = count % (intDsize/8);
  8021.          if (count2>0)
  8022.            { var reg7 uintL shiftcount = 0;
  8023.              var reg3 uintD digit = (uintD)(*--bitbufferptr);
  8024.              dotimesL(count2,count2-1,
  8025.                { shiftcount += 8;
  8026.                  digit |= ((uintD)(*--bitbufferptr) << shiftcount);
  8027.                });
  8028.              *--bigptr = digit;
  8029.            }
  8030.         }
  8031.         #endif
  8032.         # Wegen (intDsize/8)*(digitcount-1) < count <= (intDsize/8)*digitcount
  8033.         # ist alles gefüllt.
  8034.         return big;
  8035.       }
  8036.     }
  8037.  
  8038. # Typ rd_by_ix_I: eines dieser beiden Unterprogramme:
  8039.   typedef object rd_by_ix_I (object stream, uintL bitsize, uintL bytesize);
  8040.  
  8041. # UP für READ-BYTE auf File-Streams für Integers, Art a :
  8042. # Füllt den Bitbuffer mit den nächsten bitsize Bits.
  8043. # > stream : File-Stream für Integers, Art a
  8044. # > finisher : Beendigungsroutine
  8045. # < ergebnis : gelesener Integer oder eof_value
  8046.   local object rd_by_iax_file (object stream, rd_by_ix_I* finisher);
  8047.   local object rd_by_iax_file(stream,finisher)
  8048.     var reg1 object stream;
  8049.     var reg7 rd_by_ix_I* finisher;
  8050.     { var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize);
  8051.       var reg5 uintL bytesize = bitsize/8;
  8052.       # genügend viele Bytes in den Bitbuffer übertragen:
  8053.      {var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize];
  8054.       var reg4 uintL count;
  8055.       dotimespL(count,bytesize,
  8056.         { var reg3 uintB* ptr = b_file_nextbyte(stream);
  8057.           if (ptr == (uintB*)NULL) goto eof;
  8058.           # nächstes Byte holen:
  8059.           *--bitbufferptr = *ptr;
  8060.           # index incrementieren:
  8061.           TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  8062.         });
  8063.       # position incrementieren:
  8064.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  8065.       # in Zahl umwandeln:
  8066.       return (*finisher)(stream,bitsize,bytesize);
  8067.       eof: # EOF erreicht
  8068.       position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position)*bytesize);
  8069.       return eof_value;
  8070.     }}
  8071.  
  8072. # UP für READ-BYTE auf File-Streams für Integers, Art b :
  8073. # Füllt den Bitbuffer mit den nächsten bitsize Bits.
  8074. # > stream : File-Stream für Integers, Art b
  8075. # > finisher : Beendigungsroutine
  8076. # < ergebnis : gelesener Integer oder eof_value
  8077.   local object rd_by_ibx_file (object stream, rd_by_ix_I* finisher);
  8078.   local object rd_by_ibx_file(stream,finisher)
  8079.     var reg1 object stream;
  8080.     var reg8 rd_by_ix_I* finisher;
  8081.     { # Nur bei position < eofposition gibt's was zu lesen:
  8082.       if (eq(TheStream(stream)->strm_file_position,TheStream(stream)->strm_file_eofposition))
  8083.         goto eof;
  8084.       { var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); # bitsize (>0, <8)
  8085.         # genügend viele Bits in den Bitbuffer übertragen:
  8086.         var reg4 uintL bitindex = posfixnum_to_L(TheStream(stream)->strm_file_bitindex);
  8087.         var reg5 uintL count = bitindex + bitsize;
  8088.         var reg1 uint8 bit_akku;
  8089.         var reg3 uintB* ptr = b_file_nextbyte(stream);
  8090.         if (ptr == (uintB*)NULL) goto eof;
  8091.         # angefangenes Byte holen:
  8092.         bit_akku = (*ptr)>>bitindex;
  8093.         # bitshift := 8-bitindex
  8094.         # Von bit_akku sind die Bits (bitshift-1)..0 gültig.
  8095.         if (count > 8)
  8096.           { # index incrementieren, da gerade *ptr verarbeitet:
  8097.             TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  8098.             count -= 8; # Noch count (>0) Bits zu holen.
  8099.            {var reg3 uintB* ptr = b_file_nextbyte(stream);
  8100.             if (ptr == (uintB*)NULL) goto eof1;
  8101.             # nächstes Byte holen:
  8102.             # (8-bitindex < 8, da sonst count = 0+bitsize < 8 gewesen wäre!)
  8103.             bit_akku |= (*ptr)<<(8-bitindex);
  8104.           }}# Von bit_akku sind alle 8 Bits gültig.
  8105.         # 8 Bit abspeichern:
  8106.         TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[0] = bit_akku;
  8107.         TheStream(stream)->strm_file_bitindex = fixnum(count);
  8108.         # position incrementieren:
  8109.         TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  8110.         # in Zahl umwandeln:
  8111.         return (*finisher)(stream,bitsize,1);
  8112.         eof1:
  8113.           # Wieder zurückpositionieren:
  8114.           position_i_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position));
  8115.       }
  8116.       eof: # EOF erreicht gewesen
  8117.         return eof_value;
  8118.     }
  8119.  
  8120. # UP für READ-BYTE auf File-Streams für Integers, Art c :
  8121. # Füllt den Bitbuffer mit den nächsten bitsize Bits.
  8122. # > stream : File-Stream für Integers, Art c
  8123. # > finisher : Beendigungsroutine
  8124. # < ergebnis : gelesener Integer oder eof_value
  8125.   local object rd_by_icx_file (object stream, rd_by_ix_I* finisher);
  8126.   local object rd_by_icx_file(stream,finisher)
  8127.     var reg1 object stream;
  8128.     var reg8 rd_by_ix_I* finisher;
  8129.     { var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize);
  8130.       var reg7 uintL bytesize = ceiling(bitsize,8);
  8131.       # genügend viele Bits in den Bitbuffer übertragen:
  8132.       var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize];
  8133.       var reg4 uintL count = bitsize;
  8134.       var reg5 uintL bitshift = posfixnum_to_L(TheStream(stream)->strm_file_bitindex);
  8135.       var reg3 uintB* ptr = b_file_nextbyte(stream);
  8136.       if (ptr == (uintB*)NULL) goto eof;
  8137.       if (bitshift==0)
  8138.         { loop
  8139.             { *--bitbufferptr = *ptr; # 8 Bits holen und abspeichern
  8140.               # index incrementieren, da gerade *ptr verarbeitet:
  8141.               TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  8142.               count -= 8;
  8143.               # Noch count (>0) Bits zu holen.
  8144.               ptr = b_file_nextbyte(stream);
  8145.               if (ptr == (uintB*)NULL) goto eof;
  8146.               if (count<=8) break; # Sind damit count Bits fertig?
  8147.             }
  8148.           # Noch count = bitsize mod 8 (>0,<8) Bits zu holen.
  8149.           *--bitbufferptr = *ptr; # count Bits holen und abspeichern
  8150.         }
  8151.         else # 0<bitindex<8
  8152.         { var reg1 uint16 bit_akku;
  8153.           # angefangenes Byte holen:
  8154.           bit_akku = (*ptr)>>bitshift;
  8155.           bitshift = 8-bitshift; # bitshift := 8-bitindex
  8156.           count -= bitshift;
  8157.           loop
  8158.             { # index incrementieren, da gerade *ptr verarbeitet:
  8159.               TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  8160.               # Von bit_akku sind die Bits (bitshift-1)..0 gültig.
  8161.               # Noch count (>0) Bits zu holen.
  8162.              {var reg3 uintB* ptr = b_file_nextbyte(stream);
  8163.               if (ptr == (uintB*)NULL) goto eof;
  8164.               # nächstes Byte holen:
  8165.               bit_akku |= (uint16)(*ptr)<<bitshift;
  8166.              }# Von bit_akku sind die Bits (7+bitshift)..0 gültig.
  8167.               *--bitbufferptr = (uint8)bit_akku; # 8 Bit abspeichern
  8168.               if (count<=8) break; # Sind damit count Bits fertig?
  8169.               count -= 8;
  8170.               bit_akku = bit_akku>>8;
  8171.             }
  8172.         }
  8173.       TheStream(stream)->strm_file_bitindex = fixnum(count);
  8174.       # position incrementieren:
  8175.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  8176.       # in Zahl umwandeln:
  8177.       return (*finisher)(stream,bitsize,bytesize);
  8178.       eof: # EOF erreicht
  8179.       position_i_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position));
  8180.       return eof_value;
  8181.     }
  8182.  
  8183. # UP für WRITE-BYTE auf File-Streams für Integers, Art a :
  8184. # Schreibt den Bitbuffer-Inhalt aufs File.
  8185.   local void wr_by_ia (object stream, uintL bitsize, uintL bytesize);
  8186.   local void wr_by_ia(stream,bitsize,bytesize)
  8187.     var reg3 object stream;
  8188.     var uintL bitsize;
  8189.     var reg4 uintL bytesize;
  8190.     { var reg1 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize];
  8191.       var reg2 uintL count;
  8192.       dotimespL(count,bytesize, { b_file_writebyte(stream,*--bitbufferptr); } );
  8193.       # position incrementieren:
  8194.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  8195.     }
  8196.  
  8197. # UP für WRITE-BYTE auf File-Streams für Integers, Art b :
  8198. # Schreibt den Bitbuffer-Inhalt aufs File.
  8199.   local void wr_by_ib (object stream, uintL bitsize, uintL bytesize);
  8200.   local void wr_by_ib(stream,bitsize,bytesize)
  8201.     var reg4 object stream;
  8202.     var reg6 uintL bitsize;
  8203.     var uintL bytesize;
  8204.     { var reg1 uintL bitshift = posfixnum_to_L(TheStream(stream)->strm_file_bitindex);
  8205.       var reg3 uint16 bit_akku = (uint16)(TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[0])<<bitshift;
  8206.       var reg2 uintL count = bitsize;
  8207.       var reg5 uintB* ptr = b_file_nextbyte(stream);
  8208.       # angefangenes Byte holen:
  8209.       if (!(ptr == (uintB*)NULL)) { bit_akku |= (*ptr)&(bit(bitshift)-1); }
  8210.       count += bitshift;
  8211.       # evtl. einzelnes Byte schreiben:
  8212.       if (count>=8)
  8213.         { b_file_writebyte(stream,(uint8)bit_akku);
  8214.           bit_akku = bit_akku>>8;
  8215.           count -= 8;
  8216.         }
  8217.       # letztes Byte (count Bits) schreiben:
  8218.       if (!(count==0))
  8219.         { ptr = b_file_nextbyte(stream);
  8220.           if (ptr == (uintB*)NULL) # EOF ?
  8221.             { ptr = b_file_eofbyte(stream); # 1 Byte Platz machen
  8222.               *ptr = (uint8)bit_akku; # Byte schreiben
  8223.             }
  8224.             else
  8225.             # nächstes Byte nur teilweise überschreiben:
  8226.             { var reg3 uint8 diff = (*ptr ^ (uint8)bit_akku) & (uint8)(bit(count)-1);
  8227.               if (diff == 0) goto no_modification;
  8228.               *ptr ^= diff;
  8229.             }
  8230.           set_modified_flag(stream);
  8231.           no_modification: ;
  8232.         }
  8233.       TheStream(stream)->strm_file_bitindex = fixnum(count);
  8234.       # position und evtl. eofposition incrementieren:
  8235.       if (eq(TheStream(stream)->strm_file_eofposition,TheStream(stream)->strm_file_position))
  8236.         { TheStream(stream)->strm_file_eofposition = fixnum_inc(TheStream(stream)->strm_file_eofposition,1); }
  8237.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  8238.     }
  8239.  
  8240. # UP für WRITE-BYTE auf File-Streams für Integers, Art c :
  8241. # Schreibt den Bitbuffer-Inhalt aufs File.
  8242.   local void wr_by_ic (object stream, uintL bitsize, uintL bytesize);
  8243.   local void wr_by_ic(stream,bitsize,bytesize)
  8244.     var reg5 object stream;
  8245.     var reg7 uintL bitsize;
  8246.     var reg8 uintL bytesize;
  8247.     { var reg1 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize];
  8248.       var reg2 uintL bitshift = posfixnum_to_L(TheStream(stream)->strm_file_bitindex);
  8249.       var reg3 uintL count = bitsize;
  8250.       var reg4 uint16 bit_akku;
  8251.       var reg6 uintB* ptr = b_file_nextbyte(stream);
  8252.       # angefangenes Byte holen:
  8253.       bit_akku = (ptr==(uintB*)NULL ? 0 : (*ptr)&(bit(bitshift)-1) );
  8254.       count += bitshift;
  8255.       # einzelne Bytes schreiben:
  8256.       loop
  8257.         { bit_akku |= (uint16)(*--bitbufferptr)<<bitshift;
  8258.           if (count<8) break;
  8259.           b_file_writebyte(stream,(uint8)bit_akku);
  8260.           bit_akku = bit_akku>>8;
  8261.           count -= 8;
  8262.           if (count<=bitshift) break;
  8263.         }
  8264.       # letztes Byte (count Bits) schreiben:
  8265.       if (!(count==0))
  8266.         { ptr = b_file_nextbyte(stream);
  8267.           if (ptr == (uintB*)NULL) # EOF ?
  8268.             { ptr = b_file_eofbyte(stream); # 1 Byte Platz machen
  8269.               *ptr = (uint8)bit_akku; # Byte schreiben
  8270.             }
  8271.             else
  8272.             # nächstes Byte nur teilweise überschreiben:
  8273.             { var reg3 uint8 diff = (*ptr ^ (uint8)bit_akku) & (uint8)(bit(count)-1);
  8274.               if (diff == 0) goto no_modification;
  8275.               *ptr ^= diff;
  8276.             }
  8277.           set_modified_flag(stream);
  8278.           no_modification: ;
  8279.         }
  8280.       TheStream(stream)->strm_file_bitindex = fixnum(count);
  8281.       # position incrementieren:
  8282.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  8283.     }
  8284.  
  8285. # Typ wr_by_ix: eines dieser drei Unterprogramme:
  8286.   typedef void wr_by_ix (object stream, uintL bitsize, uintL bytesize);
  8287.  
  8288. # UP für WRITE-BYTE auf File-Streams für Integers, Art u :
  8289. # Legt das Objekt (ein Integer >=0) als bytesize Bytes im Bitbuffer ab.
  8290. # > stream : File-Stream für Integers, Art u
  8291. # > obj : auszugebendes Objekt
  8292. # > finisher : Beendigungsroutine
  8293.   local void wr_by_ixu_file (object stream, object obj, wr_by_ix* finisher);
  8294.   local void wr_by_ixu_file(stream,obj,finisher)
  8295.     var reg1 object stream;
  8296.     var reg5 object obj;
  8297.     var reg8 wr_by_ix* finisher;
  8298.     { # obj überprüfen:
  8299.       if (!integerp(obj)) { fehler_wr_integer(stream,obj); }
  8300.       if (!positivep(obj)) { fehler_bad_integer(stream,obj); }
  8301.       # obj ist jetzt ein Integer >=0
  8302.      {var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize);
  8303.       var reg6 uintL bytesize = ceiling(bitsize,8);
  8304.       # obj in den Bitbuffer übertragen:
  8305.       { var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize];
  8306.         var reg4 uintL count = bytesize;
  8307.         if (posfixnump(obj))
  8308.           # obj ist ein Fixnum >=0
  8309.           { var reg3 uintL wert = posfixnum_to_L(obj);
  8310.             # wert < 2^bitsize überprüfen:
  8311.             if (!((bitsize>=oint_data_len) || (wert < bit(bitsize))))
  8312.               { fehler_bad_integer(stream,obj); }
  8313.             # wert im Bitbuffer ablegen:
  8314.             until (wert==0)
  8315.               { *--bitbufferptr = (uint8)wert; wert = wert>>8; count--; }
  8316.           }
  8317.           else
  8318.           # obj ist ein Bignum >0
  8319.           { var reg5 uintL len = (uintL)(TheBignum(obj)->length);
  8320.             # obj < 2^bitsize überprüfen:
  8321.             if (!((floor(bitsize,intDsize) >= len)
  8322.                   || ((floor(bitsize,intDsize) == len-1)
  8323.                       && (TheBignum(obj)->data[0] < bit(bitsize%intDsize))
  8324.                ) )   )
  8325.               { fehler_bad_integer(stream,obj); }
  8326.             #if BIG_ENDIAN_P
  8327.             {var reg3 uintB* ptr = (uintB*)&TheBignum(obj)->data[len];
  8328.              # Digit-Länge in Byte-Länge umrechnen:
  8329.              len = (intDsize/8)*len;
  8330.              #define CHECK_NEXT_BYTE(i)  \
  8331.                if (!( ((uintB*)(&TheBignum(obj)->data[0]))[i] ==0)) goto len_ok; \
  8332.                len--;
  8333.              DOCONSTTIMES(intDsize/8,CHECK_NEXT_BYTE); # CHECK_NEXT_BYTE(0..intDsize/8-1)
  8334.              #undef CHECK_NEXT_BYTE
  8335.              len_ok:
  8336.              # obj im Bitbuffer ablegen:
  8337.              count = count - len;
  8338.              dotimespL(len,len, { *--bitbufferptr = *--ptr; } );
  8339.             }
  8340.             #else
  8341.             {var reg3 uintD* ptr = &TheBignum(obj)->data[len];
  8342.              len--;
  8343.              count -= (intDsize/8)*len;
  8344.              dotimesL(len,len,
  8345.                { var reg2 uintD digit = *--ptr;
  8346.                  doconsttimes(intDsize/8,
  8347.                    { *--bitbufferptr = (uintB)digit; digit = digit >> 8; }
  8348.                    );
  8349.                });
  8350.              {var reg2 uintD digit = *--ptr;
  8351.               doconsttimes(intDsize/8,
  8352.                 { if (digit==0) goto ok;
  8353.                   *--bitbufferptr = (uintB)digit; digit = digit >> 8;
  8354.                   count--;
  8355.                 });
  8356.               ok: ;
  8357.             }}
  8358.             #endif
  8359.           }
  8360.         dotimesL(count,count, { *--bitbufferptr = 0; } );
  8361.       }
  8362.       (*finisher)(stream,bitsize,bytesize);
  8363.     }}
  8364.  
  8365. # UP für WRITE-BYTE auf File-Streams für Integers, Art s :
  8366. # Legt das Objekt (ein Integer) als bytesize Bytes im Bitbuffer ab.
  8367. # > stream : File-Stream für Integers, Art s
  8368. # > obj : auszugebendes Objekt
  8369. # > finisher : Beendigungsroutine
  8370.   local void wr_by_ixs_file (object stream, object obj, wr_by_ix* finisher);
  8371.   local void wr_by_ixs_file(stream,obj,finisher)
  8372.     var reg1 object stream;
  8373.     var reg5 object obj;
  8374.     var reg8 wr_by_ix* finisher;
  8375.     { # obj überprüfen:
  8376.       if (!integerp(obj)) { fehler_wr_integer(stream,obj); }
  8377.       # obj ist jetzt ein Integer
  8378.      {var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize);
  8379.       var reg6 uintL bytesize = ceiling(bitsize,8);
  8380.       # obj in den Bitbuffer übertragen:
  8381.       { var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize];
  8382.         var reg4 uintL count = bytesize;
  8383.         var reg6 uintL sign = (sintL)R_sign(obj);
  8384.         if (fixnump(obj))
  8385.           # obj ist ein Fixnum
  8386.           { var reg3 uintL wert = fixnum_to_L(obj); # >=0 oder <0, je nach sign
  8387.             # 0 <= wert < 2^(bitsize-1) bzw. -2^(bitsize-1) <= wert < 0 überprüfen:
  8388.             wert = wert^sign;
  8389.             if (!((bitsize>oint_data_len) || (wert < bit(bitsize-1))))
  8390.               { fehler_bad_integer(stream,obj); }
  8391.             # wert^sign im Bitbuffer ablegen:
  8392.             until (wert == 0)
  8393.               { *--bitbufferptr = (uint8)(wert^sign); wert = wert>>8; count--; }
  8394.             dotimesL(count,count, { *--bitbufferptr = (uint8)sign; } );
  8395.           }
  8396.           else
  8397.           # obj ist ein Bignum
  8398.           { var reg5 uintL len = (uintL)(TheBignum(obj)->length);
  8399.             # -2^(bitsize-1) <= obj < 2^(bitsize-1) überprüfen:
  8400.             if (!((floor(bitsize,intDsize) >= len)
  8401.                   || ((bitsize > intDsize*(len-1))
  8402.                       && ((TheBignum(obj)->data[0] ^ (uintD)sign) < bit((bitsize%intDsize)-1))
  8403.                ) )   )
  8404.               { fehler_bad_integer(stream,obj); }
  8405.             #if BIG_ENDIAN_P
  8406.             {var reg3 uintB* ptr = (uintB*)&TheBignum(obj)->data[len];
  8407.              # Digit-Länge in Byte-Länge umrechnen:
  8408.              len = (intDsize/8)*len;
  8409.              #define CHECK_NEXT_BYTE(i)  \
  8410.                if (!( ((uintB*)(&TheBignum(obj)->data[0]))[i] == (uintB)sign)) goto len_ok; \
  8411.                len--;
  8412.              DOCONSTTIMES(intDsize/8,CHECK_NEXT_BYTE); # CHECK_NEXT_BYTE(0..intDsize/8-1)
  8413.              #undef CHECK_NEXT_BYTE
  8414.              len_ok:
  8415.              # obj im Bitbuffer ablegen:
  8416.              count = count - len;
  8417.              dotimespL(len,len, { *--bitbufferptr = *--ptr; } );
  8418.             }
  8419.             #else
  8420.             {var reg3 uintD* ptr = &TheBignum(obj)->data[len];
  8421.              len--;
  8422.              count -= (intDsize/8)*len;
  8423.              dotimesL(len,len,
  8424.                { var reg2 uintD digit = *--ptr;
  8425.                  doconsttimes(intDsize/8,
  8426.                    { *--bitbufferptr = (uintB)digit; digit = digit >> 8; }
  8427.                    );
  8428.                });
  8429.              {var reg2 sintD digit = *--ptr;
  8430.               doconsttimes(intDsize/8,
  8431.                 { if (digit == (sintD)sign) goto ok;
  8432.                   *--bitbufferptr = (uintB)digit; digit = digit >> 8;
  8433.                   count--;
  8434.                 });
  8435.               ok: ;
  8436.             }}
  8437.             #endif
  8438.             dotimesL(count,count, { *--bitbufferptr = (uintB)sign; } );
  8439.           }
  8440.       }
  8441.       (*finisher)(stream,bitsize,bytesize);
  8442.     }}
  8443.  
  8444. # READ-BYTE - Pseudofunktion für File-Streams für Integers, Art au :
  8445.   local object rd_by_iau_file (object stream);
  8446.   local object rd_by_iau_file(stream)
  8447.     var reg1 object stream;
  8448.     { return rd_by_iax_file(stream,&rd_by_iu_I); }
  8449.  
  8450. # WRITE-BYTE - Pseudofunktion für File-Streams für Integers, Art au :
  8451.   local void wr_by_iau_file (object stream, object obj);
  8452.   local void wr_by_iau_file(stream,obj)
  8453.     var reg1 object stream;
  8454.     var reg2 object obj;
  8455.     { wr_by_ixu_file(stream,obj,&wr_by_ia); }
  8456.  
  8457. # READ-BYTE - Pseudofunktion für File-Streams für Integers, Art as :
  8458.   local object rd_by_ias_file (object stream);
  8459.   local object rd_by_ias_file(stream)
  8460.     var reg1 object stream;
  8461.     { return rd_by_iax_file(stream,&rd_by_is_I); }
  8462.  
  8463. # WRITE-BYTE - Pseudofunktion für File-Streams für Integers, Art as :
  8464.   local void wr_by_ias_file (object stream, object obj);
  8465.   local void wr_by_ias_file(stream,obj)
  8466.     var reg1 object stream;
  8467.     var reg2 object obj;
  8468.     { wr_by_ixs_file(stream,obj,&wr_by_ia); }
  8469.  
  8470. # READ-BYTE - Pseudofunktion für File-Streams für Integers, Art bu :
  8471.   local object rd_by_ibu_file (object stream);
  8472.   local object rd_by_ibu_file(stream)
  8473.     var reg1 object stream;
  8474.     { return rd_by_ibx_file(stream,&rd_by_iu_I); }
  8475.  
  8476. # WRITE-BYTE - Pseudofunktion für File-Streams für Integers, Art bu :
  8477.   local void wr_by_ibu_file (object stream, object obj);
  8478.   local void wr_by_ibu_file(stream,obj)
  8479.     var reg1 object stream;
  8480.     var reg2 object obj;
  8481.     { wr_by_ixu_file(stream,obj,&wr_by_ib); }
  8482.  
  8483. # READ-BYTE - Pseudofunktion für File-Streams für Integers, Art bs :
  8484.   local object rd_by_ibs_file (object stream);
  8485.   local object rd_by_ibs_file(stream)
  8486.     var reg1 object stream;
  8487.     { return rd_by_ibx_file(stream,&rd_by_is_I); }
  8488.  
  8489. # WRITE-BYTE - Pseudofunktion für File-Streams für Integers, Art bs :
  8490.   local void wr_by_ibs_file (object stream, object obj);
  8491.   local void wr_by_ibs_file(stream,obj)
  8492.     var reg1 object stream;
  8493.     var reg2 object obj;
  8494.     { wr_by_ixs_file(stream,obj,&wr_by_ib); }
  8495.  
  8496. # READ-BYTE - Pseudofunktion für File-Streams für Integers, Art cu :
  8497.   local object rd_by_icu_file (object stream);
  8498.   local object rd_by_icu_file(stream)
  8499.     var reg1 object stream;
  8500.     { return rd_by_icx_file(stream,&rd_by_iu_I); }
  8501.  
  8502. # WRITE-BYTE - Pseudofunktion für File-Streams für Integers, Art cu :
  8503.   local void wr_by_icu_file (object stream, object obj);
  8504.   local void wr_by_icu_file(stream,obj)
  8505.     var reg1 object stream;
  8506.     var reg2 object obj;
  8507.     { wr_by_ixu_file(stream,obj,&wr_by_ic); }
  8508.  
  8509. # READ-BYTE - Pseudofunktion für File-Streams für Integers, Art cs :
  8510.   local object rd_by_ics_file (object stream);
  8511.   local object rd_by_ics_file(stream)
  8512.     var reg1 object stream;
  8513.     { return rd_by_icx_file(stream,&rd_by_is_I); }
  8514.  
  8515. # WRITE-BYTE - Pseudofunktion für File-Streams für Integers, Art cs :
  8516.   local void wr_by_ics_file (object stream, object obj);
  8517.   local void wr_by_ics_file(stream,obj)
  8518.     var reg1 object stream;
  8519.     var reg2 object obj;
  8520.     { wr_by_ixs_file(stream,obj,&wr_by_ic); }
  8521.  
  8522. # WRITE-BYTE-SEQUENCE für File-Streams für Integers, Art au, bitsize = 8 :
  8523.   local uintB* write_byte_array_iau8_file (object stream, uintB* byteptr, uintL len);
  8524.   local uintB* write_byte_array_iau8_file(stream,byteptr,len)
  8525.     var reg5 object stream;
  8526.     var reg2 uintB* byteptr;
  8527.     var reg9 uintL len;
  8528.     { var reg6 uintL remaining = len;
  8529.       var reg1 uintB* ptr;
  8530.       do # Noch remaining>0 Bytes abzulegen.
  8531.         { ptr = b_file_nextbyte(stream);
  8532.           if (ptr == (uintB*)NULL) goto eof_reached;
  8533.          {var reg8 object eofindex = TheStream(stream)->strm_file_eofindex;
  8534.           var reg7 uintL next = # so viel wie noch in den Buffer oder bis EOF paßt
  8535.             (eq(eofindex,T) ? strm_file_bufflen : posfixnum_to_L(eofindex))
  8536.             - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index); # > 0 !
  8537.           if (next > remaining) { next = remaining; }
  8538.           # next Bytes in den Buffer kopieren:
  8539.           {var reg4 uintL count;
  8540.            dotimespL(count,next,
  8541.              { var reg3 uintB b = *byteptr++; # nächstes Byte
  8542.                if (!(*ptr == b)) { *ptr = b; set_modified_flag(stream); } # in den Buffer
  8543.                ptr++;
  8544.              });
  8545.           }
  8546.           remaining = remaining - next;
  8547.           # index incrementieren:
  8548.           TheStream(stream)->strm_file_index =
  8549.             fixnum_inc(TheStream(stream)->strm_file_index,next);
  8550.         }}
  8551.         until (remaining == 0);
  8552.       if (FALSE)
  8553.         eof_reached: # Schreiben am EOF, eofindex = index
  8554.         do # Noch remaining>0 Bytes abzulegen.
  8555.           { var reg7 uintL next = # so viel wie noch Platz im Buffer ist
  8556.               strm_file_bufflen
  8557.               - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index);
  8558.             if (next==0)
  8559.               { # Buffer muß neu gefüllt werden. Da nach ihm sowieso EOF kommt,
  8560.                 # genügt es, ihn hinauszuschreiben:
  8561.                 if (modified_flag(stream)) { b_file_half_flush(stream); }
  8562.                 TheStream(stream)->strm_file_buffstart =
  8563.                   fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen);
  8564.                 TheStream(stream)->strm_file_eofindex = Fixnum_0; # eofindex := 0
  8565.                 TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert
  8566.                 # Dann nochmals versuchen:
  8567.                 next = strm_file_bufflen;
  8568.               }
  8569.             if (next > remaining) { next = remaining; }
  8570.             # next Bytes in den Buffer kopieren:
  8571.             {var reg3 uintL count;
  8572.              ptr = &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(TheStream(stream)->strm_file_index)];
  8573.              dotimespL(count,next, { *ptr++ = *byteptr++; } );
  8574.              set_modified_flag(stream);
  8575.             }
  8576.             remaining = remaining - next;
  8577.             # index und eofindex incrementieren:
  8578.             TheStream(stream)->strm_file_index =
  8579.               fixnum_inc(TheStream(stream)->strm_file_index,next);
  8580.             TheStream(stream)->strm_file_eofindex =
  8581.               fixnum_inc(TheStream(stream)->strm_file_eofindex,next);
  8582.           }
  8583.           until (remaining == 0);
  8584.       # position incrementieren:
  8585.       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,len);
  8586.       return byteptr;
  8587.     }
  8588.  
  8589. # File-Stream allgemein
  8590. # =====================
  8591.  
  8592. # UP: Positioniert einen (offenen) File-Stream an den Anfang.
  8593. # position_file_start(stream);
  8594. # > stream : (offener) File-Stream.
  8595. # verändert in stream: index, eofindex, buffstart, ..., position, rd_ch_last
  8596.   local void position_file_start (object stream);
  8597.   local void position_file_start(stream)
  8598.     var reg1 object stream;
  8599.     { position_b_file(stream,
  8600.                       (TheStream(stream)->strmflags & strmflags_i_B) == strmflags_ib_B # Integer-Stream vom Typ b ?
  8601.                       ? sizeof(uintL) : 0 # ja -> Position 4, sonst Position 0
  8602.                      );
  8603.       switch (TheStream(stream)->strmflags & strmflags_i_B)
  8604.         { case strmflags_ib_B: case strmflags_ic_B:
  8605.             # Integer-Stream der Art b,c
  8606.             TheStream(stream)->strm_file_bitindex = Fixnum_0; # bitindex := 0
  8607.           default: break;
  8608.         }
  8609.       TheStream(stream)->strm_file_position = Fixnum_0; # position := 0
  8610.       TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL
  8611.     }
  8612.  
  8613. # UP: Positioniert einen (offenen) File-Stream an eine gegebene Position.
  8614. # position_file(stream,position);
  8615. # > stream : (offener) File-Stream.
  8616. # > position : neue (logische) Position
  8617. # verändert in stream: index, eofindex, buffstart, ..., position, rd_ch_last
  8618.   local void position_file (object stream, uintL position);
  8619.   local void position_file(stream,position)
  8620.     var reg1 object stream;
  8621.     var reg2 uintL position;
  8622.     { var reg3 uintB flags = TheStream(stream)->strmflags;
  8623.       if (flags & strmflags_i_B) # Integer-Stream ?
  8624.         { if ((flags & strmflags_i_B) == strmflags_ia_B)
  8625.             # Art a
  8626.             { var reg4 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize);
  8627.               position_b_file(stream,position*(bitsize/8));
  8628.             }
  8629.             else
  8630.             # Art b,c
  8631.             { position_i_file(stream,position); }
  8632.         }
  8633.         else
  8634.         { if (TheStream(stream)->strmtype == strmtype_ch_file) # Character-Stream ?
  8635.             { position_b_file(stream,position*char_size); }
  8636.           else # String-Char-Stream
  8637.             { position_b_file(stream,position); }
  8638.           TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL
  8639.         }
  8640.       TheStream(stream)->strm_file_position = fixnum(position);
  8641.     }
  8642.  
  8643. # UP: Positioniert einen (offenen) File-Stream ans Ende.
  8644. # position_file_end(stream);
  8645. # > stream : (offener) File-Stream.
  8646. # verändert in stream: index, eofindex, buffstart, ..., position, rd_ch_last
  8647.   local void position_file_end (object stream);
  8648.   local void position_file_end(stream)
  8649.     var reg1 object stream;
  8650.     { # evtl. Buffer hinausschreiben:
  8651.       if (modified_flag(stream)) { b_file_flush(stream); }
  8652.      {var reg2 uintL eofbytes; # EOF-Position, gemessen in Bytes
  8653.       # ans Ende positionieren:
  8654.       begin_system_call();
  8655.       file_lseek(stream,0,SEEK_END,eofbytes=);
  8656.       end_system_call();
  8657.       # logische Position berechnen und eofbytes korrigieren:
  8658.       { var reg5 uintL position; # logische Position
  8659.         var reg6 uintL eofbits = 0; # Bit-Ergänzung zu eofbytes
  8660.         var reg3 uintB flags = TheStream(stream)->strmflags;
  8661.         if (flags & strmflags_i_B) # Integer-Stream ?
  8662.           { var reg4 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize);
  8663.             if ((flags & strmflags_i_B) == strmflags_ia_B)
  8664.               # Art a
  8665.               { var reg4 uintL bytesize = bitsize/8;
  8666.                 position = floor(eofbytes,bytesize);
  8667.                 eofbytes = position*bytesize;
  8668.               }
  8669.             elif ((flags & strmflags_i_B) == strmflags_ib_B)
  8670.               # Art b
  8671.               { eofbytes -= sizeof(uintL); # Header berücksichtigen
  8672.                 # Ist die gemerkte EOF-Position plausibel?
  8673.                 position = posfixnum_to_L(TheStream(stream)->strm_file_eofposition);
  8674.                 if (!(ceiling(position*bitsize,8)==eofbytes)) # ja -> verwende sie
  8675.                   { position = floor(eofbytes*8,bitsize); } # nein -> rechne sie neu aus
  8676.                 # Rechne eofbytes und eofbits neu aus:
  8677.                 eofbytes = floor(position*bitsize,8);
  8678.                 eofbits = (position*bitsize)%8;
  8679.                 eofbytes += sizeof(uintL); # Header berücksichtigen
  8680.               }
  8681.             else
  8682.               # Art c
  8683.               { position = floor(eofbytes*8,bitsize);
  8684.                 eofbytes = floor(position*bitsize,8);
  8685.                 eofbits = (position*bitsize)%8;
  8686.               }
  8687.           }
  8688.           else
  8689.           { if (TheStream(stream)->strmtype == strmtype_ch_file) # Character-Stream ?
  8690.               { position = floor(eofbytes,char_size); eofbytes = position*char_size; }
  8691.             else # String-Char-Stream
  8692.               { position = eofbytes; }
  8693.           }
  8694.         # auf den Anfang des letzten Sectors positionieren:
  8695.         { var reg4 uintL buffstart;
  8696.           begin_system_call();
  8697.           file_lseek(stream,floor(eofbytes,strm_file_bufflen)*strm_file_bufflen,SEEK_SET,buffstart=);
  8698.           end_system_call();
  8699.           TheStream(stream)->strm_file_buffstart = fixnum(buffstart);
  8700.         }
  8701.         # Sector lesen:
  8702.         TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL
  8703.         TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert
  8704.         { var reg4 uintL eofindex = eofbytes % strm_file_bufflen;
  8705.           if (!((eofindex==0) && (eofbits==0))) # EOF am Sectorende -> brauche nichts zu lesen
  8706.             { b_file_nextbyte(stream);
  8707.               # Jetzt ist index=0. index und eofindex setzen:
  8708.               TheStream(stream)->strm_file_index = fixnum(eofindex);
  8709.               if (!(eofbits==0)) { eofindex += 1; }
  8710.               TheStream(stream)->strm_file_eofindex = fixnum(eofindex);
  8711.         }   }
  8712.         switch (flags & strmflags_i_B)
  8713.           { case strmflags_ib_B: case strmflags_ic_B:
  8714.               # Integer-Stream der Art b,c
  8715.               TheStream(stream)->strm_file_bitindex = fixnum(eofbits);
  8716.             default: break;
  8717.           }
  8718.         # position setzen:
  8719.         TheStream(stream)->strm_file_position = fixnum(position);
  8720.         TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL
  8721.     }}}
  8722.  
  8723. # UP: erzeugt ein File-Stream
  8724. # make_file_stream(handle,direction,type,eltype_size,append_flag)
  8725. # > handle: Handle des geöffneten Files
  8726. # > STACK_1: Filename, ein Pathname
  8727. # > STACK_0: Truename, ein Pathname
  8728. # > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE)
  8729. # > type: nähere Typinfo
  8730. #         (STRMTYPE_SCH_FILE oder STRMTYPE_CH_FILE oder
  8731. #          STRMTYPE_IU_FILE oder STRMTYPE_IS_FILE)
  8732. # > eltype_size: (bei Integer-Streams) Größe der Elemente in Bits,
  8733. #         ein Fixnum >0 und <intDsize*uintC_max
  8734. # > append_flag: TRUE falls der Stream gleich ans Ende positioniert werden
  8735. #         soll, FALSE sonst
  8736. # < ergebnis: File-Stream (oder evtl. File-Handle-Stream)
  8737. # < STACK: aufgeräumt
  8738. # kann GC auslösen
  8739.   global object make_file_stream (object handle, uintB direction, uintB type, object eltype_size, boolean append_flag);
  8740.   global object make_file_stream(handle,direction,type,eltype_size,append_flag)
  8741.     var reg9 object handle;
  8742.     var reg8 uintB direction;
  8743.     var reg4 uintB type;
  8744.     var reg9 object eltype_size;
  8745.     var reg10 boolean append_flag;
  8746.     {
  8747.       #if defined(HANDLES)
  8748.       # Nur reguläre Files zu gebufferten File-Streams machen.
  8749.       # Alles andere gibt File-Handle-Streams, weil vermutlich lseek() nicht geht.
  8750.       if (!nullp(handle))
  8751.         {
  8752.           #if defined(UNIX) || defined(MSDOS) # || defined(RISCOS)
  8753.           var struct stat statbuf;
  8754.           begin_system_call();
  8755.           if (!( fstat(TheHandle(handle),&statbuf) ==0)) { OS_error(); }
  8756.           end_system_call();
  8757.           if (!S_ISREG(statbuf.st_mode))
  8758.           #endif
  8759.           #ifdef AMIGAOS
  8760.           var reg1 LONG not_regular_p;
  8761.           begin_system_call();
  8762.           not_regular_p = IsInteractive(TheHandle(handle)); # Behandlung nicht interaktiver, nicht regulärer Files??
  8763.           end_system_call();
  8764.           if (not_regular_p)
  8765.           #endif
  8766.             { if (((type == strmtype_sch_file)
  8767.                    || ((type == strmtype_iu_file) && eq(eltype_size,fixnum(8)))
  8768.                   )
  8769.                   && !append_flag
  8770.                  )
  8771.                 { return make_handle_stream(handle,direction); }
  8772.                 else
  8773.                 { # Truename noch in STACK_0, Wert für Slot PATHNAME von FILE-ERROR
  8774.                   pushSTACK(STACK_0);
  8775.                   pushSTACK(S(open));
  8776.                   //: DEUTSCH "~: ~ ist kein reguläres File."
  8777.                   //: ENGLISH "~: ~ is not a regular file."
  8778.                   //: FRANCAIS "~: ~ n'est pas un fichier régulier."
  8779.                   fehler(file_error,GETTEXT( "~: ~ is not a regular file."));
  8780.         }   }   }
  8781.       #endif
  8782.      { # Flags:
  8783.        var reg6 uintB flags =
  8784.          (direction==0 ? 0 : # bei Modus :PROBE sind alle Flags =0
  8785.            # sonst:
  8786.            (direction>=4 ? strmflags_open_B : strmflags_rd_B) # Modus :INPUT[-IMMUTABLE] -> nur Read, sonst Read/Write
  8787.            &
  8788.            (type>=strmtype_iu_file ? strmflags_by_B : strmflags_ch_B) # auf Integers oder Characters
  8789.            #ifdef IMMUTABLE
  8790.            | (direction==3 ? strmflags_immut_B : 0) # Modus :INPUT-IMMUTABLE ?
  8791.            #endif
  8792.          );
  8793.        # Art von Integer-Streams:
  8794.        var reg5 uintB art;
  8795.        # Länge:
  8796.        var reg7 uintC len = strm_len; # Das hat jeder Stream
  8797.        len += 8; # Das haben alle File-Streams
  8798.        if (type==strmtype_sch_file)
  8799.          { len += 1; } # Das haben die File-Streams für String-Chars
  8800.        elif (type>=strmtype_iu_file)
  8801.          { len += 2; # Das haben die File-Streams für Integers
  8802.            {var reg1 uintL bitsize = posfixnum_to_L(eltype_size);
  8803.             if ((bitsize%8)==0)
  8804.               { art = strmflags_ia_B; } # Art a
  8805.               else
  8806.               { len += 1; # Arten b,c
  8807.                 if (bitsize<8)
  8808.                   { art = strmflags_ib_B; len += 1; } # Art b
  8809.                   else
  8810.                   { art = strmflags_ic_B; } # Art c
  8811.            }  }
  8812.            flags |= art; # Art in die Flags mit aufnehmen
  8813.          }
  8814.        #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT
  8815.        pushSTACK(handle); # Handle retten
  8816.        #endif
  8817.       {# Stream allozieren:
  8818.        var reg1 object stream = allocate_stream(flags,type,len);
  8819.        # und füllen:
  8820.        # Komponenten aller Streams:
  8821.        switch (type)
  8822.          { case strmtype_sch_file:
  8823.              TheStream(stream)->strm_rd_ch = P(rd_ch_sch_file);
  8824.              TheStream(stream)->strm_wr_ch = P(wr_ch_sch_file);
  8825.              #ifdef STRM_WR_SS
  8826.              TheStream(stream)->strm_wr_ss = P(wr_ss_sch_file);
  8827.              #endif
  8828.              break;
  8829.            case strmtype_ch_file:
  8830.              TheStream(stream)->strm_rd_ch = P(rd_ch_ch_file);
  8831.              TheStream(stream)->strm_wr_ch = P(wr_ch_ch_file);
  8832.              #ifdef STRM_WR_SS
  8833.              TheStream(stream)->strm_wr_ss = P(wr_ss_dummy_nogc);
  8834.              #endif
  8835.              break;
  8836.            case strmtype_iu_file:
  8837.              TheStream(stream)->strm_rd_by =
  8838.                (art==strmflags_ia_B ? P(rd_by_iau_file) :
  8839.                 art==strmflags_ib_B ? P(rd_by_ibu_file) :
  8840.                                       P(rd_by_icu_file)
  8841.                );
  8842.              TheStream(stream)->strm_wr_by =
  8843.                (art==strmflags_ia_B ? P(wr_by_iau_file) :
  8844.                 art==strmflags_ib_B ? P(wr_by_ibu_file) :
  8845.                                       P(wr_by_icu_file)
  8846.                );
  8847.              break;
  8848.            case strmtype_is_file:
  8849.              TheStream(stream)->strm_rd_by =
  8850.                (art==strmflags_ia_B ? P(rd_by_ias_file) :
  8851.                 art==strmflags_ib_B ? P(rd_by_ibs_file) :
  8852.                                       P(rd_by_ics_file)
  8853.                );
  8854.              TheStream(stream)->strm_wr_by =
  8855.                (art==strmflags_ia_B ? P(wr_by_ias_file) :
  8856.                 art==strmflags_ib_B ? P(wr_by_ibs_file) :
  8857.                                       P(wr_by_ics_file)
  8858.                );
  8859.              break;
  8860.            default: NOTREACHED
  8861.          }
  8862.        # Default für READ-BYTE-Pseudofunktion:
  8863.        if ((flags & strmflags_rd_by_B)==0)
  8864.          { TheStream(stream)->strm_rd_by = P(rd_by_dummy); }
  8865.        # Default für WRITE-BYTE-Pseudofunktion:
  8866.        if ((flags & strmflags_wr_by_B)==0)
  8867.          { TheStream(stream)->strm_wr_by = P(wr_by_dummy); }
  8868.        # Default für READ-CHAR-Pseudofunktion:
  8869.        if ((flags & strmflags_rd_ch_B)==0)
  8870.          { TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); }
  8871.        TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL
  8872.        # Default für WRITE-CHAR-Pseudofunktion:
  8873.        if ((flags & strmflags_wr_ch_B)==0)
  8874.          { TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  8875.            #ifdef STRM_WR_SS
  8876.            TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  8877.            #endif
  8878.          }
  8879.        TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0
  8880.        # Komponenten von File-Streams:
  8881.        #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT
  8882.        handle = popSTACK(); # Handle zurück
  8883.        #endif
  8884.        TheStream(stream)->strm_file_truename = popSTACK(); # Truename eintragen
  8885.        TheStream(stream)->strm_file_name = popSTACK(); # Filename eintragen
  8886.        if (!nullp(handle)) # Handle=NIL -> Rest bereits mit NIL initialisiert, fertig
  8887.          { TheStream(stream)->strm_file_handle = handle; # Handle eintragen
  8888.            TheStream(stream)->strm_file_buffstart = Fixnum_0; # buffstart := 0
  8889.            # Buffer allozieren:
  8890.            pushSTACK(stream);
  8891.           {var reg2 object buffer = allocate_string(strm_file_bufflen); # neuer String
  8892.            stream = popSTACK();
  8893.            TheStream(stream)->strm_file_buffer = buffer;
  8894.           }
  8895.            TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL
  8896.            TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, Buffer unmodifiziert
  8897.            TheStream(stream)->strm_file_position = Fixnum_0; # position := 0
  8898.            if (type==strmtype_sch_file)
  8899.              # File-Stream für String-Chars
  8900.              { TheStream(stream)->strm_sch_file_lineno = Fixnum_1; }
  8901.            elif (type>=strmtype_iu_file)
  8902.              # File-Stream für Integers
  8903.              { TheStream(stream)->strm_file_bitsize = eltype_size;
  8904.                # Bitbuffer allozieren:
  8905.                pushSTACK(stream);
  8906.               {var reg2 object bitbuffer = allocate_bit_vector(ceiling(posfixnum_to_L(eltype_size),8)*8);
  8907.                stream = popSTACK();
  8908.                TheStream(stream)->strm_file_bitbuffer = bitbuffer;
  8909.               }
  8910.                if (!(art==strmflags_ia_B))
  8911.                  # Arten b,c
  8912.                  { TheStream(stream)->strm_file_bitindex = Fixnum_0; # bitindex := 0
  8913.                    if (art==strmflags_ib_B)
  8914.                      # Art b
  8915.                      { # eofposition lesen:
  8916.                        var reg3 uintL eofposition = 0;
  8917.                        var reg2 uintC count;
  8918.                        for (count=0; count < 8*sizeof(uintL); count += 8 )
  8919.                          { var reg1 uintB* ptr = b_file_nextbyte(stream);
  8920.                            if (ptr == (uintB*)NULL) goto too_short;
  8921.                            eofposition |= ((*ptr) << count);
  8922.                            # index incrementieren, da gerade *ptr verarbeitet:
  8923.                            TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  8924.                          }
  8925.                        if (FALSE)
  8926.                          { too_short:
  8927.                            # File zu kurz (< sizeof(uintL) Bytes)
  8928.                            if ((TheStream(stream)->strmflags & strmflags_wr_by_B) == 0) # Read-Only-Stream?
  8929.                              goto bad_eofposition;
  8930.                            # File Read/Write -> setze eofposition := 0
  8931.                            eofposition = 0;
  8932.                            position_b_file(stream,0); # an Position 0 positionieren
  8933.                           {var reg2 uintC count; # und eofposition = 0 herausschreiben
  8934.                            dotimespC(count,sizeof(uintL), { b_file_writebyte(stream,0); } );
  8935.                          }}
  8936.                        elif (eofposition > (uintL)(bitm(oint_data_len)-1))
  8937.                          { bad_eofposition:
  8938.                            # Keine gültige EOF-Position.
  8939.                            # File schließen und Error melden:
  8940.                            TheStream(stream)->strmflags &= ~strmflags_wr_by_B; # Stream Read-Only machen
  8941.                            pushSTACK(stream);
  8942.                            stream_close(&STACK_0);
  8943.                            # STACK_0 = Wert für Slot STREAM von STREAM-ERROR
  8944.                            pushSTACK(TheStream(STACK_0)->strm_file_truename);
  8945.                            //: DEUTSCH "File ~ hat nicht das Format eines Integer-Files."
  8946.                            //: ENGLISH "file ~ is not an integer file"
  8947.                            //: FRANCAIS "Le fichier ~ n'a pas le format d'un fichier d'entiers."
  8948.                            fehler(stream_error,GETTEXT("file ~ is not an integer file"));
  8949.                          }
  8950.                        # Auf die gelesene EOF-Position verlassen wir uns jetzt!
  8951.                        TheStream(stream)->strm_file_eofposition =
  8952.                          fixnum(eofposition);
  8953.              }   }   }
  8954.            # Liste der offenen File-Streams um stream erweitern:
  8955.            pushSTACK(stream);
  8956.           {var reg1 object new_cons = allocate_cons();
  8957.            Car(new_cons) = stream = popSTACK();
  8958.            Cdr(new_cons) = O(open_files);
  8959.            O(open_files) = new_cons;
  8960.           }# Modus :APPEND behandeln:
  8961.            if (append_flag) { position_file_end(stream); }
  8962.          }
  8963.        return stream;
  8964.     }}}
  8965.  
  8966. # UP: Bereitet das Schließen eines File-Streams vor.
  8967. # Dabei wird der Buffer und evtl. eofposition hinausgeschrieben.
  8968. # file_flush(stream);
  8969. # > stream : (offener) File-Stream.
  8970. # verändert in stream: index, eofindex, buffstart, ...
  8971.   local void file_flush (object stream);
  8972.   local void file_flush(stream)
  8973.     var reg1 object stream;
  8974.     { # Bei Integer-Streams (Art b) eofposition abspeichern:
  8975.       if ((TheStream(stream)->strmflags & strmflags_i_B) == strmflags_ib_B)
  8976.         if (TheStream(stream)->strmflags & strmflags_wr_by_B) # nur falls nicht Read-Only
  8977.           { position_b_file(stream,0); # an Position 0 positionieren
  8978.            {var reg2 uintL eofposition = posfixnum_to_L(TheStream(stream)->strm_file_eofposition);
  8979.             var reg3 uintC count;
  8980.             dotimespC(count,sizeof(uintL),
  8981.               { b_file_writebyte(stream,(uintB)eofposition);
  8982.                 eofposition = eofposition>>8;
  8983.               });
  8984.           }}
  8985.       # evtl. Buffer hinausschreiben:
  8986.       if (modified_flag(stream)) { b_file_flush(stream); }
  8987.       # Nun ist das modified_flag gelöscht.
  8988.     }
  8989.  
  8990. # UP: Bringt den wartenden Output eines File-Stream ans Ziel.
  8991. # Schreibt dazu den Buffer des File-Streams (auch physikalisch) aufs File.
  8992. # finish_output_file(stream);
  8993. # > stream : File-Stream.
  8994. # verändert in stream: handle, index, eofindex, buffstart, ..., rd_ch_last
  8995. # kann GC auslösen
  8996.   local void finish_output_file (object stream);
  8997.   local void finish_output_file(stream)
  8998.     var reg1 object stream;
  8999.     { # Handle=NIL (Stream bereits geschlossen) -> fertig:
  9000.       if (nullp(TheStream(stream)->strm_file_handle)) { return; }
  9001.       # kein File mit Schreibzugriff -> gar nichts zu tun:
  9002.       if (!(TheStream(stream)->strmflags & strmflags_wr_B)) { return; }
  9003.       # evtl. Buffer und evtl. eofposition hinausschreiben:
  9004.       file_flush(stream);
  9005.       # Nun ist das modified_flag gelöscht.
  9006.      #ifdef MSDOS
  9007.        # File-Handle duplizieren und schließen:
  9008.        { var reg3 uintW handle = TheHandle(TheStream(stream)->strm_file_handle);
  9009.          begin_system_call();
  9010.         {var reg2 sintW handle2 = dup(handle);
  9011.          if (handle2 < 0) { OS_error(); } # Error melden
  9012.          if ( CLOSE(handle2) <0) { OS_error(); }
  9013.          end_system_call();
  9014.        }}
  9015.      #endif
  9016.      #ifdef RISCOS # || MSDOS, wenn wir da nicht schon was besseres hätten
  9017.        # File schließen (DOS schreibt physikalisch):
  9018.        begin_system_call();
  9019.        if ( CLOSE(TheHandle(TheStream(stream)->strm_file_handle)) <0) { OS_error(); }
  9020.        end_system_call();
  9021.        # File neu öffnen:
  9022.        pushSTACK(stream); # stream retten
  9023.        pushSTACK(TheStream(stream)->strm_file_truename); # Filename
  9024.       {# Directory existiert schon:
  9025.        var reg3 object namestring = assume_dir_exists(); # Filename als ASCIZ-String
  9026.        var reg2 sintW handle;
  9027.        begin_system_call();
  9028.        handle = OPEN(TheAsciz(namestring),O_RDWR); # Datei neu öffnen
  9029.        if (handle < 0) { OS_error(); } # Error melden
  9030.        #ifdef MSDOS
  9031.        setmode(handle,O_BINARY);
  9032.        #endif
  9033.        end_system_call();
  9034.        # Nun enthält handle das Handle des geöffneten Files.
  9035.        skipSTACK(1);
  9036.        stream = popSTACK(); # stream zurück
  9037.        # neues Handle eintragen:
  9038.        TheStream(stream)->strm_file_handle = allocate_handle(handle);
  9039.       }
  9040.      #endif
  9041.      #ifdef UNIX
  9042.       #ifdef HAVE_FSYNC
  9043.       begin_system_call();
  9044.       if (!( fsync(TheHandle(TheStream(stream)->strm_file_handle)) ==0))
  9045.         { OS_error(); }
  9046.       end_system_call();
  9047.       #endif
  9048.      #endif
  9049.      #ifdef AMIGAOS
  9050.       #if 0 # Manche Devices vertragen es nicht, wenn man geöffnete Dateien
  9051.             # zu- und wieder aufmacht. Z.B. bei Pipes hat das eine besondere
  9052.             # Bedeutung.
  9053.       begin_system_call();
  9054.       {var reg1 Handle handle = TheHandle(TheStream(stream)->strm_file_handle);
  9055.        if (!IsInteractive(handle))
  9056.          { # File schließen (OS schreibt physikalisch):
  9057.            Close(handle);
  9058.            # File neu öffnen:
  9059.            pushSTACK(stream); # stream retten
  9060.            pushSTACK(TheStream(stream)->strm_file_truename); # Filename
  9061.           {# Directory existiert schon, Datei neu öffnen:
  9062.            var reg2 object namestring = assume_dir_exists(); # Filename als ASCIZ-String
  9063.            handle = Open(TheAsciz(namestring),MODE_OLDFILE);
  9064.            if (handle==NULL) { OS_error(); } # Error melden
  9065.            skipSTACK(1);
  9066.            stream = popSTACK(); # stream zurück
  9067.            # neues Handle eintragen:
  9068.            TheHandle(TheStream(stream)->strm_file_handle) = handle;
  9069.       }  }}
  9070.       end_system_call();
  9071.       #endif
  9072.      #endif
  9073.       # und neu positionieren:
  9074.      {var reg2 uintL position = posfixnum_to_L(TheStream(stream)->strm_file_buffstart)
  9075.                                 + posfixnum_to_L(TheStream(stream)->strm_file_index);
  9076.       TheStream(stream)->strm_file_buffstart = Fixnum_0; # buffstart := 0
  9077.       TheStream(stream)->strm_file_index = Fixnum_0; # index := 0
  9078.       TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL
  9079.       position_b_file(stream,position);
  9080.      }# Komponenten position, ..., lastchar bleiben unverändert
  9081.     }
  9082.  
  9083. # UP: Bringt den wartenden Output eines File-Stream ans Ziel.
  9084. # Schreibt dazu den Buffer des File-Streams (auch physikalisch) aufs File.
  9085. # force_output_file(stream);
  9086. # > stream : File-Stream.
  9087. # verändert in stream: handle, index, eofindex, buffstart, ..., rd_ch_last
  9088. # kann GC auslösen
  9089.   #define force_output_file  finish_output_file
  9090.  
  9091. # UP: Erklärt einen File-Stream für geschlossen.
  9092. # closed_file(stream);
  9093. # > stream : (offener) File-Stream.
  9094. # verändert in stream: alle Komponenten außer name und truename
  9095.   local void closed_file (object stream);
  9096.   local void closed_file(stream)
  9097.     var reg1 object stream;
  9098.     { TheStream(stream)->strm_file_handle = NIL; # Handle wird ungültig
  9099.       TheStream(stream)->strm_file_buffer = NIL; # Buffer freimachen
  9100.       TheStream(stream)->strm_file_buffstart = NIL; # buffstart löschen (unnötig)
  9101.       TheStream(stream)->strm_file_eofindex = NIL; # eofindex löschen (unnötig)
  9102.       TheStream(stream)->strm_file_index = NIL; # index löschen (unnötig)
  9103.       TheStream(stream)->strm_file_position = NIL; # position löschen (unnötig)
  9104.       if (TheStream(stream)->strmflags & strmflags_i_B)
  9105.         { TheStream(stream)->strm_file_bitsize = NIL; # bitsize löschen (unnötig)
  9106.           TheStream(stream)->strm_file_bitbuffer = NIL; # Bitbuffer freimachen
  9107.         }
  9108.     }
  9109.  
  9110. # UP: Schließt einen File-Stream.
  9111. # close_file(stream);
  9112. # > stream : File-Stream.
  9113. # verändert in stream: alle Komponenten außer name und truename
  9114.   local void close_file (object stream);
  9115.   local void close_file(stream)
  9116.     var reg1 object stream;
  9117.     { # Handle=NIL (Stream bereits geschlossen) -> fertig:
  9118.       if (nullp(TheStream(stream)->strm_file_handle)) { return; }
  9119.       # evtl. Buffer und evtl. eofposition hinausschreiben:
  9120.       file_flush(stream);
  9121.       # Nun ist das modified_flag gelöscht.
  9122.       # File schließen:
  9123.       #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  9124.       begin_system_call();
  9125.       if (!( CLOSE(TheHandle(TheStream(stream)->strm_file_handle)) ==0))
  9126.         { OS_error(); }
  9127.       end_system_call();
  9128.       #endif
  9129.       #ifdef AMIGAOS
  9130.       begin_system_call();
  9131.       Close(TheHandle(TheStream(stream)->strm_file_handle));
  9132.       end_system_call();
  9133.       #endif
  9134.       # Komponenten ungültig machen (close_dummys kommt später):
  9135.       closed_file(stream);
  9136.       # stream aus der Liste aller offenen File-Streams streichen:
  9137.       O(open_files) = deleteq(O(open_files),stream);
  9138.     }
  9139.  
  9140. LISPFUNN(file_stream_p,1)
  9141. # (SYS::FILE-STREAM-P stream) == (TYPEP stream 'FILE-STREAM)
  9142.   { var reg1 object arg = popSTACK();
  9143.     if (streamp(arg))
  9144.       { if_strm_file_p(arg, { value1 = T; } , { value1 = NIL; } ); }
  9145.       else
  9146.       { value1 = NIL; }
  9147.     mv_count=1;
  9148.   }
  9149.  
  9150.  
  9151. # Synonym-Stream
  9152. # ==============
  9153.  
  9154. # Zusätzliche Komponenten:
  9155.   # define strm_synonym_symbol  strm_other[0]  # Symbol, auf dessen Wert verwiesen wird
  9156.  
  9157. # Macro: Liefert den Wert eines Symbols, ein Stream.
  9158. # get_synonym_stream(sym)
  9159. # > sym: Symbol
  9160. # < ergebnis: sein Wert, ein Stream
  9161.   #define get_synonym_stream(sym)  \
  9162.     ((!sym_streamp(sym)) ?                    \
  9163.        (fehler_value_stream(sym), unbound) :  \
  9164.        Symbol_value(sym)                      \
  9165.     )
  9166.  
  9167. # READ-BYTE - Pseudofunktion für Synonym-Streams:
  9168.   local object rd_by_synonym (object stream);
  9169.   local object rd_by_synonym(stream)
  9170.     var reg2 object stream;
  9171.     { check_SP();
  9172.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9173.       return read_byte(get_synonym_stream(symbol));
  9174.     }}
  9175.  
  9176. # WRITE-BYTE - Pseudofunktion für Synonym-Streams:
  9177.   local void wr_by_synonym (object stream, object obj);
  9178.   local void wr_by_synonym(stream,obj)
  9179.     var reg2 object stream;
  9180.     var reg3 object obj;
  9181.     { check_SP();
  9182.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9183.       write_byte(get_synonym_stream(symbol),obj);
  9184.     }}
  9185.  
  9186. # READ-CHAR - Pseudofunktion für Synonym-Streams:
  9187.   local object rd_ch_synonym (object* stream_);
  9188.   local object rd_ch_synonym(stream_)
  9189.     var reg3 object* stream_;
  9190.     {  check_SP(); check_STACK();
  9191.      { var reg2 object stream = *stream_;
  9192.        var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9193.        pushSTACK(get_synonym_stream(symbol));
  9194.       {var reg1 object ergebnis = read_char(&STACK_0);
  9195.        skipSTACK(1);
  9196.        return ergebnis;
  9197.     }}}
  9198.  
  9199. # WRITE-CHAR - Pseudofunktion für Synonym-Streams:
  9200.   local void wr_ch_synonym (object* stream_, object obj);
  9201.   local void wr_ch_synonym(stream_,obj)
  9202.     var reg3 object* stream_;
  9203.     var reg4 object obj;
  9204.     { check_SP(); check_STACK();
  9205.      {var reg2 object stream = *stream_;
  9206.       var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9207.       pushSTACK(get_synonym_stream(symbol));
  9208.       write_char(&STACK_0,obj);
  9209.       skipSTACK(1);
  9210.     }}
  9211.  
  9212. #ifdef STRM_WR_SS
  9213. # WRITE-SIMPLE-STRING - Pseudofunktion für Synonym-Streams:
  9214.   local void wr_ss_synonym (object* stream_, object string, uintL start, uintL len);
  9215.   local void wr_ss_synonym(stream_,string,start,len)
  9216.     var reg1 object* stream_;
  9217.     var reg3 object string;
  9218.     var reg4 uintL start;
  9219.     var reg5 uintL len;
  9220.     { check_SP(); check_STACK();
  9221.      {var reg2 object symbol = TheStream(*stream_)->strm_synonym_symbol;
  9222.       pushSTACK(get_synonym_stream(symbol));
  9223.       wr_ss(STACK_0)(&STACK_0,string,start,len);
  9224.       skipSTACK(1);
  9225.       # Line-Position aktualisieren kann hier entfallen.
  9226.     }}
  9227. #endif
  9228.  
  9229. # Schließt einen Synonym-Stream.
  9230. # close_synonym(stream);
  9231. # > stream : Synonym-Stream
  9232. #ifdef X3J13_014
  9233.   #define close_synonym(stream)
  9234. #else
  9235.   local void close_synonym (object stream);
  9236.   local void close_synonym(stream)
  9237.     var reg2 object stream;
  9238.     { check_SP(); check_STACK();
  9239.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9240.       pushSTACK(get_synonym_stream(symbol));
  9241.       stream_close(&STACK_0);
  9242.       skipSTACK(1);
  9243.     }}
  9244. #endif
  9245.  
  9246. # Stellt fest, ob ein Synonym-Stream ein Zeichen verfügbar hat.
  9247. # listen_synonym(stream)
  9248. # > stream : Synonym-Stream
  9249. # < ergebnis:  0 falls Zeichen verfügbar,
  9250. #             -1 falls bei EOF angelangt,
  9251. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  9252. # kann GC auslösen
  9253.   local signean listen_synonym (object stream);
  9254.   local signean listen_synonym(stream)
  9255.     var reg2 object stream;
  9256.     { check_SP();
  9257.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9258.       return stream_listen(get_synonym_stream(symbol));
  9259.     }}
  9260.  
  9261. # UP: Löscht bereits eingegebenen interaktiven Input von einem Synonym-Stream.
  9262. # clear_input_synonym(stream)
  9263. # > stream: Synonym-Stream
  9264. # < ergebnis: TRUE falls Input gelöscht wurde
  9265. # kann GC auslösen
  9266.   local boolean clear_input_synonym (object stream);
  9267.   local boolean clear_input_synonym(stream)
  9268.     var reg2 object stream;
  9269.     { check_SP();
  9270.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9271.       return clear_input(get_synonym_stream(symbol));
  9272.     }}
  9273.  
  9274. # UP: Wartenden Output eines Synonym-Stream ans Ziel bringen.
  9275. # finish_output_synonym(stream);
  9276. # > stream: Synonym-Stream
  9277. # kann GC auslösen
  9278.   local void finish_output_synonym (object stream);
  9279.   local void finish_output_synonym(stream)
  9280.     var reg2 object stream;
  9281.     { check_SP();
  9282.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9283.       finish_output(get_synonym_stream(symbol));
  9284.     }}
  9285.  
  9286. # UP: Wartenden Output eines Synonym-Stream ans Ziel bringen.
  9287. # force_output_synonym(stream);
  9288. # > stream: Synonym-Stream
  9289. # kann GC auslösen
  9290.   local void force_output_synonym (object stream);
  9291.   local void force_output_synonym(stream)
  9292.     var reg2 object stream;
  9293.     { check_SP();
  9294.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9295.       force_output(get_synonym_stream(symbol));
  9296.     }}
  9297.  
  9298. # UP: Löscht den wartenden Output eines Synonym-Stream.
  9299. # clear_output_synonym(stream);
  9300. # > stream: Synonym-Stream
  9301. # kann GC auslösen
  9302.   local void clear_output_synonym (object stream);
  9303.   local void clear_output_synonym(stream)
  9304.     var reg2 object stream;
  9305.     { check_SP();
  9306.      {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol;
  9307.       clear_output(get_synonym_stream(symbol));
  9308.     }}
  9309.  
  9310. # Liefert einen Synonym-Stream zu einem Symbol.
  9311. # make_synonym_stream(symbol)
  9312. # > symbol : Symbol
  9313. # < ergebnis : neuer Synonym-Stream
  9314. # kann GC auslösen
  9315.   local object make_synonym_stream (object symbol);
  9316.   local object make_synonym_stream(symbol)
  9317.     var reg2 object symbol;
  9318.     { pushSTACK(symbol); # Symbol retten
  9319.      {var reg1 object stream = # neuer Stream, alle Operationen erlaubt
  9320.         allocate_stream(strmflags_open_B,strmtype_synonym,strm_len+1);
  9321.       TheStream(stream)->strm_rd_by = P(rd_by_synonym);
  9322.       TheStream(stream)->strm_wr_by = P(wr_by_synonym);
  9323.       TheStream(stream)->strm_rd_ch = P(rd_ch_synonym);
  9324.       TheStream(stream)->strm_rd_ch_last = NIL;
  9325.       TheStream(stream)->strm_wr_ch = P(wr_ch_synonym);
  9326.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  9327.       #ifdef STRM_WR_SS
  9328.       TheStream(stream)->strm_wr_ss = P(wr_ss_synonym);
  9329.       #endif
  9330.       TheStream(stream)->strm_synonym_symbol = popSTACK();
  9331.       return stream;
  9332.     }}
  9333.  
  9334. LISPFUNN(make_synonym_stream,1)
  9335. # (MAKE-SYNONYM-STREAM symbol), CLTL S. 329
  9336.   { var reg1 object arg = popSTACK();
  9337.     if (!symbolp(arg))
  9338.       { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  9339.         pushSTACK(S(symbol)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  9340.         pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
  9341.         //: DEUTSCH "~: Argument muß ein Symbol sein, nicht ~"
  9342.         //: ENGLISH "~: argument should be a symbol, not ~"
  9343.         //: FRANCAIS "~ : L'argument doit être un symbole et non ~"
  9344.         fehler(type_error,GETTEXT("~: argument should be a symbol, not ~"));
  9345.       }
  9346.     value1 = make_synonym_stream(arg); mv_count=1;
  9347.   }
  9348.  
  9349. LISPFUNN(synonym_stream_p,1)
  9350. # (SYS::SYNONYM-STREAM-P stream) == (TYPEP stream 'SYNONYM-STREAM)
  9351.   { var reg1 object arg = popSTACK();
  9352.     value1 = (streamp(arg) && (TheStream(arg)->strmtype == strmtype_synonym)
  9353.               ? T
  9354.               : NIL
  9355.              );
  9356.     mv_count=1;
  9357.   }
  9358.  
  9359. LISPFUNN(synonym_stream_symbol,1)
  9360. # (SYNONYM-STREAM-SYMBOL stream), CLtL2 S. 507
  9361.   { var reg1 object stream = popSTACK();
  9362.     if (!streamp(stream)) { fehler_stream(stream); }
  9363.     if (!(TheStream(stream)->strmtype == strmtype_synonym))
  9364.       { fehler_streamtype(stream,S(synonym_stream)); }
  9365.     value1 = TheStream(stream)->strm_synonym_symbol; mv_count=1;
  9366.   }
  9367.  
  9368.  
  9369. # Broadcast-Stream
  9370. # ================
  9371.  
  9372. # Zusätzliche Komponenten:
  9373.   # define strm_broad_list  strm_other[0] # Liste von Streams
  9374.  
  9375. # WRITE-BYTE - Pseudofunktion für Broadcast-Streams:
  9376.   local void wr_by_broad (object stream, object obj);
  9377.   local void wr_by_broad(stream,obj)
  9378.     var reg2 object stream;
  9379.     var reg3 object obj;
  9380.     { check_SP(); check_STACK();
  9381.       pushSTACK(obj);
  9382.       { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams
  9383.         # obj auf jeden Stream aus der Liste ausgeben:
  9384.         while (consp(streamlist))
  9385.           { pushSTACK(Cdr(streamlist)); # restliche Streams
  9386.             write_byte(Car(streamlist),STACK_1); # obj ausgeben
  9387.             streamlist = popSTACK();
  9388.       }   }
  9389.       skipSTACK(1);
  9390.     }
  9391.  
  9392. # WRITE-CHAR - Pseudofunktion für Broadcast-Streams:
  9393.   local void wr_ch_broad (object* stream_, object obj);
  9394.   local void wr_ch_broad(stream_,obj)
  9395.     var reg3 object* stream_;
  9396.     var reg4 object obj;
  9397.     { check_SP(); check_STACK();
  9398.       pushSTACK(obj);
  9399.       pushSTACK(NIL); # dummy
  9400.       pushSTACK(TheStream(*stream_)->strm_broad_list); # Liste von Streams
  9401.       # obj auf jeden Stream aus der Liste ausgeben:
  9402.       while (mconsp(STACK_0))
  9403.         { # Stackaufbau: obj, dummy, streamlistr.
  9404.           STACK_1 = Car(STACK_0); # ein Stream aus der Liste
  9405.           write_char(&STACK_1,STACK_2); # obj ausgeben
  9406.           STACK_0 = Cdr(STACK_0);
  9407.         }
  9408.       skipSTACK(3);
  9409.     }
  9410.  
  9411. #ifdef STRM_WR_SS
  9412. # WRITE-CHAR - Pseudofunktion für Broadcast-Streams:
  9413.   local void wr_ss_broad (object* stream_, object string, uintL start, uintL len);
  9414.   local void wr_ss_broad(stream_,string,start,len)
  9415.     var reg1 object* stream_;
  9416.     var reg4 object string;
  9417.     var reg2 uintL start;
  9418.     var reg3 uintL len;
  9419.     { check_SP(); check_STACK();
  9420.       pushSTACK(string);
  9421.       pushSTACK(NIL); # dummy
  9422.       pushSTACK(TheStream(*stream_)->strm_broad_list); # Liste von Streams
  9423.       # string auf jeden Stream aus der Liste ausgeben:
  9424.       while (mconsp(STACK_0))
  9425.         { # Stackaufbau: string, dummy, streamlistr.
  9426.           STACK_1 = Car(STACK_0); # ein Stream aus der Liste
  9427.           wr_ss(STACK_1)(&STACK_1,STACK_2,start,len); # string-Stück ausgeben
  9428.           STACK_0 = Cdr(STACK_0);
  9429.         }
  9430.       skipSTACK(3);
  9431.       # Line-Position aktualisieren kann hier entfallen.
  9432.     }
  9433. #endif
  9434.  
  9435. # UP: Bringt den wartenden Output eines Broadcast-Stream ans Ziel.
  9436. # finish_output_broad(stream);
  9437. # > stream: Broadcast-Stream
  9438. # kann GC auslösen
  9439.   local void finish_output_broad (object stream);
  9440.   local void finish_output_broad(stream)
  9441.     var reg2 object stream;
  9442.     { check_SP(); check_STACK();
  9443.       { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams
  9444.         # Jeden Stream aus der Liste einzeln behandeln:
  9445.         while (consp(streamlist))
  9446.           { pushSTACK(Cdr(streamlist)); # restliche Streams
  9447.             finish_output(Car(streamlist));
  9448.             streamlist = popSTACK();
  9449.       }   }
  9450.     }
  9451.  
  9452. # UP: Bringt den wartenden Output eines Broadcast-Stream ans Ziel.
  9453. # force_output_broad(stream);
  9454. # > stream: Broadcast-Stream
  9455. # kann GC auslösen
  9456.   local void force_output_broad (object stream);
  9457.   local void force_output_broad(stream)
  9458.     var reg2 object stream;
  9459.     { check_SP(); check_STACK();
  9460.       { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams
  9461.         # Jeden Stream aus der Liste einzeln behandeln:
  9462.         while (consp(streamlist))
  9463.           { pushSTACK(Cdr(streamlist)); # restliche Streams
  9464.             force_output(Car(streamlist));
  9465.             streamlist = popSTACK();
  9466.       }   }
  9467.     }
  9468.  
  9469. # UP: Löscht den wartenden Output eines Broadcast-Stream.
  9470. # clear_output_broad(stream);
  9471. # > stream: Broadcast-Stream
  9472. # kann GC auslösen
  9473.   local void clear_output_broad (object stream);
  9474.   local void clear_output_broad(stream)
  9475.     var reg2 object stream;
  9476.     { check_SP(); check_STACK();
  9477.       { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams
  9478.         # Jeden Stream aus der Liste einzeln behandeln:
  9479.         while (consp(streamlist))
  9480.           { pushSTACK(Cdr(streamlist)); # restliche Streams
  9481.             clear_output(Car(streamlist));
  9482.             streamlist = popSTACK();
  9483.       }   }
  9484.     }
  9485.  
  9486. # Liefert einen Broadcast-Stream zu einer Streamliste.
  9487. # make_broadcast_stream(list)
  9488. # > list : Liste von Streams
  9489. # < ergebnis : Broadcast-Stream
  9490. # Die Liste list wird dabei zerstört.
  9491. # kann GC auslösen
  9492.   local object make_broadcast_stream (object list);
  9493.   local object make_broadcast_stream(list)
  9494.     var reg2 object list;
  9495.     { pushSTACK(list); # list retten
  9496.      {var reg1 object stream = # neuer Stream, nur WRITEs erlaubt
  9497.         allocate_stream(strmflags_wr_B,strmtype_broad,strm_len+1);
  9498.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  9499.       TheStream(stream)->strm_wr_by = P(wr_by_broad);
  9500.       TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  9501.       TheStream(stream)->strm_rd_ch_last = NIL;
  9502.       TheStream(stream)->strm_wr_ch = P(wr_ch_broad);
  9503.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  9504.       #ifdef STRM_WR_SS
  9505.       TheStream(stream)->strm_wr_ss = P(wr_ss_broad);
  9506.       #endif
  9507.       TheStream(stream)->strm_broad_list = popSTACK();
  9508.       return stream;
  9509.     }}
  9510.  
  9511. # Liefert einen Broadcast-Stream zum Stream stream.
  9512. # make_broadcast1_stream(stream)
  9513. # > stream : Stream
  9514. # < ergebnis : Broadcast-Stream
  9515. # kann GC auslösen
  9516.   global object make_broadcast1_stream (object stream);
  9517.   global object make_broadcast1_stream(oldstream)
  9518.     var reg3 object oldstream;
  9519.     {  pushSTACK(oldstream);
  9520.        # oldstream in eine einelementige Liste packen:
  9521.      { var reg2 object new_cons = allocate_cons();
  9522.        Car(new_cons) = STACK_0;
  9523.       {var reg1 object stream = make_broadcast_stream(new_cons); # neuer Stream
  9524.        oldstream = popSTACK();
  9525.        # Line-Position übernehmen:
  9526.        TheStream(stream)->strm_wr_ch_lpos = TheStream(oldstream)->strm_wr_ch_lpos;
  9527.        return stream;
  9528.     }}}
  9529.  
  9530. LISPFUN(make_broadcast_stream,0,0,rest,nokey,0,NIL)
  9531. # (MAKE-BROADCAST-STREAM {stream}), CLTL S. 329
  9532.   { # Überprüfen, ob alle Argumente Streams sind:
  9533.     test_stream_args(rest_args_pointer,argcount);
  9534.     # zu einer Liste zusammenfassen:
  9535.    {var reg1 object list = listof(argcount);
  9536.     # Stream bauen:
  9537.     value1 = make_broadcast_stream(list); mv_count=1;
  9538.   }}
  9539.  
  9540. LISPFUNN(broadcast_stream_p,1)
  9541. # (SYS::BROADCAST-STREAM-P stream) == (TYPEP stream 'BROADCAST-STREAM)
  9542.   { var reg1 object arg = popSTACK();
  9543.     value1 = (streamp(arg) && (TheStream(arg)->strmtype == strmtype_broad)
  9544.               ? T
  9545.               : NIL
  9546.              );
  9547.     mv_count=1;
  9548.   }
  9549.  
  9550. LISPFUNN(broadcast_stream_streams,1)
  9551. # (BROADCAST-STREAM-STREAMS stream), CLtL2 S. 507
  9552.   { var reg1 object stream = popSTACK();
  9553.     if (!streamp(stream)) { fehler_stream(stream); }
  9554.     if (!(TheStream(stream)->strmtype == strmtype_broad))
  9555.       { fehler_streamtype(stream,S(broadcast_stream)); }
  9556.     # Liste der Streams sicherheitshalber kopieren
  9557.     value1 = copy_list(TheStream(stream)->strm_broad_list); mv_count=1;
  9558.   }
  9559.  
  9560.  
  9561. # Concatenated-Stream
  9562. # ===================
  9563.  
  9564. # Zusätzliche Komponenten:
  9565.   # define strm_concat_list   strm_other[0]  # Liste von Streams
  9566.   #define strm_concat_list2  strm_other[1]  # Liste der verbrauchten Streams
  9567.  
  9568. # READ-BYTE - Pseudofunktion für Concatenated-Streams:
  9569.   local object rd_by_concat (object stream);
  9570.   local object rd_by_concat(stream)
  9571.     var reg3 object stream;
  9572.     { check_SP(); check_STACK();
  9573.       pushSTACK(stream);
  9574.      {var reg1 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams
  9575.       var reg2 object ergebnis;
  9576.       while (consp(streamlist))
  9577.         { ergebnis = read_byte(Car(streamlist)); # Integer lesen
  9578.           if (!eq(ergebnis,eof_value)) { goto OK; } # nicht EOF ?
  9579.           # EOF erreicht -> verbrauchten Stream aus der Liste nehmen
  9580.           # und in die zweite Liste stecken:
  9581.           stream = STACK_0;
  9582.          {var reg4 object first_cons = TheStream(stream)->strm_concat_list;
  9583.           streamlist = Cdr(first_cons);
  9584.           Cdr(first_cons) = TheStream(stream)->strm_concat_list2;
  9585.           TheStream(stream)->strm_concat_list2 = first_cons;
  9586.           TheStream(stream)->strm_concat_list = streamlist;
  9587.         }}
  9588.       # alle Streams verbraucht -> liefere EOF:
  9589.       ergebnis = eof_value;
  9590.       OK: # ergebnis fertig
  9591.       skipSTACK(1);
  9592.       return ergebnis;
  9593.     }}
  9594.  
  9595. # READ-CHAR - Pseudofunktion für Concatenated-Streams:
  9596.   local object rd_ch_concat (object* stream_);
  9597.   local object rd_ch_concat(stream_)
  9598.     var reg3 object* stream_;
  9599.     { check_SP(); check_STACK();
  9600.      {var reg1 object streamlist = TheStream(*stream_)->strm_concat_list; # Liste von Streams
  9601.       while (consp(streamlist))
  9602.         { pushSTACK(Car(streamlist));
  9603.          {var reg2 object ergebnis = read_char(&STACK_0); # Character lesen
  9604.           skipSTACK(1);
  9605.           if (!eq(ergebnis,eof_value)) { return ergebnis; }
  9606.           # EOF erreicht -> verbrauchten Stream aus der Liste nehmen
  9607.           # und in die zweite Liste stecken:
  9608.           {var reg2 object stream = *stream_;
  9609.            var reg4 object first_cons = TheStream(stream)->strm_concat_list;
  9610.            streamlist = Cdr(first_cons);
  9611.            Cdr(first_cons) = TheStream(stream)->strm_concat_list2;
  9612.            TheStream(stream)->strm_concat_list2 = first_cons;
  9613.            TheStream(stream)->strm_concat_list = streamlist;
  9614.         }}}
  9615.       # alle Streams verbraucht -> liefere EOF:
  9616.       return eof_value;
  9617.     }}
  9618.  
  9619. # Stellt fest, ob ein Concatenated-Stream ein Zeichen verfügbar hat.
  9620. # listen_concat(stream)
  9621. # > stream : Concatenated-Stream
  9622. # < ergebnis:  0 falls Zeichen verfügbar,
  9623. #             -1 falls bei EOF angelangt,
  9624. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  9625. # kann GC auslösen
  9626.   local signean listen_concat (object stream);
  9627.   local signean listen_concat(stream)
  9628.     var reg3 object stream;
  9629.     { pushSTACK(stream);
  9630.      {var reg1 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams
  9631.       var reg2 signean ergebnis;
  9632.       while (consp(streamlist))
  9633.         { ergebnis = stream_listen(Car(streamlist));
  9634.           if (ergebnis>=0) { goto OK; } # nicht EOF ?
  9635.           # EOF erreicht -> verbrauchten Stream aus der Liste nehmen
  9636.           # und in die zweite Liste stecken:
  9637.           stream = STACK_0;
  9638.          {var reg4 object first_cons = TheStream(stream)->strm_concat_list;
  9639.           streamlist = Cdr(first_cons);
  9640.           Cdr(first_cons) = TheStream(stream)->strm_concat_list2;
  9641.           TheStream(stream)->strm_concat_list2 = first_cons;
  9642.           TheStream(stream)->strm_concat_list = streamlist;
  9643.         }}
  9644.       # alle Streams verbraucht -> liefere EOF:
  9645.       ergebnis = signean_minus;
  9646.       OK: # ergebnis fertig
  9647.       skipSTACK(1);
  9648.       return ergebnis;
  9649.     }}
  9650.  
  9651. # UP: Löscht bereits eingegebenen interaktiven Input von einem
  9652. # Concatenated-Stream.
  9653. # clear_input_concat(stream)
  9654. # > stream: Concatenated-Stream
  9655. # < ergebnis: TRUE falls Input gelöscht wurde
  9656. # kann GC auslösen
  9657.   local boolean clear_input_concat (object stream);
  9658.   local boolean clear_input_concat(stream)
  9659.     var reg3 object stream;
  9660.     { var reg2 boolean ergebnis = FALSE; # noch kein Input gelöscht
  9661.       # alle Streams einzeln behandeln:
  9662.       var reg1 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams
  9663.       while (consp(streamlist))
  9664.         { pushSTACK(Cdr(streamlist)); # restliche Streamliste
  9665.           ergebnis |= clear_input(Car(streamlist)); # allen Input des Teilstreams löschen
  9666.           streamlist = popSTACK();
  9667.         }
  9668.       return ergebnis;
  9669.     }
  9670.  
  9671. # Liefert einen Concatenated-Stream zu einer Streamliste.
  9672. # make_concatenated_stream(list)
  9673. # > list : Liste von Streams
  9674. # < ergebnis : Concatenated-Stream
  9675. # Die Liste list wird dabei zerstört.
  9676. # kann GC auslösen
  9677.   local object make_concatenated_stream (object list);
  9678.   local object make_concatenated_stream(list)
  9679.     var reg2 object list;
  9680.     { pushSTACK(list); # list retten
  9681.      {var reg1 object stream = # neuer Stream, nur READs erlaubt
  9682.         allocate_stream(strmflags_rd_B,strmtype_concat,strm_len+2);
  9683.       TheStream(stream)->strm_rd_by = P(rd_by_concat);
  9684.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  9685.       TheStream(stream)->strm_rd_ch = P(rd_ch_concat);
  9686.       TheStream(stream)->strm_rd_ch_last = NIL;
  9687.       TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  9688.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  9689.       #ifdef STRM_WR_SS
  9690.       TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  9691.       #endif
  9692.       TheStream(stream)->strm_concat_list = popSTACK();
  9693.       TheStream(stream)->strm_concat_list2 = NIL;
  9694.       return stream;
  9695.     }}
  9696.  
  9697. LISPFUN(make_concatenated_stream,0,0,rest,nokey,0,NIL)
  9698. # (MAKE-CONCATENATED-STREAM {stream}), CLTL S. 329
  9699.   { # Überprüfen, ob alle Argumente Streams sind:
  9700.     test_stream_args(rest_args_pointer,argcount);
  9701.     # zu einer Liste zusammenfassen:
  9702.    {var reg1 object list = listof(argcount);
  9703.     # Stream bauen:
  9704.     value1 = make_concatenated_stream(list); mv_count=1;
  9705.   }}
  9706.  
  9707. LISPFUNN(concatenated_stream_p,1)
  9708. # (SYS::CONCATENATED-STREAM-P stream) == (TYPEP stream 'CONCATENATED-STREAM)
  9709.   { var reg1 object arg = popSTACK();
  9710.     value1 = (streamp(arg) && (TheStream(arg)->strmtype == strmtype_concat)
  9711.               ? T
  9712.               : NIL
  9713.              );
  9714.     mv_count=1;
  9715.   }
  9716.  
  9717. LISPFUNN(concatenated_stream_streams,1)
  9718. # (CONCATENATED-STREAM-STREAMS stream), CLtL2 S. 507
  9719.   { var reg1 object stream = popSTACK();
  9720.     if (!streamp(stream)) { fehler_stream(stream); }
  9721.     if (!(TheStream(stream)->strmtype == strmtype_concat))
  9722.       { fehler_streamtype(stream,S(concatenated_stream)); }
  9723.     # Liste der Streams sicherheitshalber kopieren:
  9724.     # (revappend list2 (copy-list list))
  9725.     pushSTACK(TheStream(stream)->strm_concat_list);
  9726.     pushSTACK(copy_list(TheStream(stream)->strm_concat_list2));
  9727.     funcall(L(revappend),2);
  9728.   }
  9729.  
  9730.  
  9731. # Two-Way-Stream, Echo-Stream
  9732. # ===========================
  9733.  
  9734. # Zusätzliche Komponenten:
  9735.   #define strm_twoway_input   strm_other[0]  # Stream für Input
  9736.   #define strm_twoway_output  strm_other[1]  # Stream für Output
  9737.  
  9738. # WRITE-BYTE - Pseudofunktion für Two-Way- und Echo-Streams:
  9739.   local void wr_by_twoway (object stream, object obj);
  9740.   local void wr_by_twoway(stream,obj)
  9741.     var reg1 object stream;
  9742.     var reg2 object obj;
  9743.     { check_SP();
  9744.       write_byte(TheStream(stream)->strm_twoway_output,obj);
  9745.     }
  9746.  
  9747. # WRITE-CHAR - Pseudofunktion für Two-Way- und Echo-Streams:
  9748.   local void wr_ch_twoway (object* stream_, object obj);
  9749.   local void wr_ch_twoway(stream_,obj)
  9750.     var reg1 object* stream_;
  9751.     var reg2 object obj;
  9752.     { check_SP(); check_STACK();
  9753.       pushSTACK(TheStream(*stream_)->strm_twoway_output);
  9754.       write_char(&STACK_0,obj);
  9755.       skipSTACK(1);
  9756.     }
  9757.  
  9758. #ifdef STRM_WR_SS
  9759. # WRITE-SIMPLE-STRING - Pseudofunktion für Two-Way- und Echo-Streams:
  9760.   local void wr_ss_twoway (object* stream_, object string, uintL start, uintL len);
  9761.   local void wr_ss_twoway(stream_,string,start,len)
  9762.     var reg1 object* stream_;
  9763.     var reg2 object string;
  9764.     var reg3 uintL start;
  9765.     var reg4 uintL len;
  9766.     { check_SP(); check_STACK();
  9767.       pushSTACK(TheStream(*stream_)->strm_twoway_output);
  9768.       wr_ss(STACK_0)(&STACK_0,string,start,len);
  9769.       skipSTACK(1);
  9770.       # Line-Position aktualisieren kann hier entfallen.
  9771.     }
  9772. #endif
  9773.  
  9774. # Stellt fest, ob ein Two-Way- oder Echo-Stream ein Zeichen verfügbar hat.
  9775. # listen_twoway(stream)
  9776. # > stream : Two-Way- oder Echo-Stream
  9777. # < ergebnis:  0 falls Zeichen verfügbar,
  9778. #             -1 falls bei EOF angelangt,
  9779. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  9780. # kann GC auslösen
  9781.   local signean listen_twoway (object stream);
  9782.   local signean listen_twoway(stream)
  9783.     var reg1 object stream;
  9784.     { check_SP();
  9785.       return stream_listen(TheStream(stream)->strm_twoway_input);
  9786.     }
  9787.  
  9788. # UP: Löscht bereits eingegebenen interaktiven Input von einem Two-Way-
  9789. # oder Echo-Stream.
  9790. # clear_input_twoway(stream)
  9791. # > stream: Two-Way- oder Echo-Stream
  9792. # < ergebnis: TRUE falls Input gelöscht wurde
  9793. # kann GC auslösen
  9794.   local boolean clear_input_twoway (object stream);
  9795.   local boolean clear_input_twoway(stream)
  9796.     var reg1 object stream;
  9797.     { check_SP();
  9798.       return clear_input(TheStream(stream)->strm_twoway_input);
  9799.     }
  9800.  
  9801. # UP: Bringt den wartenden Output eines Two-Way- oder Echo-Stream ans Ziel.
  9802. # finish_output_twoway(stream);
  9803. # > stream: Two-Way- oder Echo-Stream
  9804. # kann GC auslösen
  9805.   local void finish_output_twoway (object stream);
  9806.   local void finish_output_twoway(stream)
  9807.     var reg1 object stream;
  9808.     { check_SP();
  9809.       finish_output(TheStream(stream)->strm_twoway_output);
  9810.     }
  9811.  
  9812. # UP: Bringt den wartenden Output eines Two-Way- oder Echo-Stream ans Ziel.
  9813. # force_output_twoway(stream);
  9814. # > stream: Two-Way- oder Echo-Stream
  9815. # kann GC auslösen
  9816.   local void force_output_twoway (object stream);
  9817.   local void force_output_twoway(stream)
  9818.     var reg1 object stream;
  9819.     { check_SP();
  9820.       force_output(TheStream(stream)->strm_twoway_output);
  9821.     }
  9822.  
  9823. # UP: Löscht den wartenden Output eines Two-Way- oder Echo-Stream.
  9824. # clear_output_twoway(stream);
  9825. # > stream: Two-Way- oder Echo-Stream
  9826. # kann GC auslösen
  9827.   local void clear_output_twoway (object stream);
  9828.   local void clear_output_twoway(stream)
  9829.     var reg1 object stream;
  9830.     { check_SP();
  9831.       clear_output(TheStream(stream)->strm_twoway_output);
  9832.     }
  9833.  
  9834.  
  9835. # Two-Way-Stream
  9836. # ==============
  9837.  
  9838. # READ-BYTE - Pseudofunktion für Two-Way-Streams:
  9839.   local object rd_by_twoway (object stream);
  9840.   local object rd_by_twoway(stream)
  9841.     var reg1 object stream;
  9842.     { check_SP();
  9843.       return read_byte(TheStream(stream)->strm_twoway_input);
  9844.     }
  9845.  
  9846. # READ-CHAR - Pseudofunktion für Two-Way-Streams:
  9847.   local object rd_ch_twoway (object* stream_);
  9848.   local object rd_ch_twoway(stream_)
  9849.     var reg1 object* stream_;
  9850.     { check_SP(); check_STACK();
  9851.       pushSTACK(TheStream(*stream_)->strm_twoway_input);
  9852.      {var reg2 object ergebnis = read_char(&STACK_0);
  9853.       skipSTACK(1);
  9854.       return ergebnis;
  9855.     }}
  9856.  
  9857. # Liefert einen Two-Way-Stream zu einem Input-Stream und einem Output-Stream.
  9858. # make_twoway_stream(input_stream,output_stream)
  9859. # > input_stream : Input-Stream
  9860. # > output_stream : Output-Stream
  9861. # < ergebnis : Two-Way-Stream
  9862. # kann GC auslösen
  9863.   global object make_twoway_stream (object input_stream, object output_stream);
  9864.   global object make_twoway_stream(input_stream,output_stream)
  9865.     var reg2 object input_stream;
  9866.     var reg2 object output_stream;
  9867.     { pushSTACK(input_stream); pushSTACK(output_stream); # Streams retten
  9868.      {var reg1 object stream = # neuer Stream, alle Operationen erlaubt
  9869.         allocate_stream(strmflags_open_B,strmtype_twoway,strm_len+2);
  9870.       TheStream(stream)->strm_rd_by = P(rd_by_twoway);
  9871.       TheStream(stream)->strm_wr_by = P(wr_by_twoway);
  9872.       TheStream(stream)->strm_rd_ch = P(rd_ch_twoway);
  9873.       TheStream(stream)->strm_rd_ch_last = NIL;
  9874.       TheStream(stream)->strm_wr_ch = P(wr_ch_twoway);
  9875.       output_stream = popSTACK(); input_stream = popSTACK(); # Streams zurück
  9876.       TheStream(stream)->strm_wr_ch_lpos = TheStream(output_stream)->strm_wr_ch_lpos;
  9877.       #ifdef STRM_WR_SS
  9878.       TheStream(stream)->strm_wr_ss = P(wr_ss_twoway);
  9879.       #endif
  9880.       TheStream(stream)->strm_twoway_input = input_stream;
  9881.       TheStream(stream)->strm_twoway_output = output_stream;
  9882.       return stream;
  9883.     }}
  9884.  
  9885. LISPFUNN(make_two_way_stream,2)
  9886. # (MAKE-TWO-WAY-STREAM input-stream output-stream), CLTL S. 329
  9887.   { # Überprüfen, ob beides Streams sind:
  9888.     test_stream_args(args_end_pointer STACKop 2, 2);
  9889.    {var reg2 object output_stream = popSTACK();
  9890.     var reg1 object input_stream = popSTACK();
  9891.     # Stream bauen:
  9892.     value1 = make_twoway_stream(input_stream,output_stream); mv_count=1;
  9893.   }}
  9894.  
  9895. LISPFUNN(two_way_stream_p,1)
  9896. # (SYS::TWO-WAY-STREAM-P stream) == (TYPEP stream 'TWO-WAY-STREAM)
  9897.   { var reg1 object arg = popSTACK();
  9898.     value1 = (streamp(arg) && (TheStream(arg)->strmtype == strmtype_twoway)
  9899.               ? T
  9900.               : NIL
  9901.              );
  9902.     mv_count=1;
  9903.   }
  9904.  
  9905. LISPFUNN(two_way_stream_input_stream,1)
  9906. # (TWO-WAY-STREAM-INPUT-STREAM stream), CLtL2 S. 507
  9907.   { var reg1 object stream = popSTACK();
  9908.     if (!streamp(stream)) { fehler_stream(stream); }
  9909.     if (!(TheStream(stream)->strmtype == strmtype_twoway))
  9910.       { fehler_streamtype(stream,S(two_way_stream)); }
  9911.     value1 = TheStream(stream)->strm_twoway_input; mv_count=1;
  9912.   }
  9913.  
  9914. LISPFUNN(two_way_stream_output_stream,1)
  9915. # (TWO-WAY-STREAM-OUTPUT-STREAM stream), CLtL2 S. 507
  9916.   { var reg1 object stream = popSTACK();
  9917.     if (!streamp(stream)) { fehler_stream(stream); }
  9918.     if (!(TheStream(stream)->strmtype == strmtype_twoway))
  9919.       { fehler_streamtype(stream,S(two_way_stream)); }
  9920.     value1 = TheStream(stream)->strm_twoway_output; mv_count=1;
  9921.   }
  9922.  
  9923.  
  9924. # Echo-Stream
  9925. # ===========
  9926.  
  9927. # READ-BYTE - Pseudofunktion für Echo-Streams:
  9928.   local object rd_by_echo (object stream);
  9929.   local object rd_by_echo(stream)
  9930.     var reg1 object stream;
  9931.     { check_SP(); check_STACK();
  9932.       pushSTACK(stream);
  9933.      {var reg1 object obj = read_byte(TheStream(stream)->strm_twoway_input);
  9934.       stream = popSTACK();
  9935.       if (!eq(obj,eof_value))
  9936.         { pushSTACK(obj);
  9937.           write_byte(TheStream(stream)->strm_twoway_output,obj);
  9938.           obj = popSTACK();
  9939.         }
  9940.       return obj;
  9941.     }}
  9942.  
  9943. # READ-CHAR - Pseudofunktion für Echo-Streams:
  9944.   local object rd_ch_echo (object* stream_);
  9945.   local object rd_ch_echo(stream_)
  9946.     var reg1 object* stream_;
  9947.     { check_SP(); check_STACK();
  9948.       pushSTACK(TheStream(*stream_)->strm_twoway_input);
  9949.      {var reg2 object obj = read_char(&STACK_0);
  9950.       if (!eq(obj,eof_value))
  9951.         { STACK_0 = TheStream(*stream_)->strm_twoway_output;
  9952.           pushSTACK(obj);
  9953.           write_char(&STACK_1,obj);
  9954.           obj = popSTACK();
  9955.         }
  9956.       skipSTACK(1);
  9957.       return obj;
  9958.     }}
  9959.  
  9960. # Liefert einen Echo-Stream zu einem Input-Stream und einem Output-Stream.
  9961. # make_echo_stream(input_stream,output_stream)
  9962. # > input_stream : Input-Stream
  9963. # > output_stream : Output-Stream
  9964. # < ergebnis : Echo-Stream
  9965. # kann GC auslösen
  9966.   local object make_echo_stream (object input_stream, object output_stream);
  9967.   local object make_echo_stream(input_stream,output_stream)
  9968.     var reg3 object input_stream;
  9969.     var reg2 object output_stream;
  9970.     { pushSTACK(input_stream); pushSTACK(output_stream); # Streams retten
  9971.      {var reg4 uintB flags = strmflags_open_B
  9972.         #ifdef IMMUTABLE
  9973.         | (TheStream(input_stream)->strmflags & strmflags_immut_B)
  9974.         #endif
  9975.         ;
  9976.       var reg1 object stream = # neuer Stream, alle Operationen erlaubt
  9977.         allocate_stream(flags,strmtype_echo,strm_len+2);
  9978.       TheStream(stream)->strm_rd_by = P(rd_by_echo);
  9979.       TheStream(stream)->strm_wr_by = P(wr_by_twoway);
  9980.       TheStream(stream)->strm_rd_ch = P(rd_ch_echo);
  9981.       TheStream(stream)->strm_rd_ch_last = NIL;
  9982.       TheStream(stream)->strm_wr_ch = P(wr_ch_twoway);
  9983.       output_stream = popSTACK(); input_stream = popSTACK(); # Streams zurück
  9984.       TheStream(stream)->strm_wr_ch_lpos = TheStream(output_stream)->strm_wr_ch_lpos;
  9985.       #ifdef STRM_WR_SS
  9986.       TheStream(stream)->strm_wr_ss = P(wr_ss_twoway);
  9987.       #endif
  9988.       TheStream(stream)->strm_twoway_input = input_stream;
  9989.       TheStream(stream)->strm_twoway_output = output_stream;
  9990.       return stream;
  9991.     }}
  9992.  
  9993. LISPFUNN(make_echo_stream,2)
  9994. # (MAKE-ECHO-STREAM input-stream output-stream), CLTL S. 330
  9995.   { # Überprüfen, ob beides Streams sind:
  9996.     test_stream_args(args_end_pointer STACKop 2, 2);
  9997.    {var reg2 object output_stream = popSTACK();
  9998.     var reg1 object input_stream = popSTACK();
  9999.     # Stream bauen:
  10000.     value1 = make_echo_stream(input_stream,output_stream); mv_count=1;
  10001.   }}
  10002.  
  10003. LISPFUNN(echo_stream_p,1)
  10004. # (SYS::ECHO-STREAM-P stream) == (TYPEP stream 'ECHO-STREAM)
  10005.   { var reg1 object arg = popSTACK();
  10006.     value1 = (streamp(arg) && (TheStream(arg)->strmtype == strmtype_echo)
  10007.               ? T
  10008.               : NIL
  10009.              );
  10010.     mv_count=1;
  10011.   }
  10012.  
  10013. LISPFUNN(echo_stream_input_stream,1)
  10014. # (ECHO-STREAM-INPUT-STREAM stream), CLtL2 S. 507
  10015.   { var reg1 object stream = popSTACK();
  10016.     if (!streamp(stream)) { fehler_stream(stream); }
  10017.     if (!(TheStream(stream)->strmtype == strmtype_echo))
  10018.       { fehler_streamtype(stream,S(echo_stream)); }
  10019.     value1 = TheStream(stream)->strm_twoway_input; mv_count=1;
  10020.   }
  10021.  
  10022. LISPFUNN(echo_stream_output_stream,1)
  10023. # (ECHO-STREAM-OUTPUT-STREAM stream), CLtL2 S. 507
  10024.   { var reg1 object stream = popSTACK();
  10025.     if (!streamp(stream)) { fehler_stream(stream); }
  10026.     if (!(TheStream(stream)->strmtype == strmtype_echo))
  10027.       { fehler_streamtype(stream,S(echo_stream)); }
  10028.     value1 = TheStream(stream)->strm_twoway_output; mv_count=1;
  10029.   }
  10030.  
  10031.  
  10032. # String-Input-Stream
  10033. # ===================
  10034.  
  10035. # Zusätzliche Komponenten:
  10036.   #define strm_str_in_string    strm_other[0]  # String für Input
  10037.   #define strm_str_in_index     strm_other[1]  # Index in den String (Fixnum >=0)
  10038.   #define strm_str_in_endindex  strm_other[2]  # Endindex (Fixnum >= index >=0)
  10039.  
  10040. # Fehlermeldung, wenn index >= length(string):
  10041. # fehler_str_in_adjusted(stream);
  10042. # > stream: problematischer String-Input-Stream
  10043.   nonreturning_function(local, fehler_str_in_adjusted, (object stream));
  10044.   local void fehler_str_in_adjusted(stream)
  10045.     var reg1 object stream;
  10046.     { pushSTACK(TheStream(stream)->strm_str_in_string);
  10047.       pushSTACK(stream);
  10048.       //: DEUTSCH "~ hinterm Stringende angelangt, weil String ~ adjustiert wurde."
  10049.       //: ENGLISH "~ is beyond the end because the string ~ has been adjusted"
  10050.       //: FRANCAIS "~ est arrivé après la fin de la chaîne, parce que la chaîne ~ a été ajustée."
  10051.       fehler(error,GETTEXT("~ is beyond the end because the string ~ has been adjusted"));
  10052.     }
  10053.  
  10054. # READ-CHAR - Pseudofunktion für String-Input-Streams:
  10055.   local object rd_ch_str_in (object* stream_);
  10056.   local object rd_ch_str_in(stream_)
  10057.     var reg4 object* stream_;
  10058.     { var reg1 object stream = *stream_;
  10059.       var reg2 uintL index = posfixnum_to_L(TheStream(stream)->strm_str_in_index); # Index
  10060.       var reg4 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_str_in_endindex);
  10061.       if (index >= endindex)
  10062.         { return eof_value; } # EOF erreicht
  10063.         else
  10064.         # index < eofindex
  10065.         { var uintL len;
  10066.           var reg3 uintB* charptr = unpack_string(TheStream(stream)->strm_str_in_string,&len);
  10067.           # Ab charptr kommen len Zeichen.
  10068.           if (index >= len) # Index zu groß ?
  10069.             { fehler_str_in_adjusted(stream); }
  10070.          {var reg1 object ch = code_char(charptr[index]); # Zeichen aus dem String holen
  10071.           # Index erhöhen:
  10072.           TheStream(stream)->strm_str_in_index = fixnum_inc(TheStream(stream)->strm_str_in_index,1);
  10073.           return ch;
  10074.         }}
  10075.     }
  10076.  
  10077. # Schließt einen String-Input-Stream.
  10078. # close_str_in(stream);
  10079. # > stream : String-Input-Stream
  10080.   local void close_str_in (object stream);
  10081.   local void close_str_in(stream)
  10082.     var reg1 object stream;
  10083.     { TheStream(stream)->strm_str_in_string = NIL; } # String := NIL
  10084.  
  10085. # Stellt fest, ob ein String-Input-Stream ein Zeichen verfügbar hat.
  10086. # listen_str_in(stream)
  10087. # > stream : String-Input-Stream
  10088. # < ergebnis:  0 falls Zeichen verfügbar,
  10089. #             -1 falls bei EOF angelangt,
  10090. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  10091. # kann GC auslösen
  10092.   local signean listen_str_in (object stream);
  10093.   local signean listen_str_in(stream)
  10094.     var reg1 object stream;
  10095.     { var reg2 uintL index = posfixnum_to_L(TheStream(stream)->strm_str_in_index); # Index
  10096.       var reg3 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_str_in_endindex);
  10097.       if (index >= endindex)
  10098.         { return signean_minus; } # EOF erreicht
  10099.         else
  10100.         { return signean_null; }
  10101.     }
  10102.  
  10103. LISPFUN(make_string_input_stream,1,2,norest,nokey,0,NIL)
  10104. # (MAKE-STRING-INPUT-STREAM string [start [end]]), CLTL S. 330
  10105.   { # String holen und Grenzen überprüfen:
  10106.     var object string;
  10107.     var uintL start;
  10108.     var uintL len;
  10109.     test_string_limits(&string,&start,&len);
  10110.    {var reg2 object start_arg = fixnum(start); # start-Argument (Fixnum >=0)
  10111.     var reg3 object end_arg = fixnum_inc(start_arg,len); # end-Argument (Fixnum >=0)
  10112.     pushSTACK(string); # String retten
  10113.     { var reg1 object stream = # neuer Stream, nur READ-CHAR erlaubt
  10114.         allocate_stream(strmflags_rd_ch_B,strmtype_str_in,strm_len+3);
  10115.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  10116.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10117.       TheStream(stream)->strm_rd_ch = P(rd_ch_str_in);
  10118.       TheStream(stream)->strm_rd_ch_last = NIL;
  10119.       TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  10120.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  10121.       #ifdef STRM_WR_SS
  10122.       TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  10123.       #endif
  10124.       TheStream(stream)->strm_str_in_string = popSTACK();
  10125.       TheStream(stream)->strm_str_in_index = start_arg; # Index := start-Argument
  10126.       TheStream(stream)->strm_str_in_endindex = end_arg; # Endindex := end-Argument
  10127.       value1 = stream; mv_count=1; # stream als Wert
  10128.   }}}
  10129.  
  10130. LISPFUNN(string_input_stream_index,1)
  10131. # (SYSTEM::STRING-INPUT-STREAM-INDEX string-input-stream) liefert den Index
  10132.   { var reg1 object stream = popSTACK(); # Argument
  10133.     # muß ein String-Input-Stream sein:
  10134.     if (!(streamp(stream) && (TheStream(stream)->strmtype == strmtype_str_in)))
  10135.       { pushSTACK(stream);
  10136.         pushSTACK(TheSubr(subr_self)->name);
  10137.         //: DEUTSCH "~: ~ ist kein String-Input-Stream."
  10138.         //: ENGLISH "~: ~ is not a string input stream"
  10139.         //: FRANCAIS "~ : ~ n'est pas un «stream» lisant d'une chaîne."
  10140.         fehler(error,GETTEXT("~: ~ is not a string input stream"));
  10141.       }
  10142.    {var reg2 object index = TheStream(stream)->strm_str_in_index;
  10143.     # Falls ein Character mit UNREAD-CHAR zurückgeschoben wurde,
  10144.     # verwende (1- index), ein Fixnum >=0, als Wert:
  10145.     if (mposfixnump(TheStream(stream)->strm_rd_ch_last))
  10146.       { index = fixnum_inc(index,-1); }
  10147.     value1 = index; mv_count=1;
  10148.   }}
  10149.  
  10150.  
  10151. # String-Output-Stream
  10152. # ====================
  10153.  
  10154. # Zusätzliche Komponenten:
  10155.   #define strm_str_out_string  strm_other[0]  # Semi-Simple-String für Output
  10156.  
  10157. # WRITE-CHAR - Pseudofunktion für String-Output-Streams:
  10158.   local void wr_ch_str_out (object* stream_, object ch);
  10159.   local void wr_ch_str_out(stream_,ch)
  10160.     var reg3 object* stream_;
  10161.     var reg1 object ch;
  10162.     { var reg2 object stream = *stream_;
  10163.       # obj sollte String-Char sein:
  10164.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); }
  10165.       # Character in den String schieben:
  10166.       ssstring_push_extend(TheStream(stream)->strm_str_out_string,char_code(ch));
  10167.     }
  10168.  
  10169. #ifdef STRM_WR_SS
  10170. # WRITE-SIMPLE-STRING - Pseudofunktion für String-Output-Streams:
  10171.   local void wr_ss_str_out (object* stream_, object string, uintL start, uintL len);
  10172.   local void wr_ss_str_out(stream_,srcstring,start,len)
  10173.     var reg8 object* stream_;
  10174.     var reg9 object srcstring;
  10175.     var reg10 uintL start;
  10176.     var reg6 uintL len;
  10177.     { if (len==0) return;
  10178.      {var reg4 object ssstring = TheStream(*stream_)->strm_str_out_string; # Semi-Simple-String
  10179.       var reg5 uintL old_len = TheArray(ssstring)->dims[1]; # jetzige Länge = Fill-Pointer
  10180.       if (old_len + len > TheArray(ssstring)->dims[0]) # passen keine len Bytes mehr hinein
  10181.         { pushSTACK(srcstring);
  10182.           ssstring = ssstring_extend(ssstring,old_len+len); # dann länger machen
  10183.           srcstring = popSTACK();
  10184.         }
  10185.       # Zeichen hineinschieben:
  10186.       {var reg1 uintB* srcptr = &TheSstring(srcstring)->data[start];
  10187.        var reg3 uintL count;
  10188.        {var reg2 uintB* ptr = &TheSstring(TheArray(ssstring)->data)->data[old_len];
  10189.         dotimespL(count,len, { *ptr++ = *srcptr++; } );
  10190.        }
  10191.        # und Fill-Pointer erhöhen:
  10192.        TheArray(ssstring)->dims[1] = old_len + len;
  10193.        wr_ss_lpos(*stream_,srcptr,len); # Line-Position aktualisieren
  10194.     }}}
  10195. #endif
  10196.  
  10197. # Liefert einen String-Output-Stream.
  10198. # make_string_output_stream()
  10199. # kann GC auslösen
  10200.   global object make_string_output_stream (void);
  10201.   global object make_string_output_stream()
  10202.     { # kleinen Semi-Simple-String der Länge 50 allozieren:
  10203.       pushSTACK(make_ssstring(50));
  10204.      {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt
  10205.         allocate_stream(strmflags_wr_ch_B,strmtype_str_out,strm_len+1);
  10206.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  10207.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10208.       TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  10209.       TheStream(stream)->strm_rd_ch_last = NIL;
  10210.       TheStream(stream)->strm_wr_ch = P(wr_ch_str_out);
  10211.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  10212.       #ifdef STRM_WR_SS
  10213.       TheStream(stream)->strm_wr_ss = P(wr_ss_str_out);
  10214.       #endif
  10215.       TheStream(stream)->strm_str_out_string = popSTACK(); # String eintragen
  10216.       return stream;
  10217.     }}
  10218.  
  10219. LISPFUN(make_string_output_stream,0,1,norest,nokey,0,NIL)
  10220. # (MAKE-STRING-OUTPUT-STREAM [line-position]), CLTL S. 330
  10221.   { # line-position überprüfen:
  10222.     if (eq(STACK_0,unbound))
  10223.       { STACK_0 = Fixnum_0; } # Defaultwert 0
  10224.       else
  10225.       # line-position angegeben, sollte ein Fixnum >=0 sein:
  10226.       { if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); } }
  10227.    {var reg1 object stream = make_string_output_stream(); # String-Output-Stream
  10228.     TheStream(stream)->strm_wr_ch_lpos = popSTACK(); # Line Position eintragen
  10229.     value1 = stream; mv_count=1; # stream als Wert
  10230.   }}
  10231.  
  10232. # UP: Liefert das von einem String-Output-Stream Angesammelte.
  10233. # get_output_stream_string(&stream)
  10234. # > stream: String-Output-Stream
  10235. # < stream: geleerter Stream
  10236. # < ergebnis: Angesammeltes, ein Simple-String
  10237. # kann GC auslösen
  10238.   global object get_output_stream_string (object* stream_);
  10239.   global object get_output_stream_string(stream_)
  10240.     var reg1 object* stream_;
  10241.     { var reg2 object string = TheStream(*stream_)->strm_str_out_string; # alter String
  10242.       string = coerce_ss(string); # in Simple-String umwandeln (erzwingt ein Kopieren)
  10243.       # alten String durch Fill-Pointer:=0 leeren:
  10244.       TheArray(TheStream(*stream_)->strm_str_out_string)->dims[1] = 0;
  10245.       return string;
  10246.     }
  10247.  
  10248. LISPFUNN(get_output_stream_string,1)
  10249. # (GET-OUTPUT-STREAM-STRING string-output-stream), CLTL S. 330
  10250.   { var reg1 object stream = STACK_0; # Argument
  10251.     # muß ein String-Output-Stream sein:
  10252.     if (!(streamp(stream) && (TheStream(stream)->strmtype == strmtype_str_out)))
  10253.       { # stream in STACK_0
  10254.         pushSTACK(TheSubr(subr_self)->name);
  10255.         //: DEUTSCH "~: ~ ist kein String-Output-Stream."
  10256.         //: ENGLISH "~: ~ is not a string output stream."
  10257.         //: FRANCAIS "~ : ~ n'est pas un «stream» écrivant dans une chaîne."
  10258.         fehler(error,GETTEXT("~: ~ is not a string output stream"));
  10259.       }
  10260.    {value1 = get_output_stream_string(&STACK_0); mv_count=1; # Angesammeltes als Wert
  10261.     skipSTACK(1);
  10262.   }}
  10263.  
  10264.  
  10265. # String-Push-Stream
  10266. # ==================
  10267.  
  10268. # Zusätzliche Komponenten:
  10269.   #define strm_str_push_string  strm_other[0]  # String mit Fill-Pointer für Output
  10270.  
  10271. # WRITE-CHAR - Pseudofunktion für String-Push-Streams:
  10272.   local void wr_ch_str_push (object* stream_, object ch);
  10273.   local void wr_ch_str_push(stream_,ch)
  10274.     var reg3 object* stream_;
  10275.     var reg1 object ch;
  10276.     { var reg2 object stream = *stream_;
  10277.       # ch sollte String-Char sein:
  10278.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); }
  10279.       # Character in den String schieben:
  10280.       pushSTACK(ch); pushSTACK(TheStream(stream)->strm_str_push_string);
  10281.       funcall(L(vector_push_extend),2); # (VECTOR-PUSH-EXTEND ch string)
  10282.     }
  10283.  
  10284. # (SYSTEM::MAKE-STRING-PUSH-STREAM string) liefert einen Stream, dessen
  10285. # WRITE-CHAR-Operation mit einem VECTOR-PUSH-EXTEND auf den gegebenen String
  10286. # äquivalent ist.
  10287. LISPFUNN(make_string_push_stream,1)
  10288.   { {var reg1 object arg = STACK_0; # Argument
  10289.      # muß ein String mit Fill-Pointer sein:
  10290.      if (!(stringp(arg) && array_has_fill_pointer_p(arg)))
  10291.        { # arg in STACK_0
  10292.          pushSTACK(S(with_output_to_string));
  10293.          //: DEUTSCH "~: Argument muß ein String mit Fill-Pointer sein, nicht ~"
  10294.          //: ENGLISH "~: argument ~ should be a string with fill pointer"
  10295.          //: FRANCAIS "~ : L'argument ~ doit être une chaîne munie d'un pointeur de remplissage."
  10296.          fehler(error,GETTEXT("~: argument ~ should be a string with fill pointer"));
  10297.     }  }
  10298.     {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt
  10299.        allocate_stream(strmflags_wr_ch_B,strmtype_str_push,strm_len+1);
  10300.      TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  10301.      TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10302.      TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  10303.      TheStream(stream)->strm_rd_ch_last = NIL;
  10304.      TheStream(stream)->strm_wr_ch = P(wr_ch_str_push);
  10305.      TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  10306.      #ifdef STRM_WR_SS
  10307.      TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  10308.      #endif
  10309.      TheStream(stream)->strm_str_push_string = popSTACK(); # String eintragen
  10310.      value1 = stream; mv_count=1; # stream als Wert
  10311.   } }
  10312.  
  10313.  
  10314. # String-Stream allgemein
  10315. # =======================
  10316.  
  10317. LISPFUNN(string_stream_p,1)
  10318. # (SYS::STRING-STREAM-P stream) == (TYPEP stream 'STRING-STREAM)
  10319.   { var reg1 object arg = popSTACK();
  10320.     if (streamp(arg))
  10321.       { switch (TheStream(arg)->strmtype)
  10322.           { case strmtype_str_in:   # String-Input-Stream
  10323.             case strmtype_str_out:  # String-Output-Stream
  10324.             case strmtype_str_push: # String-Push-Stream
  10325.               value1 = T; break;
  10326.             default:
  10327.               value1 = NIL; break;
  10328.       }   }
  10329.       else
  10330.       { value1 = NIL; }
  10331.     mv_count=1;
  10332.   }
  10333.  
  10334.  
  10335. # Pretty-Printer-Hilfs-Stream
  10336. # ===========================
  10337.  
  10338. # Zusätzliche Komponenten:
  10339.   # define strm_pphelp_strings  strm_other[0]   # Semi-Simple-Strings für Output
  10340.   # define strm_pphelp_modus    strm_other[1]   # Modus (NIL=Einzeiler, T=Mehrzeiler)
  10341.  
  10342. # WRITE-CHAR - Pseudofunktion für Pretty-Printer-Hilfs-Streams:
  10343.   local void wr_ch_pphelp (object* stream_, object ch);
  10344.   local void wr_ch_pphelp(stream_,ch)
  10345.     var reg4 object* stream_;
  10346.     var reg2 object ch;
  10347.     { var reg1 object stream = *stream_;
  10348.       # ch sollte String-Char sein:
  10349.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); }
  10350.      {var reg3 uintB c = char_code(ch); # Character
  10351.       # Bei NL: Ab jetzt  Modus := Mehrzeiler
  10352.       if (c == NL) { TheStream(stream)->strm_pphelp_modus = T; }
  10353.       # Character in den ersten String schieben:
  10354.       ssstring_push_extend(Car(TheStream(stream)->strm_pphelp_strings),c);
  10355.     }}
  10356.  
  10357. #ifdef STRM_WR_SS
  10358. # WRITE-SIMPLE-STRING - Pseudofunktion für Pretty-Printer-Hilfs-Streams:
  10359.   local void wr_ss_pphelp (object* stream_, object string, uintL start, uintL len);
  10360.   local void wr_ss_pphelp(stream_,srcstring,start,len)
  10361.     var reg8 object* stream_;
  10362.     var reg9 object srcstring;
  10363.     var reg10 uintL start;
  10364.     var reg6 uintL len;
  10365.     { if (len==0) return;
  10366.      {var reg4 object ssstring = Car(TheStream(*stream_)->strm_pphelp_strings); # Semi-Simple-String
  10367.       var reg5 uintL old_len = TheArray(ssstring)->dims[1]; # jetzige Länge = Fill-Pointer
  10368.       if (old_len + len > TheArray(ssstring)->dims[0]) # passen keine len Bytes mehr hinein
  10369.         { pushSTACK(srcstring);
  10370.           ssstring = ssstring_extend(ssstring,old_len+len); # dann länger machen
  10371.           srcstring = popSTACK();
  10372.         }
  10373.       # Zeichen hineinschieben:
  10374.       {var reg1 uintB* srcptr = &TheSstring(srcstring)->data[start];
  10375.        var reg3 uintL count;
  10376.        {var reg2 uintB* ptr = &TheSstring(TheArray(ssstring)->data)->data[old_len];
  10377.         dotimespL(count,len, { *ptr++ = *srcptr++; } );
  10378.        }
  10379.        # und Fill-Pointer erhöhen:
  10380.        TheArray(ssstring)->dims[1] = old_len + len;
  10381.        if (wr_ss_lpos(*stream_,srcptr,len)) # Line-Position aktualisieren
  10382.          { TheStream(*stream_)->strm_pphelp_modus = T; } # Nach NL: Modus := Mehrzeiler
  10383.     }}}
  10384. #endif
  10385.  
  10386. # UP: Liefert einen Pretty-Printer-Hilfs-Stream.
  10387. # make_pphelp_stream()
  10388. # kann GC auslösen
  10389.   global object make_pphelp_stream (void);
  10390.   global object make_pphelp_stream()
  10391.     { # kleinen Semi-Simple-String der Länge 50 allozieren:
  10392.       pushSTACK(make_ssstring(50));
  10393.       # einelementige Stringliste bauen:
  10394.      {var reg1 object new_cons = allocate_cons();
  10395.       Car(new_cons) = popSTACK();
  10396.       pushSTACK(new_cons);
  10397.      }
  10398.      {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt
  10399.         allocate_stream(strmflags_wr_ch_B,strmtype_pphelp,strm_len+2);
  10400.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  10401.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10402.       TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  10403.       TheStream(stream)->strm_rd_ch_last = NIL;
  10404.       TheStream(stream)->strm_wr_ch = P(wr_ch_pphelp);
  10405.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  10406.       #ifdef STRM_WR_SS
  10407.       TheStream(stream)->strm_wr_ss = P(wr_ss_pphelp);
  10408.       #endif
  10409.       TheStream(stream)->strm_pphelp_strings = popSTACK(); # String-Liste eintragen
  10410.       TheStream(stream)->strm_pphelp_modus = NIL; # Modus := Einzeiler
  10411.       return stream;
  10412.     }}
  10413.  
  10414.  
  10415. # Buffered-Input-Stream
  10416. # =====================
  10417.  
  10418. # Elementtyp: string-char
  10419. # Richtungen: nur input
  10420. # (make-buffered-input-stream fun mode) liefert einen solchen.
  10421. #   Dabei ist fun eine Funktion von 0 Argumenten, die bei Aufruf
  10422. #   entweder NIL (steht für EOF) oder bis zu drei Werte string, start, end
  10423. #   zurückliefert.
  10424. #   Funktionsweise: (read-char ...) liefert nacheinander die Zeichen des
  10425. #   aktuellen Strings; ist der zu Ende, wird fun aufgerufen, und ist der
  10426. #   Wert davon ein String, so wird der neue aktuelle String gegeben durch
  10427. #     (multiple-value-bind (str start end) (funcall fun)
  10428. #       (subseq str (or start 0) (or end 'NIL))
  10429. #     )
  10430. #   Der von fun zurückgegebene String sollte nicht verändert werden.
  10431. #   (Ansonsten sollte fun vorher den String mit COPY-SEQ kopieren.)
  10432. #   mode bestimmt, wie sich der Stream bezüglich LISTEN verhält.
  10433. #   mode = NIL: Stream verhält sich wie ein File-Stream, d.h. bei LISTEN
  10434. #               und leerem aktuellen String wird fun aufgerufen.
  10435. #   mode = T: Stream verhält sich wie ein interaktiver Stream ohne EOF,
  10436. #             d.h. man kann davon ausgehen, das stets noch weitere Zeichen
  10437. #             kommen, auch ohne fun aufzurufen.
  10438. #   mode eine Funktion: Diese Funktion teilt, wenn aufgerufen, mit, ob
  10439. #             noch weitere nichtleere Strings zu erwarten sind.
  10440. #   (clear-input ...) beendet die Bearbeitung des aktuellen Strings.
  10441.  
  10442. # Zusätzliche Komponenten:
  10443.   # define strm_buff_in_fun      strm_other[0]  # Lesefunktion
  10444.   #define strm_buff_in_mode      strm_other[1]  # Modus oder Listen-Funktion
  10445.   #define strm_buff_in_string    strm_other[2]  # aktueller String für Input
  10446.   #define strm_buff_in_index     strm_other[3]  # Index in den String (Fixnum >=0)
  10447.   #define strm_buff_in_endindex  strm_other[4]  # Endindex (Fixnum >= index >=0)
  10448.  
  10449. # READ-CHAR - Pseudofunktion für Buffered-Input-Streams:
  10450.   local object rd_ch_buff_in (object* stream_);
  10451.   local object rd_ch_buff_in(stream_)
  10452.     var reg5 object* stream_;
  10453.     { var reg1 object stream = *stream_;
  10454.       var reg2 uintL index = posfixnum_to_L(TheStream(stream)->strm_buff_in_index); # Index
  10455.       var reg4 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_buff_in_endindex);
  10456.       loop
  10457.         { if (index < endindex) break; # noch was im aktuellen String?
  10458.           # String-Ende erreicht
  10459.           # fun aufrufen:
  10460.           funcall(TheStream(stream)->strm_buff_in_fun,0);
  10461.           if (!stringp(value1))
  10462.             { return eof_value; } # EOF erreicht
  10463.           # neuen String holen und Grenzen überprüfen:
  10464.           pushSTACK(value1); # String
  10465.           pushSTACK(mv_count >= 2 ? value2 : unbound); # start
  10466.           pushSTACK(mv_count >= 3 ? value3 : unbound); # end
  10467.          {var object string;
  10468.           var uintL start;
  10469.           var uintL len;
  10470.           subr_self = L(read_char);
  10471.           test_string_limits(&string,&start,&len);
  10472.           stream = *stream_;
  10473.           index = start;
  10474.           endindex = index+len;
  10475.           TheStream(stream)->strm_buff_in_string = string;
  10476.           TheStream(stream)->strm_buff_in_index = fixnum(index);
  10477.           TheStream(stream)->strm_buff_in_endindex = fixnum(endindex);
  10478.         }}
  10479.       # index < eofindex
  10480.       { var uintL len;
  10481.         var reg3 uintB* charptr = unpack_string(TheStream(stream)->strm_buff_in_string,&len);
  10482.         # Ab charptr kommen len Zeichen.
  10483.         if (index >= len) # Index zu groß ?
  10484.           { pushSTACK(TheStream(stream)->strm_buff_in_string);
  10485.             pushSTACK(stream);
  10486.             //: DEUTSCH "~ hinterm Stringende angelangt, weil String ~ adjustiert wurde."
  10487.             //: ENGLISH "~ is beyond the end because the string ~ has been adjusted"
  10488.             //: FRANCAIS "~ est arrivé après la fin de la chaîne, parce que la chaîne ~ a été ajustée."
  10489.             fehler(error,GETTEXT("~ is beyond the end because the string ~ has been adjusted"));
  10490.           }
  10491.        {var reg1 object ch = code_char(charptr[index]); # Zeichen aus dem String holen
  10492.         # Index erhöhen:
  10493.         TheStream(stream)->strm_buff_in_index = fixnum_inc(TheStream(stream)->strm_buff_in_index,1);
  10494.         return ch;
  10495.       }}
  10496.     }
  10497.  
  10498. # Schließt einen Buffered-Input-Stream.
  10499. # close_buff_in(stream);
  10500. # > stream : Buffered-Input-Stream
  10501.   local void close_buff_in (object stream);
  10502.   local void close_buff_in(stream)
  10503.     var reg1 object stream;
  10504.     { TheStream(stream)->strm_buff_in_fun = NIL; # Funktion := NIL
  10505.       TheStream(stream)->strm_buff_in_mode = NIL; # Mode := NIL
  10506.       TheStream(stream)->strm_buff_in_string = NIL; # String := NIL
  10507.     }
  10508.  
  10509. # Stellt fest, ob ein Buffered-Input-Stream ein Zeichen verfügbar hat.
  10510. # listen_buff_in(stream)
  10511. # > stream : Buffered-Input-Stream
  10512. # < ergebnis:  0 falls Zeichen verfügbar,
  10513. #             -1 falls bei EOF angelangt,
  10514. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  10515. # kann GC auslösen
  10516.   local signean listen_buff_in (object stream);
  10517.   local signean listen_buff_in(stream)
  10518.     var reg1 object stream;
  10519.     { var reg3 uintL index = posfixnum_to_L(TheStream(stream)->strm_buff_in_index); # Index
  10520.       var reg4 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_buff_in_endindex);
  10521.       if (index < endindex) { return signean_null; }
  10522.      {var reg2 object mode = TheStream(stream)->strm_buff_in_mode;
  10523.       if (eq(mode,S(nil)))
  10524.         { pushSTACK(stream);
  10525.           mode = peek_char(&STACK_0); # peek_char macht read_char, ruft fun auf
  10526.           skipSTACK(1);
  10527.           if (eq(mode,eof_value))
  10528.             { return signean_minus; } # EOF erreicht
  10529.             else
  10530.             { return signean_null; }
  10531.         }
  10532.       elif (eq(mode,S(t)))
  10533.         { return signean_null; }
  10534.       else
  10535.         { funcall(mode,0); # mode aufrufen
  10536.           if (nullp(value1)) # keine Strings mehr zu erwarten?
  10537.             { return signean_minus; } # ja -> EOF erreicht
  10538.             else
  10539.             { return signean_null; }
  10540.         }
  10541.     }}
  10542.  
  10543. # UP: Löscht bereits eingegebenen interaktiven Input von einem Buffered-Input-Stream.
  10544. # clear_input_buff_in(stream)
  10545. # > stream: Buffered-Input-Stream
  10546. # < ergebnis: TRUE falls Input gelöscht wurde
  10547. # kann GC auslösen
  10548.   local boolean clear_input_buff_in (object stream);
  10549.   local boolean clear_input_buff_in(stream)
  10550.     var reg1 object stream;
  10551.     { # Bearbeitung des aktuellen Strings beenden:
  10552.       var reg3 object index = TheStream(stream)->strm_buff_in_index; # Index
  10553.       var reg2 object endindex = TheStream(stream)->strm_buff_in_endindex;
  10554.       TheStream(stream)->strm_buff_in_index = endindex; # index := endindex
  10555.       if (eq(index,endindex)) { return FALSE; } else { return TRUE; }
  10556.     }
  10557.  
  10558. LISPFUNN(make_buffered_input_stream,2)
  10559. # (MAKE-BUFFERED-INPUT-STREAM fun mode)
  10560.   { var reg1 object stream = # neuer Stream, nur READ-CHAR erlaubt
  10561.       allocate_stream(strmflags_rd_ch_B,strmtype_buff_in,strm_len+5);
  10562.     TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  10563.     TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10564.     TheStream(stream)->strm_rd_ch = P(rd_ch_buff_in);
  10565.     TheStream(stream)->strm_rd_ch_last = NIL;
  10566.     TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  10567.     TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  10568.     #ifdef STRM_WR_SS
  10569.     TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  10570.     #endif
  10571.     TheStream(stream)->strm_buff_in_mode = popSTACK();
  10572.     TheStream(stream)->strm_buff_in_fun = popSTACK();
  10573.     TheStream(stream)->strm_buff_in_string = O(leer_string); # String := ""
  10574.     TheStream(stream)->strm_buff_in_index = Fixnum_0; # Index := 0
  10575.     TheStream(stream)->strm_buff_in_endindex = Fixnum_0; # Endindex := 0
  10576.     value1 = stream; mv_count=1; # stream als Wert
  10577.   }
  10578.  
  10579. LISPFUNN(buffered_input_stream_index,1)
  10580. # (SYSTEM::BUFFERED-INPUT-STREAM-INDEX buffered-input-stream) liefert den Index
  10581.   { var reg1 object stream = popSTACK(); # Argument
  10582.     # muß ein Buffered-Input-Stream sein:
  10583.     if (!(streamp(stream) && (TheStream(stream)->strmtype == strmtype_buff_in)))
  10584.       { pushSTACK(stream);
  10585.         pushSTACK(TheSubr(subr_self)->name);
  10586.         //: DEUTSCH "~: ~ ist kein Buffered-Input-Stream."
  10587.         //: ENGLISH "~: ~ is not a buffered input stream"
  10588.         //: FRANCAIS "~ : ~ n'est pas un «stream» d'entrée bufferisé."
  10589.         fehler(error,GETTEXT("~: ~ is not a buffered input stream"));
  10590.       }
  10591.    {var reg2 object index = TheStream(stream)->strm_buff_in_index;
  10592.     # Falls ein Character mit UNREAD-CHAR zurückgeschoben wurde,
  10593.     # verwende (1- index), ein Fixnum >=0, als Wert:
  10594.     if (mposfixnump(TheStream(stream)->strm_rd_ch_last))
  10595.       { index = fixnum_inc(index,-1); }
  10596.     value1 = index; mv_count=1;
  10597.   }}
  10598.  
  10599.  
  10600. # Buffered-Output-Stream
  10601. # ======================
  10602.  
  10603. # Elementtyp: string-char
  10604. # Richtungen: nur output
  10605. # (make-buffered-output-stream fun) liefert einen solchen.
  10606. #   Dabei ist fun eine Funktion von einem Argument, die, mit einem
  10607. #   Simple-String als Argument aufgerufen, dessen Inhalt in Empfang nimmt.
  10608. #   Funktionsweise: (write-char ...) sammelt die geschriebenen Zeichen in
  10609. #   einem String, bis ein #\Newline oder eine FORCE-/FINISH-OUTPUT-
  10610. #   Anforderung kommt, und ruft dann fun mit einem Simple-String, der das
  10611. #   bisher Angesammelte enthält, als Argument auf.
  10612. #   (clear-output ...) wirft die bisher angesammelten Zeichen weg.
  10613.  
  10614. # Zusätzliche Komponenten:
  10615.   # define strm_buff_out_fun    strm_other[0]  # Ausgabefunktion
  10616.   #define strm_buff_out_string  strm_other[1]  # Semi-Simple-String für Output
  10617.  
  10618. # UP: Bringt den wartenden Output eines Buffered-Output-Stream ans Ziel.
  10619. # finish_output_buff_out(stream);
  10620. # > stream: Buffered-Output-Stream
  10621. # kann GC auslösen
  10622.   local void finish_output_buff_out (object stream);
  10623.   local void finish_output_buff_out(stream)
  10624.     var reg1 object stream;
  10625.     { pushSTACK(stream);
  10626.      {var reg2 object string = TheStream(stream)->strm_buff_out_string; # String
  10627.       string = coerce_ss(string); # in Simple-String umwandeln (erzwingt ein Kopieren)
  10628.       stream = STACK_0; STACK_0 = string;
  10629.       # String durch Fill-Pointer:=0 leeren:
  10630.       TheArray(TheStream(stream)->strm_buff_out_string)->dims[1] = 0;
  10631.       funcall(TheStream(stream)->strm_buff_out_fun,1); # Funktion aufrufen
  10632.     }}
  10633.  
  10634. # UP: Bringt den wartenden Output eines Buffered-Output-Stream ans Ziel.
  10635. # force_output_buff_out(stream);
  10636. # > stream: Buffered-Output-Stream
  10637. # kann GC auslösen
  10638.   #define force_output_buff_out  finish_output_buff_out
  10639.  
  10640. # UP: Löscht den wartenden Output eines Buffered-Output-Stream.
  10641. # clear_output_buff_out(stream);
  10642. # > stream: Buffered-Output-Stream
  10643. # kann GC auslösen
  10644.   local void clear_output_buff_out (object stream);
  10645.   local void clear_output_buff_out(stream)
  10646.     var reg1 object stream;
  10647.     { # String durch Fill-Pointer:=0 leeren:
  10648.       TheArray(TheStream(stream)->strm_buff_out_string)->dims[1] = 0;
  10649.       # Line-Position unverändert lassen??
  10650.     }
  10651.  
  10652. # WRITE-CHAR - Pseudofunktion für Buffered-Output-Streams:
  10653.   local void wr_ch_buff_out (object* stream_, object ch);
  10654.   local void wr_ch_buff_out(stream_,ch)
  10655.     var reg3 object* stream_;
  10656.     var reg1 object ch;
  10657.     { var reg2 object stream = *stream_;
  10658.       # obj sollte String-Char sein:
  10659.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); }
  10660.       # Character in den String schieben:
  10661.       ssstring_push_extend(TheStream(stream)->strm_buff_out_string,char_code(ch));
  10662.       # Nach #\Newline den Buffer durchreichen:
  10663.       if (char_code(ch) == NL) { force_output_buff_out(*stream_); }
  10664.     }
  10665.  
  10666. # Schließt einen Buffered-Output-Stream.
  10667. # close_buff_out(stream);
  10668. # > stream : Buffered-Output-Stream
  10669. # kann GC auslösen
  10670.   local void close_buff_out (object stream);
  10671.   local void close_buff_out(stream)
  10672.     var reg1 object stream;
  10673.     { pushSTACK(stream); # stream retten
  10674.       finish_output_buff_out(stream);
  10675.       stream = popSTACK(); # stream zurück
  10676.       TheStream(stream)->strm_buff_out_fun = NIL; # Funktion := NIL
  10677.       TheStream(stream)->strm_buff_out_string = NIL; # String := NIL
  10678.     }
  10679.  
  10680. LISPFUN(make_buffered_output_stream,1,1,norest,nokey,0,NIL)
  10681. # (MAKE-BUFFERED-OUTPUT-STREAM fun [line-position])
  10682.   { # line-position überprüfen:
  10683.     if (eq(STACK_0,unbound))
  10684.       { STACK_0 = Fixnum_0; } # Defaultwert 0
  10685.       else
  10686.       # line-position angegeben, sollte ein Fixnum >=0 sein:
  10687.       { if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); } }
  10688.     # kleinen Semi-Simple-String der Länge 50 allozieren:
  10689.     pushSTACK(make_ssstring(50));
  10690.    {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt
  10691.       allocate_stream(strmflags_wr_ch_B,strmtype_buff_out,strm_len+2);
  10692.     TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  10693.     TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10694.     TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  10695.     TheStream(stream)->strm_rd_ch_last = NIL;
  10696.     TheStream(stream)->strm_wr_ch = P(wr_ch_buff_out);
  10697.     #ifdef STRM_WR_SS
  10698.     TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  10699.     #endif
  10700.     TheStream(stream)->strm_buff_out_string = popSTACK(); # String eintragen
  10701.     TheStream(stream)->strm_wr_ch_lpos = popSTACK(); # Line Position eintragen
  10702.     TheStream(stream)->strm_buff_out_fun = popSTACK(); # Funktion eintragen
  10703.     value1 = stream; mv_count=1; # stream als Wert
  10704.   }}
  10705.  
  10706. #ifdef PRINTER_AMIGAOS
  10707.  
  10708. # Printer-Stream
  10709. # ==============
  10710.  
  10711. # Zusätzliche Komponenten:
  10712.   #define strm_printer_handle  strm_other[0]  # Handle von "PRT:"
  10713.  
  10714. # WRITE-CHAR - Pseudofunktion für Printer-Streams:
  10715.   local void wr_ch_printer (object* stream_, object ch);
  10716.   local void wr_ch_printer(stream_,ch)
  10717.     var reg4 object* stream_;
  10718.     var reg2 object ch;
  10719.     { var reg1 object stream = *stream_;
  10720.       # ch sollte String-Char sein:
  10721.       if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); }
  10722.       begin_system_call();
  10723.      {var uintB c = char_code(ch);
  10724.       var reg3 long ergebnis = # Zeichen auszugeben versuchen
  10725.         Write(TheHandle(TheStream(stream)->strm_printer_handle),&c,1L);
  10726.       end_system_call();
  10727.       if (ergebnis<0) { OS_error(); } # Error melden
  10728.       # ergebnis = Anzahl der ausgegebenen Zeichen (0 oder 1)
  10729.       if (ergebnis==0) # nicht erfolgreich?
  10730.         { fehler_unwritable(S(write_char),stream); }
  10731.     }}
  10732.  
  10733. # Schließt einen Printer-Stream.
  10734.   local void close_printer (object stream);
  10735.   local void close_printer(stream)
  10736.     var reg1 object stream;
  10737.     { begin_system_call();
  10738.       Close(TheHandle(TheStream(stream)->strm_printer_handle));
  10739.       end_system_call();
  10740.     }
  10741.  
  10742. # UP: Liefert einen Printer-Stream.
  10743. # kann GC auslösen
  10744.   local object make_printer_stream (void);
  10745.   local object make_printer_stream()
  10746.     { pushSTACK(allocate_cons()); # Cons für Liste
  10747.       pushSTACK(allocate_handle(Handle_NULL)); # Handle-Verpackung
  10748.      {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt
  10749.         allocate_stream(strmflags_wr_ch_B,strmtype_printer,strm_len+1);
  10750.       set_break_sem_4();
  10751.       begin_system_call();
  10752.       {var reg2 Handle handle = Open("PRT:",MODE_NEWFILE);
  10753.        if (handle==Handle_NULL) { OS_error(); } # Error melden
  10754.        end_system_call();
  10755.        TheHandle(STACK_0) = handle; # Handle verpacken
  10756.       }
  10757.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  10758.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10759.       TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  10760.       TheStream(stream)->strm_rd_ch_last = NIL;
  10761.       TheStream(stream)->strm_wr_ch = P(wr_ch_printer);
  10762.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  10763.       #ifdef STRM_WR_SS
  10764.       TheStream(stream)->strm_wr_ss = P(wr_ss_dummy_nogc);
  10765.       #endif
  10766.       TheStream(stream)->strm_printer_handle = popSTACK();
  10767.       # Liste der offenen Streams um stream erweitern:
  10768.       {var reg1 object new_cons = popSTACK();
  10769.        Car(new_cons) = stream;
  10770.        Cdr(new_cons) = O(open_files);
  10771.        O(open_files) = new_cons;
  10772.       }
  10773.       clr_break_sem_4();
  10774.       return stream;
  10775.     }}
  10776.  
  10777. LISPFUNN(make_printer_stream,0)
  10778. # (SYSTEM::MAKE-PRINTER-STREAM) liefert einen Printer-Stream.
  10779. # Für die verstandenen Escape-Sequenzen siehe in PRINTER.DOC.
  10780.   { value1 = make_printer_stream(); mv_count=1; return; }
  10781.  
  10782. #endif
  10783.  
  10784.  
  10785. #ifdef PIPES
  10786.  
  10787. # Pipe-Input-Stream
  10788. # =================
  10789.  
  10790. # Zusätzliche Komponenten:
  10791.   # define strm_pipe_pid       strm_other[3] # Prozeß-Id, ein Fixnum >=0
  10792.   #define strm_pipe_in_handle  strm_ihandle  # Handle für Input
  10793.   #if defined(EMUNIX) && defined(PIPES2)
  10794.   #define strm_pipe_in_other   strm_ohandle  # Pipe-Stream in Gegenrichtung
  10795.   #define strm_pipe_out_other  strm_ihandle  # Pipe-Stream in Gegenrichtung
  10796.   #endif
  10797.  
  10798. # READ-CHAR - Pseudofunktion für Pipe-Input-Streams:
  10799.   #define rd_ch_pipe_in  rd_ch_handle
  10800.   #define rd_by_pipe_in  rd_by_handle
  10801.  
  10802. # Schließt einen Pipe-Input-Stream.
  10803. # close_pipe_in(stream);
  10804. # > stream : Pipe-Input-Stream
  10805.   #ifdef EMUNIX
  10806.     local void close_pipe_in (object stream);
  10807.     local void close_pipe_in(stream)
  10808.       var reg1 object stream;
  10809.       { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_pipe_in_handle);
  10810.         #ifdef PIPES2
  10811.         if (mstreamp(TheStream(stream)->strm_pipe_in_other))
  10812.           # Der andere Pipe-Stream ist noch offen. Wir dürfen nicht pclose()
  10813.           # aufrufen, da das ein waitpid() ausführt.
  10814.           { TheStream(TheStream(stream)->strm_pipe_in_other)->strm_pipe_out_other = NIL;
  10815.             TheStream(stream)->strm_pipe_in_other = NIL;
  10816.             begin_system_call();
  10817.             if ( fclose(&_streamv[handle]) != 0) { OS_error(); }
  10818.             end_system_call();
  10819.             # Die Pipes sind nun getrennt, so daß beim Schließen der anderen
  10820.             # Pipe das pclose() ausgeführt werden wird.
  10821.             return;
  10822.           }
  10823.         #endif
  10824.         begin_system_call();
  10825.         if ( pclose(&_streamv[handle]) == -1) { OS_error(); }
  10826.         end_system_call();
  10827.       }
  10828.   #endif
  10829.   #if defined(UNIX) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  10830.     #define close_pipe_in  close_ihandle
  10831.   #endif
  10832.  
  10833. # Stellt fest, ob ein Pipe-Input-Stream ein Zeichen verfügbar hat.
  10834. # listen_pipe_in(stream)
  10835. # > stream : Pipe-Input-Stream
  10836. # < ergebnis:  0 falls Zeichen verfügbar,
  10837. #             -1 falls bei EOF angelangt,
  10838. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  10839. # kann GC auslösen
  10840.   #define listen_pipe_in  listen_handle
  10841.  
  10842. LISPFUNN(make_pipe_input_stream,1)
  10843. # (MAKE-PIPE-INPUT-STREAM command)
  10844. # ruft eine Shell auf, die command ausführt, wobei deren Standard-Output
  10845. # in unsere Pipe hinein geht.
  10846.   { # command überprüfen:
  10847.     var reg4 object command;
  10848.     funcall(L(string),1); # (STRING command)
  10849.     command = string_to_asciz(value1); # als ASCIZ-String
  10850.     pushSTACK(command);
  10851.    {var int handles[2]; # zwei Handles für die Pipe
  10852.     var reg3 int child;
  10853.     #ifdef EMUNIX
  10854.     { # Stackaufbau: command.
  10855.       begin_system_call();
  10856.      {var reg1 FILE* f = popen(TheAsciz(STACK_0),"r");
  10857.       if (f==NULL) { OS_error(); }
  10858.       child = f->pid;
  10859.       handles[0] = fileno(f);
  10860.       end_system_call();
  10861.     }}
  10862.     #endif
  10863.     #ifdef UNIX
  10864.     { # Als Shell nehmen wir immer die Kommando-Shell.
  10865.       # Stackaufbau: command.
  10866.       # command in den Stack kopieren:
  10867.       var reg5 uintL command_length = TheSstring(command)->length;
  10868.       var DYNAMIC_ARRAY(reg6,command_data,char,command_length);
  10869.       { var reg2 char* ptr1 = TheAsciz(command);
  10870.         var reg1 char* ptr2 = &command_data[0];
  10871.         dotimespL(command_length,command_length, { *ptr2++ = *ptr1++; } );
  10872.       }
  10873.       begin_system_call();
  10874.       # Pipe aufbauen:
  10875.       if (!( pipe(handles) ==0))
  10876.         { FREE_DYNAMIC_ARRAY(command_data); OS_error(); }
  10877.       # Alles, was in handles[1] reingeschoben wird, kommt bei handles[0]
  10878.       # wieder raus. Wir werden dies so benutzen:
  10879.       #
  10880.       #       write            system            read
  10881.       # child  ->   handles[1]   ->   handles[0]  ->  parent
  10882.       #
  10883.       # einen neuen Prozeß starten:
  10884.       if ((child = vfork()) ==0)
  10885.         # Dieses Programmstück wird vom Child-Prozeß ausgeführt:
  10886.         { if ( dup2(handles[1],stdout_handle) >=0) # Standard-Output umleiten
  10887.             if ( CLOSE(handles[1]) ==0) # Wir wollen nur über stdout_handle schreiben
  10888.               if ( CLOSE(handles[0]) ==0) # Wir wollen von der Pipe nicht lesen
  10889.                 # (Muß das dem Betriebssystem sagen, damit - wenn der Child
  10890.                 # die Pipe gefüllt hat - der Parent-Prozeß und nicht etwa der
  10891.                 # Child-Prozeß aufgerufen wird, um die Pipe zu leeren.)
  10892.                 { # Child-Prozeß zum Hintergrundprozeß machen:
  10893.                   SETSID(); # er bekommt eine eigene Process Group
  10894.                   execl(SHELL,            # Shell aufrufen
  10895.                         SHELL,            # =: argv[0]
  10896.                         "-c",             # =: argv[1]
  10897.                         &command_data[0], # =: argv[2]
  10898.                         NULL
  10899.                        );
  10900.                 }
  10901.           _exit(-1); # sollte dies mißlingen, Child-Prozeß beenden
  10902.         }
  10903.       # Dieses Programmstück wird wieder vom Aufrufer ausgeführt:
  10904.       if (child==-1)
  10905.         # Etwas ist mißlungen, entweder beim vfork oder beim execl.
  10906.         # In beiden Fällen wurde errno gesetzt.
  10907.         { var int saved_errno = errno;
  10908.           CLOSE(handles[1]); CLOSE(handles[0]);
  10909.           FREE_DYNAMIC_ARRAY(command_data);
  10910.           errno = saved_errno; OS_error();
  10911.         }
  10912.       # Wir wollen von der Pipe nur lesen, nicht schreiben:
  10913.       if (!( CLOSE(handles[1]) ==0))
  10914.         { var int saved_errno = errno;
  10915.           CLOSE(handles[0]);
  10916.           FREE_DYNAMIC_ARRAY(command_data);
  10917.           errno = saved_errno; OS_error();
  10918.         }
  10919.       # (Muß das dem Betriebssystem sagen, damit - wenn der Parent-Prozeß
  10920.       # die Pipe geleert hat - der Child-Prozeß und nicht etwa der
  10921.       # Parent-Prozeß aufgerufen wird, um die Pipe wieder zu füllen.)
  10922.       end_system_call();
  10923.       FREE_DYNAMIC_ARRAY(command_data);
  10924.     }
  10925.     #endif
  10926.     # Stream allozieren:
  10927.     { var reg1 object stream = # neuer Stream, nur READ-CHAR und READ-BYTE erlaubt
  10928.         allocate_stream(strmflags_rd_B,strmtype_pipe_in,strm_len+4);
  10929.       TheStream(stream)->strm_rd_by = P(rd_by_pipe_in);
  10930.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  10931.       TheStream(stream)->strm_rd_ch = P(rd_ch_pipe_in);
  10932.       TheStream(stream)->strm_rd_ch_last = NIL;
  10933.       TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  10934.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  10935.       #ifdef STRM_WR_SS
  10936.       TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  10937.       #endif
  10938.       TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid
  10939.       TheStream(stream)->strm_pipe_in_handle = allocate_handle(handles[0]); # Read-Handle
  10940.       TheStream(stream)->strm_isatty = NIL;
  10941.       value1 = stream; mv_count=1; # stream als Wert
  10942.       skipSTACK(1);
  10943.   }}}
  10944.  
  10945.  
  10946. # Pipe-Output-Stream
  10947. # ==================
  10948.  
  10949. # Zusätzliche Komponenten:
  10950.   # define strm_pipe_pid          strm_other[3] # Prozeß-Id, ein Fixnum >=0
  10951.   #define strm_pipe_out_handle    strm_ohandle  # Handle für Output
  10952.   #if defined(EMUNIX) && defined(PIPES2)
  10953.   # define strm_pipe_out_other    strm_ihandle  # Pipe-Stream in Gegenrichtung
  10954.   #endif
  10955.  
  10956. # WRITE-CHAR - Pseudofunktion für Pipe-Output-Streams:
  10957.   #define wr_ch_pipe_out  wr_ch_handle_x
  10958.   #define wr_by_pipe_out  wr_by_handle
  10959.  
  10960. #ifdef STRM_WR_SS
  10961. # WRITE-SIMPLE-STRING - Pseudofunktion für Pipe-Output-Streams:
  10962.   #define wr_ss_pipe_out  wr_ss_handle_x
  10963. #endif
  10964.  
  10965. # Schließt einen Pipe-Output-Stream.
  10966. # close_pipe_out(stream);
  10967. # > stream : Pipe-Output-Stream
  10968.   #ifdef EMUNIX
  10969.     local void close_pipe_out (object stream);
  10970.     local void close_pipe_out(stream)
  10971.       var reg1 object stream;
  10972.       { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_pipe_out_handle);
  10973.         #ifdef PIPES2
  10974.         if (mstreamp(TheStream(stream)->strm_pipe_out_other))
  10975.           # Der andere Pipe-Stream ist noch offen. Wir dürfen nicht pclose()
  10976.           # aufrufen, da das ein waitpid() ausführt.
  10977.           { TheStream(TheStream(stream)->strm_pipe_out_other)->strm_pipe_in_other = NIL;
  10978.             TheStream(stream)->strm_pipe_out_other = NIL;
  10979.             begin_system_call();
  10980.             if ( fclose(&_streamv[handle]) != 0) { OS_error(); }
  10981.             end_system_call();
  10982.             # Die Pipes sind nun getrennt, so daß beim Schließen der anderen
  10983.             # Pipe das pclose() ausgeführt werden wird.
  10984.             return;
  10985.           }
  10986.         #endif
  10987.         begin_system_call();
  10988.         if ( pclose(&_streamv[handle]) == -1) { OS_error(); }
  10989.         end_system_call();
  10990.       }
  10991.   #endif
  10992.   #if defined(UNIX) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  10993.     #define close_pipe_out  close_ohandle
  10994.   #endif
  10995.  
  10996. LISPFUNN(make_pipe_output_stream,1)
  10997. # (MAKE-PIPE-OUTPUT-STREAM command)
  10998. # ruft eine Shell auf, die command ausführt, wobei unsere Pipe in deren
  10999. # Standard-Input hinein geht.
  11000.   { # command überprüfen:
  11001.     var reg4 object command;
  11002.     funcall(L(string),1); # (STRING command)
  11003.     command = string_to_asciz(value1); # als ASCIZ-String
  11004.     pushSTACK(command);
  11005.    {var int handles[2]; # zwei Handles für die Pipe
  11006.     var reg3 int child;
  11007.     #ifdef EMUNIX
  11008.     { # Stackaufbau: command.
  11009.       begin_system_call();
  11010.      {var reg1 FILE* f = popen(TheAsciz(STACK_0),"w");
  11011.       if (f==NULL) { OS_error(); }
  11012.       child = f->pid;
  11013.       handles[1] = fileno(f);
  11014.       end_system_call();
  11015.     }}
  11016.     #endif
  11017.     #ifdef UNIX
  11018.     { # Als Shell nehmen wir immer die Kommando-Shell.
  11019.       # Stackaufbau: command.
  11020.       # command in den Stack kopieren:
  11021.       var reg5 uintL command_length = TheSstring(command)->length;
  11022.       var DYNAMIC_ARRAY(reg6,command_data,char,command_length);
  11023.       { var reg2 char* ptr1 = TheAsciz(command);
  11024.         var reg1 char* ptr2 = &command_data[0];
  11025.         dotimespL(command_length,command_length, { *ptr2++ = *ptr1++; } );
  11026.       }
  11027.       begin_system_call();
  11028.       if (!( pipe(handles) ==0))
  11029.         { FREE_DYNAMIC_ARRAY(command_data); OS_error(); }
  11030.       # Alles, was in handles[1] reingeschoben wird, kommt bei handles[0]
  11031.       # wieder raus. Wir werden dies so benutzen:
  11032.       #
  11033.       #        write            system            read
  11034.       # parent  ->   handles[1]   ->   handles[0]  ->  child
  11035.       #
  11036.       # einen neuen Prozeß starten:
  11037.       if ((child = vfork()) ==0)
  11038.         # Dieses Programmstück wird vom Child-Prozeß ausgeführt:
  11039.         { if ( dup2(handles[0],stdin_handle) >=0) # Standard-Input umleiten
  11040.             if ( CLOSE(handles[0]) ==0) # Wir wollen nur über stdin_handle lesen
  11041.               if ( CLOSE(handles[1]) ==0) # Wir wollen auf die Pipe nicht schreiben
  11042.                 # (Muß das dem Betriebssystem sagen, damit - wenn der Child
  11043.                 # die Pipe geleert hat - der Parent-Prozeß und nicht etwa der
  11044.                 # Child-Prozeß aufgerufen wird, um die Pipe zu wieder zu füllen.)
  11045.                 { # Child-Prozeß zum Hintergrundprozeß machen:
  11046.                   SETSID(); # er bekommt eine eigene Process Group
  11047.                   execl(SHELL,            # Shell aufrufen
  11048.                         SHELL,            # =: argv[0]
  11049.                         "-c",             # =: argv[1]
  11050.                         &command_data[0], # =: argv[2]
  11051.                         NULL
  11052.                        );
  11053.                 }
  11054.           _exit(-1); # sollte dies mißlingen, Child-Prozeß beenden
  11055.         }
  11056.       # Dieses Programmstück wird wieder vom Aufrufer ausgeführt:
  11057.       if (child==-1)
  11058.         # Etwas ist mißlungen, entweder beim vfork oder beim execl.
  11059.         # In beiden Fällen wurde errno gesetzt.
  11060.         { var int saved_errno = errno;
  11061.           CLOSE(handles[1]); CLOSE(handles[0]);
  11062.           FREE_DYNAMIC_ARRAY(command_data);
  11063.           errno = saved_errno; OS_error();
  11064.         }
  11065.       # Wir wollen auf die Pipe nur schreiben, nicht lesen:
  11066.       if (!( CLOSE(handles[0]) ==0))
  11067.         { var int saved_errno = errno;
  11068.           CLOSE(handles[1]);
  11069.           FREE_DYNAMIC_ARRAY(command_data);
  11070.           errno = saved_errno; OS_error();
  11071.         }
  11072.       # (Muß das dem Betriebssystem sagen, damit - wenn der Parent-Prozeß
  11073.       # die Pipe gefüllt hat - der Child-Prozeß und nicht etwa der
  11074.       # Parent-Prozeß aufgerufen wird, um die Pipe wieder zu leeren.)
  11075.       end_system_call();
  11076.       FREE_DYNAMIC_ARRAY(command_data);
  11077.     }
  11078.     #endif
  11079.     # Stream allozieren:
  11080.     { var reg1 object stream = # neuer Stream, nur WRITE-CHAR und WRITE-BYTE erlaubt
  11081.         allocate_stream(strmflags_wr_B,strmtype_pipe_out,strm_len+4);
  11082.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  11083.       TheStream(stream)->strm_wr_by = P(wr_by_pipe_out);
  11084.       TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  11085.       TheStream(stream)->strm_rd_ch_last = NIL;
  11086.       TheStream(stream)->strm_wr_ch = P(wr_ch_pipe_out);
  11087.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  11088.       #ifdef STRM_WR_SS
  11089.       TheStream(stream)->strm_wr_ss = P(wr_ss_pipe_out);
  11090.       #endif
  11091.       TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid
  11092.       TheStream(stream)->strm_pipe_out_handle = allocate_handle(handles[1]); # Write-Handle
  11093.       value1 = stream; mv_count=1; # stream als Wert
  11094.       skipSTACK(1);
  11095.   }}}
  11096.  
  11097. #ifdef PIPES2
  11098.  
  11099. # Bidirektionale Pipes
  11100. # ====================
  11101.  
  11102. LISPFUNN(make_pipe_io_stream,1)
  11103. # (MAKE-PIPE-IO-STREAM command)
  11104. # ruft eine Shell auf, die command ausführt, wobei der Output unserer Pipe
  11105. # in deren Standard-Input hinein und deren Standard-Output wiederum in
  11106. # unsere Pipe hinein geht.
  11107.   { # command überprüfen:
  11108.     var reg4 object command;
  11109.     funcall(L(string),1); # (STRING command)
  11110.     command = string_to_asciz(value1); # als ASCIZ-String
  11111.     pushSTACK(command);
  11112.    {var int in_handles[2]; # zwei Handles für die Pipe zum Input-Stream
  11113.     var int out_handles[2]; # zwei Handles für die Pipe zum Output-Stream
  11114.     var reg3 int child;
  11115.     #ifdef EMUNIX
  11116.     { # Stackaufbau: command.
  11117.       var FILE* f_in;
  11118.       var FILE* f_out;
  11119.       begin_system_call();
  11120.       if (popenrw(TheAsciz(STACK_0),&f_in,&f_out) <0) { OS_error(); }
  11121.       child = f_in->pid; # = f_out->pid;
  11122.       in_handles[0] = fileno(f_in);
  11123.       out_handles[1] = fileno(f_out);
  11124.     }
  11125.     #endif
  11126.     #ifdef UNIX
  11127.     { # Als Shell nehmen wir immer die Kommando-Shell.
  11128.       # Stackaufbau: command.
  11129.       # command in den Stack kopieren:
  11130.       var reg5 uintL command_length = TheSstring(command)->length;
  11131.       var DYNAMIC_ARRAY(reg6,command_data,char,command_length);
  11132.       { var reg2 char* ptr1 = TheAsciz(command);
  11133.         var reg1 char* ptr2 = &command_data[0];
  11134.         dotimespL(command_length,command_length, { *ptr2++ = *ptr1++; } );
  11135.       }
  11136.       begin_system_call();
  11137.       # Pipes aufbauen:
  11138.       if (!( pipe(in_handles) ==0))
  11139.         { FREE_DYNAMIC_ARRAY(command_data); OS_error(); }
  11140.       if (!( pipe(out_handles) ==0))
  11141.         { var int saved_errno = errno;
  11142.           CLOSE(in_handles[1]); CLOSE(in_handles[0]);
  11143.           FREE_DYNAMIC_ARRAY(command_data);
  11144.           errno = saved_errno; OS_error();
  11145.         }
  11146.       # Alles, was in handles[1] reingeschoben wird, kommt bei handles[0]
  11147.       # wieder raus. Wir werden dies so benutzen:
  11148.       #
  11149.       #        write                system                read
  11150.       # parent  ->   out_handles[1]   ->   out_handles[0]  ->   child
  11151.       # parent  <-   in_handles[0]    <-   in_handles[1]   <-   child
  11152.       #        read                 system                write
  11153.       #
  11154.       # einen neuen Prozeß starten:
  11155.       if ((child = vfork()) ==0)
  11156.         # Dieses Programmstück wird vom Child-Prozeß ausgeführt:
  11157.         { if ( dup2(out_handles[0],stdin_handle) >=0) # Standard-Input umleiten
  11158.             if ( dup2(in_handles[1],stdout_handle) >=0) # Standard-Output umleiten
  11159.               if ( CLOSE(out_handles[0]) ==0) # Wir wollen nur über stdin_handle lesen
  11160.                 if ( CLOSE(in_handles[1]) ==0) # Wir wollen nur über stdout_handle schreiben
  11161.                   if ( CLOSE(out_handles[1]) ==0) # Wir wollen auf die Pipe nicht schreiben
  11162.                     # (Muß das dem Betriebssystem sagen, damit - wenn der Child
  11163.                     # die Pipe geleert hat - der Parent-Prozeß und nicht etwa der
  11164.                     # Child-Prozeß aufgerufen wird, um die Pipe zu wieder zu füllen.)
  11165.                     if ( CLOSE(in_handles[0]) ==0) # Wir wollen von der Pipe nicht lesen
  11166.                       # (Muß das dem Betriebssystem sagen, damit - wenn der Child
  11167.                       # die Pipe gefüllt hat - der Parent-Prozeß und nicht etwa der
  11168.                       # Child-Prozeß aufgerufen wird, um die Pipe zu leeren.)
  11169.                       { # Child-Prozeß zum Hintergrundprozeß machen:
  11170.                         SETSID(); # er bekommt eine eigene Process Group
  11171.                         execl(SHELL,            # Shell aufrufen
  11172.                               SHELL,            # =: argv[0]
  11173.                               "-c",             # =: argv[1]
  11174.                               &command_data[0], # =: argv[2]
  11175.                               NULL
  11176.                              );
  11177.                       }
  11178.           _exit(-1); # sollte dies mißlingen, Child-Prozeß beenden
  11179.         }
  11180.       # Dieses Programmstück wird wieder vom Aufrufer ausgeführt:
  11181.       if (child==-1)
  11182.         # Etwas ist mißlungen, entweder beim vfork oder beim execl.
  11183.         # In beiden Fällen wurde errno gesetzt.
  11184.         { var int saved_errno = errno;
  11185.           CLOSE(in_handles[1]); CLOSE(in_handles[0]);
  11186.           CLOSE(out_handles[1]); CLOSE(out_handles[0]);
  11187.           FREE_DYNAMIC_ARRAY(command_data);
  11188.           errno = saved_errno; OS_error();
  11189.         }
  11190.       # Wir wollen auf die Pipe nur schreiben, nicht lesen:
  11191.       if (!( CLOSE(out_handles[0]) ==0))
  11192.         { var int saved_errno = errno;
  11193.           CLOSE(in_handles[1]); CLOSE(in_handles[0]);
  11194.           CLOSE(out_handles[1]);
  11195.           FREE_DYNAMIC_ARRAY(command_data);
  11196.           errno = saved_errno; OS_error();
  11197.         }
  11198.       # (Muß das dem Betriebssystem sagen, damit - wenn der Parent-Prozeß
  11199.       # die Pipe gefüllt hat - der Child-Prozeß und nicht etwa der
  11200.       # Parent-Prozeß aufgerufen wird, um die Pipe wieder zu leeren.)
  11201.       # Wir wollen von der Pipe nur lesen, nicht schreiben:
  11202.       if (!( CLOSE(in_handles[1]) ==0))
  11203.         { var int saved_errno = errno;
  11204.           CLOSE(in_handles[0]);
  11205.           CLOSE(out_handles[1]);
  11206.           FREE_DYNAMIC_ARRAY(command_data);
  11207.           errno = saved_errno; OS_error();
  11208.         }
  11209.       # (Muß das dem Betriebssystem sagen, damit - wenn der Parent-Prozeß
  11210.       # die Pipe geleert hat - der Child-Prozeß und nicht etwa der
  11211.       # Parent-Prozeß aufgerufen wird, um die Pipe wieder zu füllen.)
  11212.       end_system_call();
  11213.       FREE_DYNAMIC_ARRAY(command_data);
  11214.     }
  11215.     #endif
  11216.     # Input-Stream allozieren:
  11217.     { var reg1 object stream = # neuer Stream, nur READ-CHAR erlaubt
  11218.         allocate_stream(strmflags_rd_ch_B,strmtype_pipe_in,strm_len+4);
  11219.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  11220.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  11221.       TheStream(stream)->strm_rd_ch = P(rd_ch_pipe_in);
  11222.       TheStream(stream)->strm_rd_ch_last = NIL;
  11223.       TheStream(stream)->strm_wr_ch = P(wr_ch_dummy);
  11224.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  11225.       #ifdef STRM_WR_SS
  11226.       TheStream(stream)->strm_wr_ss = P(wr_ss_dummy);
  11227.       #endif
  11228.       TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid
  11229.       TheStream(stream)->strm_pipe_in_handle = allocate_handle(in_handles[0]); # Read-Handle
  11230.       TheStream(stream)->strm_isatty = NIL;
  11231.       pushSTACK(stream);
  11232.     }
  11233.     # Output-Stream allozieren:
  11234.     { var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt
  11235.         allocate_stream(strmflags_wr_ch_B,strmtype_pipe_out,strm_len+4);
  11236.       TheStream(stream)->strm_rd_by = P(rd_by_dummy);
  11237.       TheStream(stream)->strm_wr_by = P(wr_by_dummy);
  11238.       TheStream(stream)->strm_rd_ch = P(rd_ch_dummy);
  11239.       TheStream(stream)->strm_rd_ch_last = NIL;
  11240.       TheStream(stream)->strm_wr_ch = P(wr_ch_pipe_out);
  11241.       TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  11242.       #ifdef STRM_WR_SS
  11243.       TheStream(stream)->strm_wr_ss = P(wr_ss_pipe_out);
  11244.       #endif
  11245.       TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid
  11246.       TheStream(stream)->strm_pipe_out_handle = allocate_handle(out_handles[1]); # Write-Handle
  11247.       pushSTACK(stream);
  11248.     }
  11249.     #ifdef EMUNIX
  11250.     # Beide Pipes miteinander verknüpfen, zum reibungslosen close:
  11251.     TheStream(STACK_1)->strm_pipe_in_other = STACK_0;
  11252.     TheStream(STACK_0)->strm_pipe_out_other = STACK_1;
  11253.     #endif
  11254.     # 3 Werte:
  11255.     # (make-two-way-stream input-stream output-stream), input-stream, output-stream.
  11256.     STACK_2 = make_twoway_stream(STACK_1,STACK_0);
  11257.     funcall(L(values),3);
  11258.   }}
  11259.  
  11260. #endif # PIPES2
  11261.  
  11262. #endif # PIPES
  11263.  
  11264.  
  11265. #ifdef XSOCKETS
  11266.  
  11267. # X-Socket-Stream
  11268. # ===============
  11269.  
  11270. # Verwendung: für X-Windows.
  11271.  
  11272. # Zusätzliche Komponenten:
  11273.   # define strm_xsocket_connect strm_other[3] # Liste (host display)
  11274.  
  11275. # READ-CHAR - Pseudofunktion für X-Socket-Streams:
  11276.   #define rd_ch_xsocket  rd_ch_handle
  11277.  
  11278. # Stellt fest, ob ein X-Socket-Stream ein Zeichen verfügbar hat.
  11279. # listen_xsocket(stream)
  11280. # > stream : X-Socket-Stream
  11281. # < ergebnis:  0 falls Zeichen verfügbar,
  11282. #             -1 falls bei EOF angelangt,
  11283. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  11284. # kann GC auslösen
  11285.   #define listen_xsocket  listen_handle
  11286.  
  11287. # WRITE-CHAR - Pseudofunktion für X-Socket-Streams:
  11288.   #define wr_ch_xsocket  wr_ch_handle
  11289.  
  11290. #ifdef STRM_WR_SS
  11291. # WRITE-SIMPLE-STRING - Pseudofunktion für X-Socket-Streams:
  11292.   #define wr_ss_xsocket  wr_ss_handle
  11293. #endif
  11294.  
  11295. # READ-BYTE - Pseudofunktion für X-Socket-Streams:
  11296.   #define rd_by_xsocket  rd_by_handle
  11297.  
  11298. # WRITE-BYTE - Pseudofunktion für X-Socket-Streams:
  11299.   #define wr_by_xsocket  wr_by_handle
  11300.  
  11301. # Schließt einen X-Socket-Stream.
  11302. # close_xsocket(stream);
  11303. # > stream : X-Socket-Stream
  11304.   #define close_xsocket  close_ihandle
  11305.  
  11306. extern int connect_to_server (char* host, int display); # ein Stück X-Source...
  11307.  
  11308. LISPFUNN(make_xsocket_stream,2)
  11309. # (SYS::MAKE-XSOCKET-STREAM host display)
  11310. # liefert einen X-Socket-Stream für X-Windows oder NIL.
  11311.   { if (!mstringp(STACK_1))
  11312.       { pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  11313.         pushSTACK(S(string)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  11314.         pushSTACK(STACK_(1+2));
  11315.         //: DEUTSCH "Host muß ein String sein, nicht ~"
  11316.         //: ENGLISH "host should be string, not ~"
  11317.         //: FRANCAIS "L'hôte devrait être un chaîne et non ~"
  11318.         fehler(type_error,GETTEXT("host should be string, not ~"));
  11319.       }
  11320.     if (!mposfixnump(STACK_0))
  11321.       { pushSTACK(STACK_0); # Wert für Slot DATUM von TYPE-ERROR
  11322.         pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  11323.         pushSTACK(STACK_(0+2));
  11324.         //: DEUTSCH "Display sollte ein Fixnum >=0 sein, nicht ~"
  11325.         //: ENGLISH "display should be a nonnegative fixnum, not ~"
  11326.         //: FRANCAIS "Le «display» doit être de type FIXNUM >= 0 et non ~"
  11327.         fehler(type_error,GETTEXT("display should be a nonnegative fixnum, not ~"));
  11328.      }
  11329.   begin_system_call();
  11330.   {var reg2 int handle = connect_to_server(TheAsciz(string_to_asciz(STACK_1)),posfixnum_to_L(STACK_0));
  11331.    end_system_call();
  11332.    if (handle < 0) { OS_error(); }
  11333.    # Liste bilden:
  11334.    {var reg1 object list = listof(2); pushSTACK(list); }
  11335.    # Stream allozieren:
  11336.    {var reg1 object stream = # neuer Stream, nur READ-CHAR und WRITE-CHAR erlaubt
  11337.       allocate_stream(strmflags_ch_B,strmtype_xsocket,strm_len+4);
  11338.     TheStream(stream)->strm_rd_by = P(rd_by_xsocket);
  11339.     TheStream(stream)->strm_wr_by = P(wr_by_xsocket);
  11340.     TheStream(stream)->strm_rd_ch = P(rd_ch_xsocket);
  11341.     TheStream(stream)->strm_rd_ch_last = NIL;
  11342.     TheStream(stream)->strm_wr_ch = P(wr_ch_xsocket);
  11343.     TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  11344.     #ifdef STRM_WR_SS
  11345.     TheStream(stream)->strm_wr_ss = P(wr_ss_xsocket);
  11346.     #endif
  11347.     TheStream(stream)->strm_xsocket_connect = popSTACK(); # zweielementige Liste
  11348.     TheStream(stream)->strm_ihandle =
  11349.     TheStream(stream)->strm_ohandle = allocate_handle(handle); # Handle eintragen
  11350.     TheStream(stream)->strm_isatty = NIL;
  11351.     value1 = stream; mv_count=1; # stream als Wert
  11352.   }}}
  11353.  
  11354. # Die beiden folgenden Funktionen sollten
  11355. # 1. nicht nur auf Handle- und Socket-Streams, sondern auch auf Synonym-
  11356. #    und Concatenated-Streams funktionieren, idealerweise auch auf File-Streams.
  11357. # 2. das rd_ch_lastchar ebenso verändern wie READ-BYTE.
  11358. # 3. auch nicht-simple Byte-Vektoren akzeptieren.
  11359. # Für CLX reicht aber die vorliegende Implementation.
  11360.  
  11361. # (SYS::READ-N-BYTES stream vector start count)
  11362. # liest n Bytes auf einmal.
  11363. # Quelle:
  11364. #   stream: Handle- oder Socket-Stream
  11365. # Ziel: (aref vector start), ..., (aref vector (+ start (- count 1))), wobei
  11366. #   vector: semi-simpler 8Bit-Byte-Vektor
  11367. #   start: Start-Index in den Vektor
  11368. #   count: Anzahl der Bytes
  11369.  
  11370. # (SYS::WRITE-N-BYTES stream vector start count)
  11371. # schreibt n Bytes auf einmal.
  11372. # Quelle: (aref vector start), ..., (aref vector (+ start (- count 1))), wobei
  11373. #   vector: semi-simpler 8Bit-Byte-Vektor
  11374. #   start: Start-Index in den Vektor
  11375. #   count: Anzahl der Bytes
  11376. # Ziel:
  11377. #   stream: Handle- oder Socket-Stream
  11378.  
  11379. # Argumentüberprüfungen:
  11380. # Liefert den Index in *index_, den count in *count_, den Datenvektor im
  11381. # Stack statt des Vektors, und räumt den Stack um 2 auf.
  11382.   local void test_n_bytes_args (uintL* index_, uintL* count_);
  11383.   local void test_n_bytes_args(index_,count_)
  11384.     var reg3 uintL* index_;
  11385.     var reg2 uintL* count_;
  11386.     { if (!mstreamp(STACK_3)) { fehler_stream(STACK_3); }
  11387.       {var reg1 object stream = STACK_3;
  11388.        if (!(   eq(TheStream(stream)->strm_rd_by,P(rd_by_handle))
  11389.              && eq(TheStream(stream)->strm_wr_by,P(wr_by_handle))
  11390.           ) )
  11391.          { pushSTACK(stream);
  11392.            pushSTACK(TheSubr(subr_self)->name);
  11393.            //: DEUTSCH "~: Stream muß ein Handle-Stream sein, nicht ~"
  11394.            //: ENGLISH "~: stream must be a handle-stream, not ~"
  11395.            //: FRANCAIS "~ : Le stream doit être un «handle-stream» et non ~"
  11396.            fehler(error,GETTEXT( "~: stream must be a handle-stream, not ~"));
  11397.       }  }
  11398.       {var reg1 object vector = STACK_2;
  11399.        if (!(((typecode(vector)&~imm_array_mask) == bvector_type) # Bit/Byte-Vektor?
  11400.              && ((TheArray(vector)->flags & arrayflags_atype_mask) == Atype_8Bit) # 8Bit
  11401.           ) )
  11402.          { pushSTACK(vector); # Wert für Slot DATUM von TYPE-ERROR
  11403.            pushSTACK(O(type_uint8_vector)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  11404.            pushSTACK(vector);
  11405.            pushSTACK(TheSubr(subr_self)->name);
  11406.            //: DEUTSCH "~: Argument ~ sollte ein Vektor vom Typ (ARRAY (UNSIGNED-BYTE 8) (*)) sein."
  11407.            //: ENGLISH "~: argument ~ should be a vector of type (ARRAY (UNSIGNED-BYTE 8) (*))"
  11408.            //: FRANCAIS "~ : l'argument ~ doit être un vecteur de type (ARRAY (UNSIGNED-BYTE 8) (*))."
  11409.            fehler(type_error,GETTEXT("~: argument ~ should be a vector of type (ARRAY (UNSIGNED-BYTE 8) (*))"));
  11410.          }
  11411.        if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); }
  11412.        *count_ = posfixnum_to_L(popSTACK());
  11413.        if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); }
  11414.        *index_ = posfixnum_to_L(popSTACK());
  11415.        STACK_0 = array1_displace_check(vector,*count_,index_);
  11416.     } }
  11417.  
  11418. LISPFUNN(read_n_bytes,4)
  11419.   { var uintL startindex;
  11420.     var uintL totalcount;
  11421.     test_n_bytes_args(&startindex,&totalcount);
  11422.     if (!(totalcount==0))
  11423.       { var reg4 Handle handle = TheHandle(TheStream(STACK_1)->strm_ihandle);
  11424.         var reg2 uintL remaining = totalcount;
  11425.         restart_it:
  11426.        {var reg1 uintB* ptr = &TheSbvector(TheArray(STACK_0)->data)->data[startindex];
  11427.         begin_system_call();
  11428.         loop
  11429.           { var reg3 int ergebnis = full_read(handle,ptr,remaining);
  11430.             if (ergebnis<0)
  11431.               { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  11432.                   { end_system_call();
  11433.                     interruptp({ pushSTACK(S(read_n_bytes)); tast_break(); }); # Break-Schleife aufrufen
  11434.                     goto restart_it;
  11435.                   }
  11436.                 OS_error(); # Error melden
  11437.               }
  11438.             ptr += ergebnis; startindex += ergebnis; remaining -= ergebnis;
  11439.             if (remaining==0) break; # fertig?
  11440.           }
  11441.         end_system_call();
  11442.       }}
  11443.     skipSTACK(2);
  11444.     value1 = T; mv_count=1; # Wert T
  11445.   }
  11446.  
  11447. LISPFUNN(write_n_bytes,4)
  11448.   { var uintL startindex;
  11449.     var uintL totalcount;
  11450.     test_n_bytes_args(&startindex,&totalcount);
  11451.     if (!(totalcount==0))
  11452.       { var reg4 Handle handle = TheHandle(TheStream(STACK_1)->strm_ihandle);
  11453.         var reg2 uintL remaining = totalcount;
  11454.         restart_it:
  11455.        {var reg1 uintB* ptr = &TheSbvector(TheArray(STACK_0)->data)->data[startindex];
  11456.         begin_system_call();
  11457.         loop
  11458.           { var reg3 int ergebnis = full_write(handle,ptr,remaining);
  11459.             if (ergebnis<0)
  11460.               { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  11461.                   { end_system_call();
  11462.                     interruptp({ pushSTACK(S(write_n_bytes)); tast_break(); }); # Break-Schleife aufrufen
  11463.                     goto restart_it;
  11464.                   }
  11465.                 OS_error(); # Error melden
  11466.               }
  11467.             if (ergebnis==0) # nicht erfolgreich?
  11468.               { fehler_unwritable(S(write_n_bytes),STACK_1); }
  11469.             ptr += ergebnis; startindex += ergebnis; remaining -= ergebnis;
  11470.             if (remaining==0) break; # fertig?
  11471.           }
  11472.         end_system_call();
  11473.       }}
  11474.     skipSTACK(2);
  11475.     value1 = T; mv_count=1; # Wert T
  11476.   }
  11477.  
  11478. #endif
  11479.  
  11480.  
  11481. #ifdef GENERIC_STREAMS
  11482.  
  11483. # Generic Streams
  11484. # ===============
  11485.  
  11486.   # Contains a "controller object".
  11487.   # define strm_controller_object  strm_other[0]  # see lispbibl.d
  11488.  
  11489.   # The function GENERIC-STREAM-CONTROLLER will return some
  11490.   # object c associated with the stream s.
  11491.  
  11492.   #   (GENERIC-STREAM-READ-CHAR c)                      --> character or NIL
  11493.   #   (GENERIC-STREAM-LISTEN c)                         --> {0,1,-1}
  11494.   #   (GENERIC-STREAM-CLEAR-INPUT c)                    --> {T,NIL}
  11495.   #   (GENERIC-STREAM-WRITE-CHAR c ch)                  -->
  11496.   #   (GENERIC-STREAM-WRITE-STRING c string start len)  -->
  11497.   #   (GENERIC-STREAM-FINISH-OUTPUT c)                  -->
  11498.   #   (GENERIC-STREAM-FORCE-OUTPUT c)                   -->
  11499.   #   (GENERIC-STREAM-CLEAR-OUTPUT c)                   -->
  11500.   #   (GENERIC-STREAM-READ-BYTE c)                      --> integer or NIL
  11501.   #   (GENERIC-STREAM-WRITE-BYTE c i)                   -->
  11502.   #   (GENERIC-STREAM-CLOSE c)                          -->
  11503.  
  11504.   # (READ-CHAR s) ==
  11505.   # (GENERIC-STREAM-READ-CHAR c)
  11506.   local object rd_ch_generic (object* stream_);
  11507.   local object rd_ch_generic(stream_)
  11508.     var reg1 object* stream_;
  11509.     { pushSTACK(*stream_); funcall(L(generic_stream_controller),1);
  11510.       pushSTACK(value1); funcall(S(generic_stream_rdch),1);
  11511.       return nullp(value1) ? eof_value : value1;
  11512.     }
  11513.  
  11514.   # (LISTEN s) ==
  11515.   # (GENERIC-STREAM-LISTEN c)
  11516.   local signean listen_generic (object stream);
  11517.   local signean listen_generic(stream)
  11518.     var reg1 object stream;
  11519.     { pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11520.       pushSTACK(value1); funcall(S(generic_stream_listen),1);
  11521.       return I_to_L(value1);
  11522.     }
  11523.  
  11524.   # (CLEAR-INPUT s) ==
  11525.   # (GENERIC-STREAM-CLEAR-INPUT c)
  11526.   local boolean clear_input_generic (object stream);
  11527.   local boolean clear_input_generic(stream)
  11528.     var reg1 object stream;
  11529.     { pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11530.       pushSTACK(value1); funcall(S(generic_stream_clear_input),1);
  11531.       return !nullp(value1);
  11532.     }
  11533.  
  11534.   # (WRITE-CHAR ch s) ==
  11535.   # (GENERIC-STREAM-WRITE-CHAR c ch)
  11536.   local void wr_ch_generic (object* stream_, object ch);
  11537.   local void wr_ch_generic(stream_,ch)
  11538.     var reg1 object* stream_;
  11539.     var reg2 object ch;
  11540.     { # ch is a character, need not save it
  11541.       pushSTACK(*stream_); funcall(L(generic_stream_controller),1);
  11542.       pushSTACK(value1); pushSTACK(ch); funcall(S(generic_stream_wrch),2);
  11543.     }
  11544.  
  11545. #ifdef STRM_WR_SS
  11546.   # (WRITE-SIMPLE-STRING s string start len) ==
  11547.   # (GENERIC-STREAM-WRITE-STRING c string start len)
  11548.   local void wr_ss_generic (object* stream_, object string, uintL start, uintL len);
  11549.   local void wr_ss_generic(stream_,string,start,len)
  11550.     var reg2 object* stream_;
  11551.     var reg1 object string;
  11552.     var reg3 uintL start;
  11553.     var reg4 uintL len;
  11554.     { pushSTACK(string); # save string
  11555.       pushSTACK(*stream_); funcall(L(generic_stream_controller),1);
  11556.       pushSTACK(value1); pushSTACK(STACK_(0+1));
  11557.       pushSTACK(UL_to_I(start)); pushSTACK(UL_to_I(len));
  11558.       funcall(S(generic_stream_wrss),4);
  11559.       string = popSTACK();
  11560.       wr_ss_lpos(*stream_,&TheSstring(string)->data[start],len);
  11561.     }
  11562. #endif
  11563.  
  11564.   # (FINISH-OUTPUT s) ==
  11565.   # (GENERIC-STREAM-FINISH-OUTPUT c)
  11566.   local void finish_output_generic (object stream);
  11567.   local void finish_output_generic(stream)
  11568.     var reg1 object stream;
  11569.     { pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11570.       pushSTACK(value1); funcall(S(generic_stream_finish_output),1);
  11571.     }
  11572.  
  11573.   # (FORCE-OUTPUT s) ==
  11574.   # (GENERIC-STREAM-FORCE-OUTPUT c)
  11575.   local void force_output_generic (object stream);
  11576.   local void force_output_generic(stream)
  11577.     var reg1 object stream;
  11578.     { pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11579.       pushSTACK(value1); funcall(S(generic_stream_force_output),1);
  11580.     }
  11581.  
  11582.   # (CLEAR-OUTPUT s) ==
  11583.   # (GENERIC-STREAM-CLEAR-OUTPUT c)
  11584.   local void clear_output_generic (object stream);
  11585.   local void clear_output_generic(stream)
  11586.     var reg1 object stream;
  11587.     { pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11588.       pushSTACK(value1); funcall(S(generic_stream_clear_output),1);
  11589.     }
  11590.  
  11591.   # (READ-BYTE s) ==
  11592.   # (GENERIC-STREAM-READ-BYTE c)
  11593.   local object rd_by_generic (object stream);
  11594.   local object rd_by_generic(stream)
  11595.     var reg1 object stream;
  11596.     { pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11597.       pushSTACK(value1); funcall(S(generic_stream_rdby),1);
  11598.       return (nullp(value1) ? eof_value : value1);
  11599.     }
  11600.  
  11601.   # (WRITE-BYTE s i) ==
  11602.   # (GENERIC-STREAM-WRITE-BYTE c i)
  11603.   local void wr_by_generic (object stream, object obj);
  11604.   local void wr_by_generic(stream,obj)
  11605.     var reg2 object stream;
  11606.     var reg1 object obj;
  11607.     { pushSTACK(obj); # save obj
  11608.       pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11609.       obj = STACK_0;
  11610.       STACK_0 = value1; pushSTACK(obj); funcall(S(generic_stream_wrby),2);
  11611.     }
  11612.  
  11613.   # (CLOSE s) ==
  11614.   # (GENERIC-STREAM-CLOSE c)
  11615.   local void close_generic(stream)
  11616.     var reg1 object stream;
  11617.     { pushSTACK(stream); funcall(L(generic_stream_controller),1);
  11618.       pushSTACK(value1); funcall(S(generic_stream_close),1);
  11619.     }
  11620.  
  11621. LISPFUNN(generic_stream_controller,1)
  11622.   { var reg1 object stream = popSTACK();
  11623.     if (!streamp(stream)) { fehler_stream(stream); }
  11624.     if (!(   eq(TheStream(stream)->strm_rd_by,P(rd_by_generic))
  11625.           && eq(TheStream(stream)->strm_wr_by,P(wr_by_generic))))
  11626.       { pushSTACK(stream);
  11627.         pushSTACK(TheSubr(subr_self)->name);
  11628.         //: DEUTSCH "~: Stream muß ein Generic-Stream sein, nicht ~"
  11629.         //: ENGLISH "~: stream must be a generic-stream, not ~"
  11630.         //: FRANCAIS "~ : Le stream doit être un «generic-stream» et non ~"
  11631.         fehler(error,GETTEXT("~: stream must be a generic-stream, not ~"));
  11632.       }
  11633.     value1=TheStream(stream)->strm_controller_object;
  11634.     mv_count=1;
  11635.   }
  11636.  
  11637. LISPFUNN(make_generic_stream,1)
  11638.   { var reg1 object stream =
  11639.       allocate_stream(strmflags_open_B,strmtype_generic,strm_len+1);
  11640.     TheStream(stream)->strm_rd_by = P(rd_by_generic);
  11641.     TheStream(stream)->strm_wr_by = P(wr_by_generic);
  11642.     TheStream(stream)->strm_rd_ch = P(rd_ch_generic);
  11643.     TheStream(stream)->strm_rd_ch_last = NIL;
  11644.     TheStream(stream)->strm_wr_ch = P(wr_ch_generic);
  11645.     TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  11646.     #ifdef STRM_WR_SS
  11647.     TheStream(stream)->strm_wr_ss = P(wr_ss_generic);
  11648.     #endif
  11649.     TheStream(stream)->strm_controller_object = popSTACK();
  11650.     value1 = stream; mv_count=1; # stream als Wert
  11651.   }
  11652.  
  11653. LISPFUNN(generic_stream_p,1)
  11654.   { var reg1 object stream = popSTACK();
  11655.     if (!streamp(stream)) { fehler_stream(stream); }
  11656.     if ((eq(TheStream(stream)->strm_rd_by,P(rd_by_generic))
  11657.       && eq(TheStream(stream)->strm_wr_by,P(wr_by_generic))))
  11658.       { value1 = T; mv_count=1; }
  11659.     else
  11660.       { value1 = NIL; mv_count=1; }
  11661.   }
  11662.  
  11663. #endif
  11664.  
  11665.  
  11666. #ifdef SOCKET_STREAMS
  11667.  
  11668. # Socket-Streams
  11669. # ==============
  11670.  
  11671.   #define rd_ch_socket  rd_ch_handle
  11672.   #define listen_socket  listen_handle
  11673.   #define wr_ch_socket  wr_ch_handle
  11674.  
  11675. #ifdef STRM_WR_SS
  11676.   #define wr_ss_socket  wr_ss_handle
  11677. #endif
  11678.  
  11679.   #define rd_by_socket  rd_by_handle
  11680.   #define wr_by_socket  wr_by_handle
  11681.   #define close_socket  close_handle
  11682.   # define strm_socket_port strm_other[3]
  11683.   # define strm_socket_host strm_other[4]
  11684.  
  11685. local object make_socket_stream (int handle,object host,object port);
  11686. local object make_socket_stream(handle,host,port)
  11687.   var int handle;
  11688.   var object host;
  11689.   var object port;
  11690.   # Stream allozieren:
  11691.   {var reg1 object stream = # neuer Stream, nur READ-CHAR und WRITE-CHAR erlaubt
  11692.      allocate_stream(strmflags_ch_B,strmtype_socket,strm_len+5);
  11693.    pushSTACK(stream);
  11694.    TheStream(stream)->strm_rd_by = P(rd_by_socket);
  11695.    TheStream(stream)->strm_wr_by = P(wr_by_socket);
  11696.    TheStream(stream)->strm_rd_ch = P(rd_ch_socket);
  11697.    TheStream(stream)->strm_rd_ch_last = NIL;
  11698.    TheStream(stream)->strm_wr_ch = P(wr_ch_socket);
  11699.    TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
  11700.    #ifdef STRM_WR_SS
  11701.    TheStream(stream)->strm_wr_ss = P(wr_ss_socket);
  11702.    #endif
  11703.    TheStream(stream)->strm_socket_port = port;
  11704.    TheStream(stream)->strm_socket_host = host;
  11705.    TheStream(stream)->strm_ihandle =
  11706.    TheStream(stream)->strm_ohandle = allocate_handle(handle); # Handle eintragen
  11707.    TheStream(stream)->strm_isatty = NIL;
  11708.    return popSTACK();
  11709.   }
  11710.  
  11711. local void test_socket_server (object obj);
  11712. local void test_socket_server(obj)
  11713.   var object obj;
  11714.   {
  11715.     if (!socket_server_p(obj))
  11716.       { pushSTACK(obj);
  11717.         pushSTACK(S(socket_server));
  11718.         pushSTACK(obj);
  11719.         //: DEUTSCH "~ is not a SOCKET-SERVER"
  11720.         //: ENGLISH "~ is not a SOCKET-SERVER"
  11721.         //: FRANCAIS "~ is not a SOCKET-SERVER"
  11722.         fehler(type_error,GETTEXT("~ is not a SOCKET-SERVER"));
  11723.       }
  11724.   }
  11725.  
  11726. # Called when some socket server dies.
  11727. LISPFUNN(socket_server_close,1)
  11728.   { begin_system_call();
  11729.     test_socket_server(STACK_0);
  11730.     if (!( CLOSE(posfixnum_to_L(TheSocketServer(popSTACK())->socket_handle)) == 0))
  11731.       { OS_error(); }
  11732.     end_system_call();
  11733.     value1 = NIL; mv_count=0;
  11734.   }
  11735.  
  11736. extern int create_server_socket (int port);
  11737.  
  11738. LISPFUN(socket_server,0,1,norest,nokey,0,NIL)
  11739. # (SOCKET-SERVER [port])
  11740.   {
  11741.     var int s;
  11742.     var object socket_server;
  11743.  
  11744.     if (!mposfixnump(STACK_0))
  11745.       fehler_uint(STACK_0);
  11746.     begin_system_call();
  11747.     s = create_server_socket(posfixnum_to_L(STACK_0));
  11748.     end_system_call();
  11749.     if (s < 0) OS_error();
  11750.      
  11751.     pushSTACK(allocate_socket_server());
  11752.     TheSocketServer(STACK_0)->socket_handle = fixnum(s);
  11753.     TheSocketServer(STACK_0)->port = STACK_1;
  11754.     pushSTACK(STACK_0);
  11755.     pushSTACK(L(socket_server_close));
  11756.     funcall(L(finalize),2);
  11757.     value1 = popSTACK();
  11758.     mv_count = 1;
  11759.     skipSTACK(1);
  11760.   }
  11761.  
  11762. LISPFUNN(socket_server_port,1)
  11763. # (SOCKET-SERVER-PORT socket-server)
  11764.   { test_socket_server(STACK_0); 
  11765.     value1 = TheSocketServer(STACK_0)->port;
  11766.     mv_count = 1;
  11767.     skipSTACK(1);
  11768.   }
  11769.  
  11770. extern int accept_connection (int socket_handle);
  11771.  
  11772. LISPFUNN(socket_accept,1)
  11773. # (SOCKET-ACCEPT socket-server)
  11774.   {
  11775.     var int s;
  11776.     var int handle;
  11777.  
  11778.     test_socket_server(STACK_0);
  11779.     s = posfixnum_to_L(TheSocketServer(STACK_0)->socket_handle);
  11780.     begin_system_call();
  11781.     handle = accept_connection (s);
  11782.     end_system_call();
  11783.     if (handle < 0) OS_error();
  11784.     value1 = make_socket_stream(handle,NIL,STACK_0);
  11785.     mv_count = 1;
  11786.     skipSTACK(1);
  11787.   }
  11788.  
  11789. LISPFUN(socket_wait,1,2,norest,nokey,0,NIL)
  11790. # (SOCKET-WAIT socket-server [seconds [microseconds]])
  11791.   {
  11792.     #ifdef HAVE_SELECT
  11793.     var reg1 int handle;
  11794.     var struct timeval timeout,*timeout_ptr;
  11795.     test_socket_server(STACK_2);
  11796.     handle = posfixnum_to_L(TheSocketServer(STACK_2)->socket_handle);
  11797.     if (eq(STACK_1,unbound) && eq(STACK_0,unbound))
  11798.       { timeout_ptr = NULL; }
  11799.     else
  11800.       { timeout.tv_sec =  mposfixnump(STACK_1) ? posfixnum_to_L(STACK_1) : 0;
  11801.         timeout.tv_usec =  mposfixnump(STACK_0) ? posfixnum_to_L(STACK_0) : 0;
  11802.         timeout_ptr = &timeout;
  11803.       }
  11804.     begin_system_call();
  11805.     {var reg1 int ret;
  11806.      var fd_set handle_set;
  11807.      FD_ZERO(&handle_set); FD_SET(handle,&handle_set);
  11808.      ret = select(FD_SETSIZE,&handle_set,NULL,NULL,timeout_ptr);
  11809.      end_system_call();
  11810.      if (ret < 0) OS_error();
  11811.      value1 = (ret == 0) ? NIL : T;
  11812.     }
  11813.     #else
  11814.     value1 = NIL;
  11815.     #endif
  11816.     mv_count = 1;
  11817.     skipSTACK(3);
  11818.   }
  11819.  
  11820. extern int create_client_socket(char *host,int port);
  11821.  
  11822. LISPFUN(socket_connect,1,1,norest,nokey,0,NIL)
  11823. # (SOCKET-CONNECT port [host])
  11824.   {
  11825.     var int handle;
  11826.     var char *hostname;
  11827.  
  11828.     begin_system_call();
  11829.     if (eq(STACK_0,unbound))
  11830.       hostname = "localhost";
  11831.     elif (mstringp(STACK_0))
  11832.       hostname = TheAsciz(string_to_asciz(STACK_0));
  11833.     else
  11834.       fehler_string(STACK_0);
  11835.  
  11836.     if (posfixnump(STACK_1))                                    
  11837.       {
  11838.         handle = create_client_socket(hostname,posfixnum_to_L(STACK_1));
  11839.         if (handle == -1) OS_error();
  11840.       }
  11841.     else
  11842.       fehler_uint(STACK_1);
  11843.     end_system_call();
  11844.     value1 = make_socket_stream(handle,asciz_to_string(hostname),STACK_1);
  11845.     skipSTACK(2);
  11846.     mv_count = 1;
  11847.   }
  11848.  
  11849. extern int resolve_service (char *name_or_number,char **name);
  11850.  
  11851. LISPFUNN(socket_service_port,1)
  11852. # (SOCKET-SERVICE-PORT service-name)
  11853.   { 
  11854.     var char *service_name=TheAsciz(string_to_asciz(STACK_0));
  11855.  
  11856.     value1=L_to_I(resolve_service(service_name,&service_name));
  11857.     skipSTACK(1);
  11858.     mv_count=1;
  11859.   }
  11860.  
  11861. local void test_socket_stream (object obj);
  11862. local void test_socket_stream(obj)
  11863.   var object obj;
  11864.   { 
  11865.     if (!(streamp(obj) && (TheStream(obj)->strmtype==strmtype_socket)))
  11866.       {
  11867.         pushSTACK(obj);
  11868.         pushSTACK(S(stream));
  11869.         pushSTACK(obj);
  11870.         //: DEUTSCH "Argument was not a SOCKET-STREAM"
  11871.         //: ENGLISH "Argument was not a SOCKET-STREAM"
  11872.         //: FRANCAIS "Argument was not a SOCKET-STREAM"
  11873.         fehler(type_error,GETTEXT("Argument was not a SOCKET-STREAM"));
  11874.       }
  11875.   }
  11876.  
  11877. LISPFUNN(socket_stream_port,1)
  11878. # (SOCKET-STREAM-PORT socket-stream)
  11879.   {
  11880.     test_socket_stream(STACK_0);
  11881.     value1=TheStream(STACK_0)->strm_socket_port;
  11882.     skipSTACK(1);
  11883.     mv_count=1;
  11884.   }
  11885.  
  11886. LISPFUNN(socket_stream_host,1)
  11887. # (SOCKET-STREAM-HOST socket-stream)
  11888.   {
  11889.     test_socket_stream(STACK_0);
  11890.     value1=TheStream(STACK_0)->strm_socket_host;
  11891.     skipSTACK(1);
  11892.     mv_count=1;
  11893.   }
  11894.  
  11895. extern char *socket_getpeername(int socket_handle);
  11896.  
  11897. LISPFUNN(socket_stream_peer_host,1)
  11898. # (SOCKET-STREAM-PEERNAME socket-stream)
  11899.   {
  11900.     var int s;
  11901.     var struct sockaddr *name;
  11902.     var char *peername;
  11903.  
  11904.     test_socket_stream(STACK_0);   
  11905.     s = TheHandle(TheStream(STACK_0)->strm_ihandle);
  11906.  
  11907.     if ((peername=socket_getpeername(s)) == NULL) OS_error();
  11908.     skipSTACK(1);
  11909.     value1 = asciz_to_string(peername); mv_count=1;
  11910.   }
  11911.  
  11912. LISPFUNN(socket_stream_handle,1)
  11913. # (SOCKET-STREAM-HANDLE socket-stream)
  11914.   {
  11915.     test_socket_stream(STACK_0);   
  11916.     value1 = fixnum(TheHandle(TheStream(STACK_0)->strm_ihandle));
  11917.     skipSTACK(1);
  11918.     mv_count=1;
  11919.   }
  11920.  
  11921. #endif
  11922.  
  11923.  
  11924. # Streams allgemein
  11925. # =================
  11926.  
  11927. # UP: Initialisiert die Stream-Variablen.
  11928. # init_streamvars();
  11929. # kann GC auslösen
  11930.   global void init_streamvars (void);
  11931.   global void init_streamvars()
  11932.     {
  11933.      #ifdef KEYBOARD
  11934.      {var reg1 object stream = make_keyboard_stream();
  11935.       define_variable(S(keyboard_input),stream);   # *KEYBOARD-INPUT*
  11936.      }
  11937.      #endif
  11938.      #ifdef GNU_READLINE
  11939.      rl_readline_name = "Clisp";
  11940.      if (ilisp_mode)
  11941.        # Simuliere folgende Anweisung im .inputrc:
  11942.        #   Control-i: self-insert
  11943.        { rl_bind_key(CTRL('I'),rl_named_function("self-insert")); }
  11944.      rl_attempted_completion_function = &lisp_completion_matches;
  11945.      rl_completion_entry_function = &lisp_completion_more;
  11946.      #endif
  11947.      {var reg1 object stream = make_terminal_stream();
  11948.       define_variable(S(terminal_io),stream);      # *TERMINAL-IO*
  11949.      }
  11950.      {var reg1 object stream = make_synonym_stream(S(terminal_io)); # Synonym-Stream auf *TERMINAL-IO*
  11951.       define_variable(S(query_io),stream);         # *QUERY-IO*
  11952.       define_variable(S(debug_io),stream);         # *DEBUG-IO*
  11953.       define_variable(S(standard_input),stream);   # *STANDARD-INPUT*
  11954.       define_variable(S(standard_output),stream);  # *STANDARD-OUTPUT*
  11955.       define_variable(S(error_output),stream);     # *ERROR-OUTPUT*
  11956.       define_variable(S(trace_output),stream);     # *TRACE-OUTPUT*
  11957.      }
  11958.     }
  11959.  
  11960. # Liefert Fehlermeldung, wenn der Wert des Symbols sym kein Stream ist.
  11961.   local void fehler_value_stream(sym)
  11962.     var reg1 object sym;
  11963.     { # Vor der Fehlermeldung eventuell noch reparieren
  11964.       # (so wie bei init_streamvars bzw. init_pathnames initialisiert):
  11965.       var reg2 object stream;
  11966.       pushSTACK(sym); # sym retten
  11967.       #ifdef KEYBOARD
  11968.       if (eq(sym,S(keyboard_input)))
  11969.         # Keyboard-Stream als Default
  11970.         { stream = make_keyboard_stream(); }
  11971.       else
  11972.       #endif
  11973.       if (eq(sym,S(terminal_io)))
  11974.         # Terminal-Stream als Default
  11975.         { stream = make_terminal_stream(); }
  11976.       elif (eq(sym,S(query_io)) || eq(sym,S(debug_io)) ||
  11977.             eq(sym,S(standard_input)) || eq(sym,S(standard_output)) ||
  11978.             eq(sym,S(error_output)) || eq(sym,S(trace_output))
  11979.            )
  11980.         # Synonym-Stream auf *TERMINAL-IO* als Default
  11981.         { stream = make_synonym_stream(S(terminal_io)); }
  11982.       else
  11983.         # sonstiges Symbol, nicht reparierbar -> sofort Fehlermeldung:
  11984.         { pushSTACK(Symbol_value(sym)); # Wert für Slot DATUM von TYPE-ERROR
  11985.           pushSTACK(S(stream)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  11986.           pushSTACK(Symbol_value(sym)); # Variablenwert
  11987.           pushSTACK(sym); # Variable
  11988.           if (!sym_streamp(sym))
  11989.             { 
  11990.               //: DEUTSCH "Der Wert von ~ ist kein Stream: ~"
  11991.               //: ENGLISH "The value of ~ is not a stream: ~"
  11992.               //: FRANCAIS "La valeur de ~ n'est pas de type STREAM : ~"
  11993.               fehler(type_error,GETTEXT("The value of ~ is not a stream: ~"));
  11994.             }
  11995.             else
  11996.             {
  11997.               //: DEUTSCH "Der Wert von ~ ist kein passender Stream: ~"
  11998.               //: ENGLISH "The value of ~ is not an appropriate stream: ~"
  11999.               //: FRANCAIS "La valeur de ~ n'est pas un STREAM acceptable : ~"
  12000.               fehler(type_error,GETTEXT("The value of ~ is not an appropriate stream: ~"));
  12001.         }   }
  12002.       sym = popSTACK();
  12003.       # Reparatur beendet: stream ist der neue Wert von sym.
  12004.      {var reg3 object oldvalue = Symbol_value(sym);
  12005.       set_Symbol_value(sym,stream);
  12006.       pushSTACK(oldvalue); # Wert für Slot DATUM von TYPE-ERROR
  12007.       pushSTACK(S(stream)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  12008.       pushSTACK(stream); # neuer Variablenwert
  12009.       pushSTACK(oldvalue); # alter Variablenwert
  12010.       pushSTACK(sym); # Variable
  12011.       //: DEUTSCH "Der Wert von ~ war kein Stream: ~. Wurde zurückgesetzt auf ~."
  12012.       //: ENGLISH "The value of ~ was not a stream: ~. It has been changed to ~."
  12013.       //: FRANCAIS "La valeur de ~ n'était pas de type STREAM : ~. Changé en ~."
  12014.       fehler(type_error,GETTEXT("The value of ~ was not a stream: ~. It has been changed to ~."));
  12015.     }}
  12016.  
  12017. #ifdef GNU_READLINE
  12018.  
  12019. # Hilfsfunktionen für die GNU readline Library:
  12020.  
  12021. nonreturning_function(local, rl_memory_abort, (void));
  12022. local void rl_memory_abort()
  12023.   { # Wenn für die Readline-Library der Speicher nicht mehr reicht,
  12024.     # schmeißen wir sie raus und ersetzen den Terminal-Stream durch einen,
  12025.     # der ohne sie auskommt.
  12026.     rl_deprep_terminal(); # alle komischen ioctl()s rückgängig machen
  12027.     begin_callback(); # STACK wieder auf einen vernünftigen Wert setzen
  12028.     rl_present_p = FALSE;
  12029.     set_Symbol_value(S(terminal_io),make_terminal_stream());
  12030.     //: DEUTSCH "Readline-Library: kein freier Speicher mehr da."
  12031.     //: ENGLISH "readline library: out of memory."
  12032.     //: FRANCAIS "Bibliothèque readline: mémoire épuisée."
  12033.     fehler(storage_condition,GETTEXT("readline library: out of memory."));
  12034.   }
  12035.  
  12036. global char* xmalloc (int count);
  12037. global char* xmalloc(count)
  12038.   var reg2 int count;
  12039.   { var reg1 char* tmp = (char*)malloc(count);
  12040.     if (tmp) return tmp; else rl_memory_abort();
  12041.   }
  12042.  
  12043. global char* xrealloc (char* ptr, int count);
  12044. global char* xrealloc(ptr,count)
  12045.   var reg2 char* ptr;
  12046.   var reg2 int count;
  12047.   { var reg1 char* tmp = (ptr==NULL ? (char*)malloc(count) : (char*)realloc(ptr,count));
  12048.     if (tmp) return tmp; else rl_memory_abort();
  12049.   }
  12050.  
  12051. #endif
  12052.  
  12053. LISPFUNN(open_stream_p,1)
  12054. # (OPEN-STREAM-P stream), CLtL2 S. 505
  12055.   { var reg1 object stream = popSTACK();
  12056.     if (!streamp(stream)) { fehler_stream(stream); }
  12057.     if (TheStream(stream)->strmflags & strmflags_open_B) # Stream offen?
  12058.       { value1 = T; mv_count=1; } # Wert T
  12059.       else
  12060.       { value1 = NIL; mv_count=1; } # Wert NIL
  12061.   }
  12062.  
  12063. LISPFUNN(input_stream_p,1)
  12064. # (INPUT-STREAM-P stream), CLTL S. 332, CLtL2 S. 505
  12065.   { var reg1 object stream = popSTACK();
  12066.     if (!streamp(stream)) { fehler_stream(stream); }
  12067.     if (TheStream(stream)->strmflags & strmflags_rd_B) # READ-BYTE oder READ-CHAR erlaubt ?
  12068.       { value1 = T; mv_count=1; } # Wert T
  12069.       else
  12070.       { value1 = NIL; mv_count=1; } # Wert NIL
  12071.   }
  12072.  
  12073. LISPFUNN(output_stream_p,1)
  12074. # (OUTPUT-STREAM-P stream), CLTL S. 332, CLtL2 S. 505
  12075.   { var reg1 object stream = popSTACK();
  12076.     if (!streamp(stream)) { fehler_stream(stream); }
  12077.     if (TheStream(stream)->strmflags & strmflags_wr_B) # WRITE-BYTE oder WRITE-CHAR erlaubt ?
  12078.       { value1 = T; mv_count=1; } # Wert T
  12079.       else
  12080.       { value1 = NIL; mv_count=1; } # Wert NIL
  12081.   }
  12082.  
  12083. LISPFUNN(stream_element_type,1)
  12084. # (STREAM-ELEMENT-TYPE stream), CLTL S. 332, CLtL2 S. 505
  12085. # liefert NIL (für geschlossene Streams) oder CHARACTER oder INTEGER oder T
  12086. # oder (spezieller) STRING-CHAR oder (UNSIGNED-BYTE n) oder (SIGNED-BYTE n).
  12087.   { var reg1 object stream = popSTACK();
  12088.     if (!streamp(stream)) { fehler_stream(stream); }
  12089.    {var reg2 object eltype;
  12090.     if ((TheStream(stream)->strmflags & strmflags_open_B) == 0)
  12091.       # Stream geschlossen
  12092.       { eltype = NIL; }
  12093.       else
  12094.       # Stream offen
  12095.       { switch (TheStream(stream)->strmtype)
  12096.           { # erst die Streamtypen mit eingeschränkten Element-Typen:
  12097.             #ifdef KEYBOARD
  12098.             case strmtype_keyboard:
  12099.             #endif
  12100.             case strmtype_ch_file:
  12101.               # CHARACTER
  12102.               eltype = S(character); break;
  12103.             case strmtype_terminal:
  12104.             case strmtype_sch_file:
  12105.             case strmtype_str_in:
  12106.             case strmtype_str_out:
  12107.             case strmtype_str_push:
  12108.             case strmtype_pphelp:
  12109.             case strmtype_buff_in:
  12110.             case strmtype_buff_out:
  12111.             #ifdef SCREEN
  12112.             case strmtype_window:
  12113.             #endif
  12114.             #ifdef PRINTER
  12115.             case strmtype_printer:
  12116.             #endif
  12117.             #ifdef PIPES
  12118.             case strmtype_pipe_in:
  12119.             case strmtype_pipe_out:
  12120.             #endif
  12121.               # STRING-CHAR
  12122.               eltype = S(string_char); break;
  12123.             case strmtype_iu_file:
  12124.               # (UNSIGNED-BYTE bitsize)
  12125.               pushSTACK(S(unsigned_byte));
  12126.               pushSTACK(TheStream(stream)->strm_file_bitsize);
  12127.               eltype = listof(2);
  12128.               break;
  12129.             case strmtype_is_file:
  12130.               # (SIGNED-BYTE bitsize)
  12131.               pushSTACK(S(signed_byte));
  12132.               pushSTACK(TheStream(stream)->strm_file_bitsize);
  12133.               eltype = listof(2);
  12134.               break;
  12135.             # dann die allgemeinen Streams:
  12136.             #ifdef HANDLES
  12137.             case strmtype_handle:
  12138.             #endif
  12139.             #ifdef GENERIC_STREAMS
  12140.             case strmtype_generic:
  12141.             #endif
  12142.             default:
  12143.               { var reg1 uintB flags = TheStream(stream)->strmflags;
  12144.                 if (flags & strmflags_by_B)
  12145.                   { if (flags & strmflags_ch_B)
  12146.                       # (OR CHARACTER INTEGER)
  12147.                       { pushSTACK(S(or)); pushSTACK(S(character)); pushSTACK(S(integer));
  12148.                         eltype = listof(3);
  12149.                       }
  12150.                       else
  12151.                       # INTEGER
  12152.                       { eltype = S(integer); }
  12153.                   }
  12154.                   else
  12155.                   { if (flags & strmflags_ch_B)
  12156.                       # CHARACTER
  12157.                       { eltype = S(character); }
  12158.                       else
  12159.                       # NIL
  12160.                       { eltype = NIL; }
  12161.                   }
  12162.                 break;
  12163.               }
  12164.       }   }
  12165.     value1 = eltype; mv_count=1;
  12166.   }}
  12167.  
  12168. # UP: Stellt fest, ob ein Stream "interaktiv" ist, d.h. ob Input vom Stream
  12169. # vermutlich von einem vorher ausgegebenen Prompt abhängen wird.
  12170. # interactive_stream_p(stream)
  12171. # > stream: Stream
  12172.   local boolean interactive_stream_p (object stream);
  12173.   local boolean interactive_stream_p(stream)
  12174.     var reg1 object stream;
  12175.     { start:
  12176.       if ((TheStream(stream)->strmflags & strmflags_rd_B) == 0)
  12177.         # Stream für Input geschlossen
  12178.         { return FALSE; }
  12179.       # Stream offen
  12180.       switch (TheStream(stream)->strmtype)
  12181.         {
  12182.           #if !(defined(WINDOWS) || defined(WIN32_WINDOWS) || defined(NEXTAPP)) || defined(HANDLES)
  12183.           #if !(defined(WINDOWS) || defined(WIN32_WINDOWS) || defined(NEXTAPP))
  12184.           case strmtype_terminal:
  12185.           #endif
  12186.           #ifdef HANDLES
  12187.           case strmtype_handle:
  12188.           #endif
  12189.             #if defined(UNIX) || defined(MSDOS) || defined(AMIGAOS) || defined(RISCOS)
  12190.             if (nullp(TheStream(stream)->strm_isatty))
  12191.               # Reguläre Files sind sicher nicht interaktiv.
  12192.               { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_ihandle);
  12193.                 #if defined(UNIX) || defined(MSDOS) || defined(RISCOS)
  12194.                 var struct stat statbuf;
  12195.                 begin_system_call();
  12196.                 if (!( fstat(handle,&statbuf) ==0)) { OS_error(); }
  12197.                 end_system_call();
  12198.                 if (S_ISREG(statbuf.st_mode))
  12199.                 #endif
  12200.                 #ifdef AMIGAOS
  12201.                 var reg3 LONG interactivep;
  12202.                 begin_system_call();
  12203.                 interactivep = IsInteractive(handle);
  12204.                 end_system_call();
  12205.                 if (!interactivep)
  12206.                 #endif
  12207.                   return FALSE;
  12208.               }
  12209.             #endif
  12210.           #endif
  12211.           #ifdef KEYBOARD
  12212.           case strmtype_keyboard:
  12213.           #endif
  12214.           #if defined(WINDOWS) || defined(WIN32_WINDOWS) || defined(NEXTAPP)
  12215.           case strmtype_terminal:
  12216.           #endif
  12217.           case strmtype_buff_in:
  12218.           #ifdef PIPES
  12219.           case strmtype_pipe_in:
  12220.           #endif
  12221.           #ifdef GENERIC_STREAMS
  12222.           case strmtype_generic:
  12223.           #endif
  12224.             return TRUE;
  12225.           case strmtype_synonym:
  12226.             # Synonym-Stream: weiterverfolgen
  12227.             { var reg2 object symbol = TheStream(stream)->strm_synonym_symbol;
  12228.               stream = get_synonym_stream(symbol);
  12229.               /* return interactive_stream_p(stream); */ # entrekursiviert:
  12230.               goto start;
  12231.             }
  12232.           case strmtype_concat:
  12233.             # den ersten der Streams abfragen:
  12234.             { var reg2 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams
  12235.               if (consp(streamlist))
  12236.                 { stream = Car(streamlist);
  12237.                   /* return interactive_stream_p(stream); */ # entrekursiviert:
  12238.                   goto start;
  12239.                 }
  12240.                 else
  12241.                 { return FALSE; }
  12242.             }
  12243.           case strmtype_twoway:
  12244.           case strmtype_echo:
  12245.             { # Two-Way-Stream oder Echo-Stream: Input-Stream anschauen
  12246.               stream = TheStream(stream)->strm_twoway_input;
  12247.               /* return interactive_stream_p(stream); */ # entrekursiviert:
  12248.               goto start;
  12249.             }
  12250.           case strmtype_sch_file:
  12251.           case strmtype_ch_file:
  12252.           case strmtype_iu_file:
  12253.           case strmtype_is_file:
  12254.           case strmtype_str_in:
  12255.           default:
  12256.             return FALSE;
  12257.     }   }
  12258.  
  12259. LISPFUNN(interactive_stream_p,1)
  12260. # (INTERACTIVE-STREAM-P stream), CLTL2 S. 507/508
  12261. # stellt fest, ob stream interaktiv ist.
  12262.   { value1 = (interactive_stream_p(popSTACK()) ? T : NIL); mv_count=1; }
  12263.  
  12264. # UP: Schließt einen Stream.
  12265. # stream_close(&stream);
  12266. # > stream: Stream
  12267. # < stream: Stream
  12268. # kann GC auslösen
  12269.   global void stream_close (object* stream_);
  12270.   global void stream_close(stream_)
  12271.     var reg2 object* stream_;
  12272.     { var reg1 object stream = *stream_;
  12273.       if ((TheStream(stream)->strmflags & strmflags_open_B) == 0) # Stream schon geschlossen?
  12274.         return;
  12275.       # Typspezifische Routine aufrufen (darf GC auslösen):
  12276.       switch (TheStream(stream)->strmtype)
  12277.         {
  12278.           #ifdef KEYBOARD
  12279.           case strmtype_keyboard: break;
  12280.           #endif
  12281.           case strmtype_terminal: break;
  12282.           case strmtype_sch_file:
  12283.           case strmtype_ch_file:
  12284.           case strmtype_iu_file:
  12285.           case strmtype_is_file:
  12286.             close_file(stream); break;
  12287.           case strmtype_synonym:
  12288.             close_synonym(stream); break; # X3J13_014 sagt: nichtrekursiv
  12289.           case strmtype_broad: break; # nichtrekursiv
  12290.           case strmtype_concat: break; # nichtrekursiv
  12291.           case strmtype_twoway: break; # nichtrekursiv
  12292.           case strmtype_echo: break; # nichtrekursiv
  12293.           case strmtype_str_in:
  12294.             close_str_in(stream); break;
  12295.           case strmtype_str_out: break;
  12296.           case strmtype_str_push: break;
  12297.           case strmtype_pphelp: break;
  12298.           case strmtype_buff_in:
  12299.             close_buff_in(stream); break;
  12300.           case strmtype_buff_out:
  12301.             close_buff_out(stream); break;
  12302.           #ifdef SCREEN
  12303.           case strmtype_window:
  12304.             close_window(stream); break;
  12305.           #endif
  12306.           #ifdef PRINTER_AMIGAOS
  12307.           case strmtype_printer:
  12308.             close_printer(stream); break;
  12309.           #endif
  12310.           #ifdef HANDLES
  12311.           case strmtype_handle:
  12312.             close_handle(stream); break;
  12313.           #endif
  12314.           #ifdef PIPES
  12315.           case strmtype_pipe_in:
  12316.             close_pipe_in(stream); break;
  12317.           case strmtype_pipe_out:
  12318.             close_pipe_out(stream); break;
  12319.           #endif
  12320.           #ifdef XSOCKETS
  12321.           case strmtype_xsocket:
  12322.             close_xsocket(stream); break;
  12323.           #endif
  12324.           #ifdef GENERIC_STREAMS
  12325.           case strmtype_generic:
  12326.             close_generic(stream); break;
  12327.           #endif
  12328.           #ifdef SOCKET_STREAMS
  12329.           case strmtype_socket:
  12330.             close_socket(stream); break;
  12331.           #endif
  12332.           default: NOTREACHED
  12333.         }
  12334.       # Dummys eintragen:
  12335.       close_dummys(*stream_);
  12336.     }
  12337.  
  12338. # UP: Schließt eine Liste offener Files.
  12339. # close_some_files(list);
  12340. # > list: Liste von offenen Streams
  12341. # kann GC auslösen
  12342.   global void close_some_files (object list);
  12343.   global void close_some_files(list)
  12344.     var reg2 object list;
  12345.     { pushSTACK(NIL); # dummy
  12346.       pushSTACK(list); # list
  12347.       while (mconsp(STACK_0))
  12348.         { var reg1 object streamlist = STACK_0;
  12349.           STACK_0 = Cdr(streamlist); # restliche Streams
  12350.           STACK_1 = Car(streamlist); # ein Stream aus der Liste
  12351.           stream_close(&STACK_1); # schließen
  12352.         }
  12353.       skipSTACK(2);
  12354.     }
  12355.  
  12356. # UP: Schließt alle offenen Files.
  12357. # close_all_files();
  12358. # kann GC auslösen
  12359.   global void close_all_files (void);
  12360.   global void close_all_files()
  12361.     { close_some_files(O(open_files)); } # Liste aller offenen File-Streams
  12362.  
  12363. # UP: Erklärt alle offenen File-Streams für geschlossen.
  12364. # closed_all_files();
  12365.   global void closed_all_files (void);
  12366.   global void closed_all_files()
  12367.     { var reg2 object streamlist = O(open_files); # Liste aller offenen File-Streams
  12368.       while (consp(streamlist))
  12369.         { var reg1 object stream = Car(streamlist); # ein Stream aus der Liste
  12370.           if_strm_bfile_p(stream, # File-Stream ?
  12371.             { if (!nullp(TheStream(stream)->strm_file_handle)) # mit Handle /= NIL ?
  12372.                 # ja: Stream noch offen
  12373.                 { closed_file(stream); }
  12374.             },
  12375.             ; );
  12376.           close_dummys(stream);
  12377.           streamlist = Cdr(streamlist); # restliche Streams
  12378.         }
  12379.       O(open_files) = NIL; # keine offenen Files mehr
  12380.     }
  12381.  
  12382. LISPFUN(close,1,0,norest,key,1, (kw(abort)) )
  12383. # (CLOSE stream :abort), CLTL S. 332
  12384.   { skipSTACK(1); # :ABORT-Argument ignorieren
  12385.    {var reg1 object stream = STACK_0; # Argument
  12386.     if (!streamp(stream)) { fehler_stream(stream); } # muß ein Stream sein
  12387.     stream_close(&STACK_0); # schließen
  12388.     skipSTACK(1);
  12389.     value1 = T; mv_count=1; # T als Ergebnis
  12390.   }}
  12391.  
  12392. # UP: Stellt fest, ob im Stream stream ein Zeichen sofort verfügbar ist.
  12393. # stream_listen(stream)
  12394. # > stream: Stream
  12395. # < ergebnis:  0 falls Zeichen verfügbar,
  12396. #             -1 falls bei EOF angelangt,
  12397. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  12398. # kann GC auslösen
  12399.   global signean stream_listen (object stream);
  12400.   global signean stream_listen(stream)
  12401.     var reg1 object stream;
  12402.     { check_SP(); check_STACK();
  12403.       if (mposfixnump(TheStream(stream)->strm_rd_ch_last)) # Char nach UNREAD ?
  12404.         { return signean_null; } # ja -> verfügbar
  12405.         else
  12406.         # sonst nach Streamtyp verzweigen.
  12407.         # Jede Einzelroutine darf GC auslösen. Außer beim Keyboard-Stream
  12408.         # oder Terminal-Stream handelt es sich um einen reinen EOF-Test.
  12409.         { switch (TheStream(stream)->strmtype)
  12410.             {
  12411.               #ifdef KEYBOARD
  12412.               case strmtype_keyboard: return listen_keyboard(stream);
  12413.               #endif
  12414.               case strmtype_terminal:
  12415.                 #if defined(WINDOWS) || defined(WIN32_WINDOWS) || defined(NEXTAPP)
  12416.                 return listen_terminal(stream);
  12417.                 #endif
  12418.                 #if (defined(UNIX) && !defined(NEXTAPP)) || (defined(MSDOS) && !defined(WINDOWS) && !defined(WIN32_WINDOWS)) || defined(AMIGAOS) || defined(RISCOS)
  12419.                 terminalcase(stream,
  12420.                              { return listen_terminal1(stream); },
  12421.                              { return listen_terminal2(stream); },
  12422.                              { return listen_terminal3(stream); }
  12423.                             );
  12424.                 #endif
  12425.                 NOTREACHED
  12426.               case strmtype_sch_file:
  12427.                 if (TheStream(stream)->strmflags & strmflags_rd_ch_B)
  12428.                   { return listen_sch_file(stream); }
  12429.                   else
  12430.                   { return signean_minus; } # kein READ-CHAR
  12431.               case strmtype_ch_file:
  12432.                 if (TheStream(stream)->strmflags & strmflags_rd_ch_B)
  12433.                   { return listen_ch_file(stream); }
  12434.                   else
  12435.                   { return signean_minus; } # kein READ-CHAR
  12436.               case strmtype_iu_file:  return signean_minus; # kein READ-CHAR
  12437.               case strmtype_is_file:  return signean_minus; # kein READ-CHAR
  12438.               case strmtype_synonym:  return listen_synonym(stream);
  12439.               case strmtype_broad:    return signean_minus; # kein READ-CHAR
  12440.               case strmtype_concat:   return listen_concat(stream);
  12441.               case strmtype_twoway:   return listen_twoway(stream);
  12442.               case strmtype_echo:     return listen_twoway(stream);
  12443.               case strmtype_str_in:   return listen_str_in(stream);
  12444.               case strmtype_str_out:  return signean_minus; # kein READ-CHAR
  12445.               case strmtype_str_push: return signean_minus; # kein READ-CHAR
  12446.               case strmtype_pphelp:   return signean_minus; # kein READ-CHAR
  12447.               case strmtype_buff_in:  return listen_buff_in(stream);
  12448.               case strmtype_buff_out: return signean_minus; # kein READ-CHAR
  12449.               #ifdef SCREEN
  12450.               case strmtype_window:   return signean_minus; # kein READ-CHAR
  12451.               #endif
  12452.               #ifdef PRINTER
  12453.               case strmtype_printer:  return signean_minus; # kein READ-CHAR
  12454.               #endif
  12455.               #ifdef HANDLES
  12456.               case strmtype_handle:
  12457.                 if (TheStream(stream)->strmflags & strmflags_rd_ch_B)
  12458.                   { return listen_handle(stream); }
  12459.                   else
  12460.                   { return signean_minus; } # kein READ-CHAR
  12461.               #endif
  12462.               #ifdef PIPES
  12463.               case strmtype_pipe_in:  return listen_pipe_in(stream);
  12464.               case strmtype_pipe_out: return signean_minus; # kein READ-CHAR
  12465.               #endif
  12466.               #ifdef XSOCKETS
  12467.               case strmtype_xsocket:   return listen_xsocket(stream);
  12468.               #endif
  12469.               #ifdef GENERIC_STREAMS
  12470.               case strmtype_generic:  return listen_generic(stream);
  12471.               #endif
  12472.               #ifdef SOCKET_STREAMS
  12473.               case strmtype_socket:   return listen_socket(stream);
  12474.               #endif
  12475.               default: # Allgemein: nur EOF abfragen
  12476.                 if (TheStream(stream)->strmflags & strmflags_rd_ch_B)
  12477.                   { pushSTACK(stream);
  12478.                    {var reg2 object nextchar = peek_char(&STACK_0);
  12479.                     skipSTACK(1);
  12480.                     if (eq(nextchar,eof_value))
  12481.                       { return signean_minus; } # EOF erreicht
  12482.                       else
  12483.                       { return signean_null; }
  12484.                   }}
  12485.                   else
  12486.                   { return signean_minus; } # kein READ-CHAR
  12487.     }   }   }
  12488.  
  12489. # UP: Löscht bereits eingegebenen interaktiven Input von einem Stream stream.
  12490. # clear_input(stream)
  12491. # > stream: Stream
  12492. # < ergebnis: TRUE falls Input gelöscht wurde
  12493. # kann GC auslösen
  12494.   global boolean clear_input (object stream);
  12495.   global boolean clear_input(stream)
  12496.     var reg1 object stream;
  12497.     { check_SP(); check_STACK();
  12498.       pushSTACK(stream); # Stream retten
  12499.       # Typspezifische Routine aufrufen (darf GC auslösen).
  12500.       # Nur beim Keyboard-Stream und Terminal-Stream wird etwas getan.
  12501.      {var reg2 boolean ergebnis;
  12502.       switch (TheStream(stream)->strmtype)
  12503.         {
  12504.           #ifdef KEYBOARD
  12505.           case strmtype_keyboard:
  12506.             ergebnis = clear_input_keyboard(stream); break;
  12507.           #endif
  12508.           case strmtype_terminal:
  12509.             #if defined(WINDOWS) || defined(WIN32_WINDOWS) || defined(NEXTAPP)
  12510.             ergebnis = clear_input_terminal(stream);
  12511.             #endif
  12512.             #if (defined(UNIX) && !defined(NEXTAPP)) || (defined(MSDOS) && !defined(WINDOWS) && !defined(WIN32_WINDOWS)) || defined(AMIGAOS) || defined(RISCOS)
  12513.             terminalcase(stream,
  12514.                          { ergebnis = clear_input_terminal1(stream); },
  12515.                          { ergebnis = clear_input_terminal2(stream); },
  12516.                          { ergebnis = clear_input_terminal3(stream); }
  12517.                         );
  12518.             #endif
  12519.             break;
  12520.           case strmtype_synonym:
  12521.             ergebnis = clear_input_synonym(stream); break;
  12522.           case strmtype_concat:
  12523.             ergebnis = clear_input_concat(stream); break;
  12524.           case strmtype_twoway:
  12525.           case strmtype_echo:
  12526.             ergebnis = clear_input_twoway(stream); break;
  12527.           case strmtype_buff_in:
  12528.             ergebnis = clear_input_buff_in(stream); break;
  12529.           #ifdef HANDLES
  12530.           case strmtype_handle:
  12531.             if (TheStream(stream)->strmflags & strmflags_rd_ch_B)
  12532.               { ergebnis = clear_input_handle(stream); }
  12533.               else
  12534.               { ergebnis = FALSE; }
  12535.             break;
  12536.           #endif
  12537.           #ifdef GENERIC_STREAMS
  12538.           case strmtype_generic:
  12539.             ergebnis = clear_input_generic(stream); break;
  12540.           #endif
  12541.           #ifdef PIPES
  12542.           case strmtype_pipe_in: # Pipe: nichts löschen??
  12543.           #endif
  12544.           #ifdef XSOCKETS
  12545.           case strmtype_xsocket: # Socket: nichts löschen??
  12546.           #endif
  12547.           #ifdef SOCKET_STREAMS
  12548.           case strmtype_socket:
  12549.           #endif
  12550.           default:
  12551.             ergebnis = FALSE; break;
  12552.         }
  12553.       stream = popSTACK();
  12554.       if (ergebnis)
  12555.         # Input wurde gelöscht -> auch das Lastchar muß gelöscht werden.
  12556.         # Dabei wird auch ein schon gesehenes EOF vergessen.
  12557.         { TheStream(stream)->strm_rd_ch_last = NIL; }
  12558.       return ergebnis;
  12559.     }}
  12560.  
  12561. # UP: Wartenden Output eines Stream stream ans Ziel bringen.
  12562. # finish_output(stream);
  12563. # > stream: Stream
  12564. # kann GC auslösen
  12565.   global void finish_output (object stream);
  12566.   global void finish_output(stream)
  12567.     var reg1 object stream;
  12568.     { if (TheStream(stream)->strmflags & strmflags_wr_B) # Output-Stream?
  12569.         # nein -> fertig, ja -> nach Streamtyp verzweigen:
  12570.         { switch (TheStream(stream)->strmtype)
  12571.             { case strmtype_terminal:
  12572.                 finish_output_terminal(stream); break;
  12573.               case strmtype_sch_file:
  12574.               case strmtype_ch_file:
  12575.               case strmtype_iu_file:
  12576.               case strmtype_is_file:
  12577.                 finish_output_file(stream); break;
  12578.               case strmtype_synonym:
  12579.                 finish_output_synonym(stream); break;
  12580.               case strmtype_broad:
  12581.                 finish_output_broad(stream); break;
  12582.               case strmtype_twoway:
  12583.               case strmtype_echo:
  12584.                 finish_output_twoway(stream); break;
  12585.               case strmtype_buff_out:
  12586.                 finish_output_buff_out(stream); break;
  12587.               #ifdef PRINTER_AMIGAOS
  12588.               case strmtype_printer: # Printer:
  12589.                 # Schließen und neu aufmachen würde vermutlich einen
  12590.                 # Seitenvorschub ausgeben, und das ist ja wohl nicht erwünscht.
  12591.                 break; # Daher nichts tun.
  12592.               #endif
  12593.               #ifdef HANDLES
  12594.               case strmtype_handle:
  12595.                 finish_output_handle(stream); break;
  12596.               #endif
  12597.               #ifdef GENERIC_STREAMS
  12598.               case strmtype_generic:
  12599.                 finish_output_generic(stream); break;
  12600.               #endif
  12601.               #ifdef PIPES
  12602.               case strmtype_pipe_out: # Pipe: kann nichts tun
  12603.               #endif
  12604.               #ifdef XSOCKETS
  12605.               case strmtype_xsocket: # Socket: kann nichts tun
  12606.               #endif
  12607.               #ifdef SOCKET_STREAMS
  12608.               case strmtype_socket:
  12609.               #endif
  12610.               default: # nichts tun
  12611.                 break;
  12612.         }   }
  12613.     }
  12614.  
  12615. # UP: Wartenden Output eines Stream stream ans Ziel bringen.
  12616. # force_output(stream);
  12617. # > stream: Stream
  12618. # kann GC auslösen
  12619.   global void force_output (object stream);
  12620.   global void force_output(stream)
  12621.     var reg1 object stream;
  12622.     { if (TheStream(stream)->strmflags & strmflags_wr_B) # Output-Stream?
  12623.         # nein -> fertig, ja -> nach Streamtyp verzweigen:
  12624.         { switch (TheStream(stream)->strmtype)
  12625.             { case strmtype_terminal:
  12626.                 force_output_terminal(stream); break;
  12627.               case strmtype_sch_file:
  12628.               case strmtype_ch_file:
  12629.               case strmtype_iu_file:
  12630.               case strmtype_is_file:
  12631.                 force_output_file(stream); break;
  12632.               case strmtype_synonym:
  12633.                 force_output_synonym(stream); break;
  12634.               case strmtype_broad:
  12635.                 force_output_broad(stream); break;
  12636.               case strmtype_twoway:
  12637.               case strmtype_echo:
  12638.                 force_output_twoway(stream); break;
  12639.               case strmtype_buff_out:
  12640.                 force_output_buff_out(stream); break;
  12641.               #ifdef PRINTER_AMIGAOS
  12642.               case strmtype_printer: # Printer:
  12643.                 # Schließen und neu aufmachen würde vermutlich einen
  12644.                 # Seitenvorschub ausgeben, und das ist ja wohl nicht erwünscht.
  12645.                 break; # Daher nichts tun.
  12646.               #endif
  12647.               #ifdef HANDLES
  12648.               case strmtype_handle:
  12649.                 force_output_handle(stream); break;
  12650.               #endif
  12651.               #ifdef GENERIC_STREAMS
  12652.               case strmtype_generic:
  12653.                 force_output_generic(stream); break;
  12654.               #endif
  12655.               #ifdef PIPES
  12656.               case strmtype_pipe_out: # Pipe: kann nichts tun
  12657.               #endif
  12658.               #ifdef XSOCKETS
  12659.               case strmtype_xsocket: # Socket: kann nichts tun
  12660.               #endif
  12661.               #ifdef SOCKET_STREAMS
  12662.               case strmtype_socket:
  12663.               #endif
  12664.               default: # nichts tun
  12665.                 break;
  12666.         }   }
  12667.     }
  12668.  
  12669. # UP: Wartenden Output eines Stream stream löschen.
  12670. # clear_output(stream);
  12671. # > stream: Stream
  12672. # kann GC auslösen
  12673.   global void clear_output (object stream);
  12674.   global void clear_output(stream)
  12675.     var reg1 object stream;
  12676.     { # Unter DOS ist zwar bei keinem File- oder Terminal-Stream etwas zu tun,
  12677.       # aber das kann man nicht ausnutzen, denn clear_output auf
  12678.       # Buffered-Output-Streams geht immer.
  12679.       if (TheStream(stream)->strmflags & strmflags_wr_B) # Output-Stream?
  12680.         # nein -> fertig, ja -> nach Streamtyp verzweigen:
  12681.         { switch (TheStream(stream)->strmtype)
  12682.             { case strmtype_terminal:
  12683.                 #if (defined(UNIX) && !defined(NEXTAPP)) || (defined(MSDOS) && !defined(WINDOWS) && !defined(WIN32_WINDOWS)) || defined(AMIGAOS) || defined(RISCOS)
  12684.                 terminalcase(stream,
  12685.                              { clear_output_terminal1(stream); },
  12686.                              { clear_output_terminal2(stream); },
  12687.                              { clear_output_terminal3(stream); }
  12688.                             );
  12689.                 #endif
  12690.                 break;
  12691.               case strmtype_sch_file:
  12692.               case strmtype_ch_file:
  12693.               case strmtype_iu_file:
  12694.               case strmtype_is_file:
  12695.                 # File: nichts tun (würde die File-Verwaltung durcheinanderbringen)
  12696.                 break;
  12697.               case strmtype_synonym:
  12698.                 clear_output_synonym(stream); break;
  12699.               case strmtype_broad:
  12700.                 clear_output_broad(stream); break;
  12701.               case strmtype_twoway:
  12702.               case strmtype_echo:
  12703.                 clear_output_twoway(stream); break;
  12704.               case strmtype_buff_out:
  12705.                 clear_output_buff_out(stream); break;
  12706.               #ifdef PRINTER_AMIGAOS
  12707.               case strmtype_printer: # Printer: ungebuffert, also nichts zu tun
  12708.                 break;
  12709.               #endif
  12710.               #ifdef HANDLES
  12711.               case strmtype_handle:
  12712.                 clear_output_handle(stream); break;
  12713.               #endif
  12714.               #ifdef PIPES
  12715.               case strmtype_pipe_out: # Pipe: geht nicht
  12716.                 break;
  12717.               #endif
  12718.               #ifdef XSOCKETS
  12719.               case strmtype_xsocket: # Socket: geht nicht
  12720.                 break;
  12721.               #endif
  12722.               #ifdef GENERIC_STREAMS
  12723.               case strmtype_generic:
  12724.                 clear_output_generic(stream);
  12725.                 break;
  12726.               #endif
  12727.               #ifdef SOCKET_STREAMS
  12728.               case strmtype_socket:
  12729.                 break;
  12730.               #endif
  12731.               default: # nichts tun
  12732.                 break;
  12733.         }   }
  12734.     }
  12735.  
  12736. # UP: Liefert die Line-Position eines Streams.
  12737. # get_line_position(stream)
  12738. # > stream: Stream
  12739. # < ergebnis: Line-Position (Fixnum >=0)
  12740.   global object get_line_position (object stream);
  12741.   global object get_line_position(stream)
  12742.     var reg1 object stream;
  12743.     { check_SP();
  12744.       start:
  12745.       switch (TheStream(stream)->strmtype)
  12746.         { case strmtype_synonym:
  12747.             # Synonym-Stream: weiterverfolgen
  12748.             { var reg2 object symbol = TheStream(stream)->strm_synonym_symbol;
  12749.               stream = get_synonym_stream(symbol);
  12750.               /* return get_line_position(stream); */ # entrekursiviert:
  12751.               goto start;
  12752.             }
  12753.           case strmtype_broad:
  12754.             # Broadcast-Stream:
  12755.             # Maximum der Line-Positions der einzelnen Streams
  12756.             { var reg2 object streamlist = TheStream(stream)->strm_broad_list;
  12757.               var reg3 uintL maximum = 0; # bisheriges Maximum := 0
  12758.               while (consp(streamlist))
  12759.                 { var reg4 uintL next = # Line-Position des nächsten Teilstreams
  12760.                     posfixnum_to_L(get_line_position(Car(streamlist)));
  12761.                   if (next > maximum) { maximum = next; } # Maximum nehmen
  12762.                   streamlist = Cdr(streamlist);
  12763.                 }
  12764.               return fixnum(maximum); # Maximum als Ergebnis
  12765.             }
  12766.           case strmtype_twoway:
  12767.           case strmtype_echo:
  12768.             { # Two-Way-Stream oder Echo-Stream: Output-Stream anschauen
  12769.               stream = TheStream(stream)->strm_twoway_output;
  12770.               /* return get_line_position(stream); */ # entrekursiviert:
  12771.               goto start;
  12772.             }
  12773.           default: # normaler Stream
  12774.             return TheStream(stream)->strm_wr_ch_lpos;
  12775.     }   }
  12776.  
  12777. # UP: Liest mehrere Bytes von einem Stream.
  12778. # read_byte_array(stream,byteptr,len)
  12779. # > stream: Stream
  12780. # > uintB* byteptr: Adresse der zu füllenden Bytefolge
  12781. # > uintL len: Länge der zu füllenden Bytefolge
  12782. # < uintB* ergebnis: Pointer ans Ende des gefüllten Bereiches oder NULL
  12783.   global uintB* read_byte_array (object stream, uintB* byteptr, uintL len);
  12784.   global uintB* read_byte_array(stream,byteptr,len)
  12785.     var reg1 object stream;
  12786.     var reg3 uintB* byteptr;
  12787.     var reg2 uintL len;
  12788.     { if (len==0) { return byteptr; }
  12789.       start:
  12790.       if (eq(TheStream(stream)->strm_rd_by,P(rd_by_synonym))) # synonym
  12791.         { stream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol);
  12792.           goto start;
  12793.         }
  12794.       elif (eq(TheStream(stream)->strm_rd_by,P(rd_by_twoway))) # twoway
  12795.         { stream = TheStream(stream)->strm_twoway_input;
  12796.           goto start;
  12797.         }
  12798.       #if defined(HANDLES) || defined(XSOCKETS) || defined(SOCKET_STREAMS)
  12799.       elif (eq(TheStream(stream)->strm_rd_by,P(rd_by_handle))) # handle, socket
  12800.         { var reg5 Handle handle = TheHandle(TheStream(stream)->strm_ihandle);
  12801.           begin_system_call();
  12802.           loop
  12803.             {
  12804.               #if !defined(AMIGAOS)
  12805.               var reg4 int ergebnis = full_read(handle,byteptr,len);
  12806.               if (ergebnis<0)
  12807.                 { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  12808.                     { end_system_call();
  12809.                       pushSTACK(S(read_byte_sequence));
  12810.                       //: DEUTSCH "~: Ctrl-C: Tastatur-Interrupt"
  12811.                       //: ENGLISH "~: Ctrl-C: User break"
  12812.                       //: FRANCAIS "~ : Ctrl-C : Interruption clavier"
  12813.                       fehler(serious_condition,GETTEXT("~: Ctrl-C: User break"));
  12814.                     }
  12815.                   OS_error(); # Error melden
  12816.                 }
  12817.               #else # defined(AMIGAOS)
  12818.               var reg4 long ergebnis = Read(handle,byteptr,len);
  12819.               if (ergebnis<0) { OS_error(); } # Error melden
  12820.               #endif
  12821.               if (ergebnis==0) break; # EOF -> fertig
  12822.               byteptr += ergebnis; len -= ergebnis;
  12823.               if (len==0) break; # fertig?
  12824.             }
  12825.           end_system_call();
  12826.           return byteptr;
  12827.         }
  12828.       #endif
  12829.       elif (eq(TheStream(stream)->strm_rd_by,P(rd_by_iau_file)) # file
  12830.             && eq(TheStream(stream)->strm_file_bitsize,fixnum(8)) # eltype = (UNSIGNED-BYTE 8)
  12831.            )
  12832.         { dotimespL(len,len,
  12833.             { var reg4 uintB* ptr = b_file_nextbyte(stream);
  12834.               if (ptr == (uintB*)NULL) break;
  12835.               *byteptr++ = *ptr;
  12836.               # index und position incrementieren:
  12837.               TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  12838.               TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  12839.             });
  12840.           return byteptr;
  12841.         }
  12842.       else # keine Optimierung möglich
  12843.         { return NULL; }
  12844.     }
  12845.  
  12846. # UP: Schreibt mehrere Bytes auf einen Stream.
  12847. # write_byte_array(stream,byteptr,len)
  12848. # > stream: Stream
  12849. # > uintB* byteptr: Adresse der zu schreibenden Bytefolge
  12850. # > uintL len: Länge der zu schreibenden Bytefolge
  12851. # < uintB* ergebnis: Pointer ans Ende des geschriebenen Bereiches oder NULL
  12852.   global uintB* write_byte_array (object stream, uintB* byteptr, uintL len);
  12853.   global uintB* write_byte_array(stream,byteptr,len)
  12854.     var reg1 object stream;
  12855.     var reg3 uintB* byteptr;
  12856.     var reg2 uintL len;
  12857.     { if (len==0) { return byteptr; }
  12858.       start:
  12859.       if (eq(TheStream(stream)->strm_wr_by,P(wr_by_synonym))) # synonym
  12860.         { stream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol);
  12861.           goto start;
  12862.         }
  12863.       elif (eq(TheStream(stream)->strm_wr_by,P(wr_by_twoway))) # twoway, echo
  12864.         { stream = TheStream(stream)->strm_twoway_output;
  12865.           goto start;
  12866.         }
  12867.       #if defined(HANDLES) || defined(XSOCKETS) || defined(SOCKET_STREAMS)
  12868.       elif (eq(TheStream(stream)->strm_wr_by,P(wr_by_handle))) # handle, socket
  12869.         { var reg5 Handle handle = TheHandle(TheStream(stream)->strm_ohandle);
  12870.           begin_system_call();
  12871.           loop
  12872.             {
  12873.               #if !defined(AMIGAOS)
  12874.               var reg4 int ergebnis = full_write(handle,byteptr,len);
  12875.               if (ergebnis<0)
  12876.                 { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  12877.                     { end_system_call();
  12878.                       pushSTACK(S(write_byte_sequence));
  12879.                       //: DEUTSCH "~: Ctrl-C: Tastatur-Interrupt"
  12880.                       //: ENGLISH "~: Ctrl-C: User break"
  12881.                       //: FRANCAIS "~ : Ctrl-C : Interruption clavier"
  12882.                       fehler(serious_condition,GETTEXT("~: Ctrl-C: User break"));
  12883.                     }
  12884.                   OS_error(); # Error melden
  12885.                 }
  12886.               #else # defined(AMIGAOS)
  12887.               var reg4 long ergebnis = Write(handle,byteptr,len);
  12888.               if (ergebnis<0) { OS_error(); } # Error melden
  12889.               #endif
  12890.               if (ergebnis==0) # nicht erfolgreich?
  12891.                 { fehler_unwritable(S(write_byte_sequence),stream); }
  12892.               byteptr += ergebnis; len -= ergebnis;
  12893.               if (len==0) break; # fertig?
  12894.             }
  12895.           end_system_call();
  12896.           return byteptr;
  12897.         }
  12898.       #endif
  12899.       elif (eq(TheStream(stream)->strm_wr_by,P(wr_by_iau_file)) # file
  12900.             && eq(TheStream(stream)->strm_file_bitsize,fixnum(8)) # eltype = (UNSIGNED-BYTE 8)
  12901.            )
  12902.         { return write_byte_array_iau8_file(stream,byteptr,len); }
  12903.       else # keine Optimierung möglich
  12904.         { return NULL; }
  12905.     }
  12906.  
  12907. # UP: Liest mehrere String-Characters von einem Stream.
  12908. # read_schar_array(stream,charptr,len)
  12909. # > stream: Stream
  12910. # > uintB* charptr: Adresse der zu füllenden Zeichenfolge
  12911. # > uintL len: Länge der zu füllenden Zeichenfolge
  12912. # < uintB* ergebnis: Pointer ans Ende des gefüllten Bereiches oder NULL
  12913.   global uintB* read_schar_array (object stream, uintB* charptr, uintL len);
  12914.   global uintB* read_schar_array(stream,charptr,len)
  12915.     var reg4 object stream;
  12916.     var reg2 uintB* charptr;
  12917.     var reg3 uintL len;
  12918.     { if (len==0) { return charptr; }
  12919.      {var reg5 object lastchar = TheStream(stream)->strm_rd_ch_last;
  12920.       if (eq(lastchar,eof_value)) # EOF ?
  12921.         { return charptr; }
  12922.       if (posfixnump(lastchar) # Char nach UNREAD ?
  12923.           && !string_char_p(fixnum_to_char(lastchar)) # aber kein String-Char?
  12924.          )
  12925.         { return NULL; }
  12926.       if (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_synonym))) # synonym
  12927.         { var reg6 object substream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol);
  12928.           check_SP();
  12929.          {var reg1 uintB* endptr =
  12930.             (posfixnump(lastchar)
  12931.              ? read_schar_array(substream,charptr+1,len-1)
  12932.              : read_schar_array(substream,charptr,len)
  12933.             );
  12934.           if (endptr==NULL) { return NULL; }
  12935.           if (posfixnump(lastchar))
  12936.             { charptr[0] = char_code(fixnum_to_char(lastchar)); }
  12937.           TheStream(stream)->strm_rd_ch_last =
  12938.             (endptr == charptr+len ? code_char(endptr[-1]) : eof_value);
  12939.           return endptr;
  12940.         }}
  12941.       elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_twoway))) # twoway
  12942.         { var reg6 object substream = TheStream(stream)->strm_twoway_input;
  12943.           check_SP();
  12944.          {var reg1 uintB* endptr =
  12945.             (posfixnump(lastchar)
  12946.              ? read_schar_array(substream,charptr+1,len-1)
  12947.              : read_schar_array(substream,charptr,len)
  12948.             );
  12949.           if (endptr==NULL) { return NULL; }
  12950.           if (posfixnump(lastchar))
  12951.             { charptr[0] = char_code(fixnum_to_char(lastchar)); }
  12952.           TheStream(stream)->strm_rd_ch_last =
  12953.             (endptr == charptr+len ? code_char(endptr[-1]) : eof_value);
  12954.           return endptr;
  12955.         }}
  12956.       #ifdef XHANDLES
  12957.       elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_handle))) # handle, pipe_in, socket
  12958.         { if (posfixnump(lastchar))
  12959.             { *charptr++ = char_code(fixnum_to_char(lastchar)); len--; }
  12960.           if (len>0)
  12961.             { var reg6 Handle handle = TheHandle(TheStream(stream)->strm_ihandle);
  12962.               run_time_stop(); # Run-Time-Stoppuhr anhalten
  12963.               #ifdef GRAPHICS_SWITCH
  12964.               if (handle == stdin_handle) switch_text_mode();
  12965.               #endif
  12966.               begin_system_call();
  12967.               loop
  12968.                 {
  12969.                   #if !defined(AMIGAOS)
  12970.                   var reg1 int ergebnis = full_read(handle,charptr,len);
  12971.                   #else
  12972.                   var reg1 long ergebnis = Read(handle,charptr,len);
  12973.                   #endif
  12974.                   if (ergebnis<0)
  12975.                     {
  12976.                       #if !defined(AMIGAOS)
  12977.                       if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ?
  12978.                         { end_system_call();
  12979.                           run_time_restart();
  12980.                           pushSTACK(S(read_char_sequence));
  12981.                           //: DEUTSCH "~: Ctrl-C: Tastatur-Interrupt"
  12982.                           //: ENGLISH "~: Ctrl-C: User break"
  12983.                           //: FRANCAIS "~ : Ctrl-C : Interruption clavier"
  12984.                           fehler(serious_condition,GETTEXT("~: Ctrl-C: User break"));
  12985.                         }
  12986.                       #endif
  12987.                       OS_error(); # Error melden
  12988.                     }
  12989.                   if (ergebnis==0) break; # EOF -> fertig
  12990.                   charptr += ergebnis; len -= ergebnis;
  12991.                   if (len==0) break; # fertig?
  12992.                 }
  12993.               end_system_call();
  12994.               run_time_restart();
  12995.             }
  12996.           TheStream(stream)->strm_rd_ch_last =
  12997.             (len==0 ? code_char(charptr[-1]) : eof_value);
  12998.           return charptr;
  12999.         }
  13000.       #endif
  13001.       elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_sch_file))) # file
  13002.         { if (posfixnump(lastchar))
  13003.             { *charptr++ = char_code(fixnum_to_char(lastchar)); len--; }
  13004.           while (len>0)
  13005.             { var reg1 uintB* ptr = b_file_nextbyte(stream);
  13006.               if (ptr == (uintB*)NULL) break; # EOF -> fertig
  13007.              {var reg6 uintB ch = *ptr;
  13008.               # index und position incrementieren:
  13009.               TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  13010.               TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  13011.               # CR/LF -> NL umwandeln:
  13012.               if (ch==CR)
  13013.                 { # nächstes Zeichen auf LF untersuchen
  13014.                   ptr = b_file_nextbyte(stream);
  13015.                   if (!(ptr == (uintB*)NULL) && (*ptr == LF))
  13016.                     { # index und position incrementieren:
  13017.                       TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1);
  13018.                       TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1);
  13019.                       ch = NL;
  13020.                 }   }
  13021.               if (ch==NL)
  13022.                 # lineno incrementieren:
  13023.                 { TheStream(stream)->strm_sch_file_lineno = fixnum_inc(TheStream(stream)->strm_sch_file_lineno,1); }
  13024.               *charptr++ = ch; len--;
  13025.             }}
  13026.           TheStream(stream)->strm_rd_ch_last =
  13027.             (len==0 ? code_char(charptr[-1]) : eof_value);
  13028.           return charptr;
  13029.         }
  13030.       elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_str_in))) # str_in
  13031.         { if (posfixnump(lastchar))
  13032.             { *charptr++ = char_code(fixnum_to_char(lastchar)); len--; }
  13033.           if (len>0)
  13034.             { var reg7 uintL index = posfixnum_to_L(TheStream(stream)->strm_str_in_index); # Index
  13035.               var reg8 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_str_in_endindex);
  13036.               if (index < endindex)
  13037.                 { var uintL srclen;
  13038.                   var reg1 uintB* srcptr = unpack_string(TheStream(stream)->strm_str_in_string,&srclen);
  13039.                   # Ab srcptr kommen srclen Zeichen.
  13040.                   if (srclen < endindex) { fehler_str_in_adjusted(stream); }
  13041.                   srcptr += index;
  13042.                  {var reg6 uintL count = endindex - index;
  13043.                   if (count > len) { count = len; }
  13044.                   # count = min(len,endindex-index) > 0.
  13045.                   len -= count;
  13046.                   dotimespL(count,count, { *charptr++ = *srcptr++; } );
  13047.             }   }}
  13048.           TheStream(stream)->strm_rd_ch_last =
  13049.             (len==0 ? code_char(charptr[-1]) : eof_value);
  13050.           return charptr;
  13051.         }
  13052.       else # keine Optimierung möglich
  13053.         { return NULL; }
  13054.     }}
  13055.  
  13056. # UP: Schreibt mehrere String-Characters auf einen Stream.
  13057. # write_schar_array(stream,charptr,len)
  13058. # > stream: Stream
  13059. # > uintB* charptr: Adresse der zu schreibenden Zeichenfolge
  13060. # > uintL len: Länge der zu schreibenden Zeichenfolge
  13061. # < uintB* ergebnis: Pointer ans Ende des geschriebenen Bereiches oder NULL
  13062.   global uintB* write_schar_array (object stream, uintB* charptr, uintL len);
  13063.   global uintB* write_schar_array(stream,charptr,len)
  13064.     var reg4 object stream;
  13065.     var reg2 uintB* charptr;
  13066.     var reg3 uintL len;
  13067.     { if (len==0) { return charptr; }
  13068.       start:
  13069.       if (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_synonym))) # synonym
  13070.         { stream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol);
  13071.           goto start;
  13072.           # Line-Position aktualisieren kann hier entfallen.
  13073.         }
  13074.       elif (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_twoway))) # twoway, echo
  13075.         { stream = TheStream(stream)->strm_twoway_output;
  13076.           goto start;
  13077.           # Line-Position aktualisieren kann hier entfallen.
  13078.         }
  13079.       #ifdef XHANDLES
  13080.       elif (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_handle))) # handle, pipe_out, socket
  13081.         { return write_schar_array_handle(stream,charptr,len); }
  13082.       #endif
  13083.       elif (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_sch_file))) # file
  13084.         { return write_schar_array_sch_file(stream,charptr,len); }
  13085.       else # keine Optimierung möglich
  13086.         { return NULL; }
  13087.     }
  13088.  
  13089. LISPFUN(read_byte,1,2,norest,nokey,0,NIL)
  13090. # (READ-BYTE stream [eof-error-p [eof-value]]), CLTL S. 382
  13091.   { # Stream überprüfen:
  13092.     var reg1 object stream = STACK_2;
  13093.     if (!streamp(stream)) { fehler_stream(stream); }
  13094.     # Integer lesen:
  13095.    {var reg2 object obj = read_byte(stream);
  13096.     if (eq(obj,eof_value))
  13097.       # EOF-Behandlung
  13098.       { if (!nullp(STACK_1)) # eof-error-p /= NIL (z.B. = #<UNBOUND>) ?
  13099.           # Error melden:
  13100.           { pushSTACK(STACK_2); # Wert für Slot STREAM von STREAM-ERROR
  13101.             pushSTACK(STACK_(2+1)); # Stream
  13102.             pushSTACK(S(read_byte));
  13103.             //: DEUTSCH "~: Eingabestream ~ ist zu Ende."
  13104.             //: ENGLISH "~: input stream ~ has reached its end"
  13105.             //: FRANCAIS "~ : Arrivée en fin du «stream» d'entrée ~."
  13106.             fehler(end_of_file,GETTEXT("~: input stream ~ has reached its end"));
  13107.           }
  13108.           else
  13109.           # EOF verarzten:
  13110.           { var reg2 object eofval = STACK_0;
  13111.             if (eq(eofval,unbound)) { eofval = eof_value; } # Default ist #<EOF>
  13112.             value1 = eofval; mv_count=1; skipSTACK(3); # eofval als Wert
  13113.           }
  13114.       }
  13115.       else
  13116.       { value1 = obj; mv_count=1; skipSTACK(3); } # obj als Wert
  13117.   }}
  13118.  
  13119. LISPFUNN(write_byte,2)
  13120. # (WRITE-BYTE integer stream), CLTL S. 385
  13121.   { # Stream überprüfen:
  13122.     var reg1 object stream = STACK_0;
  13123.     if (!streamp(stream)) { fehler_stream(stream); }
  13124.    {# Integer überprüfen:
  13125.     var reg2 object obj = STACK_1;
  13126.     if (!integerp(obj)) { fehler_wr_integer(stream,obj); }
  13127.     # Integer schreiben:
  13128.     write_byte(stream,obj);
  13129.     value1 = STACK_1; mv_count=1; skipSTACK(2); # obj als Wert
  13130.   }}
  13131.  
  13132. # UP: Überprüft, ob ein Argument ein offener File-Stream ist.
  13133. # check_open_file_stream(obj);
  13134. # > obj: Argument
  13135. # > subr_self: Aufrufer (ein SUBR)
  13136.   local void check_open_file_stream (object obj);
  13137.   local void check_open_file_stream(obj)
  13138.     var reg1 object obj;
  13139.     { if (!streamp(obj)) goto fehler_bad_obj; # Stream ?
  13140.       if_strm_bfile_p(obj, ; , goto fehler_bad_obj; ); # Streamtyp File-Stream ?
  13141.       if ((TheStream(obj)->strmflags & strmflags_open_B) == 0) goto fehler_bad_obj; # Stream offen ?
  13142.       if (nullp(TheStream(obj)->strm_file_handle)) goto fehler_bad_obj; # und Handle /= NIL ?
  13143.       return; # ja -> OK
  13144.       fehler_bad_obj:
  13145.         pushSTACK(obj);
  13146.         pushSTACK(TheSubr(subr_self)->name);
  13147.         //: DEUTSCH "~: Argument muß ein offener File-Stream sein, nicht ~"
  13148.         //: ENGLISH "~: argument ~ is not an open file stream"
  13149.         //: FRANCAIS "~ : L'argument ~ doit être un «stream» ouvert de fichier et non ~."
  13150.         fehler(error,GETTEXT("~: argument ~ is not an open file stream"));
  13151.     }
  13152.  
  13153. LISPFUN(file_position,1,1,norest,nokey,0,NIL)
  13154. # (FILE-POSITION file-stream [position]), CLTL S. 425
  13155.   { var reg1 object position = popSTACK();
  13156.     var reg2 object stream = popSTACK();
  13157.     check_open_file_stream(stream); # stream überprüfen
  13158.     if (eq(position,unbound))
  13159.       # position nicht angegeben -> Position als Wert:
  13160.       { value1 = TheStream(stream)->strm_file_position; mv_count=1; }
  13161.       else
  13162.       { if (eq(position,S(Kstart)))
  13163.           # :START -> an den Anfang positionieren:
  13164.           { position_file_start(stream); }
  13165.         elif (eq(position,S(Kend)))
  13166.           # :END -> ans Ende positionieren:
  13167.           { position_file_end(stream); }
  13168.         elif (posfixnump(position))
  13169.           # an die angegebene Position positionieren:
  13170.           { position_file(stream,posfixnum_to_L(position)); }
  13171.         else
  13172.           # Unzulässiges Position-Argument
  13173.           { pushSTACK(position); # Wert für Slot DATUM von TYPE-ERROR
  13174.             pushSTACK(O(type_position)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  13175.             pushSTACK(position); pushSTACK(S(Kend)); pushSTACK(S(Kstart));
  13176.             pushSTACK(TheSubr(subr_self)->name);
  13177.             //: DEUTSCH "~: Position-Argument muß ~ oder ~ oder ein Fixnum >=0 sein, nicht ~"
  13178.             //: ENGLISH "~: position argument should be ~ or ~ or a nonnegative fixnum, not ~"
  13179.             //: FRANCAIS "~ : L'argument position doit être ~, ~ ou de type FIXNUM positif ou zéro, mais non ~."
  13180.             fehler(type_error,GETTEXT("~: position argument should be ~ or ~ or a nonnegative fixnum, not ~"));
  13181.           }
  13182.         value1 = T; mv_count=1; # Wert T
  13183.       }
  13184.   }
  13185.  
  13186. LISPFUNN(file_length,1)
  13187. # (FILE-LENGTH file-stream), CLTL S. 425
  13188.   { var reg1 object stream = popSTACK();
  13189.     check_open_file_stream(stream); # stream überprüfen
  13190.     # Position merken:
  13191.    {var reg2 object position = TheStream(stream)->strm_file_position;
  13192.     # ans Ende positionieren:
  13193.     position_file_end(stream);
  13194.     # Ende-Position merken:
  13195.     {var reg3 object endposition = TheStream(stream)->strm_file_position;
  13196.      # an die alte Position zurückpositionieren:
  13197.      position_file(stream,posfixnum_to_L(position));
  13198.      value1 = endposition; mv_count=1; # Ende-Position als Wert
  13199.   }}}
  13200.  
  13201. LISPFUNN(line_number,1)
  13202. # (SYS::LINE-NUMBER stream) liefert die aktuelle Zeilennummer (falls stream
  13203. # ein String-Char-File-Input-Stream ist, von dem nur gelesen wurde).
  13204.   { var reg1 object stream = popSTACK();
  13205.     if (!streamp(stream)) { fehler_stream(stream); } # stream überprüfen
  13206.     value1 = (TheStream(stream)->strmtype == strmtype_sch_file
  13207.               ? TheStream(stream)->strm_sch_file_lineno # aktuelle Zeilennummer
  13208.               : NIL                                     # NIL falls unbekannt
  13209.              );
  13210.     mv_count=1;
  13211.   }
  13212.  
  13213. # ==============================================================================
  13214.  
  13215. # Binärkompatibilität zwischen .mem-Files mit und ohne NEXTAPP erreichen:
  13216.   #ifdef MAYBE_NEXTAPP
  13217.     #ifndef NEXTAPP
  13218.       #define wr_ch_terminal  wr_ch_dummy
  13219.       #define rd_ch_terminal  rd_ch_dummy
  13220.     #else
  13221.       #define wr_ch_terminal1  wr_ch_dummy
  13222.       #define rd_ch_terminal1  rd_ch_dummy
  13223.       #define wr_ss_terminal1  wr_ss_dummy_nogc
  13224.     #endif
  13225.     #ifndef GNU_READLINE
  13226.       #define wr_ch_terminal3  wr_ch_dummy
  13227.       #define rd_ch_terminal3  rd_ch_dummy
  13228.       #define wr_ss_terminal3  wr_ss_dummy_nogc
  13229.     #endif
  13230.     #ifdef NEXTAPP
  13231.       #define wr_ch_window  wr_ch_dummy
  13232.     #endif
  13233.   #endif
  13234.  
  13235.   #if defined(WIN32_UNIX) || defined(WIN32_UNIX)
  13236.     #define wr_ch_window wr_ch_dummy
  13237.   #endif
  13238.  
  13239. # Tabelle aller Pseudofunktionen
  13240.   global struct pseudofun_tab_ pseudofun_tab =
  13241.     {
  13242.       #define PSEUDOFUN  PSEUDOFUN_B
  13243.       #include "pseudofun.c"
  13244.       #undef PSEUDOFUN
  13245.     };
  13246.  
  13247. # ==============================================================================
  13248.  
  13249. #ifdef EMUNIX_PORTABEL
  13250.  
  13251. # Eine Hilfsfunktion für bidirektionale Pipes: popenrw()
  13252. #undef stdin_handle
  13253. #undef stdout_handle
  13254. #include "../os2/popenrw.c"
  13255.  
  13256. #endif
  13257.  
  13258. # ==============================================================================
  13259.  
  13260. # filestatus/if_file_exists, file_datetime durch break_sem_4 schützen??
  13261. # Signalbehandlung bei EXECUTE, SHELL, MAKE-PIPE-INPUT-STREAM, MAKE-PIPE-OUTPUT-STREAM, MAKE-PIPE-IO-STREAM ??
  13262.  
  13263.