Il CD di internet

home *** CD-ROM | disk | FTP | other *** search

/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / stream.d < prev next >

Wrap

Text File | 1994-12-30 | 523.9 KB | 13,434 lines

# Streams fⁿr CLISP # Bruno Haible 30.12.1994 # Generic Streams: Marcus Daniels 8.4.1994 #include "lispbibl.c" #include "arilev0.c" # fⁿr R_sign #ifdef GNU_READLINE #define READLINE_LIBRARY # Hinweis, wo die Include-Files gesucht werden mⁿssen #include "readline.h" #include "history.h" #undef READLINE_LIBRARY #ifdef STDC_HEADERS #include <string.h> # deklariert strcpy() #endif #endif #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) # Betriebssystem-Funktion read sichtbar machen: #undef read #endif # Nochmals zum Aufbau von Streams: # strmflags = Flags # Bits in den Flags: #define strmflags_ia_bit_B 0 # gesetzt, falls Integer-Stream der Art a #define strmflags_ib_bit_B 1 # gesetzt, falls Integer-Stream der Art b #define strmflags_ic_bit_B 2 # gesetzt, falls Integer-Stream der Art c #define strmflags_immut_bit_B 3 # gesetzt, falls gelesene Objekte immutabel sind #define strmflags_rd_by_bit_B 4 # gesetzt, falls READ-BYTE m÷glich ist #define strmflags_wr_by_bit_B 5 # gesetzt, falls WRITE-BYTE m÷glich ist # define strmflags_rd_ch_bit_B 6 # gesetzt, falls READ-CHAR m÷glich ist #define strmflags_wr_ch_bit_B 7 # gesetzt, falls WRITE-CHAR m÷glich ist # Bitmasken in den Flags: #define strmflags_ia_B bit(strmflags_ia_bit_B) #define strmflags_ib_B bit(strmflags_ib_bit_B) #define strmflags_ic_B bit(strmflags_ic_bit_B) # define strmflags_immut_B bit(strmflags_immut_bit_B) #define strmflags_rd_by_B bit(strmflags_rd_by_bit_B) #define strmflags_wr_by_B bit(strmflags_wr_by_bit_B) #define strmflags_rd_ch_B bit(strmflags_rd_ch_bit_B) #define strmflags_wr_ch_B bit(strmflags_wr_ch_bit_B) #define strmflags_i_B (strmflags_ia_B | strmflags_ib_B | strmflags_ic_B) #define strmflags_rd_B (strmflags_rd_by_B | strmflags_rd_ch_B) #define strmflags_wr_B (strmflags_wr_by_B | strmflags_wr_ch_B) #define strmflags_by_B (strmflags_rd_by_B | strmflags_wr_by_B) #define strmflags_ch_B (strmflags_rd_ch_B | strmflags_wr_ch_B) # strmflags_open_B: die 4 oberen Bits # strmtype = NΣhere Typinfo. Siehe LISPBIBL.D. # einzelne Komponenten: # strm_rd_by Pseudofunktion fⁿr READ-BYTE # strm_wr_by Pseudofunktion fⁿr WRITE-BYTE # strm_rd_ch Pseudofunktion fⁿr READ-CHAR # strm_rd_ch_last letztes von READ-CHAR gelesenes Zeichen # (bzw. als Fixnum nach UNREAD-CHAR bzw. NIL sonst) # strm_wr_ch Pseudofunktion fⁿr WRITE-CHAR # strm_wr_ch_lpos Line-Position in der Zeile nach dem letzten WRITE-CHAR #ifdef STRM_WR_SS # strm_wr_ss Pseudofunktion fⁿr WRITE-SIMPLE-STRING #endif # weitere (typspezifische) Komponenten: # siehe in LISPBIBL.D und bei den einzelnen Stream-Typen. # ============================================================================== # S T R E A M S # Da MAKE-TWO-WAY-STREAM eventuell einen Stream liefern kann, der z.B. # Character-Input und Byte-Output ist, und damit insbesondere alle # READ-/WRITE-Operationen effizient laufen, werden Streams folgenderma▀en # aufgebaut: # - Typ des Streams, # - Komponenten fⁿr READ-BYTE, # - Komponenten fⁿr WRITE-BYTE, # - Komponenten fⁿr READ-CHAR, # - Komponenten fⁿr WRITE-CHAR, # - vom Typ des Streams abhΣngige Komponenten. # Feste Komponenten # ----------------- # fⁿr READ-BYTE: # RD_BY Pseudofunktion zum Lesen eines Bytes # fⁿr WRITE-BYTE: # WR_BY Pseudofunktion zum Schreiben eines Bytes # fⁿr READ-CHAR: # RD_CH Pseudofunktion zum Lesen eines Characters # RD_CH_LAST letztes gelesenes Zeichen und Flag # (NIL zu Beginn, eof_value nach End-of-File, # sonst: letztes gelesenes Zeichen, als Fixnum, # falls es mit UNREAD zurⁿckgeschoben wurde) # fⁿr WRITE-CHAR: # WR_CH Pseudofunktion zum Schreiben eines Characters # WR_CH_LPOS Position in der Zeile (Fixnum >=0) (fⁿr FORMAT ~T) # Pseudofunktionen sind Adressen von C-Funktionen, die direkt angesprungen # werden k÷nnen, mit dem Stream als erstem Argument, und ein Objekt # als Ergebnis liefern. #define P(fun) (type_constpointer_object(machine_type,(Pseudofun)&(fun))) # Spezifikation der vier Typen von Pseudofunktionen: # # Spezifikation fⁿr READ-BYTE - Pseudofunktion: # fun(stream) # > stream: Stream # < ergebnis: gelesener Integer (eof_value bei EOF) # kann GC ausl÷sen typedef object (* rd_by_Pseudofun) (object stream); # # Spezifikation fⁿr WRITE-BYTE - Pseudofunktion: # fun(stream,obj) # > stream: Stream # > obj: auszugebender Integer # kann GC ausl÷sen typedef void (* wr_by_Pseudofun) (object stream, object obj); # # Spezifikation fⁿr READ-CHAR - Pseudofunktion: # fun(&stream) # > stream: Stream # < stream: Stream # < ergebnis: gelesenes Character (eof_value bei EOF) # kann GC ausl÷sen typedef object (* rd_ch_Pseudofun) (object* stream_); # # Spezifikation fⁿr WRITE-CHAR - Pseudofunktion: # fun(&stream,obj) # > stream: Stream # < stream: Stream # > obj: auszugebendes Character # kann GC ausl÷sen typedef void (* wr_ch_Pseudofun) (object* stream_, object obj); # #ifdef STRM_WR_SS # Spezifikation fⁿr WRITE-SIMPLE-STRING - Pseudofunktion: # fun(&stream,string,start,len) # > string: Simple-String # > start: Startindex # > len: Anzahl der auszugebenden Zeichen # > stream: Stream # < stream: Stream # kann GC ausl÷sen typedef void (* wr_ss_Pseudofun) (object* stream_, object string, uintL start, uintL len); #endif # Pseudofunktionen aus einem Stream herausgreifen: #define rd_by(strm) (*(rd_by_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_by))) #define wr_by(strm) (*(wr_by_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_by))) #define rd_ch(strm) (*(rd_ch_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_ch))) #define wr_ch(strm) (*(wr_ch_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ch))) #ifdef STRM_WR_SS #define wr_ss(strm) (*(wr_ss_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ss))) #endif # M÷gliche Typen von Streams Zusatzkomponenten # -------------------------- ----------------- # 0. Keyboard-Stream # 1. Interaktiver Terminalstream Eingabebuffer, ZeichenzΣhler # 2. File-Stream fⁿr String-Chars Handle, Pathname, File-Position, # (Input, Output, I/O, Closed=Probe) Buffer # 3. File-Stream fⁿr Characters Handle, Pathname, File-Position, # (Input, Output, I/O, Closed=Probe) Buffer # 4. File-Stream fⁿr Unsigned-Bytes Handle, Pathname, File-Position, # (Input, Output, I/O, Closed=Probe) Buffer, Bit-Buffer # 5. File-Stream fⁿr Signed-Bytes Handle, Pathname, File-Position, # (Input, Output, I/O, Closed=Probe) Buffer, Bit-Buffer # 6. Synonym-Stream Symbol # 7. Broadcast-(Output-)Stream Liste von Streams # 8. Concatenated-(Input-)Stream Liste von Streams # 9. Two-Way-Stream Stream fⁿr Input, Stream fⁿr Output # 10. Echo-Stream Stream fⁿr Input, Stream fⁿr Output # 11. String-Input-Stream Gesamtstring, ZeichenzΣhler # 12. String-Output-Stream Buffer (Semi-Simple-String) # 13. String-Push-Stream String mit Fill-Pointer # 14. Pretty-Printer-Hilfs-Stream Liste von Buffers, Modus # 15. Buffered-Input-Stream fun, mode, String, ZeichenzΣhler # 16. Buffered-Output-Stream fun, Buffer (Semi-Simple-String) # 17. Window-Stream --- #ifdef PRINTER # 18. Printer-Stream Atari: 2 Gemdos-Funktionsnummern #endif #ifdef HANDLES # 19. File-Handle-Stream Handle, Pathname #endif #ifdef PIPES # 20. Pipe-Input-Stream Pid, Handle # 21. Pipe-Output-Stream Pid, Handle #endif #ifdef SOCKETS # 22. Socket-Stream Info, Handle #endif #ifdef GENERIC_STREAMS # 23. Generic-Stream Private Controller Object #endif # ZusΣtzlich wird (sicherheitshalber) eine Liste aller offenen File-Streams # gefⁿhrt. # Fehlermeldung, wenn eine Stream-Operation auf einem Stream nicht erlaubt ist. # fehler_illegal_streamop(caller,stream); # > caller: Aufrufer (ein Symbol) # > stream: Stream nonreturning_function(global, fehler_illegal_streamop, (object caller, object stream)); global void fehler_illegal_streamop(caller,stream) var reg1 object caller; var reg2 object stream; { pushSTACK(stream); # Wert fⁿr Slot STREAM von STREAM-ERROR pushSTACK(stream); pushSTACK(caller); fehler(stream_error, DEUTSCH ? "~ auf ~ ist unzulΣssig." : ENGLISH ? "~ on ~ is illegal" : FRANCAIS ? "~ de/sur ~ est impossible." : "" ); } # Dummy-Pseudo-Funktionen, die Errors liefern: local object rd_by_dummy (object stream); local object rd_by_dummy(stream) var reg1 object stream; { fehler_illegal_streamop(S(read_byte),stream); } local void wr_by_dummy (object stream, object obj); local void wr_by_dummy(stream,obj) var reg1 object stream; var reg2 object obj; { fehler_illegal_streamop(S(write_byte),stream); } local object rd_ch_dummy (object* stream_); local object rd_ch_dummy(stream_) var reg1 object* stream_; { fehler_illegal_streamop(S(read_char),*stream_); } local void wr_ch_dummy (object* stream_, object obj); local void wr_ch_dummy(stream_,obj) var reg1 object* stream_; var reg2 object obj; { fehler_illegal_streamop(S(write_char),*stream_); } #ifdef STRM_WR_SS local void wr_ss_dummy (object* stream_, object string, uintL start, uintL len); local void wr_ss_dummy(stream_,string,start,len) var reg3 object* stream_; var reg5 object string; var reg4 uintL start; var reg2 uintL len; { if (len==0) return; {var reg1 uintL index = start; pushSTACK(string); # Simple-String retten dotimespL(len,len, { write_schar(stream_,TheSstring(STACK_0)->data[index]); index++; }); skipSTACK(1); }} # Dasselbe, wenn write_char auf diesem Stream keine GC ausl÷sen kann: local void wr_ss_dummy_nogc (object* stream_, object string, uintL start, uintL len); local void wr_ss_dummy_nogc(stream_,string,start,len) var reg3 object* stream_; var reg5 object string; var reg4 uintL start; var reg2 uintL len; { if (len==0) return; {var reg1 uintB* ptr = &TheSstring(string)->data[start]; dotimespL(len,len, { write_schar(stream_,*ptr++); } ); }} #endif # Am Ende eines wr_ss die Line-Position aktualisieren: # wr_ss_lpos(stream,ptr,len); # > stream: Stream, nicht der Terminal-Stream # > ptr: Pointer ans Ende(!) der bereits auf den Stream ausgegebenen Zeichen # > len: Anzahl der Zeichen, >0 # < ergebnis: TRUE, falls ein NL unter den Zeichen ist, FALSE sonst local boolean wr_ss_lpos (object stream, uintB* ptr, uintL len); local boolean wr_ss_lpos(stream,ptr,len) var reg4 object stream; var reg1 uintB* ptr; var reg5 uintL len; { var reg3 uintL pos = 0; # zΣhle die Zahl der Zeichen seit dem letzten NL var reg2 uintL count; dotimespL(count,len, { if (*--ptr == NL) goto found_NL; pos++; } ); if (FALSE) found_NL: # pos Zeichen seit dem letzten NL { TheStream(stream)->strm_wr_ch_lpos = fixnum(pos); return TRUE; } else # kein NL { TheStream(stream)->strm_wr_ch_lpos = fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,len); return FALSE; } } # Liest ein Byte von einem Stream. # read_byte(stream) # > stream: Stream # < ergebnis: gelesener Integer (eof_value bei EOF) # kann GC ausl÷sen global object read_byte (object stream); global object read_byte(stream) var reg1 object stream; { return rd_by(stream)(stream); } # Schreibt ein Byte auf einen Stream. # write_byte(stream,byte); # > stream: Stream # > byte: auszugebender Integer # kann GC ausl÷sen global void write_byte(object stream, object byte); global void write_byte(stream,byte) var reg1 object stream; var reg2 object byte; { wr_by(stream)(stream,byte); } # Liest ein Character von einem Stream. # read_char(&stream) # > stream: Stream # < stream: Stream # < ergebnis: gelesenes Character (eof_value bei EOF) # kann GC ausl÷sen global object read_char (object* stream_); global object read_char(stream_) var reg1 object* stream_; { var reg2 object stream = *stream_; if (!mposfixnump(TheStream(stream)->strm_rd_ch_last)) # Char nach UNREAD ? # nein -> neues Zeichen holen: { var reg3 object newch = rd_ch(stream)(stream_); TheStream(*stream_)->strm_rd_ch_last = newch; # und abspeichern return newch; } else # ja -> Flagbit l÷schen und letztes Zeichen holen: { return TheStream(stream)->strm_rd_ch_last = fixnum_to_char(TheStream(stream)->strm_rd_ch_last); } } # Schiebt das letzte gelesene Character auf einen Stream zurⁿck. # unread_char(&stream,ch); # > ch: letztes gelesenes Character # > stream: Stream # < stream: Stream global void unread_char (object* stream_, object ch); global void unread_char(stream_,ch) var reg1 object* stream_; var reg3 object ch; { var reg2 object stream = *stream_; if (eq(TheStream(stream)->strm_rd_ch_last,ch)) { TheStream(stream)->strm_rd_ch_last = char_to_fixnum(TheStream(stream)->strm_rd_ch_last); # Flagbit setzen } else { if (mcharp(TheStream(stream)->strm_rd_ch_last)) { pushSTACK(stream); # Wert fⁿr Slot STREAM von STREAM-ERROR pushSTACK(ch); pushSTACK(stream); pushSTACK(S(unread_char)); fehler(stream_error, DEUTSCH ? "~: Das letzte von ~ gelesene Zeichen war nicht ~." : ENGLISH ? "~: the last character read from ~ was not ~" : FRANCAIS ? "~ : Le dernier caractΦre lu dans ~ n'Θtait pas ~." : "" ); } else { pushSTACK(stream); # Wert fⁿr Slot STREAM von STREAM-ERROR pushSTACK(S(read_char)); pushSTACK(stream); pushSTACK(S(unread_char)); fehler(stream_error, DEUTSCH ? "~ von ~ ohne vorheriges ~." : ENGLISH ? "~ from ~ without ~ before it" : FRANCAIS ? "~ de ~ sans prΘcΘdent ~." : "" ); } } } # Liest ein Character von einem Stream, ohne es zu verbrauchen. # peek_char(&stream) # > stream: Stream # < stream: Stream # < ergebnis: gelesenes Character (eof_value bei EOF) # kann GC ausl÷sen global object peek_char (object* stream_); global object peek_char(stream_) var reg1 object* stream_; { var reg2 object stream = *stream_; if (!mposfixnump(TheStream(stream)->strm_rd_ch_last)) # Char nach UNREAD ? # nein -> neues Zeichen holen: { var reg3 object newch = rd_ch(stream)(stream_); # und abspeichern: TheStream(*stream_)->strm_rd_ch_last = (eq(newch,eof_value) ? newch : char_to_fixnum(newch)); return newch; } else # ja -> letztes Zeichen holen: { return fixnum_to_char(TheStream(stream)->strm_rd_ch_last); } } # Schreibt ein Character auf einen Stream. # write_char(&stream,ch); # > ch: auszugebendes Character # > stream: Stream # < stream: Stream # kann GC ausl÷sen global void write_char (object* stream_, object ch); global void write_char(stream_,ch) var reg1 object* stream_; var reg4 object ch; { var reg3 cint c = char_int(ch); # Char schreiben: wr_ch(*stream_)(stream_,ch); # Line Position aktualisieren: {var reg2 object stream = *stream_; if (!(TheStream(stream)->strmtype == strmtype_terminal)) # nicht der Terminal-Stream { if (c == NL) # Nach Newline: Line Position := 0 { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; } else # Line Position incrementieren: { TheStream(stream)->strm_wr_ch_lpos = fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,1); } } else # es ist der Terminal-Stream #ifdef TERMINAL_USES_KEYBOARD { ; } # Auf dem Atari macht dies wr_ch_terminal() selbst. #else # Wie wirken sich die Steuerzeichen in der Position aus? { if (graphic_char_p(c)) # normales druckendes Zeichen -> Line Position incrementieren: { TheStream(stream)->strm_wr_ch_lpos = fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,1); } elif (c == NL) # Newline -> Line Position := 0 { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; } elif (c == BS) # Backspace -> Line Position, wenn m÷glich, decrementieren: { if (!eq(TheStream(stream)->strm_wr_ch_lpos,Fixnum_0)) { TheStream(stream)->strm_wr_ch_lpos = fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,-1); } } } #endif }} # UP: Fⁿllt beim Schlie▀en eines Streams die Dummy-Pseudofunktionen ein. # close_dummys(stream); # > stream: Stream local void close_dummys (object stream); local void close_dummys(stream) var reg1 object stream; { TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strmflags &= ~strmflags_open_B; # FΣhigkeiten-Flags l÷schen } # Liefert Fehlermeldung, wenn der Wert des Symbols sym kein Stream ist. nonreturning_function(local, fehler_value_stream, (object sym)); # siehe unten # UP: Liefert den Stream, der der Wert einer Variablen ist. # var_stream(sym) # > sym: Variable (Symbol) # < ergebnis: Stream global object var_stream (object sym); global object var_stream(sym) var reg1 object sym; { if (!mstreamp(Symbol_value(sym))) { fehler_value_stream(sym); } return Symbol_value(sym); } #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(AMIGAOS) || defined(RISCOS) # Fehler, wenn aus einem obskuren Grunde ein WRITE nicht gehen sollte: nonreturning_function(local, fehler_unwritable, (object caller, object stream)); local void fehler_unwritable(caller,stream) var reg1 object caller; var reg2 object stream; { pushSTACK(stream); # Wert fⁿr Slot PATHNAME von FILE-ERROR pushSTACK(stream); pushSTACK(caller); fehler(file_error, DEUTSCH ? "~: Kann nichts auf ~ ausgeben." : ENGLISH ? "~: cannot output to ~" : FRANCAIS ? "~ : Ne peux rien Θcrire sur ~." : "" ); } #endif # Fehler, wenn ein Objekt kein Character ist: # fehler_wr_char(stream,obj); nonreturning_function(local, fehler_wr_char, (object stream, object obj)); local void fehler_wr_char(stream,obj) var reg1 object stream; var reg2 object obj; { pushSTACK(obj); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(S(character)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(stream); pushSTACK(obj); fehler(type_error, DEUTSCH ? "~ ist kein Character und kann daher nicht auf ~ ausgegeben werden." : ENGLISH ? "~ is not a character, cannot be output onto ~" : FRANCAIS ? "~, n'Θtant pas de type CHARACTER, ne peut pas Ωtre Θcrit dans ~." : "" ); } # Fehler, wenn ein Character kein String-Char ist: # fehler_wr_string_char(stream,ch); nonreturning_function(local, fehler_wr_string_char, (object stream, object ch)); local void fehler_wr_string_char(stream,ch) var reg1 object stream; var reg2 object ch; { pushSTACK(ch); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(S(string_char)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(stream); pushSTACK(ch); fehler(type_error, DEUTSCH ? "Character ~ ist kein String-Char und kann daher nicht auf ~ ausgegeben werden." : ENGLISH ? "character ~ is not a string-char, cannot be output onto ~" : FRANCAIS ? "Le caractΦre ~, n'Θtant pas de type STRING-CHAR, ne peut pas Ωtre Θcrit dans ~." : "" ); } # Fehler, wenn ein Objekt kein Integer ist: # fehler_wr_integer(stream,obj); nonreturning_function(local, fehler_wr_integer, (object stream, object obj)); local void fehler_wr_integer(stream,obj) var reg1 object stream; var reg2 object obj; { pushSTACK(obj); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(S(integer)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(stream); pushSTACK(obj); fehler(type_error, DEUTSCH ? "~ ist kein Integer und kann daher nicht auf ~ ausgegeben werden." : ENGLISH ? "~ is not an integer, cannot be output onto ~" : FRANCAIS ? "~, n'Θtant pas un entier, ne peut pas Ωtre Θcrit dans ~." : "" ); } # Fehler, wenn ein Integer nicht im passenden Bereich ist: # fehler_bad_integer(stream,obj); nonreturning_function(local, fehler_bad_integer, (object stream, object obj)); local void fehler_bad_integer(stream,obj) var reg1 object stream; var reg2 object obj; { pushSTACK(stream); pushSTACK(obj); fehler(error, DEUTSCH ? "Integer ~ ist zu gro▀ oder zu klein und kann daher nicht auf ~ ausgegeben werden." : ENGLISH ? "integer ~ is out of range, cannot be output onto ~" : FRANCAIS ? "L'entier ~, n'Θtant pas dans l'intervalle souhaitΘ, ne peut pas Ωtre Θcrit dans ~." : "" ); } # Fehler, wenn ein Argument kein Fixnum >=0 ist: # fehler_bad_lpos(); # > STACK_0: lpos nonreturning_function(local, fehler_bad_lpos, (void)); local void fehler_bad_lpos() { # line-position in STACK_0 pushSTACK(STACK_0); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(O(type_posfixnum)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(STACK_(0+2)); pushSTACK(TheSubr(subr_self)->name); fehler(type_error, DEUTSCH ? "~: Argument mu▀ ein Fixnum >=0 sein, nicht ~" : ENGLISH ? "~: argument ~ should be a nonnegative fixnum" : FRANCAIS ? "~ : L'argument doit Ωtre de type FIXNUM positif ou zΘro et non pas ~.": "" ); } # UP: ▄berprⁿft Argumente, ob sie Streams sind. # test_stream_args(args_pointer,argcount); # > args_pointer: Pointer ⁿber die Argumente # > argcount: Anzahl der Argumente # > subr_self: Aufrufer (ein SUBR) local void test_stream_args (object* args_pointer, uintC argcount); local void test_stream_args(args_pointer, argcount) var reg1 object* args_pointer; var reg2 uintC argcount; { dotimesC(argcount,argcount, { var reg3 object next_arg = NEXT(args_pointer); if (!streamp(next_arg)) { fehler_stream(next_arg); } }); } #if defined(UNIX) || defined(EMUNIX) || defined(DJUNIX) || defined(WATCOM) || defined(RISCOS) # UP: L÷scht bereits eingegebenen interaktiven Input von einem Handle. local void clear_tty_input (Handle handle); #if !(defined(DJUNIX) || defined(RISCOS)) local void clear_tty_input(handle) var reg1 Handle handle; { # Methode 1: tcflush TCIFLUSH, siehe TERMIOS(3V) # Methode 2: ioctl TCFLSH TCIFLUSH, siehe TERMIO(4) # Methode 3: ioctl TIOCFLUSH FREAD, siehe TTCOMPAT(4) begin_system_call(); #ifdef UNIX_TERM_TERMIOS if (!( TCFLUSH(handle,TCIFLUSH) ==0)) { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } # kein TTY: OK, sonstigen Error melden #endif #ifdef UNIX_TERM_TERMIO #ifdef TCIFLUSH # !RISCOS if (!( ioctl(handle,TCFLSH,(CADDR_T)TCIFLUSH) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Error melden #endif #endif #ifdef UNIX_TERM_SGTTY #ifdef FREAD # !UNIX_MINT {var int arg = FREAD; if (!( ioctl(handle,TIOCFLUSH,&arg) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Error melden } #endif #endif #ifdef EMUNIX # Eberhard Mattes sagt, das funktioniert nur, wenn IDEFAULT nicht # gesetzt ist. ?? if (!( ioctl(handle,TCFLSH,0) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Erro #endif end_system_call(); } #else #define clear_tty_input(handle) #endif # UP: Bringt den wartenden Output eines Handles ans Ziel. local void finish_tty_output (Handle handle); #if !(defined(DJUNIX) || defined(WATCOM) || defined(RISCOS)) local void finish_tty_output(handle) var reg1 Handle handle; { # Methode 1: fsync, siehe FSYNC(2) # Methode 2: tcdrain, siehe TERMIOS(3V) # Methode 3: ioctl TCSBRK 1, siehe TERMIO(4) # evtl. Methode 3: ioctl TCGETS/TCSETSW, siehe TERMIO(4) # oder (fast Σquivalent) ioctl TIOCGETP/TIOCSETP, siehe TTCOMPAT(4) begin_system_call(); #if !(defined(UNIX) && !defined(HAVE_FSYNC)) if (!( fsync(handle) ==0)) #ifdef EMUNIX_NEW_8e #ifdef EMUNIX_NEW_9a if (!(errno==ENOSYS)) #else if (!(errno==EMSDOS)) #endif #endif if (!(errno==EINVAL)) { OS_error(); } #endif #ifdef UNIX_TERM_TERMIOS if (!( TCDRAIN(handle) ==0)) { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } # kein TTY: OK, sonstigen Error melden #endif #ifdef UNIX_TERM_TERMIO if (!( ioctl(handle,TCSBRK,(CADDR_T)1) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #endif #if defined(UNIX_TERM_TERMIOS) && defined(TCGETS) && defined(TCSETSW) {var struct termios term_parameters; if (!( ( ioctl(handle,TCGETS,&term_parameters) ==0) && ( ioctl(handle,TCSETSW,&term_parameters) ==0) ) ) { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } # kein TTY: OK, sonstigen Error melden } #endif #ifdef EMUNIX {var struct termio term_parameters; if (!( ( ioctl(handle,TCGETA,&term_parameters) ==0) && ( ioctl(handle,TCSETAW,&term_parameters) ==0) ) ) { if (!(errno==ENOTTY)) { OS_error(); } } } #endif #if 0 # Vorsicht: das mⁿ▀te FINISH-OUTPUT und CLEAR-INPUT bewirken! {var struct sgttyb tty_parameters; if (!( ( ioctl(handle,TIOCGETP,&tty_parameters) ==0) && ( ioctl(handle,TIOCSETP,&tty_parameters) ==0) ) ) { if (!(errno==ENOTTY)) { OS_error(); } } } #endif end_system_call(); } #else #define finish_tty_output(handle) #endif # UP: Bringt den wartenden Output eines Handles ans Ziel. local void force_tty_output (Handle handle); #if !(defined(DJUNIX) || defined(WATCOM) || (defined(UNIX) && !defined(HAVE_FSYNC)) || defined(RISCOS)) local void force_tty_output(handle) var reg1 Handle handle; { # Methode: fsync, siehe FSYNC(2) begin_system_call(); if (!( fsync(handle) ==0)) #ifdef EMUNIX_NEW_8e #ifdef EMUNIX_NEW_9a if (!(errno==ENOSYS)) #else if (!(errno==EMSDOS)) #endif #endif if (!(errno==EINVAL)) { OS_error(); } end_system_call(); } #else #define force_tty_output(handle) #endif # UP: L÷scht den wartenden Output eines Handles. local void clear_tty_output (Handle handle); #if !(defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)) local void clear_tty_output(handle) var reg1 Handle handle; { # Methode 1: tcflush TCOFLUSH, siehe TERMIOS(3V) # Methode 2: ioctl TCFLSH TCOFLUSH, siehe TERMIO(4) # Methode 3: ioctl TIOCFLUSH FWRITE, siehe TTCOMPAT(4) begin_system_call(); #ifdef UNIX_TERM_TERMIOS if (!( TCFLUSH(handle,TCOFLUSH) ==0)) { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } # kein TTY: OK, sonstigen Error melden #endif #ifdef UNIX_TERM_TERMIO #ifdef TCOFLUSH # !RISCOS if (!( ioctl(handle,TCFLSH,(CADDR_T)TCOFLUSH) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Error melden #endif #endif #ifdef UNIX_TERM_SGTTY #ifdef FWRITE # !UNIX_MINT {var int arg = FWRITE; if (!( ioctl(handle,TIOCFLUSH,&arg) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } # kein TTY: OK, sonstigen Error melden } #endif #endif end_system_call(); } #else #define clear_tty_output(handle) #endif #endif #if defined(AMIGAOS) # UP: Bringt den wartenden Output eines Handles ans Ziel. local void finish_tty_output (Handle handle); # Wir k÷nnen nichts tun, da wir handle nicht schlie▀en dⁿrfen und # kein fsync() haben. #define finish_tty_output(handle) # UP: Bringt den wartenden Output eines Handles ans Ziel. local void force_tty_output (Handle handle); #define force_tty_output(handle) finish_tty_output(handle) # UP: L÷scht den wartenden Output eines Handles. local void clear_tty_output (Handle handle); # Nichts zu tun. #define clear_tty_output(handle) #endif #if (defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(AMIGAOS) || defined(RISCOS)) && (!defined(TERMINAL_USES_KEYBOARD) || defined(HANDLES) || defined(PIPES) || defined(SOCKETS)) #define XHANDLES # Handle-Streams # ============== # sind ein gemeinsamer Rahmen fⁿr Streams, deren Input/Output ungebuffert # ⁿber ein Handle des Betriebssystems abgewickelt wird. Umfa▀t: # Input: Terminal-Stream, File-Handle-Stream, Pipe-Input-Stream, Socket-Stream. # Output: File-Handle-Stream, Pipe-Output-Stream, Socket-Stream. #define strm_isatty strm_other[0] # Flag, ob das Input-Handle ein TTY ist #define strm_ihandle strm_other[1] # Input-Handle immer als zweite Komponente #define strm_ohandle strm_other[2] # Output-Handle immer als dritte Komponente # Da▀ beim Input EOF erreicht ist, erkennt man an # TheStream(stream)->strm_rd_ch_last = eof_value. # READ-CHAR - Pseudofunktion fⁿr Handle-Streams: local object rd_ch_handle (object* stream_); local object rd_ch_handle(stream_) var reg4 object* stream_; { restart_it: { var reg2 object stream = *stream_; if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF? { return eof_value; } { var reg3 Handle handle = TheHandle(TheStream(stream)->strm_ihandle); var uintB c; #if defined(AMIGAOS) interruptp({ pushSTACK(S(read_char)); tast_break(); # Ctrl-C -> Break-Schleife aufrufen return read_char(stream_); }); #endif run_time_stop(); # Run-Time-Stoppuhr anhalten #ifdef GRAPHICS_SWITCH if (handle == stdin_handle) switch_text_mode(); #endif begin_system_call(); { #if !defined(AMIGAOS) var reg1 int ergebnis = read(handle,&c,1); # Zeichen lesen versuchen #else # defined(AMIGAOS) var reg1 long ergebnis = Read(handle,&c,1L); # Zeichen lesen versuchen #endif end_system_call(); run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen if (ergebnis<0) { #if !defined(AMIGAOS) if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } #endif OS_error(); } if (ergebnis==0) # kein Zeichen verfⁿgbar -> mu▀ EOF sein { return eof_value; } else { #if defined(AMIGAOS) # Ctrl-C wird meist wΣhrend des Read()-Aufrufs festgestellt, und # Read() liefert dann "unschuldig" ein Zeichen ab. Wir behandeln # das Ctrl-C jetzt. Damit das Zeichen nicht verlorengeht, wird # es wie durch unread_char() zurⁿckgelegt. interruptp( { TheStream(stream)->strm_rd_ch_last = fixnum(c); pushSTACK(S(read_char)); tast_break(); # Break-Schleife aufrufen return read_char(stream_); }); #endif return code_char(c); } }}}} # Stellt fest, ob ein Handle-Stream ein Zeichen verfⁿgbar hat. # listen_handle(stream) # > stream: Handle-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF local signean listen_handle (object stream); local signean listen_handle(stream) var reg2 object stream; { if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ? { return signean_minus; } # Methode 1: select, siehe SELECT(2) # Methode 2: ioctl FIONREAD, siehe FILIO(4) # Methode 3: kurzzeitig auf non-blocking I/O schalten und read versuchen, # siehe READ(2V) und FILIO(4), bzw. # siehe READ(2V), FCNTL(2V) und FCNTL(5) {var reg3 Handle handle = TheHandle(TheStream(stream)->strm_ihandle); #if defined(MSDOS) && !defined(EMUNIX_PORTABEL) { var reg2 uintB status; begin_system_call(); get_handle_input_status(handle,status); end_system_call(); if (status) { return signean_null; } # Zeichen verfⁿgbar } if (!nullp(TheStream(stream)->strm_isatty)) # Terminal { return signean_plus; } # kein Zeichen verfⁿgbar else # File # kein Zeichen verfⁿgbar -> EOF erkennen { TheStream(stream)->strm_rd_ch_last = eof_value; return signean_minus; } #elif defined(EMUNIX_PORTABEL) { var struct termio oldtermio; var struct termio newtermio; begin_system_call(); if (!( ioctl(handle,TCGETA,&oldtermio) ==0)) { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } newtermio = oldtermio; newtermio.c_lflag &= ~IDEFAULT & ~ICANON; if (!( ioctl(handle,TCSETA,&newtermio) ==0)) { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } {var uintL chars_ready = 0; var int result = ioctl(handle,FIONREAD,&chars_ready); # abfragen # (Bei EMUNIX_NEW_8f k÷nnte man das auch mit select() machen.) if (!( ioctl(handle,TCSETA,&oldtermio) ==0)) { if (!((errno==ENOTTY)||(errno==EINVAL))) { OS_error(); } } end_system_call(); if (result == 0) # Abfrage gelungen { if (chars_ready > 0) { return signean_null; } } # welche verfⁿgbar? #ifdef EMUNIX_NEW_8e begin_system_call(); if (!isatty(handle)) { result = eof(handle); if (result<0) { if (!(errno==ESPIPE)) { OS_error(); } } # "Illegal seek error" ist OK else { end_system_call(); if (result>0) # EOF erreicht? { return signean_minus; } else { return signean_null; } } } end_system_call(); #endif return signean_plus; # offenbar kein Zeichen verfⁿgbar }} #elif !defined(AMIGAOS) #ifdef HAVE_SELECT { # Verwende select mit readfds = einelementige Menge {handle} # und timeout = Null-Zeitintervall. var fd_set handle_menge; # Menge von Handles := {handle} var struct timeval zero_time; # Zeitintervall := 0 FD_ZERO(&handle_menge); FD_SET(handle,&handle_menge); restart_select: zero_time.tv_sec = 0; zero_time.tv_usec = 0; begin_system_call(); {var reg1 int ergebnis; ergebnis = select(FD_SETSIZE,&handle_menge,NULL,NULL,&zero_time); end_system_call(); if (ergebnis<0) { if (errno==EINTR) goto restart_select; if (!(errno==EBADF)) { OS_error(); } # UNIX_LINUX liefert bei Files EBADF ! } else { # ergebnis = Anzahl der Handles in handle_menge, bei denen read # sofort ein Ergebnis liefern wⁿrde. if (ergebnis==0) { return signean_plus; } # kein Zeichen verfⁿgbar # ergebnis=1 # Wenn read() sofort ein Ergebnis liefern wⁿrde, kann das auch EOF # sein! (Beispiel: Linux und Pipes.) Wir hⁿten uns daher vor # einem { return signean_null; } und versuchen stattdessen # erst noch Methoden 2 und 3. }} } #endif #ifdef HAVE_FIONREAD # versuche die Zahl der verfⁿgbaren Zeichen abzufragen: begin_system_call(); {var uintL chars_ready; if ( ioctl(handle,FIONREAD,&chars_ready) ==0) # abfragen # Abfrage gelungen, also war's ein File { end_system_call(); if (chars_ready > 0) { return signean_null; } # welche verfⁿgbar? # sonst EOF des File erkennen: TheStream(stream)->strm_rd_ch_last = eof_value; return signean_minus; } if (!((errno == ENOTTY)||(errno == EINVAL))) { OS_error(); } end_system_call(); }# Abfrage mi▀lungen, war wohl kein File #endif #ifdef GRAPHICS_SWITCH if (handle == stdin_handle) switch_text_mode(); #endif #ifndef HAVE_SELECT if (!nullp(TheStream(stream)->strm_isatty)) # Terminal { # in Non-blocking-Modus umschalten, dann read() versuchen: var uintB c; var int ergebnis; begin_system_call(); restart_read_tty: #ifdef FIONBIO # non-blocking I/O α la BSD 4.2 { var int non_blocking_io; non_blocking_io = 1; if (!( ioctl(handle,FIONBIO,&non_blocking_io) ==0)) { OS_error(); } ergebnis = read(handle,&c,1); # Zeichen lesen versuchen non_blocking_io = 0; if (!( ioctl(handle,FIONBIO,&non_blocking_io) ==0)) { OS_error(); } } #else # non-blocking I/O α la SYSV { var reg2 int fcntl_flags; if (( fcntl_flags = fcntl(handle,F_GETFL,0) )<0) { OS_error(); } if ( fcntl(handle,F_SETFL,fcntl_flags|O_NDELAY) <0) { OS_error(); } ergebnis = read(handle,&c,1); # Zeichen lesen versuchen if ( fcntl(handle,F_SETFL,fcntl_flags) <0) { OS_error(); } } #endif if (ergebnis < 0) { if (errno==EINTR) goto restart_read_tty; #ifdef FIONBIO if (errno==EWOULDBLOCK) # BSD 4.2 Error-Code #else if ((errno==EAGAIN) # Posix Error-Code #ifdef EWOULDBLOCK || (errno==EWOULDBLOCK) #endif ) #endif { return signean_plus; } # kein Zeichen verfⁿgbar OS_error(); } end_system_call(); if (ergebnis==0) # kein Zeichen verfⁿgbar { return signean_plus; } else # Zeichen verfⁿgbar { TheStream(stream)->strm_rd_ch_last = fixnum(c); return signean_null; } # Sollte das nicht gehen, einen Timer von 1/10 sec verwenden?? } else #endif # File (oder Pipe) { # ein Zeichen lesen versuchen (wie bei peek_char): begin_system_call(); restart_read_other: {var uintB c; var reg1 int ergebnis = read(handle,&c,1); # Zeichen lesen versuchen if (ergebnis<0) { if (errno==EINTR) goto restart_read_other; OS_error(); } end_system_call(); if (ergebnis==0) # kein Zeichen verfⁿgbar -> EOF erkennen { TheStream(stream)->strm_rd_ch_last = eof_value; return signean_minus; } else # Zeichen verfⁿgbar { TheStream(stream)->strm_rd_ch_last = fixnum(c); return signean_null; } }} #else # defined(AMIGAOS) begin_system_call(); if (!nullp(TheStream(stream)->strm_isatty)) # interaktiv { if (WaitForChar(handle,1000L)) # 1/1000 sec auf ein Zeichen warten { end_system_call(); return signean_null; } # eins da else { end_system_call(); return signean_plus; } # keins da } else # nicht interaktiv { # ein Zeichen lesen versuchen (wie bei peek_char): var uintB c; var reg1 long ergebnis = Read(handle,&c,1L); # Zeichen lesen versuchen end_system_call(); if (ergebnis<0) { OS_error(); } if (ergebnis==0) # kein Zeichen verfⁿgbar -> EOF erkennen { TheStream(stream)->strm_rd_ch_last = eof_value; return signean_minus; } else # Zeichen verfⁿgbar { TheStream(stream)->strm_rd_ch_last = fixnum(c); return signean_null; } } #endif }} # UP: L÷scht bereits eingegebenen interaktiven Input von einem Handle-Stream. # clear_input_handle(stream); # > stream: Handle-Stream # < ergebnis: TRUE falls Input gel÷scht wurde, FALSE sonst local boolean clear_input_handle (object stream); local boolean clear_input_handle(stream) var reg1 object stream; { var reg1 Handle handle = TheHandle(TheStream(stream)->strm_ihandle); if (nullp(TheStream(stream)->strm_isatty)) # File -> nichts tun { return FALSE; } #if !defined(AMIGAOS) # Terminal TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen clear_tty_input(handle); # Fⁿr den Fall, das das nicht funktionierte: # Zeichen lesen, solange listen_handle() 0 liefert. pushSTACK(stream); while (listen_handle(STACK_0) == 0) { read_char(&STACK_0); } skipSTACK(1); return TRUE; #else # defined(AMIGAOS) # interaktiv { begin_system_call(); loop { if (!WaitForChar(handle,1000L)) # 1/1000 sec auf ein Zeichen warten break; # keins mehr da -> fertig {var uintB c; var reg1 long ergebnis = Read(handle,&c,1L); # Zeichen lesen versuchen if (ergebnis<0) { OS_error(); } }} end_system_call(); return TRUE; } #endif } # WRITE-CHAR - Pseudofunktion fⁿr Handle-Streams: local void wr_ch_handle (object* stream_, object ch); local void wr_ch_handle(stream_,ch) var reg3 object* stream_; var reg1 object ch; { var reg2 Handle handle = TheHandle(TheStream(*stream_)->strm_ohandle); # ch sollte String-Char sein: if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } {var uintB c = char_code(ch); # Code des Zeichens restart_it: #ifdef GRAPHICS_SWITCH if (handle == stdout_handle) switch_text_mode(); #endif begin_system_call(); { #if !defined(AMIGAOS) var reg4 int ergebnis = write(handle,&c,1); # Zeichen auszugeben versuchen end_system_call(); if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { interruptp({ pushSTACK(S(write_char)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } OS_error(); # Error melden } #else # defined(AMIGAOS) var reg4 long ergebnis = Write(handle,&c,1L); # Zeichen auszugeben versuchen end_system_call(); if (ergebnis<0) { OS_error(); } # Error melden interruptp({ pushSTACK(S(write_char)); tast_break(); }); # Ctrl-C -> Break-Schleife aufrufen #endif if (ergebnis==0) # nicht erfolgreich? { fehler_unwritable(S(write_char),*stream_); } } }} # WRITE-CHAR-SEQUENCE fⁿr Handle-Streams: local uintB* write_schar_array_handle (object stream, uintB* ptr, uintL len); local uintB* write_schar_array_handle(stream,ptr,len) var reg5 object stream; var reg1 uintB* ptr; var reg6 uintL len; { var reg4 Handle handle = TheHandle(TheStream(stream)->strm_ohandle); var reg2 uintL remaining = len; #ifdef GRAPHICS_SWITCH if (handle == stdout_handle) switch_text_mode(); #endif begin_system_call(); restart_it: loop { #if !defined(AMIGAOS) var reg3 int ergebnis = write(handle,ptr,remaining); # Zeichen auszugeben versuchen if (ergebnis<0) { if (errno==EINTR) goto restart_it; OS_error(); # Error melden } #else # defined(AMIGAOS) var reg3 long ergebnis = Write(handle,ptr,remaining); # Zeichen auszugeben versuchen if (ergebnis<0) { OS_error(); } # Error melden #endif if (ergebnis==0) # nicht erfolgreich? { fehler_unwritable(S(write_string),stream); } ptr += ergebnis; remaining -= ergebnis; if (remaining==0) break; # fertig? } end_system_call(); wr_ss_lpos(stream,ptr,len); # Line-Position aktualisieren return ptr; } #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr Handle-Streams: local void wr_ss_handle (object* stream_, object string, uintL start, uintL len); local void wr_ss_handle(stream_,string,start,len) var reg1 object* stream_; var reg2 object string; var reg4 uintL start; var reg3 uintL len; { if (len==0) return; write_schar_array_handle(*stream_,&TheSstring(string)->data[start],len); } #endif # UP: Bringt den wartenden Output eines Handle-Stream ans Ziel. # finish_output_handle(stream); # > stream: Handle-Stream # kann GC ausl÷sen local void finish_output_handle (object stream); local void finish_output_handle(stream) var reg1 object stream; { finish_tty_output(TheHandle(TheStream(stream)->strm_ohandle)); } # UP: Bringt den wartenden Output eines Handle-Stream ans Ziel. # force_output_handle(stream); # > stream: Handle-Stream # kann GC ausl÷sen local void force_output_handle (object stream); local void force_output_handle(stream) var reg1 object stream; { force_tty_output(TheHandle(TheStream(stream)->strm_ohandle)); } # UP: L÷scht den wartenden Output eines Handle-Stream. # clear_output_handle(stream); # > stream: Handle-Stream # kann GC ausl÷sen local void clear_output_handle (object stream); local void clear_output_handle(stream) var reg1 object stream; { clear_tty_output(TheHandle(TheStream(stream)->strm_ohandle)); } #if defined(HANDLES) || defined(SOCKETS) # READ-BYTE - Pseudofunktion fⁿr Handle-Streams: local object rd_by_handle (object stream); local object rd_by_handle(stream) var reg1 object stream; { pushSTACK(stream); {var reg1 object obj = read_char(&STACK_0); skipSTACK(1); if (!eq(obj,eof_value)) { obj = char_to_fixnum(obj); } return obj; }} # WRITE-BYTE - Pseudofunktion fⁿr Handle-Streams: local void wr_by_handle (object stream, object obj); local void wr_by_handle(stream,obj) var reg1 object stream; var reg2 object obj; { # obj ⁿberprⁿfen: if (!integerp(obj)) { fehler_wr_integer(stream,obj); } if (!(posfixnump(obj) && (posfixnum_to_L(obj) < char_code_limit))) { fehler_bad_integer(stream,obj); } pushSTACK(stream); wr_ch_handle(&STACK_0,fixnum_to_char(obj)); skipSTACK(1); } #endif #if defined(HANDLES) || (defined(PIPES) && defined(UNIX)) || defined(SOCKETS) # Schlie▀t einen Handle-Stream. # close_ihandle(stream); # close_ohandle(stream); # > stream : Handle-Stream local void close_ihandle (object stream); local void close_ohandle (object stream); local void close_ihandle(stream) var reg1 object stream; { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_ihandle); begin_system_call(); if (!( CLOSE(handle) ==0)) { OS_error(); } end_system_call(); } local void close_ohandle(stream) var reg1 object stream; { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_ohandle); begin_system_call(); if (!( CLOSE(handle) ==0)) { OS_error(); } end_system_call(); } #endif #if defined(HANDLES) #define close_handle close_ihandle # UP: erzeugt ein File-Handle-Stream # make_handle_stream(handle,direction) # > handle: Handle des ge÷ffneten Files # > STACK_1: Filename, ein Pathname # > STACK_0: Truename, ein Pathname # > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE) # < ergebnis: File-Handle-Stream # < STACK: aufgerΣumt # kann GC ausl÷sen local object make_handle_stream (object handle, uintB direction); local object make_handle_stream(handle,direction) var reg4 object handle; var reg2 uintB direction; { # Flags: var reg3 uintB flags = ((direction & bit(0)) ? strmflags_rd_B : 0) # evtl. READ-CHAR, READ-BYTE erlaubt | ((direction & bit(2)) ? strmflags_wr_B : 0) # evtl. WRITE-CHAR, WRITE-BYTE erlaubt #ifdef IMMUTABLE | ((direction & bit(1)) ? strmflags_immut_B : 0) # evtl. immutable Objekte #endif ; #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT pushSTACK(handle); # Handle retten #endif {# Stream allozieren: var reg1 object stream = allocate_stream(flags,strmtype_handle,strm_len+5); # und fⁿllen: if (direction & bit(0)) { TheStream(stream)->strm_rd_by = P(rd_by_handle); TheStream(stream)->strm_rd_ch = P(rd_ch_handle); } else { TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); } if (direction & bit(2)) { TheStream(stream)->strm_wr_by = P(wr_by_handle); TheStream(stream)->strm_wr_ch = P(wr_ch_handle); #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_handle); #endif } else { TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif } TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT handle = popSTACK(); # Handle zurⁿck #endif TheStream(stream)->strm_ihandle = TheStream(stream)->strm_ohandle = handle; # Handle eintragen # Flag isatty = (handle_tty ? T : NIL) bestimmen: begin_system_call(); #if !defined(AMIGAOS) TheStream(stream)->strm_isatty = (isatty(TheHandle(handle)) ? T : NIL); #else # defined(AMIGAOS) TheStream(stream)->strm_isatty = (IsInteractive(TheHandle(handle)) ? T : NIL); #endif end_system_call(); # File-Handle-Streams werden fⁿr Pathname-Zwecke wie File-Streams behandelt. # Daher ist (vgl. file_write_date) strm_file_handle == strm_ohandle, # und wir tragen nun die Pathnames ein: TheStream(stream)->strm_file_truename = popSTACK(); # Truename eintragen TheStream(stream)->strm_file_name = popSTACK(); # Filename eintragen # Liste der offenen Streams um stream erweitern: pushSTACK(stream); {var reg2 object new_cons = allocate_cons(); Car(new_cons) = stream = popSTACK(); Cdr(new_cons) = O(open_files); O(open_files) = new_cons; } return stream; }} #endif #endif # (UNIX || DJUNIX || EMUNIX || WATCOM || AMIGAOS || RISCOS) && (brauche Handle-Streams) #ifdef KEYBOARD # Keyboard-Stream # =============== # Funktionsweise: # Liest ein Zeichen von Tastatur. # Liefert ein Character mit Font=0 und folgenden Bits: # HYPER falls Sondertaste. # Zu den Sondertasten zΣhlen die Non-Standard-Tasten. # ATARI: # Funktionstasten, Cursorblock, Ziffernblock, Delete-Taste. # MSDOS: # Funktionstasten, Cursorbl÷cke, Ziffernblock. # CHAR-CODE Bei normalen Tasten der Ascii-Code, # bei Sondertasten: # ATARI: # F1 -> #\F1, ..., F9 -> #\F9, F10 -> #\F10, # Help -> #\Help, Undo -> #\Undo, # Insert -> #\Insert, Delete -> #\Delete, # ClrHome -> #\Home, # -> #\Up, -> #\Down, -> #\Left, -> #\Right. # MSDOS: # F1 -> #\F1, ..., F10 -> #\F10, F11 -> #\F11, F12 -> #\F12, # Insert -> #\Insert, Delete -> #\Delete, # Home -> #\Home, End -> #\End, PgUp -> #\PgUp, PgDn -> #\PgDn, # Pfeiltasten -> #\Up, #\Down, #\Left, #\Right. # SUPER falls mit Shift-Taste(n) gedrⁿckt und sich ohne Shift # ein anderer Code ergeben hΣtte, # CONTROL falls mit Control-Taste gedrⁿckt, # META falls mit Alternate-Taste gedrⁿckt. #if defined(UNIX) || defined(RISCOS) # ZusΣtzliche Komponenten: #define strm_keyboard_isatty strm_isatty # Flag, ob stdin ein Terminal ist #define strm_keyboard_handle strm_ihandle # Handle fⁿr listen_handle() #define strm_keyboard_buffer strm_other[2] # Liste der noch zu liefernden Zeichen #define strm_keyboard_keytab strm_other[3] # Liste aller Tastenzuordnungen # jeweils (char1 ... charn . result) #define strm_keyboard_len 4 #else # Keine zusΣtzlichen Komponenten. #define strm_keyboard_len 0 #endif #ifdef MSDOS #ifdef WINDOWS # Tastaturabfrage im Haupt-Fenster #define kbhit win_main_kbhit #define getch win_main_getch #else # Fⁿr Tastaturabfrage unter DOS: # # INT 16 documentation: # INT 16,00 - Wait for keystroke and read # INT 16,01 - Get keystroke status # INT 16,02 - Get shift status # INT 16,03 - Set keyboard typematic rate (AT+) # INT 16,04 - Keyboard click adjustment (AT+) # INT 16,05 - Keyboard buffer write (AT,PS/2 enhanced keyboards) # INT 16,10 - Wait for keystroke and read (AT,PS/2 enhanced keyboards) # INT 16,11 - Get keystroke status (AT,PS/2 enhanced keyboards) # INT 16,12 - Get shift status (AT,PS/2 enhanced keyboards) # # INT 16,00 - Wait for Keypress and Read Character # AH = 00 # on return: # AH = keyboard scan code # AL = ASCII character or zero if special function key # - halts program until key with a scancode is pressed # - see SCAN CODES # # INT 16,01 - Get Keyboard Status # AH = 01 # on return: # ZF = 0 if a key pressed (even Ctrl-Break) # AX = 0 if no scan code is available # AH = scan code # AL = ASCII character or zero if special function key # - data code is not removed from buffer # - Ctrl-Break places a zero word in the keyboard buffer but does # register a keypress. # # INT 16,10 - Extended Wait for Keypress and Read Character (AT+) # AH = 10h # on return: # AH = scan code # AL = ASCII character or zero if special function key # - available on AT and PS/2 machines with extended keyboard support # - similar to INT 16,00 # # INT 16,11 - Extended Get Keyboard Status (AT+) # AH = 11h # on return: # ZF = 0 if key pressed (data waiting) # AX = 0 if no scan code is available # AH = scan code # AL = ASCII character or zero if special function key # - available on AT and PS/2 machines with extended keyboard support # - data is not removed from buffer # - similar to INT 16,01 # #if defined(DJUNIX) || defined(WATCOM) # Liefert den nΣchsten Tastendruck incl. Scan-Code: # high byte = Scan-Code oder 0, low byte = Ascii-Code oder 0 oder 0xE0. local boolean kbhit() { var union REGS in; var union REGS out; in.regB.ah = 0x11; int86(0x16,&in,&out); return ((out.reg_flags & 0x40) == 0); # Zero-Flag abfragen } local uintW getch() { var union REGS in; var union REGS out; in.regB.ah = 0x10; int86(0x16,&in,&out); return out.regW.ax; } #endif #ifdef EMUNIX # Unter DOS: # Bis emx 0.8e ist uns der INT 16,10 offenbar versperrt. # Wir bekommen keine Extended-Keystrokes, k÷nnen aber immerhin die Return- # von der Enter-Taste unterscheiden. # Unter OS/2: # INT 16 funktioniert nicht, dafⁿr geht _read_kbd() prΣziser als unter DOS. # Liefert unter DOS den nΣchsten Tastendruck incl. Scan-Code: # high byte = Scan-Code oder 0, low byte = Ascii-Code oder 0 oder 0xE0. #ifdef EMUNIX_OLD_8e #define int16_wait "0x00" #define int16_stat "0x01" #else # EMUNIX_NEW_8f #define int16_wait "0x10" #define int16_stat "0x11" #endif local boolean kbhit() { var reg1 boolean result; __asm__ __volatile__ ("movb $"int16_stat",%%ah ; .byte 0xcd ; .byte 0x16 ; " "movl $0,%%eax ; jz 1f ; incl %%eax ; 1: " : "=a" /* %eax */ (result) /* OUT */ : /* IN */ : "bx","cx","dx","si","di" /* %ebx,%ecx,%edx,%esi,%edi */ /* CLOBBER */ ); return result; } local uintW getch() { var reg1 uintW ch; __asm__ __volatile__ ("movb $"int16_wait",%%ah ; .byte 0xcd ; .byte 0x16" : "=a" /* %ax */ (ch) /* OUT */ : /* IN */ : "bx","cx","dx","si","di" /* %ebx,%ecx,%edx,%esi,%edi */ /* CLOBBER */ ); return ch; } #endif # Tabelle der Characters, die den Scan-Codes 0..166 (als Sondertasten) # entsprechen: local cint scancode_table [167] = { 0, ESC | char_meta_c, # 1 -> Alt-Escape '1' | char_control_c, # [2 = Ctrl-1 -> #\CONTROL-1] '2' | char_control_c, # 3 = Ctrl-2 -> #\CONTROL-2 '3' | char_control_c, # [4 = Ctrl-3 -> #\CONTROL-3] '4' | char_control_c, # [5 = Ctrl-4 -> #\CONTROL-4] '5' | char_control_c, # [6 = Ctrl-5 -> #\CONTROL-5] '6' | char_control_c, # 7 = Ctrl-6 -> #\CONTROL-6 '7' | char_control_c, # [8 = Ctrl-7 -> #\CONTROL-7] '8' | char_control_c, # [9 = Ctrl-8 -> #\CONTROL-8] '9' | char_control_c, # [10 = Ctrl-9 -> #\CONTROL-9] '0' | char_control_c, # [11 = Ctrl-0 -> #\CONTROL-0] '-' | char_meta_c, # [12 = Ctrl-- -> #\CONTROL-- # nicht international portabel] '=' | char_meta_c, # [13 = Ctrl-= -> #\CONTROL-= # nicht international portabel] BS | char_meta_c, # 14 -> Alt-Backspace 9 | char_super_c, # 15 -> Shift-Tab 'Q' | char_meta_c, # 16 -> Alt-Q 'W' | char_meta_c, # 17 -> Alt-W 'E' | char_meta_c, # 18 -> Alt-E 'R' | char_meta_c, # 19 -> Alt-R 'T' | char_meta_c, # 20 -> Alt-T 'Y' | char_meta_c, # 21 -> Alt-Y 'U' | char_meta_c, # 22 -> Alt-U 'I' | char_meta_c, # 23 -> Alt-I 'O' | char_meta_c, # 24 -> Alt-O 'P' | char_meta_c, # 25 -> Alt-P '[' | char_meta_c, # 26 -> Alt-[ # nicht international portabel ']' | char_meta_c, # 27 -> Alt-] # nicht international portabel CR | char_meta_c, # 28 = Alt-Return -> #\META-Return 0, 'A' | char_meta_c, # 30 -> Alt-A 'S' | char_meta_c, # 31 -> Alt-S 'D' | char_meta_c, # 32 -> Alt-D 'F' | char_meta_c, # 33 -> Alt-F 'G' | char_meta_c, # 34 -> Alt-G 'H' | char_meta_c, # 35 -> Alt-H 'J' | char_meta_c, # 36 -> Alt-J 'K' | char_meta_c, # 37 -> Alt-K 'L' | char_meta_c, # 38 -> Alt-L oder Alt-\ ?? ';' | char_meta_c, # 39 -> Alt-; # nicht international portabel '\''| char_meta_c, # 40 -> Alt-' # nicht international portabel '`' | char_meta_c, # 41 -> Alt-` # nicht international portabel 0, '\\'| char_meta_c, # 43 -> Alt-\ # nicht international portabel 'Z' | char_meta_c, # 44 -> Alt-Z 'X' | char_meta_c, # 45 -> Alt-X 'C' | char_meta_c, # 46 -> Alt-C 'V' | char_meta_c, # 47 -> Alt-V 'B' | char_meta_c, # 48 -> Alt-B 'N' | char_meta_c, # 49 -> Alt-N 'M' | char_meta_c, # 50 -> Alt-M ',' | char_meta_c, # 51 = Alt-, -> #\META-',' # nicht international portabel '.' | char_meta_c, # 52 = Alt-. -> #\META-'.' # nicht international portabel '/' | char_meta_c, # 53 = Alt-/ -> #\META-'/' # nicht international portabel 0, '*' | char_meta_c | char_hyper_c, # 55 = Alt-* -> #\META-HYPER-'*' 0, ' ' | char_meta_c, # 57 = Alt-Space -> #\META-Space 0, 'A' | char_hyper_c, # 59 = F1 -> #\F1 = #\HYPER-A 'B' | char_hyper_c, # 60 = F2 -> #\F2 = #\HYPER-B 'C' | char_hyper_c, # 61 = F3 -> #\F3 = #\HYPER-C 'D' | char_hyper_c, # 62 = F4 -> #\F4 = #\HYPER-D 'E' | char_hyper_c, # 63 = F5 -> #\F5 = #\HYPER-E 'F' | char_hyper_c, # 64 = F6 -> #\F6 = #\HYPER-F 'G' | char_hyper_c, # 65 = F7 -> #\F7 = #\HYPER-G 'H' | char_hyper_c, # 66 = F8 -> #\F8 = #\HYPER-H 'I' | char_hyper_c, # 67 = F9 -> #\F9 = #\HYPER-I 'J' | char_hyper_c, # 68 = F10 -> #\F10 = #\HYPER-J 'K' | char_hyper_c, # [69 = F11 -> #\F11 = #\HYPER-K] 'L' | char_hyper_c, # [70 = F12 -> #\F12 = #\HYPER-L] 23 | char_hyper_c, # 71 = Home -> #\Home = #\HYPER-Code23 24 | char_hyper_c, # 72 = Up -> #\Up = #\HYPER-Code24 25 | char_hyper_c, # 73 = PgUp -> #\PgUp = #\HYPER-Code25 '-' | char_meta_c | char_hyper_c, # 74 = Alt-- -> #\META-HYPER-- 20 | char_hyper_c, # 75 = Left -> #\Left = #\HYPER-Code20 21 | char_hyper_c, # [76 -> #\HYPER-Code21] 22 | char_hyper_c, # 77 = Right -> #\Right = #\HYPER-Code22 '+' | char_meta_c | char_hyper_c, # 78 = Alt-+ -> #\META-HYPER-+ 17 | char_hyper_c, # 79 = End -> #\End = #\HYPER-Code17 18 | char_hyper_c, # 80 = Down -> #\Down = #\HYPER-Code18 19 | char_hyper_c, # 81 = PgDn -> #\PgDn = #\HYPER-Code19 16 | char_hyper_c, # 82 = Insert -> #\Insert = #\HYPER-Code16 127 | char_hyper_c, # 83 = Delete -> #\Delete = #\HYPER-Code127 'A' | char_super_c | char_hyper_c, # 84 = Shift-F1 -> #\S-F1 = #\SUPER-HYPER-A 'B' | char_super_c | char_hyper_c, # 85 = Shift-F2 -> #\S-F2 = #\SUPER-HYPER-B 'C' | char_super_c | char_hyper_c, # 86 = Shift-F3 -> #\S-F3 = #\SUPER-HYPER-C 'D' | char_super_c | char_hyper_c, # 87 = Shift-F4 -> #\S-F4 = #\SUPER-HYPER-D 'E' | char_super_c | char_hyper_c, # 88 = Shift-F5 -> #\S-F5 = #\SUPER-HYPER-E 'F' | char_super_c | char_hyper_c, # 89 = Shift-F6 -> #\S-F6 = #\SUPER-HYPER-F 'G' | char_super_c | char_hyper_c, # 90 = Shift-F7 -> #\S-F7 = #\SUPER-HYPER-G 'H' | char_super_c | char_hyper_c, # 91 = Shift-F8 -> #\S-F8 = #\SUPER-HYPER-H 'I' | char_super_c | char_hyper_c, # 92 = Shift-F9 -> #\S-F9 = #\SUPER-HYPER-I 'J' | char_super_c | char_hyper_c, # 93 = Shift-F10 -> #\S-F10 = #\SUPER-HYPER-J 'A' | char_control_c | char_hyper_c, # 94 = Control-F1 -> #\C-F1 = #\CONTROL-HYPER-A 'B' | char_control_c | char_hyper_c, # 95 = Control-F2 -> #\C-F2 = #\CONTROL-HYPER-B 'C' | char_control_c | char_hyper_c, # 96 = Control-F3 -> #\C-F3 = #\CONTROL-HYPER-C 'D' | char_control_c | char_hyper_c, # 97 = Control-F4 -> #\C-F4 = #\CONTROL-HYPER-D 'E' | char_control_c | char_hyper_c, # 98 = Control-F5 -> #\C-F5 = #\CONTROL-HYPER-E 'F' | char_control_c | char_hyper_c, # 99 = Control-F6 -> #\C-F6 = #\CONTROL-HYPER-F 'G' | char_control_c | char_hyper_c, # 100 = Control-F7 -> #\C-F7 = #\CONTROL-HYPER-G 'H' | char_control_c | char_hyper_c, # 101 = Control-F8 -> #\C-F8 = #\CONTROL-HYPER-H 'I' | char_control_c | char_hyper_c, # 102 = Control-F9 -> #\C-F9 = #\CONTROL-HYPER-I 'J' | char_control_c | char_hyper_c, # 103 = Control-F10 -> #\C-F10 = #\CONTROL-HYPER-J 'A' | char_meta_c | char_hyper_c, # 104 = Alt-F1 -> #\M-F1 = #\META-HYPER-A 'B' | char_meta_c | char_hyper_c, # 105 = Alt-F2 -> #\M-F2 = #\META-HYPER-B 'C' | char_meta_c | char_hyper_c, # 106 = Alt-F3 -> #\M-F3 = #\META-HYPER-C 'D' | char_meta_c | char_hyper_c, # 107 = Alt-F4 -> #\M-F4 = #\META-HYPER-D 'E' | char_meta_c | char_hyper_c, # 108 = Alt-F5 -> #\M-F5 = #\META-HYPER-E 'F' | char_meta_c | char_hyper_c, # 109 = Alt-F6 -> #\M-F6 = #\META-HYPER-F 'G' | char_meta_c | char_hyper_c, # 110 = Alt-F7 -> #\M-F7 = #\META-HYPER-G 'H' | char_meta_c | char_hyper_c, # 111 = Alt-F8 -> #\M-F8 = #\META-HYPER-H 'I' | char_meta_c | char_hyper_c, # 112 = Alt-F9 -> #\M-F9 = #\META-HYPER-I 'J' | char_meta_c | char_hyper_c, # 113 = Alt-F10 -> #\M-F10 = #\META-HYPER-J 29 | char_control_c | char_hyper_c, # 114 = Control-PrtScr -> #\CONTROL-HYPER-Code29 20 | char_control_c | char_hyper_c, # 115 = Control-Left -> #\C-Left = #\CONTROL-HYPER-Code20 22 | char_control_c | char_hyper_c, # 116 = Control-Right -> #\C-Right = #\CONTROL-HYPER-Code22 17 | char_control_c | char_hyper_c, # 117 = Control-End -> #\C-End = #\CONTROL-HYPER-Code17 19 | char_control_c | char_hyper_c, # 118 = Control-PgDn -> #\C-PgDn = #\CONTROL-HYPER-Code19 23 | char_control_c | char_hyper_c, # 119 = Control-Home -> #\C-Home = #\CONTROL-HYPER-Code23 '1' | char_meta_c, # 120 = Alt-1 -> #\META-1 '2' | char_meta_c, # 121 = Alt-2 -> #\META-2 '3' | char_meta_c, # 122 = Alt-3 -> #\META-3 '4' | char_meta_c, # 123 = Alt-4 -> #\META-4 '5' | char_meta_c, # 124 = Alt-5 -> #\META-5 '6' | char_meta_c, # 125 = Alt-6 -> #\META-6 '7' | char_meta_c, # 126 = Alt-7 -> #\META-7 '8' | char_meta_c, # 127 = Alt-8 -> #\META-8 '9' | char_meta_c, # 128 = Alt-9 -> #\META-9 '0' | char_meta_c, # 129 = Alt-0 -> #\META-0 '-' | char_meta_c, # 130 = Alt-- -> #\META-- # nicht international portabel '=' | char_meta_c, # 131 = Alt-= -> #\META-= # nicht international portabel 25 | char_control_c | char_hyper_c, # 132 = Control-PgUp -> #\C-PgUp = #\CONTROL-HYPER-Code25 'K' | char_hyper_c, # 133 = F11 -> #\F11 = #\HYPER-K 'L' | char_hyper_c, # 134 = F12 -> #\F12 = #\HYPER-L 'K' | char_super_c | char_hyper_c, # 135 = Shift-F11 -> #\S-F11 = #\SUPER-HYPER-K 'L' | char_super_c | char_hyper_c, # 136 = Shift-F12 -> #\S-F12 = #\SUPER-HYPER-L 'K' | char_control_c | char_hyper_c, # 137 = Control-F11 -> #\C-F11 = #\CONTROL-HYPER-K 'L' | char_control_c | char_hyper_c, # 138 = Control-F12 -> #\C-F12 = #\CONTROL-HYPER-L 'K' | char_meta_c | char_hyper_c, # 139 = Alt-F1 -> #\M-F11 = #\META-HYPER-K 'L' | char_meta_c | char_hyper_c, # 140 = Alt-F2 -> #\M-F12 = #\META-HYPER-L 24 | char_control_c | char_hyper_c, # 141 = Control-Up -> #\C-Up = #\CONTROL-HYPER-Code24 '-' | char_control_c | char_hyper_c, # 142 = Control-- -> #\CONTROL-HYPER-- 21 | char_control_c | char_hyper_c, # 143 = Control-Keypad5 -> #\CONTROL-HYPER-Code21 '+' | char_control_c | char_hyper_c, # 142 = Control-+ -> #\CONTROL-HYPER-+ 18 | char_control_c | char_hyper_c, # 145 = Control-Down -> #\C-Down = #\CONTROL-HYPER-Code18 16 | char_control_c | char_hyper_c, # 146 = Control-Insert -> #\C-Insert = #\CONTROL-HYPER-Code16 127 | char_control_c | char_hyper_c, # 147 = Control-Delete -> #\CONTROL-HYPER-Delete 9 | char_control_c, # 148 = Control-Tab -> #\CONTROL-Tab '/' | char_control_c | char_hyper_c, # 149 = Control-/ -> #\CONTROL-HYPER-'/' '*' | char_control_c | char_hyper_c, # 150 = Control-* -> #\CONTROL-HYPER-'*' 23 | char_meta_c | char_hyper_c, # 151 = Alt-Home -> #\M-Home = #\META-HYPER-Code23 24 | char_meta_c | char_hyper_c, # 152 = Alt-Up -> #\M-Up = #\META-HYPER-Code24 25 | char_meta_c | char_hyper_c, # 153 = Alt-PgUp -> #\M-PgUp = #\META-HYPER-Code25 0, 20 | char_meta_c | char_hyper_c, # 155 = Alt-Left -> #\M-Left = #\META-HYPER-Code20 21 | char_meta_c | char_hyper_c, # [156 -> #\META-HYPER-Code21] 22 | char_meta_c | char_hyper_c, # 157 = Alt-Right -> #\M-Right = #\META-HYPER-Code22 0, 17 | char_meta_c | char_hyper_c, # 159 = Alt-End -> #\M-End = #\META-HYPER-Code17 18 | char_meta_c | char_hyper_c, # 160 = Alt-Down -> #\M-Down = #\META-HYPER-Code18 19 | char_meta_c | char_hyper_c, # 161 = Alt-PgDn -> #\M-PgDn = #\META-HYPER-Code19 16 | char_meta_c | char_hyper_c, # 162 = Alt-Insert -> #\M-Insert = #\META-HYPER-Code16 127 | char_meta_c | char_hyper_c, # 163 = Alt-Delete -> #\META-HYPER-Delete '/' | char_meta_c | char_hyper_c, # 164 = Alt-/ -> #\META-HYPER-'/' 9 | char_meta_c, # 165 = Alt-Tab -> #\META-Tab CR | char_meta_c | char_hyper_c, # 166 = Alt-Enter -> #\META-HYPER-Return }; #ifdef EMUNIX_PORTABEL # Wir haben, um portabel zu bleiben, nur die Funktion _read_kbd zur Verfⁿgung. # Diese erkennt unter DOS aber nur recht wenige Sondertasten: nur die mit # Scan-Codes 3, 7, 15-25, 30-38, 44-50, 59-131 (ungefΣhr). # Insbesondere fehlen F11, F12, Ctrl-Up, Ctrl-Down, und man kann # Enter von Return, Tab von Ctrl-I, Backspace von Ctrl-H nicht unterscheiden. # Trotzdem! #ifdef EMUNIX_NEW_8f # Da INT 16,10 unter DOS nun endlich befriedigend funktioniert, verwenden wir # dieses. Zur Laufzeit wird _osmode abgefragt. #endif #endif # EMUNIX_PORTABEL #endif # !WINDOWS #endif # MSDOS # Stellt fest, ob der Keyboard-Stream ein Zeichen verfⁿgbar hat. # listen_keyboard(stream) # > stream: Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF local signean listen_keyboard (object stream); #if defined(ATARI) || defined(MSDOS) local signean listen_keyboard(stream) var reg1 object stream; { #ifdef ATARI if (GEMDOS_ConStat()==0) # inzwischen wieder Tasten gedrⁿckt? { return signean_plus; } # nein else { return signean_null; } # ja #endif #ifdef MSDOS #ifdef EMUNIX_PORTABEL if (!(_osmode == DOS_MODE)) # OS/2 { var reg2 int ch = _read_kbd(FALSE,FALSE,FALSE); if (ch < 0) { return signean_plus; } # nein {var reg2 cint c = (ch==0 ? scancode_table[(uintB)_read_kbd(FALSE,TRUE,FALSE)] : (ch <= 26) && !(ch == BS) && !(ch == CR) && !(ch == TAB) ? # Ctrl-A bis Ctrl-Z -> Buchstabe mit CONTROL-Bit draus machen: ((cint)(ch==LF ? CR : (ch | bit(6))) << char_code_shift_c) | char_control_c : (cint)(uintB)ch << char_code_shift_c ); /* asciz_out("{"); hex_out(ch); asciz_out("}"); _sleep2(500); */ # Test TheStream(stream)->strm_rd_ch_last = char_to_fixnum(int_char(c)); return signean_null; }} else #endif # DOS if (kbhit()) # inzwischen wieder Tasten gedrⁿckt? { return signean_null; } # ja else { return signean_plus; } # nein #endif } #endif #if defined(UNIX) || defined(RISCOS) #define listen_keyboard listen_handle #endif # UP: L÷scht bereits eingegebenen interaktiven Input vom Keyboard-Stream. # clear_input_keyboard(stream); # > stream: Stream # < ergebnis: TRUE falls Input gel÷scht wurde, FALSE sonst local boolean clear_input_keyboard (object stream); local boolean clear_input_keyboard(stream) var reg1 object stream; { #ifdef ATARI # GEMDOS-Tastaturbuffer leeren: loop { if (GEMDOS_ConStat()==0) break; # Buffer leer -> fertig GEMDOS_DirConIn(); # sonst: Zeichen verbrauchen } #endif #ifdef MSDOS #ifdef EMUNIX_PORTABEL if (!(_osmode == DOS_MODE)) # OS/2 { while (listen_keyboard(stream)) { /* das Zeichen wurde schon geholt! */ } } else #endif # DOS while (kbhit()) { getch(); } #endif #if defined(UNIX) || defined(RISCOS) if (nullp(TheStream(stream)->strm_keyboard_isatty)) # File -> nichts tun { return FALSE; } # Terminal TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen clear_tty_input(stdin_handle); pushSTACK(stream); while (listen_keyboard(STACK_0) == 0) { read_char(&STACK_0); } skipSTACK(1); #endif return TRUE; } # Lesen eines Zeichens vom Keyboard: local object rd_ch_keyboard (object* stream_); #ifdef ATARI # # Um einerseits bei normalen Tasten feststellen zu k÷nnen, ob sie mit # und ohne Shift dasselbe ergeben hΣtte, und um andererseits von nationalen # SpezialitΣten wie 'Σ', '÷', 'ⁿ', Shift-ⁿ = @ usw. unabhΣngig zu sein, # lassen wir uns vom BIOS den Ascii-Code geben, entscheiden aber hinterher # aufgrund der BIOS-Tastaturtabellen, ob wir ihn verwenden wollen oder nicht. # # Zeiger auf die drei Tastaturtabellen des BIOS (LΣnge 128, Index: Scancode, # Wert: Ascii-Code), werden beim Programmstart initialisiert: local KEYTAB keytables; # local object rd_ch_keyboard(stream_) var reg7 object* stream_; { var reg6 object ch; run_time_stop(); # Run-Time-Stoppuhr anhalten restart_it: {# Tastendruck abwarten, nichts ausgeben: var reg5 uintL erg = GEMDOS_DirConIn(); # Wegen der Initialisierung in SPVW.Q ist # in (erg>>24) der Sondertasten-Status enthalten. { var reg4 uintB code = (uintB)erg; # Ascii-Code var reg3 uintB scancode = (uintB)(erg>>16); # Scan-Code var reg2 uintB kbshift = (uintB)(erg>>24); # Sondertasten-Status var reg1 cint c = 0; # neues Character # Eine kleine Merkwⁿrdigkeit beheben: # Beim Drⁿcken von [Shift-]Ctrl-Alt-Insert bzw. -ClrHome liefert # das BIOS zwei TastenanschlΣge (und doppelten Tastaturclick): # Ctrl-Alt-Insert: 0x0C520000, 0x0CD20000, # Ctrl-Alt-ClrHome: 0x0C770000, 0x0CC70000, # und zwischen diesen beiden AnschlΣgen wird die linke bzw. # rechte Maustaste als gedrⁿckt betrachtet (z.B. BIOS_KBSHIFT, # liefert gesetztes Bit 6 bzw. Bit 5). # 0xD2 und 0xC7 sind natⁿrlich irrsinnige Scan-Codes. Sie ent- # stehen offenbar als 82+128 bzw. 71+128. # Wir behandeln das Problem so, da▀ wir den zweiten Tastenanschlag # dann ignorieren, wenn er kommt. if (scancode >= 59+128) # Scancode einer Sondertaste, um 128 erh÷ht? goto restart_it; # ja -> diesen Tastenanschlag ⁿbergehen # (Eigentlich mⁿ▀te deswegen auch listen_keyboard geΣndert werden.) {var reg8 uintB* keytables_normal = keytables.unshift; # Scan-Code aufbereiten und auf Sondertaste entscheiden: if ((scancode >= 120) && (scancode <= 131)) { scancode = scancode-118; } # 120->2,121->3,... 'Alt i' -> 'i' if ((scancode >= 59) && !(scancode == 96)) # Scancode <59 oder =96 -> normale Taste # Sondertaste { if ((scancode < 96) && (scancode >= 84)) { scancode = scancode-25; } # 84->59,85->60,... 'Shift Fi' -> 'Fi' switch (scancode) { case 115: scancode = 75; break; # 115->75 'Ctrl-' -> '' case 116: scancode = 77; break; # 116->77 'Ctrl-' -> '' case 117: scancode = 79; break; # 117->79 'Ctrl-End' -> 'End' case 118: scancode = 81; break; # 118->81 'Ctrl-PgDn' -> 'PgDn' case 119: scancode = 71; break; # 119->71 'Ctrl-Home' -> 'Home' case 132: scancode = 73; break; # 132->73 'Ctrl-PgUp' -> 'PgUp' default: ; } c |= char_hyper_c; # HYPER-Bit setzen } # Ascii-Code ⁿbernehmen bzw. neu berechnen: if (kbshift & (CapsLockKey_mask | CtrlKey_mask | AltKey_mask)) # Caps-Lock eingeschaltet oder Control- oder Alternate-Taste gedrⁿckt { keytables_normal = keytables.capslock; } if ((code >= 32) && ((scancode < 71) || (scancode >= 84))) # Ascii-Code ⁿbernehmen, evtl. Shift- oder Alt-Bit killen: { if (kbshift & BothShiftKey_mask) # Shift gedrⁿckt { if (keytables.shift[scancode] == code) # Ascii-Code kam aus der Tabelle 'shift' { if (keytables_normal[scancode] == code) # Ascii-Code kam auch aus der Tabelle 'unshift'/'capslock' { c |= char_super_c; } # 'Shift' war unn÷tig -> SUPER-Bit setzen else {} # 'Shift' war n÷tig, 'Shift' killen } else # Ascii-Code kam wohl durch 'Alt' zustande, 'Alt' und 'Shift' killen { kbshift &= ~AltKey_mask; } } else # Shift nicht gedrⁿckt { if (keytables_normal[scancode] == code) {} # Ascii-Code kam aus der Tabelle 'unshift'/'capslock' else # Ascii-Code kam wohl durch 'Alt' zustande, 'Alt' killen { kbshift &= ~AltKey_mask; } } } else # Ascii-Code <32 (oder >=32, aber vom Cursorblock), # das erkennen wir nicht an. { if (kbshift & BothShiftKey_mask) # Shift gedrⁿckt { # Ascii-Code nicht (immer) aus der Tabelle 'shift' nehmen, denn # die enthΣlt Ziffern 024678 bei Tasten aus dem Cursorblock! code = keytables.capslock[scancode]; # Ascii-Code aus der Tabelle 'capslock' c |= char_super_c; # SUPER-Bit setzen } else # Shift nicht gedrⁿckt { code = keytables_normal[scancode]; } # Ascii-Code aus der Tabelle 'unshift'/'capslock' } if (code==0) # setze den Scan-Code in eine Sondertaste um: { if ((scancode >= 59) && (scancode < 99)) { # Tabelle der Characters, die den Scan-Codes 59..98 entsprechen: local uintB table [99-59] = { 'A', # 59 = F1 -> #\F1 = #\HYPER-A 'B', # 60 = F2 -> #\F2 = #\HYPER-B 'C', # 61 = F3 -> #\F3 = #\HYPER-C 'D', # 62 = F4 -> #\F4 = #\HYPER-D 'E', # 63 = F5 -> #\F5 = #\HYPER-E 'F', # 64 = F6 -> #\F6 = #\HYPER-F 'G', # 65 = F7 -> #\F7 = #\HYPER-G 'H', # 66 = F8 -> #\F8 = #\HYPER-H 'I', # 67 = F9 -> #\F9 = #\HYPER-I 'J', # 68 = F10 -> #\F10 = #\HYPER-J 'K', # [69 = F11 -> #\F11 = #\HYPER-K] 'L', # [70 = F12 -> #\F12 = #\HYPER-L] 23, # 71 = ClrHome -> #\Home = #\HYPER-Code23 24, # 72 = -> #\Up = #\HYPER-Code24 25, # [73 = PgUp -> #\PgUp = #\HYPER-Code25] '-', # [74 = - -> #\HYPER--] 20, # 75 = -> #\Left = #\HYPER-Code20 0, 22, # 77 = -> #\Right = #\HYPER-Code22 '+', # [78 = + -> #\HYPER-+] 17, # [79 = End -> #\End = #\HYPER-Code17] 18, # 80 = -> #\Down = #\HYPER-Code18 19, # [81 = PgDn -> #\PgDn = #\HYPER-Code19] 16, # 82 = Insert -> #\Insert = #\HYPER-Code16 127, # [83 = Delete -> #\Delete = #\HYPER-Code127] 'A', # [84 = Shift F1 -> #\SUPER-F1 = #\SUPER-HYPER-A] 'B', # [85 = Shift F2 -> #\SUPER-F2 = #\SUPER-HYPER-B] 'C', # [86 = Shift F3 -> #\SUPER-F3 = #\SUPER-HYPER-C] 'D', # [87 = Shift F4 -> #\SUPER-F4 = #\SUPER-HYPER-D] 'E', # [88 = Shift F5 -> #\SUPER-F5 = #\SUPER-HYPER-E] 'F', # [89 = Shift F6 -> #\SUPER-F6 = #\SUPER-HYPER-F] 'G', # [90 = Shift F7 -> #\SUPER-F7 = #\SUPER-HYPER-G] 'H', # [91 = Shift F8 -> #\SUPER-F8 = #\SUPER-HYPER-H] 'I', # [92 = Shift F9 -> #\SUPER-F9 = #\SUPER-HYPER-I] 'J', # [93 = Shift F10 -> #\SUPER-F10 = #\SUPER-HYPER-J] 'K', # [94 = Shift F11 -> #\SUPER-F11 = #\SUPER-HYPER-K] 'L', # [95 = Shift F12 -> #\SUPER-F12 = #\SUPER-HYPER-L] 0, 29, # 97 = Undo -> #\Undo = #\HYPER-Code29 28, # 98 = Help -> #\Help = #\HYPER-Code28 }; code = table[scancode-59]; } } # Ascii-Code fertig if (kbshift & CtrlKey_mask) # Control-Taste gedrⁿckt? { c |= char_control_c; } # ja -> CONTROL-Bit setzen if (kbshift & AltKey_mask) # Alternate-Taste gedrⁿckt? { c |= char_meta_c; } # ja -> META-Bit setzen c |= ((cint)code << char_code_shift_c); ch = int_char(c); }}} run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen return ch; } #endif #ifdef MSDOS local object rd_ch_keyboard(stream_) var reg7 object* stream_; { #ifdef EMUNIX_PORTABEL if (!(_osmode == DOS_MODE)) # OS/2 { run_time_stop(); # Run-Time-Stoppuhr anhalten {var reg1 int ch = _read_kbd(FALSE,TRUE,FALSE); var reg2 cint c = (ch==0 ? scancode_table[(uintB)_read_kbd(FALSE,TRUE,FALSE)] : (ch <= 26) && !(ch == BS) && !(ch == CR) && !(ch == TAB) ? # Ctrl-A bis Ctrl-Z -> Buchstabe mit CONTROL-Bit draus machen: ((cint)(ch==LF ? CR : (ch | bit(6))) << char_code_shift_c) | char_control_c : (cint)(uintB)ch << char_code_shift_c ); # noch zu behandeln: ?? # Ctrl-2 -> #\Control-2, Ctrl-6 -> #\Code30, Ctrl-▀ -> #\Code28, # Ctrl-+ -> #\Code29, Ctrl-ⁿ -> #\Code27 = #\Escape /* asciz_out("{"); hex_out(ch); asciz_out("}"); _sleep2(500); */ # Test run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen return int_char(c); }} else #endif # DOS {var reg6 object ch; run_time_stop(); # Run-Time-Stoppuhr anhalten { # Tastendruck abwarten, nichts ausgeben: var reg5 uintW erg = getch(); #ifdef WINDOWS var reg1 cint c = erg; #else var reg4 uintB code = (uintB)erg; # Ascii-Code var reg3 uintB scancode = (uintB)(erg>>8); # Scan-Code var reg1 cint c = 0; # neues Character if (scancode == 0) # Multikey-Event, z.B. accent+space oder Alt xyz { c = (cint)code << char_code_shift_c; } else { if ((code == 0) || (code == 0xE0)) # Sondertaste { c = (scancode < 167 ? scancode_table[scancode] : 0); } else { if (((scancode >= 71) && (scancode < 84)) || (scancode == 55) || ((scancode == 0xE0) && (code >= 32)) ) # Ziffernblocktaste au▀er Enter (auch nicht F1 bis F12 !) { c = ((cint)code << char_code_shift_c) | char_hyper_c; } elif ((scancode == 14) || (scancode == 28) || ((scancode == 0xE0) && (code < 32)) ) # Backspace-Taste, Return-Taste, Enter-Taste { var reg5 uintB defaultcode = (scancode==14 ? BS : CR); c = (cint)defaultcode << char_code_shift_c; if (scancode == 0xE0) { c |= char_hyper_c; } if (!(code == defaultcode)) { c |= char_control_c; } } else { if ((code < 32) && ((scancode >= 16) && (scancode <= 53))) # Ctrl-A bis Ctrl-Z -> Buchstabe mit CONTROL-Bit draus machen: { c = ((cint)(code | bit(6)) << char_code_shift_c) | char_control_c; } else # normales Zeichen { c = (cint)code << char_code_shift_c; } } } } # noch zu behandeln: ?? # Ctrl-2 0300 # Ctrl-6 071E # Ctrl-▀ 0C1C # Ctrl-- 0C1F #endif ch = int_char(c); } run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen return ch; }} #endif #if defined(UNIX) || defined(RISCOS) # vgl. rd_ch_handle() : local object rd_ch_keyboard(stream_) var reg3 object* stream_; { restart_it: {var reg2 object stream = *stream_; if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF? { return eof_value; } # Noch etwas im Buffer? if (mconsp(TheStream(stream)->strm_keyboard_buffer)) goto empty_buffer; # Ein Zeichen lesen: { var uintB c; read_next_char: {run_time_stop(); # Run-Time-Stoppuhr anhalten begin_system_call(); {var reg1 int ergebnis = read(stdin_handle,&c,1); # Zeichen lesen versuchen end_system_call(); run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } OS_error(); } if (ergebnis==0) # kein Zeichen verfⁿgbar -> EOF erkennen { TheStream(stream)->strm_rd_ch_last = eof_value; return eof_value; } }} next_char_is_read: # Es verlΣngert den Buffer: {var reg4 object new_cons = allocate_cons(); Car(new_cons) = code_char(c); stream = *stream_; {var reg1 object* last_ = &TheStream(stream)->strm_keyboard_buffer; while (mconsp(*last_)) { last_ = &Cdr(*last_); } *last_ = new_cons; }} # Ist der Buffer eine vollstΣndige Zeichenfolge zu einer Taste, # so liefern wir diese Taste. Ist der Buffer ein echtes Anfangsstⁿck # einer Zeichenfolge zu einer Taste, so warten wir noch ein wenig. # Ansonsten fangen wir an, den Buffer Zeichen fⁿr Zeichen zu leeren. { var reg4 object keytab = TheStream(stream)->strm_keyboard_keytab; while (consp(keytab)) { var reg1 object L1 = Car(keytab); keytab = Cdr(keytab); {var reg1 object L2 = TheStream(stream)->strm_keyboard_buffer; while (consp(L1) && consp(L2) && eq(Car(L1),Car(L2))) { L1 = Cdr(L1); L2 = Cdr(L2); } if (atomp(L2)) { if (atomp(L1)) # vollstΣndige Zeichenfolge { TheStream(stream)->strm_keyboard_buffer = NIL; return L1; } }} } } { var reg4 object keytab = TheStream(stream)->strm_keyboard_keytab; while (consp(keytab)) { var reg1 object L1 = Car(keytab); keytab = Cdr(keytab); {var reg1 object L2 = TheStream(stream)->strm_keyboard_buffer; while (consp(L1) && consp(L2) && eq(Car(L1),Car(L2))) { L1 = Cdr(L1); L2 = Cdr(L2); } if (atomp(L2)) # Da consp(L1), liegt ein Anfangsstⁿck einer Zeichenfolge vor. goto wait_for_another; } }} goto empty_buffer; wait_for_another: #ifdef HAVE_SELECT { # Verwende select mit readfds = einelementige Menge {stdin_handle} # und timeout = kleines Zeitintervall. var fd_set handle_menge; # Menge von Handles := {stdin_handle} var struct timeval small_time; # Zeitintervall := 0 FD_ZERO(&handle_menge); FD_SET(stdin_handle,&handle_menge); restart_select: small_time.tv_sec = 0; small_time.tv_usec = 1000000/10; # 1/10 sec run_time_stop(); # Run-Time-Stoppuhr anhalten begin_system_call(); {var reg1 int ergebnis; ergebnis = select(FD_SETSIZE,&handle_menge,NULL,NULL,&small_time); end_system_call(); run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen if (ergebnis<0) { if (errno==EINTR) goto restart_select; if (!(errno == EBADF)) { OS_error(); } } else { # ergebnis = Anzahl der Handles in handle_menge, bei denen read # sofort ein Ergebnis liefern wⁿrde. if (ergebnis==0) goto empty_buffer; # kein Zeichen verfⁿgbar # ergebnis=1 -> Zeichen verfⁿgbar }} } #else #if defined(UNIX_TERM_TERMIOS) || defined(UNIX_TERM_TERMIO) { # Verwende die Termio-Elemente VMIN und VTIME. #ifdef UNIX_TERM_TERMIOS var struct termios oldtermio; var struct termios newtermio; #else # UNIX_TERM_TERMIO var struct termio oldtermio; var struct termio newtermio; #endif run_time_stop(); # Run-Time-Stoppuhr anhalten begin_system_call(); #ifdef UNIX_TERM_TERMIOS if (!( tcgetattr(stdin_handle,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #else if (!( ioctl(stdin_handle,TCGETA,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #endif # Wir gehen nun davon aus, da▀ oldtermio nun mit dem newtermio aus # term_raw() (s.u.) identisch ist. Das ist dann gewΣhrleistet, wenn # 1. (SYS::TERMINAL-RAW T) aufgerufen wurde und # 2. stdin_handle und stdout_handle beide dasselbe Terminal sind. ?? newtermio = oldtermio; newtermio.c_cc[VMIN] = 0; newtermio.c_cc[VTIME] = 1; # 1/10 Sekunde Timeout #ifdef UNIX_TERM_TERMIOS if (!( TCSETATTR(stdin_handle,TCSANOW,&newtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #else if (!( ioctl(stdin_handle,TCSETA,&newtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #endif {var reg1 int ergebnis = read(stdin_handle,&c,1); # Zeichen lesen versuchen, mit Timeout #ifdef UNIX_TERM_TERMIOS if (!( TCSETATTR(stdin_handle,TCSANOW,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #else if (!( ioctl(stdin_handle,TCSETA,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #endif end_system_call(); run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } OS_error(); } if (ergebnis==0) goto empty_buffer; # kein Zeichen verfⁿgbar goto next_char_is_read; # ergebnis=1 -> Zeichen verfⁿgbar }} #else # Man k÷nnte hier fcntl(stdin_handle,F_SETFL,...|FASYNC) verwenden # und auf Signal SIGIO warten. Allerdings funktioniert das auf so # wenigen Systemen (siehe Emacs), da▀ es sich wohl nicht lohnt. #endif #endif goto read_next_char; } # Buffer Zeichen fⁿr Zeichen liefern: empty_buffer: { var reg1 object l = TheStream(stream)->strm_keyboard_buffer; TheStream(stream)->strm_keyboard_buffer = Cdr(l); {var reg1 uintB c = char_code(Car(l)); if ((c >= ' ') || (c == ESC) || (c == TAB) || (c == CR) || (c == BS)) { return code_char(c); } else # Taste vermutlich mit Ctrl getippt { return int_char(((64 | c) << char_code_shift_c) | char_control_c); } }} }} # UP: Erweitert die Liste STACK_0 um eine Tastenzuordnung. # kann GC ausl÷sen local void keybinding (char* cap, cint key); local void keybinding(cap,key) var reg4 char* cap; var reg3 cint key; { var reg1 uintB* ptr = (uintB*)cap; if (*ptr=='\0') return; # leere Tastenfolge vermeiden pushSTACK(allocate_cons()); # Liste (char1 ... charn . key) bilden: {var reg2 uintC count = 0; do { pushSTACK(code_char(*ptr)); ptr++; count++; } until (*ptr=='\0'); pushSTACK(int_char(key)); count++; funcall(L(liststern),count); } # und auf STACK_0 pushen: {var reg2 object l = popSTACK(); Car(l) = value1; Cdr(l) = STACK_0; STACK_0 = l; } } #endif # Liefert einen Keyboard-Stream. # make_keyboard_stream() # kann GC ausl÷sen local object make_keyboard_stream (void); local object make_keyboard_stream() { #if defined(UNIX) || defined(RISCOS) # Tabelle aller Zuordnungen Zeichenfolge -> Taste bilden: pushSTACK(NIL); # Terminal-Typ abfragen: begin_system_call(); {var reg3 char* s = getenv("TERM"); if (s==NULL) { end_system_call(); } else { var char tbuf[4096]; # interner Buffer fⁿr die Termcap-Routinen if (!(tgetent(tbuf,s)==1)) { end_system_call(); } else { var char tentry[4096]; # Buffer fⁿr von mir ben÷tigte Capabilities und Pointer da hinein var char* tp = &tentry[0]; var reg1 char* cap; end_system_call(); # Backspace: begin_system_call(); cap = tgetstr("kb",&tp); end_system_call(); if (cap) { keybinding(cap,BS); } # #\Backspace # Insert, Delete: begin_system_call(); cap = tgetstr("kI",&tp); end_system_call(); if (cap) { keybinding(cap,16 | char_hyper_c); } # #\Insert #ifdef UNIX_COHERENT begin_system_call(); cap = tgetstr("Ku",&tp); end_system_call(); if (cap) { keybinding(cap,16 | char_hyper_c); } # #\Insert #endif begin_system_call(); cap = tgetstr("kD",&tp); end_system_call(); if (cap) { keybinding(cap,127); } # #\Delete #ifdef UNIX_COHERENT begin_system_call(); cap = tgetstr("Kd",&tp); end_system_call(); if (cap) { keybinding(cap,127); } # #\Delete #endif # Pfeiltasten: begin_system_call(); cap = tgetstr("ku",&tp); end_system_call(); if (cap) { keybinding(cap,24 | char_hyper_c); } # #\Up if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'A') && (cap[3] == '\0')) { keybinding(ESCstring"[A",24 | char_hyper_c); } # #\Up begin_system_call(); cap = tgetstr("kd",&tp); end_system_call(); if (cap) { keybinding(cap,18 | char_hyper_c); } # #\Down if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'B') && (cap[3] == '\0')) { keybinding(ESCstring"[B",18 | char_hyper_c); } # #\Down begin_system_call(); cap = tgetstr("kr",&tp); end_system_call(); if (cap) { keybinding(cap,22 | char_hyper_c); } # #\Right if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'C') && (cap[3] == '\0')) { keybinding(ESCstring"[C",22 | char_hyper_c); } # #\Right begin_system_call(); cap = tgetstr("kl",&tp); end_system_call(); if (cap) { keybinding(cap,20 | char_hyper_c); } # #\Left if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'D') && (cap[3] == '\0')) { keybinding(ESCstring"[D",20 | char_hyper_c); } # #\Left # sonstige Cursorblock-Tasten: begin_system_call(); cap = tgetstr("kh",&tp); end_system_call(); if (cap) { keybinding(cap,23 | char_hyper_c); } # #\Home begin_system_call(); cap = tgetstr("K1",&tp); end_system_call(); if (cap) { keybinding(cap,23 | char_hyper_c); } # #\Home begin_system_call(); cap = tgetstr("KH",&tp); end_system_call(); if (cap) { keybinding(cap,17 | char_hyper_c); } # #\End begin_system_call(); cap = tgetstr("K4",&tp); end_system_call(); if (cap) { keybinding(cap,17 | char_hyper_c); } # #\End #ifdef UNIX_COHERENT begin_system_call(); cap = tgetstr("KE",&tp); end_system_call(); if (cap) { keybinding(cap,17 | char_hyper_c); } # #\End #endif begin_system_call(); cap = tgetstr("kP",&tp); end_system_call(); if (cap) { keybinding(cap,25 | char_hyper_c); } # #\PgUp begin_system_call(); cap = tgetstr("K3",&tp); end_system_call(); if (cap) { keybinding(cap,25 | char_hyper_c); } # #\PgUp #ifdef UNIX_COHERENT begin_system_call(); cap = tgetstr("Kp",&tp); end_system_call(); if (cap) { keybinding(cap,25 | char_hyper_c); } # #\PgUp #endif begin_system_call(); cap = tgetstr("kN",&tp); end_system_call(); if (cap) { keybinding(cap,19 | char_hyper_c); } # #\PgDn begin_system_call(); cap = tgetstr("K5",&tp); end_system_call(); if (cap) { keybinding(cap,19 | char_hyper_c); } # #\PgDn begin_system_call(); cap = tgetstr("K2",&tp); end_system_call(); #ifdef UNIX_COHERENT begin_system_call(); cap = tgetstr("KP",&tp); end_system_call(); if (cap) { keybinding(cap,19 | char_hyper_c); } # #\PgDn #endif if (cap) { keybinding(cap,21 | char_hyper_c); } # #\Center # Funktionstasten: { typedef struct { char* capname; cint key; } funkey; local var funkey funkey_tab[] = { { "k1", 'A' | char_hyper_c }, # #\F1 { "k2", 'B' | char_hyper_c }, # #\F2 { "k3", 'C' | char_hyper_c }, # #\F3 { "k4", 'D' | char_hyper_c }, # #\F4 { "k5", 'E' | char_hyper_c }, # #\F5 { "k6", 'F' | char_hyper_c }, # #\F6 { "k7", 'G' | char_hyper_c }, # #\F7 { "k8", 'H' | char_hyper_c }, # #\F8 { "k9", 'I' | char_hyper_c }, # #\F9 { "k0", 'J' | char_hyper_c }, # #\F10 { "k;", 'J' | char_hyper_c }, # #\F10 { "F1", 'K' | char_hyper_c }, # #\F11 { "F2", 'L' | char_hyper_c }, # #\F12 }; var reg2 uintL i; for (i=0; i < sizeof(funkey_tab)/sizeof(funkey); i++) { begin_system_call(); cap = tgetstr(funkey_tab[i].capname,&tp); end_system_call(); if (cap) { keybinding(cap,funkey_tab[i].key); } #ifdef UNIX_COHERENT # Shift-F1 bis Shift-F10 funktionieren, fehlen aber in /etc/termcap if ((i<10) # F1 bis F10 && cap && (cap[0] == ESC) && (cap[1] == '[') && (cap[2] == funkey_tab[i].capname[1]) && (cap[3] == 'x') && (cap[4] == '\0') ) { # neue Capability fⁿr Shift-Fi bilden und eintragen: var reg4 char* newcap = tp; *tp++ = ESC; *tp++ = '['; *tp++ = cap[2]; *tp++ = 'y'; *tp++ = '\0'; keybinding(newcap,char_super_c | funkey_tab[i].key); } #endif } } # Spezielle xterm-Behandlung: begin_system_call(); cap = tgetstr("ku",&tp); if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'A') && (cap[3] == '\0'))) goto not_xterm; cap = tgetstr("kd",&tp); if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'B') && (cap[3] == '\0'))) goto not_xterm; cap = tgetstr("kr",&tp); if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'C') && (cap[3] == '\0'))) goto not_xterm; cap = tgetstr("kl",&tp); if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'D') && (cap[3] == '\0'))) goto not_xterm; if (!tgetflag("km")) goto not_xterm; end_system_call(); { # Insert, Delete: keybinding(ESCstring"[2~",16 | char_hyper_c); # #\Insert keybinding(ESCstring"[3~",127); # #\Delete } { # Application Keypad: ESC O M -> Return, # ESC O k -> +, ESC O m -> -, ESC O j -> *, ESC O o -> / # (ohne Hyper-Bit, da das zu Terminal-abhΣngig wⁿrde) var char cap[4]; cap[0] = ESC; cap[1] = 'O'; cap[3] = '\0'; {var reg1 uintB c; for (c='E'; c<='z'; c++) { cap[2] = c; keybinding(&!cap,c-64); } }} begin_system_call(); if (!(tgetnum("kn")==4)) goto not_xterm; end_system_call(); xterm: { # Pfeiltasten s.o. # sonstige Cursorblock-Tasten: keybinding(ESCstring"[5~",25 | char_hyper_c); # #\PgUp keybinding(ESCstring"[6~",19 | char_hyper_c); # #\PgDn # Funktionstasten: keybinding(ESCstring"[11~",'A' | char_hyper_c); # #\F1 keybinding(ESCstring"[12~",'B' | char_hyper_c); # #\F2 keybinding(ESCstring"[13~",'C' | char_hyper_c); # #\F3 keybinding(ESCstring"[14~",'D' | char_hyper_c); # #\F4 keybinding(ESCstring"[15~",'E' | char_hyper_c); # #\F5 keybinding(ESCstring"[17~",'F' | char_hyper_c); # #\F6 keybinding(ESCstring"[18~",'G' | char_hyper_c); # #\F7 keybinding(ESCstring"[19~",'H' | char_hyper_c); # #\F8 keybinding(ESCstring"[20~",'I' | char_hyper_c); # #\F9 keybinding(ESCstring"[21~",'J' | char_hyper_c); # #\F10 keybinding(ESCstring"[23~",'K' | char_hyper_c); # #\F11 keybinding(ESCstring"[24~",'L' | char_hyper_c); # #\F12 } not_xterm: end_system_call(); } } } #endif {# neuen Stream allozieren: var reg2 object stream = allocate_stream(strmflags_rd_ch_B,strmtype_keyboard,strm_len+strm_keyboard_len); # Flags: nur READ-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_keyboard); # READ-CHAR-Pseudofunktion s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_dummy); # WRITE-CHAR unm÷glich s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy); #endif #if defined(UNIX) || defined(RISCOS) # Flag isatty = (stdin_tty ? T : NIL) bestimmen: begin_system_call(); s->strm_keyboard_isatty = (isatty(stdin_handle) ? T : NIL); end_system_call(); s->strm_keyboard_handle = allocate_handle(stdin_handle); s->strm_keyboard_buffer = NIL; s->strm_keyboard_keytab = popSTACK(); #endif return stream; }} #endif # KEYBOARD # Interaktiver Terminalstream # =========================== #ifdef ATARI # Funktionsweise: # Bei Bedarf an Zeichen wird eine ganze Zeile eingelesen. Sie wird durch NL # abgeschlossen. Die eingegebenen Zeichen bleiben am Bildschirm stehen. # Das abschlie▀ende NL wird erst dann ausgegeben (als CR/LF), wenn n÷tig, # d.h. bei der nΣchsten Bildschirmaktion (Lesen einer weiteren Eingabezeile # oder Ausgeben eines Zeichens). Ist diese nΣchste Bildschirmaktion eine # NL-Ausgabe, so wird NL nur einfach und nicht doppelt ausgegeben. # Ausgabe von Control-Zeichen: als Grafik-Zeichen, # alle anderen als Steuerzeichen. # Bug: Wird eine Zeile eingelesen, die mehr als einen ganzen Bildschirm # umfa▀t, so kann der Bildschirm bei Backspace usw. durcheinanderkommen. # ZusΣtzliche Komponenten: # INBUFF : Eingabebuffer, ein Simple-String #define strm_terminal_inbuff strm_other[0] # COUNT : Anzahl der Zeichen im Eingabebuffer #define strm_terminal_count strm_other[1] # INDEX : Anzahl der bereits verbrauchten Zeichen #define strm_terminal_index strm_other[2] # NLflag : 1 falls NL wartet, 0 sonst #define strm_terminal_NLflag strm_other[3] # ZusΣtzliche Information: Gr÷▀e des Ausgabe-Fensters in x- bzw. y-Richtung local struct { uintC x; uintC y; } window_size; #define window_width window_size.x # Stellt fest, ob ein Terminal-Stream ein Zeichen verfⁿgbar hat. # listen_terminal(stream) # > stream: Terminal-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF local signean listen_terminal (object stream); local signean listen_terminal(stream) var reg1 object stream; { # Buffer der gelesenen Zeichen leer ? if (TheStream(stream)->strm_terminal_index >= TheStream(stream)->strm_terminal_count) { return listen_keyboard(stream); } # ja -> Tastatur abfragen else { return signean_null; } # nein -> Es sind noch Zeichen im Buffer } # UP: L÷scht bereits eingegebenen interaktiven Input von einem Terminal-Stream. # clear_input_terminal(stream); # > stream: Terminal-Stream # < ergebnis: TRUE falls Input gel÷scht wurde, FALSE sonst local boolean clear_input_terminal (object stream); local boolean clear_input_terminal(stream) var reg1 object stream; { # Buffer der gelesenen Zeichen leeren durch INDEX := COUNT : TheStream(stream)->strm_terminal_index = TheStream(stream)->strm_terminal_count; # GEMDOS-Tastaturbuffer leeren: return clear_input_keyboard(stream); } # UP: Newline auf einen Terminal-Stream ausgeben und Flag l÷schen. # wr_NL_terminal(stream); # > stream: Terminal-Stream local void wr_NL_terminal (object stream); local void wr_NL_terminal(stream) var reg1 object stream; { asciz_out(CRLFstring); # Newline als CR/LF ausgeben TheStream(stream)->strm_terminal_NLflag = Fixnum_0; # nun wartet kein NL mehr } # UP: Ein Zeichen auf einen Terminal-Stream ausgeben. # wr_ch_terminal(&stream,ch); # > stream: Terminal-Stream # > ch: auszugebendes Zeichen local void wr_ch_terminal (object* stream_, object ch); local void wr_ch_terminal(stream_,ch) var reg4 object* stream_; var reg2 object ch; { var reg1 object stream = *stream_; if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # ch sollte String-Char sein {var reg2 uintB c = char_code(ch); # Code des Zeichens if (c == NL) # Newline ? { wr_NL_terminal(stream); } else { # kein Newline # Wartet noch ein NL, wird es jetzt ausgegeben: if (eq(TheStream(stream)->strm_terminal_NLflag,Fixnum_1)) { wr_NL_terminal(stream); } # Code c ⁿbers BIOS auf den Bildschirm ausgeben: # c >= ' ' -> ⁿbers GEMDOS # 0 <= c < 32 -> genau c in {1,..,4}u{14,..,25}u{28,..,31} ⁿbers BIOS # sonst als Steuerzeichen ⁿbers BIOS if ((c < ' ') && # Bit c aus der 32-Bit-Zahl %11110011111111111100000000011110 holen: (0xF3FFC01EUL & bit(c)) ) { BIOS_GrConOut(c); } else { BIOS_ConOut(c); } } # Line Position aktualisieren (es wartet kein NL mehr!): TheStream(stream)->strm_wr_ch_lpos = fixnum((UWORD)(vdiesc.v_cur_x)); # Bei gedrⁿckter rechter Maustaste warten: if (LineA_MouseButtons() & bit(1)) # rechte Maustaste gedrⁿckt? { run_time_stop(); # Run-Time-Stoppuhr anhalten if (!(c==NL)) # Maus wird bewegt -> Zeitschleife von 0.005 Sekunden. # Maus wird nicht bewegt -> warten, bis die rechte Maustaste los- # gelassen oder die Maus bewegt wurde, mind. jedoch 0.005 Sekunden. { interruptp( {goto interrupt;} ); # erst auf Tastatur-Interrupt testen # Zeitschleife von 0.005 Sekunden: { var reg1 uintC count; dotimespC(count,4096, ; ); } } else # Maus wird bewegt -> Zeitschleife von 0.4 Sekunden. # Maus wird nicht bewegt -> warten, bis die rechte Maustaste los- # gelassen oder die Maus bewegt wurde, mind. jedoch 0.4 Sekunden. { # Zeitschleife von 0.4 Sekunden mit Tastatur-Interrupt-Abfrage: var reg1 uintL endtime = get_real_time() + ticks_per_second*2/5; # zur momentanen Real-Time 0.4 sec. addieren, # ergibt Zeit, bis zu der zu warten ist. # warten, bis die Real-Time bei endtime angelangt ist: do { interruptp( {goto interrupt;} ); } until (get_real_time() == endtime); } # Ende der Warteschleife oder nicht, je nach Mausstatus: loop { if (LineA_MouseStatus() & bit(5)) # Maus wurde bewegt? { LineA_MouseStatus() &= ~bit(5); break; } # ja -> nicht weiter warten interruptp( {goto interrupt;} ); if ((LineA_MouseButtons() & bit(1)) ==0) # rechte Maustaste gedrⁿckt? break; # nein -> nicht mehr warten } if (TRUE) { run_time_restart(); } # Run-Time-Stoppuhr weiterlaufen lassen else { interrupt: # Tastatur-Interrupt run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen pushSTACK(S(write_char)); tast_break(); # Break-Schleife aufrufen } } }} # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel. # finish_output_terminal(stream); # > stream: Terminal-Stream # kann GC ausl÷sen local void finish_output_terminal (object stream); local void finish_output_terminal(stream) var reg1 object stream; { # Wartet noch ein NL, wird es jetzt ausgegeben: if (eq(TheStream(stream)->strm_terminal_NLflag,Fixnum_1)) { wr_NL_terminal(stream); } } # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel. # force_output_terminal(stream); # > stream: Terminal-Stream # kann GC ausl÷sen #define force_output_terminal finish_output_terminal # Lesen eines Zeichens vom Terminal-Stream local object rd_ch_terminal (object* stream_); # # Zustand wΣhrend der Eingabe: typedef struct { uintL linelen; # LΣnge der Eingabezeile (<= length(inbuff)) uintL linepos; # Position in der Eingabezeile uintC screenpos; # Line Position am Bildschirm (>=0, <window_width) } rd_ch_vars; # > v : aktueller Zustand # > STACK_1 : Terminal-Stream # > STACK_0 : Eingabebuffer INBUFF # # Unterprogramme wΣhrend der Eingabe einer Zeile: # # UP: macht String so lang, da▀ noch ein Zeichen hineinpa▀t, # und erh÷ht die ZeilenlΣnge um 1. # add1char(&v); local void add1char (rd_ch_vars* v); local void add1char(v) var reg4 rd_ch_vars* v; { if (v->linelen >= TheSstring(STACK_0)->length) # Bei linelen < StringlΣnge ist im String noch Platz. # Bei linelen = StringlΣnge mu▀ man den String verlΣngern: { var reg3 uintL count = TheSstring(STACK_0)->length; # alte StringlΣnge (>0) var reg5 object new_string = allocate_string(2*count); # doppelt so langer String # Stringinhalt von String STACK_0 nach String new_string kopieren: var reg2 uintB* ptr1 = &TheSstring(STACK_0)->data[0]; var reg1 uintB* ptr2 = &TheSstring(new_string)->data[0]; dotimespL(count,count, { *ptr2++ = *ptr1++; } ); # new_string ablegen: STACK_0 = new_string; TheStream(STACK_1)->strm_terminal_inbuff = new_string; } v->linelen++; # ZeilenlΣnge erh÷hen } # # UP: akzeptiert ein normales Zeichen c. # normalchar(&v,c); local void normalchar (rd_ch_vars* v, uintB c); local void normalchar(v,c) var reg1 rd_ch_vars* v; var reg2 uintB c; { # Eventuell die Eingabezeile verlΣngern: if (v->linepos >= v->linelen) { add1char(v); } # Jetzt ist sicher linepos < linelen. TheSstring(STACK_0)->data[v->linepos] = c; # Zeichen in den String v->linepos++; # und Index erh÷hen BIOS_ConOut(c); # Zeichen ausgeben # Bildschirmposition adjustieren: v->screenpos++; if (v->screenpos == window_width) { v->screenpos = 0; } } # # UP: Cursor in derselben Zeile an eine neue Position setzen. # cursor_gotox(&v,x); # > x: neue Position (>=0, <window_width) local void cursor_gotox (rd_ch_vars* v, uintC x); local void cursor_gotox(v,x) var reg2 rd_ch_vars* v; var reg3 uintC x; { if (x < floor(v->screenpos,2)) { BIOS_ConOut(CR); v->screenpos = 0; } # nach links geht's mit CR schneller {var reg4 sintC rel_pos = x - v->screenpos; # relative Positionierung if (rel_pos >= 0) { var reg1 uintC count; dotimesC(count,rel_pos, { asciz_out(ESCstring "C"); } ); # Cursor nach rechts } else { var reg1 uintC count; dotimespC(count,-rel_pos, { asciz_out(ESCstring "D"); } ); # Cursor nach links } v->screenpos = x; # Cursor steht jetzt in Spalte x }} # # UP: Cursor ein Zeichen weiter nach links, linepos mitfⁿhren. # cursor_1left(&v); local void cursor_1left (rd_ch_vars* v); local void cursor_1left(v) var reg2 rd_ch_vars* v; { v->linepos--; if (!(v->screenpos == 0)) # Cursor war nicht ganz links -> Cursor eins nach links { v->screenpos--; asciz_out(ESCstring "D"); } else # Cursor war ganz links -> zeilenⁿbergreifend: { v->screenpos = window_width-1; # bewege den Cursor vom linken Rand einer Zeile # an den rechten Rand der nΣchsth÷heren Zeile: asciz_out(ESCstring "f"); # Cursor ausschalten asciz_out(ESCstring "I"); # Cursor eine Zeile hoch { var reg1 uintC count; dotimesC(count,window_width-1, # 79 mal: { asciz_out(ESCstring "C"); } # Cursor ein Zeichen rechts ); } asciz_out(ESCstring "e"); # Cursor wieder einschalten } } # # UP: Cursor einige Zeichen nach links. # cursor_left(&v,count); # > count: Zeichenzahl (>=0) local void cursor_left (rd_ch_vars* v, sintL count); local void cursor_left(v, count) var reg3 rd_ch_vars* v; var reg2 sintL count; { asciz_out(ESCstring "f"); # Cursor ausschalten # Cursor einige Zeilen hoch: {var reg1 sintL countlimit = v->screenpos; while (count > countlimit) { asciz_out(ESCstring "I"); # Cursor eine Zeile hoch count -= window_width; } } # Nun ist screenpos-window_width < count <= screenpos. # Der Cursor befindet sich also in der richtigen Zeile. cursor_gotox(v,v->screenpos-count); # Der Cursor steht jetzt richtig. asciz_out(ESCstring "e"); # Cursor wieder einschalten } # # UP: Cursor ein Zeichen weiter nach rechts, linepos mitfⁿhren. # cursor_1right(&v); local void cursor_1right (rd_ch_vars* v); local void cursor_1right(v) var reg2 rd_ch_vars* v; { if (!(v->screenpos == window_width-1)) # Cursor war nicht ganz rechts -> Cursor eins nach rechts { v->screenpos++; asciz_out(ESCstring "C"); } else # Cursor war ganz rechts -> zeilenⁿbergreifend: { v->screenpos = 0; BIOS_ConOut(TheSstring(STACK_0)->data[v->linepos]); } v->linepos++; } # # UP: Cursor einige Zeichen nach rechts. # cursor_right(&v,count); # > count: Zeichenzahl (>=0) local void cursor_right (rd_ch_vars* v, sintL count); local void cursor_right(v, count) var reg3 rd_ch_vars* v; var reg2 sintL count; { asciz_out(ESCstring "f"); # Cursor ausschalten # Cursor einige Zeilen runter: {var reg1 sintL countlimit = window_width - v->screenpos; while (count >= countlimit) { asciz_out(ESCstring "B"); # Cursor eine Zeile runter count -= window_width; } } # Nun ist -screenpos <= count < window_width-screenpos. # Der Cursor befindet sich also in der richtigen Zeile. cursor_gotox(v,v->screenpos+count); # Der Cursor steht jetzt richtig. asciz_out(ESCstring "e"); # Cursor wieder einschalten } # # UP: An der Cursor-Position Platz fⁿr ein Zeichen machen. # insert1char(&v,c); local void insert1char (rd_ch_vars* v, uintB c); local void insert1char(v,c) var reg5 rd_ch_vars* v; var reg2 uintB c; { add1char(v); # Eingabezeile wird 1 Zeichen lΣnger {var reg5 uintL charcount = v->linelen - v->linepos; # = Anzahl der zu verschiebenden Zeichen + 1 asciz_out(ESCstring "f"); # Cursor ausschalten {var reg1 uintB* ptr = &TheSstring(STACK_0)->data[v->linepos]; var reg3 uintL count; # Schleife charcount mal durchlaufen, dabei beim ersten # Durchlauf das ⁿbergebene c einfⁿgen: dotimespL(count,charcount, { var reg4 uintB nextc = *ptr; # nΣchstes Zeichen *ptr++ = c; # durch c ersetzen BIOS_ConOut(c); # und c ausgeben c = nextc; }); } # neue Spalte am Bildschirm berechnen: {var reg1 uintL new_screenpos = v->screenpos + charcount; while (new_screenpos >= window_width) { new_screenpos -= window_width; } v->screenpos = new_screenpos; } # Cursor an die alte Position und Cursor wieder einschalten: cursor_left(v,charcount); }} # # UP: An der Cursor-Position ein Zeichen l÷schen. # > 0 <= linepos < linelen. # delete1(&v); local void delete1 (rd_ch_vars* v); local void delete1(v) var reg5 rd_ch_vars* v; { v->linelen--; # Gesamtzeichenzahl decrementieren {var reg4 uintL charcount = v->linelen - v->linepos; # = Anzahl der zu verschiebenden Zeichen asciz_out(ESCstring "f"); # Cursor ausschalten {var reg1 uintB* ptr = &TheSstring(STACK_0)->data[v->linepos]; var reg3 uintL count; dotimesL(count,charcount, { var reg2 uintB nextch = *(ptr+1); # nΣchstes Zeichen *ptr++ = nextch; # um eine Position nach vorne schieben BIOS_ConOut(nextch); # und ausgeben }); } BIOS_ConOut(' '); # letztes Zeichen mit ' ' ⁿberschreiben charcount++; # neue Spalte am Bildschirm berechnen: {var reg1 uintL new_screenpos = v->screenpos + charcount; while (new_screenpos >= window_width) { new_screenpos -= window_width; } v->screenpos = new_screenpos; } # Cursor an die alte Position und Cursor wieder einschalten: cursor_left(v,charcount); }} # local object rd_ch_terminal(stream_) var reg1 object* stream_; { var reg1 object stream = *stream_; var reg1 object inbuff = TheStream(stream)->strm_terminal_inbuff; # Eingabebuffer if (posfixnum_to_L(TheStream(stream)->strm_terminal_index) >= posfixnum_to_L(TheStream(stream)->strm_terminal_count) ) # index<count -> Es sind noch Zeichen im Buffer # index=count -> mu▀ eine ganze Zeile von Tastatur lesen: { # Wartet noch ein NL, wird es jetzt ausgegeben: if (eq(TheStream(stream)->strm_terminal_NLflag,Fixnum_1)) { wr_NL_terminal(stream); } TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0 TheStream(stream)->strm_terminal_count = Fixnum_0; # count := 0 {var rd_ch_vars v; # Zustandsvariablen v.linelen = 0; v.linepos = 0; # Zeile noch leer v.screenpos = posfixnum_to_L(TheStream(stream)->strm_wr_ch_lpos); # aktuelle Screen-Spalte pushSTACK(stream); pushSTACK(inbuff); asciz_out(ESCstring "e"); # Cursor einschalten loop { # Eingabeschleife. # STACK_1 : Terminal-Stream, # STACK_0 : Eingabezeile inbuff (ein Simple-String), # v.linelen : LΣnge der Eingabezeile (<= length(inbuff)) # Eingabezeile = TheSstring(STACK_0)->data[0..(v.linelen-1)] # v.linepos : Position in der Eingabezeile (>=0, <=linelen) # v.screenpos : Line Position am Bildschirm (>=0, <window_width) {var object kbstream = var_stream(S(keyboard_input)); # Stream *KEYBOARD-INPUT* var reg2 object ch = read_char(&kbstream); # Zeichen holen if (eq(ch,eof_value)) # EOF (sollte nicht auftreten) ? { funcall(L(exit),0); } # ja -> LISP beenden if (v.linelen == 0) # Eine Taste aus SYS::*KEY-BINDINGS* ? { var reg1 object alist = Symbol_value(S(key_bindings)); while (consp(alist)) { if (mconsp(Car(alist)) && eq(ch,Car(Car(alist)))) { asciz_out(ESCstring "f"); # Cursor ausschalten funcall(Cdr(Car(alist)),0); # Funktion dazu aufrufen # und wenn diese Funktion zurⁿckkehren sollte: asciz_out(ESCstring "e"); # Cursor einschalten break; } alist = Cdr(alist); } } {var reg1 cint c = char_int(ch); if (!(c & char_hyper_c)) # HYPER-Bit gesetzt ? # nein -> normales Zeichen { c &= char_code_mask_c; # SUPER-Bit usw. wegmaskieren switch (c) { case BS: # Backspace # Backspace-Taste entfernt das Zeichen links vom Cursor if (v.linepos == 0) goto nix; # war der Cursor schon ganz links -> Fehleingabe cursor_1left(&v); # Cursor ein Zeichen nach links delete1(&v); # Zeichen unterm Cursor l÷schen break; case TAB: # Tab # Tab fⁿgt Spaces ein, bis der Cursor auf einer # durch 8 teilbaren Spalte steht. do { normalchar(&v,' '); } until ((v.screenpos % 8) == 0); break; case CR: # Return/Enter do_CR: # Return/Enter beendet die Zeile mit einem NL. cursor_right(&v,v.linelen - v.linepos); add1char(&v); # String mit NL abschlie▀en: TheSstring(STACK_0)->data[v.linelen-1] = NL; goto loopend; default: if (c < ' ') # sonstiges Control-Zeichen < ' ' ? goto nix; # ja -> war nix # normales Zeichen normalchar(&v,c); } } else # ja -> Sondertaste { switch (c) { case char_hyper_c|CR : # Taste 'Enter' goto do_CR; case char_hyper_c|127: # Taste 'Delete' # Delete-Taste entfernt das Zeichen unterm Cursor if (v.linepos >= v.linelen) goto nix; # war der Cursor schon ganz rechts -> Fehleingabe delete1(&v); # Zeichen unterm Cursor l÷schen break; case char_hyper_c|16 : # Taste 'Insert' # Insert-Taste macht am Cursor Platz fⁿr ein Zeichen insert1char(&v,' '); break; case char_hyper_c|20 : # Taste '<-' # Pfeil links -> Cursor eine Position nach links if (v.linepos==0) goto nix; # war der Cursor schon ganz links -> Fehleingabe cursor_1left(&v); break; case char_hyper_c|char_super_c|20 : # Taste Shift '<-' # Shift Pfeil links -> Cursor ganz nach links cursor_left(&v,v.linepos); v.linepos = 0; break; case char_hyper_c|22 : # Taste '->' # Pfeil rechts -> Cursor eine Position nach rechts if (v.linepos < v.linelen) { cursor_1right(&v); } else { normalchar(&v,' '); } # am Zeilenende: Leerstelle anfⁿgen break; case char_hyper_c|char_super_c|22 : # Taste Shift '->' # Shift Pfeil rechts -> Cursor ganz nach rechts cursor_right(&v,v.linelen-v.linepos); v.linepos = v.linelen; break; default: { var reg1 uintB code = c & char_code_mask_c; if ((code >= ' ') && (code < '@')) # Sondertaste >=' ' und <'@' kommt vom Ziffernblock # -> als normales Zeichen behandeln { normalchar(&v,code); break; } } nix: # Zeichen war nix (Fehleingabe) -> Glocke lΣuten BIOS_Bell(); } } } }} loopend: # Eingabezeile fertig. asciz_out(ESCstring "f"); # Cursor ausschalten inbuff = popSTACK(); stream = popSTACK(); # STACK aufrΣumen TheStream(stream)->strm_terminal_index = Fixnum_0; # Index := 0 TheStream(stream)->strm_terminal_count = fixnum(v.linelen); TheStream(stream)->strm_terminal_NLflag = Fixnum_1; # wartendes NL vormerken TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; # und deswegen Line Position := 0 }} # Jetzt sind genug Zeichen da, d.h. INDEX < COUNT . {var reg1 uintL index = posfixnum_to_L(TheStream(stream)->strm_terminal_index); # Index TheStream(stream)->strm_terminal_index = fixnum_inc(TheStream(stream)->strm_terminal_index,1); # Index erh÷hen return code_char(TheSstring(inbuff)->data[index]); # nΣchstes Character }} # Liefert einen interaktiven Terminal-Stream. # kann GC ausl÷sen local object make_terminal_stream_ (void); local object make_terminal_stream_() { # Bildschirmgr÷▀e bestimmen: window_size.x = (UWORD)(vdiesc.v_cel_mx+1); window_size.y = (UWORD)(vdiesc.v_cel_my+1); {# neuen Stream allozieren: var reg2 object stream = allocate_stream(strmflags_ch_B,strmtype_terminal,strm_len+4); # Flags: nur READ-CHAR und WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_terminal); # READ-CHAR-Pseudofunktion s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_terminal); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy); #endif {pushSTACK(stream); {var reg1 object inbuff = allocate_string(window_width+1); # neuer String # (reicht fⁿr alle einzeiligen Eingaben) stream = popSTACK(); s = TheStream(stream); s->strm_terminal_inbuff = inbuff; # als Eingabebuffer }} s->strm_terminal_count = Fixnum_0; # Buffer leer, Count:=0 s->strm_terminal_index = Fixnum_0; # Index:=0 s->strm_terminal_NLflag = Fixnum_0; # NL-Flag := false return stream; }} #endif # ATARI #ifdef WINDOWS # Benutze die Eingabefunktionen aus wintext.d. # Output: extern void winterm_writechar (mywindow w, uintB c); # Input: extern signean winterm_listen (mywindow w); extern boolean winterm_clear_input (mywindow w); extern cint winterm_readchar (mywindow w); # Stellt fest, ob ein Terminal-Stream ein Zeichen verfⁿgbar hat. # listen_terminal(stream) # > stream: Terminal-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF local signean listen_terminal (object stream); local signean listen_terminal(stream) var reg1 object stream; { return winterm_listen(main_window); } # UP: L÷scht bereits eingegebenen interaktiven Input von einem Terminal-Stream. # clear_input_terminal(stream); # > stream: Terminal-Stream # < ergebnis: TRUE falls Input gel÷scht wurde, FALSE sonst local boolean clear_input_terminal (object stream); local boolean clear_input_terminal(stream) var reg1 object stream; { return winterm_clear_input(main_window); } # UP: Ein Zeichen auf einen Terminal-Stream ausgeben. # wr_ch_terminal(&stream,ch); # > stream: Terminal-Stream # > ch: auszugebendes Zeichen local void wr_ch_terminal (object* stream_, object ch); local void wr_ch_terminal(stream_,ch) var reg2 object* stream_; var reg1 object ch; { var reg3 object stream = *stream_; if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # ch sollte String-Char sein winterm_writechar(main_window,char_code(ch)); } # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel. # finish_output_terminal(stream); # > stream: Terminal-Stream # kann GC ausl÷sen #define finish_output_terminal(stream) # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel. # force_output_terminal(stream); # > stream: Terminal-Stream # kann GC ausl÷sen #define force_output_terminal(stream) # UP: Ein Zeichen von einem Terminal-Stream lesen. # rd_ch_terminal(&stream) # > stream: Terminal-Stream # < object ch: eingegebenes Zeichen local object rd_ch_terminal (object* stream_); local object rd_ch_terminal(stream_) var reg1 object* stream_; { return int_char(winterm_readchar(main_window)); } # Liefert einen interaktiven Terminal-Stream. # kann GC ausl÷sen local object make_terminal_stream_ (void); local object make_terminal_stream_() { # neuen Stream allozieren: var reg2 object stream = allocate_stream(strmflags_ch_B,strmtype_terminal,strm_len+0); # Flags: nur READ-CHAR und WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_terminal); # READ-CHAR-Pseudofunktion s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_terminal); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy); #endif return stream; } #endif # WINDOWS #if defined(UNIX) || (defined(MSDOS) && !defined(WINDOWS)) || defined(AMIGAOS) || defined(RISCOS) # Funktionsweise: # Es wird auf Standard-Input und Standard-Output zugegriffen. # Wegen Umleite-M÷glichkeit mⁿssen manche Funktionen unterscheiden, ob es # sich bei Standard-Input um ein Terminal handelt oder nicht. # Ob Standard-Output ein Terminal ist oder nicht, ist hier irrelevant. # Relevant ist nur, ob Standard-Input und Standard-Output dasselbe Terminal # sind; in diesem Falle nehmen wir an, da▀ nach Beendigung einer Eingabezeile # (durch NL) von Standard-Input der Cursor von Standard-Output in Spalte 0 # steht, und in diesem Falle k÷nnen wir auch die GNU readline()-Library # benutzen. # Es gibt drei m÷gliche Varianten des Terminal-Streams: # Wenn Standard-Input und Standard-Output nicht dasselbe Terminal sind: # * terminal1 normalerweise, # * terminal2 mit zeilenweiser Bufferung der Eingabe, # Wenn Standard-Input und Standard-Output dasselbe Terminal sind: # * terminal3 benutzt readline()-Library, mit zeilenweiser Bufferung der # Eingabe und der Ausgabe. #define HAVE_TERMINAL1 # define TERMINAL_LINEBUFFERED 0 # define TERMINAL_OUTBUFFERED 0 #ifdef MSDOS # Bei Eingabe einer Zeile von Tastatur wird das <Enter> am Ende der Zeile als # CR/LF ausgegeben. Jedoch: Das CR sofort, das LF jedoch erst dann, wenn das # <Enter> mit read() gelesen wird - das ist bei uns manchmal erst viel spΣter. # [Wer diesen Schwachsinn programmiert hat - im DOS vermutlich - # geh÷rt an die Wand gestellt und erschossen! :-(] # Aus diesem Grund mⁿssen wir den Terminal-Stream auf der Input-Seite # zeilengepuffert machen. #define HAVE_TERMINAL2 # define TERMINAL_LINEBUFFERED 1 # define TERMINAL_OUTBUFFERED 0 #endif #ifdef GNU_READLINE # Wir benutzen die GNU Readline-Library. Sie liefert den Input zeilenweise, # mit Editierm÷glichkeit, VervollstΣndigung und History. Leider mⁿssen wir # den Output zeilenweise zwischenspeichern, um die letzte angefangene Zeile # als "Prompt" verwenden zu k÷nnen. #define HAVE_TERMINAL3 # define TERMINAL_LINEBUFFERED 1 # define TERMINAL_OUTBUFFERED 1 #endif # ZusΣtzliche Komponenten: # ISATTY : Flag, ob stdin ein TTY ist und ob stdin und stdout dasselbe sind: # NIL: stdin ein File o.Σ. # T, EQUAL: stdin ein Terminal # EQUAL: stdin und stdout dasselbe Terminal #define strm_terminal_isatty strm_isatty #define strm_terminal_ihandle strm_ihandle #define strm_terminal_ohandle strm_ohandle #if defined(HAVE_TERMINAL2) || defined(HAVE_TERMINAL3) # Komponenten wegen TERMINAL_LINEBUFFERED: # INBUFF : Eingabebuffer, ein Semi-Simple-String #define strm_terminal_inbuff strm_other[3] # COUNT = sein Fill-Pointer : Anzahl der Zeichen im Eingabebuffer # INDEX : Anzahl der bereits verbrauchten Zeichen #define strm_terminal_index strm_other[4] #endif #ifdef HAVE_TERMINAL3 # Komponenten wegen TERMINAL_OUTBUFFERED: # OUTBUFF : Ausgabebuffer, ein Semi-Simple-String #define strm_terminal_outbuff strm_other[5] #endif # LΣngen der unterschiedlichen Terminal-Streams: #define strm_terminal1_len (strm_len+3) #define strm_terminal2_len (strm_len+5) #define strm_terminal3_len (strm_len+6) # Unterscheidung nach Art des Terminal-Streams: # terminalcase(stream, statement1,statement2,statement3); #if defined(HAVE_TERMINAL2) && defined(HAVE_TERMINAL3) #define terminalcase(stream,statement1,statement2,statement3) \ switch (TheStream(stream)->reclength) \ { case strm_terminal1_len: statement1 break; \ case strm_terminal2_len: statement2 break; \ case strm_terminal3_len: statement3 break; \ default: NOTREACHED \ } #elif defined(HAVE_TERMINAL2) #define terminalcase(stream,statement1,statement2,statement3) \ if (TheStream(stream)->reclength == strm_terminal2_len) { statement2 } else { statement1 } #elif defined(HAVE_TERMINAL3) #define terminalcase(stream,statement1,statement2,statement3) \ if (TheStream(stream)->reclength == strm_terminal3_len) { statement3 } else { statement1 } #else #define terminalcase(stream,statement1,statement2,statement3) \ statement1 #endif #ifdef MSDOS # get_handle_info(handle) # > handle # < ergebnis: Handle-Info (INT 21,44,00) #ifdef DJUNIX #define get_handle_info(handle) \ ({ var reg1 uintW __info; \ __asm__ (# DOS-Funktion 44H, Code 00H \ " movw $0x4400,%%ax ; int $0x21 " \ : "=d" /* %dx */ (__info) # OUT \ : "b" /* %bx */ ((uintW)(handle)) # IN \ : "ax","bx","cx","si","di" /* %eax,%ebx,%ecx,%esi,%edi */ # CLOBBER \ ); \ __info; \ }) #endif #ifdef EMUNIX #define get_handle_info(handle) __ioctl1(handle,0x00) #endif #ifdef WATCOM local uintW get_handle_info (uintW handle); local uintW get_handle_info(handle) var uintW handle; { var union REGS in; var union REGS out; in.regW.ax = 0x4400; in.regW.bx = handle; intdos(&in,&out); return out.regW.dx; } #endif #endif #ifdef HAVE_TERMINAL1 # Lesen eines Zeichens von einem Terminal-Stream. local object rd_ch_terminal1 (object* stream_); local object rd_ch_terminal1(stream_) var reg3 object* stream_; { var reg1 object ch = rd_ch_handle(stream_); # Wenn stdin und stdout beide dasselbe Terminal sind, # und wir lesen ein NL, so k÷nnen wir davon ausgehen, # da▀ der Cursor danach in Spalte 0 steht. if (eq(ch,code_char(NL))) { var reg2 object stream = *stream_; if (eq(TheStream(stream)->strm_terminal_isatty,S(equal))) { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; } } return ch; } # Stellt fest, ob ein Terminal-Stream ein Zeichen verfⁿgbar hat. # listen_terminal1(stream) # > stream: Terminal-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF #define listen_terminal1 listen_handle # UP: L÷scht bereits eingegebenen interaktiven Input von einem Terminal-Stream. # clear_input_terminal1(stream); # > stream: Terminal-Stream # < ergebnis: TRUE falls Input gel÷scht wurde, FALSE sonst #define clear_input_terminal1 clear_input_handle # UP: Ein Zeichen auf einen Terminal-Stream ausgeben. # wr_ch_terminal1(&stream,ch); # > stream: Terminal-Stream # > ch: auszugebendes Zeichen #if !defined(AMIGAOS) #define wr_ch_terminal1 wr_ch_handle #else # defined(AMIGAOS) local void wr_ch_terminal1 (object* stream_, object ch); local void wr_ch_terminal1(stream_,ch) var reg6 object* stream_; var reg5 object ch; { # ch sollte ein Character mit h÷chstens Font, aber ohne Bits sein: 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)))) { pushSTACK(*stream_); pushSTACK(ch); fehler(error, DEUTSCH ? "Character ~ enthΣlt Bits und kann daher nicht auf ~ ausgegeben werden." : ENGLISH ? "character ~ contains bits, cannot be output onto ~" : FRANCAIS ? "Le caractΦre ~ contient des ½bits╗ et ne peut pas Ωtre Θcrit dans ~." : "" ); } #if (!(char_font_len_c == 4)) #error "char_font_len_c neu einstellen oder wr_ch_terminal neu schreiben!" #endif {var uintB outbuffer[14]; var reg1 uintB* ptr = &outbuffer[0]; var reg3 uintL count = 1; var reg2 uintB f = (char_int(ch) & char_font_mask_c) >> char_font_shift_c; # Font des Zeichens var reg4 uintB c = char_code(ch); # Code des Zeichens if (f==0) { *ptr++ = c; } else { *ptr++ = CSI; # Kontroll-Sequenz zum Umschalten auf den richtigen Font: if (f & bit(0)) { *ptr++ = '1'; *ptr++ = ';'; count += 2; } # Fettschrift ein if (f & bit(1)) { *ptr++ = '3'; *ptr++ = ';'; count += 2; } # Kursiv ein if (f & bit(2)) { *ptr++ = '4'; *ptr++ = ';'; count += 2; } # Unterstreichung ein if (f & bit(3)) { *ptr++ = '7'; *ptr++ = ';'; count += 2; } # Reverse ein *ptr++ = 0x6D; *ptr++ = c; # dann das Zeichen ausgeben *ptr++ = CSI; *ptr++ = '0'; *ptr++ = 0x6D; # Wieder Normalschrift count += 5; } begin_system_call(); {var reg1 long ergebnis = Write(Output_handle,&outbuffer[0],count); # Zeichen auszugeben versuchen end_system_call(); if (ergebnis<0) { OS_error(); } # Error melden if (ergebnis<count) # nicht erfolgreich? { fehler_unwritable(S(write_char),*stream_); } }}} #endif #ifdef STRM_WR_SS # UP: Mehrere Zeichen auf einen Terminal-Stream ausgeben. # wr_ss_terminal1(&stream,string,start,len); # > stream: Terminal-Stream # > string: Simple-String # > start: Startindex # > len: Anzahl der auszugebenden Zeichen #define wr_ss_terminal1 wr_ss_handle #endif # UP: L÷scht den wartenden Output eines Terminal-Stream. # clear_output_terminal1(stream); # > stream: Terminal-Stream # kann GC ausl÷sen #define clear_output_terminal1 clear_output_handle #endif # HAVE_TERMINAL1 #ifdef HAVE_TERMINAL2 #define TERMINAL_LINEBUFFERED TRUE # Lesen eines Zeichens von einem Terminal-Stream. local object rd_ch_terminal2 (object* stream_); # vgl. rd_ch_handle() : local object rd_ch_terminal2(stream_) var reg3 object* stream_; { restart_it: {var reg2 object stream = *stream_; if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ? { return eof_value; } #if TERMINAL_LINEBUFFERED { var reg4 object inbuff = TheStream(stream)->strm_terminal_inbuff; # Eingabebuffer if (posfixnum_to_L(TheStream(stream)->strm_terminal_index) < TheArray(inbuff)->dims[1] ) # index<count -> Es sind noch Zeichen im Buffer { var reg1 uintL index = posfixnum_to_L(TheStream(stream)->strm_terminal_index); # Index TheStream(stream)->strm_terminal_index = fixnum_inc(TheStream(stream)->strm_terminal_index,1); # Index erh÷hen return code_char(TheSstring(TheArray(inbuff)->data)->data[index]); # nΣchstes Character } # index=count -> mu▀ eine ganze Zeile von Tastatur lesen: TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0 TheArray(inbuff)->dims[1] = 0; # count := 0 } continue_line: #endif {var uintB c; run_time_stop(); # Run-Time-Stoppuhr anhalten #ifdef GRAPHICS_SWITCH switch_text_mode(); #endif begin_system_call(); {var reg1 int ergebnis = read(stdin_handle,&c,1); # Zeichen lesen versuchen end_system_call(); run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { interruptp({ pushSTACK(S(read_char)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } OS_error(); } if (ergebnis==0) # kein Zeichen verfⁿgbar -> EOF erkennen #if TERMINAL_LINEBUFFERED if (TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] > 0) goto restart_it; # Zeichen des Buffers liefern, dann erst eof_value liefern else #endif { TheStream(stream)->strm_rd_ch_last = eof_value; return eof_value; } } #if TERMINAL_LINEBUFFERED # Zeichen c zur Eingabezeile dazunehmen, evtl. die Zeile vergr÷▀ern: ssstring_push_extend(TheStream(stream)->strm_terminal_inbuff,c); stream = *stream_; #endif # Wenn stdin und stdout beide dasselbe Terminal sind, # und wir lesen ein NL, so k÷nnen wir davon ausgehen, # da▀ der Cursor danach in Spalte 0 steht. if (c==NL) { if (eq(TheStream(stream)->strm_terminal_isatty,S(equal))) { TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; } } #if TERMINAL_LINEBUFFERED else goto continue_line; # so lang weiterlesen, bis ein NL kommt... # Kam ein NL, so fangen wir an, die Zeichen des Buffers zu liefern: goto restart_it; #endif } }} # Stellt fest, ob ein Terminal-Stream ein Zeichen verfⁿgbar hat. # listen_terminal2(stream) # > stream: Terminal-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF local signean listen_terminal2 (object stream); local signean listen_terminal2(stream) var reg1 object stream; { if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ? { return signean_minus; } if (posfixnum_to_L(TheStream(stream)->strm_terminal_index) < TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] ) # index<count -> Es sind noch Zeichen im Buffer { return signean_null; } return listen_handle(stream); } # UP: L÷scht bereits eingegebenen interaktiven Input von einem Terminal-Stream. # clear_input_terminal2(stream); # > stream: Terminal-Stream # < ergebnis: TRUE falls Input gel÷scht wurde, FALSE sonst local boolean clear_input_terminal2 (object stream); local boolean clear_input_terminal2(stream) var reg1 object stream; { if (nullp(TheStream(stream)->strm_terminal_isatty)) # File -> nichts tun { return FALSE; } # Terminal TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen #if TERMINAL_LINEBUFFERED TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0 TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] = 0; # count := 0 #endif clear_tty_input(stdin_handle); pushSTACK(stream); while (listen_terminal2(STACK_0) == 0) { read_char(&STACK_0); } skipSTACK(1); return TRUE; } # UP: Ein Zeichen auf einen Terminal-Stream ausgeben. # wr_ch_terminal2(&stream,ch); # > stream: Terminal-Stream # > ch: auszugebendes Zeichen #define wr_ch_terminal2 wr_ch_handle #ifdef STRM_WR_SS # UP: Mehrere Zeichen auf einen Terminal-Stream ausgeben. # wr_ss_terminal2(&stream,string,start,len); # > stream: Terminal-Stream # > string: Simple-String # > start: Startindex # > len: Anzahl der auszugebenden Zeichen #define wr_ss_terminal2 wr_ss_handle #endif # UP: L÷scht den wartenden Output eines Terminal-Stream. # clear_output_terminal2(stream); # > stream: Terminal-Stream # kann GC ausl÷sen #define clear_output_terminal2 clear_output_handle #endif # HAVE_TERMINAL2 #ifdef HAVE_TERMINAL3 #define TERMINAL_LINEBUFFERED TRUE #define TERMINAL_OUTBUFFERED TRUE # Unsere eigene VervollstΣndigungs-Funktion, imitiert completion_matches() # aus readline.c. local char** lisp_completion (char* text, int start, int end); local boolean want_filename_completion; extern char* filename_completion_function (char* text, int state); # siehe readline.c local char** lisp_completion(text,start,end) var reg7 char* text; # text[0..end-start-1] = the_line[start..end-1] var reg8 int start; var reg9 int end; { # Dies ist eine Callback-Funktion, wir mⁿssen den Stack wieder korrekt setzen: begin_callback(); if ((start>=2) && (rl_line_buffer[start-2]=='#') && (rl_line_buffer[start-1]== '\"')) # VervollstΣndigung nach #" bezieht sich auf Filenamen: { want_filename_completion = TRUE; return NULL; } # (SYS::COMPLETION text start end) aufrufen: pushSTACK(asciz_to_string(rl_line_buffer)); pushSTACK(fixnum((uintL)start)); pushSTACK(fixnum((uintL)end)); funcall(S(completion),3); want_filename_completion = FALSE; end_callback(); {var reg4 object mlist = value1; # Liste der M÷glichkeiten # Liste von Simple-Strings in mallozierten Array von mallozierten # Asciz-Strings umbauen: if (nullp(mlist)) { return NULL; } {var reg6 char** array = malloc((llength(mlist)+1)*sizeof(char*)); if (array==NULL) { return NULL; } {var reg5 char** ptr = array; while (consp(mlist)) { var reg3 uintC count = TheSstring(Car(mlist))->length; var reg2 uintB* ptr1 = &TheSstring(Car(mlist))->data[0]; var reg1 char* ptr2 = malloc((count+1)*sizeof(char)); if (ptr2==NULL) # malloc scheitert -> alles zurⁿckgeben { until (ptr==array) { free(*--ptr); } free(array); return NULL; } *ptr++ = ptr2; dotimesC(count,count, { *ptr2++ = *ptr1++; }); *ptr2 = '\0'; mlist = Cdr(mlist); } *ptr = NULL; } return array; }}} # Falls obige Funktion NULL (keine Matches) lieferte, wird die folgende # Funktion so lange aufgerufen, bis sie ihrerseits NULL liefert. local char* lisp_completion_more (char* text, int state); local char* lisp_completion_more(text,state) var reg2 char* text; var reg1 int state; { if (want_filename_completion) { return filename_completion_function(text,state); } else { return NULL; } } # Lesen eines Zeichens von einem Terminal-Stream. local object rd_ch_terminal3 (object* stream_); # vgl. rd_ch_handle() : local object rd_ch_terminal3(stream_) var reg3 object* stream_; { restart_it: {var reg2 object stream = *stream_; if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ? { return eof_value; } #if TERMINAL_LINEBUFFERED { var reg4 object inbuff = TheStream(stream)->strm_terminal_inbuff; # Eingabebuffer if (posfixnum_to_L(TheStream(stream)->strm_terminal_index) < TheArray(inbuff)->dims[1] ) # index<count -> Es sind noch Zeichen im Buffer { var reg1 uintL index = posfixnum_to_L(TheStream(stream)->strm_terminal_index); # Index TheStream(stream)->strm_terminal_index = fixnum_inc(TheStream(stream)->strm_terminal_index,1); # Index erh÷hen return code_char(TheSstring(TheArray(inbuff)->data)->data[index]); # nΣchstes Character } # index=count -> mu▀ eine ganze Zeile von Tastatur lesen: TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0 TheArray(inbuff)->dims[1] = 0; # count := 0 } #endif { var reg5 char* prompt; # Prompt: letzte bisher ausgegebene Zeile {var reg6 object lastline = string_to_asciz(TheStream(*stream_)->strm_terminal_outbuff); prompt = (char*) malloc(TheSstring(lastline)->length+1); if (!(prompt==NULL)) { strcpy(prompt,TheAsciz(lastline)); # Die readline()-Library arbeitet mit einer anderen Bildschirmbreite, # als sie bei der Ausgabe des Prompts benutzt wurde. Bei Prompts # lΣnger als eine Bildschirmzeile gibt das Probleme. Wir behelfen # uns, indem wir an passender Stelle ein '\n' einfⁿgen. { var reg8 uintL prompt_length = asciz_length(prompt); var reg7 uintL screenwidth = posfixnum_to_L(Symbol_value(S(prin_linelength)))+1; if (prompt_length >= screenwidth) { var reg4 uintL insertpos = round_down(prompt_length,screenwidth); var reg1 uintL i; for (i = prompt_length; i >= insertpos; i--) { prompt[i+1] = prompt[i]; } prompt[insertpos] = '\n'; } } } } # Lexem-trennende Characters: die mit Syntaxcode whsp,tmac,nmac # (siehe IO.D, eigentlich von der Readtable abhΣngig): rl_basic_word_break_characters = "\t" NLstring " \"#'(),;`"; rl_basic_quote_characters = "\"|"; rl_completer_quote_characters = "\\|"; run_time_stop(); # Run-Time-Stoppuhr anhalten #ifdef GRAPHICS_SWITCH switch_text_mode(); #endif begin_call(); rl_already_prompted = TRUE; {var reg4 uintB* line = (uintB*)readline(prompt==NULL ? "" : prompt); # Zeile lesen end_call(); run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen if (!(prompt==NULL)) { free(prompt); } if (line==NULL) # EOF (am Zeilenanfang) erkennen { TheStream(stream)->strm_rd_ch_last = eof_value; return eof_value; } # gelesene Zeile zur Eingabezeile dazunehmen: {var reg1 uintB* ptr = line; until (*ptr == '\0') { ssstring_push_extend(TheStream(*stream_)->strm_terminal_inbuff,*ptr++); } ssstring_push_extend(TheStream(*stream_)->strm_terminal_inbuff,NL); } # und in die History ⁿbernehmen, falls nicht leer: if (!(line[0]=='\0')) { add_history(line); } # Freigeben mⁿssen wir die Zeile! free(line); }} # Wenn stdin und stdout beide dasselbe Terminal sind, k÷nnen # wir davon ausgehen, da▀ der Cursor in Spalte 0 steht. if (eq(TheStream(*stream_)->strm_terminal_isatty,S(equal))) { TheStream(*stream_)->strm_wr_ch_lpos = Fixnum_0; TheArray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0 } # Nun fangen wir an, die Zeichen des Buffers zu liefern: goto restart_it; }} # Stellt fest, ob ein Terminal-Stream ein Zeichen verfⁿgbar hat. # listen_terminal3(stream) # > stream: Terminal-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF local signean listen_terminal3 (object stream); local signean listen_terminal3(stream) var reg1 object stream; { if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) # schon EOF ? { return signean_minus; } if (posfixnum_to_L(TheStream(stream)->strm_terminal_index) < TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] ) # index<count -> Es sind noch Zeichen im Buffer { return signean_null; } return listen_handle(stream); } # UP: L÷scht bereits eingegebenen interaktiven Input von einem Terminal-Stream. # clear_input_terminal3(stream); # > stream: Terminal-Stream # < ergebnis: TRUE falls Input gel÷scht wurde, FALSE sonst local boolean clear_input_terminal3 (object stream); local boolean clear_input_terminal3(stream) var reg1 object stream; { if (nullp(TheStream(stream)->strm_terminal_isatty)) # File -> nichts tun { return FALSE; } # Terminal TheStream(stream)->strm_rd_ch_last = NIL; # gewesenes EOF vergessen #if TERMINAL_LINEBUFFERED TheStream(stream)->strm_terminal_index = Fixnum_0; # index := 0 TheArray(TheStream(stream)->strm_terminal_inbuff)->dims[1] = 0; # count := 0 #endif clear_tty_input(stdin_handle); pushSTACK(stream); while (listen_terminal3(STACK_0) == 0) { read_char(&STACK_0); } skipSTACK(1); return TRUE; } # UP: Ein Zeichen auf einen Terminal-Stream ausgeben. # wr_ch_terminal3(&stream,ch); # > stream: Terminal-Stream # > ch: auszugebendes Zeichen local void wr_ch_terminal3 (object* stream_, object ch); local void wr_ch_terminal3(stream_,ch) var reg3 object* stream_; var reg1 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var uintB c = char_code(ch); # Code des Zeichens #if TERMINAL_OUTBUFFERED if (c==NL) TheArray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0 else ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,c); #endif restart_it: #ifdef GRAPHICS_SWITCH switch_text_mode(); #endif begin_system_call(); {var reg2 int ergebnis = write(stdout_handle,&c,1); # Zeichen auszugeben versuchen end_system_call(); if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { interruptp({ pushSTACK(S(write_char)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } OS_error(); # Error melden } if (ergebnis==0) # nicht erfolgreich? { fehler_unwritable(S(write_char),*stream_); } } }} #ifdef STRM_WR_SS # UP: Mehrere Zeichen auf einen Terminal-Stream ausgeben. # wr_ss_terminal3(&stream,string,start,len); # > stream: Terminal-Stream # > string: Simple-String # > start: Startindex # > len: Anzahl der auszugebenden Zeichen local void wr_ss_terminal3 (object* stream_, object string, uintL start, uintL len); local void wr_ss_terminal3(stream_,string,start,len) var reg6 object* stream_; var reg4 object string; var reg5 uintL start; var reg7 uintL len; { if (len==0) return; #ifdef GRAPHICS_SWITCH switch_text_mode(); #endif {var reg1 uintB* ptr = &TheSstring(string)->data[start]; var reg2 uintL remaining = len; loop { restart_it: begin_system_call(); {var reg3 int ergebnis = write(stdout_handle,ptr,remaining); # Zeichen auszugeben versuchen end_system_call(); if (ergebnis<0) { if (errno==EINTR) goto restart_it; OS_error(); # Error melden } if (ergebnis==0) # nicht erfolgreich? { fehler_unwritable(S(write_string),*stream_); } ptr += ergebnis; remaining -= ergebnis; if (remaining==0) break; # fertig? }} #if TERMINAL_OUTBUFFERED # Zeichen seit dem letzten NL in den Buffer: { var reg3 uintL pos = 0; # zΣhle die Zahl der Zeichen seit dem letzten NL var reg2 uintL count; dotimespL(count,len, { if (*--ptr == NL) goto found_NL; pos++; } ); if (FALSE) found_NL: # pos Zeichen seit dem letzten NL { ptr++; TheArray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0 } dotimesL(count,pos, ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,*ptr++); ); } #endif wr_ss_lpos(*stream_,ptr,len); # Line-Position aktualisieren }} #endif # UP: L÷scht den wartenden Output eines Terminal-Stream. # clear_output_terminal3(stream); # > stream: Terminal-Stream # kann GC ausl÷sen local void clear_output_terminal3 (object stream); local void clear_output_terminal3(stream) var reg1 object stream; { clear_output_handle(stream); #if TERMINAL_OUTBUFFERED TheArray(TheStream(stream)->strm_terminal_outbuff)->dims[1] = 0; # Fill-Pointer := 0 #endif } #endif # HAVE_TERMINAL3 # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel. # finish_output_terminal(stream); # > stream: Terminal-Stream # kann GC ausl÷sen #define finish_output_terminal finish_output_handle # UP: Bringt den wartenden Output eines Terminal-Stream ans Ziel. # force_output_terminal(stream); # > stream: Terminal-Stream # kann GC ausl÷sen #define force_output_terminal force_output_handle # Liefert einen interaktiven Terminal-Stream. # kann GC ausl÷sen local object make_terminal_stream_ (void); local object make_terminal_stream_() { #ifdef AMIGAOS # nur HAVE_TERMINAL1 { pushSTACK(allocate_handle(Output_handle)); pushSTACK(allocate_handle(Input_handle)); {var reg2 object stream = allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal1_len); # Flags: nur READ-CHAR und WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_terminal1); # READ-CHAR-Pseudofunktion s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_terminal1); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_terminal1); #endif begin_system_call(); s->strm_terminal_isatty = (IsInteractive(Input_handle) ? (IsInteractive(Output_handle) ? S(equal) # Input und Output Terminals -> vermutlich dasselbe : T ) : NIL ); end_system_call(); s->strm_terminal_ihandle = popSTACK(); s->strm_terminal_ohandle = popSTACK(); return stream; }} #else { var reg7 int stdin_tty; var reg8 int stdout_tty; var reg6 int same_tty; begin_system_call(); stdin_tty = isatty(stdin_handle); # stdin ein Terminal? stdout_tty = isatty(stdout_handle); # stdout ein Terminal? same_tty = FALSE; # vorlΣufig if (stdin_tty && stdout_tty) # stdin und stdout Terminals. { #if defined(UNIX) || defined(RISCOS) #if 0 var reg1 char* ergebnis; var reg2 object filename; ergebnis = ttyname(stdin_handle); # Filename von stdin holen if (!(ergebnis==NULL)) { end_system_call(); filename = asciz_to_string(ergebnis); begin_system_call(); ergebnis = ttyname(stdout_handle); # Filename von stdout holen if (!(ergebnis==NULL)) { end_system_call(); pushSTACK(filename); filename = asciz_to_string(ergebnis); if (string_gleich(popSTACK(),filename)) # gleiche Filenamen? { same_tty = TRUE; } } } #else # ttyname() ist recht langsam, fstat() geht schneller. struct stat stdin_stat; struct stat stdout_stat; if ((fstat(stdin_handle,&stdin_stat) >= 0) && (fstat(stdout_handle,&stdout_stat) >= 0)) if ((stdin_stat.st_dev == stdout_stat.st_dev) && (stdin_stat.st_ino == stdout_stat.st_ino)) { same_tty = TRUE; } #endif #endif #ifdef MSDOS if ( ((get_handle_info(stdin_handle) & (bit(7)|bit(0))) == (bit(7)|bit(0))) # stdin == console_input ? && ((get_handle_info(stdout_handle) & (bit(7)|bit(1))) == (bit(7)|bit(1))) # stdout == console_output ? ) { same_tty = TRUE; } #endif } end_system_call(); #ifdef HAVE_TERMINAL3 if (rl_present_p && same_tty) # Baue einen TERMINAL3-Stream: { pushSTACK(make_ssstring(80)); # Zeilenbuffer allozieren pushSTACK(make_ssstring(80)); # Zeilenbuffer allozieren # neuen Stream allozieren: {var reg2 object stream = allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal3_len); # Flags: nur READ-CHAR und WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_terminal3); # READ-CHAR-Pseudofunktion s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_terminal3); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_terminal3); #endif s->strm_terminal_isatty = S(equal); # stdout=stdin s->strm_terminal_ihandle = allocate_handle(stdin_handle); # Handle fⁿr listen_handle() s->strm_terminal_ohandle = allocate_handle(stdout_handle); # Handle fⁿr Output #if 1 # TERMINAL_LINEBUFFERED s->strm_terminal_inbuff = popSTACK(); # Zeilenbuffer eintragen, count := 0 s->strm_terminal_index = Fixnum_0; # index := 0 #endif #if 1 # TERMINAL_OUTBUFFERED s->strm_terminal_outbuff = popSTACK(); # Zeilenbuffer eintragen #endif return stream; }} #endif #ifdef HAVE_TERMINAL2 if (stdin_tty) # Baue einen TERMINAL2-Stream: { pushSTACK(make_ssstring(80)); # Zeilenbuffer allozieren # neuen Stream allozieren: {var reg2 object stream = allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal2_len); # Flags: nur READ-CHAR und WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_terminal2); # READ-CHAR-Pseudofunktion s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_terminal2); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_terminal2); #endif s->strm_terminal_isatty = (stdin_tty ? (same_tty ? S(equal) : T) : NIL); s->strm_terminal_ihandle = allocate_handle(stdin_handle); # Handle fⁿr listen_handle() s->strm_terminal_ohandle = allocate_handle(stdout_handle); # Handle fⁿr Output #if 1 # TERMINAL_LINEBUFFERED s->strm_terminal_inbuff = popSTACK(); # Zeilenbuffer eintragen, count := 0 s->strm_terminal_index = Fixnum_0; # index := 0 #endif return stream; }} #endif # Baue einen TERMINAL1-Stream: { # neuen Stream allozieren: var reg2 object stream = allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal1_len); # Flags: nur READ-CHAR und WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_terminal1); # READ-CHAR-Pseudofunktion s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_terminal1); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_terminal1); #endif s->strm_terminal_isatty = (stdin_tty ? (same_tty ? S(equal) : T) : NIL); s->strm_terminal_ihandle = allocate_handle(stdin_handle); # Handle fⁿr listen_handle() s->strm_terminal_ohandle = allocate_handle(stdout_handle); # Handle fⁿr Output return stream; } } #endif } #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS) # (SYS::TERMINAL-RAW *terminal-io* flag) # flag /= NIL: versetzt das Terminal in cbreak/noecho-Modus, # flag = NIL: versetzt das Terminal in nocbreak/echo-Modus zurⁿck. # Liefert T falls erfolgreich, NIL wenn es nicht geht. # (SYS::TERMINAL-RAW *terminal-io* t) entspricht im wesentlichen # (progn # ; keine Editierm÷glichkeiten, kein Echo, keine CR<-->NL-Umwandlungen: # (shell "stty -icanon -echo -icrnl -inlcr") # ; nichts abfangen: # ; 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 # (shell "stty -ixon -ixoff erase ^- kill ^- werase ^- rprnt ^- flush ^- lnext ^- susp ^- intr ^- quit ^- start ^- stop ^- eof ^-") # ; 1 Zeichen auf einmal verlangen (nicht 4!): # (shell "stty min 1") ; das mu▀ seltsamerweise zuletzt kommen... # ) # (SYS::TERMINAL-RAW *terminal-io* nil) entspricht im wesentlichen # (shell "stty sane") local void term_raw (void); local void term_unraw (void); #if defined(UNIX) || defined(RISCOS) local boolean oldterm_initialized = FALSE; #if defined(UNIX_TERM_TERMIOS) local struct termios oldtermio; # ursprⁿnglicher TTY-Modus local void term_raw() { if (!oldterm_initialized) { if (!( tcgetattr(stdout_handle,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } oldterm_initialized = TRUE; } {var struct termios newtermio; newtermio = oldtermio; newtermio.c_iflag &= ( /* IXON|IXOFF|IXANY| */ ISTRIP|IGNBRK); /* newtermio.c_oflag &= ~OPOST; */ # Curses st÷rt sich dran! newtermio.c_lflag &= ISIG; { var reg1 uintC i; for (i=0; i<NCCS; i++) { newtermio.c_cc[i] = 0; } } newtermio.c_cc[VMIN] = 1; newtermio.c_cc[VTIME] = 0; if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&newtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } }} local void term_unraw() { if (oldterm_initialized) { if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } } # Manche machen's so: # define crmode() (_tty.c_lflag &=~ICANON,_tty.c_cc[VMIN]=1,tcsetattr(_tty_ch, TCSAFLUSH, &_tty)) # define nocrmode() (_tty.c_lflag |= ICANON,_tty.c_cc[VEOF] = CEOF,tcsetattr(_tty_ch, TCSAFLUSH,&_tty)) # define echo() (_tty.c_lflag |= ECHO, tcsetattr(_tty_ch, TCSAFLUSH, &_tty)) # define noecho() (_tty.c_lflag &=~ECHO, tcsetattr(_tty_ch, TCSAFLUSH, &_tty)) # define nl() (_tty.c_iflag |= ICRNL,_tty.c_oflag |= ONLCR,tcsetattr(_tty_ch, TCSAFLUSH, &_tty)) # define nonl() (_tty.c_iflag &=~ICRNL,_tty.c_oflag &=~ONLCR,tcsetattr(_tty_ch, TCSAFLUSH, &_tty)) # define savetty() (tcgetattr(_tty_ch, &_oldtty),tcgetattr(_tty_ch, &_tty)) # define resetty() (tcsetattr(_tty_ch, TCSAFLUSH, &_oldtty)) #elif defined(UNIX_TERM_TERMIO) || defined(EMUNIX) local struct termio oldtermio; # ursprⁿnglicher TTY-Modus local void term_raw() { if (!oldterm_initialized) { if (!( ioctl(stdout_handle,TCGETA,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } oldterm_initialized = TRUE; } {var struct termio newtermio; newtermio = oldtermio; newtermio.c_iflag &= ( /* IXON|IXOFF|IXANY| */ ISTRIP|IGNBRK); /* newtermio.c_oflag &= ~OPOST; */ # Curses st÷rt sich dran! newtermio.c_lflag &= ISIG; { var reg1 uintC i; for (i=0; i<NCCS; i++) { newtermio.c_cc[i] = 0; } } newtermio.c_cc[VMIN] = 1; newtermio.c_cc[VTIME] = 0; if (!( ioctl(stdout_handle,TCSETAF,&newtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } }} local void term_unraw() { if (oldterm_initialized) { if (!( ioctl(stdout_handle,TCSETAF,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } } # Manche machen's so: # define crmode() (_tty.c_lflag &=~ICANON,_tty.c_cc[VMIN] = 1,ioctl(_tty_ch,TCSETAF,&_tty)) # define nocrmode() (_tty.c_lflag |= ICANON,_tty.c_cc[VEOF] = CEOF,stty(_tty_ch,&_tty)) # define echo() (_tty.c_lflag |= ECHO, ioctl(_tty_ch, TCSETA, &_tty)) # define noecho() (_tty.c_lflag &=~ECHO, ioctl(_tty_ch, TCSETA, &_tty)) # define nl() (_tty.c_iflag |= ICRNL,_tty.c_oflag |= ONLCR,ioctl(_tty_ch, TCSETAW, &_tty)) # define nonl() (_tty.c_iflag &=~ICRNL,_tty.c_oflag &=~ONLCR,ioctl(_tty_ch, TCSETAW, &_tty)) #elif defined(UNIX_TERM_SGTTY) local struct sgttyb oldsgttyb; # ursprⁿnglicher TTY-Modus local struct tchars oldtchars; # ursprⁿngliche Steuerzeichen #ifdef TIOCSLTC local struct ltchars oldltchars; # ursprⁿngliche Editierzeichen #endif local void term_raw() { if (!oldterm_initialized) { if (!( ioctl(stdout_handle,TIOCGETP,&oldsgttyb) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } if (!( ioctl(stdout_handle,TIOCGETC,&oldtchars) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #ifdef TIOCSLTC if (!( ioctl(stdout_handle,TIOCGLTC,&oldltchars) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #endif oldterm_initialized = TRUE; } {var struct sgttyb newsgttyb; newsgttyb = oldsgttyb; newsgttyb.sg_flags |= CBREAK; newsgttyb.sg_flags &= ~(CRMOD|ECHO|XTABS); if (!( ioctl(stdout_handle,TIOCSETP,&newsgttyb) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } {var struct tchars newtchars; local var union { char a [sizeof(struct tchars)]; struct tchars b; } zero_tchars = {{0,}}; newtchars = zero_tchars.b; if (!( ioctl(stdout_handle,TIOCSETC,&newtchars) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } #ifdef TIOCSLTC {var struct ltchars newltchars; local var union { char a [sizeof(struct ltchars)]; struct ltchars b; } zero_ltchars = {{0,}}; newltchars = zero_ltchars.b; if (!( ioctl(stdout_handle,TIOCSLTC,&newltchars) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } #endif } local void term_unraw() { if (oldterm_initialized) { if (!( ioctl(stdout_handle,TIOCSETP,&oldsgttyb) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } if (!( ioctl(stdout_handle,TIOCSETC,&oldtchars) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #ifdef TIOCSLTC if (!( ioctl(stdout_handle,TIOCSLTC,&oldltchars) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } #endif } } # Manche machen's so: # define raw() (_tty.sg_flags|=RAW, stty(_tty_ch,&_tty)) # define noraw() (_tty.sg_flags&=~RAW,stty(_tty_ch,&_tty)) # define crmode() (_tty.sg_flags |= CBREAK, stty(_tty_ch,&_tty)) # define nocrmode() (_tty.sg_flags &= ~CBREAK,stty(_tty_ch,&_tty)) # define echo() (_tty.sg_flags |= ECHO, stty(_tty_ch, &_tty)) # define noecho() (_tty.sg_flags &= ~ECHO, stty(_tty_ch, &_tty)) # define nl() (_tty.sg_flags |= CRMOD,stty(_tty_ch, &_tty)) # define nonl() (_tty.sg_flags &= ~CRMOD, stty(_tty_ch, &_tty)) # define savetty() (gtty(_tty_ch, &_tty), _res_flg = _tty.sg_flags) # define resetty() (_tty.sg_flags = _res_flg, stty(_tty_ch, &_tty)) #endif # Wir speichern, ob zuletzt term_raw() oder term_unraw() ausgefⁿhrt wurde, # damit wir bei Programm-Ausstieg zurⁿckschalten k÷nnen. local boolean terminal_raw = FALSE; global void terminal_sane (void); global void terminal_sane() { if (terminal_raw) { term_unraw(); terminal_raw = FALSE; } } LISPFUNN(terminal_raw,2) { var reg2 object flag = popSTACK(); var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } if (TheStream(stream)->strmtype == strmtype_terminal) # der Terminal-Stream { if (!nullp(TheStream(stream)->strm_terminal_isatty)) # Terminal { begin_system_call(); if (!nullp(flag)) # Umschalten in cbreak/noecho-Modus: { term_raw(); terminal_raw = TRUE; } else # Umschalten in nocbreak/echo-Modus: { term_unraw(); terminal_raw = FALSE; } end_system_call(); } } value1 = T; mv_count=1; } #endif # UNIX || RISCOS #ifdef AMIGAOS # include <exec/types.h> # include <dos/dosextens.h> # include <inline/exec.h> # include <inline/dos.h> # From Ralph Babel, The Amiga GURU book, p. 278 # SetMode() for pre-2.0 systems local LONG setmode (BPTR fh, LONG mode); local LONG setmode(fh,mode) var BPTR fh; var LONG mode; { if (DOSBase->dl_lib.lib_Version > 35) { return SetMode(fh,mode); } else # pre-2.0, no SetMode in the library { register struct MsgPort *fh_type = ((struct FileHandle *)BADDR(fh))->fh_Type; if (fh_type==NULL) return DOSFALSE; /* NIL: has no message port */ {var LONGALIGNTYPE(struct StandardPacket) spb; var struct StandardPacket * sp = LONGALIGN(&spb); var struct MsgPort * mp = &((struct Process *)FindTask(NULL))->pr_MsgPort; sp->sp_Msg.mn_Node.ln_Name = (char *)&sp->sp_Pkt; sp->sp_Pkt.dp_Link = &sp->sp_Msg; sp->sp_Pkt.dp_Port = mp; sp->sp_Pkt.dp_Type = ACTION_SCREEN_MODE; sp->sp_Pkt.dp_Arg1 = mode; /* 0 for CON */ PutMsg(fh_type, &sp->sp_Msg); WaitPort(mp); GetMsg(mp); /* assumes that no other packets are pending */ return sp->sp_Pkt.dp_Res1; } }} # Genauso wie den Terminal-Stream k÷nnen wir auch beliebige interaktive # Handle-Streams (andere Text-Fenster) in den Raw-Modus schalten. # Beim Terminal-Stream speichern wir den momentanen Zustand (um so wenig wie # m÷glich umschalten zu mⁿssen), bei den Handle-Streams wird das von screen.lsp # ⁿbernommen. local LONG terminal_mode = 0; # 0 = CON, 1 = RAW global void terminal_sane (void); global void terminal_sane() { if (!(terminal_mode == 0)) { begin_system_call(); setmode(Input_handle,0); end_system_call(); terminal_mode = 0; } } LISPFUNN(terminal_raw,2) { var reg4 object flag = popSTACK(); var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } if (!(TheStream(stream)->strmflags & strmflags_open_B)) # Stream geschlossen? { fehler_illegal_streamop(S(terminal_raw),stream); } {var reg3 LONG new_mode = (nullp(flag) ? 0 : 1); if ((TheStream(stream)->strmtype == strmtype_terminal) # der Terminal-Stream || (TheStream(stream)->strmtype == strmtype_handle) # ein File-Handle-Stream ) { if (!nullp(TheStream(stream)->strm_isatty)) { var reg2 LONG result; if (TheStream(stream)->strmtype == strmtype_terminal) # Terminal { if (new_mode == terminal_mode) { result = TRUE; } else { begin_system_call(); result = setmode(Input_handle,new_mode); end_system_call(); terminal_mode = new_mode; } } else # Handle-Stream { begin_system_call(); result = setmode(TheHandle(TheStream(stream)->strm_ihandle),new_mode); end_system_call(); } value1 = (result ? T : NIL); } else { value1 = T; } } else { value1 = NIL; } mv_count=1; }} #endif # AMIGAOS #endif # UNIX || AMIGAOS || RISCOS #endif # UNIX || (MSDOS && !WINDOWS) || AMIGAOS || RISCOS # Liefert einen interaktiven Terminal-Stream. # kann GC ausl÷sen local object make_terminal_stream (void); local object make_terminal_stream() { var reg2 object stream = make_terminal_stream_(); # Liste der offenen Streams um stream erweitern: pushSTACK(stream); {var reg1 object new_cons = allocate_cons(); Car(new_cons) = stream = popSTACK(); Cdr(new_cons) = O(open_files); O(open_files) = new_cons; } return stream; } # Window-Stream # ============= #ifdef SCREEN # Editor-Unterstⁿtzung: # ATARI: Direkt mit dem BIOS-VT52-Emulator. # MSDOS: ▄bers BIOS. # OS/2: Mit der Video-Library von Eberhard Mattes. # CURSES: Ein Window-Stream ist im wesentlichen ein Curses-WINDOW. # # (SCREEN:MAKE-WINDOW) # liefert einen Window-Stream. Solange bis dieser wieder geschlossen wird, # ist das Terminal im cbreak-noecho-Modus; weitere Ein-/Ausgabe ⁿber # *terminal-io* sollte in dieser Zeit nicht erfolgen. # # (SCREEN:WINDOW-SIZE window-stream) # liefert die Gr÷▀e des Windows, # als 2 Werte: H÷he (= Ymax+1), Breite (= Xmax+1). # # (SCREEN:WINDOW-CURSOR-POSITION window-stream) # liefert die Position des Cursors im Window # als 2 Werte: Zeile (>=0, <=Ymax, 0=oben), Spalte (>=0, <=Xmax, 0=links). # # (SCREEN:SET-WINDOW-CURSOR-POSITION window-stream line column) # setzt die Position des Cursors im Window. # # (SCREEN:CLEAR-WINDOW window-stream) # l÷scht den Inhalt des Window und setzt den Cursor an die linke obere Ecke # # (SCREEN:CLEAR-WINDOW-TO-EOT window-stream) # l÷scht den Inhalt des Window ab Cursor-Position bis Bildschirmende # # (SCREEN:CLEAR-WINDOW-TO-EOL window-stream) # l÷scht den Inhalt des Window ab Cursor-Position bis Zeilenende # # (SCREEN:DELETE-WINDOW-LINE window-stream) # l÷scht die Cursorzeile, schiebt die Zeilen drunter um 1 nach oben # und l÷scht die letzte Bildschirmzeile. # # (SCREEN:INSERT-WINDOW-LINE window-stream) # fⁿgt in der Zeile des Cursors eine neue Zeile ein und schiebt dabei alle # Zeilen ab der Cursorzeile um 1 nach unten. # # (SCREEN:HIGHLIGHT-ON window-stream) # schaltet "hervorgehobene" Ausgabe ein. # # (SCREEN:HIGHLIGHT-OFF window-stream) # schaltet "hervorgehobene" Ausgabe wieder aus. # # (SCREEN:WINDOW-CURSOR-ON window-stream) # macht den Cursor(block) sichtbar. # # (SCREEN:WINDOW-CURSOR-OFF window-stream) # macht den Cursor(block) wieder unsichtbar. # ▄berprⁿft, ob das Argument ein Window-Stream ist. local void check_window_stream (object stream); local void check_window_stream(stream) var reg1 object stream; { if (streamp(stream) && (TheStream(stream)->strmtype == strmtype_window) ) return; pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: Argument ~ sollte ein Window-Stream sein." : ENGLISH ? "~: argument ~ should be a window stream" : FRANCAIS ? "~ : L'argument ~ devrait Ωtre un WINDOW-STREAM." : "" ); } #ifdef ATARI # Terminal-Emulation: # VT52 mit einigen Erweiterungen, # vgl. TERMCAP-EintrΣge "vt52", "atari st", "heathkit 19" # UP: Ein Zeichen auf einen Window-Stream ausgeben. # wr_ch_window(&stream,ch); # > stream: Window-Stream # > ch: auszugebendes Zeichen local void wr_ch_window (object* stream_, object ch); local void wr_ch_window(stream_,ch) var reg2 object* stream_; var reg3 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var reg1 uintB c = char_code(ch); # Code des Zeichens # Code c ⁿbers BIOS auf den Bildschirm ausgeben: # c >= ' ' -> ⁿbers GEMDOS # 0 <= c < 32 -> genau c in {1,..,4}u{14,..,25}u{28,..,31} ⁿbers BIOS # sonst als Steuerzeichen ⁿbers BIOS if ((c < ' ') && # Bit c aus der 32-Bit-Zahl %11110011111111111100000000011110 holen: (0xF3FFC01EUL & bit(c)) ) { BIOS_GrConOut(c); } else { BIOS_ConOut(c); } }} LISPFUNN(make_window,0) { finish_output_terminal(var_stream(S(terminal_io))); # evtl. wartendes NL jetzt ausgeben {var reg2 object stream = allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+0); # Flags: nur WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unm÷glich s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy_nogc); #endif set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('w'); # Wrap off BIOS_ConOut(ESC); BIOS_ConOut('q'); # Reverse off clr_break_sem_1(); value1 = stream; mv_count=1; }} # Schlie▀t einen Window-Stream. local void close_window (object stream); local void close_window(stream) var reg1 object stream; { set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('v'); # Wrap on BIOS_ConOut(ESC); BIOS_ConOut('q'); # Reverse off clr_break_sem_1(); } LISPFUNN(window_size,1) { check_window_stream(popSTACK()); value1 = fixnum(window_size.y); value2 = fixnum(window_size.x); mv_count=2; } LISPFUNN(window_cursor_position,1) { check_window_stream(popSTACK()); value1 = fixnum((UWORD)(vdiesc.v_cur_y)); value2 = fixnum((UWORD)(vdiesc.v_cur_x)); mv_count=2; } LISPFUNN(set_window_cursor_position,3) { check_window_stream(STACK_2); {var reg2 uintL line = posfixnum_to_L(STACK_1); var reg3 uintL column = posfixnum_to_L(STACK_0); if ((line < (uintL)window_size.y) && (column < (uintL)window_size.x)) { set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('Y'); BIOS_ConOut(32+line); BIOS_ConOut(32+column); clr_break_sem_1(); } value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3); }} LISPFUNN(clear_window,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('E'); clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eot,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('J'); clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eol,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('K'); clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(delete_window_line,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('M'); clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(insert_window_line,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('L'); clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(highlight_on,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('p'); # Reverse on clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(highlight_off,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('q'); # Reverse off clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_on,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('e'); # Cursor on clr_break_sem_1(); value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_off,1) { check_window_stream(popSTACK()); set_break_sem_1(); BIOS_ConOut(ESC); BIOS_ConOut('f'); # Cursor off clr_break_sem_1(); value1 = NIL; mv_count=0; } #endif # ATARI #if defined(MSDOS) && !defined(EMUNIX_PORTABEL) && !defined(WINDOWS) # Aus der Distribution von ELVIS 1.4, File PC.C : # Author: # Guntram Blohm # Buchenstra▀e 19 # W 7904 Erbach # Germany # Tel. ++49-7305-6997 # sorry - no regular network connection # This file implements the ibm pc bios interface. See IBM documentation # for details. # If TERM is set upon invocation of CLISP, this code is ignored completely, # and the standard termcap functions are used, thus, even not-so-close # compatibles can run CLISP. For close compatibles however, bios output # is much faster (and permits reverse scrolling, adding and deleting lines, # and much more ansi.sys isn't capable of). GB. local uintL screentype; # 0 = monochrome, 1 = color local uintW screenattr; # screen attribute index # Documentation of attributes: # bit 7 : foreground character blinking, # bit 6..4 : background color, # bit 3 : foreground intensity, # bit 2..0 : foreground color, # color table: # 0 black, 1 blue, 2 green, 3 cyan, 4 red, 5 magenta, 6 brown, 7 lightgray, # and as foreground color with intensity bit set, it is light: # 8 darkgray, ..., E yelloe, F white. #define col_black 0 # schwarz #define col_blue 1 # blau #define col_green 2 # grⁿn #define col_cyan 3 # blaugrⁿn #define col_red 4 # rot #define col_magenta 5 # lila #define col_brown 6 # braun #define col_white 7 # wei▀ #define col_light(x) (8 | x) # hell #define FG(x) x # foreground color #define BG(x) (x << 4) # background color local uintB attr_table[2][5] = { # monochrome: { /* no standout */ BG(col_black) | FG(col_white), /* standout */ BG(col_white) | FG(col_black), /* visible bell */ BG(col_black) | FG(col_light(col_white)), /* underline */ BG(col_black) | FG(1), # underline /* alt. char set */ BG(col_black) | FG(col_light(col_white)), }, # color: { /* no standout */ BG(col_blue) | FG(col_light(col_white)), /* standout */ BG(col_blue) | FG(col_light(col_magenta)), /* visible bell */ BG(col_blue) | FG(col_light(col_brown)), /* underline */ BG(col_blue) | FG(col_light(col_green)), /* alt. char set */ BG(col_blue) | FG(col_light(col_red)), }, }; local uintB attr; # = attr_table[screentype][screenattr]; # INT 10 documentation: # INT 10,01 - Set cursor type # INT 10,02 - Set cursor position # INT 10,03 - Read cursor position # INT 10,06 - Scroll active page up # INT 10,07 - Scroll active page down # INT 10,09 - Write character and attribute at cursor # INT 10,0E - Write text in teletype mode # INT 10,0F - Get current video state # # INT 10,01 - Set Cursor Type # AH = 01 # CH = cursor starting scan line (cursor top) (low order 5 bits) # CL = cursor ending scan line (cursor bottom) (low order 5 bits) # returns nothing # - cursor scan lines are zero based # - the following is a list of the cursor scan lines associated with # most common adapters; screen sizes over 40 lines may differ # depending on adapters. # Line Starting Ending Character # Video Count Scan Line Scan Line Point Size # CGA 25 06 07 08 # MDA 25 0B 0C 0E # EGA 25 06 07 0E # EGA 43 04/06 07 08 # VGA 25 0D 0E 10 # VGA 40 08 09 0A # VGA 50 06 07 08 # - use CX = 2000h to disable cursor # # INT 10,02 - Set Cursor Position # AH = 02 # BH = page number (0 for graphics modes) # DH = row # DL = column # returns nothing # - positions relative to 0,0 origin # - 80x25 uses coordinates 0,0 to 24,79; 40x25 uses 0,0 to 24,39 # # INT 10,03 - Read Cursor Position and Size # AH = 03 # BH = video page # on return: # CH = cursor starting scan line (low order 5 bits) # CL = cursor ending scan line (low order 5 bits) # DH = row # DL = column # # INT 10,06 - Scroll Window Up # AH = 06 # AL = number of lines to scroll, previous lines are # blanked, if 0 or AL > screen size, window is blanked # BH = attribute to be used on blank line # CH = row of upper left corner of scroll window # CL = column of upper left corner of scroll window # DH = row of lower right corner of scroll window # DL = column of lower right corner of scroll window # returns nothing # - in video mode 4 (300x200 4 color) on the EGA, MCGA and VGA # this function scrolls page 0 regardless of the current page # # INT 10,07 - Scroll Window Down # AH = 07 # AL = number of lines to scroll, previous lines are # blanked, if 0 or AL > screen size, window is blanked # BH = attribute to be used on blank line # CH = row of upper left corner of scroll window # CL = column of upper left corner of scroll window # DH = row of lower right corner of scroll window # DL = column of lower right corner of scroll window # returns nothing # - in video mode 4 (300x200 4 color) on the EGA, MCGA and VGA # this function scrolls page 0 regardless of the current page # # INT 10,09 - Write Character and Attribute at Cursor Position # AH = 09 # AL = ASCII character to write # BH = display page (or mode 13h, background pixel value) # BL = character attribute (text) foreground color (graphics) # CX = count of characters to write (CX >= 1) # returns nothing # - does not move the cursor # - in graphics mode (except mode 13h), if BL bit 7=1 then # value of BL is XOR'ed with the background color # # INT 10,0E - Write Text in Teletype Mode # AH = 0E # AL = ASCII character to write # BH = page number (text modes) # BL = foreground pixel color (graphics modes) # returns nothing # - cursor advances after write # - characters BEL (7), BS (8), LF (A), and CR (D) are # treated as control codes # - for some older BIOS (10/19/81), the BH register must point # to the currently displayed page # - on CGA adapters this function can disable the video signal while # performing the output which causes flitter. # # INT 10,0F - Get Video State # AH = 0F # on return: # AH = number of screen columns # AL = mode currently set (see ~VIDEO MODES~) # BH = current display page # - video modes greater than 13h on EGA, MCGA and VGA indicate # ~INT 10,0~ was called with the high bit of the mode (AL) set # to 1, meaning the display does not need cleared # low-level BIOS interface #if defined(DJUNIX) || defined(WATCOM) #define intvideo(in_ptr,out_ptr) int86(0x10,in_ptr,out_ptr) #endif #ifdef EMUNIX local void intvideo (union REGS * in_regs, union REGS * out_regs); local void intvideo(in_regs,out_regs) var register union REGS * in_regs; var register union REGS * out_regs; { __asm__ __volatile__ ( "movl 0(%%esi),%%eax ; " "movl 4(%%esi),%%ebx ; " "movl 8(%%esi),%%ecx ; " "movl 12(%%esi),%%edx ; " "pushl %%edi ; " ".byte 0xcd ; .byte 0x10 ; " "popl %%edi ; " "movl %%eax,0(%%edi) ; " "movl %%ebx,4(%%edi) ; " "movl %%ecx,8(%%edi) ; " "movl %%edx,12(%%edi)" : # OUT : "S" /* %esi */ (in_regs), "D" /* %edi */ (out_regs) # IN : "ax","bx","cx","si","di" /* %eax,%ebx,%ecx,%esi,%edi */ # CLOBBER ); } #endif local void video (uintW ax, uintW* cx, uintW* dx); local void video(ax,cx,dx) var reg1 uintW ax; var reg1 uintW* cx; var reg1 uintW* dx; { var union REGS in; var union REGS out; in.regW.ax = ax; { var uintB ah = in.regB.ah; if (ah==0x06 || ah==0x07) { in.regB.bh = attr; } else { in.regB.bh = 0; # "active page" if (ah==0x09 || ah==0x0e) { in.regB.bl = attr; } } } if (cx) { in.regW.cx = *cx; } if (dx) { in.regW.dx = *dx; } begin_system_call(); intvideo(&in,&out); end_system_call(); if (dx) { *dx = out.regW.dx; } if (cx) { *cx = out.regW.cx; } } global uintW v_cols() { # determine number of screen columns. Also set screentype according # to monochrome/color screen. var union REGS in; var union REGS out; in.regB.ah=0x0f; intvideo(&in,&out); # INT 10,0F : get current video state {var reg1 uintB videomode = out.regB.al & 0x7f; # Text modes are 0,1,2,3,7, and others (depending on the graphics card). # Only modes 0 and 7 are mono. (Well, mode 2 is gray shaded.) screentype = (((videomode==0) || (videomode==7)) ? 0 # monochrome : 1 # color ); return out.regB.ah; }} local uintW v_rows() { # Getting the number of rows is hard. Most screens support 25 only, # EGA/VGA also support 43/50 lines, and some OEM's even more. # Unfortunately, there is no standard bios variable for the number # of lines, and the bios screen memory size is always rounded up # to 0x1000. So, we'll really have to cheat. # When using the screen memory size, keep in mind that each character # byte has an associated attribute byte. # uses: word at 40:4c contains memory size # byte at 40:84 # of rows-1 (sometimes) # byte at 40:4a # of columns #if 0 # cannot execute 8086 code! # screen size less then 4K? then we have 25 lines only if (*(uintW far *)(0x0040004CL)<=4096) return 25; # VEGA vga uses the bios byte at 0x40:0x84 for # of rows. # Use that byte, if it makes sense together with memory size. if ((((*(uintB far *)(0x0040004AL)*2*(*(uintB far *)(0x00400084L)+1)) +0xfff ) &(~0xfff) ) == *(uintW far *)(0x0040004CL) ) return *(uintB far *)(0x00400084L)+1; #endif # uh oh. Emit LFs until screen starts scrolling. { var uintW line; var uintW oldline = 0; video(0x0200,NULL,&oldline); # INT 10,02 : set cursor position to (0,0) loop { video(0x0e0a,NULL,NULL); # INT 10,0E : write LF in teletype mode video(0x0300,NULL,&line); # INT 10,03 : read cursor position line>>=8; if (oldline==line) { return line+1; } oldline = line; } } } # High-level BIOS interface local uintW LINES; local uintW COLS; void v_up() { # cursor up: determine current position, decrement row, set position var uintW dx; video(0x0300,NULL,&dx); # INT 10,03 : read cursor position dx -= 0x100; video(0x0200,NULL,&dx); # INT 10,02 : set cursor position } #if 1 void v_cb() { # cursor big: set begin scan to end scan - 4 var uintW cx; video(0x0300,&cx,NULL); # INT 10,03 : read cursor position cx=((cx&0xff)|(((cx&0xff)-4)<<8)); video(0x0100,&cx,NULL); # INT 10,01 : set cursor type } void v_cs() { # cursor small: set begin scan to end scan - 1 var uintW cx; video(0x0300,&cx,NULL); # INT 10,03 : read cursor position cx=((cx&0xff)|(((cx&0xff)-1)<<8)); video(0x0100,&cx,NULL); # INT 10,01 : set cursor type } #endif void v_ce() { # clear to end: get cursor position and emit the aproppriate number # of spaces, without moving cursor. var uintW cx; var uintW dx; video(0x0300,NULL,&dx); # INT 10,03 : read cursor position cx = COLS - (dx&0xff); video(0x0920,&cx,NULL); # INT 10,09 : write character at cursor, cx times 0x20 } void v_cl() { # clear screen: clear all and set cursor home var uintW cx = 0; var uintW dx = ((LINES-1)<<8)+(COLS-1); video(0x0600,&cx,&dx); # INT 10,06 : scroll active page up dx = 0; video(0x0200,&cx,&dx); # INT 10,02 : set cursor position } void v_cd() { # clear to bottom: get position, clear to eol, clear next line to end var uintW cx; var uintW dx; var uintW dxtmp; video(0x0300,NULL,&dx); # INT 10,03 : read cursor position dxtmp = (dx&0xff00)|(COLS-1); cx = dx; video(0x0600,&cx,&dxtmp); # INT 10,06 : scroll active page up cx = (dx&0xff00)+0x100; dx = ((LINES-1)<<8)+(COLS-1); video(0x0600,&cx,&dx); # INT 10,06 : scroll active page up } void v_al() { # add line: scroll rest of screen down var uintW cx; var uintW dx; video(0x0300,NULL,&dx); # INT 10,03 : read cursor position cx = (dx&0xff00); dx = ((LINES-1)<<8)+(COLS-1); video(0x0701,&cx,&dx); # INT 10,06 : scroll active page down } void v_dl() { # delete line: scroll rest up var uintW cx; var uintW dx; video(0x0300,NULL,&dx); # INT 10,03 : read cursor position cx = (dx&0xff00) /* + 0x100 */ ; dx = ((LINES-1)<<8)+(COLS-1); video(0x0601,&cx,&dx); # INT 10,06 : scroll active page up } void v_sr() { # scroll reverse: scroll whole screen var uintW cx = 0; var uintW dx = ((LINES-1)<<8)+(COLS-1); video(0x0701,&cx,&dx); # INT 10,06 : scroll active page down } void v_move(y,x) var uintW y; var uintW x; { # set cursor var uintW dx = (y<<8)+x; video(0x0200,NULL,&dx); # INT 10,02 : set cursor position } uintW v_put(ch) var uintW ch; { # put character: # put attribute and char (no scroll!), then update cursor position. var uintW cx=1; ch &= 0xff; if (ch==NL) { video(0x0e00|CR,NULL,NULL); # INT 10,0E : write in teletype mode video(0x0e00|LF,NULL,NULL); # INT 10,0E : write in teletype mode } else { video(0x0900|ch,&cx,NULL); # INT 10,09 : write character at cursor {# cursor right: determine current position, increment column, set position var uintW dx; video(0x0300,NULL,&dx); # INT 10,03 : read cursor position dx += 0x1; # increment column if ((dx & 0xff) == COLS) # at right margin? { dx &= 0xff00; # set column to 0 dx += 0x100; # increment row if ((dx >> 8) == LINES) # at bottom margin? goto no_scroll; # do not scroll at right bottom corner!! } video(0x0200,NULL,&dx); # INT 10,02 : set cursor position no_scroll: ; }} return ch; } # Lisp-Funktionen: # UP: Ein Zeichen auf einen Window-Stream ausgeben. # wr_ch_window(&stream,ch); # > stream: Window-Stream # > ch: auszugebendes Zeichen local void wr_ch_window (object* stream_, object ch); local void wr_ch_window(stream_,ch) var reg2 object* stream_; var reg3 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var reg1 uintB c = char_code(ch); # Code des Zeichens # Code c ⁿbers BIOS auf den Bildschirm ausgeben: v_put(c); }} LISPFUNN(make_window,0) { var reg2 object stream = allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+0); # Flags: nur WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unm÷glich s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy_nogc); #endif LINES = v_rows(); COLS = v_cols(); screenattr = 0; attr = attr_table[screentype][screenattr]; v_cs(); value1 = stream; mv_count=1; } # Schlie▀t einen Window-Stream. local void close_window (object stream); local void close_window(stream) var reg1 object stream; { v_cs(); attr = BG(col_black) | FG(col_white); v_cl(); # clear screen black } LISPFUNN(window_size,1) { check_window_stream(popSTACK()); value1 = fixnum(LINES); value2 = fixnum(COLS); mv_count=2; } LISPFUNN(window_cursor_position,1) { check_window_stream(popSTACK()); {var uintW dx; video(0x0300,NULL,&dx); # INT 10,03 : read cursor position value1 = fixnum(dx>>8); value2 = fixnum(dx&0xff); mv_count=2; }} LISPFUNN(set_window_cursor_position,3) { check_window_stream(STACK_2); {var reg2 uintL line = posfixnum_to_L(STACK_1); var reg3 uintL column = posfixnum_to_L(STACK_0); if ((line < (uintL)LINES) && (column < (uintL)COLS)) { v_move(line,column); } value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3); }} LISPFUNN(clear_window,1) { check_window_stream(popSTACK()); v_cl(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eot,1) { check_window_stream(popSTACK()); v_cd(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eol,1) { check_window_stream(popSTACK()); v_ce(); value1 = NIL; mv_count=0; } LISPFUNN(delete_window_line,1) { check_window_stream(popSTACK()); v_dl(); value1 = NIL; mv_count=0; } LISPFUNN(insert_window_line,1) { check_window_stream(popSTACK()); v_al(); value1 = NIL; mv_count=0; } LISPFUNN(highlight_on,1) { check_window_stream(popSTACK()); screenattr = 1; attr = attr_table[screentype][screenattr]; value1 = NIL; mv_count=0; } LISPFUNN(highlight_off,1) { check_window_stream(popSTACK()); screenattr = 0; attr = attr_table[screentype][screenattr]; value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_on,1) { check_window_stream(popSTACK()); v_cb(); value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_off,1) { check_window_stream(popSTACK()); v_cs(); value1 = NIL; mv_count=0; } #endif # MSDOS && !EMUNIX_PORTABEL && !WINDOWS #if defined(MSDOS) && (defined(EMUNIX_PORTABEL) && defined(EMUNIX_NEW_8f)) # Benutze die Video-Library von Eberhard Mattes. # Vorzⁿge: # - einfaches Interface, # - ruft unter OS/2 die Vio-Funktionen auf, unter DOS wird der Bildschirm- # speicher direkt angesprochen (schnell!), falls einer der Standard-Textmodi # vorliegt, sonst wird das BIOS bemⁿht (portabel!). local uintL screentype; # 0 = monochrome, 1 = color local uintB attr_table[2][5] = { # monochrome: { /* no standout */ BW_NORMAL, /* standout */ BW_REVERSE, /* visible bell */ BW_NORMAL | INTENSITY, /* underline */ BW_UNDERLINE, /* alt. char set */ BW_NORMAL | INTENSITY, }, # color: { /* no standout */ B_BLUE | F_WHITE | INTENSITY, /* standout */ B_BLUE | F_MAGENTA | INTENSITY, /* visible bell */ B_BLUE | F_BROWN | INTENSITY, /* underline */ B_BLUE | F_GREEN | INTENSITY, /* alt. char set */ B_BLUE | F_RED | INTENSITY, }, }; local int cursor_scanlines_start; local int cursor_scanlines_end; local int LINES; # Anzahl Zeilen local int COLS; # Anzahl Spalten, Anzahl Zeichen pro Zeile # UP: Ein Zeichen auf einen Window-Stream ausgeben. # wr_ch_window(&stream,ch); # > stream: Window-Stream # > ch: auszugebendes Zeichen local void wr_ch_window (object* stream_, object ch); local void wr_ch_window(stream_,ch) var reg2 object* stream_; var reg3 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var reg1 uintB c = char_code(ch); # Code des Zeichens # Code c ⁿber die Video-Library auf den Bildschirm ausgeben: if (c==NL) { v_putc(c); } else { var int current_x; var int current_y; v_getxy(¤t_x,¤t_y); # get current cursor position if ((current_x==COLS-1) && (current_y==LINES-1)) { v_putn(c,1); } # do not scroll at right bottom corner!! else { v_putc(c); } } }} LISPFUNN(make_window,0) { var reg2 object stream = allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+0); # Flags: nur WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unm÷glich s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy_nogc); #endif v_init(); # Initialisieren #if 1 screentype = (v_hardware()==V_MONOCHROME ? 0 : 1); # Bildschirmtyp abfragen #else videomode abfragen wie in vinit.c, dann screentype = (((videomode==0) || (videomode==7)) ? 0 # monochrome : 1 # color ); #endif v_dimen(&COLS,&LINES); # Bildschirmgr÷▀e abfragen v_getctype(&cursor_scanlines_start,&cursor_scanlines_end); # Cursorform abfragen v_attrib(attr_table[screentype][0]); # Highlight off v_ctype(cursor_scanlines_end-1,cursor_scanlines_end); # cursor small value1 = stream; mv_count=1; } # Schlie▀t einen Window-Stream. local void close_window (object stream); local void close_window(stream) var reg1 object stream; { v_gotoxy(0,0); # Cursor home v_attrib(screentype==0 ? BW_NORMAL : (B_BLACK | F_WHITE)); v_putn(' ',LINES*COLS); # Bildschirm l÷schen v_ctype(cursor_scanlines_start,cursor_scanlines_end); # Cursorform zurⁿcksetzen } LISPFUNN(window_size,1) { check_window_stream(popSTACK()); value1 = fixnum((uintW)LINES); value2 = fixnum((uintW)COLS); mv_count=2; } LISPFUNN(window_cursor_position,1) { check_window_stream(popSTACK()); {var int current_x; var int current_y; v_getxy(¤t_x,¤t_y); # get current cursor position value1 = fixnum((uintW)current_y); value2 = fixnum((uintW)current_x); mv_count=2; }} LISPFUNN(set_window_cursor_position,3) { check_window_stream(STACK_2); {var reg2 uintL line = posfixnum_to_L(STACK_1); var reg3 uintL column = posfixnum_to_L(STACK_0); if ((line < (uintL)LINES) && (column < (uintL)COLS)) { v_gotoxy((int)column,(int)line); } value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3); }} LISPFUNN(clear_window,1) { check_window_stream(popSTACK()); v_gotoxy(0,0); #ifdef EMUNIX_NEW_9a v_clear(); #else # v_clear() funktioniert bei emx <= 0.8h nicht v_putn(' ',LINES*COLS); #endif value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eot,1) { check_window_stream(popSTACK()); {var int current_x; var int current_y; v_getxy(¤t_x,¤t_y); # get current cursor position v_putn(' ',COLS*(LINES-current_y)-current_x); value1 = NIL; mv_count=0; }} LISPFUNN(clear_window_to_eol,1) { check_window_stream(popSTACK()); v_clreol(); value1 = NIL; mv_count=0; } LISPFUNN(delete_window_line,1) { check_window_stream(popSTACK()); #ifdef EMUNIX_NEW_8g v_delline(1); #else # Bug in EMX 0.8f umgehen {var int current_x; var int current_y; v_getxy(¤t_x,¤t_y); # get current cursor position v_scroll(0,current_y,COLS-1,LINES-1,1,V_SCROLL_UP); } #endif value1 = NIL; mv_count=0; } LISPFUNN(insert_window_line,1) { check_window_stream(popSTACK()); v_insline(1); value1 = NIL; mv_count=0; } LISPFUNN(highlight_on,1) { check_window_stream(popSTACK()); v_attrib(attr_table[screentype][1]); value1 = NIL; mv_count=0; } LISPFUNN(highlight_off,1) { check_window_stream(popSTACK()); v_attrib(attr_table[screentype][0]); value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_on,1) { check_window_stream(popSTACK()); # cursor big: set begin scan to end scan - 4 v_ctype(cursor_scanlines_end-4,cursor_scanlines_end); value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_off,1) { check_window_stream(popSTACK()); # cursor small: set begin scan to end scan - 1 v_ctype(cursor_scanlines_end-1,cursor_scanlines_end); value1 = NIL; mv_count=0; } #endif # MSDOS && (EMUNIX_PORTABEL && EMUNIX_NEW_8f) #if defined(MSDOS) && defined(WINDOWS) # Benutze ein Text-Fenster, siehe wintext.d. extern mywindow text_create (void); extern void text_destroy (mywindow w); extern void text_cursor_on (mywindow w); extern void text_cursor_off (mywindow w); extern void get_text_size (mywindow w, int* width, int* height); extern void get_text_cursor_position (mywindow w, int* x, int* y); extern void set_text_cursor_position (mywindow w, int x, int y); extern void text_writechar (mywindow w, char c); extern void text_clear (mywindow w); extern void text_clear_to_eol (mywindow w); extern void text_clear_to_eot (mywindow w); extern void text_delete_line (mywindow w); extern void text_insert_line (mywindow w); #define strm_mywindow strm_other[0] # Maschinenpointer auf ein struct mywindow # UP: Ein Zeichen auf einen Window-Stream ausgeben. # wr_ch_window(&stream,ch); # > stream: Window-Stream # > ch: auszugebendes Zeichen local void wr_ch_window (object* stream_, object ch); local void wr_ch_window(stream_,ch) var reg2 object* stream_; var reg3 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var reg1 uintB c = char_code(ch); # Code des Zeichens var reg4 mywindow w = (mywindow)TheMachine(TheStream(*stream_)->strm_mywindow); # Code c auf den Bildschirm ausgeben: if (c=='\t') { var int x,y; do { text_writechar(w,' '); get_text_cursor_position(w,&x,&y); } until ((x % 8) == 0); } else { text_writechar(w,c); } }} LISPFUNN(make_window,0) { var reg3 mywindow w = text_create(); if (!w) { pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: Kann keinen Window-Stream erzeugen." : ENGLISH ? "~: cannot create a window stream" : FRANCAIS ? "~ : Ne peux pas Θtablir un WINDOW-STREAM." : "" ); } {var reg2 object stream = allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1); # Flags: nur WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unm÷glich s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy); #endif s->strm_mywindow = type_untype_object(machine_type,w); value1 = stream; mv_count=1; }} # Schlie▀t einen Window-Stream. local void close_window (object stream); local void close_window(stream) var reg1 object stream; { var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_destroy(w); } LISPFUNN(window_size,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); var int current_width; var int current_height; get_text_size(w,¤t_width,¤t_height); value1 = fixnum((uintW)current_height); value2 = fixnum((uintW)current_width); mv_count=2; }} LISPFUNN(window_cursor_position,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); var int current_x; var int current_y; get_text_cursor_position(w,¤t_x,¤t_y); value1 = fixnum((uintW)current_y); value2 = fixnum((uintW)current_x); mv_count=2; }} LISPFUNN(set_window_cursor_position,3) { var reg1 object stream = STACK_2; check_window_stream(stream); {var reg4 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); var reg2 uintL line = posfixnum_to_L(STACK_1); var reg3 uintL column = posfixnum_to_L(STACK_0); var int current_width; var int current_height; get_text_size(w,¤t_width,¤t_height); if ((line < (uintL)current_height) && (column < (uintL)current_width)) { set_text_cursor_position(w,column,line); } value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3); }} LISPFUNN(clear_window,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_clear(w); value1 = NIL; mv_count=0; }} LISPFUNN(clear_window_to_eot,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_clear_to_eot(w); value1 = NIL; mv_count=0; }} LISPFUNN(clear_window_to_eol,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_clear_to_eol(w); value1 = NIL; mv_count=0; }} LISPFUNN(delete_window_line,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_delete_line(w); value1 = NIL; mv_count=0; }} LISPFUNN(insert_window_line,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_insert_line(w); value1 = NIL; mv_count=0; }} LISPFUNN(highlight_on,1) { check_window_stream(popSTACK()); # noch nicht implementiert value1 = NIL; mv_count=0; } LISPFUNN(highlight_off,1) { check_window_stream(popSTACK()); # noch nicht implementiert value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_on,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_cursor_on(w); value1 = NIL; mv_count=0; }} LISPFUNN(window_cursor_off,1) { var reg1 object stream = popSTACK(); check_window_stream(stream); {var reg2 mywindow w = (mywindow)TheMachine(TheStream(stream)->strm_mywindow); text_cursor_off(w); value1 = NIL; mv_count=0; }} #endif # MSDOS && WINDOWS #if defined(UNIX) || (defined(EMUNIX_PORTABEL) && defined(EMUNIX_OLD_8e)) || defined(RISCOS) # ------------------------------------------------------------------------------ # Routinen zur Emulation aller VT100-Features auf normalen Terminals. # Idee: Oliver Laumann 1987 # Benutzt die TERMCAP-Library: # Besorgt die Capability-Informationen zu Terminal-Type name. # Ergebnis: 1 falls OK, 0 falls name unbekannt, -1 bei sonstigem Fehler. extern int tgetent (char* bp, char* name); # Besorgt den Wert einer numerischen Capability (-1 falls nicht vorhanden). extern int tgetnum (char* id); # Besorgt den Wert einer booleschen Capability (1 falls vorhanden, 0 sonst). extern int tgetflag (char* id); # Besorgt den Wert einer String-wertigen Capability und (falls area/=NULL) # kopiert es nach *area und rⁿckt dabei *area weiter. extern char* tgetstr (char* id, char** area); # Besorgt den String, der eine Cursor-Positionierung an Stelle (destcol,destline) # bewirkt. (N÷tig, da tgetstr("cm") ein spezielles Format hat!) extern char* tgoto (char* cm, int destcol, int destline); # Fⁿhrt eine String-Capability aus. Dazu wird fⁿr jedes Character die # Ausgabefunktion *outcharfun aufgerufen. (N÷tig, da String-Capabilities # Padding-Befehle enthalten k÷nnen!) extern char* tputs (char* cp, int affcnt, void (*outcharfun)()); # Einstellbare Wⁿnsche: #define WANT_INSERT FALSE # Insert-Modus #define WANT_SAVE FALSE # Save/Restore fⁿr die Cursor-Position #define WANT_ATTR TRUE # Attribute (fett, reverse etc.) #define WANT_CHARSET FALSE # Fonts = Charsets # zu definierende Funktionen: #define WANT_CURSOR_MOVE FALSE #define WANT_CURSOR_BACKSPACE FALSE #define WANT_CURSOR_RETURN TRUE #define WANT_CURSOR_LINEFEED TRUE #define WANT_CURSOR_REVLINEFEED FALSE #define WANT_CLEAR_SCREEN TRUE #define WANT_CLEAR_FROM_BOS FALSE #define WANT_CLEAR_TO_EOS TRUE #define WANT_CLEAR_LINE FALSE #define WANT_CLEAR_FROM_BOL FALSE #define WANT_CLEAR_TO_EOL TRUE #define WANT_INSERT_1CHAR FALSE #define WANT_INSERT_CHAR FALSE #define WANT_INSERT_LINE TRUE #define WANT_DELETE_CHAR FALSE #define WANT_DELETE_LINE TRUE #define WANT_OUTPUT_1CHAR TRUE # kleine Korrekturen: #define WANT_CLEAR_SCREEN TRUE #if WANT_OUTPUT_1CHAR && WANT_INSERT #define WANT_INSERT_1CHAR TRUE #endif # Ausgabe eines Zeichens, direkt. local void out_char (uintB c); local void out_char(c) var uintB c; { #ifdef GRAPHICS_SWITCH switch_text_mode(); #endif begin_system_call(); restart_it: {var reg1 int ergebnis = write(stdout_handle,&c,1); # Zeichen auszugeben versuchen if (ergebnis<0) { if (errno==EINTR) goto restart_it; OS_error(); # Error melden } if (ergebnis==0) # nicht erfolgreich? { pushSTACK(var_stream(S(terminal_io))); # Wert fⁿr Slot PATHNAME von FILE-ERROR fehler(file_error, DEUTSCH ? "Kann nichts auf Standard-Output ausgeben." : ENGLISH ? "cannot output to standard output" : FRANCAIS ? "Ne peut rien Θcrire sur la sortie principale." : "" ); } end_system_call(); }} # Ausgabe eines Capability-Strings. local void out_capstring (char* s); local void out_capstring(s) var reg1 char* s; { if (!(s==NULL)) # Absichern gegen nicht vorhandene Capability { tputs(s,1,(void (*)()) &out_char); } } # Ausgabe eines Capability-Strings mit einem Argument. local void out_cap1string (char* s, int arg); local void out_cap1string(s,arg) var reg1 char* s; var reg2 int arg; { if (!(s==NULL)) # Absichern gegen nicht vorhandene Capability { tputs(tgoto(s,0,arg),1,(void (*)()) &out_char); } } # Kosten der Ausfⁿhrung einer Capability: #define EXPENSIVE 1000 local uintC cost_counter; # ZΣhler # Funktion, die nicht ausgibt, sondern nur zΣhlt: local void count_char (char c); local void count_char(c) var reg1 char c; { cost_counter++; } # Berechnet die Kosten der Ausgabe einer Capability: local uintC cap_cost (char* s); local uintC cap_cost(s) var reg1 char* s; { if (s==NULL) { return EXPENSIVE; } # Capability nicht vorhanden else { cost_counter = 0; tputs(s,1,(void (*)()) &count_char); return cost_counter; } } # Buffer fⁿr von mir ben÷tigte Capabilities und Pointer da hinein: local char tentry[4096]; local char* tp = &tentry[0]; # Einige ausgewΣhlte Capabilities (NULL oder Pointer in tentry hinein): # Insert-Modus: local char* IMcap; # Enter Insert Mode local uintC IMcost; local char* EIcap; # End Insert Mode local uintC EIcost; #if WANT_ATTR # Attribute: local char* SOcap; # Enter standout mode local char* SEcap; # End standout mode local char* UScap; # Enter underline mode local char* UEcap; # End underline mode local char* MBcap; # Turn on blinking local char* MDcap; # Turn on bold (extra-bright) mode local char* MHcap; # Turn on half-bright mode local char* MRcap; # Turn on reverse mode local char* MEcap; # Turn off all attributes #endif #if WANT_CHARSET # ZeichensΣtze: local boolean ISO2022; # ob Zeichensatzwechsel nach ISO2022 unterstⁿtzt wird #endif # Cursor-Bewegung: local char* CMcap; # Cursor motion, allgemeine Cursor-Positionierung local char* TIcap; # Initialize mode where CM is usable local char* TEcap; # Exit mode where CM is usable local char* BCcap; # Backspace Cursor local uintC BCcost; local char* NDcap; # cursor right local uintC NDcost; local char* DOcap; # cursor down local uintC DOcost; local char* UPcap; # cursor up local uintC UPcost; local char* NLcap; # Newline local char* CRcap; # Carriage Return local uintC CRcost; # Scrolling: local char* CScap; # change scroll region #if WANT_DELETE_LINE local char* SFcap; # Scroll (text up) #endif #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE local char* SRcap; # Scroll reverse (text down) #endif # Sonstige: local char* IScap; # Terminal Initialization 2 # local char* BLcap; # Bell # local char* VBcap; # Visible Bell (Flash) local char* CLcap; # clear screen, cursor home #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL local char* CEcap; # clear to end of line #endif #if WANT_CLEAR_TO_EOS local char* CDcap; # clear to end of screen #endif #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE local char* ALcap; # add new blank line #endif #if WANT_DELETE_LINE local char* DLcap; # delete line #endif #if WANT_DELETE_CHAR local char* DCcap; # delete character #endif #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR local char* ICcap; # insert character #endif #if WANT_INSERT_CHAR local char* CICcap; # insert count characters #endif #if WANT_INSERT_LINE local char* CALcap; # add count blank lines #endif #if WANT_DELETE_CHAR local char* CDCcap; # delete count chars #endif #if WANT_DELETE_LINE local char* CDLcap; # delete count lines #endif local boolean AM; # automatic margins, ob an rechterer unterer Ecke scrollt local int rows; # Anzahl der Zeilen des Bildschirms, >0 local int cols; # Anzahl der Spalten des Bildschirms, >0 # Obere Zeile ist Zeile 0, untere Zeile ist Zeile rows-1. # Linke Spalte ist Spalte 0, rechte Spalte ist Spalte cols-1. #if WANT_ATTR || WANT_CHARSET local uintB* null; # Pointer auf cols Nullen #endif local uintB* blank; # Pointer auf cols Blanks # Beschreibung einer Terminal-Ausgabe-Einheit: typedef struct { uintB** image; # image[y][x] ist das Zeichen an Position (x,y) #if WANT_ATTR uintB** attr; # attr[y][x] ist sein Attribut uintB curr_attr; # welches Attribut gerade aktuell ist #endif #if WANT_CHARSET uintB** font; # font[y][x] ist sein Font (Charset) #define charset_count 4 uintB charsets[charset_count]; # Tabelle von ZeichensΣtzen uintC curr_charset; # welcher der ZeichensΣtze gerade aktuell ist # (>=0, <charset_count) #endif int x; # Cursorposition (>=0, <=cols) int y; # Cursorposition (>=0, <rows) # (Bei x=cols wird der Cursor in Spalte cols-1 dargestellt.) int top, bot; # Scroll-Region = Zeilen y mit top <= y <= bot, # es ist 0 <= top <= bot <= rows-1. #if WANT_INSERT boolean insert; # ob die Ausgabe-Einheit im Insert-Modus arbeitet # (dann ist das Terminal meist im Insert-Modus) #endif #if WANT_SAVE boolean saved; #if WANT_ATTR uintB saved_curr_attr; #endif #if WANT_CHARSET uintB saved_charsets[charset_count]; uintC saved_curr_charset; #endif int saved_x, saved_y; #endif } win; # aktuelle Ausgabe-Einheit: local win currwin; # es gibt nur eine! #define curr (&currwin) #if WANT_INSERT # Insert-Modus ein- bzw. ausschalten: # Flag, ob das Terminal im Insert-Modus ist (falls es einen solchen gibt): local boolean insert; local void set_insert_mode (boolean flag); local void set_insert_mode(flag) var reg1 boolean flag; { if (flag) # Einschalten { if (!insert) { out_capstring(IMcap); } } else # Ausschalten { if (insert) { out_capstring(EIcap); } } insert = flag; } #endif #if WANT_ATTR # Ausgabe-Attribute des Terminals umschalten: local uintB term_attr; # aktuelle Attribute des Terminals # m÷gliche Attribute sind ein ODER aus: #define A_SO bit(0) # Standout mode #define A_US bit(1) # Underscore mode #define A_BL bit(2) # Blinking #define A_BD bit(3) # Bold mode #define A_DI bit(4) # Dim mode #define A_RV bit(5) # Reverse mode local void change_attr (uintB new_attr); local void change_attr(new_attr) var reg1 uintB new_attr; { var reg2 uintB old_attr = term_attr; if (old_attr == new_attr) { return; } if ( ((old_attr & A_SO) && !(new_attr & A_SO)) || ((old_attr & A_US) && !(new_attr & A_US)) || ((old_attr & A_BL) && !(new_attr & A_BL)) || ((old_attr & A_BD) && !(new_attr & A_BD)) || ((old_attr & A_DI) && !(new_attr & A_DI)) || ((old_attr & A_RV) && !(new_attr & A_RV)) ) # Mu▀ Attribute ausschalten. { out_capstring(UEcap); # alle aus out_capstring(SEcap); out_capstring(MEcap); if (new_attr & A_SO) out_capstring(SOcap); # und selektiv wieder an if (new_attr & A_US) out_capstring(UScap); if (new_attr & A_BL) out_capstring(MBcap); if (new_attr & A_BD) out_capstring(MDcap); if (new_attr & A_DI) out_capstring(MHcap); if (new_attr & A_RV) out_capstring(MRcap); } else { # selektiv einschalten: if ((new_attr & A_SO) && !(old_attr & A_SO)) out_capstring(SOcap); if ((new_attr & A_US) && !(old_attr & A_US)) out_capstring(UScap); if ((new_attr & A_BL) && !(old_attr & A_BL)) out_capstring(MBcap); if ((new_attr & A_BD) && !(old_attr & A_BD)) out_capstring(MDcap); if ((new_attr & A_DI) && !(old_attr & A_DI)) out_capstring(MHcap); if ((new_attr & A_RV) && !(old_attr & A_RV)) out_capstring(MRcap); } term_attr = new_attr; } #endif #if WANT_CHARSET # Ausgabe-Zeichensatz des Terminals umschalten: local uintB term_charset; # aktueller Zeichensatz des Terminals # = curr->charsets[curr->curr_charset] #define ASCII 0 # Abkⁿrzung fⁿr den Zeichensatz 'B' local void change_charset (uintB new); local void change_charset(new) var reg1 uintB new; { if (term_charset==new) { return; } if (ISO2022) { out_char(ESC); out_char('('); out_char(new==ASCII ? 'B' : new); } /*)*/ term_charset = new; } # Charset Nr. n auf c schalten: local void choose_charset (uintB c, uintC n); local void choose_charset(c,n) var reg1 uintB c; var reg2 uintC n; { if (c=='B') { c = ASCII; } if (curr->charsets[n] == c) return; curr->charsets[n] = c; if (curr->curr_charset == n) # der aktuelle? { change_charset(c); } } # Charset Nr. n aktuell machen: local void set_curr_charset (uintC n); local void set_curr_charset(n) var reg1 uintC n; { if (curr->curr_charset == n) return; curr->curr_charset = n; change_charset(curr->charsets[n]); } #endif # Kosten des Neu-Anzeigens von Zeile y, Zeichen x1..x2-1 berechnen: # (0 <= y < rows, 0 <= x1 <= x2 <= cols) local uintC rewrite_cost (int y, int x1, int x2); local uintC rewrite_cost(y,x1,x2) var reg4 int y; var reg6 int x1; var reg5 int x2; { if (AM && (y==rows-1) && (x2==cols)) # rechte untere Ecke kann scrollen? { return EXPENSIVE; } {var reg1 int dx = x2-x1; if (dx==0) { return 0; } #if WANT_ATTR {var reg2 uintB* p = &curr->attr[y][x1]; var reg3 uintC count; dotimespC(count,dx, { if (!(*p++ == term_attr)) # Attribut-Wechsel n÷tig? { return EXPENSIVE; } }); } #endif #if WANT_CHARSET {var reg2 uintB* p = &curr->font[y][x1]; var reg3 uintC count; dotimespC(count,dx, { if (!(*p++ == term_charset)) # Font-Wechsel n÷tig? { return EXPENSIVE; } }); } #endif {var reg2 uintC cost = dx; #if WANT_INSERT if (curr->insert) { cost += EIcost + IMcost; } #endif return cost; }}} # Bewegt den Cursor von Position (y1,x1) an Position (y2,x2). # (x1,y1) = (-1,-1) falls aktuelle Position unbekannt. local void gofromto (int y1, int x1, int y2, int x2); local void gofromto(y1,x1,y2,x2) var reg10 int y1; var reg10 int x1; var reg10 int y2; var reg9 int x2; { if (x2==cols) # Cursor an den rechten Rand? { x2--; out_capstring(tgoto(CMcap,x2,y2)); return; } # Bleibt in der letzten Spalte if (x1==cols) # Cursor ist am rechten Rand? { out_capstring(tgoto(CMcap,x2,y2)); return; } # absolut adressieren {var reg4 int dy = y2-y1; var reg5 int dx = x2-x1; if ((dy==0) && (dx==0)) { return; } if ((y1==-1) || (x1==-1) || (y2 > curr->bot) || (y2 < curr->top)) { out_capstring(tgoto(CMcap,x2,y2)); return; } { var reg7 enum { MX_NONE, MX_LE, MX_RI, MX_RW, MX_CR } mx = MX_NONE; var reg8 enum { MY_NONE, MY_UP, MY_DO } my = MY_NONE; # M÷glichkeit 1: mit CMcap var reg6 uintC CMcost = cap_cost(tgoto(CMcap,x2,y2)); # M÷glichkeit 2: mit getrennten x- und y-Bewegungen: var reg1 uintC xycost = 0; if (dx > 0) { var reg2 uintC cost1 = rewrite_cost(y1,x1,x2); var reg3 uintC cost2 = dx * NDcost; if (cost1 < cost2) { mx = MX_RW; xycost += cost1; } else { mx = MX_RI; xycost += cost2; } } elif (dx < 0) { mx = MX_LE; xycost += (-dx) * BCcost; } if (!(dx==0)) { var reg2 uintC cost1 = CRcost + rewrite_cost(y1,0,x2); if (cost1 < xycost) { mx = MX_CR; xycost = cost1; } } if (dy > 0) { my = MY_DO; xycost += dy * DOcost; } elif (dy < 0) { my = MY_UP; xycost += (-dy) * UPcost; } if (xycost >= CMcost) { out_capstring(tgoto(CMcap,x2,y2)); return; } if (!(mx==MX_NONE)) { if ((mx==MX_LE) || (mx==MX_RI)) { var reg2 char* s; if (mx==MX_LE) { dx = -dx; s = BCcap; } else { s = NDcap; } do { out_capstring(s); } until (--dx == 0); } else { if (mx==MX_CR) { out_capstring(CRcap); x1=0; } # Hiervon wurden die Kosten mit rewrite_cost berechnet: if (x1<x2) { #if WANT_INSERT if (curr->insert) { set_insert_mode(FALSE); } #endif {var reg2 uintB* ptr = &curr->image[y1][x1]; var reg3 uintC count; dotimespC(count,x2-x1, { out_char(*ptr++); }); } #if WANT_INSERT if (curr->insert) { set_insert_mode(TRUE); } #endif } } } if (!(my==MY_NONE)) { var reg2 char* s; if (my==MY_UP) { dy = -dy; s = UPcap; } else { s = DOcap; } do { out_capstring(s); } until (--dy == 0); } }}} # Redisplay # lokale Variablen: local int last_x; local int last_y; # Eine Zeile neu anzeigen, die sich verΣndert haben kann: # nur ben÷tigte Parameter wirklich ⁿbergeben: #if WANT_ATTR && WANT_CHARSET #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,ofp,nsp,nap,nfp,y,x1,x2) #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,ofp,nsp,nap,nfp,y,x1,x2) #endif #if !WANT_ATTR && WANT_CHARSET #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,ofp,nsp,nfp,y,x1,x2) #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,ofp,nsp,nfp,y,x1,x2,oap,nap) #endif #if WANT_ATTR && !WANT_CHARSET #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,nsp,nap,y,x1,x2) #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,nsp,nap,y,x1,x2,ofp,nfp) #endif #if !WANT_ATTR && !WANT_CHARSET #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,nsp,y,x1,x2) #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,nsp,y,x1,x2,oap,ofp,nap,nfp) #endif #ifdef ANSI #undef RHparms #define RHparms RHargs # korrekt deklarieren local void redisplay_help RHparms (uintB* osp, uintB* oap, uintB* ofp, # old uintB* nsp, uintB* nap, uintB* nfp, # new int y, int x1, int x2); # Zeile y, von x1 bis x2-1 #endif local void redisplay_help RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) var reg6 uintB* osp; var reg4 uintB* oap; var reg5 uintB* ofp; var reg3 uintB* nsp; var reg1 uintB* nap; var reg2 uintB* nfp; var reg9 int y; var reg10 int x1; var reg10 int x2; { if (AM && (y == rows-1) && (x2 == cols)) { x2--; } { #if WANT_ATTR var reg8 uintB a = term_attr; # letztes Attribut #endif #if WANT_CHARSET var reg8 uintB f = term_charset; # letzter Font #endif var reg7 int x = x1; osp = &osp[x1]; nsp = &nsp[x1]; #if WANT_ATTR oap = &oap[x1]; nap = &nap[x1]; #endif #if WANT_CHARSET ofp = &ofp[x1]; nfp = &nfp[x1]; #endif while (x < x2) { if (!((*nsp==*osp) #if WANT_ATTR && (*nap==*oap) && (*nap==a) #endif #if WANT_CHARSET && (*nfp==*nap) && (*nfp==f) #endif ) ) { gofromto(last_y,last_x,y,x); #if WANT_ATTR a = *nap; if (!(a==term_attr)) { change_attr(a); } #endif #if WANT_CHARSET f = *nfp; if (!(f==term_charset)) { change_charset(f); } #endif out_char(*nsp); last_y = y; last_x = x+1; } x++; osp++; nsp++; #if WANT_ATTR oap++; nap++; #endif #if WANT_CHARSET ofp++; nfp++; #endif } }} #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR # Eine Zeile neu anzeigen: # nur ben÷tigte Parameter wirklich ⁿbergeben: #if WANT_ATTR && WANT_CHARSET #define RLargs(osp,oap,ofp,y,x1,x2) (osp,oap,ofp,y,x1,x2) #define RLparms(osp,oap,ofp,y,x1,x2) (osp,oap,ofp,y,x1,x2) #endif #if !WANT_ATTR && WANT_CHARSET #define RLargs(osp,oap,ofp,y,x1,x2) (osp,ofp,y,x1,x2) #define RLparms(osp,oap,ofp,y,x1,x2) (osp,ofp,y,x1,x2,oap) #endif #if WANT_ATTR && !WANT_CHARSET #define RLargs(osp,oap,ofp,y,x1,x2) (osp,oap,y,x1,x2) #define RLparms(osp,oap,ofp,y,x1,x2) (osp,oap,y,x1,x2,ofp) #endif #if !WANT_ATTR && !WANT_CHARSET #define RLargs(osp,oap,ofp,y,x1,x2) (osp,y,x1,x2) #define RLparms(osp,oap,ofp,y,x1,x2) (osp,y,x1,x2,oap,ofp) #endif #ifdef ANSI #undef RHparms #define RHparms RHargs # korrekt deklarieren local void redisplay_line RLparms (uintB* osp, uintB* oap, uintB* ofp, # old int y, int x1, int x2); # Zeile y, von x1 bis x2-1 #endif local void redisplay_line RLparms(osp,oap,ofp,y,x1,x2) var reg4 uintB* osp; var reg5 uintB* oap; var reg6 uintB* ofp; var reg1 int y; var reg2 int x1; var reg3 int x2; { #if WANT_INSERT if (curr->insert) { set_insert_mode(FALSE); } #endif #if WANT_ATTR {var reg4 uintB saved_attr = term_attr; change_attr(0); #endif #if WANT_CHARSET {var reg4 uintB saved_charset = term_charset; change_charset(ASCII); #endif last_y = y; last_x = x1; redisplay_help RHargs(osp, oap, ofp, curr->image[y],curr->attr[y],curr->font[y], y, x1,x2 ); #if WANT_CHARSET change_charset(saved_charset); } #endif #if WANT_ATTR change_attr(saved_attr); } #endif #if WANT_INSERT if (curr->insert) { set_insert_mode(TRUE); } #endif } #endif # Den ganzen Schirm neu anzeigen: local void redisplay (void); local void redisplay() { #if WANT_INSERT set_insert_mode(FALSE); #endif #if WANT_ATTR {var reg2 uintB saved_attr = term_attr; change_attr(0); #endif #if WANT_CHARSET {var reg2 uintB saved_charset = term_charset; change_charset(ASCII); #endif out_capstring(CLcap); last_x = 0; last_y = 0; {var reg1 uintC y = 0; while (y<rows) { redisplay_help RHargs(blank, null, null, # old curr->image[y],curr->attr[y],curr->font[y], # new y, # Zeile y 0,cols # alle Spalten ); y++; } } #if WANT_CHARSET change_charset(saved_charset); } #endif #if WANT_ATTR change_attr(saved_attr); } #endif #if WANT_INSERT if (curr->insert) { set_insert_mode(TRUE); } #endif gofromto(last_y,last_x,curr->y,curr->x); } # Weitere Cursor-Bewegungen: #if WANT_CURSOR_MOVE local void cursor_right (int n); local void cursor_right(n) var reg3 int n; { var reg2 int x = curr->x; if (x==cols) { return; } {var reg1 int new_x = x + n; if (new_x > cols) { new_x = cols; } gofromto(curr->y,x,curr->y,curr->x = new_x); }} local void cursor_left (int n); local void cursor_left(n) var reg3 int n; { var reg2 int x = curr->x; var reg1 int new_x = x - n; if (new_x < 0) { new_x = 0; } gofromto(curr->y,x,curr->y,curr->x = new_x); } local void cursor_up (int n); local void cursor_up(n) var reg3 int n; { var reg2 int y = curr->y; var reg1 int new_y = y - n; if (new_y < 0) { new_y = 0; } gofromto(y,curr->x,curr->y = new_y,curr->x); } local void cursor_down (int n); local void cursor_down(n) var reg3 int n; { var reg2 int y = curr->y; var reg1 int new_y = y + n; if (new_y >= rows) { new_y = rows-1; } gofromto(y,curr->x,curr->y = new_y,curr->x); } #endif # Backspace (Cursor um 1 nach links, innerhalb einer Zeile) #if WANT_CURSOR_BACKSPACE local void cursor_backspace (void); local void cursor_backspace() { if (curr->x > 0) { if (curr->x < cols) { if (BCcap) { out_capstring(BCcap); } else { gofromto(curr->y,curr->x,curr->y,curr->x - 1); } } curr->x = curr->x - 1; } } #endif # Return (Cursor an den Anfang der Zeile) #if WANT_CURSOR_RETURN local void cursor_return (void); local void cursor_return() { if (curr->x > 0) { out_capstring(CRcap); curr->x = 0; } } #endif # Hilfroutinen zum Scrollen: #if WANT_CURSOR_LINEFEED || WANT_DELETE_LINE local void scroll_up_help (uintB** pp, uintB filler); local void scroll_up_help(pp,filler) var reg1 uintB** pp; var reg3 uintB filler; { # pp[top..bot] um eins nach links verschieben, # pp[top] herausnehmen, l÷schen und als pp[bot] wieder einhΣngen: pp = &pp[curr->top]; {var reg2 uintC count; var reg4 uintB* tmp = *pp; dotimesC(count,curr->bot - curr->top, { pp[0] = pp[1]; pp++; } ); {var reg1 uintB* p = tmp; dotimesC(count,cols, { *p++ = filler; } ); } *pp = tmp; }} local void scroll_up (void); local void scroll_up() { scroll_up_help(curr->image,' '); #if WANT_ATTR scroll_up_help(curr->attr,0); #endif #if WANT_CHARSET scroll_up_help(curr->font,0); #endif } #endif #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE local void scroll_down_help (uintB** pp, uintB filler); local void scroll_down_help(pp,filler) var reg1 uintB** pp; var reg3 uintB filler; { # pp[top..bot] um eins nach rechts verschieben, # pp[top] herausnehmen, l÷schen und als pp[bot] wieder einhΣngen: pp = &pp[curr->bot]; {var reg2 uintC count; var reg4 uintB* tmp = *pp; dotimesC(count,curr->bot - curr->top, { pp[0] = pp[-1]; pp--; } ); {var reg1 uintB* p = tmp; dotimesC(count,cols, { *p++ = filler; } ); } *pp = tmp; }} local void scroll_down (void); local void scroll_down() { scroll_down_help(curr->image,' '); #if WANT_ATTR scroll_down_help(curr->attr,0); #endif #if WANT_CHARSET scroll_down_help(curr->font,0); #endif } #endif # Linefeed (Cursor um 1 nach unten): #if WANT_CURSOR_LINEFEED local void cursor_linefeed (void); local void cursor_linefeed() { if (curr->y == curr->bot) { scroll_up(); } elif (curr->y < rows-1) { curr->y++; } out_capstring(NLcap); } #endif # Reverse Linefeed (Cursor um 1 nach oben): #if WANT_CURSOR_REVLINEFEED local void cursor_revlinefeed (void); local void cursor_revlinefeed() { if (curr->y == curr->top) { scroll_down(); if (SRcap) { out_capstring(SRcap); } elif (ALcap) { gofromto(curr->top,curr->x,curr->top,0); # Cursor nach links out_capstring(ALcap); gofromto(curr->top,0,curr->top,curr->x); # Cursor wieder zurⁿck } else { redisplay(); } } elif (curr->y > 0) { cursor_up(1); } } #endif # L÷sch-Operationen: # Stⁿck einer Zeile l÷schen: #if WANT_CLEAR_SCREEN || WANT_CLEAR_FROM_BOS local void cleared_linepart (int y, int x1, int x2); local void cleared_linepart(y,x1,x2) var reg5 int y; var reg4 int x1; var reg6 int x2; { var reg3 int n = x2-x1; if (n>0) { {var reg1 uintB* sp = &curr->image[y][x1]; var reg2 uintC count; dotimespC(count,n, { *sp++ = ' '; } ); } #if WANT_ATTR {var reg1 uintB* ap = &curr->attr[y][x1]; var reg2 uintC count; dotimespC(count,n, { *ap++ = 0; } ); } #endif #if WANT_CHARSET {var reg1 uintB* fp = &curr->font[y][x1]; var reg2 uintC count; dotimespC(count,n, { *fp++ = 0; } ); } #endif } } #endif # Bildschirm l÷schen: #if WANT_CLEAR_SCREEN local void clear_screen (void); local void clear_screen() { out_capstring(CLcap); {var reg3 uintC y = 0; while (y<rows) { cleared_linepart(y,0,cols); y++; } }} #endif # Stⁿck einer Zeile l÷schen: #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL local void clear_linepart (int y, int x1, int x2); local void clear_linepart(y,x1,x2) var reg5 int y; var reg4 int x1; var reg6 int x2; { var reg3 int n = x2-x1; if (n>0) { {var reg1 uintB* sp = &curr->image[y][x1]; var reg2 uintC count; dotimesC(count,n, { *sp++ = ' '; } ); } #if WANT_ATTR {var reg1 uintB* ap = &curr->attr[y][x1]; var reg2 uintC count; dotimesC(count,n, { *ap++ = 0; } ); } #endif #if WANT_CHARSET {var reg1 uintB* fp = &curr->font[y][x1]; var reg2 uintC count; dotimesC(count,n, { *fp++ = 0; } ); } #endif if ((x2==cols) && CEcap) { gofromto(curr->y,curr->x,y,x1); curr->y = y; curr->x = x1; out_capstring(CEcap); } else { if ((x2==cols) && (y==rows-1) && AM) { n--; } if (n>0) { #if WANT_ATTR {var reg7 uintB saved_attr = term_attr; change_attr(0); #endif #if WANT_CHARSET {var reg7 uintB saved_charset = term_charset; change_charset(ASCII); #endif #if WANT_INSERT if (curr->insert) { set_insert_mode(FALSE); } #endif gofromto(curr->y,curr->x,y,x1); {var reg1 uintC count; dotimespC(count,n, { out_char(' '); } ); } curr->y = y; curr->x = x1+n; #if WANT_CHARSET change_charset(saved_charset); } #endif #if WANT_ATTR change_attr(saved_attr); } #endif #if WANT_INSERT if (curr->insert) { set_insert_mode(TRUE); } #endif } } } } #endif # Bildschirm bis zum Cursor (ausschlie▀lich) l÷schen: #if WANT_CLEAR_FROM_BOS local void clear_from_BOS (void); local void clear_from_BOS() { var reg2 int y0 = curr->y; var reg3 int x0 = curr->x; var reg1 int y = 0; while (y<y0) { clear_linepart(y,0,cols); y++; } clear_linepart(y0,0,x0); gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0; } #endif # Bildschirm ab Cursor (einschlie▀lich) l÷schen: #if WANT_CLEAR_TO_EOS local void clear_to_EOS (void); local void clear_to_EOS() { var reg2 int y0 = curr->y; var reg3 int x0 = curr->x; if (CDcap) { out_capstring(CDcap); cleared_linepart(y0,x0,cols); {var reg1 int y = y0; while (++y < rows) { cleared_linepart(y,0,cols); } }} else { clear_linepart(y0,x0,cols); {var reg1 int y = y0; while (++y < rows) { clear_linepart(y,0,cols); } }} gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0; } #endif # Cursorzeile l÷schen: #if WANT_CLEAR_LINE local void clear_line (void); local void clear_line() { var reg1 int y0 = curr->y; var reg2 int x0 = curr->x; clear_linepart(y0,0,cols); gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0; } #endif # Cursorzeile bis Cursor (ausschlie▀lich) l÷schen: #if WANT_CLEAR_FROM_BOL local void clear_from_BOL (void); local void clear_from_BOL() { var reg1 int y0 = curr->y; var reg2 int x0 = curr->x; clear_linepart(y0,0,x0); gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0; } #endif # Cursorzeile ab Cursor (einschlie▀lich) l÷schen: #if WANT_CLEAR_TO_EOL local void clear_to_EOL (void); local void clear_to_EOL() { var reg1 int y0 = curr->y; var reg2 int x0 = curr->x; clear_linepart(y0,x0,cols); gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0; } #endif # Einfⁿge-Operationen: # alter Zeileninhalt: #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR local uintB* old_image_y; #if WANT_ATTR local uintB* old_attr_y; #endif #if WANT_CHARSET local uintB* old_font_y; #endif local void save_line_old (int y); local void save_line_old(y) var reg4 int y; { {var reg1 uintB* p1 = &curr->image[y][0]; var reg2 uintB* p2 = &old_image_y[0]; var reg3 uintC count; dotimesC(count,cols, { *p2++ = *p1++; } ); } #if WANT_ATTR {var reg1 uintB* p1 = &curr->attr[y][0]; var reg2 uintB* p2 = &old_attr_y[0]; var reg3 uintC count; dotimesC(count,cols, { *p2++ = *p1++; } ); } #endif #if WANT_CHARSET {var reg1 uintB* p1 = &curr->font[y][0]; var reg2 uintB* p2 = &old_font_y[0]; var reg3 uintC count; dotimesC(count,cols, { *p2++ = *p1++; } ); } #endif } #endif # Ein Zeichen einfⁿgen: #if WANT_INSERT_1CHAR local void insert_1char (uintB c); local void insert_1char(c) var reg6 uintB c; { var reg4 int y = curr->y; var reg5 int x = curr->x; if (x==cols) { x--; } # nicht ⁿber den rechten Rand schreiben! if (ICcap || IMcap) { curr->image[y][x] = c; #if WANT_ATTR curr->attr[y][x] = curr->curr_attr; #endif #if WANT_CHARSET curr->font[y][x] = curr->charsets[curr->curr_charset]; # = term_charset #endif #if WANT_INSERT if (!curr->insert) #endif { set_insert_mode(TRUE); } out_capstring(ICcap); out_char(c); #if WANT_INSERT if (!curr->insert) #endif { set_insert_mode(FALSE); } curr->x = x+1; } else { # alten Zeileninhalt retten: save_line_old(y); # neuen Zeileninhalt bilden: {var reg1 uintB* p1 = &curr->image[y][x]; var reg2 uintB* p2 = &old_image[x]; var reg3 uintC count; *p1++ = c; dotimesC(count,cols-1-x, { *p1++ = *p2++; } ); } #if WANT_ATTR {var reg1 uintB* p1 = &curr->attr[y][x]; var reg2 uintB* p2 = &old_attr[x]; var reg3 uintC count; *p1++ = curr->curr_attr; dotimesC(count,cols-1-x, { *p1++ = *p2++; } ); } #endif #if WANT_CHARSET {var reg1 uintB* p1 = &curr->font[y][x]; var reg2 uintB* p2 = &old_font[x]; var reg3 uintC count; *p1++ = term_charset; # = curr->charsets[curr->curr_charset] dotimesC(count,cols-1-x, { *p1++ = *p2++; } ); } #endif # Zeile anzeigen: redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols); x++; gofromto(last_y,last_x,y,x); curr->x = x; } } #endif # Platz fⁿr n Zeichen machen: #if WANT_INSERT_CHAR local void insert_char (uintC n); local void insert_char(n) var reg6 uintC n; { var reg5 int y = curr->y; var reg4 int x = curr->x; if (n > cols-x) { n = cols-x; } if (n==0) return; # alten Zeileninhalt retten: save_line_old(y); # neuen Zeileninhalt bilden: {var reg1 uintB* p1 = &curr->image[y][x]; var reg2 uintB* p2 = &old_image[x]; var reg3 uintC count; dotimespC(count,n, { *p1++ = ' '; } ); dotimesC(count,cols-x-n, { *p1++ = *p2++; } ); } #if WANT_ATTR {var reg1 uintB* p1 = &curr->attr[y][x]; var reg2 uintB* p2 = &old_attr[x]; var reg3 uintC count; dotimespC(count,n, { *p1++ = 0; } ); dotimesC(count,cols-x-n, { *p1++ = *p2++; } ); } #endif #if WANT_CHARSET {var reg1 uintB* p1 = &curr->font[y][x]; var reg2 uintB* p2 = &old_font[x]; var reg3 uintC count; dotimespC(count,n, { *p1++ = 0; } ); dotimesC(count,cols-x-n, { *p1++ = *p2++; } ); } #endif if (CICcap && (n > 1)) { #if WANT_INSERT if (curr->insert) { set_insert_mode(FALSE); } #endif out_cap1string(CICcap,n); {var reg1 uintC count; dotimespC(count,n, { out_char(' '); } ); } #if WANT_INSERT if (curr->insert) { set_insert_mode(TRUE); } #endif gofromto(y,x+n,y,x); } elif (ICcap || IMcap) { #if WANT_INSERT if (!curr->insert) #endif { set_insert_mode(TRUE); } {var reg1 uintC count; dotimespC(count,n, { out_capstring(ICcap); out_char(' '); } ); } #if WANT_INSERT if (!curr->insert) #endif { set_insert_mode(FALSE); } gofromto(y,x+n,y,x); } else { redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols); gofromto(last_y,last_x,y,x); } } #endif # Zeilen einfⁿgen: #if WANT_INSERT_LINE local void insert_line (uintC n); local void insert_line(n) var reg2 uintC n; { if (n > curr->bot - curr->y + 1) { n = curr->bot - curr->y + 1; } if (n==0) return; {var reg3 int oldtop = curr->top; curr->top = curr->y; {var reg1 uintC count; dotimespC(count,n, { scroll_down(); } ); } if (ALcap || CALcap) { gofromto(curr->y,curr->x,curr->y,0); # an den Zeilenanfang if ((CALcap && (n>1)) || !ALcap) { out_cap1string(CALcap,n); } else { var reg1 uintC count; dotimespC(count,n, { out_capstring(ALcap); } ); } gofromto(curr->y,0,curr->y,curr->x); } elif (CScap && SRcap) { out_capstring(tgoto(CScap,curr->bot,curr->top)); gofromto(-1,-1,curr->top,0); {var reg1 uintC count; dotimespC(count,n, { out_capstring(SRcap); } ); } out_capstring(tgoto(CScap,curr->bot,oldtop)); gofromto(-1,-1,curr->y,curr->x); } else { redisplay(); } curr->top = oldtop; }} #endif # L÷sch-Operationen: # Characters l÷schen: #if WANT_DELETE_CHAR local void delete_char (uintC n); local void delete_char(n) var reg6 uintC n; { var reg5 int y = curr->y; var reg4 int x = curr->x; if (n > cols-x) { n = cols-x; } if (n==0) return; # alten Zeileninhalt retten: save_line_old(y); # neuen Zeileninhalt bilden: {var reg1 uintB* p1 = &curr->image[y][x]; var reg2 uintB* p2 = &old_image[x]; var reg3 uintC count; dotimesC(count,cols-x-n, { *p1++ = *p2++; } ); dotimespC(count,n, { *p1++ = ' '; } ); } #if WANT_ATTR {var reg1 uintB* p1 = &curr->attr[y][x]; var reg2 uintB* p2 = &old_attr[x]; var reg3 uintC count; dotimesC(count,cols-x-n, { *p1++ = *p2++; } ); dotimespC(count,n, { *p1++ = 0; } ); } #endif #if WANT_CHARSET {var reg1 uintB* p1 = &curr->font[y][x]; var reg2 uintB* p2 = &old_font[x]; var reg3 uintC count; dotimesC(count,cols-x-n, { *p1++ = *p2++; } ); dotimespC(count,n, { *p1++ = 0; } ); } #endif if (CDCcap && ((n>1) || !DCcap)) { out_cap1string(CDCcap,n); } elif (DCcap) { var reg1 uintC count; dotimespC(count,n, { out_capstring(DCcap); } ); } else { redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols); gofromto(last_y,last_x,y,x); } } #endif # Zeilen l÷schen: #if WANT_DELETE_LINE local void delete_line (uintC n); local void delete_line(n) var reg2 uintC n; { if (n > curr->bot - curr->y + 1) { n = curr->bot - curr->y + 1; } if (n==0) return; {var reg3 int oldtop = curr->top; curr->top = curr->y; {var reg1 uintC count; dotimespC(count,n, { scroll_up(); } ); } if (DLcap || CDLcap) { gofromto(curr->y,curr->x,curr->y,0); # an den Zeilenanfang if ((CDLcap && (n>1)) || !DLcap) { out_cap1string(CDLcap,n); } else { var reg1 uintC count; dotimespC(count,n, { out_capstring(DLcap); } ); } gofromto(curr->y,0,curr->y,curr->x); } elif (CScap) { out_capstring(tgoto(CScap,curr->bot,curr->top)); gofromto(-1,-1,curr->bot,0); {var reg1 uintC count; dotimespC(count,n, { out_capstring(SFcap); } ); } out_capstring(tgoto(CScap,curr->bot,oldtop)); gofromto(-1,-1,curr->y,curr->x); } else { redisplay(); } curr->top = oldtop; }} #endif # Ein Zeichen ausgeben: #if WANT_OUTPUT_1CHAR local void output_1char (uintB c); local void output_1char(c) var reg3 uintB c; { #if WANT_INSERT if (curr->insert) { insert_1char(c); } else #endif { var reg1 int y = curr->y; var reg2 int x = curr->x; if (x==cols) { x--; } # nicht ⁿber den rechten Rand schreiben! curr->image[y][x] = c; #if WANT_ATTR curr->attr[y][x] = curr->curr_attr; #endif #if WANT_CHARSET curr->font[y][x] = curr->charsets[curr->curr_charset]; # = term_charset #endif x++; if (!(AM && (x==cols) && (curr->y==curr->bot))) # rechte untere Ecke evtl. freilassen { out_char(c); } # Zeichen ausgeben curr->x = x; # Cursor rⁿckt um eins weiter if (x==cols) # au▀er wenn er schon ganz rechts war { gofromto(-1,-1,curr->y,curr->x); } } } #endif #if WANT_SAVE # gespeicherte Cursor-Position: local void save_cursor (void); local void save_cursor() { curr->saved_x = curr->x; curr->saved_y = curr->y; #if WANT_ATTR curr->saved_curr_attr = curr->curr_attr; #endif #if WANT_CHARSET curr->saved_curr_charset = curr->curr_charset; {var reg1 uintC i = 0; while (i<charset_count) { curr->saved_charsets[i] = curr->charsets[i]; i++; } } #endif curr->saved = TRUE; } local void restore_cursor (void); local void restore_cursor() { if (curr->saved) { gofromto(curr->y,curr->x,curr->saved_y,curr->saved_x); curr->y = curr->saved_y; curr->x = curr->saved_x; #if WANT_ATTR curr->curr_attr = curr->saved_curr_attr; change_attr(curr->curr_attr); #endif #if WANT_CHARSET curr->curr_charset = curr->saved_curr_charset; {var reg1 uintC i = 0; while (i<charset_count) { curr->charsets[i] = curr->saved_charsets[i]; i++; } } change_charset(curr->charsets[curr->curr_charset]); #endif } } #endif # Initialisiert das Terminal. # Liefert NULL falls OK, einen Fehlerstring sonst. local boolean term_initialized = FALSE; local char* init_term (void); local char* init_term() { var char tbuf[4096]; # interner Buffer fⁿr die Termcap-Routinen if (term_initialized) { return NULL; } # schon initialisiert -> OK # Terminal-Typ abfragen: begin_system_call(); { var reg1 char* s = getenv("TERM"); if (s==NULL) { end_system_call(); return (DEUTSCH ? "Environment enthΣlt keine TERM-Variable." : ENGLISH ? "environment has no TERM variable" : FRANCAIS ? "L'environnment ne contient pas de variable TERM." : "" ); } if (!(tgetent(tbuf,s)==1)) { end_system_call(); pushSTACK(asciz_to_string(s)); return (DEUTSCH ? "TERMCAP kennt Terminal-Typ ~ nicht." : ENGLISH ? "terminal type ~ unknown to termcap" : FRANCAIS ? "TERMCAP ne connait pas le type d'Θcran ~." : "" ); } } { var reg1 int i = tgetnum("co"); cols = (i>0 ? i : 80); } { var reg1 int i = tgetnum("li"); rows = (i>0 ? i : 24); } #ifdef EMUNIX # Obwohl das eigentlich unsauber ist, holen wir uns die aktuelle Bildschirm- # gr÷▀e mit _scrsize(). #ifdef EMUNIX_OLD_8d if (!(_osmode == DOS_MODE)) #endif { var int scrsize[2]; _scrsize(&!scrsize); if (scrsize[0] > 0) { cols = scrsize[0]; } if (scrsize[1] > 0) { rows = scrsize[1]; } } #endif if (tgetflag("hc")) { end_system_call(); return (DEUTSCH ? "Unzureichendes Terminal: Hardcopy-Terminal." : ENGLISH ? "insufficient terminal: hardcopy terminal" : FRANCAIS ? "Terminal insuffisant : imprimante au lieu d'Θcran." : "" ); } if (tgetflag("os")) { end_system_call(); return (DEUTSCH ? "Unzureichendes Terminal: Kann Ausgegebenes nicht mehr l÷schen." : ENGLISH ? "insufficient terminal: overstrikes, cannot clear output" : FRANCAIS ? "Terminal insuffisant : ne peut rien effacer." : "" ); } if (tgetflag("ns")) { end_system_call(); return (DEUTSCH ? "Unzureichendes Terminal: Kann nicht scrollen." : ENGLISH ? "insufficient terminal: cannot scroll" : FRANCAIS ? "Terminal insuffisant : pas de dΘfilement." : "" ); } if (!(CLcap = tgetstr("cl",&tp))) { # K÷nnte CLcap = "\n\n\n\n"; als Default nehmen ('weird HPs') end_system_call(); return (DEUTSCH ? "Unzureichendes Terminal: Kann Bildschirm nicht l÷schen." : ENGLISH ? "insufficient terminal: cannot clear screen" : FRANCAIS ? "Terminal insuffisant : ne peut pas effacer l'Θcran." : "" ); } if (!(CMcap = tgetstr("cm",&tp))) { end_system_call(); return (DEUTSCH ? "Unzureichendes Terminal: Kann Cursor nicht willkⁿrlich positionieren." : ENGLISH ? "insufficient terminal: cannot position cursor randomly" : FRANCAIS ? "Terminal insuffisant : ne peut pas placer le curseur n'importe o∙." : "" ); } # Capabilities initialisieren: AM = tgetflag("am"); if (tgetflag("LP")) { AM = FALSE; } TIcap = tgetstr("ti",&tp); TEcap = tgetstr("te",&tp); # BLcap = tgetstr("bl",&tp); if (!BLcap) BLcap = "\007"; # VBcap = tgetstr("vb",&tp); BCcap = tgetstr("bc",&tp); if (!BCcap) BCcap = (tgetflag("bs") ? "\b" : tgetstr("le",&tp)); CRcap = tgetstr("cr",&tp); if (!CRcap) CRcap = "\r"; NLcap = tgetstr("nl",&tp); if (!NLcap) NLcap = "\n"; DOcap = tgetstr("do",&tp); if (!DOcap) DOcap = NLcap; UPcap = tgetstr("up",&tp); NDcap = tgetstr("nd",&tp); IScap = tgetstr("is",&tp); #if WANT_ATTR if ((tgetnum("sg") > 0) || (tgetnum("ug") > 0)) # Beim Umschalten in Standout-Mode oder beim Umschalten in den # Underline-Mode gibt's Leerstellen -> unbrauchbar! { SOcap = NULL; SEcap = NULL; UScap = NULL; UEcap = NULL; MBcap = NULL; MDcap = NULL; MHcap = NULL; MRcap = NULL; MEcap = NULL; } else { SOcap = tgetstr("so",&tp); SEcap = tgetstr("se",&tp); UScap = tgetstr("us",&tp); UEcap = tgetstr("ue",&tp); if (!UScap && !UEcap) # kein Underline? { UScap = SOcap; UEcap = SEcap; } # nimm Standout als Ersatz MBcap = tgetstr("mb",&tp); MDcap = tgetstr("md",&tp); MHcap = tgetstr("mh",&tp); MRcap = tgetstr("mr",&tp); MEcap = tgetstr("me",&tp); # Does ME also reverse the effect of SO and/or US? This is not # clearly specified by the termcap manual. # Anyway, we should at least look whether ME/SE/UE are equal: if (UEcap && SEcap && asciz_equal(UEcap,SEcap)) { UEcap = NULL; } if (UEcap && MEcap && asciz_equal(UEcap,MEcap)) { UEcap = NULL; } if (SEcap && MEcap && asciz_equal(SEcap,MEcap)) { SEcap = NULL; } # tgetstr("uc",&tp) liefert ein underline-character. Dann jeweils # in redisplay_help() und output_1char() nach dem out_char() noch # backspace() und out_capstring(UCcap) durchfⁿhren. # Fⁿr welche Terminals lohnt sich das?? } #endif #if WANT_CHARSET ISO2022 = tgetflag("G0"); #endif CScap = tgetstr("cs",&tp); #if WANT_DELETE_LINE SFcap = tgetstr("sf",&tp); if (!SFcap) SFcap = NLcap; #endif #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE SRcap = tgetstr("sr",&tp); #endif #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL CEcap = tgetstr("ce",&tp); #endif #if WANT_CLEAR_TO_EOS CDcap = tgetstr("cd",&tp); #endif #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE ALcap = tgetstr("al",&tp); #endif #if WANT_DELETE_LINE DLcap = tgetstr("dl",&tp); #endif #if WANT_DELETE_CHAR DCcap = tgetstr("dc",&tp); #endif #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR ICcap = tgetstr("ic",&tp); #endif #if WANT_INSERT_CHAR CICcap = tgetstr("IC",&tp); #endif #if WANT_INSERT_LINE CALcap = tgetstr("AL",&tp); #endif #if WANT_DELETE_CHAR CDCcap = tgetstr("DC",&tp); #endif #if WANT_DELETE_LINE CDLcap = tgetstr("DL",&tp); #endif IMcap = tgetstr("im",&tp); EIcap = tgetstr("ei",&tp); if (tgetflag ("in")) # Insert-Modus unbrauchbar? { IMcap = NULL; EIcap = NULL; #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR ICcap = NULL; #endif #if WANT_INSERT_CHAR CICcap = NULL; #endif } if (IMcap && (IMcap[0]==0)) { IMcap = NULL; } # IMcap leer? if (EIcap && (EIcap[0]==0)) { EIcap = NULL; } # EIcap leer? #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR if (ICcap && (ICcap[0]==0)) { ICcap = NULL; } # ICcap leer? #endif # Kosten der Capabilities berechnen: IMcost = cap_cost(IMcap); EIcost = cap_cost(EIcap); BCcost = cap_cost(BCcap); NDcost = cap_cost(NDcap); DOcost = cap_cost(DOcap); #ifndef NL_HACK # Falls DOcap ein LF ausgibt, ist nicht sicher, ob dies auch als solches # (und nicht als CR/LF) beim Terminal ankommt. In diesem Fall erklΣren # wir DOcap fⁿr unbrauchbar. Das erspart uns den NL_HACK. if (DOcap[0]=='\n') { DOcost = EXPENSIVE; } #endif UPcost = cap_cost(UPcap); CRcost = cap_cost(CRcap); # Hilfs-Datenstrukturen bereitstellen: {var reg1 uintB* ptr = malloc(cols*sizeof(uintB)); var reg2 uintC count; blank = ptr; dotimespC(count,cols, { *ptr++ = ' '; } ); } #if WANT_ATTR || WANT_CHARSET {var reg1 uintB* ptr = malloc(cols*sizeof(uintB)); var reg2 uintC count; null = ptr; dotimespC(count,cols, { *ptr++ = 0; } ); } #endif #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR old_image_y = malloc(cols*sizeof(uintB)); #if WANT_ATTR old_attr_y = malloc(cols*sizeof(uintB)); #endif #if WANT_CHARSET old_font_y = malloc(cols*sizeof(uintB)); #endif #endif end_system_call(); term_initialized = TRUE; return NULL; } #ifdef NL_HACK # Wenn NLcap = "\n" ist, mⁿssen wir ein "stty -onlcr" durchfⁿhren, weil sonst # das NL vom Terminal-Driver in ein CR umgewandelt wird, bevor es beim # Terminal ankommt. local void term_nlraw (void); local void term_nlunraw (void); #if defined(UNIX_TERM_TERMIOS) static unsigned long old_c_oflag = 0; local void term_nlraw() { var struct termios oldtermio; if (!( tcgetattr(stdout_handle,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } old_c_oflag = oldtermio.c_oflag; oldtermio.c_oflag &= ~ONLCR; if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } local void term_nlunraw() { if (old_c_oflag & ONLCR) { var struct termios oldtermio; if (!( tcgetattr(stdout_handle,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } oldtermio.c_oflag |= ONLCR; if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } } #elif defined(UNIX_TERM_TERMIO) || defined(EMUNIX) static unsigned long old_c_oflag = 0; local void term_nlraw() { var struct termio oldtermio; if (!( ioctl(stdout_handle,TCGETA,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } old_c_oflag = oldtermio.c_oflag; oldtermio.c_oflag &= ~ONLCR; if (!( ioctl(stdout_handle,TCSETAF,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } local void term_nlunraw() { if (old_c_oflag & ONLCR) { var struct termio oldtermio; if (!( ioctl(stdout_handle,TCGETA,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } oldtermio.c_oflag |= ONLCR; if (!( ioctl(stdout_handle,TCSETAF,&oldtermio) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } } #elif defined(UNIX_TERM_SGTTY) static unsigned long old_sg_flags = 0; local void term_nlraw() { var struct sgttyb oldsgttyb; if (!( ioctl(stdout_handle,TIOCGETP,&oldsgttyb) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } old_sg_flags = oldsgttyb.sg_flags; oldsgttyb.sg_flags &= ~CRMOD; if (!( ioctl(stdout_handle,TIOCSETP,&oldsgttyb) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } local void term_nlunraw() { if (old_sg_flags & CRMOD) { var struct sgttyb oldsgttyb; if (!( ioctl(stdout_handle,TIOCGETP,&oldsgttyb) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } oldsgttyb.sg_flags |= CRMOD; if (!( ioctl(stdout_handle,TIOCSETP,&oldsgttyb) ==0)) { if (!(errno==ENOTTY)) { OS_error(); } } } } #endif #endif # NL_HACK # Beginn des Arbeitens mit diesem Paket: local void start_term (void); local void start_term() { #ifdef NL_HACK if (NLcap[0] == '\n') { term_nlraw(); } #endif out_capstring (IScap); out_capstring (TIcap); } # Ende des Arbeitens mit diesem Paket: local void end_term (void); local void end_term() { out_capstring (TEcap); out_capstring (IScap); #ifdef MSDOS # wie testet man auf Farb-ANSI-Terminal?? # Auf ANSI-Terminals mit mehreren Farben: TEcap setzt die Farben zurⁿck. out_capstring(CLcap); # Bildschirm l÷schen, diesmal in der normalen Farbe #endif #ifdef NL_HACK if (NLcap[0] == '\n') { term_nlunraw(); } #endif } # Initialisiert das Window curr. local void init_curr (void); local void init_curr() { {var reg1 uintB** ptr = malloc(rows*sizeof(uintB*)); var reg2 uintC count; curr->image = ptr; dotimespC(count,rows, { *ptr++ = malloc(cols*sizeof(uintB)); } ); } #if WANT_ATTR {var reg1 uintB** ptr = malloc(rows*sizeof(uintB*)); var reg2 uintC count; curr->attr = ptr; dotimespC(count,rows, { *ptr++ = malloc(cols*sizeof(uintB)); } ); } # Attribute ausschalten: out_capstring(UEcap); # alle aus out_capstring(SEcap); out_capstring(MEcap); term_attr = curr->curr_attr = 0; #endif #if WANT_CHARSET {var reg1 uintB** ptr = malloc(rows*sizeof(uintB*)); var reg2 uintC count; curr->font = ptr; dotimespC(count,rows, { *ptr++ = malloc(cols*sizeof(uintB)); } ); } {var reg1 uintC i = 0; while (i<charset_count) { curr->charsets[i] = ASCII; i++; } } curr->curr_charset = 0; if (ISO2022) { out_char(ESC); out_char('('); out_char('B'); } /*)*/ term_charset = ASCII; #endif curr->x = 0; curr->y = 0; curr->top = 0; curr->bot = rows-1; #if WANT_INSERT curr->insert = FALSE; #endif #if WANT_SAVE curr->saved = FALSE; #endif if (CScap) { out_capstring(tgoto(CScap,curr->bot,curr->top)); } clear_screen(); } # ------------------------------------------------------------------------------ # UP: Ein Zeichen auf einen Window-Stream ausgeben. # wr_ch_window(&stream,ch); # > stream: Window-Stream # > ch: auszugebendes Zeichen local void wr_ch_window (object* stream_, object ch); local void wr_ch_window(stream_,ch) var reg2 object* stream_; var reg3 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var reg1 uintB c = char_code(ch); # Code des Zeichens if (graphic_char_p(c)) { if (curr->x == cols) { cursor_return(); cursor_linefeed(); } # Wrap! output_1char(c); } elif (c == NL) { cursor_return(); cursor_linefeed(); } elif (c == BS) { var reg4 int x0 = curr->x; if (x0>0) { var reg5 int y0 = curr->y; clear_linepart(y0,x0-1,x0); gofromto(curr->y,curr->x,y0,x0-1); curr->y = y0; curr->x = x0-1; } } }} LISPFUNN(make_window,0) { var reg2 object stream = allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1); # Flags: nur WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unm÷glich s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy_nogc); #endif # Initialisieren: {var reg3 char* ergebnis = init_term(); if (!(ergebnis==NULL)) { fehler(error,ergebnis); } } start_term(); init_curr(); value1 = stream; mv_count=1; } # Schlie▀t einen Window-Stream. local void close_window (object stream); local void close_window(stream) var reg1 object stream; { end_term(); } LISPFUNN(window_size,1) { check_window_stream(popSTACK()); value1 = fixnum(rows); # Variablen rows,cols abfragen value2 = fixnum(cols); mv_count=2; } LISPFUNN(window_cursor_position,1) { check_window_stream(popSTACK()); value1 = fixnum(curr->y); value2 = fixnum(curr->x); mv_count=2; } LISPFUNN(set_window_cursor_position,3) { check_window_stream(STACK_2); {var reg1 uintL line = posfixnum_to_L(STACK_1); var reg2 uintL column = posfixnum_to_L(STACK_0); if ((line < rows) && (column < cols)) { gofromto(curr->y,curr->x,line,column); # Cursor positionieren curr->y = line; curr->x = column; } value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3); }} LISPFUNN(clear_window,1) { check_window_stream(popSTACK()); clear_screen(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eot,1) { check_window_stream(popSTACK()); clear_to_EOS(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eol,1) { check_window_stream(popSTACK()); clear_to_EOL(); value1 = NIL; mv_count=0; } LISPFUNN(delete_window_line,1) { check_window_stream(popSTACK()); delete_line(1); value1 = NIL; mv_count=0; } LISPFUNN(insert_window_line,1) { check_window_stream(popSTACK()); insert_line(1); value1 = NIL; mv_count=0; } LISPFUNN(highlight_on,1) { check_window_stream(popSTACK()); change_attr(curr->curr_attr |= A_US); value1 = NIL; mv_count=0; } LISPFUNN(highlight_off,1) { check_window_stream(popSTACK()); change_attr(curr->curr_attr &= ~A_US); value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_on,1) { check_window_stream(popSTACK()); # Cursor ist permanent an! value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_off,1) { check_window_stream(popSTACK()); # geht nicht, da Cursor permanent an! value1 = NIL; mv_count=0; } #endif # UNIX || EMUNIX_PORTABEL || RISCOS #if defined(UNIX) && 0 # Normales CURSES-Paket, wir benutzen nur stdscr. #undef BS #undef CR #undef NL #include <curses.h> #undef OK #define CR 13 #define NL 10 # UP: Ein Zeichen auf einen Window-Stream ausgeben. # wr_ch_window(&stream,ch); # > stream: Window-Stream # > ch: auszugebendes Zeichen local void wr_ch_window (object* stream_, object ch); local void wr_ch_window(stream_,ch) var reg2 object* stream_; var reg1 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var reg1 uintB c = char_code(ch); # Code des Zeichens begin_system_call(); if (graphic_char_p(c)) # nur druckbare Zeichen auf den Bildschirm lassen { addch(c); } elif (c == NL) # NL in CR/LF umwandeln { addch(CR); addch(LF); } else # etwas ausgeben, damit die Cursorposition stimmt { addch('?'); } end_system_call(); }} LISPFUNN(make_window,0) { var reg2 object stream = allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1); # Flags: nur WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unm÷glich s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy_nogc); #endif begin_system_call(); initscr(); # Curses initialisieren # Was ist, wenn das abstⁿrzt?? newterm() benutzen?? cbreak(); noecho(); # Input nicht zeilengebuffert, ohne Echo #if defined(SUN3) || defined(SUN4) keypad(stdscr,TRUE); # Funktionstasten-Erkennung einschalten #endif end_system_call(); value1 = stream; mv_count=1; } # Schlie▀t einen Window-Stream. local void close_window (object stream); local void close_window(stream) var reg1 object stream; { begin_system_call(); nocbreak(); echo(); # Input wieder zeilengebuffert, mit Echo #if defined(SUN3) || defined(SUN4) keypad(stdscr,FALSE); # Funktionstasten-Erkennung wieder ausschalten #endif endwin(); # Curses abschalten end_system_call(); } LISPFUNN(window_size,1) { check_window_stream(popSTACK()); value1 = fixnum(LINES); # Curses-Variablen LINES, COLS abfragen value2 = fixnum(COLS); mv_count=2; } LISPFUNN(window_cursor_position,1) { check_window_stream(popSTACK()); {var reg1 int y; var reg2 int x; begin_system_call(); getyx(stdscr,y,x); # (y,x) := cursor position end_system_call(); value1 = fixnum(y); value2 = fixnum(x); mv_count=2; }} LISPFUNN(set_window_cursor_position,3) { check_window_stream(STACK_2); {var reg1 uintL line = posfixnum_to_L(STACK_1); var reg2 uintL column = posfixnum_to_L(STACK_0); if ((line < LINES) && (column < COLS)) { begin_system_call(); move(line,column); refresh(); # Cursor positionieren end_system_call(); } value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3); }} LISPFUNN(clear_window,1) { check_window_stream(popSTACK()); begin_system_call(); clear(); refresh(); end_system_call(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eot,1) { check_window_stream(popSTACK()); begin_system_call(); clrtobot(); refresh(); end_system_call(); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eol,1) { check_window_stream(popSTACK()); begin_system_call(); clrtoeol(); refresh(); end_system_call(); value1 = NIL; mv_count=0; } LISPFUNN(delete_window_line,1) { check_window_stream(popSTACK()); begin_system_call(); deleteln(); refresh(); end_system_call(); value1 = NIL; mv_count=0; } LISPFUNN(insert_window_line,1) { check_window_stream(popSTACK()); begin_system_call(); insertln(); refresh(); end_system_call(); value1 = NIL; mv_count=0; } LISPFUNN(highlight_on,1) { check_window_stream(popSTACK()); #ifdef A_STANDOUT # geht nur, wenn Curses Attribute verwaltet begin_system_call(); attron(A_STANDOUT); # Attribut A_STANDOUT bei addch() hineinoderieren end_system_call(); #endif value1 = NIL; mv_count=0; } LISPFUNN(highlight_off,1) { check_window_stream(popSTACK()); #ifdef A_STANDOUT # geht nur, wenn Curses Attribute verwaltet begin_system_call(); attroff(A_STANDOUT); # kein Attribut mehr bei addch() hineinoderieren end_system_call(); #endif value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_on,1) { check_window_stream(popSTACK()); # Cursor ist permanent an! value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_off,1) { check_window_stream(popSTACK()); # geht nicht, da Cursor permanent an! value1 = NIL; mv_count=0; } #endif # UNIX #ifdef AMIGAOS # Terminal-Emulation: ANSI-Steuerzeichen, siehe console.doc # UP: Ausgabe mehrerer Zeichen auf den Bildschirm local void wr_window (uintB* outbuffer, uintL count); local void wr_window(outbuffer,count) var reg2 uintB* outbuffer; var reg3 uintL count; { set_break_sem_1(); begin_system_call(); {var reg1 long ergebnis = Write(Output_handle,outbuffer,count); end_system_call(); if (ergebnis<0) { OS_error(); } # Error melden if (ergebnis<count) # nicht erfolgreich? { ?? } clr_break_sem_1(); }} #define WR_WINDOW(characters) \ { local var uintB outbuffer[] = characters; \ wr_window(&outbuffer,sizeof(outbuffer)); \ } # UP: Ein Zeichen auf einen Window-Stream ausgeben. # wr_ch_window(&stream,ch); # > stream: Window-Stream # > ch: auszugebendes Zeichen local void wr_ch_window (object* stream_, object ch); local void wr_ch_window(stream_,ch) var reg2 object* stream_; var reg3 object ch; { if (!string_char_p(ch)) { fehler_wr_string_char(*stream_,ch); } # ch sollte String-Char sein {var reg1 uintB c = char_code(ch); # Code des Zeichens ?? }} LISPFUNN(make_window,0) { finish_output_terminal(var_stream(S(terminal_io))); # evtl. wartendes NL jetzt ausgeben {var reg2 object stream = allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+0); # Flags: nur WRITE-CHAR erlaubt # und fⁿllen: var reg1 Stream s = TheStream(stream); s->strm_rd_by = P(rd_by_dummy); # READ-BYTE unm÷glich s->strm_wr_by = P(wr_by_dummy); # WRITE-BYTE unm÷glich s->strm_rd_ch = P(rd_ch_dummy); # READ-CHAR unm÷glich s->strm_rd_ch_last = NIL; # Lastchar := NIL s->strm_wr_ch = P(wr_ch_window); # WRITE-CHAR-Pseudofunktion s->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 #ifdef STRM_WR_SS s->strm_wr_ss = P(wr_ss_dummy_nogc); #endif # size: aWSR? aWBR?? # Wrap off ?? ASM? AWM? WR_WINDOW({CSI,'0',0x6D}); # Set Graphics Rendition Normal value1 = stream; mv_count=1; }} # Schlie▀t einen Window-Stream. local void close_window (object stream); local void close_window(stream) var reg1 object stream; { # Wrap on ?? ASM? AWM? WR_WINDOW({CSI,'0',0x6D}); # Set Graphics Rendition Normal } LISPFUNN(window_size,1) { check_window_stream(popSTACK()); value1 = fixnum(window_size.y); ?? value2 = fixnum(window_size.x); ?? mv_count=2; } LISPFUNN(window_cursor_position,1) { check_window_stream(popSTACK()); # aWSR? CPR?? value1 = fixnum(_y); ?? value2 = fixnum(_x); ?? mv_count=2; } LISPFUNN(set_window_cursor_position,3) { check_window_stream(STACK_2); {var reg3 uintL line = posfixnum_to_L(STACK_1); var reg4 uintL column = posfixnum_to_L(STACK_0); if ((line < (uintL)window_size.y) && (column < (uintL)window_size.x)) { var uintB outbuffer[23]; # Buffer fⁿr CSI <line> ; <column> H var reg1 uintB* ptr = &outbuffer[sizeof(outbuffer)]; var reg2 uintL count = 0; count++; *--ptr = 'H'; do { count++; *--ptr = '0'+(column%10); column = floor(column,10); } until (column==0); count++; *--ptr = ';'; do { count++; *--ptr = '0'+(line%10); line = floor(line,10); } until (line==0); count++; *--ptr = CSI; wr_window(ptr,count); } value1 = STACK_1; value2 = STACK_0; mv_count=2; skipSTACK(3); }} LISPFUNN(clear_window,1) { check_window_stream(popSTACK()); WR_WINDOW({CSI,'0',';','0','H',CSI,'J'}); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eot,1) { check_window_stream(popSTACK()); WR_WINDOW({CSI,'J'}); value1 = NIL; mv_count=0; } LISPFUNN(clear_window_to_eol,1) { check_window_stream(popSTACK()); WR_WINDOW({CSI,'K'}); value1 = NIL; mv_count=0; } LISPFUNN(delete_window_line,1) { check_window_stream(popSTACK()); WR_WINDOW({CSI,'M'}); value1 = NIL; mv_count=0; } LISPFUNN(insert_window_line,1) { check_window_stream(popSTACK()); WR_WINDOW({CSI,'L'}); value1 = NIL; mv_count=0; } LISPFUNN(highlight_on,1) { check_window_stream(popSTACK()); WR_WINDOW({CSI,'1',0x6D}); # Set Graphics Rendition Bold value1 = NIL; mv_count=0; } LISPFUNN(highlight_off,1) { check_window_stream(popSTACK()); WR_WINDOW({CSI,'0',0x6D}); # Set Graphics Rendition Normal value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_on,1) { check_window_stream(popSTACK()); # aSCR ?? value1 = NIL; mv_count=0; } LISPFUNN(window_cursor_off,1) { check_window_stream(popSTACK()); # aSCR ?? value1 = NIL; mv_count=0; } #endif # AMIGAOS #endif # SCREEN # File-Stream # =========== # Um nicht fⁿr jedes Character das GEMDOS/UNIX/AMIGADOS bemⁿhen zu mⁿssen, # wird ein eigener Buffer gefⁿhrt. # (Dies bewirkt z.B. beim Einlesen eines 408 KByte- Files auf dem Atari # eine Beschleunigung um einen Faktor 2.7 von 500 sec auf 180 sec.) # ZusΣtzliche Komponenten: # define strm_file_name strm_other[3] # Filename, ein Pathname # define strm_file_truename strm_other[4] # Truename, ein Pathname # define strm_file_handle strm_other[2] # Handle, ein Fixnum >=0, <2^16 #define strm_file_buffstart strm_other[0] # Buffer-Startposition, ein Fixnum >=0 #define strm_file_bufflen 4096 # BufferlΣnge (Zweierpotenz <2^16) #define strm_file_buffer strm_other[1] # eigener Buffer, # ein Simple-String der LΣnge strm_file_bufflen #define strm_file_eofindex strm_other[5] # Index darin, bis wo die # Daten gⁿltig sind (fⁿr EOF-Erkennung) #define strm_file_index strm_other[6] # Fixnum mit Index im Buffer # (>=0, <=STRM_FILE_BUFFLEN) # und Modified-Flag in Bit 16. # eofindex = NIL: Bufferdaten ganz ungⁿltig, index=0. # eofindex Fixnum: 0 <= index <= eofindex <= strm_file_bufflen. # eofindex = T: Bufferdaten ganz gⁿltig, 0 <= index <= strm_file_bufflen. # buffstart = (Nummer des Sectors) * strm_file_bufflen. # Beim Betriebssystem ist das File 'handle' ans Ende des aktuellen Buffers # positioniert: # bei eofindex = T: buffstart + strm_file_bufflen, # bei eofindex Fixnum: buffstart + eofindex, # bei eofindex = NIL: buffstart. # Modified-Flag abfragen und verΣndern: #define modified_flag(stream) \ (as_oint(TheStream(stream)->strm_file_index) & wbit(16+oint_data_shift)) #define set_modified_flag(stream) \ TheStream(stream)->strm_file_index = \ as_object(as_oint(TheStream(stream)->strm_file_index) | wbit(16+oint_data_shift)) #define reset_modified_flag(stream) \ TheStream(stream)->strm_file_index = \ as_object(as_oint(TheStream(stream)->strm_file_index) & ~wbit(16+oint_data_shift)) # Bis hierher wird ein File aus Bytes α 8 Bits aufgebaut gedacht. # Logisch ist es jedoch aus anderen Einheiten aufgebaut: #define strm_file_position strm_other[7] # Position, ein Fixnum >=0 # Bei File-Streams mit element-type = STRING-CHAR (sch_file) # belegt jedes Character 1 Byte. # define strm_sch_file_lineno strm_other[8] # Zeilennummer beim Lesen, ein Fixnum >0 # Bei File-Streams mit element-type = CHARACTER (ch_file) # belegt jedes Character 2 Bytes. # Bei File-Streams mit element-type = INTEGER ("Byte-Files") # belegt jeder Integer immer dieselbe Anzahl Bits. #define strm_file_bitsize strm_other[8] # Anzahl der Bits, ein Fixnum >0 und <intDsize*uintC_max #define strm_file_bitbuffer strm_other[9] # Buffer, ein Simple-Bit-Vector # mit ceiling(bitsize/8)*8 Bits # Ist diese Anzahl nicht durch 8 teilbar, so ist bitindex der Index # im aktuellen Byte: #define strm_file_bitindex strm_other[10] # Index im Byte, ein Fixnum >=0 und <=8 # 8*index+bitindex ist die Anzahl der gelesenen Bits des Buffers. # Die Bits sind in der Reihenfolge Bit0,...,Bit7 angeordnet. # Ist Bitsize<8, so wird beim Schlie▀en des Files die LΣnge des Files # (gemessen in Bits) als .L am Anfang des Files abgelegt, die Daten # fangen also erst beim 5. Byte an. #define strm_file_eofposition strm_other[11] # Position des logischen EOF, ein Fixnum >=0 # Bei geschlossenen File-Streams sind nur die Komponenten name und truename # relevant. # File-Stream allgemein # ===================== #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) # Annahme: Alle von OPEN(2) gelieferten File-Descriptoren (hier Handles # genannt) passen in ein uintW. # Begrⁿndung: Bekanntlich ist 0 <= fd < getdtablesize() . #endif # Handle positionieren: # file_lseek(stream,offset,mode,ergebnis_zuweisung); # > mode: Positionierungsmodus: # SEEK_SET "absolut" # SEEK_CUR "relativ" # SEEK_END "ab Ende" # < ergebnis: neue Position #ifdef ATARI #define file_lseek(stream,offset,mode,ergebnis_zuweisung) \ { var reg2 sintL ergebnis = \ GEMDOS_Lseek(offset, \ TheHandle(TheStream(stream)->strm_file_handle), # Handle \ mode \ ); \ if (ergebnis<0) { OS_error(ergebnis); } # Fehler aufgetreten? \ nowarn ergebnis_zuweisung ergebnis; \ } #define SEEK_SET 0 #define SEEK_CUR 1 #define SEEK_END 2 #endif #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) #define file_lseek(stream,offset,mode,ergebnis_zuweisung) \ { var reg2 sintL ergebnis = \ lseek(TheHandle(TheStream(stream)->strm_file_handle), # Handle \ offset, \ mode \ ); \ if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? \ nowarn ergebnis_zuweisung ergebnis; \ } #endif #ifdef AMIGAOS #define file_lseek(stream,offset,mode,ergebnis_zuweisung) \ { var reg3 uintL _offset = (offset); \ var reg2 sintL ergebnis = \ Seek(TheHandle(TheStream(stream)->strm_file_handle), \ _offset, \ mode \ ); \ if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? \ if (mode==SEEK_SET) { nowarn ergebnis_zuweisung _offset; } \ elif (mode==SEEK_CUR) { nowarn ergebnis_zuweisung ergebnis+_offset; } \ else /* mode==SEEK_END */ \ { ergebnis = Seek(TheHandle(TheStream(stream)->strm_file_handle),0,SEEK_CUR); \ if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? \ nowarn ergebnis_zuweisung ergebnis; \ } } #define SEEK_SET OFFSET_BEGINNING #define SEEK_CUR OFFSET_CURRENT #define SEEK_END OFFSET_END #endif # UP: Beendet das Zurⁿckschreiben des Buffers. # b_file_finish_flush(stream,bufflen); # > stream : (offener) Byte-basierter File-Stream. # > bufflen : Anzahl der zu schreibenden Bytes # < modified_flag von stream : gel÷scht # verΣndert in stream: index local void b_file_finish_flush (object stream, uintL bufflen); local void b_file_finish_flush(stream,bufflen) var reg1 object stream; var reg2 uintL bufflen; { begin_system_call(); {var reg3 sintL ergebnis = # Buffer hinausschreiben #ifdef ATARI GEMDOS_write(TheHandle(TheStream(stream)->strm_file_handle), # Handle bufflen, untype(&TheSstring(TheStream(stream)->strm_file_buffer)->data[0]) # Bufferadresse ohne Typinfo ) #endif #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) full_write(TheHandle(TheStream(stream)->strm_file_handle), # Handle &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse bufflen ) #endif #ifdef AMIGAOS Write(TheHandle(TheStream(stream)->strm_file_handle), &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse bufflen ) #endif ; end_system_call(); if (ergebnis==bufflen) # alles korrekt geschrieben { reset_modified_flag(stream); } else # Nicht alles geschrieben { #ifdef ATARI if (ergebnis<0) { OS_error(ergebnis); } # Fehler aufgetreten? #endif #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) if (ergebnis<0) # Fehler aufgetreten? #ifdef ENOSPC if (!(errno == ENOSPC)) #endif #ifdef EDQUOT if (!(errno == EDQUOT)) #endif { OS_error(); } #endif #ifdef AMIGAOS if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? #endif # Nicht alles geschrieben, wohl wegen voller Diskette. # Um Inkonsistenzen zu vermeiden, mu▀ man das File schlie▀en. reset_modified_flag(stream); # Hierbei gehen Daten verloren! pushSTACK(stream); stream_close(&STACK_0); # File schlie▀en clr_break_sem_4(); # keine GEMDOS/UNIX-Operation mehr aktiv # Fehler melden. pushSTACK(TheStream(STACK_0)->strm_file_truename); # Wert fⁿr Slot PATHNAME von FILE-ERROR pushSTACK(STACK_(0+1)); # stream fehler(file_error, DEUTSCH ? "Diskette/Platte voll. Deswegen wurde ~ geschlossen." : ENGLISH ? "Closed ~ because disk is full." : FRANCAIS ? "Ai fermΘ ~, parce que le disque est sans doute plein." : "" ); }} } # UP: Schreibt den vollen, modifizierten Buffer zurⁿck. # b_file_full_flush(stream); # > stream : (offener) Byte-basierter File-Stream. # < modified_flag von stream : gel÷scht # verΣndert in stream: index local void b_file_full_flush (object stream); local void b_file_full_flush(stream) var reg1 object stream; { # erst zurⁿckpositionieren, dann schreiben. begin_system_call(); file_lseek(stream,-(long)strm_file_bufflen,SEEK_CUR,); # Zurⁿckpositionieren end_system_call(); b_file_finish_flush(stream,strm_file_bufflen); } # UP: Schreibt den halbvollen, modifizierten Buffer zurⁿck. # b_file_full_flush(stream); # > stream : (offener) Byte-basierter File-Stream. # < modified_flag von stream : gel÷scht # verΣndert in stream: index local void b_file_half_flush (object stream); local void b_file_half_flush(stream) var reg1 object stream; { begin_system_call(); file_lseek(stream,posfixnum_to_L(TheStream(stream)->strm_file_buffstart),SEEK_SET,); # Zurⁿckpositionieren end_system_call(); # eofindex Bytes schreiben: b_file_finish_flush(stream, posfixnum_to_L(TheStream(stream)->strm_file_eofindex) ); } # UP: Schreibt den modifizierten Buffer zurⁿck. # b_file_flush(stream); # > stream : (offener) Byte-basierter File-Stream. # < modified_flag von stream : gel÷scht # verΣndert in stream: index local void b_file_flush (object stream); local void b_file_flush(stream) var reg1 object stream; { if (eq(TheStream(stream)->strm_file_eofindex,T)) # Buffer ganz gⁿltig ? { b_file_full_flush(stream); } else { b_file_half_flush(stream); } } # UP: Positioniert einen Byte-basierten File-Stream so, da▀ das nΣchste Byte # gelesen oder ⁿberschrieben werden kann. # b_file_nextbyte(stream) # > stream : (offener) Byte-basierter File-Stream. # < ergebnis : NULL falls EOF (und dann ist index=eofindex), # sonst: Pointer auf nΣchstes Byte # verΣndert in stream: index, eofindex, buffstart local uintB* b_file_nextbyte (object stream); local uintB* b_file_nextbyte(stream) var reg1 object stream; { var reg2 object eofindex = TheStream(stream)->strm_file_eofindex; var reg3 object index = TheStream(stream)->strm_file_index; if (!eq(eofindex,T)) # Bufferdaten nur halb gⁿltig { if (eq(eofindex,NIL)) # Bufferdaten ganz ungⁿltig { goto reread; } else # EOF tritt in diesem Sector auf { goto eofsector; } } # Bufferdaten ganz gⁿltig if (!((uintW)posfixnum_to_L(index) == strm_file_bufflen)) # index = bufflen ? # nein, also 0 <= index < strm_file_bufflen -> OK { return &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(index)]; } # Buffer mu▀ neu gefⁿllt werden. if (modified_flag(stream)) # Zuvor mu▀ der Buffer hinausgeschrieben werden: { b_file_full_flush(stream); } TheStream(stream)->strm_file_buffstart = fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen); reread: # Ab hier den Buffer neu lesen: { begin_system_call(); {var reg4 sintL ergebnis = # Buffer fⁿllen #ifdef ATARI GEMDOS_read(TheHandle(TheStream(stream)->strm_file_handle), # Handle strm_file_bufflen, untype(&TheSstring(TheStream(stream)->strm_file_buffer)->data[0]) # Bufferadresse ohne Typinfo ) #endif #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) full_read(TheHandle(TheStream(stream)->strm_file_handle), # Handle &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse strm_file_bufflen ) #endif #ifdef AMIGAOS Read(TheHandle(TheStream(stream)->strm_file_handle), &TheSstring(TheStream(stream)->strm_file_buffer)->data[0], # Bufferadresse strm_file_bufflen ) #endif ; end_system_call(); if (ergebnis==strm_file_bufflen) # der ganze Buffer wurde gefⁿllt { TheStream(stream)->strm_file_index = Fixnum_0; # Index := 0, Buffer unmodifiziert TheStream(stream)->strm_file_eofindex = T; # eofindex := T return &TheSstring(TheStream(stream)->strm_file_buffer)->data[0]; } #ifdef ATARI if (ergebnis<0) { OS_error(ergebnis); } # Fehler aufgetreten? #endif #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? #endif #ifdef AMIGAOS if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? #endif # Es wurden ergebnis (< strm_file_bufflen) Bytes gelesen. # Nicht der ganze Buffer wurde gefⁿllt -> EOF ist erreicht. TheStream(stream)->strm_file_index = index = Fixnum_0; # Index := 0, Buffer unmodifiziert TheStream(stream)->strm_file_eofindex = eofindex = fixnum(ergebnis); # eofindex := ergebnis }} eofsector: # eofindex ist ein Fixnum, d.h. EOF tritt in diesem Sector auf. if ((uintW)posfixnum_to_L(index) == (uintW)posfixnum_to_L(eofindex)) { return (uintB*)NULL; } # EOF erreicht else { return &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(index)]; } } # UP: Bereitet das Schreiben eines Bytes am EOF vor. # b_file_eofbyte(stream); # > stream : (offener) Byte-basierter File-Stream, # bei dem gerade b_file_nextbyte(stream)==NULL ist. # < ergebnis : Pointer auf nΣchstes (freies) Byte # verΣndert in stream: index, eofindex, buffstart local uintB* b_file_eofbyte (object stream); local uintB* b_file_eofbyte(stream) var reg1 object stream; { # EOF. Es ist eofindex=index. if (eq(TheStream(stream)->strm_file_eofindex, fixnum(strm_file_bufflen) ) ) # eofindex = strm_file_bufflen { # Buffer mu▀ neu gefⁿllt werden. Da nach ihm sowieso EOF kommt, # genⁿgt es, ihn hinauszuschreiben: if (modified_flag(stream)) { b_file_half_flush(stream); } TheStream(stream)->strm_file_buffstart = fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen); TheStream(stream)->strm_file_eofindex = Fixnum_0; # eofindex := 0 TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert } # eofindex erh÷hen: TheStream(stream)->strm_file_eofindex = fixnum_inc(TheStream(stream)->strm_file_eofindex,1); return &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(TheStream(stream)->strm_file_index)]; } # UP: Schreibt ein Byte auf einen Byte-basierten File-Stream. # b_file_writebyte(stream,b); # > stream : (offener) Byteblock-basierter File-Stream. # > b : zu schreibendes Byte # verΣndert in stream: index, eofindex, buffstart local void b_file_writebyte (object stream, uintB b); local void b_file_writebyte(stream,b) var reg1 object stream; var reg3 uintB b; { var reg2 uintB* ptr = b_file_nextbyte(stream); if (!(ptr == (uintB*)NULL)) { if (*ptr == b) goto no_modification; } # keine wirkliche Modifikation? else { ptr = b_file_eofbyte(stream); } # EOF -> 1 Byte Platz machen # nΣchstes Byte in den Buffer schreiben: *ptr = b; set_modified_flag(stream); no_modification: # index incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); } # File-Stream, Byte-basiert (b_file) # =========== ============ # Fehler wegen Positionierung hinter EOF. # fehler_position_beyond_EOF(stream); nonreturning_function(local, fehler_position_beyond_EOF, (object stream)); local void fehler_position_beyond_EOF(stream) var reg1 object stream; { pushSTACK(TheStream(stream)->strm_file_truename); # Wert fⁿr Slot PATHNAME von FILE-ERROR pushSTACK(stream); fehler(file_error, DEUTSCH ? "Positionierung von ~ hinter EOF unm÷glich." : ENGLISH ? "cannot position ~ beyond EOF" : FRANCAIS ? "Ne peux pas positionner ~ au-delα de la fin du fichier." : "" ); } # UP: Positioniert einen (offenen) Byte-basierten File-Stream an eine # gegebene Position. # position_b_file(stream,position); # > stream : (offener) Byte-basierter File-Stream. # > position : neue Position # verΣndert in stream: index, eofindex, buffstart local void position_b_file (object stream, uintL position); local void position_b_file(stream,position) var reg1 object stream; var reg2 uintL position; { # Liegt die neue Position im selben Sector? { var reg3 object eofindex = TheStream(stream)->strm_file_eofindex; var reg4 uintL newindex = position - posfixnum_to_L(TheStream(stream)->strm_file_buffstart); if (newindex <= (eq(eofindex,T) ? strm_file_bufflen : (!eq(eofindex,NIL)) ? posfixnum_to_L(eofindex) : 0 ) ) { # ja -> brauche nur index zu verΣndern: # (Dabei aber das modified_flag erhalten!) TheStream(stream)->strm_file_index = (modified_flag(stream) ? fixnum(bit(16)+newindex) : fixnum(newindex) ); return; } } # evtl. Buffer hinausschreiben: if (modified_flag(stream)) { b_file_flush(stream); } # Nun ist modified_flag gel÷scht. {var reg5 uintL oldposition = posfixnum_to_L(TheStream(stream)->strm_file_buffstart) + posfixnum_to_L(TheStream(stream)->strm_file_index); # Positionieren: { var reg4 uintL newposition; begin_system_call(); file_lseek(stream,floor(position,strm_file_bufflen)*strm_file_bufflen,SEEK_SET,newposition=); end_system_call(); TheStream(stream)->strm_file_buffstart = fixnum(newposition); } # Sector lesen: TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert { var reg3 uintL newindex = position % strm_file_bufflen; # gewⁿnschter Index im Sector if (!(newindex==0)) # Position zwischen Sectoren -> brauche nichts zu lesen { b_file_nextbyte(stream); # Jetzt ist index=0. # index auf (position mod bufflen) setzen, vorher ⁿberprⁿfen: {var reg4 object eofindex = TheStream(stream)->strm_file_eofindex; # Es mu▀ entweder eofindex=T oder 0<=newindex<=eofindex sein: if (!(eq(eofindex,T) || (newindex <= posfixnum_to_L(eofindex)))) # Fehler. Aber erst an die alte Position zurⁿckpositionieren: { check_SP(); position_b_file(stream,oldposition); # zurⁿckpositionieren fehler_position_beyond_EOF(stream); } TheStream(stream)->strm_file_index = fixnum(newindex); } }} }} # File-Stream fⁿr String-Chars # ============================ # Funktionsweise: # Beim Schreiben: Characters werden unverΣndert durchgereicht, nur NL wird auf # ATARI/MSDOS in CR/LF umgewandelt. Beim Lesen: CR/LF wird in NL umgewandelt. # READ-CHAR - Pseudofunktion fⁿr File-Streams fⁿr String-Chars local object rd_ch_sch_file (object* stream_); local object rd_ch_sch_file(stream_) var reg3 object* stream_; { var reg1 object stream = *stream_; var reg2 uintB* charptr = b_file_nextbyte(stream); if (charptr == (uintB*)NULL) { return eof_value; } # EOF ? # nΣchstes Zeichen holen: {var reg3 object ch = code_char(*charptr); # Character aus dem Buffer holen # index und position incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); # ch = nΣchstes Zeichen if (!eq(ch,code_char(CR))) # Ist es CR ? { # nein -> OK if (eq(ch,code_char(NL))) # Ist es NL, dann lineno incrementieren { TheStream(stream)->strm_sch_file_lineno = fixnum_inc(TheStream(stream)->strm_sch_file_lineno,1); } return ch; } # ja -> nΣchstes Zeichen auf LF untersuchen charptr = b_file_nextbyte(stream); if (charptr == (uintB*)NULL) { return ch; } # EOF -> bleibt CR if (!(*charptr == LF)) { return ch; } # kein LF -> bleibt CR # LF ⁿbergehen, index und position incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); # lineno incrementieren: TheStream(stream)->strm_sch_file_lineno = fixnum_inc(TheStream(stream)->strm_sch_file_lineno,1); # NL als Ergebnis: return code_char(NL); }} # Stellt fest, ob ein File-Stream ein Zeichen verfⁿgbar hat. # listen_sch_file(stream) # > stream: File-Stream fⁿr String-Chars # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF local signean listen_sch_file (object stream); local signean listen_sch_file(stream) var reg1 object stream; { if (b_file_nextbyte(stream) == (uintB*)NULL) { return signean_minus; } # EOF else { return signean_null; } } # UP: Schreibt ein Byte auf einen Byte-basierten File-Stream. # write_b_file(stream,b); # > stream : (offener) Byte-basierter File-Stream. # > b : zu schreibendes Byte # verΣndert in stream: index, eofindex, buffstart, position local void write_b_file (object stream, uintB b); local void write_b_file(stream,b) var reg1 object stream; var reg2 uintB b; { b_file_writebyte(stream,b); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); } # WRITE-CHAR - Pseudofunktion fⁿr File-Streams fⁿr String-Chars local void wr_ch_sch_file (object* stream_, object obj); local void wr_ch_sch_file(stream_,obj) var reg4 object* stream_; var reg2 object obj; { var reg1 object stream = *stream_; # obj mu▀ ein String-Char sein: if (!string_char_p(obj)) { fehler_wr_string_char(stream,obj); } {var reg3 uintB ch = char_code(obj); #if defined(ATARI) || defined(MSDOS) if (ch==NL) # Newline als CR/LF ausgeben { write_b_file(stream,CR); write_b_file(stream,LF); } else # alle anderen Zeichen unverΣndert ausgeben { write_b_file(stream,ch); } #else write_b_file(stream,ch); # unverΣndert ausgeben #endif }} # WRITE-CHAR-SEQUENCE fⁿr File-Streams fⁿr String-Chars: local uintB* write_schar_array_sch_file (object stream, uintB* strptr, uintL len); #if defined(ATARI) || defined(MSDOS) # Wegen NL->CR/LF-Umwandlung keine Optimierung m÷glich. local inline uintB* write_schar_array_sch_file(stream,strptr,len) var reg3 object stream; var reg4 uintB* strptr; var reg5 uintL len; { var reg1 uintL remaining = len; do { var reg2 uintB ch = *strptr++; if (ch==NL) # Newline als CR/LF ausgeben { write_b_file(stream,CR); write_b_file(stream,LF); } else # alle anderen Zeichen unverΣndert ausgeben { write_b_file(stream,ch); } remaining--; } until (remaining == 0); wr_ss_lpos(stream,strptr,len); # Line-Position aktualisieren return strptr; } #else local uintB* write_schar_array_sch_file(stream,strptr,len) var reg5 object stream; var reg2 uintB* strptr; var reg9 uintL len; { var reg6 uintL remaining = len; var reg1 uintB* ptr; do # Noch remaining>0 Bytes abzulegen. { ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof_reached; {var reg8 object eofindex = TheStream(stream)->strm_file_eofindex; var reg7 uintL next = # so viel wie noch in den Buffer oder bis EOF pa▀t (eq(eofindex,T) ? strm_file_bufflen : posfixnum_to_L(eofindex)) - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index); # > 0 ! if (next > remaining) { next = remaining; } # next Bytes in den Buffer kopieren: {var reg4 uintL count; dotimespL(count,next, { var reg3 uintB b = *strptr++; # nΣchstes Byte if (!(*ptr == b)) { *ptr = b; set_modified_flag(stream); } # in den Buffer ptr++; }); } remaining = remaining - next; # index incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,next); }} until (remaining == 0); if (FALSE) eof_reached: # Schreiben am EOF, eofindex = index do # Noch remaining>0 Bytes abzulegen. { var reg7 uintL next = # so viel wie noch Platz im Buffer ist strm_file_bufflen - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index); if (next==0) { # Buffer mu▀ neu gefⁿllt werden. Da nach ihm sowieso EOF kommt, # genⁿgt es, ihn hinauszuschreiben: if (modified_flag(stream)) { b_file_half_flush(stream); } TheStream(stream)->strm_file_buffstart = fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen); TheStream(stream)->strm_file_eofindex = Fixnum_0; # eofindex := 0 TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert # Dann nochmals versuchen: next = strm_file_bufflen; } if (next > remaining) { next = remaining; } # next Bytes in den Buffer kopieren: {var reg3 uintL count; ptr = &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(TheStream(stream)->strm_file_index)]; dotimespL(count,next, { *ptr++ = *strptr++; } ); set_modified_flag(stream); } remaining = remaining - next; # index und eofindex incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,next); TheStream(stream)->strm_file_eofindex = fixnum_inc(TheStream(stream)->strm_file_eofindex,next); } until (remaining == 0); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,len); wr_ss_lpos(stream,strptr,len); # Line-Position aktualisieren return strptr; } #endif #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr File-Streams fⁿr String-Chars local void wr_ss_sch_file (object* stream_, object string, uintL start, uintL len); local void wr_ss_sch_file(stream_,string,start,len) var reg1 object* stream_; var reg2 object string; var reg4 uintL start; var reg3 uintL len; { if (len==0) return; write_schar_array_sch_file(*stream_,&TheSstring(string)->data[start],len); } #endif # File-Stream fⁿr Characters # ========================== # Funktionsweise: # Characters werden incl. Fonts und Bits durchgereicht. #if (!((char_int_len % 8) == 0)) # char_int_len mu▀ durch 8 teilbar sein #error "Charactergr÷▀e neu einstellen!" #endif #define char_size (char_int_len / 8) # Gr÷▀e eines Characters in Bytes # READ-CHAR - Pseudofunktion fⁿr File-Streams fⁿr Characters local object rd_ch_ch_file (object* stream_); local object rd_ch_ch_file(stream_) var reg4 object* stream_; { var reg1 object stream = *stream_; var reg3 cint c; var reg2 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof; # EOF ? c = *ptr; # index incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); doconsttimes(char_size-1, ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof1; # EOF ? c = (c<<8) | *ptr; # index incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); ); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); return int_char(c); eof1: # Wieder zurⁿckpositionieren: position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position) * char_size); eof: # EOF erreicht gewesen return eof_value; } # Stellt fest, ob ein File-Stream ein Zeichen verfⁿgbar hat. # listen_ch_file(stream) # > stream: File-Stream fⁿr Characters # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen local signean listen_ch_file (object stream); local signean listen_ch_file(stream) var reg1 object stream; { var reg2 uintB* ptr = b_file_nextbyte(stream); # erstes Byte da ? if (ptr == (uintB*)NULL) goto eof; # EOF ? doconsttimes(char_size-1, # index incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); ptr = b_file_nextbyte(stream); # nΣchstes Byte da ? if (ptr == (uintB*)NULL) goto eof1; # EOF ? ); # Wieder zurⁿckpositionieren: position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position) * char_size); return signean_null; eof1: # Wieder zurⁿckpositionieren: position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position) * char_size); eof: # EOF erreicht gewesen return signean_minus; } # WRITE-CHAR - Pseudofunktion fⁿr File-Streams fⁿr Characters local void wr_ch_ch_file (object* stream_, object obj); local void wr_ch_ch_file(stream_,obj) var reg4 object* stream_; var reg2 object obj; { var reg1 object stream = *stream_; # obj mu▀ ein Character sein: if (!charp(obj)) { fehler_wr_char(stream,obj); } {var reg3 cint c = char_int(obj); #define WRITEBYTE(i) b_file_writebyte(stream,(uintB)(c>>(char_size-1-i))); DOCONSTTIMES(char_size,WRITEBYTE) # WRITEBYTE(0..char_size-1) #undef WRITEBYTE # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); }} # File-Stream, Bit-basiert # ======================== # Davon gibt es insgesamt 6 Arten: # Drei FΣlle # a - bitsize durch 8 teilbar, # b - bitsize < 8, # c - bitsize nicht durch 8 teilbar und >= 8, # jeweils unterschieden durch # s - Elementtyp (signed-byte bitsize), # dazu zΣhlt auch signed-byte = (signed-byte 8) # u - Elementtyp (unsigned-byte bitsize), # dazu zΣhlen auch unsigned-byte = (unsigned-byte 8) # und bit = (unsigned-byte 1) # und (mod n) = (unsigned-byte (integer-length n)) # UP: Positioniert einen (offenen) Bit-basierten File-Stream an eine # gegebene Position. # position_i_file(stream,position); # > stream : (offener) Byte-basierter File-Stream. # > position : neue (logische) Position # verΣndert in stream: index, eofindex, buffstart, bitindex local void position_i_file (object stream, uintL position); local void position_i_file(stream,position) var reg1 object stream; var reg2 uintL position; { var reg5 uintB flags = TheStream(stream)->strmflags; var reg4 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); var reg3 uintL position_bits = position * bitsize; if (flags & strmflags_ib_B) { position_bits += sizeof(uintL)*8; } # Header berⁿcksichtigen # An Bit Nummer position_bits positionieren. position_b_file(stream,floor(position_bits,8)); # Aufs Byte positionieren if (flags & strmflags_ia_B) return; # Bei Art a war's das. if (# Liegt die angesprochene Position im ersten Byte nach EOF ? ((!((position_bits%8)==0)) && (b_file_nextbyte(stream) == (uintB*)NULL) ) || # Liegt die angesprochene Position im letzten Byte, aber zu weit? ((flags & strmflags_ib_B) && (position > posfixnum_to_L(TheStream(stream)->strm_file_eofposition)) )) # Fehler. Aber erst an die alte Position zurⁿckpositionieren: { var reg6 uintL oldposition = posfixnum_to_L(TheStream(stream)->strm_file_position); check_SP(); position_i_file(stream,oldposition); # zurⁿckpositionieren fehler_position_beyond_EOF(stream); } TheStream(stream)->strm_file_bitindex = fixnum(position_bits%8); } # UP fⁿr READ-BYTE auf File-Streams fⁿr Integers, Art u : # Liefert die im Bitbuffer enthaltenen bytesize Bytes als Integer >=0. # kann GC ausl÷sen local object rd_by_iu_I (object stream, uintL bitsize, uintL bytesize); local object rd_by_iu_I(stream,bitsize,bytesize) var reg6 object stream; var reg7 uintL bitsize; var reg5 uintL bytesize; { var reg4 object bitbuffer = TheStream(stream)->strm_file_bitbuffer; # Zahl im bitbuffer normalisieren: var reg1 uintB* bitbufferptr = &TheSbvector(bitbuffer)->data[0]; *bitbufferptr &= (bit(((bitsize-1)%8)+1)-1); # High byte maskieren {var reg2 uintL count = bytesize; while ((!(count==0)) && (*bitbufferptr==0)) { count--; bitbufferptr++; } # Zahl bilden: if # h÷chstens oint_data_len Bits ? ((count <= floor(oint_data_len,8)) || ((count == floor(oint_data_len,8)+1) && (*bitbufferptr < bit(oint_data_len%8)) ) ) # ja -> Fixnum >=0 bilden: { var reg3 uintL wert = 0; until (count==0) { wert = (wert<<8) | *bitbufferptr++; count--; } return fixnum(wert); } else # nein -> Bignum >0 bilden: { pushSTACK(bitbuffer); {var reg5 uintL digitcount = floor(count,(intDsize/8)); if (((count%(intDsize/8)) > 0) || (*bitbufferptr & bit(7))) { digitcount++; } # Da bitsize < intDsize*uintC_max, ist # digitcount <= ceiling((bitsize+1)/intDsize) <= uintC_max . { var reg4 object big = allocate_bignum(digitcount,0); # neues Bignum >0 TheBignum(big)->data[0] = 0; # h÷chstes Digit auf 0 setzen # restliche Digits von rechts fⁿllen, dabei Folge von Bytes in # Folge von uintD ⁿbersetzen: bitbuffer = popSTACK(); bitbufferptr = &TheSbvector(bitbuffer)->data[bytesize]; #if BIG_ENDIAN_P {var reg1 uintB* bigptr = (uintB*)(&TheBignum(big)->data[digitcount]); dotimespL(count,count, { *--bigptr = *--bitbufferptr; } ); } #else {var reg1 uintD* bigptr = &TheBignum(big)->data[digitcount]; var reg6 uintL count2; #define GET_NEXT_BYTE(i) \ digit |= ((uintD)(*--bitbufferptr) << (8*i)); dotimespL(count2,floor(count,intDsize/8), { var reg3 uintD digit = 0; DOCONSTTIMES(intDsize/8,GET_NEXT_BYTE); # GET_NEXT_BYTE(0..intDsize/8-1) *--bigptr = digit; }); #undef GET_NEXT_BYTE count2 = count % (intDsize/8); if (count2>0) { var reg7 uintL shiftcount = 0; var reg3 uintD digit = (uintD)(*--bitbufferptr); dotimesL(count2,count2-1, { shiftcount += 8; digit |= ((uintD)(*--bitbufferptr) << shiftcount); }); *--bigptr = digit; } } #endif # Wegen (intDsize/8)*(digitcount-1) <= count <= (intDsize/8)*digitcount # ist alles gefⁿllt. return big; }}} }} # UP fⁿr READ-BYTE auf File-Streams fⁿr Integers, Art s : # Liefert die im Bitbuffer enthaltenen bytesize Bytes als Integer. # kann GC ausl÷sen local object rd_by_is_I (object stream, uintL bitsize, uintL bytesize); local object rd_by_is_I(stream,bitsize,bytesize) var reg6 object stream; var reg7 uintL bitsize; var reg5 uintL bytesize; { var reg4 object bitbuffer = TheStream(stream)->strm_file_bitbuffer; # Zahl im bitbuffer normalisieren: var reg1 uintB* bitbufferptr = &TheSbvector(bitbuffer)->data[0]; var reg8 sintD sign; var reg3 uintL signbitnr = (bitsize-1)%8; var reg2 uintL count = bytesize; if (!(*bitbufferptr & bit(signbitnr))) { sign = 0; *bitbufferptr &= (bitm(signbitnr+1)-1); # High byte sign-extenden # normalisieren, h÷chstes Bit mu▀ 0 bleiben: while ((count>=2) && (*bitbufferptr==0) && !(*(bitbufferptr+1) & bit(7))) { count--; bitbufferptr++; } # Zahl bilden: if # h÷chstens oint_data_len+1 Bits, Zahl <2^oint_data_len ? ((count <= floor(oint_data_len,8)) || ((count == floor(oint_data_len,8)+1) && (*bitbufferptr < bit(oint_data_len%8)) ) ) # ja -> Fixnum >=0 bilden: { var reg3 uintL wert = 0; until (count==0) { wert = (wert<<8) | *bitbufferptr++; count--; } return posfixnum(wert); } } else { sign = -1; *bitbufferptr |= minus_bitm(signbitnr+1); # High byte sign-extenden # normalisieren, h÷chstes Bit mu▀ 1 bleiben: while ((count>=2) && (*bitbufferptr==(uintB)(-1)) && (*(bitbufferptr+1) & bit(7))) { count--; bitbufferptr++; } # Zahl bilden: if # h÷chstens oint_data_len+1 Bits, Zahl >=-2^oint_data_len ? ((count <= floor(oint_data_len,8)) || ((count == floor(oint_data_len,8)+1) && (*bitbufferptr >= (uintB)(-bit(oint_data_len%8))) ) ) # ja -> Fixnum <0 bilden: { var reg3 uintL wert = -1; until (count==0) { wert = (wert<<8) | *bitbufferptr++; count--; } return negfixnum(wbitm(intLsize)+(oint)wert); } } # Bignum bilden: pushSTACK(bitbuffer); { var reg5 uintL digitcount = ceiling(count,(intDsize/8)); # Da bitsize < intDsize*uintC_max, ist # digitcount <= ceiling(bitsize/intDsize) <= uintC_max . var reg4 object big = allocate_bignum(digitcount,sign); # neues Bignum TheBignum(big)->data[0] = sign; # h÷chstes Word auf sign setzen # restliche Digits von rechts fⁿllen, dabei Folge von Bytes in # Folge von uintD ⁿbersetzen: bitbuffer = popSTACK(); bitbufferptr = &TheSbvector(bitbuffer)->data[bytesize]; #if BIG_ENDIAN_P {var reg1 uintB* bigptr = (uintB*)(&TheBignum(big)->data[digitcount]); dotimespL(count,count, { *--bigptr = *--bitbufferptr; } ); } #else {var reg1 uintD* bigptr = &TheBignum(big)->data[digitcount]; var reg6 uintL count2; #define GET_NEXT_BYTE(i) \ digit |= ((uintD)(*--bitbufferptr) << (8*i)); dotimespL(count2,floor(count,intDsize/8), { var reg3 uintD digit = 0; DOCONSTTIMES(intDsize/8,GET_NEXT_BYTE); # GET_NEXT_BYTE(0..intDsize/8-1) *--bigptr = digit; }); #undef GET_NEXT_BYTE count2 = count % (intDsize/8); if (count2>0) { var reg7 uintL shiftcount = 0; var reg3 uintD digit = (uintD)(*--bitbufferptr); dotimesL(count2,count2-1, { shiftcount += 8; digit |= ((uintD)(*--bitbufferptr) << shiftcount); }); *--bigptr = digit; } } #endif # Wegen (intDsize/8)*(digitcount-1) < count <= (intDsize/8)*digitcount # ist alles gefⁿllt. return big; } } # Typ rd_by_ix_I: eines dieser beiden Unterprogramme: typedef object rd_by_ix_I (object stream, uintL bitsize, uintL bytesize); # UP fⁿr READ-BYTE auf File-Streams fⁿr Integers, Art a : # Fⁿllt den Bitbuffer mit den nΣchsten bitsize Bits. # > stream : File-Stream fⁿr Integers, Art a # > finisher : Beendigungsroutine # < ergebnis : gelesener Integer oder eof_value local object rd_by_iax_file (object stream, rd_by_ix_I* finisher); local object rd_by_iax_file(stream,finisher) var reg1 object stream; var reg7 rd_by_ix_I* finisher; { var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); var reg5 uintL bytesize = bitsize/8; # genⁿgend viele Bytes in den Bitbuffer ⁿbertragen: {var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize]; var reg4 uintL count; dotimespL(count,bytesize, { var reg3 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof; # nΣchstes Byte holen: *--bitbufferptr = *ptr; # index incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); }); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); # in Zahl umwandeln: return (*finisher)(stream,bitsize,bytesize); eof: # EOF erreicht position_b_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position)*bytesize); return eof_value; }} # UP fⁿr READ-BYTE auf File-Streams fⁿr Integers, Art b : # Fⁿllt den Bitbuffer mit den nΣchsten bitsize Bits. # > stream : File-Stream fⁿr Integers, Art b # > finisher : Beendigungsroutine # < ergebnis : gelesener Integer oder eof_value local object rd_by_ibx_file (object stream, rd_by_ix_I* finisher); local object rd_by_ibx_file(stream,finisher) var reg1 object stream; var reg8 rd_by_ix_I* finisher; { # Nur bei position < eofposition gibt's was zu lesen: if (eq(TheStream(stream)->strm_file_position,TheStream(stream)->strm_file_eofposition)) goto eof; { var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); # bitsize (>0, <8) # genⁿgend viele Bits in den Bitbuffer ⁿbertragen: var reg4 uintL bitindex = posfixnum_to_L(TheStream(stream)->strm_file_bitindex); var reg5 uintL count = bitindex + bitsize; var reg1 uint8 bit_akku; var reg3 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof; # angefangenes Byte holen: bit_akku = (*ptr)>>bitindex; # bitshift := 8-bitindex # Von bit_akku sind die Bits (bitshift-1)..0 gⁿltig. if (count > 8) { # index incrementieren, da gerade *ptr verarbeitet: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); count -= 8; # Noch count (>0) Bits zu holen. {var reg3 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof1; # nΣchstes Byte holen: # (8-bitindex < 8, da sonst count = 0+bitsize < 8 gewesen wΣre!) bit_akku |= (*ptr)<<(8-bitindex); }}# Von bit_akku sind alle 8 Bits gⁿltig. # 8 Bit abspeichern: TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[0] = bit_akku; TheStream(stream)->strm_file_bitindex = fixnum(count); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); # in Zahl umwandeln: return (*finisher)(stream,bitsize,1); eof1: # Wieder zurⁿckpositionieren: position_i_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position)); } eof: # EOF erreicht gewesen return eof_value; } # UP fⁿr READ-BYTE auf File-Streams fⁿr Integers, Art c : # Fⁿllt den Bitbuffer mit den nΣchsten bitsize Bits. # > stream : File-Stream fⁿr Integers, Art c # > finisher : Beendigungsroutine # < ergebnis : gelesener Integer oder eof_value local object rd_by_icx_file (object stream, rd_by_ix_I* finisher); local object rd_by_icx_file(stream,finisher) var reg1 object stream; var reg8 rd_by_ix_I* finisher; { var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); var reg7 uintL bytesize = ceiling(bitsize,8); # genⁿgend viele Bits in den Bitbuffer ⁿbertragen: var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize]; var reg4 uintL count = bitsize; var reg5 uintL bitshift = posfixnum_to_L(TheStream(stream)->strm_file_bitindex); var reg3 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof; if (bitshift==0) { loop { *--bitbufferptr = *ptr; # 8 Bits holen und abspeichern # index incrementieren, da gerade *ptr verarbeitet: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); count -= 8; # Noch count (>0) Bits zu holen. ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof; if (count<=8) break; # Sind damit count Bits fertig? } # Noch count = bitsize mod 8 (>0,<8) Bits zu holen. *--bitbufferptr = *ptr; # count Bits holen und abspeichern } else # 0<bitindex<8 { var reg1 uint16 bit_akku; # angefangenes Byte holen: bit_akku = (*ptr)>>bitshift; bitshift = 8-bitshift; # bitshift := 8-bitindex count -= bitshift; loop { # index incrementieren, da gerade *ptr verarbeitet: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); # Von bit_akku sind die Bits (bitshift-1)..0 gⁿltig. # Noch count (>0) Bits zu holen. {var reg3 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof; # nΣchstes Byte holen: bit_akku |= (uint16)(*ptr)<<bitshift; }# Von bit_akku sind die Bits (7+bitshift)..0 gⁿltig. *--bitbufferptr = (uint8)bit_akku; # 8 Bit abspeichern if (count<=8) break; # Sind damit count Bits fertig? count -= 8; bit_akku = bit_akku>>8; } } TheStream(stream)->strm_file_bitindex = fixnum(count); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); # in Zahl umwandeln: return (*finisher)(stream,bitsize,bytesize); eof: # EOF erreicht position_i_file(stream,posfixnum_to_L(TheStream(stream)->strm_file_position)); return eof_value; } # UP fⁿr WRITE-BYTE auf File-Streams fⁿr Integers, Art a : # Schreibt den Bitbuffer-Inhalt aufs File. local void wr_by_ia (object stream, uintL bitsize, uintL bytesize); local void wr_by_ia(stream,bitsize,bytesize) var reg3 object stream; var uintL bitsize; var reg4 uintL bytesize; { var reg1 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize]; var reg2 uintL count; dotimespL(count,bytesize, { b_file_writebyte(stream,*--bitbufferptr); } ); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); } # UP fⁿr WRITE-BYTE auf File-Streams fⁿr Integers, Art b : # Schreibt den Bitbuffer-Inhalt aufs File. local void wr_by_ib (object stream, uintL bitsize, uintL bytesize); local void wr_by_ib(stream,bitsize,bytesize) var reg4 object stream; var reg6 uintL bitsize; var uintL bytesize; { var reg1 uintL bitshift = posfixnum_to_L(TheStream(stream)->strm_file_bitindex); var reg3 uint16 bit_akku = (uint16)(TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[0])<<bitshift; var reg2 uintL count = bitsize; var reg5 uintB* ptr = b_file_nextbyte(stream); # angefangenes Byte holen: if (!(ptr == (uintB*)NULL)) { bit_akku |= (*ptr)&(bit(bitshift)-1); } count += bitshift; # evtl. einzelnes Byte schreiben: if (count>=8) { b_file_writebyte(stream,(uint8)bit_akku); bit_akku = bit_akku>>8; count -= 8; } # letztes Byte (count Bits) schreiben: if (!(count==0)) { ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) # EOF ? { ptr = b_file_eofbyte(stream); # 1 Byte Platz machen *ptr = (uint8)bit_akku; # Byte schreiben } else # nΣchstes Byte nur teilweise ⁿberschreiben: { var reg3 uint8 diff = (*ptr ^ (uint8)bit_akku) & (uint8)(bit(count)-1); if (diff == 0) goto no_modification; *ptr ^= diff; } set_modified_flag(stream); no_modification: ; } TheStream(stream)->strm_file_bitindex = fixnum(count); # position und evtl. eofposition incrementieren: if (eq(TheStream(stream)->strm_file_eofposition,TheStream(stream)->strm_file_position)) { TheStream(stream)->strm_file_eofposition = fixnum_inc(TheStream(stream)->strm_file_eofposition,1); } TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); } # UP fⁿr WRITE-BYTE auf File-Streams fⁿr Integers, Art c : # Schreibt den Bitbuffer-Inhalt aufs File. local void wr_by_ic (object stream, uintL bitsize, uintL bytesize); local void wr_by_ic(stream,bitsize,bytesize) var reg5 object stream; var reg7 uintL bitsize; var reg8 uintL bytesize; { var reg1 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize]; var reg2 uintL bitshift = posfixnum_to_L(TheStream(stream)->strm_file_bitindex); var reg3 uintL count = bitsize; var reg4 uint16 bit_akku; var reg6 uintB* ptr = b_file_nextbyte(stream); # angefangenes Byte holen: bit_akku = (ptr==(uintB*)NULL ? 0 : (*ptr)&(bit(bitshift)-1) ); count += bitshift; # einzelne Bytes schreiben: loop { bit_akku |= (uint16)(*--bitbufferptr)<<bitshift; if (count<8) break; b_file_writebyte(stream,(uint8)bit_akku); bit_akku = bit_akku>>8; count -= 8; if (count<=bitshift) break; } # letztes Byte (count Bits) schreiben: if (!(count==0)) { ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) # EOF ? { ptr = b_file_eofbyte(stream); # 1 Byte Platz machen *ptr = (uint8)bit_akku; # Byte schreiben } else # nΣchstes Byte nur teilweise ⁿberschreiben: { var reg3 uint8 diff = (*ptr ^ (uint8)bit_akku) & (uint8)(bit(count)-1); if (diff == 0) goto no_modification; *ptr ^= diff; } set_modified_flag(stream); no_modification: ; } TheStream(stream)->strm_file_bitindex = fixnum(count); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); } # Typ wr_by_ix: eines dieser drei Unterprogramme: typedef void wr_by_ix (object stream, uintL bitsize, uintL bytesize); # UP fⁿr WRITE-BYTE auf File-Streams fⁿr Integers, Art u : # Legt das Objekt (ein Integer >=0) als bytesize Bytes im Bitbuffer ab. # > stream : File-Stream fⁿr Integers, Art u # > obj : auszugebendes Objekt # > finisher : Beendigungsroutine local void wr_by_ixu_file (object stream, object obj, wr_by_ix* finisher); local void wr_by_ixu_file(stream,obj,finisher) var reg1 object stream; var reg5 object obj; var reg8 wr_by_ix* finisher; { # obj ⁿberprⁿfen: if (!integerp(obj)) { fehler_wr_integer(stream,obj); } if (!positivep(obj)) { fehler_bad_integer(stream,obj); } # obj ist jetzt ein Integer >=0 {var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); var reg6 uintL bytesize = ceiling(bitsize,8); # obj in den Bitbuffer ⁿbertragen: { var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize]; var reg4 uintL count = bytesize; if (posfixnump(obj)) # obj ist ein Fixnum >=0 { var reg3 uintL wert = posfixnum_to_L(obj); # wert < 2^bitsize ⁿberprⁿfen: if (!((bitsize>=oint_data_len) || (wert < bit(bitsize)))) { fehler_bad_integer(stream,obj); } # wert im Bitbuffer ablegen: until (wert==0) { *--bitbufferptr = (uint8)wert; wert = wert>>8; count--; } } else # obj ist ein Bignum >0 { var reg5 uintL len = (uintL)(TheBignum(obj)->length); # obj < 2^bitsize ⁿberprⁿfen: if (!((floor(bitsize,intDsize) >= len) || ((floor(bitsize,intDsize) == len-1) && (TheBignum(obj)->data[0] < bit(bitsize%intDsize)) ) ) ) { fehler_bad_integer(stream,obj); } #if BIG_ENDIAN_P {var reg3 uintB* ptr = (uintB*)&TheBignum(obj)->data[len]; # Digit-LΣnge in Byte-LΣnge umrechnen: len = (intDsize/8)*len; #define CHECK_NEXT_BYTE(i) \ if (!( ((uintB*)(&TheBignum(obj)->data[0]))[i] ==0)) goto len_ok; \ len--; DOCONSTTIMES(intDsize/8,CHECK_NEXT_BYTE); # CHECK_NEXT_BYTE(0..intDsize/8-1) #undef CHECK_NEXT_BYTE len_ok: # obj im Bitbuffer ablegen: count = count - len; dotimespL(len,len, { *--bitbufferptr = *--ptr; } ); } #else {var reg3 uintD* ptr = &TheBignum(obj)->data[len]; len--; count -= (intDsize/8)*len; dotimesL(len,len, { var reg2 uintD digit = *--ptr; doconsttimes(intDsize/8, { *--bitbufferptr = (uintB)digit; digit = digit >> 8; } ); }); {var reg2 uintD digit = *--ptr; doconsttimes(intDsize/8, { if (digit==0) goto ok; *--bitbufferptr = (uintB)digit; digit = digit >> 8; count--; }); ok: ; }} #endif } dotimesL(count,count, { *--bitbufferptr = 0; } ); } (*finisher)(stream,bitsize,bytesize); }} # UP fⁿr WRITE-BYTE auf File-Streams fⁿr Integers, Art s : # Legt das Objekt (ein Integer) als bytesize Bytes im Bitbuffer ab. # > stream : File-Stream fⁿr Integers, Art s # > obj : auszugebendes Objekt # > finisher : Beendigungsroutine local void wr_by_ixs_file (object stream, object obj, wr_by_ix* finisher); local void wr_by_ixs_file(stream,obj,finisher) var reg1 object stream; var reg5 object obj; var reg8 wr_by_ix* finisher; { # obj ⁿberprⁿfen: if (!integerp(obj)) { fehler_wr_integer(stream,obj); } # obj ist jetzt ein Integer {var reg6 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); var reg6 uintL bytesize = ceiling(bitsize,8); # obj in den Bitbuffer ⁿbertragen: { var reg2 uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_file_bitbuffer)->data[bytesize]; var reg4 uintL count = bytesize; var reg6 uintL sign = (sintL)R_sign(obj); if (fixnump(obj)) # obj ist ein Fixnum { var reg3 uintL wert = fixnum_to_L(obj); # >=0 oder <0, je nach sign # 0 <= wert < 2^(bitsize-1) bzw. -2^(bitsize-1) <= wert < 0 ⁿberprⁿfen: wert = wert^sign; if (!((bitsize>oint_data_len) || (wert < bit(bitsize-1)))) { fehler_bad_integer(stream,obj); } # wert^sign im Bitbuffer ablegen: until (wert == 0) { *--bitbufferptr = (uint8)(wert^sign); wert = wert>>8; count--; } dotimesL(count,count, { *--bitbufferptr = (uint8)sign; } ); } else # obj ist ein Bignum { var reg5 uintL len = (uintL)(TheBignum(obj)->length); # -2^(bitsize-1) <= obj < 2^(bitsize-1) ⁿberprⁿfen: if (!((floor(bitsize,intDsize) >= len) || ((bitsize > intDsize*(len-1)) && ((TheBignum(obj)->data[0] ^ (uintD)sign) < bit((bitsize%intDsize)-1)) ) ) ) { fehler_bad_integer(stream,obj); } #if BIG_ENDIAN_P {var reg3 uintB* ptr = (uintB*)&TheBignum(obj)->data[len]; # Digit-LΣnge in Byte-LΣnge umrechnen: len = (intDsize/8)*len; #define CHECK_NEXT_BYTE(i) \ if (!( ((uintB*)(&TheBignum(obj)->data[0]))[i] == (uintB)sign)) goto len_ok; \ len--; DOCONSTTIMES(intDsize/8,CHECK_NEXT_BYTE); # CHECK_NEXT_BYTE(0..intDsize/8-1) #undef CHECK_NEXT_BYTE len_ok: # obj im Bitbuffer ablegen: count = count - len; dotimespL(len,len, { *--bitbufferptr = *--ptr; } ); } #else {var reg3 uintD* ptr = &TheBignum(obj)->data[len]; len--; count -= (intDsize/8)*len; dotimesL(len,len, { var reg2 uintD digit = *--ptr; doconsttimes(intDsize/8, { *--bitbufferptr = (uintB)digit; digit = digit >> 8; } ); }); {var reg2 sintD digit = *--ptr; doconsttimes(intDsize/8, { if (digit == (sintD)sign) goto ok; *--bitbufferptr = (uintB)digit; digit = digit >> 8; count--; }); ok: ; }} #endif dotimesL(count,count, { *--bitbufferptr = (uintB)sign; } ); } } (*finisher)(stream,bitsize,bytesize); }} # READ-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art au : local object rd_by_iau_file (object stream); local object rd_by_iau_file(stream) var reg1 object stream; { return rd_by_iax_file(stream,&rd_by_iu_I); } # WRITE-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art au : local void wr_by_iau_file (object stream, object obj); local void wr_by_iau_file(stream,obj) var reg1 object stream; var reg2 object obj; { wr_by_ixu_file(stream,obj,&wr_by_ia); } # READ-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art as : local object rd_by_ias_file (object stream); local object rd_by_ias_file(stream) var reg1 object stream; { return rd_by_iax_file(stream,&rd_by_is_I); } # WRITE-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art as : local void wr_by_ias_file (object stream, object obj); local void wr_by_ias_file(stream,obj) var reg1 object stream; var reg2 object obj; { wr_by_ixs_file(stream,obj,&wr_by_ia); } # READ-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art bu : local object rd_by_ibu_file (object stream); local object rd_by_ibu_file(stream) var reg1 object stream; { return rd_by_ibx_file(stream,&rd_by_iu_I); } # WRITE-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art bu : local void wr_by_ibu_file (object stream, object obj); local void wr_by_ibu_file(stream,obj) var reg1 object stream; var reg2 object obj; { wr_by_ixu_file(stream,obj,&wr_by_ib); } # READ-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art bs : local object rd_by_ibs_file (object stream); local object rd_by_ibs_file(stream) var reg1 object stream; { return rd_by_ibx_file(stream,&rd_by_is_I); } # WRITE-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art bs : local void wr_by_ibs_file (object stream, object obj); local void wr_by_ibs_file(stream,obj) var reg1 object stream; var reg2 object obj; { wr_by_ixs_file(stream,obj,&wr_by_ib); } # READ-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art cu : local object rd_by_icu_file (object stream); local object rd_by_icu_file(stream) var reg1 object stream; { return rd_by_icx_file(stream,&rd_by_iu_I); } # WRITE-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art cu : local void wr_by_icu_file (object stream, object obj); local void wr_by_icu_file(stream,obj) var reg1 object stream; var reg2 object obj; { wr_by_ixu_file(stream,obj,&wr_by_ic); } # READ-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art cs : local object rd_by_ics_file (object stream); local object rd_by_ics_file(stream) var reg1 object stream; { return rd_by_icx_file(stream,&rd_by_is_I); } # WRITE-BYTE - Pseudofunktion fⁿr File-Streams fⁿr Integers, Art cs : local void wr_by_ics_file (object stream, object obj); local void wr_by_ics_file(stream,obj) var reg1 object stream; var reg2 object obj; { wr_by_ixs_file(stream,obj,&wr_by_ic); } # WRITE-BYTE-SEQUENCE fⁿr File-Streams fⁿr Integers, Art au, bitsize = 8 : local uintB* write_byte_array_iau8_file (object stream, uintB* byteptr, uintL len); local uintB* write_byte_array_iau8_file(stream,byteptr,len) var reg5 object stream; var reg2 uintB* byteptr; var reg9 uintL len; { var reg6 uintL remaining = len; var reg1 uintB* ptr; do # Noch remaining>0 Bytes abzulegen. { ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto eof_reached; {var reg8 object eofindex = TheStream(stream)->strm_file_eofindex; var reg7 uintL next = # so viel wie noch in den Buffer oder bis EOF pa▀t (eq(eofindex,T) ? strm_file_bufflen : posfixnum_to_L(eofindex)) - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index); # > 0 ! if (next > remaining) { next = remaining; } # next Bytes in den Buffer kopieren: {var reg4 uintL count; dotimespL(count,next, { var reg3 uintB b = *byteptr++; # nΣchstes Byte if (!(*ptr == b)) { *ptr = b; set_modified_flag(stream); } # in den Buffer ptr++; }); } remaining = remaining - next; # index incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,next); }} until (remaining == 0); if (FALSE) eof_reached: # Schreiben am EOF, eofindex = index do # Noch remaining>0 Bytes abzulegen. { var reg7 uintL next = # so viel wie noch Platz im Buffer ist strm_file_bufflen - (uintW)posfixnum_to_L(TheStream(stream)->strm_file_index); if (next==0) { # Buffer mu▀ neu gefⁿllt werden. Da nach ihm sowieso EOF kommt, # genⁿgt es, ihn hinauszuschreiben: if (modified_flag(stream)) { b_file_half_flush(stream); } TheStream(stream)->strm_file_buffstart = fixnum_inc(TheStream(stream)->strm_file_buffstart,strm_file_bufflen); TheStream(stream)->strm_file_eofindex = Fixnum_0; # eofindex := 0 TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert # Dann nochmals versuchen: next = strm_file_bufflen; } if (next > remaining) { next = remaining; } # next Bytes in den Buffer kopieren: {var reg3 uintL count; ptr = &TheSstring(TheStream(stream)->strm_file_buffer)->data[(uintW)posfixnum_to_L(TheStream(stream)->strm_file_index)]; dotimespL(count,next, { *ptr++ = *byteptr++; } ); set_modified_flag(stream); } remaining = remaining - next; # index und eofindex incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,next); TheStream(stream)->strm_file_eofindex = fixnum_inc(TheStream(stream)->strm_file_eofindex,next); } until (remaining == 0); # position incrementieren: TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,len); return byteptr; } # File-Stream allgemein # ===================== # UP: Positioniert einen (offenen) File-Stream an den Anfang. # position_file_start(stream); # > stream : (offener) File-Stream. # verΣndert in stream: index, eofindex, buffstart, ..., position, rd_ch_last local void position_file_start (object stream); local void position_file_start(stream) var reg1 object stream; { position_b_file(stream, TheStream(stream)->strmflags & strmflags_ib_B # Integer-Stream vom Typ b ? ? sizeof(uintL) : 0 # ja -> Position 4, sonst Position 0 ); if (TheStream(stream)->strmflags & (strmflags_ib_B | strmflags_ic_B)) # Integer-Stream der Art b,c { TheStream(stream)->strm_file_bitindex = Fixnum_0; } # bitindex := 0 TheStream(stream)->strm_file_position = Fixnum_0; # position := 0 TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL } # UP: Positioniert einen (offenen) File-Stream an eine gegebene Position. # position_file(stream,position); # > stream : (offener) File-Stream. # > position : neue (logische) Position # verΣndert in stream: index, eofindex, buffstart, ..., position, rd_ch_last local void position_file (object stream, uintL position); local void position_file(stream,position) var reg1 object stream; var reg2 uintL position; { var reg3 uintB flags = TheStream(stream)->strmflags; if (flags & strmflags_i_B) # Integer-Stream ? { if (flags & strmflags_ia_B) # Art a { var reg4 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); position_b_file(stream,position*(bitsize/8)); } else # Art b,c { position_i_file(stream,position); } } else { if (TheStream(stream)->strmtype == strmtype_ch_file) # Character-Stream ? { position_b_file(stream,position*char_size); } else # String-Char-Stream { position_b_file(stream,position); } TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL } TheStream(stream)->strm_file_position = fixnum(position); } # UP: Positioniert einen (offenen) File-Stream ans Ende. # position_file_end(stream); # > stream : (offener) File-Stream. # verΣndert in stream: index, eofindex, buffstart, ..., position, rd_ch_last local void position_file_end (object stream); local void position_file_end(stream) var reg1 object stream; { # evtl. Buffer hinausschreiben: if (modified_flag(stream)) { b_file_flush(stream); } {var reg2 uintL eofbytes; # EOF-Position, gemessen in Bytes # ans Ende positionieren: begin_system_call(); file_lseek(stream,0,SEEK_END,eofbytes=); end_system_call(); # logische Position berechnen und eofbytes korrigieren: { var reg5 uintL position; # logische Position var reg6 uintL eofbits = 0; # Bit-ErgΣnzung zu eofbytes var reg3 uintB flags = TheStream(stream)->strmflags; if (flags & strmflags_i_B) # Integer-Stream ? { var reg4 uintL bitsize = posfixnum_to_L(TheStream(stream)->strm_file_bitsize); if (flags & strmflags_ia_B) # Art a { var reg4 uintL bytesize = bitsize/8; position = floor(eofbytes,bytesize); eofbytes = position*bytesize; } elif (flags & strmflags_ib_B) # Art b { eofbytes -= sizeof(uintL); # Header berⁿcksichtigen # Ist die gemerkte EOF-Position plausibel? position = posfixnum_to_L(TheStream(stream)->strm_file_eofposition); if (!(ceiling(position*bitsize,8)==eofbytes)) # ja -> verwende sie { position = floor(eofbytes*8,bitsize); } # nein -> rechne sie neu aus # Rechne eofbytes und eofbits neu aus: eofbytes = floor(position*bitsize,8); eofbits = (position*bitsize)%8; eofbytes += sizeof(uintL); # Header berⁿcksichtigen } else # Art c { position = floor(eofbytes*8,bitsize); eofbytes = floor(position*bitsize,8); eofbits = (position*bitsize)%8; } } else { if (TheStream(stream)->strmtype == strmtype_ch_file) # Character-Stream ? { position = floor(eofbytes,char_size); eofbytes = position*char_size; } else # String-Char-Stream { position = eofbytes; } } # auf den Anfang des letzten Sectors positionieren: { var reg4 uintL buffstart; begin_system_call(); file_lseek(stream,floor(eofbytes,strm_file_bufflen)*strm_file_bufflen,SEEK_SET,buffstart=); end_system_call(); TheStream(stream)->strm_file_buffstart = fixnum(buffstart); } # Sector lesen: TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, unmodifiziert { var reg4 uintL eofindex = eofbytes % strm_file_bufflen; if (!((eofindex==0) && (eofbits==0))) # EOF am Sectorende -> brauche nichts zu lesen { b_file_nextbyte(stream); # Jetzt ist index=0. index und eofindex setzen: TheStream(stream)->strm_file_index = fixnum(eofindex); if (!(eofbits==0)) { eofindex += 1; } TheStream(stream)->strm_file_eofindex = fixnum(eofindex); } } if (flags & (strmflags_ib_B | strmflags_ic_B)) # Integer-Stream der Art b,c { TheStream(stream)->strm_file_bitindex = fixnum(eofbits); } # position setzen: TheStream(stream)->strm_file_position = fixnum(position); TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL }}} # UP: erzeugt ein File-Stream # make_file_stream(handle,direction,type,eltype_size,append_flag) # > handle: Handle des ge÷ffneten Files # > STACK_1: Filename, ein Pathname # > STACK_0: Truename, ein Pathname # > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE) # > type: nΣhere Typinfo # (STRMTYPE_SCH_FILE oder STRMTYPE_CH_FILE oder # STRMTYPE_IU_FILE oder STRMTYPE_IS_FILE) # > eltype_size: (bei Integer-Streams) Gr÷▀e der Elemente in Bits, # ein Fixnum >0 und <intDsize*uintC_max # > append_flag: TRUE falls der Stream gleich ans Ende positioniert werden # soll, FALSE sonst # < ergebnis: File-Stream (oder evtl. File-Handle-Stream) # < STACK: aufgerΣumt # kann GC ausl÷sen global object make_file_stream (object handle, uintB direction, uintB type, object eltype_size, boolean append_flag); global object make_file_stream(handle,direction,type,eltype_size,append_flag) var reg9 object handle; var reg8 uintB direction; var reg4 uintB type; var reg9 object eltype_size; var reg10 boolean append_flag; { #if defined(HANDLES) # Nur regulΣre Files zu gebufferten File-Streams machen. # Alles andere gibt File-Handle-Streams, weil vermutlich lseek() nicht geht. if (!nullp(handle)) { #if defined(UNIX) || defined(MSDOS) # || defined(RISCOS) var struct stat statbuf; begin_system_call(); if (!( fstat(TheHandle(handle),&statbuf) ==0)) { OS_error(); } end_system_call(); if (!S_ISREG(statbuf.st_mode)) #endif #ifdef AMIGAOS var reg1 LONG not_regular_p; begin_system_call(); not_regular_p = IsInteractive(TheHandle(handle)); # Behandlung nicht interaktiver, nicht regulΣrer Files?? end_system_call(); if (not_regular_p) #endif { if (((type == strmtype_sch_file) || ((type == strmtype_iu_file) && eq(eltype_size,fixnum(8))) ) && !append_flag ) { return make_handle_stream(handle,direction); } else { # Truename noch in STACK_0, Wert fⁿr Slot PATHNAME von FILE-ERROR pushSTACK(STACK_0); pushSTACK(S(open)); fehler(file_error, DEUTSCH ? "~: ~ ist kein regulΣres File." : ENGLISH ? "~: ~ is not a regular file." : FRANCAIS ? "~: ~ n'est pas un fichier rΘgulier." : "" ); } } } #endif { # Flags: var reg6 uintB flags = (direction==0 ? 0 : # bei Modus :PROBE sind alle Flags =0 # sonst: (direction>=4 ? strmflags_open_B : strmflags_rd_B) # Modus :INPUT[-IMMUTABLE] -> nur Read, sonst Read/Write & (type>=strmtype_iu_file ? strmflags_by_B : strmflags_ch_B) # auf Integers oder Characters #ifdef IMMUTABLE | (direction==3 ? strmflags_immut_B : 0) # Modus :INPUT-IMMUTABLE ? #endif ); # Art von Integer-Streams: var reg5 uintB art; # LΣnge: var reg7 uintC len = strm_len; # Das hat jeder Stream len += 8; # Das haben alle File-Streams if (type==strmtype_sch_file) { len += 1; } # Das haben die File-Streams fⁿr String-Chars elif (type>=strmtype_iu_file) { len += 2; # Das haben die File-Streams fⁿr Integers {var reg1 uintL bitsize = posfixnum_to_L(eltype_size); if ((bitsize%8)==0) { art = strmflags_ia_bit_B; } # Art a else { len += 1; # Arten b,c if (bitsize<8) { art = strmflags_ib_bit_B; len += 1; } # Art b else { art = strmflags_ic_bit_B; } # Art c } } flags |= bit(art); # Art in die Flags mit aufnehmen } #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT pushSTACK(handle); # Handle retten #endif {# Stream allozieren: var reg1 object stream = allocate_stream(flags,type,len); # und fⁿllen: # Komponenten aller Streams: switch (type) { case strmtype_sch_file: TheStream(stream)->strm_rd_ch = P(rd_ch_sch_file); TheStream(stream)->strm_wr_ch = P(wr_ch_sch_file); #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_sch_file); #endif break; case strmtype_ch_file: TheStream(stream)->strm_rd_ch = P(rd_ch_ch_file); TheStream(stream)->strm_wr_ch = P(wr_ch_ch_file); #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy_nogc); #endif break; case strmtype_iu_file: TheStream(stream)->strm_rd_by = (art==strmflags_ia_bit_B ? P(rd_by_iau_file) : art==strmflags_ib_bit_B ? P(rd_by_ibu_file) : P(rd_by_icu_file) ); TheStream(stream)->strm_wr_by = (art==strmflags_ia_bit_B ? P(wr_by_iau_file) : art==strmflags_ib_bit_B ? P(wr_by_ibu_file) : P(wr_by_icu_file) ); break; case strmtype_is_file: TheStream(stream)->strm_rd_by = (art==strmflags_ia_bit_B ? P(rd_by_ias_file) : art==strmflags_ib_bit_B ? P(rd_by_ibs_file) : P(rd_by_ics_file) ); TheStream(stream)->strm_wr_by = (art==strmflags_ia_bit_B ? P(wr_by_ias_file) : art==strmflags_ib_bit_B ? P(wr_by_ibs_file) : P(wr_by_ics_file) ); break; default: NOTREACHED } # Default fⁿr READ-BYTE-Pseudofunktion: if ((flags & strmflags_rd_by_B)==0) { TheStream(stream)->strm_rd_by = P(rd_by_dummy); } # Default fⁿr WRITE-BYTE-Pseudofunktion: if ((flags & strmflags_wr_by_B)==0) { TheStream(stream)->strm_wr_by = P(wr_by_dummy); } # Default fⁿr READ-CHAR-Pseudofunktion: if ((flags & strmflags_rd_ch_B)==0) { TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); } TheStream(stream)->strm_rd_ch_last = NIL; # Lastchar := NIL # Default fⁿr WRITE-CHAR-Pseudofunktion: if ((flags & strmflags_wr_ch_B)==0) { TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif } TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; # Line Position := 0 # Komponenten von File-Streams: #if defined(FOREIGN_HANDLE) || !NIL_IS_CONSTANT handle = popSTACK(); # Handle zurⁿck #endif TheStream(stream)->strm_file_truename = popSTACK(); # Truename eintragen TheStream(stream)->strm_file_name = popSTACK(); # Filename eintragen if (!nullp(handle)) # Handle=NIL -> Rest bereits mit NIL initialisiert, fertig { TheStream(stream)->strm_file_handle = handle; # Handle eintragen TheStream(stream)->strm_file_buffstart = Fixnum_0; # buffstart := 0 # Buffer allozieren: pushSTACK(stream); {var reg2 object buffer = allocate_string(strm_file_bufflen); # neuer String stream = popSTACK(); TheStream(stream)->strm_file_buffer = buffer; } TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL TheStream(stream)->strm_file_index = Fixnum_0; # index := 0, Buffer unmodifiziert TheStream(stream)->strm_file_position = Fixnum_0; # position := 0 if (type==strmtype_sch_file) # File-Stream fⁿr String-Chars { TheStream(stream)->strm_sch_file_lineno = Fixnum_1; } elif (type>=strmtype_iu_file) # File-Stream fⁿr Integers { TheStream(stream)->strm_file_bitsize = eltype_size; # Bitbuffer allozieren: pushSTACK(stream); {var reg2 object bitbuffer = allocate_bit_vector(ceiling(posfixnum_to_L(eltype_size),8)*8); stream = popSTACK(); TheStream(stream)->strm_file_bitbuffer = bitbuffer; } if (!(art==strmflags_ia_bit_B)) # Arten b,c { TheStream(stream)->strm_file_bitindex = Fixnum_0; # bitindex := 0 if (art==strmflags_ib_bit_B) # Art b { # eofposition lesen: var reg3 uintL eofposition = 0; var reg2 uintC count; for (count=0; count < 8*sizeof(uintL); count += 8 ) { var reg1 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) goto too_short; eofposition |= ((*ptr) << count); # index incrementieren, da gerade *ptr verarbeitet: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); } if (FALSE) { too_short: # File zu kurz (< sizeof(uintL) Bytes) if ((TheStream(stream)->strmflags & strmflags_wr_by_B) == 0) # Read-Only-Stream? goto bad_eofposition; # File Read/Write -> setze eofposition := 0 eofposition = 0; position_b_file(stream,0); # an Position 0 positionieren {var reg2 uintC count; # und eofposition = 0 herausschreiben dotimespC(count,sizeof(uintL), { b_file_writebyte(stream,0); } ); }} elif (eofposition > (uintL)(bitm(oint_data_len)-1)) { bad_eofposition: # Keine gⁿltige EOF-Position. # File schlie▀en und Error melden: TheStream(stream)->strmflags &= ~strmflags_wr_by_B; # Stream Read-Only machen pushSTACK(stream); stream_close(&STACK_0); # STACK_0 = Wert fⁿr Slot STREAM von STREAM-ERROR pushSTACK(TheStream(STACK_0)->strm_file_truename); fehler(stream_error, DEUTSCH ? "File ~ hat nicht das Format eines Integer-Files." : ENGLISH ? "file ~ is not an integer file" : FRANCAIS ? "Le fichier ~ n'a pas le format d'un fichier d'entiers." : "" ); } # Auf die gelesene EOF-Position verlassen wir uns jetzt! TheStream(stream)->strm_file_eofposition = fixnum(eofposition); } } } # Liste der offenen File-Streams um stream erweitern: pushSTACK(stream); {var reg1 object new_cons = allocate_cons(); Car(new_cons) = stream = popSTACK(); Cdr(new_cons) = O(open_files); O(open_files) = new_cons; }# Modus :APPEND behandeln: if (append_flag) { position_file_end(stream); } } return stream; }}} # UP: Bereitet das Schlie▀en eines File-Streams vor. # Dabei wird der Buffer und evtl. eofposition hinausgeschrieben. # file_flush(stream); # > stream : (offener) File-Stream. # verΣndert in stream: index, eofindex, buffstart, ... local void file_flush (object stream); local void file_flush(stream) var reg1 object stream; { # Bei Integer-Streams (Art b) eofposition abspeichern: if (TheStream(stream)->strmflags & strmflags_ib_B) if (TheStream(stream)->strmflags & strmflags_wr_by_B) # nur falls nicht Read-Only { position_b_file(stream,0); # an Position 0 positionieren {var reg2 uintL eofposition = posfixnum_to_L(TheStream(stream)->strm_file_eofposition); var reg3 uintC count; dotimespC(count,sizeof(uintL), { b_file_writebyte(stream,(uintB)eofposition); eofposition = eofposition>>8; }); }} # evtl. Buffer hinausschreiben: if (modified_flag(stream)) { b_file_flush(stream); } # Nun ist das modified_flag gel÷scht. } # UP: Bringt den wartenden Output eines File-Stream ans Ziel. # Schreibt dazu den Buffer des File-Streams (auch physikalisch) aufs File. # finish_output_file(stream); # > stream : File-Stream. # verΣndert in stream: handle, index, eofindex, buffstart, ..., rd_ch_last # kann GC ausl÷sen local void finish_output_file (object stream); local void finish_output_file(stream) var reg1 object stream; { # Handle=NIL (Stream bereits geschlossen) -> fertig: if (nullp(TheStream(stream)->strm_file_handle)) { return; } # kein File mit Schreibzugriff -> gar nichts zu tun: if (!(TheStream(stream)->strmflags & strmflags_wr_B)) { return; } # evtl. Buffer und evtl. eofposition hinausschreiben: file_flush(stream); # Nun ist das modified_flag gel÷scht. #ifdef ATARI # File schlie▀en (GEMDOS schreibt physikalisch): {var reg2 sintW ergebnis = GEMDOS_close(TheHandle(TheStream(stream)->strm_file_handle)); if (ergebnis<0) { OS_error(ergebnis); } # Fehler aufgetreten? } # File neu ÷ffnen: pushSTACK(stream); # stream retten pushSTACK(TheStream(stream)->strm_file_truename); # Filename {# Directory existiert schon: var reg3 object namestring = assume_dir_exists(); # Filename als ASCIZ-String var reg2 sintW errorcode; errorcode = # Datei neu ÷ffnen, Modus 2 (Read/Write) GEMDOS_open(TheAsciz(namestring),2); if (errorcode < 0) { OS_error(errorcode); } # Error melden # Nun enthΣlt errorcode das Handle des ge÷ffneten Files. skipSTACK(1); stream = popSTACK(); # stream zurⁿck # neues Handle eintragen: TheStream(stream)->strm_file_handle = allocate_handle(errorcode); } #endif #ifdef MSDOS # File-Handle duplizieren und schlie▀en: { var reg3 uintW handle = TheHandle(TheStream(stream)->strm_file_handle); begin_system_call(); {var reg2 sintW handle2 = dup(handle); if (handle2 < 0) { OS_error(); } # Error melden if ( CLOSE(handle2) <0) { OS_error(); } end_system_call(); }} #endif #ifdef RISCOS # || MSDOS, wenn wir da nicht schon was besseres hΣtten # File schlie▀en (DOS schreibt physikalisch): begin_system_call(); if ( CLOSE(TheHandle(TheStream(stream)->strm_file_handle)) <0) { OS_error(); } end_system_call(); # File neu ÷ffnen: pushSTACK(stream); # stream retten pushSTACK(TheStream(stream)->strm_file_truename); # Filename {# Directory existiert schon: var reg3 object namestring = assume_dir_exists(); # Filename als ASCIZ-String var reg2 sintW handle; begin_system_call(); handle = OPEN(TheAsciz(namestring),O_RDWR); # Datei neu ÷ffnen if (handle < 0) { OS_error(); } # Error melden #ifdef MSDOS setmode(handle,O_BINARY); #endif end_system_call(); # Nun enthΣlt handle das Handle des ge÷ffneten Files. skipSTACK(1); stream = popSTACK(); # stream zurⁿck # neues Handle eintragen: TheStream(stream)->strm_file_handle = allocate_handle(handle); } #endif #ifdef UNIX #ifdef HAVE_FSYNC begin_system_call(); if (!( fsync(TheHandle(TheStream(stream)->strm_file_handle)) ==0)) { OS_error(); } end_system_call(); #endif #endif #ifdef AMIGAOS #if 0 # Manche Devices vertragen es nicht, wenn man ge÷ffnete Dateien # zu- und wieder aufmacht. Z.B. bei Pipes hat das eine besondere # Bedeutung. begin_system_call(); {var reg1 Handle handle = TheHandle(TheStream(stream)->strm_file_handle); if (!IsInteractive(handle)) { # File schlie▀en (OS schreibt physikalisch): Close(handle); # File neu ÷ffnen: pushSTACK(stream); # stream retten pushSTACK(TheStream(stream)->strm_file_truename); # Filename {# Directory existiert schon, Datei neu ÷ffnen: var reg2 object namestring = assume_dir_exists(); # Filename als ASCIZ-String handle = Open(TheAsciz(namestring),MODE_OLDFILE); if (handle==NULL) { OS_error(); } # Error melden skipSTACK(1); stream = popSTACK(); # stream zurⁿck # neues Handle eintragen: TheHandle(TheStream(stream)->strm_file_handle) = handle; } }} end_system_call(); #endif #endif # und neu positionieren: {var reg2 uintL position = posfixnum_to_L(TheStream(stream)->strm_file_buffstart) + posfixnum_to_L(TheStream(stream)->strm_file_index); TheStream(stream)->strm_file_buffstart = Fixnum_0; # buffstart := 0 TheStream(stream)->strm_file_index = Fixnum_0; # index := 0 TheStream(stream)->strm_file_eofindex = NIL; # eofindex := NIL position_b_file(stream,position); }# Komponenten position, ..., lastchar bleiben unverΣndert } # UP: Bringt den wartenden Output eines File-Stream ans Ziel. # Schreibt dazu den Buffer des File-Streams (auch physikalisch) aufs File. # force_output_file(stream); # > stream : File-Stream. # verΣndert in stream: handle, index, eofindex, buffstart, ..., rd_ch_last # kann GC ausl÷sen #define force_output_file finish_output_file # UP: ErklΣrt einen File-Stream fⁿr geschlossen. # closed_file(stream); # > stream : (offener) File-Stream. # verΣndert in stream: alle Komponenten au▀er name und truename local void closed_file (object stream); local void closed_file(stream) var reg1 object stream; { TheStream(stream)->strm_file_handle = NIL; # Handle wird ungⁿltig TheStream(stream)->strm_file_buffer = NIL; # Buffer freimachen TheStream(stream)->strm_file_buffstart = NIL; # buffstart l÷schen (unn÷tig) TheStream(stream)->strm_file_eofindex = NIL; # eofindex l÷schen (unn÷tig) TheStream(stream)->strm_file_index = NIL; # index l÷schen (unn÷tig) TheStream(stream)->strm_file_position = NIL; # position l÷schen (unn÷tig) if (TheStream(stream)->strmflags & strmflags_i_B) { TheStream(stream)->strm_file_bitsize = NIL; # bitsize l÷schen (unn÷tig) TheStream(stream)->strm_file_bitbuffer = NIL; # Bitbuffer freimachen } } # UP: Schlie▀t einen File-Stream. # close_file(stream); # > stream : File-Stream. # verΣndert in stream: alle Komponenten au▀er name und truename local void close_file (object stream); local void close_file(stream) var reg1 object stream; { # Handle=NIL (Stream bereits geschlossen) -> fertig: if (nullp(TheStream(stream)->strm_file_handle)) { return; } # evtl. Buffer und evtl. eofposition hinausschreiben: file_flush(stream); # Nun ist das modified_flag gel÷scht. # File schlie▀en: #ifdef ATARI { var reg2 sintW ergebnis = GEMDOS_close(TheHandle(TheStream(stream)->strm_file_handle)); if (ergebnis<0) # Fehler aufgetreten? # Fehler beim Schlie▀en abfragen, dabei die "weniger schlimmen" # GEMDOS_close_DiskChange (Diskettenwechsel) und # GEMDOS_close_BadHandle (ungⁿltige Handle-Nummer) # vorⁿbergehend ignorieren und verz÷gert ausgeben: { if ((ergebnis==GEMDOS_close_DiskChange)||(ergebnis==GEMDOS_close_BadHandle)) # harmloser Fehler? { closed_file(stream); close_dummys(stream); } OS_error(ergebnis); } } #endif #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) begin_system_call(); if (!( CLOSE(TheHandle(TheStream(stream)->strm_file_handle)) ==0)) { OS_error(); } end_system_call(); #endif #ifdef AMIGAOS begin_system_call(); Close(TheHandle(TheStream(stream)->strm_file_handle)); end_system_call(); #endif # Komponenten ungⁿltig machen (close_dummys kommt spΣter): closed_file(stream); # stream aus der Liste aller offenen File-Streams streichen: O(open_files) = deleteq(O(open_files),stream); } # Synonym-Stream # ============== # ZusΣtzliche Komponenten: # define strm_synonym_symbol strm_other[0] # Symbol, auf dessen Wert verwiesen wird # Macro: Liefert den Wert eines Symbols, ein Stream. # get_synonym_stream(sym) # > sym: Symbol # < ergebnis: sein Wert, ein Stream #define get_synonym_stream(sym) \ ((!mstreamp(Symbol_value(sym))) ? \ (fehler_value_stream(sym), unbound) : \ Symbol_value(sym) \ ) # READ-BYTE - Pseudofunktion fⁿr Synonym-Streams: local object rd_by_synonym (object stream); local object rd_by_synonym(stream) var reg2 object stream; { check_SP(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; return read_byte(get_synonym_stream(symbol)); }} # WRITE-BYTE - Pseudofunktion fⁿr Synonym-Streams: local void wr_by_synonym (object stream, object obj); local void wr_by_synonym(stream,obj) var reg2 object stream; var reg3 object obj; { check_SP(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; write_byte(get_synonym_stream(symbol),obj); }} # READ-CHAR - Pseudofunktion fⁿr Synonym-Streams: local object rd_ch_synonym (object* stream_); local object rd_ch_synonym(stream_) var reg3 object* stream_; { check_SP(); check_STACK(); { var reg2 object stream = *stream_; var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; pushSTACK(get_synonym_stream(symbol)); {var reg1 object ergebnis = read_char(&STACK_0); skipSTACK(1); return ergebnis; }}} # WRITE-CHAR - Pseudofunktion fⁿr Synonym-Streams: local void wr_ch_synonym (object* stream_, object obj); local void wr_ch_synonym(stream_,obj) var reg3 object* stream_; var reg4 object obj; { check_SP(); check_STACK(); {var reg2 object stream = *stream_; var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; pushSTACK(get_synonym_stream(symbol)); write_char(&STACK_0,obj); skipSTACK(1); }} #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr Synonym-Streams: local void wr_ss_synonym (object* stream_, object string, uintL start, uintL len); local void wr_ss_synonym(stream_,string,start,len) var reg1 object* stream_; var reg3 object string; var reg4 uintL start; var reg5 uintL len; { check_SP(); check_STACK(); {var reg2 object symbol = TheStream(*stream_)->strm_synonym_symbol; pushSTACK(get_synonym_stream(symbol)); wr_ss(STACK_0)(&STACK_0,string,start,len); skipSTACK(1); # Line-Position aktualisieren kann hier entfallen. }} #endif # Schlie▀t einen Synonym-Stream. # close_synonym(stream); # > stream : Synonym-Stream local void close_synonym (object stream); local void close_synonym(stream) var reg2 object stream; { check_SP(); check_STACK(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; pushSTACK(get_synonym_stream(symbol)); stream_close(&STACK_0); skipSTACK(1); }} # Stellt fest, ob ein Synonym-Stream ein Zeichen verfⁿgbar hat. # listen_synonym(stream) # > stream : Synonym-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen local signean listen_synonym (object stream); local signean listen_synonym(stream) var reg2 object stream; { check_SP(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; return stream_listen(get_synonym_stream(symbol)); }} # UP: L÷scht bereits eingegebenen interaktiven Input von einem Synonym-Stream. # clear_input_synonym(stream) # > stream: Synonym-Stream # < ergebnis: TRUE falls Input gel÷scht wurde # kann GC ausl÷sen local boolean clear_input_synonym (object stream); local boolean clear_input_synonym(stream) var reg2 object stream; { check_SP(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; return clear_input(get_synonym_stream(symbol)); }} # UP: Wartenden Output eines Synonym-Stream ans Ziel bringen. # finish_output_synonym(stream); # > stream: Synonym-Stream # kann GC ausl÷sen local void finish_output_synonym (object stream); local void finish_output_synonym(stream) var reg2 object stream; { check_SP(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; finish_output(get_synonym_stream(symbol)); }} # UP: Wartenden Output eines Synonym-Stream ans Ziel bringen. # force_output_synonym(stream); # > stream: Synonym-Stream # kann GC ausl÷sen local void force_output_synonym (object stream); local void force_output_synonym(stream) var reg2 object stream; { check_SP(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; force_output(get_synonym_stream(symbol)); }} # UP: L÷scht den wartenden Output eines Synonym-Stream. # clear_output_synonym(stream); # > stream: Synonym-Stream # kann GC ausl÷sen local void clear_output_synonym (object stream); local void clear_output_synonym(stream) var reg2 object stream; { check_SP(); {var reg1 object symbol = TheStream(stream)->strm_synonym_symbol; clear_output(get_synonym_stream(symbol)); }} # Liefert einen Synonym-Stream zu einem Symbol. # make_synonym_stream(symbol) # > symbol : Symbol # < ergebnis : neuer Synonym-Stream # kann GC ausl÷sen local object make_synonym_stream (object symbol); local object make_synonym_stream(symbol) var reg2 object symbol; { pushSTACK(symbol); # Symbol retten {var reg1 object stream = # neuer Stream, alle Operationen erlaubt allocate_stream(strmflags_open_B,strmtype_synonym,strm_len+1); TheStream(stream)->strm_rd_by = P(rd_by_synonym); TheStream(stream)->strm_wr_by = P(wr_by_synonym); TheStream(stream)->strm_rd_ch = P(rd_ch_synonym); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_synonym); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_synonym); #endif TheStream(stream)->strm_synonym_symbol = popSTACK(); return stream; }} LISPFUNN(make_synonym_stream,1) # (MAKE-SYNONYM-STREAM symbol), CLTL S. 329 { var reg1 object arg = popSTACK(); if (!symbolp(arg)) { pushSTACK(arg); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(S(symbol)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name); fehler(type_error, DEUTSCH ? "~: Argument mu▀ ein Symbol sein, nicht ~" : ENGLISH ? "~: argument should be a symbol, not ~" : FRANCAIS ? "~ : L'argument doit Ωtre un symbole et non ~": "" ); } value1 = make_synonym_stream(arg); mv_count=1; } # Broadcast-Stream # ================ # ZusΣtzliche Komponenten: # define strm_broad_list strm_other[0] # Liste von Streams # WRITE-BYTE - Pseudofunktion fⁿr Broadcast-Streams: local void wr_by_broad (object stream, object obj); local void wr_by_broad(stream,obj) var reg2 object stream; var reg3 object obj; { check_SP(); check_STACK(); pushSTACK(obj); { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams # obj auf jeden Stream aus der Liste ausgeben: while (consp(streamlist)) { pushSTACK(Cdr(streamlist)); # restliche Streams write_byte(Car(streamlist),STACK_1); # obj ausgeben streamlist = popSTACK(); } } skipSTACK(1); } # WRITE-CHAR - Pseudofunktion fⁿr Broadcast-Streams: local void wr_ch_broad (object* stream_, object obj); local void wr_ch_broad(stream_,obj) var reg3 object* stream_; var reg4 object obj; { check_SP(); check_STACK(); pushSTACK(obj); pushSTACK(NIL); # dummy pushSTACK(TheStream(*stream_)->strm_broad_list); # Liste von Streams # obj auf jeden Stream aus der Liste ausgeben: while (mconsp(STACK_0)) { # Stackaufbau: obj, dummy, streamlistr. STACK_1 = Car(STACK_0); # ein Stream aus der Liste write_char(&STACK_1,STACK_2); # obj ausgeben STACK_0 = Cdr(STACK_0); } skipSTACK(3); } #ifdef STRM_WR_SS # WRITE-CHAR - Pseudofunktion fⁿr Broadcast-Streams: local void wr_ss_broad (object* stream_, object string, uintL start, uintL len); local void wr_ss_broad(stream_,string,start,len) var reg1 object* stream_; var reg4 object string; var reg2 uintL start; var reg3 uintL len; { check_SP(); check_STACK(); pushSTACK(string); pushSTACK(NIL); # dummy pushSTACK(TheStream(*stream_)->strm_broad_list); # Liste von Streams # string auf jeden Stream aus der Liste ausgeben: while (mconsp(STACK_0)) { # Stackaufbau: string, dummy, streamlistr. STACK_1 = Car(STACK_0); # ein Stream aus der Liste wr_ss(STACK_1)(&STACK_1,STACK_2,start,len); # string-Stⁿck ausgeben STACK_0 = Cdr(STACK_0); } skipSTACK(3); # Line-Position aktualisieren kann hier entfallen. } #endif # UP: Bringt den wartenden Output eines Broadcast-Stream ans Ziel. # finish_output_broad(stream); # > stream: Broadcast-Stream # kann GC ausl÷sen local void finish_output_broad (object stream); local void finish_output_broad(stream) var reg2 object stream; { check_SP(); check_STACK(); { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams # Jeden Stream aus der Liste einzeln behandeln: while (consp(streamlist)) { pushSTACK(Cdr(streamlist)); # restliche Streams finish_output(Car(streamlist)); streamlist = popSTACK(); } } } # UP: Bringt den wartenden Output eines Broadcast-Stream ans Ziel. # force_output_broad(stream); # > stream: Broadcast-Stream # kann GC ausl÷sen local void force_output_broad (object stream); local void force_output_broad(stream) var reg2 object stream; { check_SP(); check_STACK(); { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams # Jeden Stream aus der Liste einzeln behandeln: while (consp(streamlist)) { pushSTACK(Cdr(streamlist)); # restliche Streams force_output(Car(streamlist)); streamlist = popSTACK(); } } } # UP: L÷scht den wartenden Output eines Broadcast-Stream. # clear_output_broad(stream); # > stream: Broadcast-Stream # kann GC ausl÷sen local void clear_output_broad (object stream); local void clear_output_broad(stream) var reg2 object stream; { check_SP(); check_STACK(); { var reg1 object streamlist = TheStream(stream)->strm_broad_list; # Liste von Streams # Jeden Stream aus der Liste einzeln behandeln: while (consp(streamlist)) { pushSTACK(Cdr(streamlist)); # restliche Streams clear_output(Car(streamlist)); streamlist = popSTACK(); } } } # Liefert einen Broadcast-Stream zu einer Streamliste. # make_broadcast_stream(list) # > list : Liste von Streams # < ergebnis : Broadcast-Stream # Die Liste list wird dabei zerst÷rt. # kann GC ausl÷sen local object make_broadcast_stream (object list); local object make_broadcast_stream(list) var reg2 object list; { pushSTACK(list); # list retten {var reg1 object stream = # neuer Stream, nur WRITEs erlaubt allocate_stream(strmflags_wr_B,strmtype_broad,strm_len+1); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_broad); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_broad); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_broad); #endif TheStream(stream)->strm_broad_list = popSTACK(); return stream; }} # Liefert einen Broadcast-Stream zum Stream stream. # make_broadcast1_stream(stream) # > stream : Stream # < ergebnis : Broadcast-Stream # kann GC ausl÷sen global object make_broadcast1_stream (object stream); global object make_broadcast1_stream(oldstream) var reg3 object oldstream; { pushSTACK(oldstream); # oldstream in eine einelementige Liste packen: { var reg2 object new_cons = allocate_cons(); Car(new_cons) = STACK_0; {var reg1 object stream = make_broadcast_stream(new_cons); # neuer Stream oldstream = popSTACK(); # Line-Position ⁿbernehmen: TheStream(stream)->strm_wr_ch_lpos = TheStream(oldstream)->strm_wr_ch_lpos; return stream; }}} LISPFUN(make_broadcast_stream,0,0,rest,nokey,0,NIL) # (MAKE-BROADCAST-STREAM {stream}), CLTL S. 329 { # ▄berprⁿfen, ob alle Argumente Streams sind: test_stream_args(rest_args_pointer,argcount); # zu einer Liste zusammenfassen: {var reg1 object list = listof(argcount); # Stream bauen: value1 = make_broadcast_stream(list); mv_count=1; }} # Concatenated-Stream # =================== # ZusΣtzliche Komponenten: # define strm_concat_list strm_other[0] # Liste von Streams #define strm_concat_list2 strm_other[1] # Liste der verbrauchten Streams # READ-BYTE - Pseudofunktion fⁿr Concatenated-Streams: local object rd_by_concat (object stream); local object rd_by_concat(stream) var reg3 object stream; { check_SP(); check_STACK(); pushSTACK(stream); {var reg1 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams var reg2 object ergebnis; while (consp(streamlist)) { ergebnis = read_byte(Car(streamlist)); # Integer lesen if (!eq(ergebnis,eof_value)) { goto OK; } # nicht EOF ? # EOF erreicht -> verbrauchten Stream aus der Liste nehmen # und in die zweite Liste stecken: stream = STACK_0; {var reg4 object first_cons = TheStream(stream)->strm_concat_list; streamlist = Cdr(first_cons); Cdr(first_cons) = TheStream(stream)->strm_concat_list2; TheStream(stream)->strm_concat_list2 = first_cons; TheStream(stream)->strm_concat_list = streamlist; }} # alle Streams verbraucht -> liefere EOF: ergebnis = eof_value; OK: # ergebnis fertig skipSTACK(1); return ergebnis; }} # READ-CHAR - Pseudofunktion fⁿr Concatenated-Streams: local object rd_ch_concat (object* stream_); local object rd_ch_concat(stream_) var reg3 object* stream_; { check_SP(); check_STACK(); {var reg1 object streamlist = TheStream(*stream_)->strm_concat_list; # Liste von Streams while (consp(streamlist)) { pushSTACK(Car(streamlist)); {var reg2 object ergebnis = read_char(&STACK_0); # Character lesen skipSTACK(1); if (!eq(ergebnis,eof_value)) { return ergebnis; } # EOF erreicht -> verbrauchten Stream aus der Liste nehmen # und in die zweite Liste stecken: {var reg2 object stream = *stream_; var reg4 object first_cons = TheStream(stream)->strm_concat_list; streamlist = Cdr(first_cons); Cdr(first_cons) = TheStream(stream)->strm_concat_list2; TheStream(stream)->strm_concat_list2 = first_cons; TheStream(stream)->strm_concat_list = streamlist; }}} # alle Streams verbraucht -> liefere EOF: return eof_value; }} # Stellt fest, ob ein Concatenated-Stream ein Zeichen verfⁿgbar hat. # listen_concat(stream) # > stream : Concatenated-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen local signean listen_concat (object stream); local signean listen_concat(stream) var reg3 object stream; { pushSTACK(stream); {var reg1 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams var reg2 signean ergebnis; while (consp(streamlist)) { ergebnis = stream_listen(Car(streamlist)); if (ergebnis>=0) { goto OK; } # nicht EOF ? # EOF erreicht -> verbrauchten Stream aus der Liste nehmen # und in die zweite Liste stecken: stream = STACK_0; {var reg4 object first_cons = TheStream(stream)->strm_concat_list; streamlist = Cdr(first_cons); Cdr(first_cons) = TheStream(stream)->strm_concat_list2; TheStream(stream)->strm_concat_list2 = first_cons; TheStream(stream)->strm_concat_list = streamlist; }} # alle Streams verbraucht -> liefere EOF: ergebnis = signean_minus; OK: # ergebnis fertig skipSTACK(1); return ergebnis; }} # UP: L÷scht bereits eingegebenen interaktiven Input von einem # Concatenated-Stream. # clear_input_concat(stream) # > stream: Concatenated-Stream # < ergebnis: TRUE falls Input gel÷scht wurde # kann GC ausl÷sen local boolean clear_input_concat (object stream); local boolean clear_input_concat(stream) var reg3 object stream; { var reg2 boolean ergebnis = FALSE; # noch kein Input gel÷scht # alle Streams einzeln behandeln: var reg1 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams while (consp(streamlist)) { pushSTACK(Cdr(streamlist)); # restliche Streamliste ergebnis |= clear_input(Car(streamlist)); # allen Input des Teilstreams l÷schen streamlist = popSTACK(); } return ergebnis; } # Liefert einen Concatenated-Stream zu einer Streamliste. # make_concatenated_stream(list) # > list : Liste von Streams # < ergebnis : Concatenated-Stream # Die Liste list wird dabei zerst÷rt. # kann GC ausl÷sen local object make_concatenated_stream (object list); local object make_concatenated_stream(list) var reg2 object list; { pushSTACK(list); # list retten {var reg1 object stream = # neuer Stream, nur READs erlaubt allocate_stream(strmflags_rd_B,strmtype_concat,strm_len+2); TheStream(stream)->strm_rd_by = P(rd_by_concat); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_concat); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_concat_list = popSTACK(); TheStream(stream)->strm_concat_list2 = NIL; return stream; }} LISPFUN(make_concatenated_stream,0,0,rest,nokey,0,NIL) # (MAKE-CONCATENATED-STREAM {stream}), CLTL S. 329 { # ▄berprⁿfen, ob alle Argumente Streams sind: test_stream_args(rest_args_pointer,argcount); # zu einer Liste zusammenfassen: {var reg1 object list = listof(argcount); # Stream bauen: value1 = make_concatenated_stream(list); mv_count=1; }} # Two-Way-Stream, Echo-Stream # =========================== # ZusΣtzliche Komponenten: #define strm_twoway_input strm_other[0] # Stream fⁿr Input #define strm_twoway_output strm_other[1] # Stream fⁿr Output # WRITE-BYTE - Pseudofunktion fⁿr Two-Way- und Echo-Streams: local void wr_by_twoway (object stream, object obj); local void wr_by_twoway(stream,obj) var reg1 object stream; var reg2 object obj; { check_SP(); write_byte(TheStream(stream)->strm_twoway_output,obj); } # WRITE-CHAR - Pseudofunktion fⁿr Two-Way- und Echo-Streams: local void wr_ch_twoway (object* stream_, object obj); local void wr_ch_twoway(stream_,obj) var reg1 object* stream_; var reg2 object obj; { check_SP(); check_STACK(); pushSTACK(TheStream(*stream_)->strm_twoway_output); write_char(&STACK_0,obj); skipSTACK(1); } #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr Two-Way- und Echo-Streams: local void wr_ss_twoway (object* stream_, object string, uintL start, uintL len); local void wr_ss_twoway(stream_,string,start,len) var reg1 object* stream_; var reg2 object string; var reg3 uintL start; var reg4 uintL len; { check_SP(); check_STACK(); pushSTACK(TheStream(*stream_)->strm_twoway_output); wr_ss(STACK_0)(&STACK_0,string,start,len); skipSTACK(1); # Line-Position aktualisieren kann hier entfallen. } #endif # Stellt fest, ob ein Two-Way- oder Echo-Stream ein Zeichen verfⁿgbar hat. # listen_twoway(stream) # > stream : Two-Way- oder Echo-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen local signean listen_twoway (object stream); local signean listen_twoway(stream) var reg1 object stream; { check_SP(); return stream_listen(TheStream(stream)->strm_twoway_input); } # UP: L÷scht bereits eingegebenen interaktiven Input von einem Two-Way- # oder Echo-Stream. # clear_input_twoway(stream) # > stream: Two-Way- oder Echo-Stream # < ergebnis: TRUE falls Input gel÷scht wurde # kann GC ausl÷sen local boolean clear_input_twoway (object stream); local boolean clear_input_twoway(stream) var reg1 object stream; { check_SP(); return clear_input(TheStream(stream)->strm_twoway_input); } # UP: Bringt den wartenden Output eines Two-Way- oder Echo-Stream ans Ziel. # finish_output_twoway(stream); # > stream: Two-Way- oder Echo-Stream # kann GC ausl÷sen local void finish_output_twoway (object stream); local void finish_output_twoway(stream) var reg1 object stream; { check_SP(); finish_output(TheStream(stream)->strm_twoway_output); } # UP: Bringt den wartenden Output eines Two-Way- oder Echo-Stream ans Ziel. # force_output_twoway(stream); # > stream: Two-Way- oder Echo-Stream # kann GC ausl÷sen local void force_output_twoway (object stream); local void force_output_twoway(stream) var reg1 object stream; { check_SP(); force_output(TheStream(stream)->strm_twoway_output); } # UP: L÷scht den wartenden Output eines Two-Way- oder Echo-Stream. # clear_output_twoway(stream); # > stream: Two-Way- oder Echo-Stream # kann GC ausl÷sen local void clear_output_twoway (object stream); local void clear_output_twoway(stream) var reg1 object stream; { check_SP(); clear_output(TheStream(stream)->strm_twoway_output); } # Two-Way-Stream # ============== # READ-BYTE - Pseudofunktion fⁿr Two-Way-Streams: local object rd_by_twoway (object stream); local object rd_by_twoway(stream) var reg1 object stream; { check_SP(); return read_byte(TheStream(stream)->strm_twoway_input); } # READ-CHAR - Pseudofunktion fⁿr Two-Way-Streams: local object rd_ch_twoway (object* stream_); local object rd_ch_twoway(stream_) var reg1 object* stream_; { check_SP(); check_STACK(); pushSTACK(TheStream(*stream_)->strm_twoway_input); {var reg2 object ergebnis = read_char(&STACK_0); skipSTACK(1); return ergebnis; }} # Liefert einen Two-Way-Stream zu einem Input-Stream und einem Output-Stream. # make_twoway_stream(input_stream,output_stream) # > input_stream : Input-Stream # > output_stream : Output-Stream # < ergebnis : Two-Way-Stream # kann GC ausl÷sen global object make_twoway_stream (object input_stream, object output_stream); global object make_twoway_stream(input_stream,output_stream) var reg2 object input_stream; var reg2 object output_stream; { pushSTACK(input_stream); pushSTACK(output_stream); # Streams retten {var reg1 object stream = # neuer Stream, alle Operationen erlaubt allocate_stream(strmflags_open_B,strmtype_twoway,strm_len+2); TheStream(stream)->strm_rd_by = P(rd_by_twoway); TheStream(stream)->strm_wr_by = P(wr_by_twoway); TheStream(stream)->strm_rd_ch = P(rd_ch_twoway); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_twoway); output_stream = popSTACK(); input_stream = popSTACK(); # Streams zurⁿck TheStream(stream)->strm_wr_ch_lpos = TheStream(output_stream)->strm_wr_ch_lpos; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_twoway); #endif TheStream(stream)->strm_twoway_input = input_stream; TheStream(stream)->strm_twoway_output = output_stream; return stream; }} LISPFUNN(make_two_way_stream,2) # (MAKE-TWO-WAY-STREAM input-stream output-stream), CLTL S. 329 { # ▄berprⁿfen, ob beides Streams sind: test_stream_args(args_end_pointer STACKop 2, 2); {var reg2 object output_stream = popSTACK(); var reg1 object input_stream = popSTACK(); # Stream bauen: value1 = make_twoway_stream(input_stream,output_stream); mv_count=1; }} # Echo-Stream # =========== # READ-BYTE - Pseudofunktion fⁿr Echo-Streams: local object rd_by_echo (object stream); local object rd_by_echo(stream) var reg1 object stream; { check_SP(); check_STACK(); pushSTACK(stream); {var reg1 object obj = read_byte(TheStream(stream)->strm_twoway_input); stream = popSTACK(); if (!eq(obj,eof_value)) { pushSTACK(obj); write_byte(TheStream(stream)->strm_twoway_output,obj); obj = popSTACK(); } return obj; }} # READ-CHAR - Pseudofunktion fⁿr Echo-Streams: local object rd_ch_echo (object* stream_); local object rd_ch_echo(stream_) var reg1 object* stream_; { check_SP(); check_STACK(); pushSTACK(TheStream(*stream_)->strm_twoway_input); {var reg2 object obj = read_char(&STACK_0); if (!eq(obj,eof_value)) { STACK_0 = TheStream(*stream_)->strm_twoway_output; pushSTACK(obj); write_char(&STACK_1,obj); obj = popSTACK(); } skipSTACK(1); return obj; }} # Liefert einen Echo-Stream zu einem Input-Stream und einem Output-Stream. # make_echo_stream(input_stream,output_stream) # > input_stream : Input-Stream # > output_stream : Output-Stream # < ergebnis : Echo-Stream # kann GC ausl÷sen local object make_echo_stream (object input_stream, object output_stream); local object make_echo_stream(input_stream,output_stream) var reg3 object input_stream; var reg2 object output_stream; { pushSTACK(input_stream); pushSTACK(output_stream); # Streams retten {var reg4 uintB flags = strmflags_open_B #ifdef IMMUTABLE | (TheStream(input_stream)->strmflags & strmflags_immut_B) #endif ; var reg1 object stream = # neuer Stream, alle Operationen erlaubt allocate_stream(flags,strmtype_echo,strm_len+2); TheStream(stream)->strm_rd_by = P(rd_by_echo); TheStream(stream)->strm_wr_by = P(wr_by_twoway); TheStream(stream)->strm_rd_ch = P(rd_ch_echo); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_twoway); output_stream = popSTACK(); input_stream = popSTACK(); # Streams zurⁿck TheStream(stream)->strm_wr_ch_lpos = TheStream(output_stream)->strm_wr_ch_lpos; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_twoway); #endif TheStream(stream)->strm_twoway_input = input_stream; TheStream(stream)->strm_twoway_output = output_stream; return stream; }} LISPFUNN(make_echo_stream,2) # (MAKE-ECHO-STREAM input-stream output-stream), CLTL S. 330 { # ▄berprⁿfen, ob beides Streams sind: test_stream_args(args_end_pointer STACKop 2, 2); {var reg2 object output_stream = popSTACK(); var reg1 object input_stream = popSTACK(); # Stream bauen: value1 = make_echo_stream(input_stream,output_stream); mv_count=1; }} # String-Input-Stream # =================== # ZusΣtzliche Komponenten: #define strm_str_in_string strm_other[0] # String fⁿr Input #define strm_str_in_index strm_other[1] # Index in den String (Fixnum >=0) #define strm_str_in_endindex strm_other[2] # Endindex (Fixnum >= index >=0) # Fehlermeldung, wenn index >= length(string): # fehler_str_in_adjusted(stream); # > stream: problematischer String-Input-Stream nonreturning_function(local, fehler_str_in_adjusted, (object stream)); local void fehler_str_in_adjusted(stream) var reg1 object stream; { pushSTACK(TheStream(stream)->strm_str_in_string); pushSTACK(stream); fehler(error, DEUTSCH ? "~ hinterm Stringende angelangt, weil String ~ adjustiert wurde." : ENGLISH ? "~ is beyond the end because the string ~ has been adjusted" : FRANCAIS ? "~ est arrivΘ aprΦs la fin de la chaεne, parce que la chaεne ~ a ΘtΘ ajustΘe." : "" ); } # READ-CHAR - Pseudofunktion fⁿr String-Input-Streams: local object rd_ch_str_in (object* stream_); local object rd_ch_str_in(stream_) var reg4 object* stream_; { var reg1 object stream = *stream_; var reg2 uintL index = posfixnum_to_L(TheStream(stream)->strm_str_in_index); # Index var reg4 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_str_in_endindex); if (index >= endindex) { return eof_value; } # EOF erreicht else # index < eofindex { var uintL len; var reg3 uintB* charptr = unpack_string(TheStream(stream)->strm_str_in_string,&len); # Ab charptr kommen len Zeichen. if (index >= len) # Index zu gro▀ ? { fehler_str_in_adjusted(stream); } {var reg1 object ch = code_char(charptr[index]); # Zeichen aus dem String holen # Index erh÷hen: TheStream(stream)->strm_str_in_index = fixnum_inc(TheStream(stream)->strm_str_in_index,1); return ch; }} } # Schlie▀t einen String-Input-Stream. # close_str_in(stream); # > stream : String-Input-Stream local void close_str_in (object stream); local void close_str_in(stream) var reg1 object stream; { TheStream(stream)->strm_str_in_string = NIL; } # String := NIL # Stellt fest, ob ein String-Input-Stream ein Zeichen verfⁿgbar hat. # listen_str_in(stream) # > stream : String-Input-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen local signean listen_str_in (object stream); local signean listen_str_in(stream) var reg1 object stream; { var reg2 uintL index = posfixnum_to_L(TheStream(stream)->strm_str_in_index); # Index var reg3 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_str_in_endindex); if (index >= endindex) { return signean_minus; } # EOF erreicht else { return signean_null; } } LISPFUN(make_string_input_stream,1,2,norest,nokey,0,NIL) # (MAKE-STRING-INPUT-STREAM string [start [end]]), CLTL S. 330 { # String holen und Grenzen ⁿberprⁿfen: var object string; var uintL start; var uintL len; test_string_limits(&string,&start,&len); {var reg2 object start_arg = fixnum(start); # start-Argument (Fixnum >=0) var reg3 object end_arg = fixnum_inc(start_arg,len); # end-Argument (Fixnum >=0) pushSTACK(string); # String retten { var reg1 object stream = # neuer Stream, nur READ-CHAR erlaubt allocate_stream(strmflags_rd_ch_B,strmtype_str_in,strm_len+3); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_str_in); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_str_in_string = popSTACK(); TheStream(stream)->strm_str_in_index = start_arg; # Index := start-Argument TheStream(stream)->strm_str_in_endindex = end_arg; # Endindex := end-Argument value1 = stream; mv_count=1; # stream als Wert }}} LISPFUNN(string_input_stream_index,1) # (SYSTEM::STRING-INPUT-STREAM-INDEX string-input-stream) liefert den Index { var reg1 object stream = popSTACK(); # Argument # mu▀ ein String-Input-Stream sein: if (!(streamp(stream) && (TheStream(stream)->strmtype == strmtype_str_in))) { pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: ~ ist kein String-Input-Stream." : ENGLISH ? "~: ~ is not a string input stream" : FRANCAIS ? "~ : ~ n'est pas un ½stream╗ lisant d'une chaεne." : "" ); } {var reg2 object index = TheStream(stream)->strm_str_in_index; # Falls ein Character mit UNREAD-CHAR zurⁿckgeschoben wurde, # verwende (1- index), ein Fixnum >=0, als Wert: if (mposfixnump(TheStream(stream)->strm_rd_ch_last)) { index = fixnum_inc(index,-1); } value1 = index; mv_count=1; }} # String-Output-Stream # ==================== # ZusΣtzliche Komponenten: #define strm_str_out_string strm_other[0] # Semi-Simple-String fⁿr Output # WRITE-CHAR - Pseudofunktion fⁿr String-Output-Streams: local void wr_ch_str_out (object* stream_, object ch); local void wr_ch_str_out(stream_,ch) var reg3 object* stream_; var reg1 object ch; { var reg2 object stream = *stream_; # obj sollte String-Char sein: if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # Character in den String schieben: ssstring_push_extend(TheStream(stream)->strm_str_out_string,char_code(ch)); } #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr String-Output-Streams: local void wr_ss_str_out (object* stream_, object string, uintL start, uintL len); local void wr_ss_str_out(stream_,srcstring,start,len) var reg8 object* stream_; var reg9 object srcstring; var reg10 uintL start; var reg6 uintL len; { if (len==0) return; {var reg4 object ssstring = TheStream(*stream_)->strm_str_out_string; # Semi-Simple-String var reg5 uintL old_len = TheArray(ssstring)->dims[1]; # jetzige LΣnge = Fill-Pointer if (old_len + len > TheArray(ssstring)->dims[0]) # passen keine len Bytes mehr hinein { pushSTACK(srcstring); ssstring = ssstring_extend(ssstring,old_len+len); # dann lΣnger machen srcstring = popSTACK(); } # Zeichen hineinschieben: {var reg1 uintB* srcptr = &TheSstring(srcstring)->data[start]; var reg3 uintL count; {var reg2 uintB* ptr = &TheSstring(TheArray(ssstring)->data)->data[old_len]; dotimespL(count,len, { *ptr++ = *srcptr++; } ); } # und Fill-Pointer erh÷hen: TheArray(ssstring)->dims[1] = old_len + len; wr_ss_lpos(*stream_,srcptr,len); # Line-Position aktualisieren }}} #endif # Liefert einen String-Output-Stream. # make_string_output_stream() # kann GC ausl÷sen global object make_string_output_stream (void); global object make_string_output_stream() { # kleinen Semi-Simple-String der LΣnge 50 allozieren: pushSTACK(make_ssstring(50)); {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_str_out,strm_len+1); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_str_out); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_str_out); #endif TheStream(stream)->strm_str_out_string = popSTACK(); # String eintragen return stream; }} LISPFUN(make_string_output_stream,0,1,norest,nokey,0,NIL) # (MAKE-STRING-OUTPUT-STREAM [line-position]), CLTL S. 330 { # line-position ⁿberprⁿfen: if (eq(STACK_0,unbound)) { STACK_0 = Fixnum_0; } # Defaultwert 0 else # line-position angegeben, sollte ein Fixnum >=0 sein: { if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); } } {var reg1 object stream = make_string_output_stream(); # String-Output-Stream TheStream(stream)->strm_wr_ch_lpos = popSTACK(); # Line Position eintragen value1 = stream; mv_count=1; # stream als Wert }} # UP: Liefert das von einem String-Output-Stream Angesammelte. # get_output_stream_string(&stream) # > stream: String-Output-Stream # < stream: geleerter Stream # < ergebnis: Angesammeltes, ein Simple-String # kann GC ausl÷sen global object get_output_stream_string (object* stream_); global object get_output_stream_string(stream_) var reg1 object* stream_; { var reg2 object string = TheStream(*stream_)->strm_str_out_string; # alter String string = coerce_ss(string); # in Simple-String umwandeln (erzwingt ein Kopieren) # alten String durch Fill-Pointer:=0 leeren: TheArray(TheStream(*stream_)->strm_str_out_string)->dims[1] = 0; return string; } LISPFUNN(get_output_stream_string,1) # (GET-OUTPUT-STREAM-STRING string-output-stream), CLTL S. 330 { var reg1 object stream = STACK_0; # Argument # mu▀ ein String-Output-Stream sein: if (!(streamp(stream) && (TheStream(stream)->strmtype == strmtype_str_out))) { # stream in STACK_0 pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: ~ ist kein String-Output-Stream." : ENGLISH ? "~: ~ is not a string output stream" : FRANCAIS ? "~ : ~ n'est pas un ½stream╗ Θcrivant dans une chaεne." : "" ); } {value1 = get_output_stream_string(&STACK_0); mv_count=1; # Angesammeltes als Wert skipSTACK(1); }} # String-Push-Stream # ================== # ZusΣtzliche Komponenten: #define strm_str_push_string strm_other[0] # String mit Fill-Pointer fⁿr Output # WRITE-CHAR - Pseudofunktion fⁿr String-Push-Streams: local void wr_ch_str_push (object* stream_, object ch); local void wr_ch_str_push(stream_,ch) var reg3 object* stream_; var reg1 object ch; { var reg2 object stream = *stream_; # ch sollte String-Char sein: if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # Character in den String schieben: pushSTACK(ch); pushSTACK(TheStream(stream)->strm_str_push_string); funcall(L(vector_push_extend),2); # (VECTOR-PUSH-EXTEND ch string) } # (SYSTEM::MAKE-STRING-PUSH-STREAM string) liefert einen Stream, dessen # WRITE-CHAR-Operation mit einem VECTOR-PUSH-EXTEND auf den gegebenen String # Σquivalent ist. LISPFUNN(make_string_push_stream,1) { {var reg1 object arg = STACK_0; # Argument # mu▀ ein String mit Fill-Pointer sein: if (!(stringp(arg) && array_has_fill_pointer_p(arg))) { # arg in STACK_0 pushSTACK(S(with_output_to_string)); fehler(error, DEUTSCH ? "~: Argument mu▀ ein String mit Fill-Pointer sein, nicht ~" : ENGLISH ? "~: argument ~ should be a string with fill pointer" : FRANCAIS ? "~ : L'argument ~ doit Ωtre une chaεne munie d'un pointeur de remplissage." : "" ); } } {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_str_push,strm_len+1); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_str_push); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_str_push_string = popSTACK(); # String eintragen value1 = stream; mv_count=1; # stream als Wert } } # Pretty-Printer-Hilfs-Stream # =========================== # ZusΣtzliche Komponenten: # define strm_pphelp_strings strm_other[0] # Semi-Simple-Strings fⁿr Output # define strm_pphelp_modus strm_other[1] # Modus (NIL=Einzeiler, T=Mehrzeiler) # WRITE-CHAR - Pseudofunktion fⁿr Pretty-Printer-Hilfs-Streams: local void wr_ch_pphelp (object* stream_, object ch); local void wr_ch_pphelp(stream_,ch) var reg4 object* stream_; var reg2 object ch; { var reg1 object stream = *stream_; # ch sollte String-Char sein: if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } {var reg3 uintB c = char_code(ch); # Character # Bei NL: Ab jetzt Modus := Mehrzeiler if (c == NL) { TheStream(stream)->strm_pphelp_modus = T; } # Character in den ersten String schieben: ssstring_push_extend(Car(TheStream(stream)->strm_pphelp_strings),c); }} #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr Pretty-Printer-Hilfs-Streams: local void wr_ss_pphelp (object* stream_, object string, uintL start, uintL len); local void wr_ss_pphelp(stream_,srcstring,start,len) var reg8 object* stream_; var reg9 object srcstring; var reg10 uintL start; var reg6 uintL len; { if (len==0) return; {var reg4 object ssstring = Car(TheStream(*stream_)->strm_pphelp_strings); # Semi-Simple-String var reg5 uintL old_len = TheArray(ssstring)->dims[1]; # jetzige LΣnge = Fill-Pointer if (old_len + len > TheArray(ssstring)->dims[0]) # passen keine len Bytes mehr hinein { pushSTACK(srcstring); ssstring = ssstring_extend(ssstring,old_len+len); # dann lΣnger machen srcstring = popSTACK(); } # Zeichen hineinschieben: {var reg1 uintB* srcptr = &TheSstring(srcstring)->data[start]; var reg3 uintL count; {var reg2 uintB* ptr = &TheSstring(TheArray(ssstring)->data)->data[old_len]; dotimespL(count,len, { *ptr++ = *srcptr++; } ); } # und Fill-Pointer erh÷hen: TheArray(ssstring)->dims[1] = old_len + len; if (wr_ss_lpos(*stream_,srcptr,len)) # Line-Position aktualisieren { TheStream(*stream_)->strm_pphelp_modus = T; } # Nach NL: Modus := Mehrzeiler }}} #endif # UP: Liefert einen Pretty-Printer-Hilfs-Stream. # make_pphelp_stream() # kann GC ausl÷sen global object make_pphelp_stream (void); global object make_pphelp_stream() { # kleinen Semi-Simple-String der LΣnge 50 allozieren: pushSTACK(make_ssstring(50)); # einelementige Stringliste bauen: {var reg1 object new_cons = allocate_cons(); Car(new_cons) = popSTACK(); pushSTACK(new_cons); } {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_pphelp,strm_len+2); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_pphelp); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_pphelp); #endif TheStream(stream)->strm_pphelp_strings = popSTACK(); # String-Liste eintragen TheStream(stream)->strm_pphelp_modus = NIL; # Modus := Einzeiler return stream; }} # Buffered-Input-Stream # ===================== # Elementtyp: string-char # Richtungen: nur input # (make-buffered-input-stream fun mode) liefert einen solchen. # Dabei ist fun eine Funktion von 0 Argumenten, die bei Aufruf # entweder NIL (steht fⁿr EOF) oder bis zu drei Werte string, start, end # zurⁿckliefert. # Funktionsweise: (read-char ...) liefert nacheinander die Zeichen des # aktuellen Strings; ist der zu Ende, wird fun aufgerufen, und ist der # Wert davon ein String, so wird der neue aktuelle String gegeben durch # (multiple-value-bind (str start end) (funcall fun) # (subseq str (or start 0) (or end 'NIL)) # ) # Der von fun zurⁿckgegebene String sollte nicht verΣndert werden. # (Ansonsten sollte fun vorher den String mit COPY-SEQ kopieren.) # mode bestimmt, wie sich der Stream bezⁿglich LISTEN verhΣlt. # mode = NIL: Stream verhΣlt sich wie ein File-Stream, d.h. bei LISTEN # und leerem aktuellen String wird fun aufgerufen. # mode = T: Stream verhΣlt sich wie ein interaktiver Stream ohne EOF, # d.h. man kann davon ausgehen, das stets noch weitere Zeichen # kommen, auch ohne fun aufzurufen. # mode eine Funktion: Diese Funktion teilt, wenn aufgerufen, mit, ob # noch weitere nichtleere Strings zu erwarten sind. # (clear-input ...) beendet die Bearbeitung des aktuellen Strings. # ZusΣtzliche Komponenten: # define strm_buff_in_fun strm_other[0] # Lesefunktion #define strm_buff_in_mode strm_other[1] # Modus oder Listen-Funktion #define strm_buff_in_string strm_other[2] # aktueller String fⁿr Input #define strm_buff_in_index strm_other[3] # Index in den String (Fixnum >=0) #define strm_buff_in_endindex strm_other[4] # Endindex (Fixnum >= index >=0) # READ-CHAR - Pseudofunktion fⁿr Buffered-Input-Streams: local object rd_ch_buff_in (object* stream_); local object rd_ch_buff_in(stream_) var reg5 object* stream_; { var reg1 object stream = *stream_; var reg2 uintL index = posfixnum_to_L(TheStream(stream)->strm_buff_in_index); # Index var reg4 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_buff_in_endindex); loop { if (index < endindex) break; # noch was im aktuellen String? # String-Ende erreicht # fun aufrufen: funcall(TheStream(stream)->strm_buff_in_fun,0); if (!stringp(value1)) { return eof_value; } # EOF erreicht # neuen String holen und Grenzen ⁿberprⁿfen: pushSTACK(value1); # String pushSTACK(mv_count >= 2 ? value2 : unbound); # start pushSTACK(mv_count >= 3 ? value3 : unbound); # end {var object string; var uintL start; var uintL len; subr_self = L(read_char); test_string_limits(&string,&start,&len); stream = *stream_; index = start; endindex = index+len; TheStream(stream)->strm_buff_in_string = string; TheStream(stream)->strm_buff_in_index = fixnum(index); TheStream(stream)->strm_buff_in_endindex = fixnum(endindex); }} # index < eofindex { var uintL len; var reg3 uintB* charptr = unpack_string(TheStream(stream)->strm_buff_in_string,&len); # Ab charptr kommen len Zeichen. if (index >= len) # Index zu gro▀ ? { pushSTACK(TheStream(stream)->strm_buff_in_string); pushSTACK(stream); fehler(error, DEUTSCH ? "~ hinterm Stringende angelangt, weil String ~ adjustiert wurde." : ENGLISH ? "~ is beyond the end because the string ~ has been adjusted" : FRANCAIS ? "~ est arrivΘ aprΦs la fin de la chaεne, parce que la chaεne ~ a ΘtΘ ajustΘe." : "" ); } {var reg1 object ch = code_char(charptr[index]); # Zeichen aus dem String holen # Index erh÷hen: TheStream(stream)->strm_buff_in_index = fixnum_inc(TheStream(stream)->strm_buff_in_index,1); return ch; }} } # Schlie▀t einen Buffered-Input-Stream. # close_buff_in(stream); # > stream : Buffered-Input-Stream local void close_buff_in (object stream); local void close_buff_in(stream) var reg1 object stream; { TheStream(stream)->strm_buff_in_fun = NIL; # Funktion := NIL TheStream(stream)->strm_buff_in_mode = NIL; # Mode := NIL TheStream(stream)->strm_buff_in_string = NIL; # String := NIL } # Stellt fest, ob ein Buffered-Input-Stream ein Zeichen verfⁿgbar hat. # listen_buff_in(stream) # > stream : Buffered-Input-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen local signean listen_buff_in (object stream); local signean listen_buff_in(stream) var reg1 object stream; { var reg3 uintL index = posfixnum_to_L(TheStream(stream)->strm_buff_in_index); # Index var reg4 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_buff_in_endindex); if (index < endindex) { return signean_null; } {var reg2 object mode = TheStream(stream)->strm_buff_in_mode; if (eq(mode,S(nil))) { pushSTACK(stream); mode = peek_char(&STACK_0); # peek_char macht read_char, ruft fun auf skipSTACK(1); if (eq(mode,eof_value)) { return signean_minus; } # EOF erreicht else { return signean_null; } } elif (eq(mode,S(t))) { return signean_null; } else { funcall(mode,0); # mode aufrufen if (nullp(value1)) # keine Strings mehr zu erwarten? { return signean_minus; } # ja -> EOF erreicht else { return signean_null; } } }} # UP: L÷scht bereits eingegebenen interaktiven Input von einem Buffered-Input-Stream. # clear_input_buff_in(stream) # > stream: Buffered-Input-Stream # < ergebnis: TRUE falls Input gel÷scht wurde # kann GC ausl÷sen local boolean clear_input_buff_in (object stream); local boolean clear_input_buff_in(stream) var reg1 object stream; { # Bearbeitung des aktuellen Strings beenden: var reg3 object index = TheStream(stream)->strm_buff_in_index; # Index var reg2 object endindex = TheStream(stream)->strm_buff_in_endindex; TheStream(stream)->strm_buff_in_index = endindex; # index := endindex if (eq(index,endindex)) { return FALSE; } else { return TRUE; } } LISPFUNN(make_buffered_input_stream,2) # (MAKE-BUFFERED-INPUT-STREAM fun mode) { var reg1 object stream = # neuer Stream, nur READ-CHAR erlaubt allocate_stream(strmflags_rd_ch_B,strmtype_buff_in,strm_len+5); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_buff_in); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_buff_in_mode = popSTACK(); TheStream(stream)->strm_buff_in_fun = popSTACK(); TheStream(stream)->strm_buff_in_string = O(leer_string); # String := "" TheStream(stream)->strm_buff_in_index = Fixnum_0; # Index := 0 TheStream(stream)->strm_buff_in_endindex = Fixnum_0; # Endindex := 0 value1 = stream; mv_count=1; # stream als Wert } LISPFUNN(buffered_input_stream_index,1) # (SYSTEM::BUFFERED-INPUT-STREAM-INDEX buffered-input-stream) liefert den Index { var reg1 object stream = popSTACK(); # Argument # mu▀ ein Buffered-Input-Stream sein: if (!(streamp(stream) && (TheStream(stream)->strmtype == strmtype_buff_in))) { pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: ~ ist kein Buffered-Input-Stream." : ENGLISH ? "~: ~ is not a buffered input stream" : FRANCAIS ? "~ : ~ n'est pas un ½stream╗ d'entrΘe bufferisΘ." : "" ); } {var reg2 object index = TheStream(stream)->strm_buff_in_index; # Falls ein Character mit UNREAD-CHAR zurⁿckgeschoben wurde, # verwende (1- index), ein Fixnum >=0, als Wert: if (mposfixnump(TheStream(stream)->strm_rd_ch_last)) { index = fixnum_inc(index,-1); } value1 = index; mv_count=1; }} # Buffered-Output-Stream # ====================== # Elementtyp: string-char # Richtungen: nur output # (make-buffered-output-stream fun) liefert einen solchen. # Dabei ist fun eine Funktion von einem Argument, die, mit einem # Simple-String als Argument aufgerufen, dessen Inhalt in Empfang nimmt. # Funktionsweise: (write-char ...) sammelt die geschriebenen Zeichen in # einem String, bis ein #\Newline oder eine FORCE-/FINISH-OUTPUT- # Anforderung kommt, und ruft dann fun mit einem Simple-String, der das # bisher Angesammelte enthΣlt, als Argument auf. # (clear-output ...) wirft die bisher angesammelten Zeichen weg. # ZusΣtzliche Komponenten: # define strm_buff_out_fun strm_other[0] # Ausgabefunktion #define strm_buff_out_string strm_other[1] # Semi-Simple-String fⁿr Output # UP: Bringt den wartenden Output eines Buffered-Output-Stream ans Ziel. # finish_output_buff_out(stream); # > stream: Buffered-Output-Stream # kann GC ausl÷sen local void finish_output_buff_out (object stream); local void finish_output_buff_out(stream) var reg1 object stream; { pushSTACK(stream); {var reg2 object string = TheStream(stream)->strm_buff_out_string; # String string = coerce_ss(string); # in Simple-String umwandeln (erzwingt ein Kopieren) stream = STACK_0; STACK_0 = string; # String durch Fill-Pointer:=0 leeren: TheArray(TheStream(stream)->strm_buff_out_string)->dims[1] = 0; funcall(TheStream(stream)->strm_buff_out_fun,1); # Funktion aufrufen }} # UP: Bringt den wartenden Output eines Buffered-Output-Stream ans Ziel. # force_output_buff_out(stream); # > stream: Buffered-Output-Stream # kann GC ausl÷sen #define force_output_buff_out finish_output_buff_out # UP: L÷scht den wartenden Output eines Buffered-Output-Stream. # clear_output_buff_out(stream); # > stream: Buffered-Output-Stream # kann GC ausl÷sen local void clear_output_buff_out (object stream); local void clear_output_buff_out(stream) var reg1 object stream; { # String durch Fill-Pointer:=0 leeren: TheArray(TheStream(stream)->strm_buff_out_string)->dims[1] = 0; # Line-Position unverΣndert lassen?? } # WRITE-CHAR - Pseudofunktion fⁿr Buffered-Output-Streams: local void wr_ch_buff_out (object* stream_, object ch); local void wr_ch_buff_out(stream_,ch) var reg3 object* stream_; var reg1 object ch; { var reg2 object stream = *stream_; # obj sollte String-Char sein: if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } # Character in den String schieben: ssstring_push_extend(TheStream(stream)->strm_buff_out_string,char_code(ch)); # Nach #\Newline den Buffer durchreichen: if (char_code(ch) == NL) { force_output_buff_out(*stream_); } } # Schlie▀t einen Buffered-Output-Stream. # close_buff_out(stream); # > stream : Buffered-Output-Stream # kann GC ausl÷sen local void close_buff_out (object stream); local void close_buff_out(stream) var reg1 object stream; { pushSTACK(stream); # stream retten finish_output_buff_out(stream); stream = popSTACK(); # stream zurⁿck TheStream(stream)->strm_buff_out_fun = NIL; # Funktion := NIL TheStream(stream)->strm_buff_out_string = NIL; # String := NIL } LISPFUN(make_buffered_output_stream,1,1,norest,nokey,0,NIL) # (MAKE-BUFFERED-OUTPUT-STREAM fun [line-position]) { # line-position ⁿberprⁿfen: if (eq(STACK_0,unbound)) { STACK_0 = Fixnum_0; } # Defaultwert 0 else # line-position angegeben, sollte ein Fixnum >=0 sein: { if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); } } # kleinen Semi-Simple-String der LΣnge 50 allozieren: pushSTACK(make_ssstring(50)); {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_buff_out,strm_len+2); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_buff_out); #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_buff_out_string = popSTACK(); # String eintragen TheStream(stream)->strm_wr_ch_lpos = popSTACK(); # Line Position eintragen TheStream(stream)->strm_buff_out_fun = popSTACK(); # Funktion eintragen value1 = stream; mv_count=1; # stream als Wert }} #ifdef PRINTER_ATARI # Printer-Stream # ============== # ZusΣtzliche Komponenten: #define strm_printer_port strm_other[0] # Fixnum >=0: # 0 bei paralleler, 1 bei serieller Schnittstelle # Gibt ein Zeichen auf den Printer aus. # wr_printer(port,c) # > port: Printer-Port # > c: Auszugebendes Zeichen # kann GC ausl÷sen local void printer_out (object port, uintB c); local void printer_out(port,c) var reg1 object port; var reg2 uintB c; { # Stellt fest, ob der Drucker bereit ist: #define printer_ready() (eq(port,Fixnum_0) ? GEMDOS_PrtStat() : GEMDOS_AuxStat()) until (printer_ready()) # Drucker bereit? { # Drucker noch nicht bereit -> eine Warteschleife einlegen: var reg5 object timeout = Symbol_value(S(printer_timeout)) ; # Wert von *PRINTER-TIMEOUT* var reg4 uintL wait_time; # sollte ein Fixnum >=0, <= 60*ticks_per_second = 12000 sein: if (posfixnump(timeout) && ((wait_time = posfixnum_to_L(timeout)) <= 12000) ) { var reg3 uintL wait_start_time = get_real_time(); loop # Warteschleife { if (printer_ready()) goto OK; # Drucker bereit -> Warteschleife beenden if ((get_real_time() - wait_start_time) >= wait_time) break; } # Habe wait_time gewartet, jetzt wird's Zeit fⁿr eine Fehlermeldung: # Continuable Error melden: pushSTACK(OL(druckerstreik_string1)); # "Neuer Versuch." pushSTACK(OL(druckerstreik_string2)); # "Drucker nicht angeschlossen oder off-line." funcall(S(cerror),2); # (CERROR "..." "...") } else { # Illegaler Wert in *PRINTER-TIMEOUT* vorgefunden. # Wert zurⁿcksetzen: Symbol_value(S(printer_timeout)) = fixnum(1000); # *PRINTER-TIMEOUT* := 1000 # Warnung ausgeben: pushSTACK(OL(printer_timeout_warnung_string)); # "Der Wert ..." pushSTACK(S(printer_timeout)); funcall(S(warn),2); # (WARN "..." '*PRINTER-TIMEOUT*) } } OK: # Drucker bereit -> Zeichen endlich ausgeben: if (eq(port,Fixnum_0)) { GEMDOS_PrtOut(c); } else { GEMDOS_AuxOut(c); } #undef printer_ready } # WRITE-CHAR - Pseudofunktion fⁿr Printer-Streams: local void wr_ch_printer (object* stream_, object ch); local void wr_ch_printer(stream_,ch) var reg4 object* stream_; var reg2 object ch; { var reg1 object stream = *stream_; # ch sollte String-Char sein: if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } {var reg4 object port = TheStream(stream)->strm_printer_port; var reg3 uintB c = char_code(ch); # Character if (c==NL) # NL in CR/LF umwandeln: { printer_out(port,CR); printer_out(port,LF); } else { printer_out(port,c); } }} # UP: Liefert einen Printer-Stream. # kann GC ausl÷sen local object make_printer_stream (void); local object make_printer_stream() { var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_printer,strm_len+1); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_printer); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_printer_port = # Printer-Port # Druckerkonfiguration abfragen: (XBIOS_GetPrtConfig() & bit(4) ? Fixnum_1 # serielle Schnittstelle : Fixnum_0 # parallele Schnittstelle ); return stream; } #endif #ifdef PRINTER_AMIGAOS # Printer-Stream # ============== # ZusΣtzliche Komponenten: #define strm_printer_handle strm_other[0] # Handle von "PRT:" # WRITE-CHAR - Pseudofunktion fⁿr Printer-Streams: local void wr_ch_printer (object* stream_, object ch); local void wr_ch_printer(stream_,ch) var reg4 object* stream_; var reg2 object ch; { var reg1 object stream = *stream_; # ch sollte String-Char sein: if (!string_char_p(ch)) { fehler_wr_string_char(stream,ch); } begin_system_call(); {var uintB c = char_code(ch); var reg3 long ergebnis = # Zeichen auszugeben versuchen Write(TheHandle(TheStream(stream)->strm_printer_handle),&c,1L); end_system_call(); if (ergebnis<0) { OS_error(); } # Error melden # ergebnis = Anzahl der ausgegebenen Zeichen (0 oder 1) if (ergebnis==0) # nicht erfolgreich? { fehler_unwritable(S(write_char),stream); } }} # Schlie▀t einen Printer-Stream. local void close_printer (object stream); local void close_printer(stream) var reg1 object stream; { begin_system_call(); Close(TheHandle(TheStream(stream)->strm_printer_handle)); end_system_call(); } # UP: Liefert einen Printer-Stream. # kann GC ausl÷sen local object make_printer_stream (void); local object make_printer_stream() { pushSTACK(allocate_cons()); # Cons fⁿr Liste pushSTACK(allocate_handle(Handle_NULL)); # Handle-Verpackung {var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_printer,strm_len+1); set_break_sem_4(); begin_system_call(); {var reg2 Handle handle = Open("PRT:",MODE_NEWFILE); if (handle==Handle_NULL) { OS_error(); } # Error melden end_system_call(); TheHandle(STACK_0) = handle; # Handle verpacken } TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_printer); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy_nogc); #endif TheStream(stream)->strm_printer_handle = popSTACK(); # Liste der offenen Streams um stream erweitern: {var reg1 object new_cons = popSTACK(); Car(new_cons) = stream; Cdr(new_cons) = O(open_files); O(open_files) = new_cons; } clr_break_sem_4(); return stream; }} LISPFUNN(make_printer_stream,0) # (SYSTEM::MAKE-PRINTER-STREAM) liefert einen Printer-Stream. # Fⁿr die verstandenen Escape-Sequenzen siehe in PRINTER.DOC. { value1 = make_printer_stream(); mv_count=1; return; } #endif #ifdef PIPES # Pipe-Input-Stream # ================= # ZusΣtzliche Komponenten: # define strm_pipe_pid strm_other[3] # Proze▀-Id, ein Fixnum >=0 #define strm_pipe_in_handle strm_ihandle # Handle fⁿr Input #if defined(EMUNIX) && defined(PIPES2) #define strm_pipe_in_other strm_ohandle # Pipe-Stream in Gegenrichtung #define strm_pipe_out_other strm_ihandle # Pipe-Stream in Gegenrichtung #endif # READ-CHAR - Pseudofunktion fⁿr Pipe-Input-Streams: #define rd_ch_pipe_in rd_ch_handle # Schlie▀t einen Pipe-Input-Stream. # close_pipe_in(stream); # > stream : Pipe-Input-Stream #ifdef EMUNIX local void close_pipe_in (object stream); local void close_pipe_in(stream) var reg1 object stream; { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_pipe_in_handle); #ifdef PIPES2 if (mstreamp(TheStream(stream)->strm_pipe_in_other)) # Der andere Pipe-Stream ist noch offen. Wir dⁿrfen nicht pclose() # aufrufen, da das ein waitpid() ausfⁿhrt. { TheStream(TheStream(stream)->strm_pipe_in_other)->strm_pipe_out_other = NIL; TheStream(stream)->strm_pipe_in_other = NIL; begin_system_call(); if ( fclose(&_streamv[handle]) != 0) { OS_error(); } end_system_call(); # Die Pipes sind nun getrennt, so da▀ beim Schlie▀en der anderen # Pipe das pclose() ausgefⁿhrt werden wird. return; } #endif begin_system_call(); if ( pclose(&_streamv[handle]) == -1) { OS_error(); } end_system_call(); } #endif #ifdef UNIX #define close_pipe_in close_ihandle #endif # Stellt fest, ob ein Pipe-Input-Stream ein Zeichen verfⁿgbar hat. # listen_pipe_in(stream) # > stream : Pipe-Input-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen #define listen_pipe_in listen_handle LISPFUNN(make_pipe_input_stream,1) # (MAKE-PIPE-INPUT-STREAM command) # ruft eine Shell auf, die command ausfⁿhrt, wobei deren Standard-Output # in unsere Pipe hinein geht. { # command ⁿberprⁿfen: var reg4 object command; funcall(L(string),1); # (STRING command) command = string_to_asciz(value1); # als ASCIZ-String pushSTACK(command); {var int handles[2]; # zwei Handles fⁿr die Pipe var reg3 int child; #ifdef EMUNIX { # Stackaufbau: command. begin_system_call(); {var reg1 FILE* f = popen(TheAsciz(STACK_0),"r"); if (f==NULL) { OS_error(); } child = f->pid; handles[0] = fileno(f); end_system_call(); }} #endif #ifdef UNIX { # Als Shell nehmen wir immer die Kommando-Shell. # Stackaufbau: command. # command in den Stack kopieren: var reg5 uintL command_length = TheSstring(command)->length; var DYNAMIC_ARRAY(reg6,command_data,char,command_length); { var reg2 char* ptr1 = TheAsciz(command); var reg1 char* ptr2 = &command_data[0]; dotimespL(command_length,command_length, { *ptr2++ = *ptr1++; } ); } begin_system_call(); # Pipe aufbauen: if (!( pipe(handles) ==0)) { FREE_DYNAMIC_ARRAY(command_data); OS_error(); } # Alles, was in handles[1] reingeschoben wird, kommt bei handles[0] # wieder raus. Wir werden dies so benutzen: # # write system read # child -> handles[1] -> handles[0] -> parent # # einen neuen Proze▀ starten: if ((child = vfork()) ==0) # Dieses Programmstⁿck wird vom Child-Proze▀ ausgefⁿhrt: { if ( dup2(handles[1],stdout_handle) >=0) # Standard-Output umleiten if ( CLOSE(handles[1]) ==0) # Wir wollen nur ⁿber stdout_handle schreiben if ( CLOSE(handles[0]) ==0) # Wir wollen von der Pipe nicht lesen # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Child # die Pipe gefⁿllt hat - der Parent-Proze▀ und nicht etwa der # Child-Proze▀ aufgerufen wird, um die Pipe zu leeren.) { # Child-Proze▀ zum Hintergrundproze▀ machen: SETSID(); # er bekommt eine eigene Process Group execl(SHELL, # Shell aufrufen SHELL, # =: argv[0] "-c", # =: argv[1] &command_data[0], # =: argv[2] NULL ); } _exit(-1); # sollte dies mi▀lingen, Child-Proze▀ beenden } # Dieses Programmstⁿck wird wieder vom Aufrufer ausgefⁿhrt: if (child==-1) # Etwas ist mi▀lungen, entweder beim vfork oder beim execl. # In beiden FΣllen wurde errno gesetzt. { var int saved_errno = errno; CLOSE(handles[1]); CLOSE(handles[0]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # Wir wollen von der Pipe nur lesen, nicht schreiben: if (!( CLOSE(handles[1]) ==0)) { var int saved_errno = errno; CLOSE(handles[0]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Parent-Proze▀ # die Pipe geleert hat - der Child-Proze▀ und nicht etwa der # Parent-Proze▀ aufgerufen wird, um die Pipe wieder zu fⁿllen.) end_system_call(); FREE_DYNAMIC_ARRAY(command_data); } #endif # Stream allozieren: { var reg1 object stream = # neuer Stream, nur READ-CHAR erlaubt allocate_stream(strmflags_rd_ch_B,strmtype_pipe_in,strm_len+4); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_pipe_in); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid TheStream(stream)->strm_pipe_in_handle = allocate_handle(handles[0]); # Read-Handle TheStream(stream)->strm_isatty = NIL; value1 = stream; mv_count=1; # stream als Wert skipSTACK(1); }}} # Pipe-Output-Stream # ================== # ZusΣtzliche Komponenten: # define strm_pipe_pid strm_other[3] # Proze▀-Id, ein Fixnum >=0 #define strm_pipe_out_handle strm_ohandle # Handle fⁿr Output #if defined(EMUNIX) && defined(PIPES2) # define strm_pipe_out_other strm_ihandle # Pipe-Stream in Gegenrichtung #endif # WRITE-CHAR - Pseudofunktion fⁿr Pipe-Output-Streams: #define wr_ch_pipe_out wr_ch_handle #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr Pipe-Output-Streams: #define wr_ss_pipe_out wr_ss_handle #endif # Schlie▀t einen Pipe-Output-Stream. # close_pipe_out(stream); # > stream : Pipe-Output-Stream #ifdef EMUNIX local void close_pipe_out (object stream); local void close_pipe_out(stream) var reg1 object stream; { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_pipe_out_handle); #ifdef PIPES2 if (mstreamp(TheStream(stream)->strm_pipe_out_other)) # Der andere Pipe-Stream ist noch offen. Wir dⁿrfen nicht pclose() # aufrufen, da das ein waitpid() ausfⁿhrt. { TheStream(TheStream(stream)->strm_pipe_out_other)->strm_pipe_in_other = NIL; TheStream(stream)->strm_pipe_out_other = NIL; begin_system_call(); if ( fclose(&_streamv[handle]) != 0) { OS_error(); } end_system_call(); # Die Pipes sind nun getrennt, so da▀ beim Schlie▀en der anderen # Pipe das pclose() ausgefⁿhrt werden wird. return; } #endif begin_system_call(); if ( pclose(&_streamv[handle]) == -1) { OS_error(); } end_system_call(); } #endif #ifdef UNIX #define close_pipe_out close_ohandle #endif LISPFUNN(make_pipe_output_stream,1) # (MAKE-PIPE-OUTPUT-STREAM command) # ruft eine Shell auf, die command ausfⁿhrt, wobei unsere Pipe in deren # Standard-Input hinein geht. { # command ⁿberprⁿfen: var reg4 object command; funcall(L(string),1); # (STRING command) command = string_to_asciz(value1); # als ASCIZ-String pushSTACK(command); {var int handles[2]; # zwei Handles fⁿr die Pipe var reg3 int child; #ifdef EMUNIX { # Stackaufbau: command. begin_system_call(); {var reg1 FILE* f = popen(TheAsciz(STACK_0),"w"); if (f==NULL) { OS_error(); } child = f->pid; handles[1] = fileno(f); end_system_call(); }} #endif #ifdef UNIX { # Als Shell nehmen wir immer die Kommando-Shell. # Stackaufbau: command. # command in den Stack kopieren: var reg5 uintL command_length = TheSstring(command)->length; var DYNAMIC_ARRAY(reg6,command_data,char,command_length); { var reg2 char* ptr1 = TheAsciz(command); var reg1 char* ptr2 = &command_data[0]; dotimespL(command_length,command_length, { *ptr2++ = *ptr1++; } ); } begin_system_call(); if (!( pipe(handles) ==0)) { FREE_DYNAMIC_ARRAY(command_data); OS_error(); } # Alles, was in handles[1] reingeschoben wird, kommt bei handles[0] # wieder raus. Wir werden dies so benutzen: # # write system read # parent -> handles[1] -> handles[0] -> child # # einen neuen Proze▀ starten: if ((child = vfork()) ==0) # Dieses Programmstⁿck wird vom Child-Proze▀ ausgefⁿhrt: { if ( dup2(handles[0],stdin_handle) >=0) # Standard-Input umleiten if ( CLOSE(handles[0]) ==0) # Wir wollen nur ⁿber stdin_handle lesen if ( CLOSE(handles[1]) ==0) # Wir wollen auf die Pipe nicht schreiben # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Child # die Pipe geleert hat - der Parent-Proze▀ und nicht etwa der # Child-Proze▀ aufgerufen wird, um die Pipe zu wieder zu fⁿllen.) { # Child-Proze▀ zum Hintergrundproze▀ machen: SETSID(); # er bekommt eine eigene Process Group execl(SHELL, # Shell aufrufen SHELL, # =: argv[0] "-c", # =: argv[1] &command_data[0], # =: argv[2] NULL ); } _exit(-1); # sollte dies mi▀lingen, Child-Proze▀ beenden } # Dieses Programmstⁿck wird wieder vom Aufrufer ausgefⁿhrt: if (child==-1) # Etwas ist mi▀lungen, entweder beim vfork oder beim execl. # In beiden FΣllen wurde errno gesetzt. { var int saved_errno = errno; CLOSE(handles[1]); CLOSE(handles[0]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # Wir wollen auf die Pipe nur schreiben, nicht lesen: if (!( CLOSE(handles[0]) ==0)) { var int saved_errno = errno; CLOSE(handles[1]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Parent-Proze▀ # die Pipe gefⁿllt hat - der Child-Proze▀ und nicht etwa der # Parent-Proze▀ aufgerufen wird, um die Pipe wieder zu leeren.) end_system_call(); FREE_DYNAMIC_ARRAY(command_data); } #endif # Stream allozieren: { var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_pipe_out,strm_len+4); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_pipe_out); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_pipe_out); #endif TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid TheStream(stream)->strm_pipe_out_handle = allocate_handle(handles[1]); # Write-Handle value1 = stream; mv_count=1; # stream als Wert skipSTACK(1); }}} #ifdef PIPES2 # Bidirektionale Pipes # ==================== LISPFUNN(make_pipe_io_stream,1) # (MAKE-PIPE-IO-STREAM command) # ruft eine Shell auf, die command ausfⁿhrt, wobei der Output unserer Pipe # in deren Standard-Input hinein und deren Standard-Output wiederum in # unsere Pipe hinein geht. { # command ⁿberprⁿfen: var reg4 object command; funcall(L(string),1); # (STRING command) command = string_to_asciz(value1); # als ASCIZ-String pushSTACK(command); {var int in_handles[2]; # zwei Handles fⁿr die Pipe zum Input-Stream var int out_handles[2]; # zwei Handles fⁿr die Pipe zum Output-Stream var reg3 int child; #ifdef EMUNIX { # Stackaufbau: command. var FILE* f_in; var FILE* f_out; begin_system_call(); if (popenrw(TheAsciz(STACK_0),&f_in,&f_out) <0) { OS_error(); } child = f_in->pid; # = f_out->pid; in_handles[0] = fileno(f_in); out_handles[1] = fileno(f_out); } #endif #ifdef UNIX { # Als Shell nehmen wir immer die Kommando-Shell. # Stackaufbau: command. # command in den Stack kopieren: var reg5 uintL command_length = TheSstring(command)->length; var DYNAMIC_ARRAY(reg6,command_data,char,command_length); { var reg2 char* ptr1 = TheAsciz(command); var reg1 char* ptr2 = &command_data[0]; dotimespL(command_length,command_length, { *ptr2++ = *ptr1++; } ); } begin_system_call(); # Pipes aufbauen: if (!( pipe(in_handles) ==0)) { FREE_DYNAMIC_ARRAY(command_data); OS_error(); } if (!( pipe(out_handles) ==0)) { var int saved_errno = errno; CLOSE(in_handles[1]); CLOSE(in_handles[0]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # Alles, was in handles[1] reingeschoben wird, kommt bei handles[0] # wieder raus. Wir werden dies so benutzen: # # write system read # parent -> out_handles[1] -> out_handles[0] -> child # parent <- in_handles[0] <- in_handles[1] <- child # read system write # # einen neuen Proze▀ starten: if ((child = vfork()) ==0) # Dieses Programmstⁿck wird vom Child-Proze▀ ausgefⁿhrt: { if ( dup2(out_handles[0],stdin_handle) >=0) # Standard-Input umleiten if ( dup2(in_handles[1],stdout_handle) >=0) # Standard-Output umleiten if ( CLOSE(out_handles[0]) ==0) # Wir wollen nur ⁿber stdin_handle lesen if ( CLOSE(in_handles[1]) ==0) # Wir wollen nur ⁿber stdout_handle schreiben if ( CLOSE(out_handles[1]) ==0) # Wir wollen auf die Pipe nicht schreiben # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Child # die Pipe geleert hat - der Parent-Proze▀ und nicht etwa der # Child-Proze▀ aufgerufen wird, um die Pipe zu wieder zu fⁿllen.) if ( CLOSE(in_handles[0]) ==0) # Wir wollen von der Pipe nicht lesen # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Child # die Pipe gefⁿllt hat - der Parent-Proze▀ und nicht etwa der # Child-Proze▀ aufgerufen wird, um die Pipe zu leeren.) { # Child-Proze▀ zum Hintergrundproze▀ machen: SETSID(); # er bekommt eine eigene Process Group execl(SHELL, # Shell aufrufen SHELL, # =: argv[0] "-c", # =: argv[1] &command_data[0], # =: argv[2] NULL ); } _exit(-1); # sollte dies mi▀lingen, Child-Proze▀ beenden } # Dieses Programmstⁿck wird wieder vom Aufrufer ausgefⁿhrt: if (child==-1) # Etwas ist mi▀lungen, entweder beim vfork oder beim execl. # In beiden FΣllen wurde errno gesetzt. { var int saved_errno = errno; CLOSE(in_handles[1]); CLOSE(in_handles[0]); CLOSE(out_handles[1]); CLOSE(out_handles[0]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # Wir wollen auf die Pipe nur schreiben, nicht lesen: if (!( CLOSE(out_handles[0]) ==0)) { var int saved_errno = errno; CLOSE(in_handles[1]); CLOSE(in_handles[0]); CLOSE(out_handles[1]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Parent-Proze▀ # die Pipe gefⁿllt hat - der Child-Proze▀ und nicht etwa der # Parent-Proze▀ aufgerufen wird, um die Pipe wieder zu leeren.) # Wir wollen von der Pipe nur lesen, nicht schreiben: if (!( CLOSE(in_handles[1]) ==0)) { var int saved_errno = errno; CLOSE(in_handles[0]); CLOSE(out_handles[1]); FREE_DYNAMIC_ARRAY(command_data); errno = saved_errno; OS_error(); } # (Mu▀ das dem Betriebssystem sagen, damit - wenn der Parent-Proze▀ # die Pipe geleert hat - der Child-Proze▀ und nicht etwa der # Parent-Proze▀ aufgerufen wird, um die Pipe wieder zu fⁿllen.) end_system_call(); FREE_DYNAMIC_ARRAY(command_data); } #endif # Input-Stream allozieren: { var reg1 object stream = # neuer Stream, nur READ-CHAR erlaubt allocate_stream(strmflags_rd_ch_B,strmtype_pipe_in,strm_len+4); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_pipe_in); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_dummy); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_dummy); #endif TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid TheStream(stream)->strm_pipe_in_handle = allocate_handle(in_handles[0]); # Read-Handle TheStream(stream)->strm_isatty = NIL; pushSTACK(stream); } # Output-Stream allozieren: { var reg1 object stream = # neuer Stream, nur WRITE-CHAR erlaubt allocate_stream(strmflags_wr_ch_B,strmtype_pipe_out,strm_len+4); TheStream(stream)->strm_rd_by = P(rd_by_dummy); TheStream(stream)->strm_wr_by = P(wr_by_dummy); TheStream(stream)->strm_rd_ch = P(rd_ch_dummy); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_pipe_out); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_pipe_out); #endif TheStream(stream)->strm_pipe_pid = fixnum(child); # Child-Pid TheStream(stream)->strm_pipe_out_handle = allocate_handle(out_handles[1]); # Write-Handle pushSTACK(stream); } #ifdef EMUNIX # Beide Pipes miteinander verknⁿpfen, zum reibungslosen close: TheStream(STACK_1)->strm_pipe_in_other = STACK_0; TheStream(STACK_0)->strm_pipe_out_other = STACK_1; #endif # 3 Werte: # (make-two-way-stream input-stream output-stream), input-stream, output-stream. STACK_2 = make_twoway_stream(STACK_1,STACK_0); funcall(L(values),3); }} #endif # PIPES2 #endif # PIPES #ifdef SOCKETS # Socket-Stream # ============= # Verwendung: fⁿr X-Windows. # ZusΣtzliche Komponenten: # define strm_socket_connect strm_other[3] # Liste (host display) # READ-CHAR - Pseudofunktion fⁿr Socket-Streams: #define rd_ch_socket rd_ch_handle # Stellt fest, ob ein Socket-Stream ein Zeichen verfⁿgbar hat. # listen_socket(stream) # > stream : Socket-Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen #define listen_socket listen_handle # WRITE-CHAR - Pseudofunktion fⁿr Socket-Streams: #define wr_ch_socket wr_ch_handle #ifdef STRM_WR_SS # WRITE-SIMPLE-STRING - Pseudofunktion fⁿr Socket-Streams: #define wr_ss_socket wr_ss_handle #endif # READ-BYTE - Pseudofunktion fⁿr Socket-Streams: #define rd_by_socket rd_by_handle # WRITE-BYTE - Pseudofunktion fⁿr Socket-Streams: #define wr_by_socket wr_by_handle # Schlie▀t einen Socket-Stream. # close_socket(stream); # > stream : Socket-Stream #define close_socket close_ihandle extern int connect_to_server (char* host, int display); # ein Stⁿck X-Source... LISPFUNN(make_socket_stream,2) # (SYS::MAKE-SOCKET-STREAM host display) # liefert einen Socket-Stream fⁿr X-Windows oder NIL. { if (!mstringp(STACK_1)) { pushSTACK(STACK_1); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(S(string)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(STACK_(1+2)); fehler(type_error, DEUTSCH ? "Host mu▀ ein String sein, nicht ~" : ENGLISH ? "host should be string, not ~" : FRANCAIS ? "L'h⌠te devrait Ωtre un chaεne et non ~" : "" ); } if (!mposfixnump(STACK_0)) { pushSTACK(STACK_0); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(O(type_posfixnum)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(STACK_(0+2)); fehler(type_error, DEUTSCH ? "Display sollte ein Fixnum >=0 sein, nicht ~" : ENGLISH ? "display should be a nonnegative fixnum, not ~" : FRANCAIS ? "Le ½display╗ doit Ωtre de type FIXNUM >= 0 et non ~" : "" ); } begin_system_call(); {var reg2 int handle = connect_to_server(TheAsciz(string_to_asciz(STACK_1)),posfixnum_to_L(STACK_0)); end_system_call(); if (handle < 0) { OS_error(); } # Liste bilden: {var reg1 object list = listof(2); pushSTACK(list); } # Stream allozieren: {var reg1 object stream = # neuer Stream, nur READ-CHAR und WRITE-CHAR erlaubt allocate_stream(strmflags_ch_B,strmtype_socket,strm_len+4); TheStream(stream)->strm_rd_by = P(rd_by_socket); TheStream(stream)->strm_wr_by = P(wr_by_socket); TheStream(stream)->strm_rd_ch = P(rd_ch_socket); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_socket); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_socket); #endif TheStream(stream)->strm_socket_connect = popSTACK(); # zweielementige Liste TheStream(stream)->strm_ihandle = TheStream(stream)->strm_ohandle = allocate_handle(handle); # Handle eintragen TheStream(stream)->strm_isatty = NIL; value1 = stream; mv_count=1; # stream als Wert }}} # Die beiden folgenden Funktionen sollten # 1. nicht nur auf Handle- und Socket-Streams, sondern auch auf Synonym- # und Concatenated-Streams funktionieren, idealerweise auch auf File-Streams. # 2. das rd_ch_lastchar ebenso verΣndern wie READ-BYTE. # 3. auch nicht-simple Byte-Vektoren akzeptieren. # Fⁿr CLX reicht aber die vorliegende Implementation. # (SYS::READ-N-BYTES stream vector start count) # liest n Bytes auf einmal. # Quelle: # stream: Handle- oder Socket-Stream # Ziel: (aref vector start), ..., (aref vector (+ start (- count 1))), wobei # vector: semi-simpler 8Bit-Byte-Vektor # start: Start-Index in den Vektor # count: Anzahl der Bytes # (SYS::WRITE-N-BYTES stream vector start count) # schreibt n Bytes auf einmal. # Quelle: (aref vector start), ..., (aref vector (+ start (- count 1))), wobei # vector: semi-simpler 8Bit-Byte-Vektor # start: Start-Index in den Vektor # count: Anzahl der Bytes # Ziel: # stream: Handle- oder Socket-Stream # Argumentⁿberprⁿfungen: # Liefert den Index in *index_, den count in *count_, den Datenvektor im # Stack statt des Vektors, und rΣumt den Stack um 2 auf. local void test_n_bytes_args (uintL* index_, uintL* count_); local void test_n_bytes_args(index_,count_) var reg3 uintL* index_; var reg2 uintL* count_; { if (!mstreamp(STACK_3)) { fehler_stream(STACK_3); } {var reg1 object stream = STACK_3; if (!( eq(TheStream(stream)->strm_rd_by,P(rd_by_handle)) && eq(TheStream(stream)->strm_wr_by,P(wr_by_handle)) ) ) { pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: Stream mu▀ ein Handle-Stream sein, nicht ~" : ENGLISH ? "~: stream must be a handle-stream, not ~" : FRANCAIS ? "~ : Le stream doit Ωtre un ½handle-stream╗ et non ~" : "" ); } } {var reg1 object vector = STACK_2; if (!(((typecode(vector)&~imm_array_mask) == bvector_type) # Bit/Byte-Vektor? && ((TheArray(vector)->flags & arrayflags_atype_mask) == Atype_8Bit) # 8Bit ) ) { pushSTACK(vector); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(O(type_uint8_vector)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(vector); pushSTACK(TheSubr(subr_self)->name); fehler(type_error, DEUTSCH ? "~: Argument ~ sollte ein Vektor vom Typ (ARRAY (UNSIGNED-BYTE 8) (*)) sein." : ENGLISH ? "~: argument ~ should be a vector of type (ARRAY (UNSIGNED-BYTE 8) (*))" : FRANCAIS ? "~ : l'argument ~ doit Ωtre un vecteur de type (ARRAY (UNSIGNED-BYTTE 8) (*))." : "" ); } if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); } *count_ = posfixnum_to_L(popSTACK()); if (!mposfixnump(STACK_0)) { fehler_bad_lpos(); } *index_ = posfixnum_to_L(popSTACK()); STACK_0 = array1_displace_check(vector,*count_,index_); } } LISPFUNN(read_n_bytes,4) { var uintL startindex; var uintL totalcount; test_n_bytes_args(&startindex,&totalcount); if (!(totalcount==0)) { var reg4 Handle handle = TheHandle(TheStream(STACK_1)->strm_ihandle); var reg2 uintL remaining = totalcount; restart_it: {var reg1 uintB* ptr = &TheSbvector(TheArray(STACK_0)->data)->data[startindex]; begin_system_call(); loop { var reg3 int ergebnis = read(handle,ptr,remaining); if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { end_system_call(); interruptp({ pushSTACK(S(read_n_bytes)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } OS_error(); # Error melden } ptr += ergebnis; startindex += ergebnis; remaining -= ergebnis; if (remaining==0) break; # fertig? } end_system_call(); }} skipSTACK(2); value1 = T; mv_count=1; # Wert T } LISPFUNN(write_n_bytes,4) { var uintL startindex; var uintL totalcount; test_n_bytes_args(&startindex,&totalcount); if (!(totalcount==0)) { var reg4 Handle handle = TheHandle(TheStream(STACK_1)->strm_ihandle); var reg2 uintL remaining = totalcount; restart_it: {var reg1 uintB* ptr = &TheSbvector(TheArray(STACK_0)->data)->data[startindex]; begin_system_call(); loop { var reg3 int ergebnis = write(handle,ptr,remaining); if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { end_system_call(); interruptp({ pushSTACK(S(write_n_bytes)); tast_break(); }); # Break-Schleife aufrufen goto restart_it; } OS_error(); # Error melden } if (ergebnis==0) # nicht erfolgreich? { fehler_unwritable(S(write_n_bytes),STACK_1); } ptr += ergebnis; startindex += ergebnis; remaining -= ergebnis; if (remaining==0) break; # fertig? } end_system_call(); }} skipSTACK(2); value1 = T; mv_count=1; # Wert T } #endif #ifdef GENERIC_STREAMS # Generic Streams # =============== # Contains a "controller object". # define strm_controller_object strm_other[0] # see lispbibl.d # The function GENERIC-STREAM-CONTROLLER will return some # object c associated with the stream s. # (GENERIC-STREAM-READ-CHAR c) --> character or NIL # (GENERIC-STREAM-LISTEN c) --> {0,1,-1} # (GENERIC-STREAM-CLEAR-INPUT c) --> {T,NIL} # (GENERIC-STREAM-WRITE-CHAR c ch) --> # (GENERIC-STREAM-WRITE-STRING c string start len) --> # (GENERIC-STREAM-FINISH-OUTPUT c) --> # (GENERIC-STREAM-FORCE-OUTPUT c) --> # (GENERIC-STREAM-CLEAR-OUTPUT c) --> # (GENERIC-STREAM-READ-BYTE c) --> integer or NIL # (GENERIC-STREAM-WRITE-BYTE c i) --> # (GENERIC-STREAM-CLOSE c) --> # (READ-CHAR s) == # (GENERIC-STREAM-READ-CHAR c) local object rd_ch_generic (object* stream_); local object rd_ch_generic(stream_) var reg1 object* stream_; { pushSTACK(*stream_); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_rdch),1); return nullp(value1) ? eof_value : value1; } # (LISTEN s) == # (GENERIC-STREAM-LISTEN c) local signean listen_generic (object stream); local signean listen_generic(stream) var reg1 object stream; { pushSTACK(stream); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_listen),1); return I_to_L(value1); } # (CLEAR-INPUT s) == # (GENERIC-STREAM-CLEAR-INPUT c) local boolean clear_input_generic (object stream); local boolean clear_input_generic(stream) var reg1 object stream; { pushSTACK(stream); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_clear_input),1); return !nullp(value1); } # (WRITE-CHAR ch s) == # (GENERIC-STREAM-WRITE-CHAR c ch) local void wr_ch_generic (object* stream_, object ch); local void wr_ch_generic(stream_,ch) var reg1 object* stream_; var reg2 object ch; { # ch is a character, need not save it pushSTACK(*stream_); funcall(L(generic_stream_controller),1); pushSTACK(value1); pushSTACK(ch); funcall(S(generic_stream_wrch),2); } #ifdef STRM_WR_SS # (WRITE-SIMPLE-STRING s string start len) == # (GENERIC-STREAM-WRITE-STRING c string start len) local void wr_ss_generic (object* stream_, object string, uintL start, uintL len); local void wr_ss_generic(stream_,string,start,len) var reg2 object* stream_; var reg1 object string; var reg3 uintL start; var reg4 uintL len; { pushSTACK(string); # save string pushSTACK(*stream_); funcall(L(generic_stream_controller),1); pushSTACK(value1); pushSTACK(STACK_(0+1)); pushSTACK(UL_to_I(start)); pushSTACK(UL_to_I(len)); funcall(S(generic_stream_wrss),4); string = popSTACK(); wr_ss_lpos(*stream_,&TheSstring(string)->data[start],len); } #endif # (FINISH-OUTPUT s) == # (GENERIC-STREAM-FINISH-OUTPUT c) local void finish_output_generic (object stream); local void finish_output_generic(stream) var reg1 object stream; { pushSTACK(stream); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_finish_output),1); } # (FORCE-OUTPUT s) == # (GENERIC-STREAM-FORCE-OUTPUT c) local void force_output_generic (object stream); local void force_output_generic(stream) var reg1 object stream; { pushSTACK(stream); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_force_output),1); } # (CLEAR-OUTPUT s) == # (GENERIC-STREAM-CLEAR-OUTPUT c) local void clear_output_generic (object stream); local void clear_output_generic(stream) var reg1 object stream; { pushSTACK(stream); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_clear_output),1); } # (READ-BYTE s) == # (GENERIC-STREAM-READ-BYTE c) local object rd_by_generic (object stream); local object rd_by_generic(stream) var reg1 object stream; { pushSTACK(stream); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_rdby),1); return (nullp(value1) ? eof_value : value1); } # (WRITE-BYTE s i) == # (GENERIC-STREAM-WRITE-BYTE c i) local void wr_by_generic (object stream, object obj); local void wr_by_generic(stream,obj) var reg2 object stream; var reg1 object obj; { pushSTACK(obj); # save obj pushSTACK(stream); funcall(L(generic_stream_controller),1); obj = STACK_0; STACK_0 = value1; pushSTACK(obj); funcall(S(generic_stream_wrby),2); } # (CLOSE s) == # (GENERIC-STREAM-CLOSE c) local void close_generic(stream) var reg1 object stream; { pushSTACK(stream); funcall(L(generic_stream_controller),1); pushSTACK(value1); funcall(S(generic_stream_close),1); } LISPFUNN(generic_stream_controller,1) { var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } if (!( eq(TheStream(stream)->strm_rd_by,P(rd_by_generic)) && eq(TheStream(stream)->strm_wr_by,P(wr_by_generic)))) { pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: Stream mu▀ ein Generic-Stream sein, nicht ~" : ENGLISH ? "~: stream must be a generic-stream, not ~" : FRANCAIS ? "~ : Le stream doit Ωtre un ½generic-stream╗ et non ~" : "" ); } value1=TheStream(stream)->strm_controller_object; mv_count=1; } LISPFUNN(make_generic_stream,1) { var reg1 object stream = allocate_stream(strmflags_open_B,strmtype_generic,strm_len+1); TheStream(stream)->strm_rd_by = P(rd_by_generic); TheStream(stream)->strm_wr_by = P(wr_by_generic); TheStream(stream)->strm_rd_ch = P(rd_ch_generic); TheStream(stream)->strm_rd_ch_last = NIL; TheStream(stream)->strm_wr_ch = P(wr_ch_generic); TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; #ifdef STRM_WR_SS TheStream(stream)->strm_wr_ss = P(wr_ss_generic); #endif TheStream(stream)->strm_controller_object = popSTACK(); value1 = stream; mv_count=1; # stream als Wert } LISPFUNN(generic_stream_p,1) { var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } if ((eq(TheStream(stream)->strm_rd_by,P(rd_by_generic)) && eq(TheStream(stream)->strm_wr_by,P(wr_by_generic)))) { value1 = T; mv_count=1; } else { value1 = NIL; mv_count=1; } } #endif # Streams allgemein # ================= # UP: Initialisiert die Stream-Variablen. # init_streamvars(); # kann GC ausl÷sen global void init_streamvars (void); global void init_streamvars() { #ifdef KEYBOARD #ifdef ATARI keytables = *(KEYTAB*)XBIOS_GetKeyTbl(); # Keyboard-Stream initialisieren #endif {var reg1 object stream = make_keyboard_stream(); define_variable(S(keyboard_input),stream); # *KEYBOARD-INPUT* } #endif #ifdef GNU_READLINE rl_readline_name = "Clisp"; rl_attempted_completion_function = &lisp_completion; rl_completion_entry_function = &lisp_completion_more; #endif {var reg1 object stream = make_terminal_stream(); define_variable(S(terminal_io),stream); # *TERMINAL-IO* } {var reg1 object stream = make_synonym_stream(S(terminal_io)); # Synonym-Stream auf *TERMINAL-IO* define_variable(S(query_io),stream); # *QUERY-IO* define_variable(S(debug_io),stream); # *DEBUG-IO* define_variable(S(standard_input),stream); # *STANDARD-INPUT* define_variable(S(standard_output),stream); # *STANDARD-OUTPUT* define_variable(S(error_output),stream); # *ERROR-OUTPUT* define_variable(S(trace_output),stream); # *TRACE-OUTPUT* } #ifdef PRINTER_ATARI # *PRINTER-OUTPUT* mit Printer-Stream initialisieren: define_variable(S(printer_output),make_printer_stream()); #endif } # Liefert Fehlermeldung, wenn der Wert des Symbols sym kein Stream ist. local void fehler_value_stream(sym) var reg1 object sym; { # Vor der Fehlermeldung eventuell noch reparieren # (so wie bei init_streamvars bzw. init_pathnames initialisiert): var reg2 object stream; pushSTACK(sym); # sym retten #ifdef KEYBOARD if (eq(sym,S(keyboard_input))) # Keyboard-Stream als Default { stream = make_keyboard_stream(); } else #endif if (eq(sym,S(terminal_io))) # Terminal-Stream als Default { stream = make_terminal_stream(); } elif (eq(sym,S(query_io)) || eq(sym,S(debug_io)) || eq(sym,S(standard_input)) || eq(sym,S(standard_output)) || eq(sym,S(error_output)) || eq(sym,S(trace_output)) ) # Synonym-Stream auf *TERMINAL-IO* als Default { stream = make_synonym_stream(S(terminal_io)); } #ifdef PRINTER_ATARI elif (eq(sym,S(printer_output))) # Printer-Stream als Default { stream = make_printer_stream(); } #endif else # sonstiges Symbol, nicht reparierbar -> sofort Fehlermeldung: { pushSTACK(Symbol_value(sym)); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(S(stream)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(Symbol_value(sym)); # Variablenwert pushSTACK(sym); # Variable fehler(type_error, DEUTSCH ? "Der Wert von ~ ist kein Stream: ~" : ENGLISH ? "The value of ~ is not a stream: ~" : FRANCAIS ? "La valeur de ~ n'est pas de type STREAM : ~" : "" ); } sym = popSTACK(); # Reparatur beendet: stream ist der neue Wert von sym. {var reg3 object oldvalue = Symbol_value(sym); Symbol_value(sym) = stream; pushSTACK(oldvalue); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(S(stream)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(stream); # neuer Variablenwert pushSTACK(oldvalue); # alter Variablenwert pushSTACK(sym); # Variable fehler(type_error, DEUTSCH ? "Der Wert von ~ war kein Stream: ~. Wurde zurⁿckgesetzt auf ~." : ENGLISH ? "The value of ~ was not a stream: ~. It has been changed to ~." : FRANCAIS ? "La valeur de ~ n'Θtait pas de type STREAM : ~. ChangΘ en ~." : "" ); }} #ifdef GNU_READLINE # Hilfsfunktionen fⁿr die GNU readline Library: nonreturning_function(local, rl_memory_abort, (void)); local void rl_memory_abort() { # Wenn fⁿr die Readline-Library der Speicher nicht mehr reicht, # schmei▀en wir sie raus und ersetzen den Terminal-Stream durch einen, # der ohne sie auskommt. rl_deprep_terminal(); # alle komischen ioctl()s rⁿckgΣngig machen begin_callback(); # STACK wieder auf einen vernⁿnftigen Wert setzen rl_present_p = FALSE; Symbol_value(S(terminal_io)) = make_terminal_stream(); fehler(storage_condition, DEUTSCH ? "Readline-Library: kein freier Speicher mehr da." : ENGLISH ? "readline library: out of memory." : FRANCAIS ? "BibliothΦque readline: mΘmoire ΘpuisΘe." : "" ); } global char* xmalloc (int count); global char* xmalloc(count) var reg2 int count; { var reg1 char* tmp = (char*)malloc(count); if (tmp) return tmp; else rl_memory_abort(); } global char* xrealloc (char* ptr, int count); global char* xrealloc(ptr,count) var reg2 char* ptr; var reg2 int count; { var reg1 char* tmp = (ptr==NULL ? (char*)malloc(count) : (char*)realloc(ptr,count)); if (tmp) return tmp; else rl_memory_abort(); } #endif LISPFUNN(input_stream_p,1) # (INPUT-STREAM-P stream), CLTL S. 332 { var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } if (TheStream(stream)->strmflags & strmflags_rd_B) # READ-BYTE oder READ-CHAR erlaubt ? { value1 = T; mv_count=1; } # Wert T else { value1 = NIL; mv_count=1; } # Wert NIL } LISPFUNN(output_stream_p,1) # (OUTPUT-STREAM-P stream), CLTL S. 332 { var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } if (TheStream(stream)->strmflags & strmflags_wr_B) # WRITE-BYTE oder WRITE-CHAR erlaubt ? { value1 = T; mv_count=1; } # Wert T else { value1 = NIL; mv_count=1; } # Wert NIL } LISPFUNN(stream_element_type,1) # (STREAM-ELEMENT-TYPE stream), CLTL S. 332 # liefert NIL (fⁿr geschlossene Streams) oder CHARACTER oder INTEGER oder T # oder (spezieller) STRING-CHAR oder (UNSIGNED-BYTE n) oder (SIGNED-BYTE n). { var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } {var reg2 object eltype; if ((TheStream(stream)->strmflags & strmflags_open_B) == 0) # Stream geschlossen { eltype = NIL; } else # Stream offen { switch (TheStream(stream)->strmtype) { # erst die Streamtypen mit eingeschrΣnkten Element-Typen: #ifdef KEYBOARD case strmtype_keyboard: #endif case strmtype_ch_file: # CHARACTER eltype = S(character); break; case strmtype_terminal: case strmtype_sch_file: case strmtype_str_in: case strmtype_str_out: case strmtype_str_push: case strmtype_pphelp: case strmtype_buff_in: case strmtype_buff_out: #ifdef SCREEN case strmtype_window: #endif #ifdef PRINTER case strmtype_printer: #endif #ifdef PIPES case strmtype_pipe_in: case strmtype_pipe_out: #endif # STRING-CHAR eltype = S(string_char); break; case strmtype_iu_file: # (UNSIGNED-BYTE bitsize) pushSTACK(S(unsigned_byte)); pushSTACK(TheStream(stream)->strm_file_bitsize); eltype = listof(2); break; case strmtype_is_file: # (SIGNED-BYTE bitsize) pushSTACK(S(signed_byte)); pushSTACK(TheStream(stream)->strm_file_bitsize); eltype = listof(2); break; # dann die allgemeinen Streams: #ifdef HANDLES case strmtype_handle: #endif #ifdef GENERIC_STREAMS case strmtype_generic: #endif default: { var reg1 uintB flags = TheStream(stream)->strmflags; if (flags & strmflags_by_B) { if (flags & strmflags_ch_B) # (OR CHARACTER INTEGER) { pushSTACK(S(or)); pushSTACK(S(character)); pushSTACK(S(integer)); eltype = listof(3); } else # INTEGER { eltype = S(integer); } } else { if (flags & strmflags_ch_B) # CHARACTER { eltype = S(character); } else # NIL { eltype = NIL; } } break; } } } value1 = eltype; mv_count=1; }} # UP: Stellt fest, ob ein Stream "interaktiv" ist, d.h. ob Input vom Stream # vermutlich von einem vorher ausgegebenen Prompt abhΣngen wird. # interactive_stream_p(stream) # > stream: Stream local boolean interactive_stream_p (object stream); local boolean interactive_stream_p(stream) var reg1 object stream; { start: if ((TheStream(stream)->strmflags & strmflags_rd_B) == 0) # Stream fⁿr Input geschlossen { return FALSE; } # Stream offen switch (TheStream(stream)->strmtype) { #if !defined(WINDOWS) || defined(HANDLES) #ifndef WINDOWS case strmtype_terminal: #endif #ifdef HANDLES case strmtype_handle: #endif #if defined(UNIX) || defined(MSDOS) || defined(AMIGAOS) || defined(RISCOS) if (nullp(TheStream(stream)->strm_isatty)) # RegulΣre Files sind sicher nicht interaktiv. { var reg2 Handle handle = TheHandle(TheStream(stream)->strm_ihandle); #if defined(UNIX) || defined(MSDOS) || defined(RISCOS) var struct stat statbuf; begin_system_call(); if (!( fstat(handle,&statbuf) ==0)) { OS_error(); } end_system_call(); if (S_ISREG(statbuf.st_mode)) #endif #ifdef AMIGAOS var reg3 LONG interactivep; begin_system_call(); interactivep = IsInteractive(handle); end_system_call(); if (!interactivep) #endif return FALSE; } #endif #endif #ifdef KEYBOARD case strmtype_keyboard: #endif #ifdef WINDOWS case strmtype_terminal: #endif case strmtype_buff_in: #ifdef PIPES case strmtype_pipe_in: #endif #ifdef GENERIC_STREAMS case strmtype_generic: #endif return TRUE; case strmtype_synonym: # Synonym-Stream: weiterverfolgen { var reg2 object symbol = TheStream(stream)->strm_synonym_symbol; stream = get_synonym_stream(symbol); /* return interactive_stream_p(stream); */ # entrekursiviert: goto start; } case strmtype_concat: # den ersten der Streams abfragen: { var reg2 object streamlist = TheStream(stream)->strm_concat_list; # Liste von Streams if (consp(streamlist)) { stream = Car(streamlist); /* return interactive_stream_p(stream); */ # entrekursiviert: goto start; } else { return FALSE; } } case strmtype_twoway: case strmtype_echo: { # Two-Way-Stream oder Echo-Stream: Input-Stream anschauen stream = TheStream(stream)->strm_twoway_input; /* return interactive_stream_p(stream); */ # entrekursiviert: goto start; } case strmtype_sch_file: case strmtype_ch_file: case strmtype_iu_file: case strmtype_is_file: case strmtype_str_in: default: return FALSE; } } LISPFUNN(interactive_stream_p,1) # (INTERACTIVE-STREAM-P stream), CLTL2 S. 507/508 # stellt fest, ob stream interaktiv ist. { value1 = (interactive_stream_p(popSTACK()) ? T : NIL); mv_count=1; } # UP: Schlie▀t einen Stream. # stream_close(&stream); # > stream: Stream # < stream: Stream # kann GC ausl÷sen global void stream_close (object* stream_); global void stream_close(stream_) var reg2 object* stream_; { var reg1 object stream = *stream_; if ((TheStream(stream)->strmflags & strmflags_open_B) == 0) # Stream schon geschlossen? return; # Typspezifische Routine aufrufen (darf GC ausl÷sen): switch (TheStream(stream)->strmtype) { #ifdef KEYBOARD case strmtype_keyboard: break; #endif case strmtype_terminal: break; case strmtype_sch_file: case strmtype_ch_file: case strmtype_iu_file: case strmtype_is_file: close_file(stream); break; case strmtype_synonym: close_synonym(stream); break; case strmtype_broad: break; # nichtrekursiv case strmtype_concat: break; # nichtrekursiv case strmtype_twoway: break; # nichtrekursiv case strmtype_echo: break; # nichtrekursiv case strmtype_str_in: close_str_in(stream); break; case strmtype_str_out: break; case strmtype_str_push: break; case strmtype_pphelp: break; case strmtype_buff_in: close_buff_in(stream); break; case strmtype_buff_out: close_buff_out(stream); break; #ifdef SCREEN case strmtype_window: close_window(stream); break; #endif #ifdef PRINTER_ATARI case strmtype_printer: break; #endif #ifdef PRINTER_AMIGAOS case strmtype_printer: close_printer(stream); break; #endif #ifdef HANDLES case strmtype_handle: close_handle(stream); break; #endif #ifdef PIPES case strmtype_pipe_in: close_pipe_in(stream); break; case strmtype_pipe_out: close_pipe_out(stream); break; #endif #ifdef SOCKETS case strmtype_socket: close_socket(stream); break; #endif #ifdef GENERIC_STREAMS case strmtype_generic: close_generic(stream); break; #endif default: NOTREACHED } # Dummys eintragen: close_dummys(*stream_); } # UP: Schlie▀t eine Liste offener Files. # close_some_files(list); # > list: Liste von offenen Streams # kann GC ausl÷sen global void close_some_files (object list); global void close_some_files(list) var reg2 object list; { pushSTACK(NIL); # dummy pushSTACK(list); # list while (mconsp(STACK_0)) { var reg1 object streamlist = STACK_0; STACK_0 = Cdr(streamlist); # restliche Streams STACK_1 = Car(streamlist); # ein Stream aus der Liste stream_close(&STACK_1); # schlie▀en } skipSTACK(2); } # UP: Schlie▀t alle offenen Files. # close_all_files(); # kann GC ausl÷sen global void close_all_files (void); global void close_all_files() { close_some_files(O(open_files)); } # Liste aller offenen File-Streams # UP: ErklΣrt alle offenen File-Streams fⁿr geschlossen. # closed_all_files(); global void closed_all_files (void); global void closed_all_files() { var reg2 object streamlist = O(open_files); # Liste aller offenen File-Streams while (consp(streamlist)) { var reg1 object stream = Car(streamlist); # ein Stream aus der Liste if_strm_bfile_p(stream, # File-Stream ? { if (!nullp(TheStream(stream)->strm_file_handle)) # mit Handle /= NIL ? # ja: Stream noch offen { closed_file(stream); } }, ; ); close_dummys(stream); streamlist = Cdr(streamlist); # restliche Streams } O(open_files) = NIL; # keine offenen Files mehr } LISPFUN(close,1,0,norest,key,1, (kw(abort)) ) # (CLOSE stream :abort), CLTL S. 332 { skipSTACK(1); # :ABORT-Argument ignorieren {var reg1 object stream = STACK_0; # Argument if (!streamp(stream)) { fehler_stream(stream); } # mu▀ ein Stream sein stream_close(&STACK_0); # schlie▀en skipSTACK(1); value1 = T; mv_count=1; # T als Ergebnis }} # UP: Stellt fest, ob im Stream stream ein Zeichen sofort verfⁿgbar ist. # stream_listen(stream) # > stream: Stream # < ergebnis: 0 falls Zeichen verfⁿgbar, # -1 falls bei EOF angelangt, # +1 falls kein Zeichen verfⁿgbar, aber nicht wegen EOF # kann GC ausl÷sen global signean stream_listen (object stream); global signean stream_listen(stream) var reg1 object stream; { check_SP(); check_STACK(); if (mposfixnump(TheStream(stream)->strm_rd_ch_last)) # Char nach UNREAD ? { return signean_null; } # ja -> verfⁿgbar else # sonst nach Streamtyp verzweigen. # Jede Einzelroutine darf GC ausl÷sen. Au▀er beim Keyboard-Stream # oder Terminal-Stream handelt es sich um einen reinen EOF-Test. { switch (TheStream(stream)->strmtype) { #ifdef KEYBOARD case strmtype_keyboard: return listen_keyboard(stream); #endif case strmtype_terminal: #if defined(ATARI) || defined(WINDOWS) return listen_terminal(stream); #endif #if defined(UNIX) || (defined(MSDOS) && !defined(WINDOWS)) || defined(AMIGAOS) || defined(RISCOS) terminalcase(stream, { return listen_terminal1(stream); }, { return listen_terminal2(stream); }, { return listen_terminal3(stream); } ); #endif NOTREACHED case strmtype_sch_file: if (TheStream(stream)->strmflags & strmflags_rd_ch_B) { return listen_sch_file(stream); } else { return signean_minus; } # kein READ-CHAR case strmtype_ch_file: if (TheStream(stream)->strmflags & strmflags_rd_ch_B) { return listen_ch_file(stream); } else { return signean_minus; } # kein READ-CHAR case strmtype_iu_file: return signean_minus; # kein READ-CHAR case strmtype_is_file: return signean_minus; # kein READ-CHAR case strmtype_synonym: return listen_synonym(stream); case strmtype_broad: return signean_minus; # kein READ-CHAR case strmtype_concat: return listen_concat(stream); case strmtype_twoway: return listen_twoway(stream); case strmtype_echo: return listen_twoway(stream); case strmtype_str_in: return listen_str_in(stream); case strmtype_str_out: return signean_minus; # kein READ-CHAR case strmtype_str_push: return signean_minus; # kein READ-CHAR case strmtype_pphelp: return signean_minus; # kein READ-CHAR case strmtype_buff_in: return listen_buff_in(stream); case strmtype_buff_out: return signean_minus; # kein READ-CHAR #ifdef SCREEN case strmtype_window: return signean_minus; # kein READ-CHAR #endif #ifdef PRINTER case strmtype_printer: return signean_minus; # kein READ-CHAR #endif #ifdef HANDLES case strmtype_handle: if (TheStream(stream)->strmflags & strmflags_rd_ch_B) { return listen_handle(stream); } else { return signean_minus; } # kein READ-CHAR #endif #ifdef PIPES case strmtype_pipe_in: return listen_pipe_in(stream); case strmtype_pipe_out: return signean_minus; # kein READ-CHAR #endif #ifdef SOCKETS case strmtype_socket: return listen_socket(stream); #endif #ifdef GENERIC_STREAMS case strmtype_generic: return listen_generic(stream); #endif default: # Allgemein: nur EOF abfragen if (TheStream(stream)->strmflags & strmflags_rd_ch_B) { pushSTACK(stream); {var reg2 object nextchar = peek_char(&STACK_0); skipSTACK(1); if (eq(nextchar,eof_value)) { return signean_minus; } # EOF erreicht else { return signean_null; } }} else { return signean_minus; } # kein READ-CHAR } } } # UP: L÷scht bereits eingegebenen interaktiven Input von einem Stream stream. # clear_input(stream) # > stream: Stream # < ergebnis: TRUE falls Input gel÷scht wurde # kann GC ausl÷sen global boolean clear_input (object stream); global boolean clear_input(stream) var reg1 object stream; { check_SP(); check_STACK(); pushSTACK(stream); # Stream retten # Typspezifische Routine aufrufen (darf GC ausl÷sen). # Nur beim Keyboard-Stream und Terminal-Stream wird etwas getan. {var reg2 boolean ergebnis; switch (TheStream(stream)->strmtype) { #ifdef KEYBOARD case strmtype_keyboard: ergebnis = clear_input_keyboard(stream); break; #endif case strmtype_terminal: #if defined(ATARI) || defined(WINDOWS) ergebnis = clear_input_terminal(stream); #endif #if defined(UNIX) || (defined(MSDOS) && !defined(WINDOWS)) || defined(AMIGAOS) || defined(RISCOS) terminalcase(stream, { ergebnis = clear_input_terminal1(stream); }, { ergebnis = clear_input_terminal2(stream); }, { ergebnis = clear_input_terminal3(stream); } ); #endif break; case strmtype_synonym: ergebnis = clear_input_synonym(stream); break; case strmtype_concat: ergebnis = clear_input_concat(stream); break; case strmtype_twoway: case strmtype_echo: ergebnis = clear_input_twoway(stream); break; case strmtype_buff_in: ergebnis = clear_input_buff_in(stream); break; #ifdef HANDLES case strmtype_handle: if (TheStream(stream)->strmflags & strmflags_rd_ch_B) { ergebnis = clear_input_handle(stream); } else { ergebnis = FALSE; } break; #endif #ifdef GENERIC_STREAMS case strmtype_generic: ergebnis = clear_input_generic(stream); break; #endif #ifdef PIPES case strmtype_pipe_in: # Pipe: nichts l÷schen?? #endif #ifdef SOCKETS case strmtype_socket: # Socket: nichts l÷schen?? #endif default: ergebnis = FALSE; break; } stream = popSTACK(); if (ergebnis) # Input wurde gel÷scht -> auch das Lastchar mu▀ gel÷scht werden. # Dabei wird auch ein schon gesehenes EOF vergessen. { TheStream(stream)->strm_rd_ch_last = NIL; } return ergebnis; }} # UP: Wartenden Output eines Stream stream ans Ziel bringen. # finish_output(stream); # > stream: Stream # kann GC ausl÷sen global void finish_output (object stream); global void finish_output(stream) var reg1 object stream; { if (TheStream(stream)->strmflags & strmflags_wr_B) # Output-Stream? # nein -> fertig, ja -> nach Streamtyp verzweigen: { switch (TheStream(stream)->strmtype) { case strmtype_terminal: finish_output_terminal(stream); break; case strmtype_sch_file: case strmtype_ch_file: case strmtype_iu_file: case strmtype_is_file: finish_output_file(stream); break; case strmtype_synonym: finish_output_synonym(stream); break; case strmtype_broad: finish_output_broad(stream); break; case strmtype_twoway: case strmtype_echo: finish_output_twoway(stream); break; case strmtype_buff_out: finish_output_buff_out(stream); break; #ifdef PRINTER_AMIGAOS case strmtype_printer: # Printer: # Schlie▀en und neu aufmachen wⁿrde vermutlich einen # Seitenvorschub ausgeben, und das ist ja wohl nicht erwⁿnscht. break; # Daher nichts tun. #endif #ifdef HANDLES case strmtype_handle: finish_output_handle(stream); break; #endif #ifdef GENERIC_STREAMS case strmtype_generic: finish_output_generic(stream); break; #endif #ifdef PIPES case strmtype_pipe_out: # Pipe: kann nichts tun #endif #ifdef SOCKETS case strmtype_socket: # Socket: kann nichts tun #endif default: # nichts tun break; } } } # UP: Wartenden Output eines Stream stream ans Ziel bringen. # force_output(stream); # > stream: Stream # kann GC ausl÷sen global void force_output (object stream); global void force_output(stream) var reg1 object stream; { if (TheStream(stream)->strmflags & strmflags_wr_B) # Output-Stream? # nein -> fertig, ja -> nach Streamtyp verzweigen: { switch (TheStream(stream)->strmtype) { case strmtype_terminal: force_output_terminal(stream); break; case strmtype_sch_file: case strmtype_ch_file: case strmtype_iu_file: case strmtype_is_file: force_output_file(stream); break; case strmtype_synonym: force_output_synonym(stream); break; case strmtype_broad: force_output_broad(stream); break; case strmtype_twoway: case strmtype_echo: force_output_twoway(stream); break; case strmtype_buff_out: force_output_buff_out(stream); break; #ifdef PRINTER_AMIGAOS case strmtype_printer: # Printer: # Schlie▀en und neu aufmachen wⁿrde vermutlich einen # Seitenvorschub ausgeben, und das ist ja wohl nicht erwⁿnscht. break; # Daher nichts tun. #endif #ifdef HANDLES case strmtype_handle: force_output_handle(stream); break; #endif #ifdef GENERIC_STREAMS case strmtype_generic: force_output_generic(stream); break; #endif #ifdef PIPES case strmtype_pipe_out: # Pipe: kann nichts tun #endif #ifdef SOCKETS case strmtype_socket: # Socket: kann nichts tun #endif default: # nichts tun break; } } } # UP: Wartenden Output eines Stream stream l÷schen. # clear_output(stream); # > stream: Stream # kann GC ausl÷sen global void clear_output (object stream); global void clear_output(stream) var reg1 object stream; { # Auf dem ATARI oder unter DOS ist zwar bei keinem File- oder # Terminal-Stream etwas zu tun, aber das kann man nicht ausnutzen, denn # clear_output auf Buffered-Output-Streams geht immer. if (TheStream(stream)->strmflags & strmflags_wr_B) # Output-Stream? # nein -> fertig, ja -> nach Streamtyp verzweigen: { switch (TheStream(stream)->strmtype) { case strmtype_terminal: #if defined(UNIX) || (defined(MSDOS) && !defined(WINDOWS)) || defined(AMIGAOS) || defined(RISCOS) terminalcase(stream, { clear_output_terminal1(stream); }, { clear_output_terminal2(stream); }, { clear_output_terminal3(stream); } ); #endif break; case strmtype_sch_file: case strmtype_ch_file: case strmtype_iu_file: case strmtype_is_file: # File: nichts tun (wⁿrde die File-Verwaltung durcheinanderbringen) break; case strmtype_synonym: clear_output_synonym(stream); break; case strmtype_broad: clear_output_broad(stream); break; case strmtype_twoway: case strmtype_echo: clear_output_twoway(stream); break; case strmtype_buff_out: clear_output_buff_out(stream); break; #ifdef PRINTER_AMIGAOS case strmtype_printer: # Printer: ungebuffert, also nichts zu tun break; #endif #ifdef HANDLES case strmtype_handle: clear_output_handle(stream); break; #endif #ifdef PIPES case strmtype_pipe_out: # Pipe: geht nicht break; #endif #ifdef SOCKETS case strmtype_socket: # Socket: geht nicht break; #endif #ifdef GENERIC_STREAMS case strmtype_generic: clear_output_generic(stream); break; #endif default: # nichts tun break; } } } # UP: Liefert die Line-Position eines Streams. # get_line_position(stream) # > stream: Stream # < ergebnis: Line-Position (Fixnum >=0) global object get_line_position (object stream); global object get_line_position(stream) var reg1 object stream; { check_SP(); start: switch (TheStream(stream)->strmtype) { case strmtype_synonym: # Synonym-Stream: weiterverfolgen { var reg2 object symbol = TheStream(stream)->strm_synonym_symbol; stream = get_synonym_stream(symbol); /* return get_line_position(stream); */ # entrekursiviert: goto start; } case strmtype_broad: # Broadcast-Stream: # Maximum der Line-Positions der einzelnen Streams { var reg2 object streamlist = TheStream(stream)->strm_broad_list; var reg3 uintL maximum = 0; # bisheriges Maximum := 0 while (consp(streamlist)) { var reg4 uintL next = # Line-Position des nΣchsten Teilstreams posfixnum_to_L(get_line_position(Car(streamlist))); if (next > maximum) { maximum = next; } # Maximum nehmen streamlist = Cdr(streamlist); } return fixnum(maximum); # Maximum als Ergebnis } case strmtype_twoway: case strmtype_echo: { # Two-Way-Stream oder Echo-Stream: Output-Stream anschauen stream = TheStream(stream)->strm_twoway_output; /* return get_line_position(stream); */ # entrekursiviert: goto start; } default: # normaler Stream return TheStream(stream)->strm_wr_ch_lpos; } } # UP: Liest mehrere Bytes von einem Stream. # read_byte_array(stream,byteptr,len) # > stream: Stream # > uintB* byteptr: Adresse der zu fⁿllenden Bytefolge # > uintL len: LΣnge der zu fⁿllenden Bytefolge # < uintB* ergebnis: Pointer ans Ende des gefⁿllten Bereiches oder NULL global uintB* read_byte_array (object stream, uintB* byteptr, uintL len); global uintB* read_byte_array(stream,byteptr,len) var reg1 object stream; var reg3 uintB* byteptr; var reg2 uintL len; { if (len==0) { return byteptr; } start: if (eq(TheStream(stream)->strm_rd_by,P(rd_by_synonym))) # synonym { stream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol); goto start; } elif (eq(TheStream(stream)->strm_rd_by,P(rd_by_twoway))) # twoway { stream = TheStream(stream)->strm_twoway_input; goto start; } #if defined(HANDLES) || defined(SOCKETS) elif (eq(TheStream(stream)->strm_rd_by,P(rd_by_handle))) # handle, socket { var reg5 Handle handle = TheHandle(TheStream(stream)->strm_ihandle); begin_system_call(); loop { #if !defined(AMIGAOS) var reg4 int ergebnis = read(handle,byteptr,len); if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { end_system_call(); pushSTACK(S(read_byte_sequence)); fehler(serious_condition, DEUTSCH ? "~: Ctrl-C: Tastatur-Interrupt" : ENGLISH ? "~: Ctrl-C: User break" : FRANCAIS ? "~ : Ctrl-C : Interruption clavier" : "" ); } OS_error(); # Error melden } #else # defined(AMIGAOS) var reg4 long ergebnis = Read(handle,byteptr,len); if (ergebnis<0) { OS_error(); } # Error melden #endif if (ergebnis==0) break; # EOF -> fertig byteptr += ergebnis; len -= ergebnis; if (len==0) break; # fertig? } end_system_call(); return byteptr; } #endif elif (eq(TheStream(stream)->strm_rd_by,P(rd_by_iau_file)) # file && eq(TheStream(stream)->strm_file_bitsize,fixnum(8)) # eltype = (UNSIGNED-BYTE 8) ) { dotimespL(len,len, { var reg4 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) break; *byteptr++ = *ptr; # index und position incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); }); return byteptr; } else # keine Optimierung m÷glich { return NULL; } } # UP: Schreibt mehrere Bytes auf einen Stream. # write_byte_array(stream,byteptr,len) # > stream: Stream # > uintB* byteptr: Adresse der zu schreibenden Bytefolge # > uintL len: LΣnge der zu schreibenden Bytefolge # < uintB* ergebnis: Pointer ans Ende des geschriebenen Bereiches oder NULL global uintB* write_byte_array (object stream, uintB* byteptr, uintL len); global uintB* write_byte_array(stream,byteptr,len) var reg1 object stream; var reg3 uintB* byteptr; var reg2 uintL len; { if (len==0) { return byteptr; } start: if (eq(TheStream(stream)->strm_wr_by,P(wr_by_synonym))) # synonym { stream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol); goto start; } elif (eq(TheStream(stream)->strm_wr_by,P(wr_by_twoway))) # twoway, echo { stream = TheStream(stream)->strm_twoway_output; goto start; } #if defined(HANDLES) || defined(SOCKETS) elif (eq(TheStream(stream)->strm_wr_by,P(wr_by_handle))) # handle, socket { var reg5 Handle handle = TheHandle(TheStream(stream)->strm_ohandle); begin_system_call(); loop { #if !defined(AMIGAOS) var reg4 int ergebnis = write(handle,byteptr,len); if (ergebnis<0) { if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { end_system_call(); pushSTACK(S(write_byte_sequence)); fehler(serious_condition, DEUTSCH ? "~: Ctrl-C: Tastatur-Interrupt" : ENGLISH ? "~: Ctrl-C: User break" : FRANCAIS ? "~ : Ctrl-C : Interruption clavier" : "" ); } OS_error(); # Error melden } #else # defined(AMIGAOS) var reg4 long ergebnis = Write(handle,byteptr,len); if (ergebnis<0) { OS_error(); } # Error melden #endif if (ergebnis==0) # nicht erfolgreich? { fehler_unwritable(S(write_byte_sequence),stream); } byteptr += ergebnis; len -= ergebnis; if (len==0) break; # fertig? } end_system_call(); return byteptr; } #endif elif (eq(TheStream(stream)->strm_wr_by,P(wr_by_iau_file)) # file && eq(TheStream(stream)->strm_file_bitsize,fixnum(8)) # eltype = (UNSIGNED-BYTE 8) ) { return write_byte_array_iau8_file(stream,byteptr,len); } else # keine Optimierung m÷glich { return NULL; } } # UP: Liest mehrere String-Characters von einem Stream. # read_schar_array(stream,charptr,len) # > stream: Stream # > uintB* charptr: Adresse der zu fⁿllenden Zeichenfolge # > uintL len: LΣnge der zu fⁿllenden Zeichenfolge # < uintB* ergebnis: Pointer ans Ende des gefⁿllten Bereiches oder NULL global uintB* read_schar_array (object stream, uintB* charptr, uintL len); global uintB* read_schar_array(stream,charptr,len) var reg4 object stream; var reg2 uintB* charptr; var reg3 uintL len; { if (len==0) { return charptr; } {var reg5 object lastchar = TheStream(stream)->strm_rd_ch_last; if (eq(lastchar,eof_value)) # EOF ? { return charptr; } if (posfixnump(lastchar) # Char nach UNREAD ? && !string_char_p(fixnum_to_char(lastchar)) # aber kein String-Char? ) { return NULL; } if (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_synonym))) # synonym { var reg6 object substream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol); check_SP(); {var reg1 uintB* endptr = (posfixnump(lastchar) ? read_schar_array(substream,charptr+1,len-1) : read_schar_array(substream,charptr,len) ); if (endptr==NULL) { return NULL; } if (posfixnump(lastchar)) { charptr[0] = char_code(fixnum_to_char(lastchar)); } TheStream(stream)->strm_rd_ch_last = (endptr == charptr+len ? code_char(endptr[-1]) : eof_value); return endptr; }} elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_twoway))) # twoway { var reg6 object substream = TheStream(stream)->strm_twoway_input; check_SP(); {var reg1 uintB* endptr = (posfixnump(lastchar) ? read_schar_array(substream,charptr+1,len-1) : read_schar_array(substream,charptr,len) ); if (endptr==NULL) { return NULL; } if (posfixnump(lastchar)) { charptr[0] = char_code(fixnum_to_char(lastchar)); } TheStream(stream)->strm_rd_ch_last = (endptr == charptr+len ? code_char(endptr[-1]) : eof_value); return endptr; }} #ifdef XHANDLES elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_handle))) # handle, pipe_in, socket { if (posfixnump(lastchar)) { *charptr++ = char_code(fixnum_to_char(lastchar)); len--; } if (len>0) { var reg6 Handle handle = TheHandle(TheStream(stream)->strm_ihandle); run_time_stop(); # Run-Time-Stoppuhr anhalten #ifdef GRAPHICS_SWITCH if (handle == stdin_handle) switch_text_mode(); #endif begin_system_call(); loop { #if !defined(AMIGAOS) var reg1 int ergebnis = read(handle,charptr,len); #else var reg1 long ergebnis = Read(handle,charptr,len); #endif if (ergebnis<0) { #if !defined(AMIGAOS) if (errno==EINTR) # Unterbrechung (evtl. durch Ctrl-C) ? { end_system_call(); run_time_restart(); pushSTACK(S(read_char_sequence)); fehler(serious_condition, DEUTSCH ? "~: Ctrl-C: Tastatur-Interrupt" : ENGLISH ? "~: Ctrl-C: User break" : FRANCAIS ? "~ : Ctrl-C : Interruption clavier" : "" ); } #endif OS_error(); # Error melden } if (ergebnis==0) break; # EOF -> fertig charptr += ergebnis; len -= ergebnis; if (len==0) break; # fertig? } end_system_call(); run_time_restart(); } TheStream(stream)->strm_rd_ch_last = (len==0 ? code_char(charptr[-1]) : eof_value); return charptr; } #endif elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_sch_file))) # file { if (posfixnump(lastchar)) { *charptr++ = char_code(fixnum_to_char(lastchar)); len--; } while (len>0) { var reg1 uintB* ptr = b_file_nextbyte(stream); if (ptr == (uintB*)NULL) break; # EOF -> fertig {var reg6 uintB ch = *ptr; # index und position incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); # CR/LF -> NL umwandeln: if (ch==CR) { # nΣchstes Zeichen auf LF untersuchen ptr = b_file_nextbyte(stream); if (!(ptr == (uintB*)NULL) && (*ptr == LF)) { # index und position incrementieren: TheStream(stream)->strm_file_index = fixnum_inc(TheStream(stream)->strm_file_index,1); TheStream(stream)->strm_file_position = fixnum_inc(TheStream(stream)->strm_file_position,1); ch = NL; } } if (ch==NL) # lineno incrementieren: { TheStream(stream)->strm_sch_file_lineno = fixnum_inc(TheStream(stream)->strm_sch_file_lineno,1); } *charptr++ = ch; len--; }} TheStream(stream)->strm_rd_ch_last = (len==0 ? code_char(charptr[-1]) : eof_value); return charptr; } elif (eq(TheStream(stream)->strm_rd_ch,P(rd_ch_str_in))) # str_in { if (posfixnump(lastchar)) { *charptr++ = char_code(fixnum_to_char(lastchar)); len--; } if (len>0) { var reg7 uintL index = posfixnum_to_L(TheStream(stream)->strm_str_in_index); # Index var reg8 uintL endindex = posfixnum_to_L(TheStream(stream)->strm_str_in_endindex); if (index < endindex) { var uintL srclen; var reg1 uintB* srcptr = unpack_string(TheStream(stream)->strm_str_in_string,&srclen); # Ab srcptr kommen srclen Zeichen. if (srclen < endindex) { fehler_str_in_adjusted(stream); } srcptr += index; {var reg6 uintL count = endindex - index; if (count > len) { count = len; } # count = min(len,endindex-index) > 0. len -= count; dotimespL(count,count, { *charptr++ = *srcptr++; } ); } }} TheStream(stream)->strm_rd_ch_last = (len==0 ? code_char(charptr[-1]) : eof_value); return charptr; } else # keine Optimierung m÷glich { return NULL; } }} # UP: Schreibt mehrere String-Characters auf einen Stream. # write_schar_array(stream,charptr,len) # > stream: Stream # > uintB* charptr: Adresse der zu schreibenden Zeichenfolge # > uintL len: LΣnge der zu schreibenden Zeichenfolge # < uintB* ergebnis: Pointer ans Ende des geschriebenen Bereiches oder NULL global uintB* write_schar_array (object stream, uintB* charptr, uintL len); global uintB* write_schar_array(stream,charptr,len) var reg4 object stream; var reg2 uintB* charptr; var reg3 uintL len; { if (len==0) { return charptr; } start: if (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_synonym))) # synonym { stream = get_synonym_stream(TheStream(stream)->strm_synonym_symbol); goto start; # Line-Position aktualisieren kann hier entfallen. } elif (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_twoway))) # twoway, echo { stream = TheStream(stream)->strm_twoway_output; goto start; # Line-Position aktualisieren kann hier entfallen. } #ifdef XHANDLES elif (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_handle)) # handle, pipe_out, socket && !(TheStream(stream)->strmtype == strmtype_terminal) # aber nicht terminal1, terminal2 (wg. wr_ss_lpos) ) { return write_schar_array_handle(stream,charptr,len); } #endif elif (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_sch_file))) # file { return write_schar_array_sch_file(stream,charptr,len); } else # keine Optimierung m÷glich { return NULL; } } LISPFUN(read_byte,1,2,norest,nokey,0,NIL) # (READ-BYTE stream [eof-error-p [eof-value]]), CLTL S. 382 { # Stream ⁿberprⁿfen: var reg1 object stream = STACK_2; if (!streamp(stream)) { fehler_stream(stream); } # Integer lesen: {var reg2 object obj = read_byte(stream); if (eq(obj,eof_value)) # EOF-Behandlung { if (!nullp(STACK_1)) # eof-error-p /= NIL (z.B. = #<UNBOUND>) ? # Error melden: { pushSTACK(STACK_2); # Wert fⁿr Slot STREAM von STREAM-ERROR pushSTACK(STACK_(2+1)); # Stream pushSTACK(S(read_byte)); fehler(end_of_file, DEUTSCH ? "~: Eingabestream ~ ist zu Ende." : ENGLISH ? "~: input stream ~ has reached its end" : FRANCAIS ? "~ : ArrivΘe en fin du ½stream╗ d'entrΘe ~." : "" ); } else # EOF verarzten: { var reg2 object eofval = STACK_0; if (eq(eofval,unbound)) { eofval = eof_value; } # Default ist #<EOF> value1 = eofval; mv_count=1; skipSTACK(3); # eofval als Wert } } else { value1 = obj; mv_count=1; skipSTACK(3); } # obj als Wert }} LISPFUNN(write_byte,2) # (WRITE-BYTE integer stream), CLTL S. 385 { # Stream ⁿberprⁿfen: var reg1 object stream = STACK_0; if (!streamp(stream)) { fehler_stream(stream); } {# Integer ⁿberprⁿfen: var reg2 object obj = STACK_1; if (!integerp(obj)) { fehler_wr_integer(stream,obj); } # Integer schreiben: write_byte(stream,obj); value1 = STACK_1; mv_count=1; skipSTACK(2); # obj als Wert }} # UP: ▄berprⁿft, ob ein Argument ein offener File-Stream ist. # check_open_file_stream(obj); # > obj: Argument # > subr_self: Aufrufer (ein SUBR) local void check_open_file_stream (object obj); local void check_open_file_stream(obj) var reg1 object obj; { if (!streamp(obj)) goto fehler_bad_obj; # Stream ? if_strm_bfile_p(obj, ; , goto fehler_bad_obj; ); # Streamtyp File-Stream ? if ((TheStream(obj)->strmflags & strmflags_open_B) == 0) goto fehler_bad_obj; # Stream offen ? if (nullp(TheStream(obj)->strm_file_handle)) goto fehler_bad_obj; # und Handle /= NIL ? return; # ja -> OK fehler_bad_obj: pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name); fehler(error, DEUTSCH ? "~: Argument mu▀ ein offener File-Stream sein, nicht ~" : ENGLISH ? "~: argument ~ is not an open file stream" : FRANCAIS ? "~ : L'argument ~ doit Ωtre un ½stream╗ ouvert de fichier et non ~." : "" ); } LISPFUN(file_position,1,1,norest,nokey,0,NIL) # (FILE-POSITION file-stream [position]), CLTL S. 425 { var reg1 object position = popSTACK(); var reg2 object stream = popSTACK(); check_open_file_stream(stream); # stream ⁿberprⁿfen if (eq(position,unbound)) # position nicht angegeben -> Position als Wert: { value1 = TheStream(stream)->strm_file_position; mv_count=1; } else { if (eq(position,S(Kstart))) # :START -> an den Anfang positionieren: { position_file_start(stream); } elif (eq(position,S(Kend))) # :END -> ans Ende positionieren: { position_file_end(stream); } elif (posfixnump(position)) # an die angegebene Position positionieren: { position_file(stream,posfixnum_to_L(position)); } else # UnzulΣssiges Position-Argument { pushSTACK(position); # Wert fⁿr Slot DATUM von TYPE-ERROR pushSTACK(O(type_position)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR pushSTACK(position); pushSTACK(S(Kend)); pushSTACK(S(Kstart)); pushSTACK(TheSubr(subr_self)->name); fehler(type_error, DEUTSCH ? "~: Position-Argument mu▀ ~ oder ~ oder ein Fixnum >=0 sein, nicht ~" : ENGLISH ? "~: position argument should be ~ or ~ or a nonnegative fixnum, not ~" : FRANCAIS ? "~ : L'argument position doit Ωtre ~, ~ ou de type FIXNUM positif ou zΘro, mais non ~." : "" ); } value1 = T; mv_count=1; # Wert T } } LISPFUNN(file_length,1) # (FILE-LENGTH file-stream), CLTL S. 425 { var reg1 object stream = popSTACK(); check_open_file_stream(stream); # stream ⁿberprⁿfen # Position merken: {var reg2 object position = TheStream(stream)->strm_file_position; # ans Ende positionieren: position_file_end(stream); # Ende-Position merken: {var reg3 object endposition = TheStream(stream)->strm_file_position; # an die alte Position zurⁿckpositionieren: position_file(stream,posfixnum_to_L(position)); value1 = endposition; mv_count=1; # Ende-Position als Wert }}} LISPFUNN(line_number,1) # (SYS::LINE-NUMBER stream) liefert die aktuelle Zeilennummer (falls stream # ein String-Char-File-Input-Stream ist, von dem nur gelesen wurde). { var reg1 object stream = popSTACK(); if (!streamp(stream)) { fehler_stream(stream); } # stream ⁿberprⁿfen value1 = (TheStream(stream)->strmtype == strmtype_sch_file ? TheStream(stream)->strm_sch_file_lineno # aktuelle Zeilennummer : NIL # NIL falls unbekannt ); mv_count=1; } # Tabelle aller Pseudofunktionen global struct pseudofun_tab_ pseudofun_tab = { #define PSEUDOFUN PSEUDOFUN_B #include "pseudofun.c" #undef PSEUDOFUN }; # ============================================================================== #ifdef EMUNIX_PORTABEL # Eine Hilfsfunktion fⁿr bidirektionale Pipes: popenrw() #undef stdin_handle #undef stdout_handle #include "../os2/popenrw.c" #endif # ============================================================================== # filestatus/if_file_exists, file_datetime durch break_sem_4 schⁿtzen?? # Signalbehandlung bei EXECUTE, SHELL, MAKE-PIPE-INPUT-STREAM, MAKE-PIPE-OUTPUT-STREAM, MAKE-PIPE-IO-STREAM ??