scm: Add open-input-string, read-string.

* module/mes/guile.mes (open-input-string, read-string): New functions.
* tests/guile.test: New file.
* GNUmakefile (TESTS): Add it.

GNUmakefile

@@ -74,6 +74,7 @@ TESTS:=\
  tests/psyntax.test\
  tests/pmatch.test\
  tests/let-syntax.test\
+ tests/guile.test\
  tests/record.test\
  tests/match.test\
  tests/peg.test\

module/mes/guile.mes

@@ -73,3 +73,54 @@
                (r (thunk)))
           (set-current-input-port save)
           r))))
+
+(define open-input-string
+  (let ((save-set-current-input-port #f)
+        (string-port #f))
+    (lambda (string)
+      (set! save-set-current-input-port set-current-input-port)
+      (set! string-port (cons '*string-port* (gensym)))
+      (set! set-current-input-port
+            (let ((save-peek-char peek-char)
+                  (save-read-char read-char)
+                  (save-unread-char unread-char)
+                  (tell 0)
+                  (end (string-length string)))
+              (lambda (port)
+                (if (not (equal? port string-port)) (save-set-current-input-port port)
+                    (begin
+                      (set! peek-char
+                            (lambda () (if (= tell end) (integer->char -1)
+                                           (string-ref string (- tell 1)))))
+                      (set! read-char
+                            (lambda () (if (= tell end) (integer->char -1)
+                                           (begin
+                                             (set! tell (1+ tell))
+                                             (string-ref string (- tell 1))))))
+                      (set! unread-char
+                            (lambda (c) (set! tell (1- tell)) c))
+                      (set! set-current-input-port
+                            (lambda (port)
+                              (save-set-current-input-port port)
+                              (set! peek-char save-peek-char)
+                              (set! read-char save-read-char)
+                              (set! unread-char save-unread-char)
+                              (set! set-current-input-port save-set-current-input-port)
+                              string-port)))))))
+      string-port)))
+
+(define (read-string)
+  (define (append-char s c)
+    (append2 s (cons c (list))))
+  (define (read-string c p s)
+    (cond
+     ((and (eq? c #\\) (or (eq? p #\\) (eq? p #\")))
+      ((lambda (c)
+         (read-string (read-char) (peek-char) (append-char s c)))
+       (read-char)))
+     ((and (eq? c #\\) (eq? p #\n))
+      (read-char)
+      (read-string (read-char) (peek-char) (append-char s 10)))
+     ((eq? c #\*eof*) s)
+     (#t (read-string (read-char) (peek-char) (append-char s c)))))
+  (list->string (read-string (read-char) (peek-char) (list))))

module/mes/libc.mes

@@ -319,7 +319,7 @@ realloc (int *p, int size)
    puts
    strcmp
    itoa
-   ;; isdigit
+   isdigit
-   ;; malloc
+   malloc
-   ;; realloc
+   realloc
    ))

module/mes/read-0.mes

@@ -248,22 +248,22 @@
            (read-hex c p 1 0)))
      (read-byte) (peek-byte)))
 
-  (define (read-string)
+  (define (reader:read-string)
     (define (append-char s c)
       (append2 s (cons (integer->char c) (list))))
-    (define (read-string c p s)
+    (define (reader:read-string c p s)
       (cond
        ((and (eq? c 92) (or (eq? p 92) (eq? p 34)))
         ((lambda (c)
-           (read-string (read-byte) (peek-byte) (append-char s c)))
+           (reader:read-string (read-byte) (peek-byte) (append-char s c)))
          (read-byte)))
        ((and (eq? c 92) (eq? p 110))
         (read-byte)
-        (read-string (read-byte) (peek-byte) (append-char s 10)))
+        (reader:read-string (read-byte) (peek-byte) (append-char s 10)))
        ((eq? c 34) s)
-       ((eq? c -1) (error (quote EOF-in-string)))
+       ((eq? c -1) (error (quote EOF-in-string) (cons c s)))
-       (#t (read-string (read-byte) (peek-byte) (append-char s c)))))
+       (#t (reader:read-string (read-byte) (peek-byte) (append-char s c)))))
-    (list->string (read-string (read-byte) (peek-byte) (list))))
+    (list->string (reader:read-string (read-byte) (peek-byte) (list))))
 
   (define (map1 f lst)
     (if (null? lst) (list)
@@ -316,7 +316,7 @@
                      (begin (unread-byte c) (lookup w a))))
      ((eq? c 41) (if (null? w) (quote *FOOBAR*)
                      (begin (unread-byte c) (lookup w a))))
-     ((eq? c 34) (if (null? w) (read-string)
+     ((eq? c 34) (if (null? w) (reader:read-string)
                      (begin (unread-byte c) (lookup w a))))
      ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
      ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))

tests/guile.test

@@ -0,0 +1,86 @@
+#! /bin/sh
+# -*-scheme-*-
+MES=${MES-$(dirname $0)/../scripts/mes}
+echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $MES $MES_FLAGS "$@"
+#paredit:||
+exit $?
+!#
+
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;(if guile? (exit 0))
+
+(cond-expand
+ ;;(guile-2)
+ (guile
+  (use-modules (ice-9 rdelim)))
+ (mes
+  (mes-use-module (mes test))
+  (mes-use-module (mes guile))))
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if-equal "read-string" "bla"
+               (with-input-from-string "bla"
+                 (lambda () (read-string))))
+
+(pass-if-equal "open-input-string" "bla"
+               (let* ((port (current-input-port))
+                      (foo (open-input-string "bla")))
+                 (set-current-input-port foo)
+                 (let ((s (read-string)))
+                   (set-current-input-port port)
+                   s)))
+
+;; NYACC
+;; === input stack =====================
+
+(define *input-stack* (make-fluid '()))
+
+(define (reset-input-stack)
+  (fluid-set! *input-stack* '()))
+
+(define (push-input port)
+  (let ((curr (current-input-port))
+	(ipstk (fluid-ref *input-stack*)))
+    (fluid-set! *input-stack* (cons curr ipstk))
+    (set-current-input-port port)))
+
+;; 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))))
+
+(result 'report)