mes: Bugfix for search-path. Fixes running MesCC on Guile.
[mes.git] / mes / module / mes / posix.mes
1 ;;; -*-scheme-*-
2
3 ;;; GNU Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 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 R_OK 0)
28 (define S_IRWXU #o700)
29
30 (define (basename file-name . ext)
31   (let ((base (last (string-split file-name #\/)))
32         (ext (and (pair? ext) (car ext))))
33     (if (and ext
34              (string-suffix? ext base)) (string-drop-right base (string-length ext))
35              base)))
36
37 (define (force-output . port)
38   *unspecified*)
39
40 (define (search-path path file-name)
41   (let loop ((path path))
42     (and (pair? path)
43          (let ((f (string-append (car path) "/" file-name)))
44            (if (access? f R_OK) f
45                (loop (cdr path)))))))
46
47 (define (execlp file-name args)
48   (let ((executable (if (string-index file-name #\/) file-name
49                         (search-path (string-split (getenv "PATH") #\:) file-name))))
50     (execl executable args)))
51
52 (define (system* file-name . args)
53   (let ((pid (primitive-fork)))
54     (cond ((zero? pid)
55            (let ((out (current-output-port))
56                  (err (current-error-port)))
57              (when (and (> out 0)
58                         (not (= out 1)))
59                (dup2 out 1))
60              (when (and (> err 0)
61                         (not (= err 2)))
62                (dup2 err 2))
63              (exit (apply execlp file-name (list args)))))
64           ((= -1 pid) (error "fork failed:" file-name))
65           (else (let ((pid+status (waitpid 0)))
66                   (cdr pid+status))))))
67
68 (define (waitpid pid . options)
69   (let ((options (if (null? options) 0 (car options))))
70     (core:waitpid pid options)))
71
72 (define (status:exit-val status)
73   (ash status -8))