mes: dirname: Fix for absolute file names.

[mes.git] / mes / module / mes / guile.mes

diff --git a/mes/module/mes/guile.mes b/mes/module/mes/guile.mes
index b59135b394ecebabfe5095bc88b598b4e1858f2c..76c3f781887b16990def49e4b51617ba6bbe802b 100644 (file)
--- a/mes/module/mes/guile.mes
+++ b/mes/module/mes/guile.mes
@@ -1,22 +1,22 @@
 ;;; -*-scheme-*-
 
-;;; Mes --- Maxwell Equations of Software
+;;; GNU Mes --- Maxwell Equations of Software
 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
-;;; This file is part of Mes.
+;;; This file is part of GNU Mes.
 ;;;
-;;; Mes is free software; you can redistribute it and/or modify it
+;;; 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.
 ;;;
-;;; Mes is distributed in the hope that it will be useful, but
+;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
+;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -31,16 +31,6 @@
 (mes-use-module (srfi srfi-16))
 (mes-use-module (mes display))
 
-(if #t ;;(not (defined? 'read-string))
-    (define (read-string)
-      (define (read-string c)
-        (if (eq? c #\*eof*) '()
-            (cons c (read-string (read-char)))))
-      (let ((string (list->string (read-string (read-char)))))
-        (if (and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 3)) string->number))
-            (core:display-error (string-append "drained: `" string "'\n")))
-        string)))
-
 (define (drain-input port) (read-string))
 
 (define (make-string n . fill)
@@ -79,6 +69,16 @@
           (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))
@@ -99,9 +99,13 @@
     port))
 
 (define (dirname file-name)
-  (let ((lst (filter (negate string-null?) (string-split file-name #\/))))
-    (if (<= (length lst) 1) "."
-        (string-join (list-head lst (1- (length lst))) "/"))))
+  (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))))))
 
 ;; FIXME: c&p from display
 (define (with-output-to-string thunk)
@@ -137,4 +141,8 @@
     (if destination (simple-format lst rest)
         (with-output-to-string
           (lambda () (simple-format lst rest))))))
+
 (define format simple-format)
+
+(define (file-exists? o)
+  (access? o R_OK))