src/os.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          os.lisp
   6 ;;;; Purpose:       Operating system interface for UFFI
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg.
  13 ;;;;
  14 ;;;; *************************************************************************
  15
  16 (in-package #:uffi)
  17
  18 ;; modified from function ASDF -- Copyright Dan Barlow and Contributors
  19
  20 (defun run-shell-command (control-string  &rest args &key output)
  21   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
  22 synchronously execute the result using a Bourne-compatible shell, with
  23 output to *trace-output*.  Returns the shell's exit code."
  24   (unless output
  25     (setq output *trace-output*))
  26
  27   (let ((command (apply #'format nil control-string args)))
  28     #+sbcl
  29     (sb-impl::process-exit-code
  30      (sb-ext:run-program
  31       "/bin/sh"
  32       (list "-c" command)
  33       :input nil :output output))
  34
  35     #+(or cmu scl)
  36     (ext:process-exit-code
  37      (ext:run-program
  38       "/bin/sh"
  39       (list "-c" command)
  40       :input nil :output output))
  41
  42     #+allegro
  43     (excl:run-shell-command command :input nil :output output)
  44
  45     #+lispworks
  46     (system:call-system-showing-output
  47      command
  48      :shell-type "/bin/sh"
  49      :output-stream output)
  50
  51     #+clisp                             ;XXX not exactly *trace-output*, I know
  52     (ext:run-shell-command  command :output :terminal :wait t)
  53
  54     #+openmcl
  55     (nth-value 1
  56                (ccl:external-process-status
  57                 (ccl:run-program "/bin/sh" (list "-c" command)
  58                                  :input nil :output output
  59                                  :wait t)))
  60
  61     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
  62     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
  63     ))