adding (chibi pty)

Makefile

@@ -41,7 +41,8 @@ CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/weak$(SO) \
 	lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) lib/chibi/ast$(SO) \
 	lib/chibi/emscripten$(SO)
 CHIBI_POSIX_COMPILED_LIBS = lib/chibi/process$(SO) lib/chibi/time$(SO) \
-	lib/chibi/system$(SO) lib/chibi/stty$(SO) lib/chibi/net$(SO) 
+	lib/chibi/system$(SO) lib/chibi/stty$(SO) lib/chibi/pty$(SO) \
+	lib/chibi/net$(SO)
 CHIBI_WIN32_COMPILED_LIBS = lib/chibi/win32/process-win32$(SO)
 CHIBI_CRYPTO_COMPILED_LIBS = lib/chibi/crypto/crypto$(SO)
 CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)

Makefile.libs

@@ -52,6 +52,9 @@ all-libs: $(COMPILED_LIBS)
 lib/%.c: lib/%.stub $(CHIBI_FFI_DEPENDENCIES)
 	$(CHIBI_FFI) $<
 
+lib/chibi/pty$(SO): lib/chibi/pty.c $(INCLUDES) libchibi-scheme$(SO)
+	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) $(XLIBS) -lchibi-scheme -lutil
+
 lib/%$(SO): lib/%.c $(INCLUDES) libchibi-scheme$(SO)
 	$(CC) $(CLIBFLAGS) $(CLINKFLAGS) $(XCPPFLAGS) $(XCFLAGS) $(LDFLAGS) -o $@ $< -L. $(RLDFLAGS) $(XLIBS) -lchibi-scheme
 

lib/chibi/pty-test.sld

@@ -0,0 +1,26 @@
+
+(define-library (chibi pty-test)
+  (import (scheme base) (scheme file) (scheme write)
+          (chibi io) (chibi pty) (chibi stty) (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests . o)
+      (when (file-exists? "/usr/bin/units")
+        (test-begin "pty")
+        (test '("\t* 3.2808399" "\t/ 0.3048")
+            (call-with-pty-process-io
+             '("/usr/bin/units" "-q")
+             (lambda (pid in out name)
+               (with-raw-io
+                out
+                (lambda ()
+                  ;; input with tab completion
+                  (display "mete\t" out) (newline out)
+                  (display "fee\t" out) (newline out)
+                  (display (integer->char 4) out)
+                  (flush-output-port out)
+                  ;; result
+                  (let* ((l1 (read-line in))
+                         (l2 (read-line in)))
+                    (list l1 l2)))))))
+        (test-end)))))

lib/chibi/pty.sld

@@ -0,0 +1,62 @@
+
+(define-library (chibi pty)
+  (import (scheme base)
+          (chibi filesystem)
+          (chibi process)
+          (chibi string)
+          (chibi stty)
+          (only (chibi) fileno?))
+  (export open-pty fork-pty login-tty
+          open-pty-process call-with-pty-process-io)
+  (include-shared "pty")
+  (begin
+    (define (winsize-arg o)
+      (cond
+       ((and (pair? o) (integer? (car o)))
+        (unless (and (pair? (cdr o)) (integer? (cadr o)))
+          (error "open-pty expects integer width and height" o))
+        (make-winsize (car o) (cadr o)))
+       ((and (pair? o) (pair? (cdr o)))  (cadr o))
+       (else #f)))
+    (define (open-pty . o)
+      (let ((termios (and (pair? o) (car o)))
+            (winsize (winsize-arg (if (pair? o) (cdr o) '()))))
+        (openpty termios winsize)))
+    (define (fork-pty . o)
+      (let ((termios (and (pair? o) (car o)))
+            (winsize (winsize-arg (if (pair? o) (cdr o) '()))))
+        (forkpty termios winsize)))
+    (define (open-pty-process command . o)
+      (let* ((command (if (and (string? command)
+                               (string-find? command #\space))
+                          (string-split command)
+                          command))
+             (pty (apply fork-pty o)))
+        (cond
+         ((not (and (pair? pty) (integer? (car pty))
+                    (not (negative? (car pty)))
+                    (pair? (cdr pty)) (fileno? (cadr pty))))
+          (error "failed to fork-pty" pty))
+         ((zero? (car pty))  ; child
+          (execute (car command) command))
+         (else               ; parent
+          pty))))
+    (define (call-with-pty-process-io command proc . o)
+      (unless (procedure? proc)
+        (error "call-with-pty-process-io expected procedure" proc))
+      (let ((pty (apply open-pty-process command o)))
+        (if (and (pair? pty)
+                 (integer? (car pty))
+                 (not (negative? (car pty)))
+                 (fileno? (cadr pty)))
+            (let* ((pid (car pty))
+                   (fd (cadr pty))
+                   (name (and (pair? (cddr pty)) (car (cddr pty))))
+                   (in (open-input-file-descriptor fd))
+                   (out (open-output-file-descriptor fd))
+                   (res (proc pid in out name)))
+              (close-input-port in)
+              (close-output-port out)
+              (close-file-descriptor fd)
+              res)
+            (error "couldn't open-pty-process" command o pty))))))

lib/chibi/pty.stub

@@ -0,0 +1,14 @@
+
+(c-system-include "pty.h")
+(c-system-include "utmp.h")
+
+(c-link "util")
+
+(declare-c-struct termios)
+(declare-c-struct winsize)
+
+(define-c errno openpty
+  ((result fileno) (result fileno) (result (array char 256)) (maybe-null default NULL termios) (maybe-null default NULL winsize)))
+(define-c pid_t forkpty
+  ((result fileno)  (result (array char 256)) (maybe-null default NULL termios) (maybe-null default NULL winsize)))
+(define-c int (login-tty "login_tty") (fileno))

lib/chibi/stty.sld

@@ -2,7 +2,14 @@
 (define-library (chibi stty)
   (export stty with-stty with-raw-io
           get-terminal-width get-terminal-dimensions
-          TCSANOW TCSADRAIN TCSAFLUSH)
+          TCSANOW TCSADRAIN TCSAFLUSH
+          winsize winsize? make-winsize winsize-row winsize-col
+          termios term-attrs? make-term-attrs
+          ;;term-attrs-iflag term-attrs-iflag-set!
+          ;;term-attrs-oflag term-attrs-oflag-set!
+          ;;term-attrs-cflag term-attrs-cflag-set!
+          ;;term-attrs-lflag term-attrs-lflag-set!
+          )
   (import (chibi) (srfi 69) (srfi 151))
   (include-shared "stty")
   (include "stty.scm"))

lib/chibi/stty.stub

@@ -24,6 +24,7 @@
 
 (define-c-struct winsize
   predicate: winsize?
+  constructor: (make-winsize ws_row ws_col)
   (unsigned-short ws_row winsize-row)
   (unsigned-short ws_col winsize-col))
 

tools/chibi-ffi

@@ -1791,7 +1791,7 @@
     (cond
      (imported?
       (cat "  name = sexp_intern(ctx, \"" scheme-name "\", -1);\n"
-           "  " (type-id-name name) " = sexp_env_ref(env, name, SEXP_FALSE);\n"
+           "  " (type-id-name name) " = sexp_env_ref(ctx, env, name, SEXP_FALSE);\n"
            "  if (sexp_not(" (type-id-name name) ")) {\n"
            "    sexp_warn(ctx, \"couldn't import declared type: \", name);\n"
            "  }\n"))