andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

DRAFT mes: (mes guile): Switch to Guile modules. 

* mes/module/mes/boot-0.scm (mes): Use (mes display), (mes simple-format).
* mes/module/mes/boot-5.mes (mes): Likewise.
* mes/module/mes/guile.mes: Do not use (mes catch), (mes
posix), (srfi-srfi-16), (mes display), (mes simple-format).
(with-input-from-string,
with-input-from-file, with-output-to-file, with-error-to-file,
with-output-to-port, with-error-to-file, open-input-file, dirname,
file-exists?, set-port-encoding!): Move to...
* mes/module/mes/guile.scm: ...this new file.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2021-05-16 13:02:46 +02:00
parent bc1a687703
commit 05424975ee
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
4 changed files with 113 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
mes/module/mes/boot-0.scm
View File

@ -175,6 +175,8 @@
(mes-use-module (mes fluids))
(mes-use-module (mes catch))
(mes-use-module (mes posix))
(mes-use-module (mes display))
(mes-use-module (mes simple-format))
(mes-use-module (mes guile))
;; end boot-04.scm

2
mes/module/mes/boot-5.mes
View File

@ -173,6 +173,8 @@
(mes-use-module (mes fluids))
(mes-use-module (mes catch))
(mes-use-module (mes posix))
(mes-use-module (mes display))
(mes-use-module (mes simple-format))
(mes-use-module (mes guile))
;; end boot-04.scm

81
mes/module/mes/guile.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2019,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -22,8 +22,6 @@
;;; Code:
(define-module (mes guile))
(define-macro (cond-expand-provide . rest) #t)
(define-macro (include-from-path file)
@ -56,88 +54,11 @@
(define (effective-version) %version)
(mes-use-module (mes catch))
(mes-use-module (mes posix))
(mes-use-module (srfi srfi-16))
(mes-use-module (mes display))
(mes-use-module (mes simple-format))
(define %load-path (or (and=> (getenv "GUILE_LOAD_PATH") (lambda (x) (string-split x #\:))) '()))
(define (drain-input port) (read-string))
(define (object->string x . rest)
(with-output-to-string
(lambda () ((if (pair? rest) (car rest) write) x))))
(define (port-filename p) "<stdin>")
(define (port-line p) 0)
(define (with-input-from-string string thunk)
(let ((prev (set-current-input-port (open-input-string string)))
(r (thunk)))
(set-current-input-port prev)
r))
(define (with-input-from-file file thunk)
(let ((port (open-input-file file)))
(if (= port -1)
(error 'no-such-file file)
(let* ((save (current-input-port))
(foo (set-current-input-port port))
(r (thunk)))
(set-current-input-port save)
r))))
(define (with-output-to-file file thunk)
(let ((port (open-output-file file)))
(if (= port -1)
(error 'cannot-open file)
(let* ((save (current-output-port))
(foo (set-current-output-port port))
(r (thunk)))
(set-current-output-port save)
r))))
(define (with-error-to-file file thunk)
(let ((port (open-output-file file)))
(if (= port -1)
(error 'cannot-open file)
(let* ((save (current-error-port))
(foo (set-current-error-port port))
(r (thunk)))
(set-current-error-port save)
r))))
(define (with-output-to-port port thunk)
(let* ((save (current-output-port))
(foo (set-current-output-port port))
(r (thunk)))
(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))
(debug (and=> (getenv "MES_DEBUG") string->number)))
(when (and debug (> debug 1))
(core:display-error (string-append "open-input-file: `" file "'"))
(when (> debug 3)
(core:display-error " port=")
(core:display-error port))
(core:display-error "\n"))
port))
(define (dirname file-name)
(let* ((lst (string-split file-name #\/))
(lst (filter (negate string-null?) lst)))
(if (null? lst) (if (string-prefix? "/" file-name) "/" ".")
(let ((dir (string-join (list-head lst (1- (length lst))) "/")))
(if (string-prefix? "/" file-name) (string-append "/" dir)
(if (string-null? dir) "."
dir))))))
(define (file-exists? o)
(access? o R_OK))
(define (set-port-encoding! port encoding) #t)

108
mes/module/mes/guile.scm Normal file
View File

@ -0,0 +1,108 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (mes guile)
#:use-module (srfi srfi-16)
#:export (drain-input
with-input-from-string
with-input-from-file
with-output-to-file
with-error-to-file
with-output-to-port
core:open-input-file
open-input-file
dirname
file-exists?
set-port-encoding!))
(define (drain-input port) (read-string))
(define (with-input-from-string string thunk)
(let ((prev (set-current-input-port (open-input-string string)))
(r (thunk)))
(set-current-input-port prev)
r))
(define (with-input-from-file file thunk)
(let ((port (open-input-file file)))
(if (= port -1)
(error 'no-such-file file)
(let* ((save (current-input-port))
(foo (set-current-input-port port))
(r (thunk)))
(set-current-input-port save)
r))))
(define (with-output-to-file file thunk)
(let ((port (open-output-file file)))
(if (= port -1)
(error 'cannot-open file)
(let* ((save (current-output-port))
(foo (set-current-output-port port))
(r (thunk)))
(set-current-output-port save)
r))))
(define (with-error-to-file file thunk)
(let ((port (open-output-file file)))
(if (= port -1)
(error 'cannot-open file)
(let* ((save (current-error-port))
(foo (set-current-error-port port))
(r (thunk)))
(set-current-error-port save)
r))))
(define (with-output-to-port port thunk)
(let* ((save (current-output-port))
(foo (set-current-output-port port))
(r (thunk)))
(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))
(debug (and=> (getenv "MES_DEBUG") string->number)))
(when (and debug (> debug 1))
(core:display-error (string-append "open-input-file: `" file "'"))
(when (> debug 3)
(core:display-error " port=")
(core:display-error port))
(core:display-error "\n"))
port))
(define (dirname file-name)
(let* ((lst (string-split file-name #\/))
(lst (filter (negate string-null?) lst)))
(if (null? lst) (if (string-prefix? "/" file-name) "/" ".")
(let ((dir (string-join (list-head lst (1- (length lst))) "/")))
(if (string-prefix? "/" file-name) (string-append "/" dir)
(if (string-null? dir) "."
dir))))))
(define (file-exists? o)
(access? o R_OK))
(define (set-port-encoding! port encoding) #t)