#!/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