Skip to content

Instantly share code, notes, and snippets.

@shkmr shkmr/gpsh Secret
Last active Jan 5, 2016

Embed
What would you like to do?
#!/usr/bin/env gosh
;; -*-Scheme-*-
;;;
;;; gpsh or gosh-pseudo-session
;;;
;;; Usage: gpsh file.scm
;;;
;;; written by skimu@mac.com
;;;
(use gauche.vport)
(define (open-mirroring-input port dest-port)
(let ((mirror-port (make <virtual-input-port>)))
(define (getb)
(let ((c (read-byte port)))
(if (eof-object? c)
c
(begin
(write-byte c dest-port)
c))))
(define (getc)
(let ((c (read-char port)))
(if (eof-object? c)
c
(begin
(display c dest-port)
c))))
(define (gets n)
(let ((str (read-block n port)))
(if (eof-object? str)
str
(begin
(display str dest-port)
str))))
(define (ready char?)
(if char?
(char-ready? port)
(byte-ready? port)))
(define (seek offset whence)
(port-seek port offset whence))
(slot-set! mirror-port 'getb getb)
(slot-set! mirror-port 'getc getc)
(slot-set! mirror-port 'gets gets)
(slot-set! mirror-port 'ready ready)
(slot-set! mirror-port 'seek seek)
mirror-port))
(define (open-output-with-prefix dest)
(let ((port (make <virtual-output-port>)))
(define need-prefix? #t)
(define (putb b)
(if need-prefix?
(display ";|" dest))
(set! need-prefix? #f)
(write-byte b dest)
(if (= b (char->integer #\newline))
(set! need-prefix? #t)))
(define (putc ch)
(if need-prefix?
(display ";|" dest))
(set! need-prefix? #f)
(write-char ch dest)
(if (char=? ch #\newline)
(set! need-prefix? #t)))
(define (flushf)
(flush dest))
(slot-set! port 'putb putb)
(slot-set! port 'putc putc)
(slot-set! port 'flush flushf)
port))
(define (pseudo-session src)
(let* ((real-out (current-output-port))
(in (open-mirroring-input src real-out))
(out (open-output-with-prefix real-out)))
(define (print-with-prefix . vals)
(display ";=> " real-out)
(for-each (lambda (x)
(write x real-out)
(display " " real-out))
vals)
(flush out))
(define (reader-with-trick)
(begin0 (read in)
(newline real-out)))
(define (prompter) #t)
(unwind-protect
(with-output-to-port out
(lambda ()
(read-eval-print-loop
reader-with-trick
#f
print-with-prefix
prompter)))
(unless (port-closed? in) (close-input-port in))
(unless (port-closed? out) (close-output-port out))
)))
(define (pseudo-session-with-file scmfile)
(call-with-input-file scmfile pseudo-session))
(define (main args)
(if (= (length args) 2)
(pseudo-session-with-file (cadr args))
(errorf "Usage: ~a file.scm" (car args)))
0)
;;; EOF
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.