Disgusting hackitude to work around mysterious S48 bug in C-calling system.

scsh/tty.c

@@ -49,6 +49,18 @@ scheme_value df_scheme_tcgetattr(long nargs, scheme_value *args)
     return ret1;
     }
 
+scheme_value df_scheme_tcgetattrB(long nargs, scheme_value *args)
+{
+    extern int scheme_tcgetattrB(int , char *, scheme_value );
+    scheme_value ret1;
+    int r1;
+
+    cig_check_nargs(3, nargs, "scheme_tcgetattrB");
+    r1 = scheme_tcgetattrB(EXTRACT_FIXNUM(args[2]), cig_string_body(args[1]), args[0]);
+    ret1 = errno_or_false(r1);
+    return ret1;
+    }
+
 scheme_value df_scheme_tcsetattr(long nargs, scheme_value *args)
 {
     extern int scheme_tcsetattr(int , int , const char *, int , int , int , int , int , int , int , int , int , int , int , int );

scsh/tty.scm

@@ -122,8 +122,21 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Retrieve tty-info bits from a tty. Arg defaults to current input port.
 
+;;; I don't understand why, but somehow returning 10 values from a 
+;;; define-foreign function seems to corrupt the stack. ??? See tty-bug
+;;; for more details. As a workaround, we don't use %tty-info/errno.
+;;; Instead, we have an alternate entry point, %bogus-tty-info/errno,
+;;; which passes in a 10-elt vector into which the results are stored.
+;;; Yech. I have no idea what has tickled this bug in S48 0.36. I hope
+;;; if we port up to a modern S48, it'll go away. -Olin
+
+;;; Actually, I subsequently discovered that adding an extra, unused binding
+;;; to the LET, cures the problem. So I backed out the really horrible code
+;;; and did that. -Olin
+
 (define (tty-info . maybe-tty)
-  (let ((control-chars (make-string num-ttychars)))
+  (let ((control-chars (make-string num-ttychars))
+	(bogus #f))
     (receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
 	      cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
 	      ispeed-code ospeed-code)
@@ -140,6 +153,27 @@
 		      (char->ascii (string-ref control-chars ttychar/min))
 		      (char->ascii (string-ref control-chars ttychar/time))))))
 
+;(define (tty-info . maybe-tty)
+;  (receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
+;		      cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
+;		      ispeed-code ospeed-code control-chars)
+;      (sleazy-call/file (:optional maybe-tty (current-input-port))
+;			call-with-input-file
+;			(lambda (fd) (%tty-info fd (make-string num-ttychars))))
+;    (make-%tty-info control-chars
+;		    (bitwise-ior (arithmetic-shift iflag-hi8 24) iflag-lo24)
+;		    (bitwise-ior (arithmetic-shift oflag-hi8 24) oflag-lo24)
+;		    (bitwise-ior (arithmetic-shift cflag-hi8 24) cflag-lo24)
+;		    (bitwise-ior (arithmetic-shift lflag-hi8 24) lflag-lo24)
+;		    (decode-baud-rate ispeed-code) ispeed-code
+;		    (decode-baud-rate ospeed-code) ospeed-code
+;		    (char->ascii (string-ref control-chars ttychar/min))
+;		    (char->ascii (string-ref control-chars ttychar/time)))))
+
+;(define (%tty-info fdes cc)
+;  (receive (v1 v2 v3 v4 v5 v6 v7 v8 v9 v10) (%real-tty-info fdes cc)
+;    (values v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 cc)))
+
 (define-errno-syscall (%tty-info fdes control-chars) %tty-info/errno
   iflag-hi8 iflag-lo24
   oflag-hi8 oflag-lo24
@@ -157,6 +191,28 @@
   integer integer
   integer integer)
 
+(define-foreign %bogus-tty-info/errno
+  ("scheme_tcgetattrB" (integer fdes)
+                       (var-string control-chars)
+		       (vector-desc ivec))
+  (to-scheme integer errno_or_false))
+
+(define-errno-syscall (%bogus-tty-info fdes control-chars ivec)
+  %bogus-tty-info/errno)
+  
+(define (%%bogus-tty-info fd control-chars)
+  (let ((ivec (make-vector 10)))
+    (%bogus-tty-info fd control-chars ivec)
+    ivec))
+
+;(define (%tty-info fdes cc)
+;  (let ((ivec (%%bogus-tty-info fdes cc)))
+;    (values (vector-ref ivec 0) (vector-ref ivec 1)
+;	    (vector-ref ivec 2) (vector-ref ivec 3)
+;	    (vector-ref ivec 4) (vector-ref ivec 5)
+;	    (vector-ref ivec 6) (vector-ref ivec 7)
+;	    (vector-ref ivec 8) (vector-ref ivec 9)
+;	    cc)))
 
 ;;; (set-tty-info       tty option info)	[Not exported]
 ;;; (set-tty-info/now   tty option info)

scsh/tty1.c

@@ -17,6 +17,7 @@
 #include <termios.h>
 #include <string.h>
 #include <sys/types.h>
+#include "../scheme48.h"
 
 /* This #include is for the #ifdef'd code in open_ctty() below, and
 ** is therefor ifdef'd identically.
@@ -52,6 +53,29 @@ int scheme_tcgetattr(int fd,	     char *control_chars,
   return result;
   }
 
+int scheme_tcgetattrB(int fd, char *control_chars, scheme_value scmvec)
+{
+  struct termios t;
+  int result = tcgetattr(fd, &t);
+  int *ivec = ADDRESS_AFTER_HEADER(scmvec, int);
+
+  if (result != -1) {
+      memcpy(control_chars, t.c_cc, NCCS);
+      ivec[0] = ENTER_FIXNUM(t.c_iflag >> 24);
+      ivec[1] = ENTER_FIXNUM(t.c_iflag & 0xffffff);
+      ivec[2] = ENTER_FIXNUM(t.c_oflag >> 24);
+      ivec[3] = ENTER_FIXNUM(t.c_oflag & 0xffffff);
+      ivec[4] = ENTER_FIXNUM(t.c_cflag >> 24);
+      ivec[5] = ENTER_FIXNUM(t.c_cflag & 0xffffff);
+      ivec[6] = ENTER_FIXNUM(t.c_lflag >> 24);
+      ivec[7] = ENTER_FIXNUM(t.c_lflag & 0xffffff);
+      ivec[8] = ENTER_FIXNUM(cfgetispeed(&t));
+      ivec[9] = ENTER_FIXNUM(cfgetospeed(&t));
+      }
+
+  return result;
+  }
+
 
 /*****************************************************************************/
 

scsh/tty1.h

@@ -7,6 +7,8 @@ int scheme_tcgetattr(int fd,	     char *control_chars,
 		     int *lflag_hi8, int *lflag_lo24,
 		     int *ispeed,    int *ospeed);
 
+int scheme_tcgetattrB(int fd, char *control_chars, scheme_value ivec);
+
 int scheme_tcsetattr(int fd,	    int option,
 		     const char *control_chars,
 		     int iflag_hi8, int iflag_lo24,