impl.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          impl.lisp
   6 ;;;; Purpose:       Implementation Dependent routines for kmrcl
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21 (defun canonicalize-directory-name (filename)
  22   (flet ((un-unspecific (value)
  23            (if (eq value :unspecific) nil value)))
  24     (let* ((path (pathname filename))
  25            (name (un-unspecific (pathname-name path)))
  26            (type (un-unspecific (pathname-type path)))
  27            (new-dir
  28             (cond ((and name type) (list (concatenate 'string name "." type)))
  29                   (name (list name))
  30                   (type (list type))
  31                   (t nil))))
  32       (if new-dir
  33           (make-pathname
  34            :directory (append (un-unspecific (pathname-directory path))
  35                               new-dir)
  36                     :name nil :type nil :version nil :defaults path)
  37           path))))
  38
  39
  40 (defun probe-directory (filename)
  41   (let ((path (canonicalize-directory-name filename)))
  42     #+allegro (excl:probe-directory path)
  43     #+clisp (values
  44              (ignore-errors
  45                (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
  46                           path)))
  47     #+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
  48     #+lispworks (lw:file-directory-p path)
  49     #+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
  50     #-(or allegro clisp cmu lispworks sbcl scl)
  51     (probe-file path)))
  52
  53
  54 (defun cwd (&optional dir)
  55   "Change directory and set default pathname"
  56   (cond
  57    ((not (null dir))
  58     (when (and (typep dir 'logical-pathname)
  59                (translate-logical-pathname dir))
  60       (setq dir (translate-logical-pathname dir)))
  61     (when (stringp dir)
  62       (setq dir (parse-namestring dir)))
  63     #+allegro (excl:chdir dir)
  64     #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
  65     #+(or cmu scl) (setf (ext:default-directory) dir)
  66     #+cormanlisp (ccl:set-current-directory dir)
  67     #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
  68     #+openmcl (ccl:cwd dir)
  69     #+gcl (si:chdir dir)
  70     #+lispworks (hcl:change-directory dir)
  71     (setq cl:*default-pathname-defaults* dir))
  72    (t
  73     (let ((dir
  74            #+allegro (excl:current-directory)
  75            #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
  76            #+(or cmu scl) (ext:default-directory)
  77            #+sbcl (sb-unix:posix-getcwd/)
  78            #+cormanlisp (ccl:get-current-directory)
  79            #+lispworks (hcl:get-working-directory)
  80            #+mcl (ccl:mac-default-directory)
  81            #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
  82       (when (stringp dir)
  83         (setq dir (parse-namestring dir)))
  84       dir))))
  85
  86
  87
  88 (defun quit (&optional (code 0))
  89   "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
  90     #+allegro (excl:exit code :quiet t)
  91     #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
  92     #+(or cmu scl) (ext:quit code)
  93     #+cormanlisp (win32:exitprocess code)
  94     #+gcl (lisp:bye code)
  95     #+lispworks (lw:quit :status code)
  96     #+lucid (lcl:quit code)
  97     #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
  98     #+mcl (ccl:quit code)
  99     #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
 100     (error 'not-implemented :proc (list 'quit code)))
 101
 102
 103 (defun command-line-arguments ()
 104   #+allegro (system:command-line-arguments)
 105   #+sbcl sb-ext:*posix-argv*
 106   )
 107
 108 (defun shell-command-output (cmd &key directory whole)
 109   #+allegro (excl.osi:command-output cmd :directory directory :whole whole)
 110   #+sbcl
 111   (let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0
 112                           :adjustable t))
 113          (err (make-array '(0) :element-type 'base-char :fill-pointer 0
 114                           :adjustable t))
 115         (status
 116          (sb-impl::process-exit-code
 117           (with-output-to-string (out-stream out)
 118             (with-output-to-string (err-stream err)
 119               (sb-ext:run-program
 120                "/bin/sh"
 121                (list  "-c" cmd)
 122                :input nil :output out-stream :error err-stream))))))
 123     (values out err status))
 124   )