artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

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

Browse source 
* module/mes/guile.mes (open-input-string, read-string): New functions.
* tests/guile.test: New file.
* GNUmakefile (TESTS): Add it.
This commit is contained in:
Jan Nieuwenhuizen 2017-04-01 12:51:35 +02:00
parent fc263de433
commit d938b38d5e
6 changed files with 149 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
GNUmakefile
View file

@ -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\

51
module/mes/guile.mes
View file

@ -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))))

6
module/mes/libc.mes
View file

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

BIN
module/mes/read-0-32.mo
View file

Binary file not shown.

16
module/mes/read-0.mes
View file

@ -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)))
(#t (read-string (read-byte) (peek-byte) (append-char s c)))))
(list->string (read-string (read-byte) (peek-byte) (list))))
((eq? c -1) (error (quote EOF-in-string) (cons c s)))
(#t (reader:read-string (read-byte) (peek-byte) (append-char s c)))))
(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)))

86
tests/guile.test Executable file
View file

@ -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)