diff --git a/module/mes/guile.mes b/module/mes/guile.mes index ffec0b54..4122c6d8 100644 --- a/module/mes/guile.mes +++ b/module/mes/guile.mes @@ -113,6 +113,16 @@ (set-current-output-port save) r)) +(define core:open-input-file open-input-file) +(define (open-input-file file) + (let ((port (core:open-input-file file))) + (when (getenv "MES_DEBUG") + (core:display-error (string-append "open-input-file: `" file "'\n")) + (core:display-error "port=") + (core:display-error port) + (core:display-error "\n")) + port)) + (define open-input-string (let ((save-set-current-input-port #f) (string-port #f)) @@ -128,8 +138,13 @@ (tell 0) (end (string-length string))) (lambda (port) + (when (getenv "MES_DEBUG") + (core:display-error (string-append "open-input-string: `" string "' save-set-current-input-port port=")) + (core:display-error port) + (core:display-error "\n")) (if (not (equal? port string-port)) (save-set-current-input-port port) (begin + (set! tell 0) (set! peek-char (lambda () (if (= tell end) (integer->char -1) (string-ref string (- tell 1))))) @@ -142,6 +157,10 @@ (lambda (c) (set! tell (1- tell)) c)) (set! set-current-input-port (lambda (port) + (when (getenv "MES_DEBUG") + (core:display-error (string-append "open-input-string: `" string "' set-current-input-port port=")) + (core:display-error port) + (core:display-error "\n")) (save-set-current-input-port port) (set! peek-char save-peek-char) (set! read-char save-read-char) diff --git a/module/mes/guile.scm b/module/mes/guile.scm index efb9f78f..ab9f0fb6 100644 --- a/module/mes/guile.scm +++ b/module/mes/guile.scm @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2017 Jan Nieuwenhuizen +;;; Copyright © 2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -23,12 +23,39 @@ ;;; Code: (define-module (mes guile) - #:export (core:display core:display-error)) + #:export (core:display core:display-error) + ;;#:re-export (open-input-file open-input-string with-input-from-string) + ) (cond-expand (guile (define core:display display) - (define (core:display-error o) (display o (current-error-port)))) + (define (core:display-error o) (display o (current-error-port))) + +;; (define core:open-input-file open-input-file) +;; (define (open-input-file file) +;; (let ((port (core:open-input-file file))) +;; (when (getenv "MES_DEBUG") +;; (core:display-error (string-append "open-input-file: `" file " port=")) +;; (core:display-error port) +;; (core:display-error "\n")) +;; port)) + +;; (define core:open-input-string open-input-string) +;; (define (open-input-string string) +;; (let ((port (core:open-input-string string))) +;; (when (getenv "MES_DEBUG") +;; (core:display-error (string-append "open-input-string: `" string " port=")) +;; (core:display-error port) +;; (core:display-error "\n")) +;; port)) + +;; (define core:with-input-from-string with-input-from-string) +;; (define (with-input-from-string string thunk) +;; (if (getenv "MES_DEBUG") +;; (core:display-error (string-append "with-input-from-string: `" string "'\n"))) +;; (core:with-input-from-string string thunk)) + ) (mes)) (cond-expand diff --git a/tests/guile.test b/tests/guile.test index d53d77d4..4a3366be 100755 --- a/tests/guile.test +++ b/tests/guile.test @@ -9,7 +9,7 @@ exit $? ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2017 Jan Nieuwenhuizen +;;; Copyright © 2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -73,14 +73,43 @@ exit $? (set-current-input-port (car ipstk)) (fluid-set! *input-stack* (cdr ipstk)))))) +;; Return #f if empty +(define (pop-input) + (let ((ipstk (fluid-ref *input-stack*))) + (if (null? ipstk) #f + (begin + (set-current-input-port (car ipstk)) + (fluid-set! *input-stack* (cdr ipstk)))))) + (pass-if-equal "push-input" - "bla" - (let () - (push-input (open-input-string "bla")) - (let ((ch (read-char))) - (unread-char ch)) - (let ((x (read-string))) - (let ((pop (pop-input))) - x)))) + "bla" + (let () + (push-input (open-input-string "bla")) + (let ((ch (read-char))) + (unread-char ch)) + (let ((x (read-string))) + (let ((pop (pop-input))) + x)))) + +(pass-if-equal "input-stack/1" + "hello world!" + (with-output-to-string + (lambda () + (with-input-from-string "hello X!" + (lambda () + (let iter ((ch (read-char))) + (unless (eq? ch #\X) (write-char ch) (iter (read-char)))) + (push-input (open-input-string "world")) + (let iter ((ch (read-char))) + (unless (eof-object? ch) (write-char ch) (iter (read-char)))) + (pop-input) + (let iter ((ch (read-char))) + (unless (eof-object? ch) (write-char ch) (iter (read-char)))) + ))))) + +(pass-if "input-stack/2" + (let ((sp (open-input-string "abc"))) + (push-input sp) + (and (pop-input) (not (pop-input))))) (result 'report)