mes: Remove copy of make-string.
[mes.git] / mes / module / mes / guile.mes
1 ;;; -*-scheme-*-
2
3 ;;; GNU Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of GNU Mes.
7 ;;;
8 ;;; GNU Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; GNU Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 (mes-use-module (srfi srfi-13))
26
27 (define-macro (cond-expand-provide . rest) #t)
28
29 (mes-use-module (mes catch))
30 (mes-use-module (mes posix))
31 (mes-use-module (srfi srfi-16))
32 (mes-use-module (mes display))
33
34 (define (drain-input port) (read-string))
35
36 (define (read-line . rest)
37   (let* ((port (if (pair? rest) (car rest) (current-input-port)))
38          (handle-delim (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 'trim))
39          (c (read-char port)))
40     (if (eof-object? c) c
41         (list->string
42          (let loop ((c c))
43            (if (or (eof-object? c) (eq? c #\newline)) (case handle-delim
44                                                         ((trim) '())
45                                                         ((concat) '(#\newline))
46                                                         (else (error (format #f "not supported: handle-delim=~a" handle-delim))))
47                (cons c (loop (read-char port)))))))))
48
49 (define (object->string x . rest)
50   (with-output-to-string
51     (lambda () ((if (pair? rest) (car rest) write) x))))
52
53 (define (port-filename p) "<stdin>")
54 (define (port-line p) 0)
55
56 (define (with-input-from-string string thunk)
57   (let ((prev (set-current-input-port (open-input-string string)))
58         (r (thunk)))
59     (set-current-input-port prev)
60     r))
61
62 (define (with-input-from-file file thunk)
63   (let ((port (open-input-file file)))
64     (if (= port -1)
65         (error 'no-such-file file)
66         (let* ((save (current-input-port))
67                (foo (set-current-input-port port))
68                (r (thunk)))
69           (set-current-input-port save)
70           r))))
71
72 (define (with-output-to-file file thunk)
73   (let ((port (open-output-file file)))
74     (if (= port -1)
75         (error 'cannot-open file)
76         (let* ((save (current-output-port))
77                (foo (set-current-output-port port))
78                (r (thunk)))
79           (set-current-output-port save)
80           r))))
81
82 (define (with-error-to-file file thunk)
83   (let ((port (open-output-file file)))
84     (if (= port -1)
85         (error 'cannot-open file)
86         (let* ((save (current-error-port))
87                (foo (set-current-error-port port))
88                (r (thunk)))
89           (set-current-error-port save)
90           r))))
91
92 (define (with-output-to-port port thunk)
93   (let* ((save (current-output-port))
94          (foo (set-current-output-port port))
95          (r (thunk)))
96     (set-current-output-port save)
97     r))
98
99 (define core:open-input-file open-input-file)
100 (define (open-input-file file)
101   (let ((port (core:open-input-file file))
102         (debug (and=> (getenv "MES_DEBUG") string->number)))
103     (when (and debug (> debug 1))
104       (core:display-error (string-append "open-input-file: `" file "'"))
105       (when (> debug 3)
106         (core:display-error " port=")
107         (core:display-error port)))
108     (core:display-error "\n")
109     port))
110
111 (define (dirname file-name)
112   (let* ((lst (string-split file-name #\/))
113          (lst (filter (negate string-null?) lst)))
114     (if (null? lst) (if (string-prefix? "/" file-name) "/" ".")
115         (let ((dir (string-join (list-head lst (1- (length lst))) "/")))
116           (if (string-prefix? "/" file-name) (string-append "/" dir)
117               (if (string-null? dir) "."
118                   dir))))))
119
120 ;; FIXME: c&p from display
121 (define (with-output-to-string thunk)
122   (define save-write-byte write-byte)
123   (let ((stdout '()))
124     (set! write-byte
125           (lambda (x . rest)
126             (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
127               (if (not out?) (apply save-write-byte (cons x rest))
128                   (begin
129                     (set! stdout (append stdout (list (integer->char x))))
130                     x)))))
131     (thunk)
132     (let ((r (apply string stdout)))
133       (set! write-byte save-write-byte)
134       r)))
135
136 ;; FIXME: c&p from display
137 (define (simple-format destination format . rest)
138   (let ((port (if (boolean? destination) (current-output-port) destination))
139         (lst (string->list format)))
140     (define (simple-format lst args)
141       (if (pair? lst)
142           (let ((c (car lst)))
143             (if (not (eq? c #\~)) (begin (write-char (car lst) port)
144                                          (simple-format (cdr lst) args))
145                 (let ((c (cadr lst)))
146                   (case c
147                     ((#\a) (display (car args) port))
148                     ((#\s) (write (car args) port)))
149                   (simple-format (cddr lst) (cdr args)))))))
150
151     (if destination (simple-format lst rest)
152         (with-output-to-string
153           (lambda () (simple-format lst rest))))))
154
155 (define format simple-format)
156
157 (define (file-exists? o)
158   (access? o R_OK))