core: Support fork, waitpid, execve.
[mes.git] / module / mes / posix.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; 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 ;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 (define R_OK 0)
26 (define S_IRWXU #o700)
27
28 (define (basename file-name . ext)
29   (let ((base (last (string-split file-name #\/)))
30         (ext (and (pair? ext) (car ext))))
31     (if (and ext
32              (string-suffix? ext base)) (string-drop-right base (string-length ext))
33              base)))
34
35 (define (search-path path file-name)
36   (if (access? file-name R_OK) file-name
37       (let loop ((path path))
38         (and (pair? path)
39              (let ((f (string-append (car path) "/" file-name)))
40                (if (access? f R_OK) f
41                    (loop (cdr path))))))))
42
43 (define (execlp file-name args)
44   (let ((executable (if (string-index file-name #\/) file-name
45                         (search-path (string-split (getenv "PATH") #\:) file-name))))
46     (execl executable args)))
47
48 (define (system* file-name . args)
49   (let ((pid (primitive-fork)))
50     (cond ((zero? pid) (apply execlp file-name (list args)))
51           ((= -1 pid) (error "fork failed:" file-name))
52           (else (let ((pid+status (waitpid 0)))
53                   (cdr pid+status))))))
54
55 (define (waitpid pid . options)
56   (let ((options (if (null? options) 0 (car options))))
57     (core:waitpid pid options)))